C++ Interface to Tauola
pythia-6.4.20.f
1 C*********************************************************************
2 C*********************************************************************
3 C* **
4 C* February 2009 **
5 C* **
6 C* The Lund Monte Carlo **
7 C* **
8 C* PYTHIA version 6.4 **
9 C* **
10 C* Torbjorn Sjostrand **
11 C* Department of Theoretical Physics **
12 C* Lund University **
13 C* Solvegatan 14A, S-223 62 Lund, Sweden **
14 C* E-mail torbjorn@thep.lu.se **
15 C* **
16 C* SUSY and Technicolor parts by **
17 C* Stephen Mrenna **
18 C* Computing Division **
19 C* Generators and Detector Simulation Group **
20 C* Fermi National Accelerator Laboratory **
21 C* MS 234, Batavia, IL 60510, USA **
22 C* phone + 1 - 630 - 840 - 2556 **
23 C* E-mail mrenna@fnal.gov **
24 C* **
25 C* New multiple interactions and more SUSY parts by **
26 C* Peter Skands **
27 C* Theoretical Physics Department **
28 C* Fermi National Accelerator Laboratory **
29 C* MS 106, Batavia, IL 60510, USA **
30 C* and **
31 C* CERN/PH, CH-1211 Geneva, Switzerland **
32 C* phone +41 - 22 - 767 24 59 **
33 C* E-mail skands@fnal.gov **
34 C* **
35 C* Several parts are written by Hans-Uno Bengtsson **
36 C* PYSHOW is written together with Mats Bengtsson **
37 C* PYMAEL is written by Emanuel Norrbin **
38 C* advanced popcorn baryon production written by Patrik Eden **
39 C* code for virtual photons mainly written by Christer Friberg **
40 C* code for low-mass strings mainly written by Emanuel Norrbin **
41 C* Bose-Einstein code mainly written by Leif Lonnblad **
42 C* CTEQ parton distributions are by the CTEQ collaboration **
43 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
44 C* SaS photon parton distributions together with Gerhard Schuler **
45 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
46 C* MSSM Higgs mass calculation code by M. Carena, **
47 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
48 C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
49 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
50 C* NRQCD/colour octet production of onium by S. Wolf **
51 C* **
52 C* The latest program version and documentation is found on WWW **
53 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
54 C* **
55 C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2008 **
56 C* **
57 C*********************************************************************
58 C*********************************************************************
59 C *
60 C List of subprograms in order of appearance, with main purpose *
61 C (S = subroutine, F = function, B = block data) *
62 C *
63 C B PYDATA to contain all default values *
64 C S PYCKBD to check that BLOCK DATA has been correctly loaded *
65 C S PYTEST to test the proper functioning of the package *
66 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
67 C *
68 C S PYINIT to administer the initialization procedure *
69 C S PYEVNT to administer the generation of an event *
70 C S PYEVNW ditto, for new multiple interactions scenario *
71 C S PYSTAT to print cross-section and other information *
72 C S PYUPEV to administer the generation of an LHA hard process *
73 C S PYUPIN to provide initialization needed for LHA input *
74 C S PYLHEF to produce a Les Houches Event File from run *
75 C S PYINRE to initialize treatment of resonances *
76 C S PYINBM to read in beam, target and frame choices *
77 C S PYINKI to initialize kinematics of incoming particles *
78 C S PYINPR to set up the selection of included processes *
79 C S PYXTOT to give total, elastic and diffractive cross-sect. *
80 C S PYMAXI to find differential cross-section maxima *
81 C S PYPILE to select multiplicity of pileup events *
82 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
83 C S PYGAGA to handle lepton -> lepton + gamma branchings *
84 C S PYRAND to select subprocess and kinematics for event *
85 C S PYSCAT to set up kinematics and colour flow of event *
86 C S PYEVOL handler for pT-ordered ISR and multiple interactions *
87 C S PYSSPA to simulate initial state spacelike showers *
88 C S PYPTIS to do pT-ordered initial state spacelike showers *
89 C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
90 C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
91 C S PYPTMI to do pT-ordered multiple interactions *
92 C F PYFCMP to give companion quark x*f distribution *
93 C F PYPCMP to calculate momentum integral for companion quarks *
94 C S PYUPRE to rearranges contents of the HEPEUP commonblock *
95 C S PYADSH to administrate sequential final-state showers *
96 C S PYVETO to allow the generation of an event to be aborted *
97 C S PYRESD to perform resonance decays *
98 C S PYMULT to generate multiple interactions - old scheme *
99 C S PYREMN to add on target remnants - old scheme *
100 C S PYMIGN to generate multiple interactions - new scheme *
101 C S PYMIHK to connect colours in mult. int. - new scheme *
102 C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
103 C S PYMIHG to collapse two pairs of LHA1 colour tags. *
104 C S PYMIRM to add on target remnants in mult. int.- new scheme *
105 C S PYFSCR to perform final state colour reconnections - -"- *
106 C S PYDIFF to set up kinematics for diffractive events *
107 C S PYDISG to set up kinematics, remnant and showers for DIS *
108 C S PYDOCU to compute cross-sections and handle documentation *
109 C S PYFRAM to perform boosts between different frames *
110 C S PYWIDT to calculate full and partial widths of resonances *
111 C S PYOFSH to calculate partial width into off-shell channels *
112 C S PYRECO to handle colour reconnection in W+W- events *
113 C S PYKLIM to calculate borders of allowed kinematical region *
114 C S PYKMAP to construct value of kinematical variable *
115 C S PYSIGH to calculate differential cross-sections *
116 C S PYSGQC auxiliary to PYSIGH for QCD processes *
117 C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
118 C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
119 C S PYSGHG auxiliary to PYSIGH for Higgs processes *
120 C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
121 C S PYSGTC auxiliary to PYSIGH for technicolor processes *
122 C S PYSGEX auxiliary to PYSIGH for various exotic processes *
123 C S PYPDFU to evaluate parton distributions *
124 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
125 C S PYPDEL to evaluate electron parton distributions *
126 C S PYPDGA to evaluate photon parton distributions (generic) *
127 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
128 C S PYGVMD to evaluate VMD part of photon parton distributions *
129 C S PYGANO to evaluate anomalous part of photon PDFs *
130 C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
131 C S PYGDIR to evaluate direct contribution to photon PDFs *
132 C S PYPDPI to evaluate pion parton distributions *
133 C S PYPDPR to evaluate proton parton distributions *
134 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
135 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
136 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
137 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
138 C F PYGRVV auxiliary to the PYGRV* routines *
139 C F PYGRVW auxiliary to the PYGRV* routines *
140 C F PYGRVS auxiliary to the PYGRV* routines *
141 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
142 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
143 C S PYPDPO to evaluate old proton parton distributions *
144 C F PYHFTH to evaluate threshold factor for heavy flavour *
145 C S PYSPLI to find flavours left in hadron when one removed *
146 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
147 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
148 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
149 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
150 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
151 C S PYSTBH to evaluate matrix element for t + b + H processes *
152 C S PYTBHB auxiliary to PYSTBH *
153 C S PYTBHG auxiliary to PYSTBH *
154 C S PYTBHQ auxiliary to PYSTBH *
155 C F PYTBHS auxiliary to PYSTBH *
156 C *
157 C S PYMSIN to initialize the supersymmetry simulation *
158 C S PYSLHA to interface to SUSY spectrum and decay calculators *
159 C S PYAPPS to determine MSSM parameters from SUGRA input *
160 C S PYSUGI to determine MSSM parameters using ISASUSY *
161 C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
162 C F PYRNMQ to determine running squark masses *
163 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
164 C S PYINOM to calculate neutralino/chargino mass eigenstates *
165 C F PYRNM3 to determine running M3, gluino mass *
166 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
167 C S PYHGGM to determine Higgs mass spectrum *
168 C S PYSUBH to determine Higgs masses in the MSSM *
169 C S PYPOLE to determine Higgs masses in the MSSM *
170 C S PYRGHM auxiliary to PYPOLE *
171 C S PYGFXX auxiliary to PYRGHM *
172 C F PYFINT auxiliary to PYPOLE *
173 C F PYFISB auxiliary to PYFINT *
174 C S PYSFDC to calculate sfermion decay partial widths *
175 C S PYGLUI to calculate gluino decay partial widths *
176 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
177 C S PYTBBC to calculate 3-body decay of gluino to chargino *
178 C S PYNJDC to calculate neutralino decay partial widths *
179 C S PYCJDC to calculate chargino decay partial widths *
180 C F PYXXZ6 auxiliary for ino 3-body decays *
181 C F PYXXGA auxiliary for ino -> ino + gamma decay *
182 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
183 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
184 C S PYHEXT to calculate non-SM Higgs decay partial widths *
185 C F PYH2XX auxiliary for H -> ino + ino decay *
186 C F PYGAUS to perform Gaussian integration *
187 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
188 C F PYSIMP to perform Simpson integration *
189 C F PYLAMF to evaluate the lambda kinematics function *
190 C S PYTBDY to perform 3-body decay of gauginos *
191 C S PYTECM to calculate techni_rho/omega masses *
192 C S PYXDIN to initialize Universal Extra Dimensions *
193 C S PYUEDC to compute UED mass radiative corrections *
194 C S PYXUED to compute UED cross sections *
195 C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
196 C F PYGRAW to compute UED partial widths to G* *
197 C F PYWDKK to compute UED differential partial widths to G* *
198 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
199 C S PYCMQR auxiliary to PYEICG *
200 C S PYCMQ2 auxiliary to PYEICG *
201 C S PYCDIV auxiliary to PYCMQR *
202 C S PYCSRT auxiliary to PYCMQR *
203 C S PYTHAG auxiliary to PYCMQR *
204 C S PYCBAL auxiliary to PYEICG *
205 C S PYCBA2 auxiliary to PYEICG *
206 C S PYCRTH auxiliary to PYEICG *
207 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
208 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
209 C S PYWIDX to calculate decay widths from within PYWIDT *
210 C S PYRVSF to calculate R-violating sfermion decay widths *
211 C S PYRVNE to calculate R-violating neutralino decay widths *
212 C S PYRVCH to calculate R-violating chargino decay widths *
213 C S PYRVGL to calculate R-violating gluino decay widths *
214 C F PYRVSB auxiliary to PYRVSF *
215 C S PYRVGW to calculate R-Violating 3-body widths *
216 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
217 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
218 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
219 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
220 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
221 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
222 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
223 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
224 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
225 C *
226 C S PY1ENT to fill one entry (= parton or particle) *
227 C S PY2ENT to fill two entries *
228 C S PY3ENT to fill three entries *
229 C S PY4ENT to fill four entries *
230 C S PY2FRM to interface to generic two-fermion generator *
231 C S PY4FRM to interface to generic four-fermion generator *
232 C S PY6FRM to interface to generic six-fermion generator *
233 C S PY4JET to generate a shower from a given 4-parton config *
234 C S PY4JTW to evaluate the weight od a shower history for above *
235 C S PY4JTS to set up the parton configuration for above *
236 C S PYJOIN to connect entries with colour flow information *
237 C S PYGIVE to fill (or query) commonblock variables *
238 C S PYONOF to allow easy control of particle decay modes *
239 C S PYTUNE to select a predefined 'tune' for min-bias and UE *
240 C S PYEXEC to administrate fragmentation and decay chain *
241 C S PYPREP to rearrange showered partons along strings *
242 C S PYSTRF to do string fragmentation of jet system *
243 C S PYJURF to find boost to string junction rest frame *
244 C S PYINDF to do independent fragmentation of one or many jets *
245 C S PYDECY to do the decay of a particle *
246 C S PYDCYK to select parton and hadron flavours in decays *
247 C S PYKFDI to select parton and hadron flavours in fragm *
248 C S PYNMES to select number of popcorn mesons *
249 C S PYKFIN to calculate falvour prod. ratios from input params. *
250 C S PYPTDI to select transverse momenta in fragm *
251 C S PYZDIS to select longitudinal scaling variable in fragm *
252 C S PYSHOW to do m-ordered timelike parton shower evolution *
253 C S PYPTFS to do pT-ordered timelike parton shower evolution *
254 C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
255 C S PYBOEI to include Bose-Einstein effects (crudely) *
256 C S PYBESQ auxiliary to PYBOEI *
257 C F PYMASS to give the mass of a particle or parton *
258 C F PYMRUN to give the running MSbar mass of a quark *
259 C S PYNAME to give the name of a particle or parton *
260 C F PYCHGE to give three times the electric charge *
261 C F PYCOMP to compress standard KF flavour code to internal KC *
262 C S PYERRM to write error messages and abort faulty run *
263 C F PYALEM to give the alpha_electromagnetic value *
264 C F PYALPS to give the alpha_strong value *
265 C F PYANGL to give the angle from known x and y components *
266 C F PYR to provide a random number generator *
267 C S PYRGET to save the state of the random number generator *
268 C S PYRSET to set the state of the random number generator *
269 C S PYROBO to rotate and/or boost an event *
270 C S PYEDIT to remove unwanted entries from record *
271 C S PYLIST to list event record or particle data *
272 C S PYLOGO to write a logo *
273 C S PYUPDA to update particle data *
274 C F PYK to provide integer-valued event information *
275 C F PYP to provide real-valued event information *
276 C S PYSPHE to perform sphericity analysis *
277 C S PYTHRU to perform thrust analysis *
278 C S PYCLUS to perform three-dimensional cluster analysis *
279 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
280 C S PYJMAS to give high and low jet mass of event *
281 C S PYFOWO to give Fox-Wolfram moments *
282 C S PYTABU to analyze events, with tabular output *
283 C *
284 C S PYEEVT to administrate the generation of an e+e- event *
285 C S PYXTEE to give the total cross-section at given CM energy *
286 C S PYRADK to generate initial state photon radiation *
287 C S PYXKFL to select flavour of primary qqbar pair *
288 C S PYXJET to select (matrix element) jet multiplicity *
289 C S PYX3JT to select kinematics of three-jet event *
290 C S PYX4JT to select kinematics of four-jet event *
291 C S PYXDIF to select angular orientation of event *
292 C S PYONIA to perform generation of onium decay to gluons *
293 C *
294 C S PYBOOK to book a histogram *
295 C S PYFILL to fill an entry in a histogram *
296 C S PYFACT to multiply histogram contents by a factor *
297 C S PYOPER to perform operations between histograms *
298 C S PYHIST to print and reset all histograms *
299 C S PYPLOT to print a single histogram *
300 C S PYNULL to reset contents of a single histogram *
301 C S PYDUMP to dump histogram contents onto a file *
302 C *
303 C S PYSTOP routine to handle Fortran STOP condition *
304 C *
305 C S PYKCUT dummy routine for user kinematical cuts *
306 C S PYEVWT dummy routine for weighting events *
307 C S UPINIT dummy routine to initialize user processes *
308 C S UPEVNT dummy routine to generate a user process event *
309 C S UPVETO dummy routine to abort event at parton level *
310 C S PDFSET dummy routine to be removed when using PDFLIB *
311 C S STRUCTM dummy routine to be removed when using PDFLIB *
312 C S STRUCTP dummy routine to be removed when using PDFLIB *
313 C S SUGRA dummy routine to be removed when linking with ISAJET *
314 C F VISAJE dummy functn. to be removed when linking with ISAJET *
315 C S SSMSSM dummy routine to be removed when linking with ISAJET *
316 C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
317 C S FHSETPARA dummy routine -"- FEYNHIGGS *
318 C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
319 C S PYTAUD dummy routine for interface to tau decay libraries *
320 C S PYTIME dummy routine for giving date and time *
321 C *
322 C*********************************************************************
323 
324 C...PYDATA
325 C...Default values for switches and parameters,
326 C...and particle, decay and process data.
327 
328  BLOCK DATA pydata
329 
330 C...Double precision and integer declarations.
331  IMPLICIT DOUBLE PRECISION(a-h, o-z)
332  IMPLICIT INTEGER(I-N)
333  INTEGER PYK,PYCHGE,PYCOMP
334 C...Commonblocks.
335  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
336  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
337  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
338  common/pydat4/chaf(500,2)
339  CHARACTER CHAF*16
340  common/pydatr/mrpy(6),rrpy(100)
341  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
342  common/pypars/mstp(200),parp(200),msti(200),pari(200)
343  common/pyint1/mint(400),vint(400)
344  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
345  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
346  common/pyint4/mwid(500),wids(500,5)
347  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
348  common/pyint6/proc(0:500)
349  CHARACTER PROC*28
350  common/pyint7/sigt(0:6,0:6,0:5)
351  common/pymssm/imss(0:99),rmss(0:99)
352  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
353  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
354  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
355  common/pytcsm/itcm(0:99),rtcm(0:99)
356  common/pypued/iued(0:99),rued(0:99)
357  common/pybins/ihist(4),indx(1000),bin(20000)
358  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
359  & au(3,3),ad(3,3),ae(3,3)
360  common/pylh3c/cpro(2),cver(2)
361  CHARACTER CPRO*12,CVER*12
362  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,/pysubs/,
363  &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,
364  &/pyint6/,/pyint7/,/pymssm/,/pyssmt/,/pymsrv/,/pytcsm/,/pypued/,
365  &/pybins/,/pylh3p/,/pylh3c/
366 
367 C...PYDAT1, containing status codes and most parameters.
368  DATA mstu/
369  & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
370  1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
371  2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
372  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373  4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
374  5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
375  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
376  7 30*0,
377  1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
378  2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
379  & 80*0/
380  DATA (paru(i),i=1,100)/
381  & 3.141592653589793d0, 6.283185307179586d0,
382  & 0.197327d0, 5.06773d0, 0.389380d0, 2.56819d0, 4*0d0,
383  1 0.001d0, 0.09d0, 0.01d0, 2d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
384  2 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
385  3 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
386  4 2.0d0, 1.0d0, 0.25d0, 2.5d0, 0.05d0,
387  4 0d0, 0d0, 0.0001d0, 0d0, 0d0,
388  5 2.5d0,1.5d0,7.0d0,1.0d0,0.5d0,2.0d0,3.2d0, 0d0, 0d0, 0d0,
389  6 40*0d0/
390  DATA (paru(i),i=101,200)/
391  & 0.00729735d0, 0.232d0, 0.007764d0, 1.0d0, 1.16639d-5,
392  & 0d0, 0d0, 0d0, 0d0, 0d0,
393  1 0.20d0, 0.25d0, 1.0d0, 4.0d0, 10d0, 0d0, 0d0, 0d0, 0d0, 0d0,
394  2 -0.693d0, -1.0d0, 0.387d0, 1.0d0, -0.08d0,
395  2 -1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,
396  3 1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
397  4 5.0d0, 1.0d0, 1.0d0, 0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0,
398  5 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
399  6 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
400  7 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
401  8 1.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
402  9 0d0, 0d0, 0d0, 0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0/
403  DATA mstj/
404  & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
405  1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
406  2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
407  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
408  4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
409  5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
410  6 40*0,
411  & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
412  1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
413  2 80*0/
414  DATA parj/
415  & 0.10d0, 0.30d0, 0.40d0, 0.05d0, 0.50d0,
416  & 0.50d0, 0.50d0, 0.6d0, 1.2d0, 0.6d0,
417  1 0.50d0,0.60d0,0.75d0, 0d0, 0d0, 0d0, 0d0, 1.0d0, 1.0d0, 0d0,
418  2 0.36d0, 1.0d0,0.01d0, 2.0d0,1.0d0,0.4d0, 0d0, 0d0, 0d0, 0d0,
419  3 0.10d0, 1.0d0, 0.8d0, 1.5d0,0d0,2.0d0,0.2d0, 0d0,0.08d0,1d0,
420  4 0.3d0, 0.58d0, 0.5d0, 0.9d0,0.5d0,1.0d0,1.0d0,1.5d0,1d0,10d0,
421  5 0.77d0, 0.77d0, 0.77d0, -0.05d0, -0.005d0,
422  5 0d0, 0d0, 0d0, 1.0d0, 0d0,
423  6 4.5d0, 0.7d0, 0d0,0.003d0, 0.5d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
424  7 10d0, 1000d0, 100d0, 1000d0, 0d0, 0.7d0,10d0, 0d0,0d0,0.5d0,
425  8 0.29d0, 1.0d0, 1.0d0, 0d0, 10d0, 10d0, 0d0, 0d0, 0d0,1d-4,
426  9 0.02d0, 1.0d0, 0.2d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
427  & 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
428  1 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
429  2 1.0d0, 0.25d0,91.187d0,2.489d0, 0.01d0,
430  2 2.0d0, 1.0d0, 0.25d0,0.002d0, 0d0,
431  3 0d0, 0d0, 0d0, 0d0, 0.01d0, 0.99d0, 0d0, 0d0, 0.2d0, 0d0,
432  4 10*0d0,
433  5 10*0d0,
434  6 10*0d0,
435  7 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, -0.693d0,
436  8 -1.0d0, 0.387d0, 1.0d0, -0.08d0, -1.0d0,
437  8 1.0d0, 1.0d0, -0.693d0, -1.0d0, 0.387d0,
438  9 1.0d0, -0.08d0, -1.0d0, 1.0d0, 1.0d0,
439  9 5*0d0/
440 
441 C...PYDAT2, with particle data and flavour treatment parameters.
442  DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
443  &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
444  &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
445  &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,3,2*1,2*0,
446  &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,3,2*-2,
447  &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,-3,2*0,
448  &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,3,0,3,
449  &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,2,-1,
450  &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
451  &7*0,3,
452 C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
453  &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
454  &3*-3,0,-3,0,-3,0,-3,
455  &3*0,3,
456  &25*0/
457  DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
458  &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
459  &-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,
460  &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
461  &83*0,12*1,9*0,2,3*0,25*0/
462  DATA (kchg(i,3),i= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
463  &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
464  &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,3*0,12*1,3*0,
465  &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,7*0,1,
466  &81*0,21*1,3*0,1,25*0/
467  DATA (kchg(i,4),i= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
468  &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
469  &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
470  &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
471  &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
472  &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
473  &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
474  &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
475  &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
476  &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
477  &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
478  &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
479  &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
480  &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
481  &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
482  &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
483  &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
484  &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
485  &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
486  &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
487  DATA (kchg(i,4),i= 291, 500)/20523,20533,20543,20553,100443,
488  &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
489  &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
490  &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
491  &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
492  &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
493  &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
494  &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
495  &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
496  &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
497  &3000115,3000215,
498  &81*0,
499 C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
500  &6100001,6100002,6100003,6100004,6100005,6100006,
501  &5100001,5100002,5100003,5100004,5100005,5100006,
502  &6100011,6100013,6100015,
503  &5100012,5100011,5100014,5100013,5100016,5100015,
504  &5100021,5100022,5100023,5100024,
505  &25*0/
506  DATA (pmas(i,1),i= 1, 217)/2*0.33d0,0.5d0,1.5d0,4.8d0,175d0,
507  &2*400d0,2*0d0,0.00051d0,0d0,0.10566d0,0d0,1.777d0,0d0,400d0,
508  &5*0d0,91.188d0,80.45d0,115d0,6*0d0,500d0,900d0,500d0,3*300d0,
509  &3*0d0,5000d0,200d0,40*0d0,1d0,2d0,5d0,16*0d0,0.13498d0,0.7685d0,
510  &1.318d0,0.49767d0,0.13957d0,0.7669d0,1.318d0,0.54745d0,0.78194d0,
511  &1.275d0,2*0.49767d0,0.8961d0,1.432d0,0.4936d0,0.8916d0,1.425d0,
512  &0.95777d0,1.0194d0,1.525d0,1.8693d0,2.01d0,2.46d0,1.8645d0,
513  &2.0067d0,2.46d0,1.9685d0,2.1124d0,2.5735d0,2.9798d0,3.09688d0,
514  &3.5562d0,5.2792d0,5.3248d0,5.83d0,5.2789d0,5.3248d0,5.83d0,
515  &5.3693d0,5.4163d0,6.07d0,6.594d0,6.602d0,7.35d0,9.4d0,9.4603d0,
516  &9.9132d0,0d0,0.77133d0,1.234d0,0.57933d0,0.77133d0,0.93957d0,
517  &1.233d0,0.77133d0,0.93827d0,1.232d0,1.231d0,0.80473d0,0.92953d0,
518  &1.19744d0,1.3872d0,1.11568d0,0.80473d0,0.92953d0,1.19255d0,
519  &1.3837d0,1.18937d0,1.3828d0,1.09361d0,1.3213d0,1.535d0,1.3149d0,
520  &1.5318d0,1.67245d0,1.96908d0,2.00808d0,2.4521d0,2.5d0,2.2849d0,
521  &2.4703d0,1.96908d0,2.00808d0,2.4535d0,2.5d0,2.4529d0,2.5d0,
522  &2.4656d0,2.15432d0,2.17967d0,2.55d0,2.63d0,2.55d0,2.63d0,2.704d0,
523  &2.8d0,3.27531d0,3.59798d0,3.65648d0,3.59798d0,3.65648d0,
524  &3.78663d0,3.82466d0,4.91594d0,5.38897d0,5.40145d0,5.8d0,5.81d0,
525  &5.641d0,5.84d0,7.00575d0,5.38897d0,5.40145d0,5.8d0,5.81d0,5.8d0/
526  DATA (pmas(i,1),i= 218, 500)/5.81d0,5.84d0,7.00575d0,5.56725d0,
527  &5.57536d0,5.96d0,5.97d0,5.96d0,5.97d0,6.12d0,6.13d0,7.19099d0,
528  &6.67143d0,6.67397d0,7.03724d0,7.0485d0,7.03724d0,7.0485d0,
529  &7.21101d0,7.219d0,8.30945d0,8.31325d0,10.07354d0,10.42272d0,
530  &10.44144d0,10.42272d0,10.44144d0,10.60209d0,10.61426d0,
531  &11.70767d0,11.71147d0,15.11061d0,0.9835d0,1.231d0,0.9835d0,
532  &1.231d0,1d0,1.17d0,1.429d0,1.29d0,1.429d0,1.29d0,2*1.4d0,2.272d0,
533  &2.424d0,2.272d0,2.424d0,2.5d0,2.536d0,3.4151d0,3.46d0,5.68d0,
534  &5.73d0,5.68d0,5.73d0,5.92d0,5.97d0,7.25d0,7.3d0,9.8598d0,9.875d0,
535  &2*1.23d0,1.282d0,2*1.402d0,1.427d0,2*2.372d0,2.56d0,3.5106d0,
536  &2*5.78d0,6.02d0,7.3d0,9.8919d0,3.686d0,10.0233d0,32*500d0,
537  &3*110d0,350d0,3*210d0,500d0,125d0,250d0,400d0,2*350d0,300d0,
538  &4*400d0,1000d0,3*500d0,1200d0,750d0,2*200d0,7*0d0,3*3.1d0,
539  &3*9.5d0,2*250d0,
540  &81*0,
541 C...UED
542  &586.,588.,586.,588.,586.,586.,6*598.,
543  &3*505.,6*516.,640.,501.,536.,536.,25*0.d0/
544  DATA (pmas(i,2),i= 1, 500)/5*0d0,1.39816d0,16*0d0,2.47813d0,
545  &2.07115d0,0.00367d0,6*0d0,14.54029d0,0d0,16.66099d0,8.38842d0,
546  &3.3752d0,4.17669d0,3*0d0,417.29147d0,0.39162d0,60*0d0,0.151d0,
547  &0.107d0,2*0d0,0.149d0,0.107d0,0d0,0.00843d0,0.185d0,2*0d0,
548  &0.0505d0,0.109d0,0d0,0.0498d0,0.098d0,0.0002d0,0.00443d0,0.076d0,
549  &2*0d0,0.023d0,2*0d0,0.023d0,2*0d0,0.015d0,0.0013d0,0d0,0.002d0,
550  &2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,5*0d0,0.12d0,
551  &3*0d0,0.12d0,2*0d0,2*0.12d0,3*0d0,0.0394d0,4*0d0,0.036d0,0d0,
552  &0.0358d0,2*0d0,0.0099d0,0d0,0.0091d0,74*0d0,0.06d0,0.142d0,
553  &0.06d0,0.142d0,0d0,0.36d0,0.287d0,0.09d0,0.287d0,0.09d0,0.25d0,
554  &0.08d0,0.05d0,0.02d0,0.05d0,0.02d0,0.05d0,0d0,0.014d0,0.01d0,
555  &8*0.05d0,0d0,0.01d0,2*0.4d0,0.025d0,2*0.174d0,0.053d0,3*0.05d0,
556  &0.0009d0,4*0.05d0,3*0d0,19*1d0,0d0,7*1d0,0d0,1d0,0d0,1d0,0d0,
557  &0.0208d0,0.01195d0,0.03705d0,0.09511d0,1.89978d0,1.60746d0,
558  &0.13396d0,200.47294d0,0.02296d0,0.18886d0,94.66794d0,6.08718d0,
559  &0d0,2.17482d0,2.59359d0,2.59687d0,0.42896d0,0.41912d0,0.14153d0,
560  &2*0.00098d0,0.00097d0,26.7245d0,21.74916d0,0.88159d0,0.88001d0,
561  &7*0d0,6*0.01d0,0.25499d0,0.28446d0,131*0d0/
562  DATA (pmas(i,3),i= 1, 500)/5*0d0,13.98156d0,16*0d0,24.78129d0,
563  &20.71149d0,0.03669d0,6*0d0,145.40294d0,0d0,166.60993d0,
564  &83.88423d0,33.75195d0,41.76694d0,3*0d0,4172.91467d0,3.91621d0,
565  &60*0d0,0.4d0,0.25d0,2*0d0,0.4d0,0.25d0,0d0,0.1d0,0.17d0,2*0d0,
566  &0.2d0,0.12d0,0d0,0.2d0,0.12d0,0.002d0,0.015d0,0.2d0,2*0d0,0.12d0,
567  &2*0d0,0.12d0,2*0d0,0.05d0,0.005d0,0d0,0.01d0,2*0d0,0.05d0,2*0d0,
568  &0.05d0,2*0d0,0.05d0,2*0d0,0.05d0,5*0d0,0.14d0,3*0d0,0.14d0,2*0d0,
569  &2*0.14d0,3*0d0,0.04d0,4*0d0,0.035d0,0d0,0.035d0,2*0d0,0.05d0,0d0,
570  &0.05d0,74*0d0,0.05d0,0.25d0,0.05d0,0.25d0,0d0,0.2d0,0.4d0,
571  &0.005d0,0.4d0,0.01d0,0.35d0,0.001d0,0.1d0,0.08d0,0.1d0,0.08d0,
572  &0.1d0,0d0,0.05d0,0.02d0,6*0.1d0,0.05d0,0.1d0,0d0,0.02d0,2*0.3d0,
573  &0.05d0,2*0.3d0,0.02d0,2*0.1d0,0.03d0,0.001d0,4*0.1d0,3*0d0,
574  &19*10d0,0.00001d0,7*10d0,0.00001d0,10d0,0.00001d0,10d0,0.00001d0,
575  &0.20797d0,0.11949d0,0.37048d0,0.95114d0,18.99785d0,16.07463d0,
576  &1.33964d0,450d0,0.22959d0,1.88863d0,360d0,60.8718d0,0d0,
577  &21.74824d0,25.93594d0,25.96873d0,4.28961d0,4.19124d0,1.41528d0,
578  &0.00977d0,0.00976d0,0.00973d0,267.24501d0,217.49162d0,8.81592d0,
579  &8.80013d0,13*0d0,2.54987d0,2.84456d0,
580  &81*0,
581 C...UED
582  &12*0.2d0,9*0.1d0,0.2,10.,0.07,0.3,25*0.d0/
583  DATA (pmas(i,4),i= 1, 500)/12*0d0,658654d0,0d0,0.0872d0,68*0d0,
584  &0.1d0,0.387d0,16*0d0,0.00003d0,2*0d0,15500d0,7804.5d0,5*0d0,
585  &26.762d0,3*0d0,3709d0,5*0d0,0.317d0,2*0d0,0.1244d0,2*0d0,0.14d0,
586  &5*0d0,0.468d0,2*0d0,0.462d0,2*0d0,0.483d0,2*0d0,0.15d0,18*0d0,
587  &44.34d0,0d0,78.88d0,4*0d0,23.96d0,2*0d0,49.1d0,0d0,87.1d0,0d0,
588  &24.6d0,4*0d0,0.0618d0,0.029d0,6*0d0,0.106d0,6*0d0,0.019d0,2*0d0,
589  &7*0.1d0,4*0d0,0.342d0,2*0.387d0,6*0d0,2*0.387d0,6*0d0,0.387d0,
590  &0d0,0.387d0,2*0d0,8*0.387d0,0d0,9*0.387d0,120*0d0,131*0d0/
591 
592  DATA parf/
593  & 0.5d0,0.25d0, 0.5d0,0.25d0, 1d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
594  1 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
595  2 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
596  3 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
597  4 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
598  5 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
599  6 0.75d0, 0.5d0, 0d0,0.1667d0,0.0833d0,0.1667d0,0d0,0d0,0d0, 0d0,
600  7 0d0, 0d0, 1d0,0.3333d0,0.6667d0,0.3333d0,0d0,0d0,0d0, 0d0,
601  8 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
602  9 0.0099d0, 0.0056d0, 0.199d0, 1.23d0, 4.17d0, 165d0, 4*0d0,
603  & 0.325d0,0.325d0,0.5d0,1.6d0, 5.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
604  1 0d0,0.11d0,0.16d0,0.048d0,0.50d0,0.45d0,0.55d0,0.60d0,0d0,0d0,
605  2 0.2d0, 0.1d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
606  3 60*0d0,
607  4 0.2d0, 0.5d0, 8*0d0,
608  5 1800*0d0/
609  DATA ((vckm(i,j),j=1,4),i=1,4)/
610  & 0.95113d0, 0.04884d0, 0.00003d0, 0.00000d0,
611  & 0.04884d0, 0.94940d0, 0.00176d0, 0.00000d0,
612  & 0.00003d0, 0.00176d0, 0.99821d0, 0.00000d0,
613  & 0.00000d0, 0.00000d0, 0.00000d0, 1.00000d0/
614 
615 C...PYDAT3, with particle decay parameters and data.
616  DATA (mdcy(i,1),i= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
617  &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
618  &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
619  &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1,
620  &81*0,
621 C...UED
622  &5*1,0,5*1,0,13*1,25*0/
623  DATA (mdcy(i,2),i= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
624  &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
625  &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
626  &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
627  &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
628  &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
629  &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
630  &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
631  &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
632  &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
633  &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
634  &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
635  &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
636  &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
637  &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
638  &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
639  &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
640  &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
641  &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
642  &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
643  DATA (mdcy(i,2),i= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
644  &4214,4215,4216,4296,4322,
645  &81*0,
646 C...UED
647  %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
648  &5031,5032,5033,
649  &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
650  &25*0/
651  DATA (mdcy(i,3),i= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
652  &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
653  &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
654  &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
655  &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
656  &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
657  &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
658  &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
659  &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,
660  &3*22,15,12,2*7,7*0,6*1,26,30,
661  &81*0,
662 C...UED
663  &6*2,6*3,9*1,24,1,18,6,25*0/
664  DATA (mdme(i,1),i= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
665  &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
666  &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
667  &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
668  &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,
669  &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
670  &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1,
671  &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,
672  &5*-1,3*1,-1,
673  &649*0,
674 C...UED
675  &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
676  &1,24*1,2912*0/
677  DATA (mdme(i,2),i= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
678  &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
679  &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
680  &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
681  &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
682  &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
683  &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
684  &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
685  &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
686  &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
687  &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
688  &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
689  &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
690  &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,
691  &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
692  &16*32,
693 C...UED
694  &653*0,30*0,9*0,12*0,37*0,2912*0/
695  DATA (brat(i) ,i= 1, 348)/43*0d0,0.00003d0,0.001765d0,
696  &0.998205d0,35*0d0,1d0,6*0d0,0.1783d0,0.1735d0,0.1131d0,0.2494d0,
697  &0.003d0,0.09d0,0.0027d0,0.01d0,0.0014d0,0.0012d0,2*0.00025d0,
698  &0.0071d0,0.012d0,0.0004d0,0.00075d0,0.00006d0,2*0.00078d0,
699  &0.0034d0,0.08d0,0.011d0,0.0191d0,0.00006d0,0.005d0,0.0133d0,
700  &0.0067d0,0.0005d0,0.0035d0,0.0006d0,0.0015d0,0.00021d0,0.0002d0,
701  &0.00075d0,0.0001d0,0.0002d0,0.0011d0,3*0.0002d0,0.00022d0,
702  &0.0004d0,0.0001d0,2*0.00205d0,2*0.00069d0,0.00025d0,0.00051d0,
703  &0.00025d0,35*0d0,0.153995d0,0.11942d0,0.153984d0,0.119259d0,
704  &0.152272d0,3*0d0,0.033576d0,0.066806d0,0.033576d0,0.066806d0,
705  &0.0335d0,0.066806d0,2*0d0,0.321369d0,0.016494d0,2*0d0,0.016502d0,
706  &0.320615d0,2*0d0,0.00001d0,0.000591d0,6*0d0,2*0.108166d0,
707  &0.108087d0,0d0,0.000001d0,0d0,0.000353d0,0.04359d0,0.795274d0,
708  &4*0d0,0.000339d0,0.095746d0,0d0,0.060724d0,0.003054d0,0.000919d0,
709  &64*0d0,0.145835d0,0.113276d0,0.145835d0,0.113271d0,0.145781d0,
710  &0.049002d0,2*0d0,0.032025d0,0.063642d0,0.032025d0,0.063642d0,
711  &0.032022d0,0.063642d0,8*0d0,0.251225d0,0.0129d0,0.000006d0,0d0,
712  &0.0129d0,0.250764d0,0.00038d0,0d0,0.000008d0,0.000465d0,
713  &0.215418d0,5*0d0,2*0.085312d0,0.08531d0,7*0d0,0.000029d0,
714  &0.000536d0,5*0d0,0.000074d0,0d0,0.000417d0,0.000015d0,0.000061d0/
715  DATA (brat(i) ,i= 349, 655)/0.306789d0,0.689189d0,0d0,0.00289d0,
716  &69*0d0,0.000001d0,0.000072d0,0.001333d0,4*0d0,0.000001d0,
717  &0.000184d0,0d0,0.003108d0,0.000015d0,0.000003d0,2*0d0,0.995284d0,
718  &66*0d0,0.000014d0,0.082234d0,2*0d0,0.000013d0,0.003746d0,0d0,
719  &0.913992d0,18*0d0,3*0.215119d0,0.214724d0,2*0d0,0.06996d0,
720  &0.069959d0,0d0,2*1d0,2*0.08d0,0.76d0,0.08d0,2*0.105d0,0.04d0,
721  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,0.988d0,0.012d0,
722  &0.998739d0,0.00079d0,0.00038d0,0.000046d0,0.000045d0,2*0.34725d0,
723  &0.144d0,0.104d0,0.0245d0,2*0.01225d0,0.0028d0,0.0057d0,0.2112d0,
724  &0.1256d0,2*0.1939d0,2*0.1359d0,0.002d0,0.001d0,0.0006d0,
725  &0.999877d0,0.000123d0,0.99955d0,0.00045d0,2*0.34725d0,0.144d0,
726  &0.104d0,0.049d0,0.0028d0,0.0057d0,0.3923d0,0.321d0,0.2317d0,
727  &0.0478d0,0.0049d0,0.0013d0,0.0003d0,0.0007d0,0.89d0,0.08693d0,
728  &0.0221d0,0.00083d0,2*0.00007d0,0.564d0,0.282d0,0.072d0,0.028d0,
729  &0.023d0,2*0.0115d0,0.005d0,0.003d0,0.6861d0,0.3139d0,2*0.5d0,
730  &0.665d0,0.333d0,0.002d0,0.333d0,0.166d0,0.168d0,0.084d0,0.087d0,
731  &0.043d0,0.059d0,2*0.029d0,0.002d0,0.6352d0,0.2116d0,0.0559d0,
732  &0.0173d0,0.0482d0,0.0318d0,0.666d0,0.333d0,0.001d0,0.332d0,
733  &0.166d0,0.168d0,0.084d0,0.086d0,0.043d0,0.059d0,2*0.029d0,
734  &2*0.002d0,0.437d0,0.208d0,0.302d0,0.0302d0,0.0212d0,0.0016d0/
735  DATA (brat(i) ,i= 656, 831)/0.48947d0,0.34d0,3*0.043d0,0.027d0,
736  &0.0126d0,0.0013d0,0.0003d0,0.00025d0,0.00008d0,0.444d0,2*0.222d0,
737  &0.104d0,2*0.004d0,0.07d0,0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,
738  &0.07d0,0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,0.026d0,0.019d0,
739  &0.066d0,0.041d0,0.045d0,0.076d0,0.0073d0,2*0.0047d0,0.026d0,
740  &0.001d0,0.0006d0,0.0066d0,0.005d0,2*0.003d0,2*0.0006d0,2*0.001d0,
741  &0.006d0,0.005d0,0.012d0,0.0057d0,0.067d0,0.008d0,0.0022d0,
742  &0.027d0,0.004d0,0.019d0,0.012d0,0.002d0,0.009d0,0.0218d0,0.001d0,
743  &0.022d0,0.087d0,0.001d0,0.0019d0,0.0015d0,0.0028d0,0.683d0,
744  &0.306d0,0.011d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,
745  &0.04d0,0.034d0,0.027d0,2*0.002d0,2*0.004d0,2*0.002d0,0.034d0,
746  &0.027d0,2*0.002d0,2*0.004d0,2*0.002d0,0.0365d0,0.045d0,0.073d0,
747  &0.062d0,3*0.021d0,0.0061d0,0.015d0,0.025d0,0.0088d0,0.074d0,
748  &0.0109d0,0.0041d0,0.002d0,0.0035d0,0.0011d0,0.001d0,0.0027d0,
749  &2*0.0016d0,0.0018d0,0.011d0,0.0063d0,0.0052d0,0.018d0,0.016d0,
750  &0.0034d0,0.0036d0,0.0009d0,0.0006d0,0.015d0,0.0923d0,0.018d0,
751  &0.022d0,0.0077d0,0.009d0,0.0075d0,0.024d0,0.0085d0,0.067d0,
752  &0.0511d0,0.017d0,0.0004d0,0.0028d0,0.619d0,0.381d0,0.3d0,0.15d0,
753  &0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.01d0,2*0.02d0,0.03d0,
754  &2*0.005d0,2*0.02d0,0.03d0,2*0.005d0,0.015d0,0.037d0,0.028d0/
755  DATA (brat(i) ,i= 832, 997)/0.079d0,0.095d0,0.052d0,0.0078d0,
756  &4*0.001d0,0.028d0,0.033d0,0.026d0,0.05d0,0.01d0,4*0.005d0,0.25d0,
757  &0.0952d0,0.94d0,0.06d0,2*0.4d0,2*0.1d0,1d0,0.0602d0,0.0601d0,
758  &0.8797d0,0.135d0,0.865d0,0.02d0,0.055d0,2*0.005d0,0.008d0,
759  &0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,
760  &0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,
761  &0.0185d0,0.0135d0,0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,
762  &0.0019d0,0.0025d0,0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,
763  &1d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,
764  &0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,
765  &2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,
766  &0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,0.0185d0,0.0135d0,
767  &0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,0.0019d0,0.0025d0,
768  &0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,1d0,0.3d0,0.15d0,
769  &0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.02d0,0.055d0,
770  &2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,
771  &0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,
772  &0.018d0,0.015d0,0.0185d0,0.0135d0,0.025d0,2*0.0002d0,0.0007d0,
773  &2*0.0004d0,0.0014d0,0.001d0,0.0009d0,0.0025d0,0.4291d0,0.08d0,
774  &0.07d0,0.02d0,0.015d0,0.005d0,1d0,2*0.3d0,2*0.2d0,0.047d0/
775  DATA (brat(i) ,i= 998,1188)/0.122d0,0.006d0,0.012d0,0.035d0,
776  &0.012d0,0.035d0,0.003d0,0.007d0,0.15d0,0.037d0,0.008d0,0.002d0,
777  &0.05d0,0.015d0,0.003d0,0.001d0,0.014d0,0.042d0,0.014d0,0.042d0,
778  &0.24d0,0.065d0,0.012d0,0.003d0,0.001d0,0.002d0,0.001d0,0.002d0,
779  &0.014d0,0.003d0,1d0,2*0.3d0,2*0.2d0,1d0,0.0252d0,0.0248d0,
780  &0.0267d0,0.015d0,0.045d0,0.015d0,0.045d0,0.7743d0,0.029d0,0.22d0,
781  &0.78d0,1d0,0.331d0,0.663d0,0.006d0,0.663d0,0.331d0,0.006d0,1d0,
782  &0.999d0,0.001d0,0.88d0,2*0.06d0,0.639d0,0.358d0,0.002d0,0.001d0,
783  &1d0,0.88d0,2*0.06d0,0.516d0,0.483d0,0.001d0,0.88d0,2*0.06d0,
784  &0.9988d0,0.0001d0,0.0006d0,0.0004d0,0.0001d0,0.667d0,0.333d0,
785  &0.9954d0,0.0011d0,0.0035d0,0.333d0,0.667d0,0.676d0,0.234d0,
786  &0.085d0,0.005d0,2*1d0,0.018d0,2*0.005d0,0.003d0,0.002d0,
787  &2*0.006d0,0.018d0,2*0.005d0,0.003d0,0.002d0,2*0.006d0,0.0066d0,
788  &0.025d0,0.016d0,0.0088d0,2*0.005d0,0.0058d0,0.005d0,0.0055d0,
789  &4*0.004d0,2*0.002d0,2*0.004d0,0.003d0,0.002d0,2*0.003d0,
790  &3*0.002d0,2*0.001d0,0.002d0,2*0.001d0,2*0.002d0,0.0013d0,
791  &0.0018d0,5*0.001d0,4*0.003d0,2*0.005d0,2*0.002d0,2*0.001d0,
792  &2*0.002d0,2*0.001d0,0.2432d0,0.057d0,2*0.035d0,0.15d0,2*0.075d0,
793  &0.03d0,2*0.015d0,2*0.08d0,0.76d0,0.08d0,4*1d0,2*0.08d0,0.76d0,
794  &0.08d0,1d0,2*0.5d0,1d0,2*0.5d0,2*0.08d0,0.76d0,0.08d0,1d0/
795  DATA (brat(i) ,i=1189,1381)/2*0.08d0,0.76d0,3*0.08d0,0.76d0,
796  &3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,
797  &3*0.08d0,0.76d0,0.08d0,2*1d0,2*0.105d0,0.04d0,0.0077d0,0.02d0,
798  &0.0235d0,0.0285d0,0.0435d0,0.0011d0,0.0022d0,0.0044d0,0.4291d0,
799  &0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,
800  &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,
801  &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,0.04d0,
802  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,
803  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,
804  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,1d0,2*0.105d0,
805  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
806  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
807  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
808  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
809  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
810  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
811  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
812  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
813  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
814  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0/
815  DATA (brat(i) ,i=1382,1582)/0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
816  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
817  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
818  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
819  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
820  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
821  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
822  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
823  &0.015d0,0.005d0,4*1d0,0.52d0,0.26d0,0.11d0,2*0.055d0,0.333d0,
824  &0.334d0,0.333d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,
825  &0.11d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,0.11d0,
826  &0.36d0,0.18d0,0.03d0,2*0.015d0,2*0.2d0,4*0.25d0,0.667d0,0.333d0,
827  &0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.007d0,
828  &0.993d0,1d0,0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,
829  &0.667d0,0.333d0,8*0.5d0,0.02d0,0.98d0,1d0,4*0.5d0,3*0.146d0,
830  &3*0.05d0,0.15d0,2*0.05d0,4*0.024d0,0.066d0,0.667d0,0.333d0,
831  &0.667d0,0.333d0,4*0.25d0,0.667d0,0.333d0,0.667d0,0.333d0,2*0.5d0,
832  &0.273d0,0.727d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.35d0,
833  &0.65d0,2*0.0083d0,0.1866d0,0.324d0,0.184d0,0.027d0,0.001d0,
834  &0.093d0,0.087d0,0.078d0,0.0028d0,3*0.014d0,0.008d0,0.024d0/
835  DATA (brat(i) ,i=1583,4150)/0.008d0,0.024d0,0.425d0,0.02d0,
836  &0.185d0,0.088d0,0.043d0,0.067d0,0.066d0,2404*0d0,0.024396d0,
837  &0.045285d0,0.83119d0,2*0d0,0.000349d0,0.09878d0,0d0,0.019884d0,
838  &0.02341d0,0.362776d0,0.550787d0,2*0d0,0.000152d0,0.042991d0,
839  &0.013695d0,0.025421d0,0.466595d0,2*0d0,0.000196d0,0.055451d0,
840  &0.438642d0,0.445781d0,0d0,0.554219d0,4*0.00335d0,0.522257d0,
841  &0.464343d0,6*0d0,1d0,6*0d0,1d0,4*0.013853d0,0.562703d0,
842  &0.376702d0,0.00518d0,4*0.006254d0,0.974985d0,7*0d0,4*0.148299d0,
843  &0.015351d0,0d0,0.182109d0,0.167099d0,0.042247d0,0.850973d0,
844  &0.005411d0,0.045025d0,0.098591d0,0.849898d0,0.021617d0,
845  &0.030018d0,0.098466d0,0.294448d0,0.10945d0,0.596102d0,0.389906d0,
846  &0.610094d0,3*0.0633d0,0.063299d0,0.063295d0,0.056281d0,2*0d0,
847  &6*0.020495d0,2*0d0,0.327919d0,0.04099d0,0.045236d0,0.090112d0,
848  &0.19874d0,0.010204d0,0.000003d0,0.010205d0,0.198356d0,0.000151d0,
849  &0.000006d0,0.000367d0,0.081967d0,0.19874d0,0.010204d0,0.000003d0,
850  &0.010205d0,0.198356d0,0.000151d0,0.000006d0,0.000367d0,
851  &0.081967d0,4*0d0,0.198776d0,0.010206d0,0.000003d0,0.010207d0,
852  &0.19839d0,0.000151d0,0.000006d0,0.000367d0,0.081893d0,0.198776d0,
853  &0.010206d0,0.000003d0,0.010207d0,0.19839d0,0.000151d0,0.000006d0,
854  &0.000367d0,0.081893d0,4*0d0,0.199344d0,0.010234d0,0.000003d0/
855  DATA (brat(i) ,i=4151,4281)/0.010236d0,0.198928d0,0.000149d0,
856  &0.000006d0,0.000368d0,0.080733d0,0.199344d0,0.010234d0,
857  &0.000003d0,0.010236d0,0.198928d0,0.000149d0,0.000006d0,
858  &0.000368d0,0.080733d0,4*0d0,0.184738d0,0.104588d0,0.184738d0,
859  &0.104587d0,0.184731d0,0.09582d0,0.022902d0,0.008429d0,0.015602d0,
860  &0.022902d0,0.008429d0,0.015602d0,0.022902d0,0.008429d0,
861  &0.015602d0,0.28959d0,0.01487d0,0.000008d0,0.01487d0,0.289061d0,
862  &0.000492d0,0.000009d0,0.000536d0,0.27911d0,2*0.037151d0,
863  &0.03715d0,0.090266d0,2*0.001805d0,0.090266d0,0.001805d0,
864  &0.812263d0,0.00179d0,0.090428d0,0.001809d0,0.001808d0,0.090428d0,
865  &0.001808d0,0.81372d0,0d0,6*1d0,0.095602d0,2*0.338272d0,
866  &0.156896d0,0.019193d0,0.017993d0,0.001168d0,0.001462d0,
867  &0.009608d0,0.003306d0,0.002132d0,0.003127d0,0.002132d0,
868  &0.003127d0,0.00213d0,3*0d0,0.001411d0,0.00045d0,0.001411d0,
869  &0.00045d0,0.001411d0,0.00045d0,2*0d0,0.097996d0,0.399787d0,
870  &0.262464d0,0.185427d0,0.022683d0,0.007648d0,0.004259d0,
871  &0.005925d0,0.000304d0,2*0d0,0.000304d0,0.005914d0,0.000002d0,
872  &2*0d0,0.000011d0,0.001258d0,5*0d0,3*0.002005d0,0d0,0.272178d0,
873  &0.022112d0,0.255165d0,0.015534d0,2*0.108965d0,0.031557d0,
874  &0.005562d0,0.044965d0,0.004674d0,0.007637d0,0.020597d0/
875  DATA (brat(i) ,i=4282,8000)/0.007636d0,0.020595d0,0.007616d0,
876  &3*0d0,0.017298d0,0.004782d0,0.017298d0,0.004782d0,0.017297d0,
877  &0.004782d0,2*0d0,0.055332d0,2*0.319757d0,0.121576d0,2*0.001556d0,
878  &4*0d0,0.0277d0,0.021481d0,0.027699d0,0.021477d0,0.027658d0,3*0d0,
879  &0.006071d0,0.01208d0,0.006071d0,0.01208d0,0.006069d0,0.01208d0,
880  &2*0d0,0.035891d0,0.209476d0,0.129084d0,0.286631d0,0.10742d0,
881  &0.109486d0,4*0d0,0.035282d0,0.001812d0,2*0d0,0.001812d0,
882  &0.035215d0,0.000021d0,0d0,0.000001d0,0.000065d0,0.011965d0,5*0d0,
883  &2*0.011947d0,0.011946d0,0d0,
884  &649*0.d0,
885 C....UED
886  &0.001d0,0.999d0,0.001d0,0.999d0,0.001d0,0.999d0,
887  &0.001d0,0.999d0,0.001d0,0.999d0,0.001d0,0.999d0,
888  &0.33d0,0.66d0,0.01d0,0.33d0,0.66d0,0.01d0,0.33d0,0.66d0,0.01d0,
889  &0.33d0,0.66d0,0.01d0,0.98d0,0.d0,0.02d0,0.33d0,0.66d0,0.01d0,
890  &9*1.d0,
891  &24*0.0416667,
892  &1.,
893  &3*0.d0,6*0.08333d0,
894  &3*0.d0,6*0.08333d0,
895  &6*0.166667d0,
896  &2912*0.d0/
897  DATA (kfdp(i,1),i= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
898  &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
899  &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
900  &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
901  &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
902  &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
903  &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
904  &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
905  &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
906  &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
907  &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
908  &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
909  &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
910  &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
911  &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
912  &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
913  &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
914  &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
915  &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
916  &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
917  DATA (kfdp(i,1),i= 378, 580)/1000002,-1000002,1000003,2000003,
918  &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
919  &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
920  &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
921  &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
922  &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
923  &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
924  &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
925  &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
926  &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
927  &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
928  &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
929  &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
930  &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
931  &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
932  &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
933  &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
934  &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
935  &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
936  &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
937  DATA (kfdp(i,1),i= 581, 992)/2*211,213,113,221,223,321,211,331,
938  &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
939  &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
940  &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
941  &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
942  &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
943  &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
944  &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
945  &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
946  &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
947  &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
948  &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
949  &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
950  &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
951  &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
952  &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
953  &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
954  &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
955  &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
956  &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
957  DATA (kfdp(i,1),i= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
958  &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
959  &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
960  &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
961  &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
962  &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
963  &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
964  &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
965  &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
966  &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
967  &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
968  &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
969  &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
970  &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
971  &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
972  &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
973  &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
974  &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
975  &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
976  &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
977  DATA (kfdp(i,1),i=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
978  &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
979  &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
980  &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
981  &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
982  &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
983  &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
984  &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
985  &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
986  &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
987  &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
988  &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
989  &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
990  &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
991  &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
992  &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
993  &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
994  &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
995  &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
996  &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
997  DATA (kfdp(i,1),i=1714,1984)/2000003,1000003,2000003,1000021,
998  &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
999  &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
1000  &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
1001  &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
1002  &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
1003  &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1004  &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
1005  &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1006  &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
1007  &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1008  &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
1009  &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1010  &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
1011  &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1012  &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
1013  &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
1014  &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
1015  &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
1016  &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
1017  DATA (kfdp(i,1),i=1985,2321)/-1000003,2000003,-2000003,1000004,
1018  &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1019  &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
1020  &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1021  &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
1022  &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
1023  &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
1024  &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
1025  &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
1026  &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
1027  &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
1028  &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
1029  &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
1030  &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
1031  &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
1032  &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
1033  &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
1034  &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
1035  &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
1036  &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
1037  DATA (kfdp(i,1),i=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1038  &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1039  &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
1040  &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
1041  &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
1042  &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
1043  &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1044  &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1045  &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1046  &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1047  &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1048  &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1049  &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1050  &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1051  &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1052  &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1053  &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1054  &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1055  &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1056  &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
1057  DATA (kfdp(i,1),i=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1058  &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1059  &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1060  &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1061  &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1062  &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1063  &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1064  &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1065  &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1066  &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1067  &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1068  &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1069  &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1070  &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1071  &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1072  &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1073  &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1074  &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1075  &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1076  &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1077  DATA (kfdp(i,1),i=2893,3182)/2000001,-2000001,1000002,-1000002,
1078  &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1079  &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1080  &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1081  &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1082  &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1083  &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1084  &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1085  &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1086  &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1087  &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1088  &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1089  &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1090  &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1091  &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1092  &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1093  &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1094  &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1095  &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1096  &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1097  DATA (kfdp(i,1),i=3183,3459)/1000024,-1000024,1000037,-1000037,
1098  &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1099  &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1100  &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1101  &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1102  &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1103  &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1104  &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1105  &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1106  &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1107  &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1108  &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1109  &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1110  &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1111  &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1112  &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1113  &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1114  &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1115  &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1116  &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1117  DATA (kfdp(i,1),i=3460,3782)/2000012,-1000011,-2000011,1000014,
1118  &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1119  &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1120  &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1121  &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1122  &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1123  &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1124  &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1125  &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1126  &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1127  &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1128  &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1129  &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1130  &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1131  &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1132  &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1133  &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1134  &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1135  &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1136  &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1137  DATA (kfdp(i,1),i=3783,4156)/1000039,1000024,1000037,1000022,
1138  &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1139  &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1140  &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1141  &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1142  &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1143  &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1144  &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1145  &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1146  &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1147  &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1148  &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1149  &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1150  &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1151  &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1152  &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1153  &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,
1154  &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1155  &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1156  &21,22,23,24,9*11,9*-11,2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15/
1157  DATA (kfdp(i,1),i=4157,8000)/9*-15,2*15,2*-15,1,2,3,4,5,6,11,12,
1158  &9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1159  &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1160  &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1161  &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1162  &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1163  &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1164  &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1165  &-11,-13,-15,-17,
1166  &649*0,
1167 C...UED
1168  &5100023,5100022,5100023,5100022,5100023,5100022,
1169  &5100023,5100022,5100023,5100022,5100023,5100022,
1170  &5100023,-5100024,5100022,5100023,5100024,5100022,
1171  &5100023,-5100024,5100022,5100023,5100024,5100022,
1172  &5100023,-5100024,5100022,5100023,5100024,5100022,
1173  &9*5100022,
1174  &6100001,6100002,6100003,6100004,6100005,6100006,
1175  &5100001,5100002,5100003,5100004,5100005,5100006,
1176  &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1177  &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1178  &39,
1179  &6100011,6100013,6100015,
1180  &5100011,5100013,5100015,
1181  %5100012,5100014,5100016,
1182  &-6100011,-6100013,-6100015,
1183  &-5100011,-5100013,-5100015,
1184  %-5100012,-5100014,-5100016,
1185  &-5100011,-5100013,-5100015,
1186  &5100012,5100014,5100016,
1187  &2912*0/
1188  DATA (kfdp(i,2),i= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
1189  &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
1190  &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,
1191  &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1192  &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1193  &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1194  &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1195  &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1196  &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1197  &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1198  &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1199  &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1200  &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1201  &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1202  &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1203  &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1204  &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1205  &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1206  &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1207  &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/
1208  DATA (kfdp(i,2),i= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1209  &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1210  &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1211  &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1212  &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1213  &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1214  &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1215  &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1216  &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1217  &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1218  &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1219  &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1220  &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1221  &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1222  &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1223  &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1224  &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1225  &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1226  &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1227  &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1228  DATA (kfdp(i,2),i= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1229  &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1230  &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1231  &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1232  &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1233  &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1234  &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1235  &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1236  &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1237  &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1238  &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1239  &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1240  &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1241  &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1242  &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1243  &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1244  &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1245  &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1246  &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1247  &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1248  DATA (kfdp(i,2),i= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1249  &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1250  &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1251  &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1252  &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1253  &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1254  &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1255  &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1256  &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1257  &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1258  &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1259  &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1260  &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1261  &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1262  &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1263  &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1264  &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
1265  &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,4,
1266  &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,
1267  &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/
1268  DATA (kfdp(i,2),i=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1269  &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,
1270  &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,
1271  &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,
1272  &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1273  &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1274  &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1275  &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1276  &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1277  &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1278  &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1279  &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1280  &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1281  &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
1282  &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
1283  &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1284  &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
1285  &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
1286  &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
1287  &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
1288  DATA (kfdp(i,2),i=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1289  &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
1290  &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1291  &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
1292  &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1293  &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1294  &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
1295  &5,-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,
1296  &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
1297  &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
1298  &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,
1299  &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,
1300  &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
1301  &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1302  &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1303  &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1304  &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1305  &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1306  &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1307  &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
1308  DATA (kfdp(i,2),i=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1309  &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1310  &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1311  &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1312  &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1313  &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1314  &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1315  &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1316  &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1317  &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1318  &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1319  &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
1320  &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1321  &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1322  &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,
1323  &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1324  &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1325  &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1326  &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1327  &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1328  DATA (kfdp(i,2),i=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1329  &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1330  &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
1331  &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
1332  &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1333  &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1334  &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1335  &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1336  &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1337  &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1338  &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
1339  &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
1340  &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
1341  &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
1342  &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
1343  &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1344  &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
1345  &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1346  &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1347  &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1348  DATA (kfdp(i,2),i=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1349  &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1350  &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1351  &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1352  &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,
1353  &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,
1354  &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
1355  &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
1356  &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1357  &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1358  &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1359  &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1360  &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1361  &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1362  &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1363  &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1364  &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1365  &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1366  &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1367  &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
1368  DATA (kfdp(i,2),i=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1369  &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
1370  &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
1371  &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1372  &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
1373  &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
1374  &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
1375  &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
1376  &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1377  &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
1378  &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
1379  &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1380  &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1381  &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1382  &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1383  &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1384  &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1385  &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1386  &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
1387  &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1388  DATA (kfdp(i,2),i=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1389  &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1390  &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1391  &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1392  &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1393  &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1394  &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1395  &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1396  &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1397  &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1398  &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1399  &649*0,
1400 C...UED
1401  &1,1,2,2,3,3,4,4,5,5,6,6,
1402  &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1403  &11,13,15,12,11,14,13,16,15,
1404  &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1405  &1,2,3,4,5,6,1,2,3,4,5,6,
1406  &22,
1407  &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1408  &11,13,15,11,13,15,12,14,16,
1409  &12,14,16,-11,-13,-15,
1410  &2912*0/
1411  DATA (kfdp(i,3),i= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1412  &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1413  &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1414  &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1415  &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1416  &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1417  &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1418  &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1419  &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1420  &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1421  &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1422  &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1423  &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1424  &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1425  &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1426  &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1427  &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1428  &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1429  &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1430  &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1431  DATA (kfdp(i,3),i=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1432  &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1433  &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1434  &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,
1435  &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,
1436  &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,
1437  &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,
1438  &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,
1439  &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,
1440  &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1441  &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1442  &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1443  &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
1444  &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1445  &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1446  &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1447  &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
1448  &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1449  &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1450  &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1451  DATA (kfdp(i,3),i=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1452  &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1453  &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1454  &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
1455  &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1456  &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1457  &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1458  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1459  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1460  &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1461  &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1462  &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1463  &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1464  &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
1465  &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1466  &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1467  &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1468  &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1469  &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1470  &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/
1471  DATA (kfdp(i,3),i=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1472  &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
1473  &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1474  &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1475  &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1476  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1477  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1478  &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1479  &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1480  &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1481  &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1482  &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1483  &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1484  &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1485  &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1486  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1487  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1488  &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1489  &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,
1490  &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1491  DATA (kfdp(i,3),i=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1492  &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
1493  &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1494  &4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
1495  &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1496  &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1497  &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1498  &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1499  &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1500  &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1501  &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
1502  &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4,
1503  &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1504  &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1505  &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1506  DATA (kfdp(i,4),i= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1507  &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1508  &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1509  &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1510  &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1511  &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1512  &-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,
1513  &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1514  &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,
1515  &162*81,31*0,-211,111,6516*0/
1516  DATA (kfdp(i,5),i= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1517  &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1518  &3*111,-211,111,7193*0/
1519 
1520 C...PYDAT4, with particle names (character strings).
1521  DATA (chaf(i,1),i= 1, 202)/'d','u','s','c','b','t','b''','t''',
1522  &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1523  &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1524  &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1525  &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1526  &'junction',' ','system','cluster','string','indep.','CMshower',
1527  &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1528  &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1529  &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1530  &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1531  &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1532  &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1533  &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1534  &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1535  &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1536  &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1537  &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1538  &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1539  &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1540  &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1541  DATA (chaf(i,1),i= 203, 332)/'Omega_cc+','Omega*_cc+',
1542  &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1543  &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1544  &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1545  &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1546  &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1547  &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1548  &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1549  &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1550  &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1551  &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1552  &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1553  &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1554  &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1555  &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1556  &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1557  &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1558  &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1559  &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1560  &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1561  DATA (chaf(i,1),i= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1562  &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1563  &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1564  &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1565  &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1566  &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1567  &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1568  &81*' ',
1569 C...UED
1570  &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1571  &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1572  &'e*_S-','mu*_S-','tau*_S-',
1573  &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1574  &'g*','gamma*','Z*0','W*+',25*' '/
1575  DATA (chaf(i,2),i= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1576  &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1577  &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1578  &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1579  &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1580  &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1581  &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1582  &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1583  &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1584  &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1585  &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1586  &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1587  &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1588  &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1589  &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1590  &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1591  &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1592  &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1593  &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1594  &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1595  DATA (chaf(i,2),i= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1596  &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1597  &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1598  &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1599  &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1600  &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1601  &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1602  &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1603  &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1604  &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1605  &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1606  &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1607  &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1608  &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1609  &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1610  &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1611  &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1612  &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1613  &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1614  &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1615  DATA (chaf(i,2),i= 326, 500)/'~nu_muRbar','~tau_2+',
1616  &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1617  &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1618  &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1619  &81*' ',
1620 C...UED
1621  &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1622  &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1623  &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1624  &'nu*_eDbar','e*_Dbar+',
1625  &'nu*_muDbar','mu*_Dbar+',
1626  &'nu*_tauDbar','tau*_Dbar+',
1627  &'g*','gamma*','Z*0','W*-',25*' '/
1628 
1629 C...PYDATR, with initial values for the random number generator.
1630  DATA mrpy/19780503,0,0,97,33,0/
1631 
1632 C...Default values for allowed processes and kinematics constraints.
1633  DATA msel/1/
1634  DATA msub/500*0/
1635  DATA ((kfin(i,j),j=-40,40),i=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1636  &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,
1637  &6*1,4*0,4*1,16*0/
1638  DATA ckin/
1639  & 2.0d0, -1.0d0, 0.0d0, -1.0d0, 1.0d0,
1640  & 1.0d0, -10d0, 10d0, -40d0, 40d0,
1641  1 -40d0, 40d0, -40d0, 40d0, -40d0,
1642  1 40d0, -1.0d0, 1.0d0, -1.0d0, 1.0d0,
1643  2 0.0d0, 1.0d0, 0.0d0, 1.0d0, -1.0d0,
1644  2 1.0d0, -1.0d0, 1.0d0, 0d0, 0d0,
1645  3 2.0d0, -1.0d0, 0d0, 0d0, 0.0d0,
1646  3 -1.0d0, 0.0d0, -1.0d0, 4.0d0, -1.0d0,
1647  4 12.0d0, -1.0d0, 12.0d0, -1.0d0, 12.0d0,
1648  4 -1.0d0, 12.0d0, -1.0d0, 0d0, 0d0,
1649  5 0.0d0, -1.0d0, 0.0d0, -1.0d0, 0.0d0,
1650  5 -1.0d0, 0d0, 0d0, 0d0, 0d0,
1651  6 0.0001d0, 0.99d0, 0.0001d0, 0.99d0, 0d0,
1652  6 -1d0, 0d0, -1d0, 0d0, -1d0,
1653  7 0d0, -1d0, 0.0001d0, 0.99d0, 0.0001d0,
1654  7 0.99d0, 2d0, -1d0, 0d0, 0d0,
1655  8 120*0d0/
1656 
1657 C...Default values for main switches and parameters. Reset information.
1658  DATA (mstp(i),i=1,100)/
1659  & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1660  1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1661  2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1662  3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1663  4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1664  5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1665  6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1666  7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1667  8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1668  9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1669  DATA (mstp(i),i=101,200)/
1670  & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1671  1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1672  2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1673  3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1674  4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1675  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1676  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1677  7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1678  8 6, 420, 2009, 02, 20, 0, 0, 0, 0, 0,
1679  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1680  DATA (parp(i),i=1,100)/
1681  & 0.25d0, 10d0, 8*0d0,
1682  1 0d0, 0d0, 1.0d0, 0.01d0, 0.5d0, 1.0d0, 1.0d0, 0.4d0, 2*0d0,
1683  2 10*0d0,
1684  3 1.5d0,2.0d0,0.075d0,1.0d0,0.2d0,0d0,1.0d0,0.70d0,0.006d0,0d0,
1685  4 0.02d0,2.0d0,0.10d0,1000d0,2054d0,123d0,246d0,50d0,0d0,0.054d0,
1686  5 10*0d0,
1687  6 0.25d0, 1.0d0,0.25d0, 1.0d0, 2.0d0,1d-3, 4.0d0,1d-3,2*0d0,
1688  7 4.0d0, 0.25d0, 5*0d0, 0.025d0, 2.0d0, 0.1d0,
1689  8 1.90d0, 2.0d0, 0.5d0, 0.4d0, 0.90d0,
1690  8 0.95d0, 0.7d0, 0.5d0, 1800d0, 0.16d0,
1691  9 2.0d0,0.40d0,5.0d0,1.0d0,0.0d0,3.0d0,1.0d0,0.75d0,1.0d0,5.0d0/
1692  DATA (parp(i),i=101,200)/
1693  & 0.5d0, 0.28d0, 1.0d0, 0.8d0, 0d0, 0d0, 0d0, 0d0, 0d0, 1d0,
1694  1 2.0d0, 3*0d0, 1.5d0, 0.5d0, 0.6d0, 2.5d0, 2.0d0, 1.0d0,
1695  2 1.0d0, 0.4d0, 8*0d0,
1696  3 0.01d0, 9*0d0,
1697  4 1.16d0, 0.0119d0, 0.01d0, 0.01d0, 0.05d0,
1698  4 9.28d0, 0.15d0, 0.02d0, 0.48d0, 0.09d0,
1699  5 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
1700  6 2.20d0, 23.6d0, 18.4d0, 11.5d0, 0.5d0, 0d0, 0d0, 0d0, 2*0d0,
1701  7 0d0, 0d0, 0d0, 1.0d0, 6*0d0,
1702  8 0.1d0, 0.01d0, 0.01d0, 0.01d0, 0.1d0, 0.01d0, 0.01d0, 0.01d0,
1703  8 0.3d0, 0.64d0,
1704  9 0.64d0, 5.0d0, 1.0d4, 1.0d4, 6*0d0/
1705  DATA msti/200*0/
1706  DATA pari/200*0d0/
1707  DATA mint/400*0/
1708  DATA vint/400*0d0/
1709 
1710 C...Constants for the generation of the various processes.
1711  DATA (iset(i),i=1,100)/
1712  & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1713  1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1714  2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1715  3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1716  4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1717  5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1718  6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1719  7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1720  8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1721  9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1722  DATA (iset(i),i=101,200)/
1723  & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1724  1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1725  2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1726  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1727  4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1728  5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1729  6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1730  7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1731  8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1732  9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1733  DATA (iset(i),i=201,300)/
1734  & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1735  1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1736  2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1737  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1738  4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1739  5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1740  6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1741  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1742  8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1743  9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1744  DATA (iset(i),i=301,500)/
1745  & 2, 9*-2, 9*2, 21*-2,
1746  4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1747  5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1748  6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1749  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1750  8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1751  9 1, 1, 2, 2, 2, 5*-2,
1752  & 5, 5, 18*-2,
1753  2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1754  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1755  6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1756  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1757  DATA ((kfpr(i,j),j=1,2),i=1,50)/
1758  & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1759  & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1760  1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1761  1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1762  2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1763  2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1764  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1765  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1766  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1767  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1768  DATA ((kfpr(i,j),j=1,2),i=51,100)/
1769  5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1770  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1771  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1772  6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1773  7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1774  7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1775  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1776  8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1777  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1778  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1779  DATA ((kfpr(i,j),j=1,2),i=101,150)/
1780  & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1781  & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1782  1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1783  1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1784  2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1785  2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1786  3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1787  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1788  4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1789  4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1790  DATA ((kfpr(i,j),j=1,2),i=151,200)/
1791  5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1792  5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1793  6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1794  6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1795  7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1796  7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1797  8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1798  8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1799  9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1800  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1801  DATA ((kfpr(i,j),j=1,2),i=201,240)/
1802  & 1000011, 1000011, 2000011, 2000011, 1000011,
1803  & 2000011, 1000013, 1000013, 2000013, 2000013,
1804  & 1000013, 2000013, 1000015, 1000015, 2000015,
1805  & 2000015, 1000015, 2000015, 1000011, 1000012,
1806  1 1000015, 1000016, 2000015, 1000016, 1000012,
1807  1 1000012, 1000016, 1000016, 0, 0,
1808  1 1000022, 1000022, 1000023, 1000023, 1000025,
1809  1 1000025, 1000035, 1000035, 1000022, 1000023,
1810  2 1000022, 1000025, 1000022, 1000035, 1000023,
1811  2 1000025, 1000023, 1000035, 1000025, 1000035,
1812  2 1000024, 1000024, 1000037, 1000037, 1000024,
1813  2 1000037, 1000022, 1000024, 1000023, 1000024,
1814  3 1000025, 1000024, 1000035, 1000024, 1000022,
1815  3 1000037, 1000023, 1000037, 1000025, 1000037,
1816  3 1000035, 1000037, 1000021, 1000022, 1000021,
1817  3 1000023, 1000021, 1000025, 1000021, 1000035/
1818  DATA ((kfpr(i,j),j=1,2),i=241,280)/
1819  4 1000021, 1000024, 1000021, 1000037, 1000021,
1820  4 1000021, 1000021, 1000021, 0, 0,
1821  4 1000002, 1000022, 2000002, 1000022, 1000002,
1822  4 1000023, 2000002, 1000023, 1000002, 1000025,
1823  5 2000002, 1000025, 1000002, 1000035, 2000002,
1824  5 1000035, 1000001, 1000024, 2000005, 1000024,
1825  5 1000001, 1000037, 2000005, 1000037, 1000002,
1826  5 1000021, 2000002, 1000021, 0, 0,
1827  6 1000006, 1000006, 2000006, 2000006, 1000006,
1828  6 2000006, 1000006, 1000006, 2000006, 2000006,
1829  6 0, 0, 0, 0, 0,
1830  6 0, 0, 0, 0, 0,
1831  7 1000002, 1000002, 2000002, 2000002, 1000002,
1832  7 2000002, 1000002, 1000002, 2000002, 2000002,
1833  7 1000002, 2000002, 1000002, 1000002, 2000002,
1834  7 2000002, 1000002, 1000002, 2000002, 2000002/
1835  DATA ((kfpr(i,j),j=1,2),i=281,350)/
1836  8 1000005, 1000002, 2000005, 2000002, 1000005,
1837  8 2000002, 1000005, 1000002, 2000005, 2000002,
1838  8 1000005, 2000002, 1000005, 1000005, 2000005,
1839  8 2000005, 1000005, 1000005, 2000005, 2000005,
1840  9 1000005, 1000005, 2000005, 2000005, 1000005,
1841  9 2000005, 1000005, 1000021, 2000005, 1000021,
1842  9 1000005, 2000005, 37, 25, 37,
1843  9 35, 36, 25, 36, 35,
1844  & 37, 37, 18*0,
1845 C...UED: 311-319
1846  & 5100021, 5100021,
1847  & 5100002, 5100021,
1848  & 5100002, 5100001,
1849  & 5100002, -5100002,
1850  & 5100002, -5100002,
1851  & 5100002, -6100001,
1852  & 5100002, -5100001,
1853  & 5100002, 6100001,
1854  & 5100001, -5100001,
1855  & 42*0,
1856  4 9900041, 0, 9900042, 0, 9900041,
1857  4 11, 9900042, 11, 9900041, 13,
1858  4 9900042, 13, 9900041, 15, 9900042,
1859  4 15, 9900041, 9900041, 9900042, 9900042/
1860  DATA ((kfpr(i,j),j=1,2),i=351,400)/
1861  5 9900041, 0, 9900042, 0, 9900023,
1862  5 0, 9900024, 0, 0, 0,
1863  5 0, 0, 0, 0, 0,
1864  5 0, 0, 0, 0, 0,
1865  6 24, 24, 24, 3000211, 3000211,
1866  6 3000211, 22, 3000111, 22, 3000221,
1867  6 23, 3000111, 23, 3000221, 24,
1868  6 3000211, 0, 0, 24, 23,
1869  7 24, 3000111, 3000211, 23, 3000211,
1870  7 3000111, 22, 3000211, 23, 3000211,
1871  7 24, 3000111, 24, 3000221, 22,
1872  7 24, 22, 23, 23, 23,
1873  8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1874  8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1875  9 5000039, 0, 5000039, 0, 21,
1876  9 5000039, 0, 5000039, 21, 5000039,
1877  9 10*0/
1878  DATA ((kfpr(i,j),j=1,2),i=401,500)/
1879  & 37, 6, 37, 6, 36*0,
1880  2 443, 21, 9900443, 21, 9900441,
1881  2 21, 9910441, 21, 0, 9900443,
1882  2 0, 9900441, 0, 9910441, 21,
1883  2 9900443, 21, 9900441, 21, 9910441,
1884  3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1885  3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1886  6 553, 21, 9900553, 21, 9900551,
1887  6 21, 9910551, 21, 0, 9900553,
1888  6 0, 9900551, 0, 9910551, 21,
1889  6 9900553, 21, 9900551, 21, 9910551,
1890  7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1891  7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1892  DATA coef/10000*0d0/
1893  DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/
1894  &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,
1895  &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,
1896  &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,
1897  &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,
1898  &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,
1899  &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,
1900  &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,
1901  &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,
1902  &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1903  &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/
1904 
1905 C...Treatment of resonances.
1906  DATA (mwid(i) ,i= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1907  &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1908  &81*0,21*1,4*1,25*0/
1909 
1910 C...Character constants: name of processes.
1911  DATA proc(0)/ 'All included subprocesses '/
1912  DATA (proc(i),i=1,20)/
1913  &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1914  &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1915  &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1916  &' ', 'W+ + W- -> h0 ',
1917  &' ', 'f + f'' -> f + f'' (QFD) ',
1918  1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1919  1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1920  1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1921  1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1922  1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1923  DATA (proc(i),i=21,40)/
1924  2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1925  2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1926  2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1927  2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1928  2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1929  3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1930  3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1931  3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1932  3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1933  3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1934  DATA (proc(i),i=41,60)/
1935  4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1936  4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1937  4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1938  4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1939  4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1940  5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1941  5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1942  5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1943  5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1944  5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1945  DATA (proc(i),i=61,80)/
1946  6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1947  6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1948  6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1949  6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1950  6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1951  7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1952  7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1953  7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1954  7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1955  7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1956  DATA (proc(i),i=81,100)/
1957  8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1958  8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1959  8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1960  8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1961  8'g + g -> chi_2c + g ', ' ',
1962  9'Elastic scattering ', 'Single diffractive (XB) ',
1963  9'Single diffractive (AX) ', 'Double diffractive ',
1964  9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1965  9' ', ' ',
1966  9'q + gamma* -> q ', ' '/
1967  DATA (proc(i),i=101,120)/
1968  &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1969  &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1970  &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1971  &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1972  &' ', 'f + fbar -> gamma + h0 ',
1973  1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1974  1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1975  1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1976  1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1977  1' ', ' '/
1978  DATA (proc(i),i=121,140)/
1979  2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1980  2'f + f'' -> f + f'' + h0 ',
1981  2'f + f'' -> f" + f"'' + h0 ',
1982  2' ', ' ',
1983  2' ', ' ',
1984  2' ', ' ',
1985  3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1986  3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1987  3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1988  3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1989  3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1990  DATA (proc(i),i=141,160)/
1991  4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1992  4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1993  4'q + l -> LQ ', 'e + gamma -> e* ',
1994  4'd + g -> d* ', 'u + g -> u* ',
1995  4'g + g -> eta_tc ', ' ',
1996  5'f + fbar -> H0 ', 'g + g -> H0 ',
1997  5'gamma + gamma -> H0 ', ' ',
1998  5' ', 'f + fbar -> A0 ',
1999  5'g + g -> A0 ', 'gamma + gamma -> A0 ',
2000  5' ', ' '/
2001  DATA (proc(i),i=161,180)/
2002  6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2003  6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2004  6'f + fbar -> f'' + fbar'' (g/Z)',
2005  6'f +fbar'' -> f" + fbar"'' (W) ',
2006  6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2007  6'q + qbar -> e + e* ', ' ',
2008  7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2009  7'f + f'' -> f + f'' + H0 ',
2010  7'f + f'' -> f" + f"'' + H0 ',
2011  7' ', 'f + fbar -> Z0 + A0 ',
2012  7'f + fbar'' -> W+/- + A0 ',
2013  7'f + f'' -> f + f'' + A0 ',
2014  7'f + f'' -> f" + f"'' + A0 ',
2015  7' '/
2016  DATA (proc(i),i=181,200)/
2017  8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2018  8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2019  8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2020  8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2021  8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2022  9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2023  9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2024  9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2025  9' ', ' ',
2026  9' ', ' '/
2027  DATA (proc(i),i=201,220)/
2028  &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2029  &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2030  &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2031  &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2032  &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2033  1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2034  1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2035  1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2036  1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2037  1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2038  DATA (proc(i),i=221,240)/
2039  2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2040  2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2041  2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2042  2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2043  2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2044  3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2045  3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2046  3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2047  3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2048  3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2049  DATA (proc(i),i=241,260)/
2050  4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2051  4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2052  4' ', 'qj + g -> ~qj_L + ~chi1 ',
2053  4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2054  4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2055  5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2056  5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2057  5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2058  5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2059  5'qj + g -> ~qj_R + ~g ', ' '/
2060  DATA (proc(i),i=261,300)/
2061  6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2062  6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2063  6'g + g -> ~t_2 + ~t_2bar ', ' ',
2064  6' ', ' ',
2065  6' ', ' ',
2066  7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2067  7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2068  7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2069  7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2070  7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2071  8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2072  8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2073  8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2074  8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2075  8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2076  9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2077  9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2078  9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2079  9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2080  9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2081  DATA (proc(i),i=301,340)/
2082  &'f + fbar -> H+ + H- ',
2083  &9*' ', 'g + g -> g* + g* ',
2084  &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2085  &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2086  &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2087  &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2088  &21*' '/
2089  DATA (proc(i),i=341,380)/
2090  4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2091  4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2092  4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2093  4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2094  4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2095  5'f + f -> f'' + f'' + H_L++/-- ',
2096  5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2097  5'f + fbar'' -> W_R+/- ',5*' ',
2098  6' ', 'f + fbar -> W_L+ W_L- ',
2099  6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2100  6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2101  6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2102  6'f + fbar -> W+/- pi_T-/+ ', ' ',
2103  7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2104  7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2105  7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2106  7'f + fbar'' -> W+/- pi_T0 ',
2107  7'f + fbar'' -> W+/- pi_T0'' ',
2108  7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2109  7'f + fbar -> Z0 Z0 (ETC) '/
2110  DATA (proc(i),i=381,420)/
2111  8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2112  8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2113  8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2114  8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2115  8' ', ' ',
2116  9'f + fbar -> G* ', 'g + g -> G* ',
2117  9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2118  9'g + g -> g + G* ', ' ',
2119  9 4*' ',
2120  &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2121  & 18*' '/
2122  DATA (proc(i),i=421,460)/
2123  2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2124  2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2125  2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2126  2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2127  2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2128  3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2129  3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2130  3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2131  3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2132  3'q + q~ -> g + cc~[3P2(1)] ',
2133  3 21 *' '/
2134  DATA (proc(i),i=461,500)/
2135  6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2136  6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2137  6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2138  6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2139  6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2140  7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2141  7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2142  7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2143  7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2144  7'q + q~ -> g + bb~[3P2(1)] ',
2145  7 21 *' '/
2146 
2147 C...Cross sections and slope offsets.
2148  DATA sigt/294*0d0/
2149 
2150 C...Supersymmetry switches and parameters.
2151  DATA imss/0,
2152  & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2153  1 89*0/
2154  DATA rmss/0d0,
2155  & 80d0,160d0,500d0,800d0,2d0,250d0,200d0,800d0,700d0,800d0,
2156  1 700d0,500d0,250d0,200d0,800d0,400d0,0d0,0.1d0,850d0,0.041d0,
2157  2 1d0,800d0,1d4,1d4,1d4,0d0,0d0,0d0,24d17,0d0,
2158  3 10*0d0,
2159  4 0d0,1d0,8*0d0,
2160  5 49*0d0/
2161 C...Initial values for R-violating SUSY couplings.
2162 C...Should not be changed here. See PYMSIN.
2163  DATA rvlam/27*0d0/
2164  DATA rvlamp/27*0d0/
2165  DATA rvlamb/27*0d0/
2166 
2167 C...Technicolor switches and parameters
2168  DATA itcm/0,
2169  & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2170  1 89*0/
2171  DATA rtcm/0d0,
2172  & 82d0,1.333d0,.333d0,0.408d0,1d0,1d0,.0182d0,1d0,0d0,1.333d0,
2173  1 .05d0,200d0,200d0,0d0,0d0,0d0,0d0,0d0,0d0,0d0,
2174  2 .283d0,.707d0,0d0,0d0,0d0,1.667d0,250d0,250d0,.707d0,0d0,
2175  3 .707d0,0d0,1d0,0d0,0d0,0d0,0d0,0d0,0d0,0d0,
2176  4 1000d0, 1d0, 1d0, 1d0, 1d0, 0d0, 1d0, 3*200d0,
2177  4 200d0, 48*0d0/
2178 
2179 C...UED switches and parameters.
2180 C... IUED(0) empty IUED vector element
2181 C... IUED(1) UED ON(=1)/OFF(=0) switch
2182 C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2183 C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2184 C... IUED(4) N the number of large extra dimensions
2185 C... IUED(5) Selects whether the code takes Lambda (=0)
2186 C... or Lambda*R (=1) as input.
2187 C... IUED(6) With radiative corrections to the masses (=1)
2188 C... or without (=0)
2189 C...
2190 C... RUED(0) empty RUED vector element
2191 C... RUED(1) RINV (1/R) the curvature of the extra dimension
2192 C... RUED(2) XMD the (4+N)-dimensional Planck scale
2193 C... RUED(3) LAMUED (Lambda cutoff scale)
2194 C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2195 C...
2196  DATA iued/0,0,0,5,6,0,1,93*0/
2197  DATA rued/0.d0,1000d0,5000d0,20000.,20.,95*0d0/
2198 
2199 C...Data for histogramming routines.
2200  DATA ihist/1000,20000,55,1/
2201  DATA indx/1000*0/
2202 
2203 C...Data for SUSY Les Houches Accord.
2204  DATA cpro/'PYTHIA ','PYTHIA '/
2205  DATA cver/'6.4 ','6.4 '/
2206  DATA modsel/200*0/
2207  DATA parmin/100*0d0/
2208  DATA rmsoft/101*0d0/
2209  DATA au/9*0d0/
2210  DATA ad/9*0d0/
2211  DATA ae/9*0d0/
2212 
2213  END
2214 
2215 C*********************************************************************
2216 
2217 C...PYCKBD
2218 C...Check that BLOCK DATA PYDATA has been loaded.
2219 C...Should not be required, except that some compilers/linkers
2220 C...are pretty buggy in this respect.
2221 
2222  SUBROUTINE pyckbd
2223 
2224 C...Double precision and integer declarations.
2225  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2226  IMPLICIT INTEGER(I-N)
2227  INTEGER PYK,PYCHGE,PYCOMP
2228 C...Commonblocks.
2229  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2230  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2231  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2232  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2233  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2234  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2235  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
2236 
2237 C...Check a few variables to see they have been sensibly initialized.
2238  IF(mstu(4).LT.10.OR.mstu(4).GT.900000.OR.pmas(2,1).LT.0.001d0
2239  &.OR.pmas(2,1).GT.1d0.OR.ckin(5).LT.0.01d0.OR.mstp(1).LT.1.OR.
2240  &mstp(1).GT.5) THEN
2241 C...If not, abort the run right away.
2242  WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2243  WRITE(*,*) 'The program execution is stopped now!'
2244  CALL pystop(8)
2245  ENDIF
2246 
2247  RETURN
2248  END
2249 
2250 C*********************************************************************
2251 
2252 C...PYTEST
2253 C...A simple program (disguised as subroutine) to run at installation
2254 C...as a check that the program works as intended.
2255 
2256  SUBROUTINE pytest(MTEST)
2257 
2258 C...Double precision and integer declarations.
2259  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2260  IMPLICIT INTEGER(I-N)
2261  INTEGER PYK,PYCHGE,PYCOMP
2262 C...Commonblocks.
2263  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2264  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2265  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2266  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2267  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2268  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2269  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
2270 C...Local arrays.
2271  dimension psum(5),pini(6),pfin(6)
2272 
2273 C...Save defaults for values that are changed.
2274  mstj1=mstj(1)
2275  mstj3=mstj(3)
2276  mstj11=mstj(11)
2277  mstj42=mstj(42)
2278  mstj43=mstj(43)
2279  mstj44=mstj(44)
2280  parj17=parj(17)
2281  parj22=parj(22)
2282  parj43=parj(43)
2283  parj54=parj(54)
2284  mst101=mstj(101)
2285  mst104=mstj(104)
2286  mst105=mstj(105)
2287  mst107=mstj(107)
2288  mst116=mstj(116)
2289 
2290 C...First part: loop over simple events to be generated.
2291  IF(mtest.GE.1) CALL pytabu(20)
2292  nerr=0
2293  DO 180 iev=1,500
2294 
2295 C...Reset parameter values. Switch on some nonstandard features.
2296  mstj(1)=1
2297  mstj(3)=0
2298  mstj(11)=1
2299  mstj(42)=2
2300  mstj(43)=4
2301  mstj(44)=2
2302  parj(17)=0.1d0
2303  parj(22)=1.5d0
2304  parj(43)=1d0
2305  parj(54)=-0.05d0
2306  mstj(101)=5
2307  mstj(104)=5
2308  mstj(105)=0
2309  mstj(107)=1
2310  IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
2311 
2312 C...Ten events each for some single jets configurations.
2313  IF(iev.LE.50) THEN
2314  ity=(iev+9)/10
2315  mstj(3)=-1
2316  IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
2317  IF(ity.EQ.1) CALL py1ent(1,1,15d0,0d0,0d0)
2318  IF(ity.EQ.2) CALL py1ent(1,3101,15d0,0d0,0d0)
2319  IF(ity.EQ.3) CALL py1ent(1,-2203,15d0,0d0,0d0)
2320  IF(ity.EQ.4) CALL py1ent(1,-4,30d0,0d0,0d0)
2321  IF(ity.EQ.5) CALL py1ent(1,21,15d0,0d0,0d0)
2322 
2323 C...Ten events each for some simple jet systems; string fragmentation.
2324  ELSEIF(iev.LE.130) THEN
2325  ity=(iev-41)/10
2326  IF(ity.EQ.1) CALL py2ent(1,1,-1,40d0)
2327  IF(ity.EQ.2) CALL py2ent(1,4,-4,30d0)
2328  IF(ity.EQ.3) CALL py2ent(1,2,2103,100d0)
2329  IF(ity.EQ.4) CALL py2ent(1,21,21,40d0)
2330  IF(ity.EQ.5) CALL py3ent(1,2101,21,-3203,30d0,0.6d0,0.8d0)
2331  IF(ity.EQ.6) CALL py3ent(1,5,21,-5,40d0,0.9d0,0.8d0)
2332  IF(ity.EQ.7) CALL py3ent(1,21,21,21,60d0,0.7d0,0.5d0)
2333  IF(ity.EQ.8) CALL py4ent(1,2,21,21,-2,40d0,
2334  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2335 
2336 C...Seventy events with independent fragmentation and momentum cons.
2337  ELSEIF(iev.LE.200) THEN
2338  ity=1+(iev-131)/16
2339  mstj(2)=1+mod(iev-131,4)
2340  mstj(3)=1+mod((iev-131)/4,4)
2341  IF(ity.EQ.1) CALL py2ent(1,4,-5,40d0)
2342  IF(ity.EQ.2) CALL py3ent(1,3,21,-3,40d0,0.9d0,0.4d0)
2343  IF(ity.EQ.3) CALL py4ent(1,2,21,21,-2,40d0,
2344  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2345  IF(ity.GE.4) CALL py4ent(1,2,-3,3,-2,40d0,
2346  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2347 
2348 C...A hundred events with random jets (check invariant mass).
2349  ELSEIF(iev.LE.300) THEN
2350  100 DO 110 j=1,5
2351  psum(j)=0d0
2352  110 CONTINUE
2353  njet=2d0+6d0*pyr(0)
2354  DO 130 i=1,njet
2355  kfl=21
2356  IF(i.EQ.1) kfl=int(1d0+4d0*pyr(0))
2357  IF(i.EQ.njet) kfl=-int(1d0+4d0*pyr(0))
2358  ejet=5d0+20d0*pyr(0)
2359  theta=acos(2d0*pyr(0)-1d0)
2360  phi=6.2832d0*pyr(0)
2361  IF(i.LT.njet) CALL py1ent(-i,kfl,ejet,theta,phi)
2362  IF(i.EQ.njet) CALL py1ent(i,kfl,ejet,theta,phi)
2363  IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
2364  IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+pymass(kfl)
2365  DO 120 j=1,4
2366  psum(j)=psum(j)+p(i,j)
2367  120 CONTINUE
2368  130 CONTINUE
2369  IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
2370  & (psum(5)+parj(32))**2) GOTO 100
2371 
2372 C...Fifty e+e- continuum events with matrix elements.
2373  ELSEIF(iev.LE.350) THEN
2374  mstj(101)=2
2375  CALL pyeevt(0,40d0)
2376 
2377 C...Fifty e+e- continuum event with varying shower options.
2378  ELSEIF(iev.LE.400) THEN
2379  mstj(42)=1+mod(iev,2)
2380  mstj(43)=1+mod(iev/2,4)
2381  mstj(44)=mod(iev/8,3)
2382  CALL pyeevt(0,90d0)
2383 
2384 C...Fifty e+e- continuum events with coherent shower.
2385  ELSEIF(iev.LE.450) THEN
2386  CALL pyeevt(0,500d0)
2387 
2388 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2389  ELSE
2390  CALL pyonia(5,9.46d0)
2391  ENDIF
2392 
2393 C...Generate event. Find total momentum, energy and charge.
2394  DO 140 j=1,4
2395  pini(j)=pyp(0,j)
2396  140 CONTINUE
2397  pini(6)=pyp(0,6)
2398  CALL pyexec
2399  DO 150 j=1,4
2400  pfin(j)=pyp(0,j)
2401  150 CONTINUE
2402  pfin(6)=pyp(0,6)
2403 
2404 C...Check conservation of energy, momentum and charge;
2405 C...usually exact, but only approximate for single jets.
2406  merr=0
2407  IF(iev.LE.50) THEN
2408  IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.10d0)
2409  & merr=merr+1
2410  epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
2411  IF(epzrem.LT.0d0.OR.epzrem.GT.2d0*parj(31)) merr=merr+1
2412  IF(abs(pfin(6)-pini(6)).GT.2.1d0) merr=merr+1
2413  ELSE
2414  DO 160 j=1,4
2415  IF(abs(pfin(j)-pini(j)).GT.0.0001d0*pini(4)) merr=merr+1
2416  160 CONTINUE
2417  IF(abs(pfin(6)-pini(6)).GT.0.1d0) merr=merr+1
2418  ENDIF
2419  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
2420  & (pfin(j),j=1,4),pfin(6)
2421 
2422 C...Check that all KF codes are known ones, and that partons/particles
2423 C...satisfy energy-momentum-mass relation. Store particle statistics.
2424  DO 170 i=1,n
2425  IF(k(i,1).GT.20) GOTO 170
2426  IF(pycomp(k(i,2)).EQ.0) THEN
2427  WRITE(mstu(11),5100) i
2428  merr=merr+1
2429  ENDIF
2430  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
2431  IF(abs(pd).GT.max(0.1d0,0.001d0*p(i,4)**2).OR.p(i,4).LT.0d0)
2432  & THEN
2433  WRITE(mstu(11),5200) i
2434  merr=merr+1
2435  ENDIF
2436  170 CONTINUE
2437  IF(mtest.GE.1) CALL pytabu(21)
2438 
2439 C...List all erroneous events and some normal ones.
2440  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
2441  IF(merr.GE.1) WRITE(mstu(11),6400)
2442  CALL pylist(2)
2443  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
2444  CALL pylist(1)
2445  ENDIF
2446 
2447 C...Stop execution if too many errors.
2448  IF(merr.NE.0) nerr=nerr+1
2449  IF(nerr.GE.10) THEN
2450  WRITE(mstu(11),6300)
2451  CALL pylist(1)
2452  CALL pystop(9)
2453  ENDIF
2454  180 CONTINUE
2455 
2456 C...Summarize result of run.
2457  IF(mtest.GE.1) CALL pytabu(22)
2458 
2459 C...Reset commonblock variables changed during run.
2460  mstj(1)=mstj1
2461  mstj(3)=mstj3
2462  mstj(11)=mstj11
2463  mstj(42)=mstj42
2464  mstj(43)=mstj43
2465  mstj(44)=mstj44
2466  parj(17)=parj17
2467  parj(22)=parj22
2468  parj(43)=parj43
2469  parj(54)=parj54
2470  mstj(101)=mst101
2471  mstj(104)=mst104
2472  mstj(105)=mst105
2473  mstj(107)=mst107
2474  mstj(116)=mst116
2475 
2476 C...Second part: complete events of various kinds.
2477 C...Common initial values. Loop over initiating conditions.
2478  mstp(122)=max(0,min(2,mtest))
2479  mdcy(pycomp(111),1)=0
2480  DO 230 iproc=1,8
2481 
2482 C...Reset process type, kinematics cuts, and the flags used.
2483  msel=0
2484  DO 190 isub=1,500
2485  msub(isub)=0
2486  190 CONTINUE
2487  ckin(1)=2d0
2488  ckin(3)=0d0
2489  mstp(2)=1
2490  mstp(11)=0
2491  mstp(33)=0
2492  mstp(81)=1
2493  mstp(82)=1
2494  mstp(111)=1
2495  mstp(131)=0
2496  mstp(133)=0
2497  parp(131)=0.01d0
2498 
2499 C...Prompt photon production at fixed target.
2500  IF(iproc.EQ.1) THEN
2501  pzsum=300d0
2502  pesum=sqrt(pzsum**2+pymass(211)**2)+pymass(2212)
2503  pqsum=2d0
2504  msel=10
2505  ckin(3)=5d0
2506  CALL pyinit('FIXT','pi+','p',pzsum)
2507 
2508 C...QCD processes at ISR energies.
2509  ELSEIF(iproc.EQ.2) THEN
2510  pesum=63d0
2511  pzsum=0d0
2512  pqsum=2d0
2513  msel=1
2514  ckin(3)=5d0
2515  CALL pyinit('CMS','p','p',pesum)
2516 
2517 C...W production + multiple interactions at CERN Collider.
2518  ELSEIF(iproc.EQ.3) THEN
2519  pesum=630d0
2520  pzsum=0d0
2521  pqsum=0d0
2522  msel=12
2523  ckin(1)=20d0
2524  mstp(82)=4
2525  mstp(2)=2
2526  mstp(33)=3
2527  CALL pyinit('CMS','p','pbar',pesum)
2528 
2529 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2530  ELSEIF(iproc.EQ.4) THEN
2531  pesum=1800d0
2532  pzsum=0d0
2533  pqsum=0d0
2534  msub(22)=1
2535  msub(23)=1
2536  msub(25)=1
2537  ckin(1)=200d0
2538  mstp(111)=0
2539  mstp(131)=1
2540  mstp(133)=2
2541  parp(131)=0.04d0
2542  CALL pyinit('CMS','p','pbar',pesum)
2543 
2544 C...Higgs production at LHC.
2545  ELSEIF(iproc.EQ.5) THEN
2546  pesum=15400d0
2547  pzsum=0d0
2548  pqsum=2d0
2549  msub(3)=1
2550  msub(102)=1
2551  msub(123)=1
2552  msub(124)=1
2553  pmas(25,1)=300d0
2554  ckin(1)=200d0
2555  mstp(81)=0
2556  mstp(111)=0
2557  CALL pyinit('CMS','p','p',pesum)
2558 
2559 C...Z' production at SSC.
2560  ELSEIF(iproc.EQ.6) THEN
2561  pesum=40000d0
2562  pzsum=0d0
2563  pqsum=2d0
2564  msel=21
2565  pmas(32,1)=600d0
2566  ckin(1)=400d0
2567  mstp(81)=0
2568  mstp(111)=0
2569  CALL pyinit('CMS','p','p',pesum)
2570 
2571 C...W pair production at 1 TeV e+e- collider.
2572  ELSEIF(iproc.EQ.7) THEN
2573  pesum=1000d0
2574  pzsum=0d0
2575  pqsum=0d0
2576  msub(25)=1
2577  msub(69)=1
2578  mstp(11)=1
2579  CALL pyinit('CMS','e+','e-',pesum)
2580 
2581 C...Deep inelastic scattering at a LEP+LHC ep collider.
2582  ELSEIF(iproc.EQ.8) THEN
2583  p(1,1)=0d0
2584  p(1,2)=0d0
2585  p(1,3)=8000d0
2586  p(2,1)=0d0
2587  p(2,2)=0d0
2588  p(2,3)=-80d0
2589  pesum=8080d0
2590  pzsum=7920d0
2591  pqsum=0d0
2592  msub(10)=1
2593  ckin(3)=50d0
2594  mstp(111)=0
2595  CALL pyinit('3MOM','p','e-',pesum)
2596  ENDIF
2597 
2598 C...Generate 20 events of each required type.
2599  DO 220 iev=1,20
2600  CALL pyevnt
2601  pesumm=pesum
2602  IF(iproc.EQ.4) pesumm=msti(41)*pesum
2603 
2604 C...Check conservation of energy/momentum/flavour.
2605  pini(1)=0d0
2606  pini(2)=0d0
2607  pini(3)=pzsum
2608  pini(4)=pesumm
2609  pini(6)=pqsum
2610  DO 200 j=1,4
2611  pfin(j)=pyp(0,j)
2612  200 CONTINUE
2613  pfin(6)=pyp(0,6)
2614  merr=0
2615  deve=abs(pfin(4)-pini(4))+abs(pfin(3)-pini(3))
2616  devt=abs(pfin(1)-pini(1))+abs(pfin(2)-pini(2))
2617  devq=abs(pfin(6)-pini(6))
2618  IF(deve.GT.2d-3*pesum.OR.devt.GT.max(0.01d0,1d-4*pesum).OR.
2619  & devq.GT.0.1d0) merr=1
2620  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
2621  & (pfin(j),j=1,4),pfin(6)
2622 
2623 C...Check that all KF codes are known ones, and that partons/particles
2624 C...satisfy energy-momentum-mass relation.
2625  DO 210 i=1,n
2626  IF(k(i,1).GT.20) GOTO 210
2627  IF(pycomp(k(i,2)).EQ.0) THEN
2628  WRITE(mstu(11),5100) i
2629  merr=merr+1
2630  ENDIF
2631  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2*
2632  & sign(1d0,p(i,5))
2633  IF(abs(pd).GT.max(0.1d0,0.002d0*p(i,4)**2,0.002d0*p(i,5)**2)
2634  & .OR.(p(i,5).GE.0d0.AND.p(i,4).LT.0d0)) THEN
2635  WRITE(mstu(11),5200) i
2636  merr=merr+1
2637  ENDIF
2638  210 CONTINUE
2639 
2640 C...Listing of erroneous events, and first event of each type.
2641  IF(merr.GE.1) nerr=nerr+1
2642  IF(nerr.GE.10) THEN
2643  WRITE(mstu(11),6300)
2644  CALL pylist(1)
2645  CALL pystop(9)
2646  ENDIF
2647  IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN
2648  IF(merr.GE.1) WRITE(mstu(11),6400)
2649  CALL pylist(1)
2650  ENDIF
2651  220 CONTINUE
2652 
2653 C...List statistics for each process type.
2654  IF(mtest.GE.1) CALL pystat(1)
2655  230 CONTINUE
2656 
2657 C...Summarize result of run.
2658  IF(nerr.EQ.0) WRITE(mstu(11),6500)
2659  IF(nerr.GT.0) WRITE(mstu(11),6600) nerr
2660 
2661 C...Format statements for output.
2662  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2663  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
2664  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
2665  &4(1x,f12.5),1x,f8.2)
2666  5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
2667  5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
2668  &'kinematics')
2669  6300 FORMAT(/5x,'This is the tenth error experienced! Something is ',
2670  &'wrong.'/5x,'Execution will be stopped after listing of event.')
2671  6400 FORMAT(5x,'Faulty event follows:')
2672  6500 FORMAT(//5x,'End result of PYTEST: no errors detected.')
2673  6600 FORMAT(//5x,'End result of PYTEST:',i2,' errors detected.'/
2674  &5x,'This should not have happened!')
2675 
2676  RETURN
2677  END
2678 
2679 C*********************************************************************
2680 
2681 C...PYHEPC
2682 C...Converts PYTHIA event record contents to or from
2683 C...the standard event record commonblock.
2684 
2685  SUBROUTINE pyhepc(MCONV)
2686 
2687 C...Double precision and integer declarations.
2688  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2689  IMPLICIT INTEGER(I-N)
2690  INTEGER PYK,PYCHGE,PYCOMP
2691 C...Commonblocks.
2692  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2693  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2694  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2695  SAVE /pyjets/,/pydat1/,/pydat2/
2696 C...HEPEVT commonblock.
2697  parameter(nmxhep=4000)
2698  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
2699  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
2700  DOUBLE PRECISION PHEP,VHEP
2701  SAVE /hepevt/
2702 
2703 C...Store HEPEVT commonblock size (for interfacing issues).
2704  mstu(8)=nmxhep
2705 
2706 C...Conversion from PYTHIA to standard, the easy part.
2707  IF(mconv.EQ.1) THEN
2708  nevhep=0
2709  IF(n.GT.nmxhep) CALL pyerrm(8,
2710  & '(PYHEPC:) no more space in /HEPEVT/')
2711  nhep=min(n,nmxhep)
2712  DO 150 i=1,nhep
2713  isthep(i)=0
2714  IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
2715  IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
2716  IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
2717  IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
2718  idhep(i)=k(i,2)
2719  jmohep(1,i)=k(i,3)
2720  jmohep(2,i)=0
2721  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
2722  jdahep(1,i)=k(i,4)
2723  jdahep(2,i)=k(i,5)
2724  ELSE
2725  jdahep(1,i)=0
2726  jdahep(2,i)=0
2727  ENDIF
2728  DO 100 j=1,5
2729  phep(j,i)=p(i,j)
2730  100 CONTINUE
2731  DO 110 j=1,4
2732  vhep(j,i)=v(i,j)
2733  110 CONTINUE
2734 
2735 C...Check if new event (from pileup).
2736  IF(i.EQ.1) THEN
2737  inew=1
2738  ELSE
2739  IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
2740  ENDIF
2741 
2742 C...Fill in missing mother information.
2743  IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
2744  imo1=i-2
2745  120 IF(imo1.GT.inew.AND.k(imo1+1,1).EQ.21.AND.k(imo1+1,3).EQ.0)
2746  & THEN
2747  imo1=imo1-1
2748  GOTO 120
2749  ENDIF
2750  jmohep(1,i)=imo1
2751  jmohep(2,i)=imo1+1
2752  ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
2753  i1=k(i,3)-1
2754  130 i1=i1+1
2755  IF(i1.GE.i) CALL pyerrm(8,
2756  & '(PYHEPC:) translation of inconsistent event history')
2757  IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) GOTO 130
2758  kc=pycomp(k(i1,2))
2759  IF(i1.LT.i.AND.kc.EQ.0) GOTO 130
2760  IF(i1.LT.i.AND.kchg(kc,2).EQ.0) GOTO 130
2761  jmohep(2,i)=i1
2762  ELSEIF(k(i,2).EQ.94) THEN
2763  njet=2
2764  IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
2765  IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
2766  jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
2767  IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
2768  & mod(k(i+1,4)/mstu(5),mstu(5))
2769  ENDIF
2770 
2771 C...Fill in missing daughter information.
2772  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
2773  DO 140 i1=jdahep(1,i),jdahep(2,i)
2774  i2=mod(k(i1,4)/mstu(5),mstu(5))
2775  jdahep(1,i2)=i
2776  140 CONTINUE
2777  ENDIF
2778  IF(k(i,2).GE.91.AND.k(i,2).LE.94) GOTO 150
2779  i1=jmohep(1,i)
2780  IF(i1.LE.0.OR.i1.GT.nhep) GOTO 150
2781  IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) GOTO 150
2782  IF(jdahep(1,i1).EQ.0) THEN
2783  jdahep(1,i1)=i
2784  ELSE
2785  jdahep(2,i1)=i
2786  ENDIF
2787  150 CONTINUE
2788  DO 160 i=1,nhep
2789  IF(k(i,1).NE.13.AND.k(i,1).NE.14) GOTO 160
2790  IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
2791  160 CONTINUE
2792 
2793 C...Conversion from standard to PYTHIA, the easy part.
2794  ELSE
2795  IF(nhep.GT.mstu(4)) CALL pyerrm(8,
2796  & '(PYHEPC:) no more space in /PYJETS/')
2797  n=min(nhep,mstu(4))
2798  nkq=0
2799  kqsum=0
2800  DO 190 i=1,n
2801  k(i,1)=0
2802  IF(isthep(i).EQ.1) k(i,1)=1
2803  IF(isthep(i).EQ.2) k(i,1)=11
2804  IF(isthep(i).EQ.3) k(i,1)=21
2805  k(i,2)=idhep(i)
2806  k(i,3)=jmohep(1,i)
2807  k(i,4)=jdahep(1,i)
2808  k(i,5)=jdahep(2,i)
2809  DO 170 j=1,5
2810  p(i,j)=phep(j,i)
2811  170 CONTINUE
2812  DO 180 j=1,4
2813  v(i,j)=vhep(j,i)
2814  180 CONTINUE
2815  v(i,5)=0d0
2816  IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
2817  i1=jdahep(1,i)
2818  IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
2819  & phep(5,i)/phep(4,i)
2820  ENDIF
2821 
2822 C...Fill in missing information on colour connection in jet systems.
2823  IF(isthep(i).EQ.1) THEN
2824  kc=pycomp(k(i,2))
2825  kq=0
2826  IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
2827  IF(kq.NE.0) nkq=nkq+1
2828  IF(kq.NE.2) kqsum=kqsum+kq
2829  IF(kq.NE.0.AND.kqsum.NE.0) THEN
2830  k(i,1)=2
2831  ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
2832  IF(k(i+1,2).EQ.21) k(i,1)=2
2833  ENDIF
2834  ENDIF
2835  190 CONTINUE
2836  IF(nkq.EQ.1.OR.kqsum.NE.0) CALL pyerrm(8,
2837  & '(PYHEPC:) input parton configuration not colour singlet')
2838  ENDIF
2839 
2840  END
2841 
2842 C*********************************************************************
2843 
2844 C...PYINIT
2845 C...Initializes the generation procedure; finds maxima of the
2846 C...differential cross-sections to be used for weighting.
2847 
2848  SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)
2849 
2850 C...Double precision and integer declarations.
2851  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2852  IMPLICIT INTEGER(I-N)
2853  INTEGER PYK,PYCHGE,PYCOMP
2854 C...Commonblocks.
2855  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2856  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2857  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2858  common/pydat4/chaf(500,2)
2859  CHARACTER CHAF*16
2860  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2861  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2862  common/pyint1/mint(400),vint(400)
2863  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2864  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2865  common/pypued/iued(0:99),rued(0:99)
2866  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
2867  &/pyint1/,/pyint2/,/pyint5/,/pypued/
2868 C...Local arrays and character variables.
2869  dimension alamin(20),nfin(20)
2870  CHARACTER*(*) FRAME,BEAM,TARGET
2871  CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2872 
2873 C...Interface to PDFLIB.
2874  common/w50511/nptype,ngroup,nset,mode,nfl,lo,tmas
2875  common/w50512/qcdl4,qcdl5
2876  SAVE /w50511/,/w50512/
2877  DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2878  CHARACTER*20 PARM(20)
2879  DATA VALUE/20*0d0/,parm/20*' '/
2880 
2881 C...Data:Lambda and n_f values for parton distributions..
2882  DATA alamin/0.177d0,0.239d0,0.247d0,0.2322d0,0.248d0,0.248d0,
2883  &0.192d0,0.326d0,2*0.2d0,0.2d0,0.2d0,0.29d0,0.2d0,0.4d0,5*0.2d0/,
2884  &nfin/20*4/
2885  DATA chlh/'lepton','hadron'/
2886 
2887 C...Check that BLOCK DATA PYDATA has been loaded.
2888  CALL pyckbd
2889 
2890 C...Reset MINT and VINT arrays. Write headers.
2891  msti(53)=0
2892  DO 100 j=1,400
2893  mint(j)=0
2894  vint(j)=0d0
2895  100 CONTINUE
2896  IF(mstu(12).NE.12345) CALL pylist(0)
2897  IF(mstp(122).GE.1) WRITE(mstu(11),5100)
2898 
2899 C...Reset error counters.
2900  mstu(23)=0
2901  mstu(27)=0
2902  mstu(30)=0
2903 
2904 C...Reset processes that should not be on.
2905  msub(96)=0
2906  msub(97)=0
2907 
2908 C...Select global FSR/ISR/UE parameter set = 'tune'
2909 C...See routine PYTUNE for details
2910  IF (mstp(5).NE.0) THEN
2911  mstp5=mstp(5)
2912  CALL pytune(mstp5)
2913  ENDIF
2914 
2915 C...Call user process initialization routine.
2916  IF(frame(1:1).EQ.'u'.OR.frame(1:1).EQ.'U') THEN
2917  msel=0
2918  CALL upinit
2919  msel=0
2920  ENDIF
2921 
2922 C...Maximum 4 generations; set maximum number of allowed flavours.
2923  mstp(1)=min(4,mstp(1))
2924  mstu(114)=min(mstu(114),2*mstp(1))
2925  mstp(58)=min(mstp(58),2*mstp(1))
2926 
2927 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2928  DO 120 i=-20,20
2929  vint(180+i)=0d0
2930  ia=iabs(i)
2931  IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN
2932  DO 110 j=1,mstp(1)
2933  ib=2*j-1+mod(ia,2)
2934  IF(ib.GE.6.AND.mstp(9).EQ.0) GOTO 110
2935  ipm=(5-isign(1,i))/2
2936  idc=j+mdcy(ia,2)+2
2937  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)=
2938  & vint(180+i)+vckm((ia+1)/2,(ib+1)/2)
2939  110 CONTINUE
2940  ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN
2941  vint(180+i)=1d0
2942  ENDIF
2943  120 CONTINUE
2944 
2945 C...Initialize parton distributions: PDFLIB.
2946  IF(mstp(52).EQ.2) THEN
2947  parm(1)='NPTYPE'
2948  value(1)=1
2949  parm(2)='NGROUP'
2950  value(2)=mstp(51)/1000
2951  parm(3)='NSET'
2952  value(3)=mod(mstp(51),1000)
2953  parm(4)='TMAS'
2954  value(4)=pmas(6,1)
2955  CALL pdfset(parm,VALUE)
2956  mint(93)=1000000+mstp(51)
2957  ENDIF
2958 
2959 C...Choose Lambda value to use in alpha-strong.
2960  mstu(111)=mstp(2)
2961  IF(mstp(3).GE.2) THEN
2962  alam=0.2d0
2963  nf=4
2964  IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.20) THEN
2965  alam=alamin(mstp(51))
2966  nf=nfin(mstp(51))
2967  ELSEIF(mstp(52).EQ.2.AND.nfl.EQ.5) THEN
2968  alam=qcdl5
2969  nf=5
2970  ELSEIF(mstp(52).EQ.2) THEN
2971  alam=qcdl4
2972  nf=4
2973  ENDIF
2974  parp(1)=alam
2975  parp(61)=alam
2976  parp(72)=alam
2977  paru(112)=alam
2978  mstu(112)=nf
2979  IF(mstp(3).EQ.3) parj(81)=alam
2980  ENDIF
2981 
2982 C...Initialize the UED masses and widths
2983  IF (iued(1).EQ.1) CALL pyxdin
2984 
2985 C...Initialize the SUSY generation: couplings, masses,
2986 C...decay modes, branching ratios, and so on.
2987  CALL pymsin
2988 C...Initialize widths and partial widths for resonances.
2989  CALL pyinre
2990 C...Set Z0 mass and width for e+e- routines.
2991  parj(123)=pmas(23,1)
2992  parj(124)=pmas(23,2)
2993 
2994 C...Identify beam and target particles and frame of process.
2995  chfram=frame//' '
2996  chbeam=beam//' '
2997  chtarg=TARGET//' '
2998  CALL pyinbm(chfram,chbeam,chtarg,win)
2999  IF(mint(65).EQ.1) GOTO 170
3000 
3001 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3002 C...For e-gamma allow 2 alternatives.
3003  mint(121)=1
3004  IF(mstp(14).EQ.10.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3005  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3006  & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=3
3007  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=6
3008  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3009  & (iabs(mint(11)).EQ.11.OR.iabs(mint(12)).EQ.11)) mint(121)=2
3010  ELSEIF(mstp(14).EQ.20.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3011  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3012  & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=3
3013  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=9
3014  ELSEIF(mstp(14).EQ.25.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3015  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3016  & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=2
3017  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=4
3018  ELSEIF(mstp(14).EQ.30.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3019  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3020  & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=4
3021  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=13
3022  ENDIF
3023  mint(123)=mstp(14)
3024  IF((mstp(14).EQ.10.OR.mstp(14).EQ.20.OR.mstp(14).EQ.25.OR.
3025  &mstp(14).EQ.30).AND.msel.NE.1.AND.msel.NE.2) mint(123)=0
3026  IF(mstp(14).GE.11.AND.mstp(14).LE.19) THEN
3027  IF(mstp(14).EQ.11) mint(123)=0
3028  IF(mstp(14).EQ.12.OR.mstp(14).EQ.14) mint(123)=5
3029  IF(mstp(14).EQ.13.OR.mstp(14).EQ.17) mint(123)=6
3030  IF(mstp(14).EQ.15) mint(123)=2
3031  IF(mstp(14).EQ.16.OR.mstp(14).EQ.18) mint(123)=7
3032  IF(mstp(14).EQ.19) mint(123)=3
3033  ELSEIF(mstp(14).GE.21.AND.mstp(14).LE.24) THEN
3034  IF(mstp(14).EQ.21) mint(123)=0
3035  IF(mstp(14).EQ.22.OR.mstp(14).EQ.23) mint(123)=4
3036  IF(mstp(14).EQ.24) mint(123)=1
3037  ELSEIF(mstp(14).GE.26.AND.mstp(14).LE.29) THEN
3038  IF(mstp(14).EQ.26.OR.mstp(14).EQ.28) mint(123)=8
3039  IF(mstp(14).EQ.27.OR.mstp(14).EQ.29) mint(123)=9
3040  ENDIF
3041 
3042 C...Set up kinematics of process.
3043  CALL pyinki(0)
3044 
3045 C...Set up kinematics for photons inside leptons.
3046  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(1,wtgaga)
3047 
3048 C...Precalculate flavour selection weights.
3049  CALL pykfin
3050 
3051 C...Loop over gamma-p or gamma-gamma alternatives.
3052  ckin3=ckin(3)
3053  msav48=0
3054  DO 160 iga=1,mint(121)
3055  ckin(3)=ckin3
3056  mint(122)=iga
3057 
3058 C...Select partonic subprocesses to be included in the simulation.
3059  CALL pyinpr
3060  mint(101)=1
3061  mint(102)=1
3062  mint(103)=mint(11)
3063  mint(104)=mint(12)
3064 
3065 C...Count number of subprocesses on.
3066  mint(48)=0
3067  DO 130 isub=1,500
3068  IF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
3069  & msub(isub).EQ.1.AND.mint(121).GT.1) THEN
3070  msub(isub)=0
3071  ELSEIF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
3072  & msub(isub).EQ.1) THEN
3073  WRITE(mstu(11),5200) isub,chlh(mint(41)),chlh(mint(42))
3074  CALL pystop(1)
3075  ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN
3076  WRITE(mstu(11),5300) isub
3077  CALL pystop(1)
3078  ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN
3079  WRITE(mstu(11),5400) isub
3080  CALL pystop(1)
3081  ELSEIF(msub(isub).EQ.1) THEN
3082  mint(48)=mint(48)+1
3083  ENDIF
3084  130 CONTINUE
3085 
3086 C...Stop or raise warning flag if no subprocesses on.
3087  IF(mint(121).EQ.1.AND.mint(48).EQ.0) THEN
3088  IF(mstp(127).NE.1) THEN
3089  WRITE(mstu(11),5500)
3090  CALL pystop(1)
3091  ELSE
3092  WRITE(mstu(11),5700)
3093  msti(53)=1
3094  ENDIF
3095  ENDIF
3096  mint(49)=mint(48)-msub(91)-msub(92)-msub(93)-msub(94)
3097  msav48=msav48+mint(48)
3098 
3099 C...Reset variables for cross-section calculation.
3100  DO 150 i=0,500
3101  DO 140 j=1,3
3102  ngen(i,j)=0
3103  xsec(i,j)=0d0
3104  140 CONTINUE
3105  150 CONTINUE
3106 
3107 C...Find parametrized total cross-sections.
3108  CALL pyxtot
3109  vint(318)=vint(317)
3110 
3111 C...Maxima of differential cross-sections.
3112  IF(mstp(121).LE.1) CALL pymaxi
3113 
3114 C...Initialize possibility of pileup events.
3115  IF(mint(121).GT.1) mstp(131)=0
3116  IF(mstp(131).NE.0) CALL pypile(1)
3117 
3118 C...Initialize multiple interactions with variable impact parameter.
3119  IF(mint(50).EQ.1) THEN
3120  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
3121  IF(mod(mstp(81),10).EQ.0.AND.(ckin(3).GT.ptmn.OR.
3122  & ((msel.NE.1.AND.msel.NE.2)))) mstp(82)=min(1,mstp(82))
3123  IF((mint(49).NE.0.OR.mstp(131).NE.0).AND.mstp(82).GE.2) THEN
3124  mint(35)=1
3125  CALL pymult(1)
3126  mint(35)=3
3127  CALL pymign(1)
3128  ENDIF
3129  ENDIF
3130 
3131 C...Save results for gamma-p and gamma-gamma alternatives.
3132  IF(mint(121).GT.1) CALL pysave(1,iga)
3133  160 CONTINUE
3134 
3135 C...Initialization finished.
3136  IF(msav48.EQ.0) THEN
3137  IF(mstp(127).NE.1) THEN
3138  WRITE(mstu(11),5500)
3139  CALL pystop(1)
3140  ELSE
3141  WRITE(mstu(11),5700)
3142  msti(53)=1
3143  ENDIF
3144  ENDIF
3145  170 IF(mstp(122).GE.1) WRITE(mstu(11),5600)
3146 
3147 C...Formats for initialization information.
3148  5100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',
3149  &'routines',1x,17('*'))
3150  5200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,
3151  &'-',a6,' interactions.'/1x,'Execution stopped!')
3152  5300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/
3153  &1x,'Execution stopped!')
3154  5400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/
3155  &1x,'Execution stopped!')
3156  5500 FORMAT(1x,'Error: no subprocess switched on.'/
3157  &1x,'Execution stopped.')
3158  5600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,
3159  &22('*'))
3160  5700 FORMAT(1x,'Error: no subprocess switched on.'/
3161  &1x,'Execution will stop if you try to generate events.')
3162 
3163  RETURN
3164  END
3165 
3166 C*********************************************************************
3167 
3168 C...PYEVNT
3169 C...Administers the generation of a high-pT event via calls to
3170 C...a number of subroutines.
3171 
3172  SUBROUTINE pyevnt
3173 
3174 C...Double precision and integer declarations.
3175  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3176  IMPLICIT INTEGER(I-N)
3177  INTEGER PYK,PYCHGE,PYCOMP
3178  parameter(maxnur=1000)
3179 C...Commonblocks.
3180  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
3181  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3182  common/pyctag/nct,mct(4000,2)
3183  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3184  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3185  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
3186  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3187  common/pyint1/mint(400),vint(400)
3188  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3189  common/pyint4/mwid(500),wids(500,5)
3190  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
3191  SAVE /pyjets/,/pydat1/,/pyctag/,/pydat2/,/pydat3/,/pypars/,
3192  &/pyint1/,/pyint2/,/pyint4/,/pyint5/
3193 C...Local array.
3194  dimension vtx(4)
3195 
3196 C...Optionally let PYEVNW do the whole job.
3197  IF(mstp(81).GE.20) THEN
3198  CALL pyevnw
3199  RETURN
3200  ENDIF
3201 
3202 C...Stop if no subprocesses on.
3203  IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
3204  WRITE(mstu(11),5100)
3205  CALL pystop(1)
3206  ENDIF
3207 
3208 C...Initial values for some counters.
3209  mstu(1)=0
3210  mstu(2)=0
3211  n=0
3212  mint(5)=mint(5)+1
3213  mint(7)=0
3214  mint(8)=0
3215  mint(30)=0
3216  mint(83)=0
3217  mint(84)=mstp(126)
3218  mstu(24)=0
3219  mstu70=0
3220  mstj14=mstj(14)
3221 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3222  nct=0
3223  mint(33)=0
3224 
3225 C...Let called routines know call is from PYEVNT (not PYEVNW).
3226  mint(35)=1
3227  IF (mstp(81).GE.10) mint(35)=2
3228 
3229 C...If variable energies: redo incoming kinematics and cross-section.
3230  msti(61)=0
3231  IF(mstp(171).EQ.1) THEN
3232  CALL pyinki(1)
3233  IF(msti(61).EQ.1) THEN
3234  mint(5)=mint(5)-1
3235  RETURN
3236  ENDIF
3237  IF(mint(121).GT.1) CALL pysave(3,1)
3238  CALL pyxtot
3239  ENDIF
3240 
3241 C...Loop over number of pileup events; check space left.
3242  IF(mstp(131).LE.0) THEN
3243  npile=1
3244  ELSE
3245  CALL pypile(2)
3246  npile=mint(81)
3247  ENDIF
3248  DO 270 ipile=1,npile
3249  IF(mint(84)+100.GE.mstu(4)) THEN
3250  CALL pyerrm(11,
3251  & '(PYEVNT:) no more space in PYJETS for pileup events')
3252  IF(mstu(21).GE.1) GOTO 280
3253  ENDIF
3254  mint(82)=ipile
3255 
3256 C...Generate variables of hard scattering.
3257  mint(51)=0
3258  msti(52)=0
3259  100 CONTINUE
3260  IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
3261  mint(31)=0
3262  mint(39)=0
3263  mint(51)=0
3264  mint(57)=0
3265  CALL pyrand
3266  IF(msti(61).EQ.1) THEN
3267  mint(5)=mint(5)-1
3268  RETURN
3269  ENDIF
3270  IF(mint(51).EQ.2) RETURN
3271  isub=mint(1)
3272  IF(mstp(111).EQ.-1) GOTO 260
3273 
3274 C...Loopback point if PYPREP fails, especially for junction topologies.
3275  nprep=0
3276  mnt31s=mint(31)
3277  110 nprep=nprep+1
3278  mint(31)=mnt31s
3279 
3280  IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
3281 C...Hard scattering (including low-pT):
3282 C...reconstruct kinematics and colour flow of hard scattering.
3283  mint31=mint(31)
3284  120 mint(31)=mint31
3285  mint(51)=0
3286  CALL pyscat
3287  IF(mint(51).EQ.1) GOTO 100
3288  ipu1=mint(84)+1
3289  ipu2=mint(84)+2
3290  IF(isub.EQ.95) GOTO 140
3291 
3292 C...Reset statistics on activity in event.
3293  DO 130 j=351,359
3294  mint(j)=0
3295  vint(j)=0d0
3296  130 CONTINUE
3297 
3298 C...Showering of initial state partons (optional).
3299  nfin=n
3300  alamsv=parj(81)
3301  parj(81)=parp(72)
3302  IF(mstp(61).GE.1.AND.mint(47).GE.2.AND.mint(111).NE.12)
3303  & CALL pysspa(ipu1,ipu2)
3304  parj(81)=alamsv
3305  IF(mint(51).EQ.1) GOTO 100
3306 
3307 C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3308  IF (npart.GE.2.AND.(mstj(41).EQ.11.OR.mstj(41).EQ.12)) THEN
3309  ptmax=0.5*sqrt(parp(71))*vint(55)
3310  CALL pyptfs(3,ptmax,0d0,ptgen)
3311  ENDIF
3312 
3313 C...Showering of final state partons (optional).
3314  alamsv=parj(81)
3315  parj(81)=parp(72)
3316  IF(mstp(71).GE.1.AND.iset(isub).GE.2.AND.iset(isub).LE.10)
3317  & THEN
3318  ipu3=mint(84)+3
3319  ipu4=mint(84)+4
3320  IF(iset(isub).EQ.5) ipu4=-3
3321  qmax=vint(55)
3322  IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
3323  CALL pyshow(ipu3,ipu4,qmax)
3324  ELSEIF(iset(isub).EQ.11) THEN
3325  CALL pyadsh(nfin)
3326  ENDIF
3327  parj(81)=alamsv
3328 
3329 C...Allow possibility for user to abort event generation.
3330  iveto=0
3331  IF(ipile.EQ.1.AND.mstp(143).EQ.1) CALL pyveto(iveto)
3332  IF(iveto.EQ.1) GOTO 100
3333 
3334 C...Decay of final state resonances.
3335  mint(32)=0
3336  IF(mstp(41).GE.1.AND.iset(isub).LE.10) CALL pyresd(0)
3337  IF(mint(51).EQ.1) GOTO 100
3338  mint(52)=n
3339 
3340 
3341 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3342  140 IF(mstp(81).GE.10.AND.mint(50).EQ.1) THEN
3343  IF(isub.EQ.95) mint(31)=mint(31)+1
3344  CALL pymign(6)
3345  IF(mint(51).EQ.1) GOTO 100
3346  mint(53)=n
3347 
3348 C...Beam remnant flavour and colour assignments - new scheme.
3349  CALL pymihk
3350  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3351  & GOTO 120
3352  IF(mint(51).EQ.1) GOTO 100
3353 
3354 C...Primordial kT and beam remnant momentum sharing - new scheme.
3355  CALL pymirm
3356  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3357  & GOTO 120
3358  IF(mint(51).EQ.1) GOTO 100
3359  IF(isub.EQ.95) mint(31)=mint(31)-1
3360 
3361 C...Multiple interactions - PYTHIA 6.2 style.
3362  ELSEIF(mint(111).NE.12) THEN
3363  IF (mstp(81).GE.1.AND.mint(50).EQ.1.AND.isub.NE.95) THEN
3364  CALL pymult(6)
3365  mint(53)=n
3366  ENDIF
3367 
3368 C...Hadron remnants and primordial kT.
3369  CALL pyremn(ipu1,ipu2)
3370  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) GOTO
3371  & 110
3372  IF(mint(51).EQ.1) GOTO 100
3373  ENDIF
3374 
3375  ELSEIF(isub.NE.99) THEN
3376 C...Diffractive and elastic scattering.
3377  CALL pydiff
3378 
3379  ELSE
3380 C...DIS scattering (photon flux external).
3381  CALL pydisg
3382  IF(mint(51).EQ.1) GOTO 100
3383  ENDIF
3384 
3385 C...Check that no odd resonance left undecayed.
3386  mint(54)=n
3387  IF(mstp(111).GE.1) THEN
3388  nfix=n
3389  DO 150 i=mint(84)+1,nfix
3390  IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
3391  & k(i,2).NE.22) THEN
3392  kca=pycomp(k(i,2))
3393  IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
3394  CALL pyresd(i)
3395  IF(mint(51).EQ.1) GOTO 100
3396  ENDIF
3397  ENDIF
3398  150 CONTINUE
3399  ENDIF
3400 
3401 C...Boost hadronic subsystem to overall rest frame.
3402 C..(Only relevant when photon inside lepton beam.)
3403  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
3404 
3405 C...Recalculate energies from momenta and masses (if desired).
3406  IF(mstp(113).GE.1) THEN
3407  DO 160 i=mint(83)+1,n
3408  IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
3409  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3410  160 CONTINUE
3411  nrecal=n
3412  ENDIF
3413 
3414 C...Colour reconnection before string formation
3415  IF (mstp(95).GE.2) CALL pyfscr(mint(84)+1)
3416 
3417 C...Rearrange partons along strings, check invariant mass cuts.
3418  mstu(28)=0
3419  IF(mstp(111).LE.0) mstj(14)=-1
3420  CALL pyprep(mint(84)+1)
3421  mstj(14)=mstj14
3422  IF(mint(51).EQ.1.AND.mstu(24).EQ.1) THEN
3423  mstu(24)=0
3424  GOTO 100
3425  ENDIF
3426  IF (mint(51).EQ.1.AND.nprep.LE.5) GOTO 110
3427  IF (mint(51).EQ.1) GOTO 100
3428  IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) GOTO 100
3429  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
3430  DO 190 i=mint(84)+1,n
3431  IF(k(i,2).EQ.94) THEN
3432  DO 180 i1=i+1,min(n,i+10)
3433  IF(k(i1,3).EQ.i) THEN
3434  k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
3435  IF(k(i1,3).EQ.0) THEN
3436  DO 170 ii=mint(84)+1,i-1
3437  IF(k(ii,2).EQ.k(i1,2)) THEN
3438  IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
3439  & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
3440  ENDIF
3441  170 CONTINUE
3442  IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
3443  ENDIF
3444  ENDIF
3445  180 CONTINUE
3446  ENDIF
3447  190 CONTINUE
3448  CALL pyedit(12)
3449  CALL pyedit(14)
3450  IF(mstp(125).EQ.0) CALL pyedit(15)
3451  IF(mstp(125).EQ.0) mint(4)=0
3452  DO 210 i=mint(83)+1,n
3453  IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
3454  DO 200 i1=i+1,n
3455  IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
3456  IF(k(i1,3).EQ.i) k(i,5)=i1
3457  200 CONTINUE
3458  ENDIF
3459  210 CONTINUE
3460  ENDIF
3461 
3462 C...Introduce separators between sections in PYLIST event listing.
3463  IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
3464  mstu70=1
3465  mstu(71)=n
3466  ELSEIF(ipile.EQ.1) THEN
3467  mstu70=3
3468  mstu(71)=2
3469  mstu(72)=mint(4)
3470  mstu(73)=n
3471  ENDIF
3472 
3473 C...Go back to lab frame (needed for vertices, also in fragmentation).
3474  CALL pyfram(1)
3475 
3476 C...Set nonvanishing production vertex (optional).
3477  IF(mstp(151).EQ.1) THEN
3478  DO 220 j=1,4
3479  vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
3480  & sin(paru(2)*pyr(0))
3481  220 CONTINUE
3482  DO 240 i=mint(83)+1,n
3483  DO 230 j=1,4
3484  v(i,j)=v(i,j)+vtx(j)
3485  230 CONTINUE
3486  240 CONTINUE
3487  ENDIF
3488 
3489 C...Perform hadronization (if desired).
3490  IF(mstp(111).GE.1) THEN
3491  CALL pyexec
3492  IF(mstu(24).NE.0) GOTO 100
3493  ENDIF
3494  IF(mstp(113).GE.1) THEN
3495  DO 250 i=nrecal,n
3496  IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
3497  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3498  250 CONTINUE
3499  ENDIF
3500  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
3501 
3502 C...Store event information and calculate Monte Carlo estimates of
3503 C...subprocess cross-sections.
3504  260 IF(ipile.EQ.1) CALL pydocu
3505 
3506 C...Set counters for current pileup event and loop to next one.
3507  msti(41)=ipile
3508  IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
3509  IF(mstu70.LT.10) THEN
3510  mstu70=mstu70+1
3511  mstu(70+mstu70)=n
3512  ENDIF
3513  mint(83)=n
3514  mint(84)=n+mstp(126)
3515  IF(ipile.LT.npile) CALL pyfram(2)
3516  270 CONTINUE
3517 
3518 C...Generic information on pileup events. Reconstruct missing history.
3519  IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
3520  pari(91)=vint(132)
3521  pari(92)=vint(133)
3522  pari(93)=vint(134)
3523  IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
3524  ENDIF
3525  CALL pyedit(16)
3526 
3527 C...Transform to the desired coordinate frame.
3528  280 CALL pyfram(mstp(124))
3529  mstu(70)=mstu70
3530  paru(21)=vint(1)
3531 
3532 C...Error messages
3533  5100 FORMAT(1x,'Error: no subprocess switched on.'/
3534  &1x,'Execution stopped.')
3535 
3536  RETURN
3537  END
3538 
3539 C*********************************************************************
3540 
3541 C...PYEVNW
3542 C...Administers the generation of a high-pT event via calls to
3543 C...a number of subroutines for the new multiple interactions and
3544 C...showering framework.
3545 
3546  SUBROUTINE pyevnw
3547 
3548 C...Double precision and integer declarations.
3549  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3550  IMPLICIT INTEGER(I-N)
3551  INTEGER PYK,PYCHGE,PYCOMP
3552  parameter(maxnur=1000)
3553 C...Commonblocks.
3554  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
3555 C...Commonblocks.
3556  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3557  common/pyctag/nct,mct(4000,2)
3558  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3559  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3560  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
3561  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3562  common/pyint1/mint(400),vint(400)
3563  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3564  common/pyint4/mwid(500),wids(500,5)
3565  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
3566  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
3567  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
3568  & xmi(2,240),pt2mi(240),imisep(0:240)
3569  SAVE /pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,
3570  & /pypars/,/pyint1/,/pyint2/,/pyint4/,/pyint5/,/pyintm/
3571 C...Local arrays.
3572  dimension vtx(4)
3573 
3574 C...Stop if no subprocesses on.
3575  IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
3576  WRITE(mstu(11),5100)
3577  CALL pystop(1)
3578  ENDIF
3579 
3580 C...Initial values for some counters.
3581  mstu(1)=0
3582  mstu(2)=0
3583  n=0
3584  mint(5)=mint(5)+1
3585  mint(7)=0
3586  mint(8)=0
3587  mint(30)=0
3588  mint(83)=0
3589  mint(84)=mstp(126)
3590  mstu(24)=0
3591  mstu70=0
3592  mstj14=mstj(14)
3593 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3594  nct=0
3595  mint(33)=0
3596 C...Zero counters for pT-ordered showers (failsafe)
3597  npart=0
3598  npartd=0
3599 
3600 C...Let called routines know call is from PYEVNW (not PYEVNT).
3601  mint(35)=3
3602 
3603 C...If variable energies: redo incoming kinematics and cross-section.
3604  msti(61)=0
3605  IF(mstp(171).EQ.1) THEN
3606  CALL pyinki(1)
3607  IF(msti(61).EQ.1) THEN
3608  mint(5)=mint(5)-1
3609  RETURN
3610  ENDIF
3611  IF(mint(121).GT.1) CALL pysave(3,1)
3612  CALL pyxtot
3613  ENDIF
3614 
3615 C...Loop over number of pileup events; check space left.
3616  IF(mstp(131).LE.0) THEN
3617  npile=1
3618  ELSE
3619  CALL pypile(2)
3620  npile=mint(81)
3621  ENDIF
3622  DO 300 ipile=1,npile
3623  IF(mint(84)+100.GE.mstu(4)) THEN
3624  CALL pyerrm(11,
3625  & '(PYEVNW:) no more space in PYJETS for pileup events')
3626  IF(mstu(21).GE.1) GOTO 310
3627  ENDIF
3628  mint(82)=ipile
3629 
3630 C...Generate variables of hard scattering.
3631  mint(51)=0
3632  msti(52)=0
3633  loophs =0
3634  100 CONTINUE
3635  loophs = loophs + 1
3636  IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
3637  IF(loophs.GE.10) THEN
3638  CALL pyerrm(19,'(PYEVNW:) failed to evolve shower or '
3639  & //'multiple interactions. Returning.')
3640  mint(51)=1
3641  RETURN
3642  ENDIF
3643  mint(31)=0
3644  mint(39)=0
3645  mint(36)=0
3646  mint(51)=0
3647  mint(57)=0
3648  CALL pyrand
3649  IF(msti(61).EQ.1) THEN
3650  mint(5)=mint(5)-1
3651  RETURN
3652  ENDIF
3653  IF(mint(51).EQ.2) RETURN
3654  isub=mint(1)
3655  IF(mstp(111).EQ.-1) GOTO 290
3656 
3657 C...Loopback point if PYPREP fails, especially for junction topologies.
3658  nprep=0
3659  mnt31s=mint(31)
3660  110 nprep=nprep+1
3661  mint(31)=mnt31s
3662 
3663  IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
3664 C...Hard scattering (including low-pT):
3665 C...reconstruct kinematics and colour flow of hard scattering.
3666  mint31=mint(31)
3667  120 mint(31)=mint31
3668  mint(51)=0
3669  CALL pyscat
3670  IF(mint(51).EQ.1) GOTO 100
3671  npartd=n
3672  nfin=n
3673 
3674 C...Intertwined initial state showers and multiple interactions.
3675 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3676 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3677  mstp61=mstp(61)
3678  IF (mint(47).LT.2) mstp(61)=0
3679  mstp81=mstp(81)
3680  IF (mint(50).EQ.0) mstp(81)=0
3681  IF ((mstp(61).GE.1.OR.mod(mstp(81),10).GE.0).AND.
3682  & mint(111).NE.12) THEN
3683 C...Absolute max pT2 scale for evolution: phase space limit.
3684  pt2mxs=0.25d0*vint(2)
3685 C...Check if more constrained by ISR and MI max scales:
3686  pt2mxs=min(pt2mxs,max(vint(56),vint(62)))
3687 C...Loopback point in case of failure in evolution.
3688  loop=0
3689  130 loop=loop+1
3690  mint(51)=0
3691  IF(loop.GT.100) THEN
3692  CALL pyerrm(9,'(PYEVNW:) failed to evolve shower or '
3693  & //'multiple interactions. Trying new point.')
3694  mint(51)=1
3695  RETURN
3696  ENDIF
3697 
3698 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3699 C...once per event. (E.g. compute constants and save variables to be
3700 C...restored later in case of failure.)
3701  IF (loop.EQ.1) CALL pyevol(-1,dummy1,dummy2)
3702 
3703 C...Initialize interleaved MI/ISR/JI evolution.
3704 C...PT2MAX: absolute upper limit for evolution - Initialization may
3705 C... return a PT2MAX which is lower than this.
3706 C...PT2MIN: absolute lower limit for evolution - Initialization may
3707 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3708  pt2max=pt2mxs
3709  pt2min=0d0
3710  CALL pyevol(0,pt2max,pt2min)
3711 C...If failed to initialize evolution, generate a new hard process
3712  IF (mint(51).EQ.1) GOTO 100
3713 
3714 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3715 C...In principle factorized, so can be stopped and restarted.
3716 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3717 C PT2MED=MAX(10D0**2,PT2MIN)
3718 C CALL PYEVOL(1,PT2MAX,PT2MED)
3719 C IF (MINT(51).EQ.1) GOTO 160
3720 C PT2MAX=PT2MED
3721  CALL pyevol(1,pt2max,pt2min)
3722 C...If fatal error (e.g., massive hard-process initiator, but no available
3723 C...phase space for creation), generate a new hard process
3724  IF (mint(51).EQ.2) GOTO 100
3725 C...If smaller error, just try running evolution again
3726  IF (mint(51).EQ.1) GOTO 130
3727 
3728 C...Finalize interleaved MI/ISR/JI evolution.
3729  CALL pyevol(2,pt2max,pt2min)
3730  IF (mint(51).EQ.1) GOTO 130
3731 
3732  ENDIF
3733  mstp(61)=mstp61
3734  mstp(81)=mstp81
3735  IF(mint(51).EQ.1) GOTO 100
3736 C...(MINT(52) is actually obsolete in this routine. Set anyway
3737 C...to ensure PYDOCU stable.)
3738  mint(52)=n
3739  mint(53)=n
3740 
3741 C...Beam remnants - new scheme.
3742  140 IF(mint(50).EQ.1) THEN
3743  IF (isub.EQ.95) mint(31)=1
3744 
3745 C...Beam remnant flavour and colour assignments - new scheme.
3746  CALL pymihk
3747  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3748  & GOTO 120
3749  IF(mint(51).EQ.1) GOTO 100
3750 
3751 C...Primordial kT and beam remnant momentum sharing - new scheme.
3752  CALL pymirm
3753  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3754  & GOTO 120
3755  IF(mint(51).EQ.1) GOTO 100
3756  IF (isub.EQ.95) mint(31)=0
3757  ELSEIF(mint(111).NE.12) THEN
3758 C...Hadron remnants and primordial kT - old model.
3759 C...Happens e.g. for direct photon on one side.
3760  ipu1=imi(1,1,1)
3761  ipu2=imi(2,1,1)
3762  CALL pyremn(ipu1,ipu2)
3763  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) GOTO
3764  & 110
3765  IF(mint(51).EQ.1) GOTO 100
3766 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3767  DO 160 i=mint(53)+1,n
3768  DO 150 kcs=4,5
3769  ida=mod(k(i,kcs),mstu(5))
3770  IF (ida.NE.0) THEN
3771  mct(i,kcs-3)=mct(ida,6-kcs)
3772  ELSE
3773  mct(i,kcs-3)=0
3774  ENDIF
3775  150 CONTINUE
3776  160 CONTINUE
3777 C...Instruct PYPREP to use colour tags
3778  mint(33)=1
3779 
3780  DO 360 mqgst=1,2
3781  DO 350 i=mint(84)+1,n
3782 
3783 C...Look for coloured string endpoint, or (later) leftover gluon.
3784  IF (k(i,1).NE.3) GOTO 350
3785  kc=pycomp(k(i,2))
3786  IF(kc.EQ.0) GOTO 350
3787  kq=kchg(kc,2)
3788  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 350
3789 
3790 C... Pick up loose string end with no previous tag.
3791  kcs=4
3792  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
3793  IF(mct(i,kcs-3).NE.0) GOTO 350
3794 
3795  CALL pycttr(i,kcs,i)
3796  IF(mint(51).NE.0) RETURN
3797 
3798  350 CONTINUE
3799  360 CONTINUE
3800 C...Now delete any colour processing information if set (since partons
3801 C...otherwise not FS showered!)
3802  DO 170 i=mint(84)+1,n
3803  IF (i.LE.n) THEN
3804  k(i,4)=mod(k(i,4),mstu(5)**2)
3805  k(i,5)=mod(k(i,5),mstu(5)**2)
3806  ENDIF
3807  170 CONTINUE
3808  ENDIF
3809 
3810 C...Showering of final state partons (optional).
3811  alamsv=parj(81)
3812  parj(81)=parp(72)
3813  IF(mstp(71).GE.1.AND.iset(isub).GE.1.AND.iset(isub).LE.10)
3814  & THEN
3815  qmax=vint(55)
3816  IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
3817  CALL pyptfs(1,qmax,0d0,ptgen)
3818 C...External processes: handle successive showers.
3819  ELSEIF(iset(isub).EQ.11) THEN
3820  CALL pyadsh(nfin)
3821  ENDIF
3822  parj(81)=alamsv
3823 
3824 C...Allow possibility for user to abort event generation.
3825  iveto=0
3826  IF(ipile.EQ.1.AND.mstp(143).EQ.1) CALL pyveto(iveto) ! sm
3827  IF(iveto.EQ.1) GOTO 100
3828 
3829 
3830 C...Decay of final state resonances.
3831  mint(32)=0
3832  IF(mstp(41).GE.1.AND.iset(isub).LE.10) THEN
3833  CALL pyresd(0)
3834  IF(mint(51).NE.0) GOTO 100
3835  ENDIF
3836 
3837  IF(mint(51).EQ.1) GOTO 100
3838 
3839  ELSEIF(isub.NE.99) THEN
3840 C...Diffractive and elastic scattering.
3841  CALL pydiff
3842 
3843  ELSE
3844 C...DIS scattering (photon flux external).
3845  CALL pydisg
3846  IF(mint(51).EQ.1) GOTO 100
3847  ENDIF
3848 
3849 C...Check that no odd resonance left undecayed.
3850  mint(54)=n
3851  IF(mstp(111).GE.1) THEN
3852  nfix=n
3853  DO 180 i=mint(84)+1,nfix
3854  IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
3855  & k(i,2).NE.22) THEN
3856  kca=pycomp(k(i,2))
3857  IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
3858  CALL pyresd(i)
3859  IF(mint(51).EQ.1) GOTO 100
3860  ENDIF
3861  ENDIF
3862  180 CONTINUE
3863  ENDIF
3864 
3865 C...Boost hadronic subsystem to overall rest frame.
3866 C..(Only relevant when photon inside lepton beam.)
3867  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
3868 
3869 C...Recalculate energies from momenta and masses (if desired).
3870  IF(mstp(113).GE.1) THEN
3871  DO 190 i=mint(83)+1,n
3872  IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
3873  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3874  190 CONTINUE
3875  nrecal=n
3876  ENDIF
3877 
3878 C...Colour reconnection before string formation
3879  CALL pyfscr(mint(84)+1)
3880 
3881 C...Rearrange partons along strings, check invariant mass cuts.
3882  mstu(28)=0
3883  IF(mstp(111).LE.0) mstj(14)=-1
3884  CALL pyprep(mint(84)+1)
3885  mstj(14)=mstj14
3886  IF(mint(51).EQ.1.AND.mstu(24).EQ.1) THEN
3887  mstu(24)=0
3888  GOTO 100
3889  ENDIF
3890  IF(mint(51).EQ.1) GOTO 110
3891  IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) GOTO 100
3892  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
3893  DO 220 i=mint(84)+1,n
3894  IF(k(i,2).EQ.94) THEN
3895  DO 210 i1=i+1,min(n,i+10)
3896  IF(k(i1,3).EQ.i) THEN
3897  k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
3898  IF(k(i1,3).EQ.0) THEN
3899  DO 200 ii=mint(84)+1,i-1
3900  IF(k(ii,2).EQ.k(i1,2)) THEN
3901  IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
3902  & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
3903  ENDIF
3904  200 CONTINUE
3905  IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
3906  ENDIF
3907  ENDIF
3908  210 CONTINUE
3909 CC...Also collapse particles decaying to themselves (if same KS)
3910  ELSEIF (k(i,1).GT.0.AND.k(i,4).EQ.k(i,5).AND.k(i,4).GT.0
3911  & .AND.k(i,4).LT.n) THEN
3912  ida=k(i,4)
3913  IF (k(ida,1).EQ.k(i,1).AND.k(ida,2).EQ.k(i,2)) THEN
3914  k(i,1)=0
3915  ENDIF
3916  ENDIF
3917  220 CONTINUE
3918  CALL pyedit(12)
3919  CALL pyedit(14)
3920  IF(mstp(125).EQ.0) CALL pyedit(15)
3921  IF(mstp(125).EQ.0) mint(4)=0
3922  DO 240 i=mint(83)+1,n
3923  IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
3924  DO 230 i1=i+1,n
3925  IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
3926  IF(k(i1,3).EQ.i) k(i,5)=i1
3927  230 CONTINUE
3928  ENDIF
3929  240 CONTINUE
3930  ENDIF
3931 
3932 C...Introduce separators between sections in PYLIST event listing.
3933  IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
3934  mstu70=1
3935  mstu(71)=n
3936  ELSEIF(ipile.EQ.1) THEN
3937  mstu70=3
3938  mstu(71)=2
3939  mstu(72)=mint(4)
3940  mstu(73)=n
3941  ENDIF
3942 
3943 C...Go back to lab frame (needed for vertices, also in fragmentation).
3944  CALL pyfram(1)
3945 
3946 C...Set nonvanishing production vertex (optional).
3947  IF(mstp(151).EQ.1) THEN
3948  DO 250 j=1,4
3949  vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
3950  & sin(paru(2)*pyr(0))
3951  250 CONTINUE
3952  DO 270 i=mint(83)+1,n
3953  DO 260 j=1,4
3954  v(i,j)=v(i,j)+vtx(j)
3955  260 CONTINUE
3956  270 CONTINUE
3957  ENDIF
3958 
3959 C...Perform hadronization (if desired).
3960  IF(mstp(111).GE.1) THEN
3961  CALL pyexec
3962  IF(mstu(24).NE.0) GOTO 100
3963  ENDIF
3964  IF(mstp(113).GE.1) THEN
3965  DO 280 i=nrecal,n
3966  IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
3967  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3968  280 CONTINUE
3969  ENDIF
3970  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
3971 
3972 C...Store event information and calculate Monte Carlo estimates of
3973 C...subprocess cross-sections.
3974  290 IF(ipile.EQ.1) CALL pydocu
3975 
3976 C...Set counters for current pileup event and loop to next one.
3977  msti(41)=ipile
3978  IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
3979  IF(mstu70.LT.10) THEN
3980  mstu70=mstu70+1
3981  mstu(70+mstu70)=n
3982  ENDIF
3983  mint(83)=n
3984  mint(84)=n+mstp(126)
3985  IF(ipile.LT.npile) CALL pyfram(2)
3986  300 CONTINUE
3987 
3988 C...Generic information on pileup events. Reconstruct missing history.
3989  IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
3990  pari(91)=vint(132)
3991  pari(92)=vint(133)
3992  pari(93)=vint(134)
3993  IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
3994  ENDIF
3995  CALL pyedit(16)
3996 
3997 C...Transform to the desired coordinate frame.
3998  310 CALL pyfram(mstp(124))
3999  mstu(70)=mstu70
4000  paru(21)=vint(1)
4001 
4002 C...Error messages
4003  5100 FORMAT(1x,'Error: no subprocess switched on.'/
4004  &1x,'Execution stopped.')
4005 
4006  RETURN
4007  END
4008 
4009 
4010 C***********************************************************************
4011 
4012 C...PYSTAT
4013 C...Prints out information about cross-sections, decay widths, branching
4014 C...ratios, kinematical limits, status codes and parameter values.
4015 
4016  SUBROUTINE pystat(MSTAT)
4017 
4018 C...Double precision and integer declarations.
4019  IMPLICIT DOUBLE PRECISION(a-h, o-z)
4020  IMPLICIT INTEGER(I-N)
4021  INTEGER PYK,PYCHGE,PYCOMP
4022 C...Parameter statement to help give large particle numbers.
4023  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
4024  &kexcit=4000000,kdimen=5000000)
4025  parameter(eps=1d-3)
4026 C...Commonblocks.
4027  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4028  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4029  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
4030  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
4031  common/pypars/mstp(200),parp(200),msti(200),pari(200)
4032  common/pyint1/mint(400),vint(400)
4033  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4034  common/pyint4/mwid(500),wids(500,5)
4035  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
4036  common/pyint6/proc(0:500)
4037  CHARACTER PROC*28, CHTMP*16
4038  common/pymssm/imss(0:99),rmss(0:99)
4039  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
4040  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
4041  &/pyint2/,/pyint4/,/pyint5/,/pyint6/,/pymssm/,/pymsrv/
4042 C...Local arrays, character variables and data.
4043  dimension wdtp(0:400),wdte(0:400,0:5),nmodes(0:20),pbrat(10)
4044  CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4045  &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4046  &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4047  CHARACTER*24 CHD0, CHDC(10)
4048  CHARACTER*6 DNAME(3)
4049  DATA proga/
4050  &'VMD/hadron * VMD ','VMD/hadron * direct ',
4051  &'VMD/hadron * anomalous ','direct * direct ',
4052  &'direct * anomalous ','anomalous * anomalous '/
4053  DATA disga/'e * VMD','e * anomalous'/
4054  DATA progg9/
4055  &'direct * direct ','direct * VMD ',
4056  &'direct * anomalous ','VMD * direct ',
4057  &'VMD * VMD ','VMD * anomalous ',
4058  &'anomalous * direct ','anomalous * VMD ',
4059  &'anomalous * anomalous ','DIS * VMD ',
4060  &'DIS * anomalous ','VMD * DIS ',
4061  &'anomalous * DIS '/
4062  DATA progg4/
4063  &'direct * direct ','direct * resolved ',
4064  &'resolved * direct ','resolved * resolved '/
4065  DATA progg2/
4066  &'direct * hadron ','resolved * hadron '/
4067  DATA progp4/
4068  &'VMD * hadron ','direct * hadron ',
4069  &'anomalous * hadron ','DIS * hadron '/
4070  DATA state/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4071  &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4072  &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4073  &' y*_small ',' eta*_large ',' eta*_small ',
4074  &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4075  &' x_2 ',' x_F ',' cos(theta_hard) ',
4076  &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4077  &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4078  &' tau'' '/
4079  DATA dname /'q ','lepton','nu '/
4080 
4081 C...Cross-sections.
4082  IF(mstat.LE.1) THEN
4083  IF(mint(121).GT.1) CALL pysave(5,0)
4084  WRITE(mstu(11),5000)
4085  WRITE(mstu(11),5100)
4086  WRITE(mstu(11),5200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)
4087  DO 100 i=1,500
4088  IF(msub(i).NE.1) GOTO 100
4089  WRITE(mstu(11),5200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)
4090  100 CONTINUE
4091  IF(mint(121).GT.1) THEN
4092  WRITE(mstu(11),5300)
4093  DO 110 iga=1,mint(121)
4094  CALL pysave(3,iga)
4095  IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
4096  WRITE(mstu(11),5200) iga,disga(iga),ngen(0,3),ngen(0,1),
4097  & xsec(0,3)
4098  ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
4099  WRITE(mstu(11),5200) iga,progg9(iga),ngen(0,3),ngen(0,1),
4100  & xsec(0,3)
4101  ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.30) THEN
4102  WRITE(mstu(11),5200) iga,progp4(iga),ngen(0,3),ngen(0,1),
4103  & xsec(0,3)
4104  ELSEIF(mint(121).EQ.4) THEN
4105  WRITE(mstu(11),5200) iga,progg4(iga),ngen(0,3),ngen(0,1),
4106  & xsec(0,3)
4107  ELSEIF(mint(121).EQ.2) THEN
4108  WRITE(mstu(11),5200) iga,progg2(iga),ngen(0,3),ngen(0,1),
4109  & xsec(0,3)
4110  ELSE
4111  WRITE(mstu(11),5200) iga,proga(iga),ngen(0,3),ngen(0,1),
4112  & xsec(0,3)
4113  ENDIF
4114  110 CONTINUE
4115  CALL pysave(5,0)
4116  ENDIF
4117  WRITE(mstu(11),5400) mstu(23),mstu(30),mstu(27),
4118  & 1d0-dble(ngen(0,3))/max(1d0,dble(ngen(0,2)))
4119 
4120 C...Decay widths and branching ratios.
4121  ELSEIF(mstat.EQ.2) THEN
4122  WRITE(mstu(11),5500)
4123  WRITE(mstu(11),5600)
4124  DO 140 kc=1,500
4125  kf=kchg(kc,4)
4126  CALL pyname(kf,chkf)
4127  ioff=0
4128  IF(kc.LE.22) THEN
4129  IF(kc.GT.2*mstp(1).AND.kc.LE.10) GOTO 140
4130  IF(kc.GT.10+2*mstp(1).AND.kc.LE.20) GOTO 140
4131  IF(kc.LE.5.OR.(kc.GE.11.AND.kc.LE.16)) ioff=1
4132  IF(kc.EQ.18.AND.pmas(18,1).LT.1d0) ioff=1
4133  IF(kc.EQ.21.OR.kc.EQ.22) ioff=1
4134  ELSE
4135  IF(mwid(kc).LE.0) GOTO 140
4136  IF(imss(1).LE.0.AND.(kf/ksusy1.EQ.1.OR.
4137  & kf/ksusy1.EQ.2)) GOTO 140
4138  ENDIF
4139 C...Off-shell branchings.
4140  IF(ioff.EQ.1) THEN
4141  ngp=0
4142  IF(kc.LE.20) ngp=(mod(kc,10)+1)/2
4143  IF(ngp.LE.mstp(1)) WRITE(mstu(11),5700) kf,chkf(1:10),
4144  & pmas(kc,1),0d0,0d0,state(mdcy(kc,1)),0d0
4145  DO 120 j=1,mdcy(kc,3)
4146  idc=j+mdcy(kc,2)-1
4147  ngp1=0
4148  IF(iabs(kfdp(idc,1)).LE.20) ngp1=
4149  & (mod(iabs(kfdp(idc,1)),10)+1)/2
4150  ngp2=0
4151  IF(iabs(kfdp(idc,2)).LE.20) ngp2=
4152  & (mod(iabs(kfdp(idc,2)),10)+1)/2
4153  CALL pyname(kfdp(idc,1),chd1)
4154  CALL pyname(kfdp(idc,2),chd2)
4155  IF(kfdp(idc,3).EQ.0) THEN
4156  IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
4157  & ngp2.LE.mstp(1)) WRITE(mstu(11),5800) idc,chd1(1:10),
4158  & chd2(1:10),0d0,0d0,state(mdme(idc,1)),0d0
4159  ELSE
4160  CALL pyname(kfdp(idc,3),chd3)
4161  IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
4162  & ngp2.LE.mstp(1)) WRITE(mstu(11),5900) idc,chd1(1:10),
4163  & chd2(1:10),chd3(1:10),0d0,0d0,state(mdme(idc,1)),0d0
4164  ENDIF
4165  120 CONTINUE
4166 C...On-shell decays.
4167  ELSE
4168  CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
4169  brfin=1d0
4170  IF(wdte(0,0).LE.0d0) brfin=0d0
4171  WRITE(mstu(11),5700) kf,chkf(1:10),pmas(kc,1),wdtp(0),1d0,
4172  & state(mdcy(kc,1)),brfin
4173  DO 130 j=1,mdcy(kc,3)
4174  idc=j+mdcy(kc,2)-1
4175  ngp1=0
4176  IF(iabs(kfdp(idc,1)).LE.20) ngp1=
4177  & (mod(iabs(kfdp(idc,1)),10)+1)/2
4178  ngp2=0
4179  IF(iabs(kfdp(idc,2)).LE.20) ngp2=
4180  & (mod(iabs(kfdp(idc,2)),10)+1)/2
4181  brpri=0d0
4182  IF(wdtp(0).GT.0d0) brpri=wdtp(j)/wdtp(0)
4183  brfin=0d0
4184  IF(wdte(0,0).GT.0d0) brfin=wdte(j,0)/wdte(0,0)
4185  CALL pyname(kfdp(idc,1),chd1)
4186  CALL pyname(kfdp(idc,2),chd2)
4187  IF(kfdp(idc,3).EQ.0) THEN
4188  IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
4189  & WRITE(mstu(11),5800) idc,chd1(1:10),
4190  & chd2(1:10),wdtp(j),brpri,
4191  & state(mdme(idc,1)),brfin
4192  ELSE
4193  CALL pyname(kfdp(idc,3),chd3)
4194  IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
4195  & WRITE(mstu(11),5900) idc,chd1(1:10),
4196  & chd2(1:10),chd3(1:10),wdtp(j),brpri,
4197  & state(mdme(idc,1)),brfin
4198  ENDIF
4199  130 CONTINUE
4200  ENDIF
4201  140 CONTINUE
4202  WRITE(mstu(11),6000)
4203 
4204 C...Allowed incoming partons/particles at hard interaction.
4205  ELSEIF(mstat.EQ.3) THEN
4206  WRITE(mstu(11),6100)
4207  CALL pyname(mint(11),chau)
4208  chin(1)=chau(1:12)
4209  CALL pyname(mint(12),chau)
4210  chin(2)=chau(1:12)
4211  WRITE(mstu(11),6200) chin(1),chin(2)
4212  DO 150 i=-20,22
4213  IF(i.EQ.0) GOTO 150
4214  ia=iabs(i)
4215  IF(ia.GT.mstp(58).AND.ia.LE.10) GOTO 150
4216  IF(ia.GT.10+2*mstp(1).AND.ia.LE.20) GOTO 150
4217  CALL pyname(i,chau)
4218  WRITE(mstu(11),6300) chau,state(kfin(1,i)),chau,
4219  & state(kfin(2,i))
4220  150 CONTINUE
4221  WRITE(mstu(11),6400)
4222 
4223 C...User-defined limits on kinematical variables.
4224  ELSEIF(mstat.EQ.4) THEN
4225  WRITE(mstu(11),6500)
4226  WRITE(mstu(11),6600)
4227  shrmax=ckin(2)
4228  IF(shrmax.LT.0d0) shrmax=vint(1)
4229  WRITE(mstu(11),6700) ckin(1),chkin(1),shrmax
4230  pthmin=max(ckin(3),ckin(5))
4231  pthmax=ckin(4)
4232  IF(pthmax.LT.0d0) pthmax=0.5d0*shrmax
4233  WRITE(mstu(11),6800) ckin(3),pthmin,chkin(2),pthmax
4234  WRITE(mstu(11),6900) chkin(3),ckin(6)
4235  DO 160 i=4,14
4236  WRITE(mstu(11),6700) ckin(2*i-1),chkin(i),ckin(2*i)
4237  160 CONTINUE
4238  sprmax=ckin(32)
4239  IF(sprmax.LT.0d0) sprmax=vint(1)
4240  WRITE(mstu(11),6700) ckin(31),chkin(15),sprmax
4241  WRITE(mstu(11),7000)
4242 
4243 C...Status codes and parameter values.
4244  ELSEIF(mstat.EQ.5) THEN
4245  WRITE(mstu(11),7100)
4246  WRITE(mstu(11),7200)
4247  DO 170 i=1,100
4248  WRITE(mstu(11),7300) i,mstp(i),parp(i),100+i,mstp(100+i),
4249  & parp(100+i)
4250  170 CONTINUE
4251 
4252 C...List of all processes implemented in the program.
4253  ELSEIF(mstat.EQ.6) THEN
4254  WRITE(mstu(11),7400)
4255  WRITE(mstu(11),7500)
4256  DO 180 i=1,500
4257  IF(iset(i).LT.0) GOTO 180
4258  WRITE(mstu(11),7600) i,proc(i),iset(i),kfpr(i,1),kfpr(i,2)
4259  180 CONTINUE
4260  WRITE(mstu(11),7700)
4261 
4262  ELSEIF(mstat.EQ.7) THEN
4263  WRITE (mstu(11),8000)
4264  nmodes(0)=0
4265  nmodes(10)=0
4266  nmodes(9)=0
4267  DO 290 ilr=1,2
4268  DO 280 kfsm=1,16
4269  kfsusy=ilr*ksusy1+kfsm
4270  nrvdc=0
4271 C...SDOWN DECAYS
4272  IF (kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5) THEN
4273  nrvdc=3
4274  DO 190 i=1,nrvdc
4275  pbrat(i)=0d0
4276  nmodes(i)=0
4277  190 CONTINUE
4278  CALL pyname(kfsusy,chtmp)
4279  chd0=chtmp//' '
4280  chdc(1)=dname(3) // ' + ' // dname(1)
4281  chdc(2)=dname(2) // ' + ' // dname(1)
4282  chdc(3)=dname(1) // ' + ' // dname(1)
4283  kc=pycomp(kfsusy)
4284  DO 200 j=1,mdcy(kc,3)
4285  idc=j+mdcy(kc,2)-1
4286  id1=iabs(kfdp(idc,1))
4287  id2=iabs(kfdp(idc,2))
4288  IF (kfdp(idc,3).EQ.0) THEN
4289  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4290  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4291  pbrat(1)=pbrat(1)+brat(idc)
4292  nmodes(1)=nmodes(1)+1
4293  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4294  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4295  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4296  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6)) THEN
4297  pbrat(2)=pbrat(2)+brat(idc)
4298  nmodes(2)=nmodes(2)+1
4299  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4300  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4301  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4302  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4303  pbrat(3)=pbrat(3)+brat(idc)
4304  nmodes(3)=nmodes(3)+1
4305  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4306  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4307  ENDIF
4308  ENDIF
4309  200 CONTINUE
4310  ENDIF
4311 C...SUP DECAYS
4312  IF (kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6) THEN
4313  nrvdc=2
4314  DO 210 i=1,nrvdc
4315  nmodes(i)=0
4316  pbrat(i)=0d0
4317  210 CONTINUE
4318  CALL pyname(kfsusy,chtmp)
4319  chd0=chtmp//' '
4320  chdc(1)=dname(2) // ' + ' // dname(1)
4321  chdc(2)=dname(1) // ' + ' // dname(1)
4322  kc=pycomp(kfsusy)
4323  DO 220 j=1,mdcy(kc,3)
4324  idc=j+mdcy(kc,2)-1
4325  id1=iabs(kfdp(idc,1))
4326  id2=iabs(kfdp(idc,2))
4327  IF (kfdp(idc,3).EQ.0) THEN
4328  IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).AND.(id2
4329  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4330  pbrat(1)=pbrat(1)+brat(idc)
4331  nmodes(1)=nmodes(1)+1
4332  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4333  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4334  ELSE IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).AND.(id2
4335  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4336  pbrat(2)=pbrat(2)+brat(idc)
4337  nmodes(2)=nmodes(2)+1
4338  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4339  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4340  ENDIF
4341  ENDIF
4342  220 CONTINUE
4343  ENDIF
4344 C...SLEPTON DECAYS
4345  IF (kfsm.EQ.11.OR.kfsm.EQ.13.OR.kfsm.EQ.15) THEN
4346  nrvdc=2
4347  DO 230 i=1,nrvdc
4348  pbrat(i)=0d0
4349  nmodes(i)=0
4350  230 CONTINUE
4351  CALL pyname(kfsusy,chtmp)
4352  chd0=chtmp//' '
4353  chdc(1)=dname(3) // ' + ' // dname(2)
4354  chdc(2)=dname(1) // ' + ' // dname(1)
4355  kc=pycomp(kfsusy)
4356  DO 240 j=1,mdcy(kc,3)
4357  idc=j+mdcy(kc,2)-1
4358  id1=iabs(kfdp(idc,1))
4359  id2=iabs(kfdp(idc,2))
4360  IF (kfdp(idc,3).EQ.0) THEN
4361  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4362  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15)) THEN
4363  pbrat(1)=pbrat(1)+brat(idc)
4364  nmodes(1)=nmodes(1)+1
4365  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4366  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4367  ENDIF
4368  IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).AND.(id2
4369  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4370  pbrat(2)=pbrat(2)+brat(idc)
4371  nmodes(2)=nmodes(2)+1
4372  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4373  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4374  ENDIF
4375  ENDIF
4376  240 CONTINUE
4377  ENDIF
4378 C...SNEUTRINO DECAYS
4379  IF ((kfsm.EQ.12.OR.kfsm.EQ.14.OR.kfsm.EQ.16).AND.ilr.EQ.1)
4380  & THEN
4381  nrvdc=2
4382  DO 250 i=1,nrvdc
4383  pbrat(i)=0d0
4384  nmodes(i)=0
4385  250 CONTINUE
4386  CALL pyname(kfsusy,chtmp)
4387  chd0=chtmp//' '
4388  chdc(1)=dname(2) // ' + ' // dname(2)
4389  chdc(2)=dname(1) // ' + ' // dname(1)
4390  kc=pycomp(kfsusy)
4391  DO 260 j=1,mdcy(kc,3)
4392  idc=j+mdcy(kc,2)-1
4393  id1=iabs(kfdp(idc,1))
4394  id2=iabs(kfdp(idc,2))
4395  IF (kfdp(idc,3).EQ.0) THEN
4396  IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).AND.(id2
4397  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15)) THEN
4398  pbrat(1)=pbrat(1)+brat(idc)
4399  nmodes(1)=nmodes(1)+1
4400  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4401  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4402  ENDIF
4403  IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).AND.(id2
4404  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4405  nmodes(2)=nmodes(2)+1
4406  pbrat(2)=pbrat(2)+brat(idc)
4407  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4408  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4409  ENDIF
4410  ENDIF
4411  260 CONTINUE
4412  ENDIF
4413  IF (nrvdc.NE.0) THEN
4414  DO 270 i=1,nrvdc
4415  WRITE (mstu(11),8200) chd0, chdc(i), pbrat(i), nmodes(i)
4416  nmodes(0)=nmodes(0)+nmodes(i)
4417  270 CONTINUE
4418  ENDIF
4419  280 CONTINUE
4420  290 CONTINUE
4421  DO 370 kfsm=21,37
4422  kfsusy=ksusy1+kfsm
4423  nrvdc=0
4424 C...NEUTRALINO DECAYS
4425  IF (kfsm.EQ.22.OR.kfsm.EQ.23.OR.kfsm.EQ.25.OR.kfsm.EQ.35) THEN
4426  nrvdc=4
4427  DO 300 i=1,nrvdc
4428  pbrat(i)=0d0
4429  nmodes(i)=0
4430  300 CONTINUE
4431  CALL pyname(kfsusy,chtmp)
4432  chd0=chtmp//' '
4433  chdc(1)=dname(3) // ' + ' // dname(2) // ' + ' // dname(2)
4434  chdc(2)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4435  chdc(3)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4436  chdc(4)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4437  kc=pycomp(kfsusy)
4438  DO 310 j=1,mdcy(kc,3)
4439  idc=j+mdcy(kc,2)-1
4440  id1=iabs(kfdp(idc,1))
4441  id2=iabs(kfdp(idc,2))
4442  id3=iabs(kfdp(idc,3))
4443  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4444  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.EQ.11.or
4445  & .id3.EQ.13.OR.id3.EQ.15)) THEN
4446  pbrat(1)=pbrat(1)+brat(idc)
4447  nmodes(1)=nmodes(1)+1
4448  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4449  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4450  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4451  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4452  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4453  pbrat(2)=pbrat(2)+brat(idc)
4454  nmodes(2)=nmodes(2)+1
4455  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4456  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4457  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4458  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.EQ.1
4459  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4460  pbrat(3)=pbrat(3)+brat(idc)
4461  nmodes(3)=nmodes(3)+1
4462  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4463  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4464  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4465  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4466  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4467  pbrat(4)=pbrat(4)+brat(idc)
4468  nmodes(4)=nmodes(4)+1
4469  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4470  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4471  ENDIF
4472  310 CONTINUE
4473  ENDIF
4474 C...CHARGINO DECAYS
4475  IF (kfsm.EQ.24.OR.kfsm.EQ.37) THEN
4476  nrvdc=5
4477  DO 320 i=1,nrvdc
4478  pbrat(i)=0d0
4479  nmodes(i)=0
4480  320 CONTINUE
4481  CALL pyname(kfsusy,chtmp)
4482  chd0=chtmp//' '
4483  chdc(1)=dname(3) // ' + ' // dname(3) // ' + ' // dname(2)
4484  chdc(2)=dname(2) // ' + ' // dname(2) // ' + ' // dname(2)
4485  chdc(3)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4486  chdc(4)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4487  chdc(5)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4488  kc=pycomp(kfsusy)
4489  DO 330 j=1,mdcy(kc,3)
4490  idc=j+mdcy(kc,2)-1
4491  id1=iabs(kfdp(idc,1))
4492  id2=iabs(kfdp(idc,2))
4493  id3=iabs(kfdp(idc,3))
4494  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4495  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.EQ.12.or
4496  & .id3.EQ.14.OR.id3.EQ.16)) THEN
4497  pbrat(1)=pbrat(1)+brat(idc)
4498  nmodes(1)=nmodes(1)+1
4499  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4500  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4501  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4502  & .(id2.EQ.12.OR.id2.EQ.14.OR.id2.EQ.16).AND.(id3.eq
4503  & .11.OR.id3.EQ.13.OR.id3.EQ.15)) THEN
4504  pbrat(1)=pbrat(1)+brat(idc)
4505  nmodes(1)=nmodes(1)+1
4506  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4507  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4508  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4509  & .(id2.EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.eq
4510  & .11.OR.id3.EQ.13.OR.id3.EQ.15)) THEN
4511  pbrat(2)=pbrat(2)+brat(idc)
4512  nmodes(2)=nmodes(2)+1
4513  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4514  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4515  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4516  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4517  & .2.OR.id3.EQ.4.OR.id3.EQ.6)) THEN
4518  pbrat(3)=pbrat(3)+brat(idc)
4519  nmodes(3)=nmodes(3)+1
4520  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4521  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4522  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4523  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4524  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4525  pbrat(3)=pbrat(3)+brat(idc)
4526  nmodes(3)=nmodes(3)+1
4527  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4528  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4529  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4530  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4531  & .2.OR.id3.EQ.4.OR.id3.EQ.6)) THEN
4532  pbrat(4)=pbrat(4)+brat(idc)
4533  nmodes(4)=nmodes(4)+1
4534  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4535  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4536  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4537  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4538  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4539  pbrat(4)=pbrat(4)+brat(idc)
4540  nmodes(4)=nmodes(4)+1
4541  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4542  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4543  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4544  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4545  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4546  pbrat(5)=pbrat(5)+brat(idc)
4547  nmodes(5)=nmodes(5)+1
4548  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4549  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4550  ELSE IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).and
4551  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4552  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4553  pbrat(5)=pbrat(5)+brat(idc)
4554  nmodes(5)=nmodes(5)+1
4555  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4556  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4557  ENDIF
4558  330 CONTINUE
4559  ENDIF
4560 C...GLUINO DECAYS
4561  IF (kfsm.EQ.21) THEN
4562  nrvdc=3
4563  DO 340 i=1,nrvdc
4564  pbrat(i)=0d0
4565  nmodes(i)=0
4566  340 CONTINUE
4567  CALL pyname(kfsusy,chtmp)
4568  chd0=chtmp//' '
4569  chdc(1)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4570  chdc(2)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4571  chdc(3)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4572  kc=pycomp(kfsusy)
4573  DO 350 j=1,mdcy(kc,3)
4574  idc=j+mdcy(kc,2)-1
4575  id1=iabs(kfdp(idc,1))
4576  id2=iabs(kfdp(idc,2))
4577  id3=iabs(kfdp(idc,3))
4578  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4579  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1.or
4580  & .id3.EQ.3.OR.id3.EQ.5)) THEN
4581  pbrat(1)=pbrat(1)+brat(idc)
4582  nmodes(1)=nmodes(1)+1
4583  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4584  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4585  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4586  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.EQ.1
4587  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4588  pbrat(2)=pbrat(2)+brat(idc)
4589  nmodes(2)=nmodes(2)+1
4590  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4591  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4592  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4593  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4594  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4595  pbrat(3)=pbrat(3)+brat(idc)
4596  nmodes(3)=nmodes(3)+1
4597  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4598  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4599  ENDIF
4600  350 CONTINUE
4601  ENDIF
4602 
4603  IF (nrvdc.NE.0) THEN
4604  DO 360 i=1,nrvdc
4605  WRITE (mstu(11),8200) chd0, chdc(i), pbrat(i), nmodes(i)
4606  nmodes(0)=nmodes(0)+nmodes(i)
4607  360 CONTINUE
4608  ENDIF
4609  370 CONTINUE
4610  WRITE (mstu(11),8100) nmodes(0), nmodes(10), nmodes(9)
4611 
4612  IF (imss(51).GE.1.OR.imss(52).GE.1.OR.imss(53).GE.1) THEN
4613  WRITE (mstu(11),8500)
4614  DO 400 irv=1,3
4615  DO 390 jrv=1,3
4616  DO 380 krv=1,3
4617  WRITE (mstu(11),8700) irv,jrv,krv,rvlam(irv,jrv,krv)
4618  & ,rvlamp(irv,jrv,krv),rvlamb(irv,jrv,krv)
4619  380 CONTINUE
4620  390 CONTINUE
4621  400 CONTINUE
4622  WRITE (mstu(11),8600)
4623  ENDIF
4624  ENDIF
4625 
4626 C...Formats for printouts.
4627  5000 FORMAT('1',9('*'),1x,'PYSTAT: Statistics on Number of ',
4628  &'Events and Cross-sections',1x,9('*'))
4629  5100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x,
4630  &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,
4631  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),
4632  &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,
4633  &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x,
4634  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x,
4635  &'I',12x,'I')
4636  5200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p,
4637  &d10.3,1x,'I')
4638  5300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/
4639  &1x,'I',34x,'I',28x,'I',12x,'I')
4640  5400 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//
4641  &1x,'********* Total number of errors, excluding junctions =',
4642  &1x,i8,' *************'/
4643  &1x,'********* Total number of errors, including junctions =',
4644  &1x,i8,' *************'/
4645  &1x,'********* Total number of warnings = ',
4646  &1x,i8,' *************'/
4647  &1x,'********* Fraction of events that fail fragmentation ',
4648  &'cuts =',1x,f8.5,' *********'/)
4649  5500 FORMAT('1',27('*'),1x,'PYSTAT: Decay Widths and Branching ',
4650  &'Ratios',1x,27('*'))
4651  5600 FORMAT(/1x,98('=')/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
4652  &1x,'I',5x,'Mother --> Branching/Decay Channel',8x,'I',1x,
4653  &'Width (GeV)',1x,'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,
4654  &'Eff. B.R.',1x,'I'/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
4655  &1x,98('='))
4656  5700 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,
4657  &i8,2x,a10,3x,'(m =',f10.3,')',2x,'-->',5x,'I',2x,1p,d10.3,0p,1x,
4658  &'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,d10.3,0p,1x,'I')
4659  5800 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,15x,'I',2x,
4660  &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
4661  &1p,d10.3,0p,1x,'I')
4662  5900 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,1x,'+',1x,a10,2x,'I',2x,
4663  &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
4664  &1p,d10.3,0p,1x,'I')
4665  6000 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,98('='))
4666  6100 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/',
4667  &'Particles at Hard Interaction',1x,7('*'))
4668  6200 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,
4669  &'Beam particle:',1x,a12,10x,'I',1x,'Target particle:',1x,a12,7x,
4670  &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',6x,'State',19x,
4671  &'I',1x,'Content',6x,'State',18x,'I'/1x,'I',38x,'I',37x,'I'/1x,
4672  &78('=')/1x,'I',38x,'I',37x,'I')
4673  6300 FORMAT(1x,'I',1x,a9,5x,a4,19x,'I',1x,a9,5x,a4,18x,'I')
4674  6400 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('='))
4675  6500 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',
4676  &'Kinematical Variables',1x,12('*'))
4677  6600 FORMAT(/1x,78('=')/1x,'I',76x,'I')
4678  6700 FORMAT(1x,'I',16x,1p,d10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,d10.3,0p,
4679  &16x,'I')
4680  6800 FORMAT(1x,'I',3x,1p,d10.3,0p,1x,'(',1p,d10.3,0p,')',1x,'<',1x,a,
4681  &1x,'<',1x,1p,d10.3,0p,16x,'I')
4682  6900 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,d10.3,0p,16x,'I')
4683  7000 FORMAT(1x,'I',76x,'I'/1x,78('='))
4684  7100 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ',
4685  &'Parameter Values',1x,12('*'))
4686  7200 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x,
4687  &'PARP(I)'/)
4688  7300 FORMAT(1x,i3,5x,i6,6x,1p,d10.3,0p,18x,i3,5x,i6,6x,1p,d10.3)
4689  7400 FORMAT('1',13('*'),1x,'PYSTAT: List of implemented processes',
4690  &1x,13('*'))
4691  7500 FORMAT(/1x,65('=')/1x,'I',34x,'I',28x,'I'/1x,'I',12x,
4692  &'Subprocess',12x,'I',1x,'ISET',2x,'KFPR(I,1)',2x,'KFPR(I,2)',1x,
4693  &'I'/1x,'I',34x,'I',28x,'I'/1x,65('=')/1x,'I',34x,'I',28x,'I')
4694  7600 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i4,1x,i10,1x,i10,1x,'I')
4695  7700 FORMAT(1x,'I',34x,'I',28x,'I'/1x,65('='))
4696  8000 FORMAT(1x/ 1x/
4697  & 17x,'Sums over R-Violating branching ratios',1x/ 1x
4698  & /1x,70('=')/1x,'I',50x,'I',11x,'I',5x,'I'/1x,'I',4x
4699  & ,'Mother --> Sum over final state flavours',4x,'I',2x
4700  & ,'BR(sum)',2x,'I',2x,'N',2x,'I'/1x,'I',50x,'I',11x,'I',5x,'I'
4701  & /1x,70('=')/1x,'I',50x,'I',11x,'I',5x,'I')
4702  8100 FORMAT(1x,'I',50x,'I',11x,'I',5x,'I'/1x,70('=')/1x,'I',1x
4703  & ,'Total number of R-Violating modes :',3x,i5,24x,'I'/
4704  & 1x,'I',1x,'Total number with non-vanishing BR :',2x,i5,24x
4705  & ,'I'/1x,'I',1x,'Total number with BR > 0.001 :',8x,i5,24x,'I'
4706  & /1x,70('='))
4707  8200 FORMAT(1x,'I',1x,a9,1x,'-->',1x,a24,11x,
4708  & 'I',2x,1p,d8.2,0p,1x,'I',2x,i2,1x,'I')
4709  8300 FORMAT(1x,'I',50x,'I',11x,'I',5x,'I')
4710  8500 FORMAT(1x/ 1x/
4711  & 1x,'R-Violating couplings',1x/ 1x /
4712  & 1x,55('=')/
4713  & 1x,'I',1x,'IJK',1x,'I',2x,'LAMBDA(IJK)',2x,'I',2x
4714  & ,'LAMBDA''(IJK)',1x,'I',1x,"LAMBDA''(IJK)",1x,'I'/1x,'I',5x
4715  & ,'I',15x,'I',15x,'I',15x,'I')
4716  8600 FORMAT(1x,55('='))
4717  8700 FORMAT(1x,'I',1x,i1,i1,i1,1x,'I',1x,1p,d13.3,0p,1x,'I',1x,1p
4718  & ,d13.3,0p,1x,'I',1x,1p,d13.3,0p,1x,'I')
4719 
4720  RETURN
4721  END
4722 
4723 C*********************************************************************
4724 
4725 C...PYUPEV
4726 C...Administers the hard-process generation required for output to the
4727 C...Les Houches event record.
4728 
4729  SUBROUTINE pyupev
4730 
4731 C...Double precision and integer declarations.
4732  IMPLICIT DOUBLE PRECISION(a-h, o-z)
4733  IMPLICIT INTEGER(I-N)
4734  INTEGER PYK,PYCHGE,PYCOMP
4735 
4736 C...Commonblocks.
4737  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
4738  common/pyctag/nct,mct(4000,2)
4739  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4740  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4741  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
4742  common/pypars/mstp(200),parp(200),msti(200),pari(200)
4743  common/pyint1/mint(400),vint(400)
4744  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4745  common/pyint4/mwid(500),wids(500,5)
4746  SAVE /pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,/pypars/,
4747  &/pyint1/,/pyint2/,/pyint4/
4748 
4749 C...HEPEUP for output.
4750  INTEGER MAXNUP
4751  parameter(maxnup=500)
4752  INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4753  DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4754  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
4755  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
4756  &vtimup(maxnup),spinup(maxnup)
4757  SAVE /hepeup/
4758 
4759 C...Stop if no subprocesses on.
4760  IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
4761  WRITE(mstu(11),5100)
4762  stop
4763  ENDIF
4764 
4765 C...Special flags for hard-process generation only.
4766  mstp71=mstp(71)
4767  mstp(71)=0
4768  mst128=mstp(128)
4769  mstp(128)=1
4770 
4771 C...Initial values for some counters.
4772  n=0
4773  mint(5)=mint(5)+1
4774  mint(7)=0
4775  mint(8)=0
4776  mint(30)=0
4777  mint(83)=0
4778  mint(84)=mstp(126)
4779  mstu(24)=0
4780  mstu70=0
4781  mstj14=mstj(14)
4782 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4783  mint(33)=0
4784 
4785 C...If variable energies: redo incoming kinematics and cross-section.
4786  msti(61)=0
4787  IF(mstp(171).EQ.1) THEN
4788  CALL pyinki(1)
4789  IF(msti(61).EQ.1) THEN
4790  mint(5)=mint(5)-1
4791  RETURN
4792  ENDIF
4793  IF(mint(121).GT.1) CALL pysave(3,1)
4794  CALL pyxtot
4795  ENDIF
4796 
4797 C...Do not allow pileup events.
4798  mint(82)=1
4799 
4800 C...Generate variables of hard scattering.
4801  mint(51)=0
4802  msti(52)=0
4803  100 CONTINUE
4804  IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
4805  mint(31)=0
4806  mint(51)=0
4807  mint(57)=0
4808  CALL pyrand
4809  IF(msti(61).EQ.1) THEN
4810  mint(5)=mint(5)-1
4811  RETURN
4812  ENDIF
4813  IF(mint(51).EQ.2) RETURN
4814  isub=mint(1)
4815 
4816  IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
4817 C...Hard scattering (including low-pT):
4818 C...reconstruct kinematics and colour flow of hard scattering.
4819  mint31=mint(31)
4820  110 mint(31)=mint31
4821  mint(51)=0
4822  CALL pyscat
4823  IF(mint(51).EQ.1) GOTO 100
4824  ipu1=mint(84)+1
4825  ipu2=mint(84)+2
4826 
4827 C...Decay of final state resonances.
4828  mint(32)=0
4829  IF(mstp(41).GE.1.AND.iset(isub).LE.10.AND.isub.NE.95)
4830  & CALL pyresd(0)
4831  IF(mint(51).EQ.1) GOTO 100
4832  mint(52)=n
4833 
4834 C...Longitudinal boost of hard scattering.
4835  betaz=(vint(41)-vint(42))/(vint(41)+vint(42))
4836  CALL pyrobo(mint(84)+1,n,0d0,0d0,0d0,0d0,betaz)
4837 
4838  ELSEIF(isub.NE.99) THEN
4839 C...Diffractive and elastic scattering.
4840  CALL pydiff
4841 
4842  ELSE
4843 C...DIS scattering (photon flux external).
4844  CALL pydisg
4845  IF(mint(51).EQ.1) GOTO 100
4846  ENDIF
4847 
4848 C...Check that no odd resonance left undecayed.
4849  mint(54)=n
4850  nfix=n
4851  DO 120 i=mint(84)+1,nfix
4852  IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
4853  & k(i,2).NE.22) THEN
4854  kca=pycomp(k(i,2))
4855  IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
4856  CALL pyresd(i)
4857  IF(mint(51).EQ.1) GOTO 100
4858  ENDIF
4859  ENDIF
4860  120 CONTINUE
4861 
4862 C...Boost hadronic subsystem to overall rest frame.
4863 C..(Only relevant when photon inside lepton beam.)
4864  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
4865 
4866 C...Store event information and calculate Monte Carlo estimates of
4867 C...subprocess cross-sections.
4868  130 CALL pydocu
4869 
4870 C...Transform to the desired coordinate frame.
4871  140 CALL pyfram(mstp(124))
4872  mstu(70)=mstu70
4873  paru(21)=vint(1)
4874 
4875 C...Restore special flags for hard-process generation only.
4876  mstp(71)=mstp71
4877  mstp(128)=mst128
4878 
4879 C...Trace colour tags; convert to LHA style labels.
4880  nct=100
4881  DO 150 i=mint(84)+1,n
4882  mct(i,1)=0
4883  mct(i,2)=0
4884  150 CONTINUE
4885  DO 160 i=mint(84)+1,n
4886  kq=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
4887  IF(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
4888  IF(k(i,4).NE.0.AND.(kq.EQ.1.OR.kq.EQ.2).AND.mct(i,1).EQ.0)
4889  & THEN
4890  imo=mod(k(i,4)/mstu(5),mstu(5))
4891  ida=mod(k(i,4),mstu(5))
4892  IF(imo.NE.0.AND.mod(k(imo,5)/mstu(5),mstu(5)).EQ.i.AND.
4893  & mct(imo,2).NE.0) THEN
4894  mct(i,1)=mct(imo,2)
4895  ELSEIF(imo.NE.0.AND.mod(k(imo,4),mstu(5)).EQ.i.AND.
4896  & mct(imo,1).NE.0) THEN
4897  mct(i,1)=mct(imo,1)
4898  ELSEIF(ida.NE.0.AND.mod(k(ida,5),mstu(5)).EQ.i.AND.
4899  & mct(ida,2).NE.0) THEN
4900  mct(i,1)=mct(ida,2)
4901  ELSE
4902  nct=nct+1
4903  mct(i,1)=nct
4904  ENDIF
4905  ENDIF
4906  IF(k(i,5).NE.0.AND.(kq.EQ.-1.OR.kq.EQ.2).AND.mct(i,2).EQ.0)
4907  & THEN
4908  imo=mod(k(i,5)/mstu(5),mstu(5))
4909  ida=mod(k(i,5),mstu(5))
4910  IF(imo.NE.0.AND.mod(k(imo,4)/mstu(5),mstu(5)).EQ.i.AND.
4911  & mct(imo,1).NE.0) THEN
4912  mct(i,2)=mct(imo,1)
4913  ELSEIF(imo.NE.0.AND.mod(k(imo,5),mstu(5)).EQ.i.AND.
4914  & mct(imo,2).NE.0) THEN
4915  mct(i,2)=mct(imo,2)
4916  ELSEIF(ida.NE.0.AND.mod(k(ida,4),mstu(5)).EQ.i.AND.
4917  & mct(ida,1).NE.0) THEN
4918  mct(i,2)=mct(ida,1)
4919  ELSE
4920  nct=nct+1
4921  mct(i,2)=nct
4922  ENDIF
4923  ENDIF
4924  ENDIF
4925  160 CONTINUE
4926 
4927 C...Put event in HEPEUP commonblock.
4928  nup=n-mint(84)
4929  idprup=mint(1)
4930  xwgtup=1d0
4931  scalup=vint(53)
4932  aqedup=vint(57)
4933  aqcdup=vint(58)
4934  DO 180 i=1,nup
4935  idup(i)=k(i+mint(84),2)
4936  IF(i.LE.2) THEN
4937  istup(i)=-1
4938  mothup(1,i)=0
4939  mothup(2,i)=0
4940  ELSEIF(k(i+4,3).EQ.0) THEN
4941  istup(i)=1
4942  mothup(1,i)=1
4943  mothup(2,i)=2
4944  ELSE
4945  istup(i)=1
4946  mothup(1,i)=k(i+mint(84),3)-mint(84)
4947  mothup(2,i)=0
4948  ENDIF
4949  IF(i.GE.3.AND.k(i+mint(84),3).GT.0)
4950  & istup(k(i+mint(84),3)-mint(84))=2
4951  icolup(1,i)=mct(i+mint(84),1)
4952  icolup(2,i)=mct(i+mint(84),2)
4953  DO 170 j=1,5
4954  pup(j,i)=p(i+mint(84),j)
4955  170 CONTINUE
4956  vtimup(i)=v(i,5)
4957  spinup(i)=9d0
4958  180 CONTINUE
4959 
4960 C...Optionally write out event to disk. Minimal size for time/spin fields.
4961  IF(mstp(162).GT.0) THEN
4962  WRITE(mstp(162),5200) nup,idprup,xwgtup,scalup,aqedup,aqcdup
4963  DO 190 i=1,nup
4964  IF(vtimup(i).EQ.0d0) THEN
4965  WRITE(mstp(162),5300) idup(i),istup(i),mothup(1,i),
4966  & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5),
4967  & ' 0. 9.'
4968  ELSE
4969  WRITE(mstp(162),5400) idup(i),istup(i),mothup(1,i),
4970  & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5),
4971  & vtimup(i),' 9.'
4972  ENDIF
4973  190 CONTINUE
4974 
4975 C...Optional extra line with parton-density information.
4976  IF(mstp(165).GE.1) WRITE(mstp(162),5500) msti(15),msti(16),
4977  & pari(33),pari(34),pari(23),pari(29),pari(30)
4978  ENDIF
4979 
4980 C...Error messages and other print formats.
4981  5100 FORMAT(1x,'Error: no subprocess switched on.'/
4982  &1x,'Execution stopped.')
4983  5200 FORMAT(1p,2i6,4e14.6)
4984  5300 FORMAT(1p,i8,5i5,5e18.10,a6)
4985  5400 FORMAT(1p,i8,5i5,5e18.10,e12.4,a3)
4986  5500 FORMAT(1p,'#pdf ',2i5,5e18.10)
4987 
4988  RETURN
4989  END
4990 
4991 C*********************************************************************
4992 
4993 C...PYUPIN
4994 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4995 C...processes, and optionally stores that information on file.
4996 
4997  SUBROUTINE pyupin
4998 
4999 C...Double precision and integer declarations.
5000  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5001  IMPLICIT INTEGER(I-N)
5002 
5003 C...Commonblocks.
5004  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5005  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5006  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5007  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
5008  SAVE /pyjets/,/pysubs/,/pypars/,/pyint5/
5009 
5010 C...User process initialization commonblock.
5011  INTEGER MAXPUP
5012  parameter(maxpup=100)
5013  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5014  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5015  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5016  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5017  &lprup(maxpup)
5018  SAVE /heprup/
5019 
5020 C...Store info on incoming beams.
5021  idbmup(1)=k(1,2)
5022  idbmup(2)=k(2,2)
5023  ebmup(1)=p(1,4)
5024  ebmup(2)=p(2,4)
5025  pdfgup(1)=0
5026  pdfgup(2)=0
5027  pdfsup(1)=mstp(51)
5028  pdfsup(2)=mstp(51)
5029 
5030 C...Event weighting strategy.
5031  idwtup=3
5032 
5033 C...Info on individual processes.
5034  nprup=0
5035  DO 100 isub=1,500
5036  IF(msub(isub).EQ.1) THEN
5037  nprup=nprup+1
5038  xsecup(nprup)=1d9*xsec(isub,3)
5039  xerrup(nprup)=xsecup(nprup)/sqrt(max(1d0,dble(ngen(isub,3))))
5040  xmaxup(nprup)=1d0
5041  lprup(nprup)=isub
5042  ENDIF
5043  100 CONTINUE
5044 
5045 C...Write info to file.
5046  IF(mstp(161).GT.0) THEN
5047  WRITE(mstp(161),5100) idbmup(1),idbmup(2),ebmup(1),ebmup(2),
5048  & pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
5049  DO 110 ipr=1,nprup
5050  WRITE(mstp(161),5200) xsecup(ipr),xerrup(ipr),xmaxup(ipr),
5051  & lprup(ipr)
5052  110 CONTINUE
5053  ENDIF
5054 
5055 C...Formats for printout.
5056  5100 FORMAT(1p,2i8,2e14.6,6i6)
5057  5200 FORMAT(1p,3e14.6,i6)
5058 
5059  RETURN
5060  END
5061 
5062 
5063 C*********************************************************************
5064 
5065 C...Combine the two old-style Pythia initialization and event files
5066 C...into a single Les Houches Event File.
5067 
5068  SUBROUTINE pylhef
5069 
5070 C...Double precision and integer declarations.
5071  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5072  IMPLICIT INTEGER(I-N)
5073 
5074 C...PYTHIA commonblock: only used to provide read/write units and version.
5075  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5076  SAVE /pypars/
5077 
5078 C...User process initialization commonblock.
5079  INTEGER MAXPUP
5080  parameter(maxpup=100)
5081  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5082  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5083  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5084  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5085  &lprup(maxpup)
5086  SAVE /heprup/
5087 
5088 C...User process event common block.
5089  INTEGER MAXNUP
5090  parameter(maxnup=500)
5091  INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5092  DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5093  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
5094  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
5095  &vtimup(maxnup),spinup(maxnup)
5096  SAVE /hepeup/
5097 
5098 C...Lines to read in assumed never longer than 200 characters.
5099  parameter(maxlen=200)
5100  CHARACTER*(MAXLEN) STRING
5101 
5102 C...Format for reading lines.
5103  CHARACTER*6 STRFMT
5104  strfmt='(A000)'
5105  WRITE(strfmt(3:5),'(I3)') maxlen
5106 
5107 C...Rewind initialization and event files.
5108  rewind mstp(161)
5109  rewind mstp(162)
5110 
5111 C...Write header info.
5112  WRITE(mstp(163),'(A)') '<LesHouchesEvents version="1.0">'
5113  WRITE(mstp(163),'(A)') '<!--'
5114  WRITE(mstp(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5115  &mstp(181),'.',mstp(182)
5116  WRITE(mstp(163),'(A)') '-->'
5117 
5118 C...Read first line of initialization info and get number of processes.
5119  READ(mstp(161),'(A)',END=400,ERR=400) string
5120  READ(string,*,err=400) idbmup(1),idbmup(2),ebmup(1),
5121  &ebmup(2),pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
5122 
5123 C...Copy initialization lines, omitting trailing blanks.
5124 C...Embed in <init> ... </init> block.
5125  WRITE(mstp(163),'(A)') '<init>'
5126  DO 140 ipr=0,nprup
5127  IF(ipr.GT.0) READ(mstp(161),'(A)',END=400,ERR=400) string
5128  len=maxlen+1
5129  120 len=len-1
5130  IF(len.GT.1.AND.string(len:len).EQ.' ') GOTO 120
5131  WRITE(mstp(163),'(A)',err=400) string(1:len)
5132  140 CONTINUE
5133  WRITE(mstp(163),'(A)') '</init>'
5134 
5135 C...Begin event loop. Read first line of event info or already done.
5136  READ(mstp(162),'(A)',END=320,ERR=400) string
5137  200 CONTINUE
5138 
5139 C...Look at first line to know number of particles in event.
5140  READ(string,*,err=400) nup,idprup,xwgtup,scalup,aqedup,aqcdup
5141 
5142 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5143  WRITE(mstp(163),'(A)') '<event>'
5144  DO 240 i=0,nup
5145  IF(i.GT.0) READ(mstp(162),'(A)',END=400,ERR=400) string
5146  len=maxlen+1
5147  220 len=len-1
5148  IF(len.GT.1.AND.string(len:len).EQ.' ') GOTO 220
5149  WRITE(mstp(163),'(A)',err=400) string(1:len)
5150  240 CONTINUE
5151 
5152 C...Copy trailing comment lines - with a # in the first column - as is.
5153  260 READ(mstp(162),'(A)',END=300,ERR=400) string
5154  IF(string(1:1).EQ.'#') THEN
5155  len=maxlen+1
5156  280 len=len-1
5157  IF(len.GT.1.AND.string(len:len).EQ.' ') GOTO 280
5158  WRITE(mstp(163),'(A)',err=400) string(1:len)
5159  GOTO 260
5160  ENDIF
5161 
5162 C..End the <event> block. Loop back to look for next event.
5163  WRITE(mstp(163),'(A)') '</event>'
5164  GOTO 200
5165 
5166 C...Successfully reached end of event loop: write closing tag
5167 C...and remove temporary intermediate files (unless asked not to).
5168  300 WRITE(mstp(163),'(A)') '</event>'
5169  320 WRITE(mstp(163),'(A)') '</LesHouchesEvents>'
5170  IF(mstp(164).EQ.1) RETURN
5171  CLOSE(mstp(161),err=400,status='DELETE')
5172  CLOSE(mstp(162),err=400,status='DELETE')
5173  RETURN
5174 
5175 C...Error exit.
5176  400 WRITE(*,*) ' PYLHEF file joining failed!'
5177 
5178  RETURN
5179  END
5180 
5181 C*********************************************************************
5182 
5183 C...PYINRE
5184 C...Calculates full and effective widths of gauge bosons, stores
5185 C...masses and widths, rescales coefficients to be used for
5186 C...resonance production generation.
5187 
5188  SUBROUTINE pyinre
5189 
5190 C...Double precision and integer declarations.
5191  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5192  IMPLICIT INTEGER(I-N)
5193  INTEGER PYK,PYCHGE,PYCOMP
5194 C...Parameter statement to help give large particle numbers.
5195  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
5196  &kexcit=4000000,kdimen=5000000)
5197 C...Commonblocks.
5198  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5199  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5200  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
5201  common/pydat4/chaf(500,2)
5202  CHARACTER CHAF*16
5203  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5204  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5205  common/pyint1/mint(400),vint(400)
5206  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5207  common/pyint4/mwid(500),wids(500,5)
5208  common/pyint6/proc(0:500)
5209  CHARACTER PROC*28
5210  common/pymssm/imss(0:99),rmss(0:99)
5211  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
5212  &/pyint1/,/pyint2/,/pyint4/,/pyint6/,/pymssm/
5213 C...Local arrays and data.
5214  dimension wdtp(0:400),wdte(0:400,0:5),wdtpm(0:400),
5215  &wdtem(0:400,0:5),kcord(500),pmord(500)
5216 
5217 C...Born level couplings in MSSM Higgs doublet sector.
5218  xw=paru(102)
5219  xwv=xw
5220  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
5221  xw1=1d0-xw
5222  IF(mstp(4).EQ.2) THEN
5223  tanbe=paru(141)
5224  ratbe=((1d0-tanbe**2)/(1d0+tanbe**2))**2
5225  sqmz=pmas(23,1)**2
5226  sqmw=pmas(24,1)**2
5227  sqmh=pmas(25,1)**2
5228  sqma=sqmh*(sqmz-sqmh)/(sqmz*ratbe-sqmh)
5229  sqmhp=0.5d0*(sqma+sqmz+sqrt((sqma+sqmz)**2-4d0*sqma*sqmz*ratbe))
5230  sqmhc=sqma+sqmw
5231  IF(sqmh.GE.sqmz.OR.min(sqma,sqmhp,sqmhc).LE.0d0) THEN
5232  WRITE(mstu(11),5000)
5233  CALL pystop(101)
5234  ENDIF
5235  pmas(35,1)=sqrt(sqmhp)
5236  pmas(36,1)=sqrt(sqma)
5237  pmas(37,1)=sqrt(sqmhc)
5238  alsu=0.5d0*atan(2d0*tanbe*(sqma+sqmz)/((1d0-tanbe**2)*
5239  & (sqma-sqmz)))
5240  besu=atan(tanbe)
5241  paru(142)=1d0
5242  paru(143)=1d0
5243  paru(161)=-sin(alsu)/cos(besu)
5244  paru(162)=cos(alsu)/sin(besu)
5245  paru(163)=paru(161)
5246  paru(164)=sin(besu-alsu)
5247  paru(165)=paru(164)
5248  paru(168)=sin(besu-alsu)+0.5d0*cos(2d0*besu)*sin(besu+alsu)/xw
5249  paru(171)=cos(alsu)/cos(besu)
5250  paru(172)=sin(alsu)/sin(besu)
5251  paru(173)=paru(171)
5252  paru(174)=cos(besu-alsu)
5253  paru(175)=paru(174)
5254  paru(176)=cos(2d0*alsu)*cos(besu+alsu)-2d0*sin(2d0*alsu)*
5255  & sin(besu+alsu)
5256  paru(177)=cos(2d0*besu)*cos(besu+alsu)
5257  paru(178)=cos(besu-alsu)-0.5d0*cos(2d0*besu)*cos(besu+alsu)/xw
5258  paru(181)=tanbe
5259  paru(182)=1d0/tanbe
5260  paru(183)=paru(181)
5261  paru(184)=0d0
5262  paru(185)=paru(184)
5263  paru(186)=cos(besu-alsu)
5264  paru(187)=sin(besu-alsu)
5265  paru(188)=paru(186)
5266  paru(189)=paru(187)
5267  paru(190)=0d0
5268  paru(195)=cos(besu-alsu)
5269  ENDIF
5270 
5271 C...Reset effective widths of gauge bosons.
5272  DO 110 i=1,500
5273  DO 100 j=1,5
5274  wids(i,j)=1d0
5275  100 CONTINUE
5276  110 CONTINUE
5277 
5278 C...Order resonances by increasing mass (except Z0 and W+/-).
5279  nres=0
5280  DO 140 kc=1,500
5281  kf=kchg(kc,4)
5282  IF(kf.EQ.0) GOTO 140
5283  IF(mwid(kc).EQ.0) GOTO 140
5284  IF(kc.EQ.7.OR.kc.EQ.8.OR.kc.EQ.17.OR.kc.EQ.18) THEN
5285  IF(mstp(1).LE.3) GOTO 140
5286  ENDIF
5287  IF(kf/ksusy1.EQ.1.OR.kf/ksusy1.EQ.2) THEN
5288  IF(imss(1).LE.0) GOTO 140
5289  ENDIF
5290  nres=nres+1
5291  pmres=pmas(kc,1)
5292  IF(kc.EQ.23.OR.kc.EQ.24) pmres=0d0
5293  DO 120 i1=nres-1,1,-1
5294  IF(pmres.GE.pmord(i1)) GOTO 130
5295  kcord(i1+1)=kcord(i1)
5296  pmord(i1+1)=pmord(i1)
5297  120 CONTINUE
5298  130 kcord(i1+1)=kc
5299  pmord(i1+1)=pmres
5300  140 CONTINUE
5301 
5302 C...Loop over possible resonances.
5303  DO 180 i=1,nres
5304  kc=kcord(i)
5305  kf=kchg(kc,4)
5306 
5307 C...Check that no fourth generation channels on by mistake.
5308  IF(mstp(1).LE.3) THEN
5309  DO 150 j=1,mdcy(kc,3)
5310  idc=j+mdcy(kc,2)-1
5311  kfa1=iabs(kfdp(idc,1))
5312  kfa2=iabs(kfdp(idc,2))
5313  IF(kfa1.EQ.7.OR.kfa1.EQ.8.OR.kfa1.EQ.17.OR.kfa1.EQ.18.OR.
5314  & kfa2.EQ.7.OR.kfa2.EQ.8.OR.kfa2.EQ.17.OR.kfa2.EQ.18)
5315  & mdme(idc,1)=-1
5316  150 CONTINUE
5317  ENDIF
5318 
5319 C...Check that no supersymmetric channels on by mistake.
5320  IF(imss(1).LE.0) THEN
5321  DO 160 j=1,mdcy(kc,3)
5322  idc=j+mdcy(kc,2)-1
5323  kfa1s=iabs(kfdp(idc,1))/ksusy1
5324  kfa2s=iabs(kfdp(idc,2))/ksusy1
5325  IF(kfa1s.EQ.1.OR.kfa1s.EQ.2.OR.kfa2s.EQ.1.OR.kfa2s.EQ.2)
5326  & mdme(idc,1)=-1
5327  160 CONTINUE
5328  ENDIF
5329 
5330 C...Find mass and evaluate width.
5331  pmr=pmas(kc,1)
5332  IF(kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) mint(62)=1
5333  IF(mwid(kc).EQ.3) mint(63)=1
5334  CALL pywidt(kf,pmr**2,wdtp,wdte)
5335  mint(51)=0
5336 
5337 C...Evaluate suppression factors due to non-simulated channels.
5338  IF(kchg(kc,3).EQ.0) THEN
5339  wdtp0i=0d0
5340  IF(wdtp(0).GT.0d0) wdtp0i=1d0/wdtp(0)
5341  wids(kc,1)=((wdte(0,1)+wdte(0,2))**2+
5342  & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
5343  & 2d0*wdte(0,4)*wdte(0,5))*wdtp0i**2
5344  wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))*wdtp0i
5345  wids(kc,3)=0d0
5346  wids(kc,4)=0d0
5347  wids(kc,5)=0d0
5348  ELSE
5349  IF(mwid(kc).EQ.3) mint(63)=1
5350  CALL pywidt(-kf,pmr**2,wdtpm,wdtem)
5351  mint(51)=0
5352  wdtp0i=0d0
5353  IF(wdtp(0).GT.0d0) wdtp0i=1d0/wdtp(0)
5354  wids(kc,1)=((wdte(0,1)+wdte(0,2))*(wdtem(0,1)+wdtem(0,3))+
5355  & (wdte(0,1)+wdte(0,2))*(wdtem(0,4)+wdtem(0,5))+
5356  & (wdte(0,4)+wdte(0,5))*(wdtem(0,1)+wdtem(0,3))+
5357  & wdte(0,4)*wdtem(0,5)+wdte(0,5)*wdtem(0,4))*wdtp0i**2
5358  wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))*wdtp0i
5359  wids(kc,3)=(wdtem(0,1)+wdtem(0,3)+wdtem(0,4))*wdtp0i
5360  wids(kc,4)=((wdte(0,1)+wdte(0,2))**2+
5361  & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
5362  & 2d0*wdte(0,4)*wdte(0,5))*wdtp0i**2
5363  wids(kc,5)=((wdtem(0,1)+wdtem(0,3))**2+
5364  & 2d0*(wdtem(0,1)+wdtem(0,3))*(wdtem(0,4)+wdtem(0,5))+
5365  & 2d0*wdtem(0,4)*wdtem(0,5))*wdtp0i**2
5366  ENDIF
5367 
5368 C...Set resonance widths and branching ratios;
5369 C...also on/off switch for decays.
5370  IF(mwid(kc).EQ.1.OR.mwid(kc).EQ.3) THEN
5371  pmas(kc,2)=wdtp(0)
5372  pmas(kc,3)=min(0.9d0*pmas(kc,1),10d0*pmas(kc,2))
5373  IF(mstp(41).EQ.0.OR.mstp(41).EQ.1) mdcy(kc,1)=mstp(41)
5374  DO 170 j=1,mdcy(kc,3)
5375  idc=j+mdcy(kc,2)-1
5376  brat(idc)=0d0
5377  IF(wdtp(0).GT.0d0) brat(idc)=wdtp(j)/wdtp(0)
5378  170 CONTINUE
5379  ENDIF
5380  180 CONTINUE
5381 
5382 C...Flavours of leptoquark: redefine charge and name.
5383  kflqq=kfdp(mdcy(42,2),1)
5384  kflql=kfdp(mdcy(42,2),2)
5385  kchg(42,1)=kchg(pycomp(kflqq),1)*isign(1,kflqq)+
5386  &kchg(pycomp(kflql),1)*isign(1,kflql)
5387  ll=1
5388  IF(iabs(kflql).EQ.13) ll=2
5389  IF(iabs(kflql).EQ.15) ll=3
5390  chaf(42,1)='LQ_'//chaf(iabs(kflqq),1)(1:1)//
5391  &chaf(iabs(kflql),1)(1:ll)//' '
5392  chaf(42,2)=chaf(42,2)(1:4+ll)//'bar '
5393 
5394 C...Special cases in treatment of gamma*/Z0: redefine process name.
5395  IF(mstp(43).EQ.1) THEN
5396  proc(1)='f + fbar -> gamma*'
5397  proc(15)='f + fbar -> g + gamma*'
5398  proc(19)='f + fbar -> gamma + gamma*'
5399  proc(30)='f + g -> f + gamma*'
5400  proc(35)='f + gamma -> f + gamma*'
5401  ELSEIF(mstp(43).EQ.2) THEN
5402  proc(1)='f + fbar -> Z0'
5403  proc(15)='f + fbar -> g + Z0'
5404  proc(19)='f + fbar -> gamma + Z0'
5405  proc(30)='f + g -> f + Z0'
5406  proc(35)='f + gamma -> f + Z0'
5407  ELSEIF(mstp(43).EQ.3) THEN
5408  proc(1)='f + fbar -> gamma*/Z0'
5409  proc(15)='f + fbar -> g + gamma*/Z0'
5410  proc(19)='f+ fbar -> gamma + gamma*/Z0'
5411  proc(30)='f + g -> f + gamma*/Z0'
5412  proc(35)='f + gamma -> f + gamma*/Z0'
5413  ENDIF
5414 
5415 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5416  IF(mstp(44).EQ.1) THEN
5417  proc(141)='f + fbar -> gamma*'
5418  ELSEIF(mstp(44).EQ.2) THEN
5419  proc(141)='f + fbar -> Z0'
5420  ELSEIF(mstp(44).EQ.3) THEN
5421  proc(141)='f + fbar -> Z''0'
5422  ELSEIF(mstp(44).EQ.4) THEN
5423  proc(141)='f + fbar -> gamma*/Z0'
5424  ELSEIF(mstp(44).EQ.5) THEN
5425  proc(141)='f + fbar -> gamma*/Z''0'
5426  ELSEIF(mstp(44).EQ.6) THEN
5427  proc(141)='f + fbar -> Z0/Z''0'
5428  ELSEIF(mstp(44).EQ.7) THEN
5429  proc(141)='f + fbar -> gamma*/Z0/Z''0'
5430  ENDIF
5431 
5432 C...Special cases in treatment of WW -> WW: redefine process name.
5433  IF(mstp(45).EQ.1) THEN
5434  proc(77)='W+ + W+ -> W+ + W+'
5435  ELSEIF(mstp(45).EQ.2) THEN
5436  proc(77)='W+ + W- -> W+ + W-'
5437  ELSEIF(mstp(45).EQ.3) THEN
5438  proc(77)='W+/- + W+/- -> W+/- + W+/-'
5439  ENDIF
5440 
5441 C...Format for error information.
5442  5000 FORMAT(1x,'Error: unphysical input tan^2(beta) and m_H ',
5443  &'combination'/1x,'Execution stopped!')
5444 
5445  RETURN
5446  END
5447 
5448 C*********************************************************************
5449 
5450 C...PYINBM
5451 C...Identifies the two incoming particles and the choice of frame.
5452 
5453  SUBROUTINE pyinbm(CHFRAM,CHBEAM,CHTARG,WIN)
5454 
5455 C...Double precision and integer declarations.
5456  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5457  IMPLICIT INTEGER(I-N)
5458  INTEGER PYK,PYCHGE,PYCOMP
5459 
5460 C...User process initialization commonblock.
5461  INTEGER MAXPUP
5462  parameter(maxpup=100)
5463  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5464  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5465  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5466  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5467  &lprup(maxpup)
5468  SAVE /heprup/
5469 
5470 C...Commonblocks.
5471  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5472  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5473  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5474  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5475  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5476  common/pyint1/mint(400),vint(400)
5477  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
5478 
5479 C...Local arrays, character variables and data.
5480  CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5481  &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5482  dimension len(3),kcde(39),pm(2)
5483  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
5484  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5485  DATA chcde/ 'e- ','e+ ','nu_e ',
5486  &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5487  &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5488  &'nu_taubar ','pi+ ','pi- ','n0 ',
5489  &'nbar0 ','p+ ','pbar- ','gamma ',
5490  &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5491  &'xi- ','xi0 ','omega- ','pi0 ',
5492  &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5493  &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5494  &'k+ ','k- ','ks0 ','kl0 '/
5495  DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5496  &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5497  &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5498 
5499 C...Store initial energy. Default frame.
5500  vint(290)=win
5501  mint(111)=0
5502 
5503 C...Special user process initialization; convert to normal input.
5504  IF(chfram(1:1).EQ.'u'.OR.chfram(1:1).EQ.'U') THEN
5505  mint(111)=11
5506  IF(pdfgup(1).EQ.-9.OR.pdfgup(2).EQ.-9) mint(111)=12
5507  CALL pyname(idbmup(1),chname)
5508  chbeam=chname(1:12)
5509  CALL pyname(idbmup(2),chname)
5510  chtarg=chname(1:12)
5511  ENDIF
5512 
5513 C...Convert character variables to lowercase and find their length.
5514  chcom(1)=chfram
5515  chcom(2)=chbeam
5516  chcom(3)=chtarg
5517  DO 130 i=1,3
5518  len(i)=12
5519  DO 110 ll=12,1,-1
5520  IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1
5521  DO 100 la=1,26
5522  IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=
5523  & chalp(1)(la:la)
5524  100 CONTINUE
5525  110 CONTINUE
5526  chidnt(i)=chcom(i)
5527 
5528 C...Fix up bar, underscore and charge in particle name (if needed).
5529  DO 120 ll=1,10
5530  IF(chidnt(i)(ll:ll).EQ.'~') THEN
5531  chtemp=chidnt(i)
5532  chidnt(i)=chtemp(1:ll-1)//'bar'//chtemp(ll+1:10)//' '
5533  ENDIF
5534  120 CONTINUE
5535  IF(chidnt(i)(1:2).EQ.'nu'.AND.chidnt(i)(3:3).NE.'_') THEN
5536  chtemp=chidnt(i)
5537  chidnt(i)='nu_'//chtemp(3:7)
5538  ELSEIF(chidnt(i)(1:2).EQ.'n ') THEN
5539  chidnt(i)(1:3)='n0 '
5540  ELSEIF(chidnt(i)(1:4).EQ.'nbar') THEN
5541  chidnt(i)(1:5)='nbar0'
5542  ELSEIF(chidnt(i)(1:2).EQ.'p ') THEN
5543  chidnt(i)(1:3)='p+ '
5544  ELSEIF(chidnt(i)(1:4).EQ.'pbar'.OR.
5545  & chidnt(i)(1:2).EQ.'p-') THEN
5546  chidnt(i)(1:5)='pbar-'
5547  ELSEIF(chidnt(i)(1:6).EQ.'lambda') THEN
5548  chidnt(i)(7:7)='0'
5549  ELSEIF(chidnt(i)(1:3).EQ.'reg') THEN
5550  chidnt(i)(1:7)='reggeon'
5551  ELSEIF(chidnt(i)(1:3).EQ.'pom') THEN
5552  chidnt(i)(1:7)='pomeron'
5553  ENDIF
5554  130 CONTINUE
5555 
5556 C...Identify free initialization.
5557  IF(chcom(1)(1:2).EQ.'no') THEN
5558  mint(65)=1
5559  RETURN
5560  ENDIF
5561 
5562 C...Identify incoming beam and target particles.
5563  DO 160 i=1,2
5564  DO 140 j=1,39
5565  IF(chidnt(i+1).EQ.chcde(j)) mint(10+i)=kcde(j)
5566  140 CONTINUE
5567  pm(i)=pymass(mint(10+i))
5568  vint(2+i)=pm(i)
5569  mint(140+i)=0
5570  IF(mint(10+i).EQ.22.AND.chidnt(i+1)(6:6).EQ.'/') THEN
5571  chtemp=chidnt(i+1)(7:12)//' '
5572  DO 150 j=1,12
5573  IF(chtemp.EQ.chcde(j)) mint(140+i)=kcde(j)
5574  150 CONTINUE
5575  pm(i)=pymass(mint(140+i))
5576  vint(302+i)=pm(i)
5577  ENDIF
5578  160 CONTINUE
5579  IF(mint(11).EQ.0) WRITE(mstu(11),5000) chbeam(1:len(2))
5580  IF(mint(12).EQ.0) WRITE(mstu(11),5100) chtarg(1:len(3))
5581  IF(mint(11).EQ.0.OR.mint(12).EQ.0) CALL pystop(7)
5582 
5583 C...Identify choice of frame and input energies.
5584  chinit=' '
5585 
5586 C...Events defined in the CM frame.
5587  IF(chcom(1)(1:2).EQ.'cm') THEN
5588  mint(111)=1
5589  s=win**2
5590  IF(mstp(122).GE.1) THEN
5591  IF(chcom(2)(1:1).NE.'e') THEN
5592  loffs=(31-(len(2)+len(3)))/2
5593  chinit(loffs+1:76)='PYTHIA will be initialized for a '//
5594  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5595  & ' collider'//' '
5596  ELSE
5597  loffs=(30-(len(2)+len(3)))/2
5598  chinit(loffs+1:76)='PYTHIA will be initialized for an '//
5599  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5600  & ' collider'//' '
5601  ENDIF
5602  WRITE(mstu(11),5200) chinit
5603  WRITE(mstu(11),5300) win
5604  ENDIF
5605 
5606 C...Events defined in fixed target frame.
5607  ELSEIF(chcom(1)(1:3).EQ.'fix') THEN
5608  mint(111)=2
5609  s=pm(1)**2+pm(2)**2+2d0*pm(2)*sqrt(pm(1)**2+win**2)
5610  IF(mstp(122).GE.1) THEN
5611  loffs=(29-(len(2)+len(3)))/2
5612  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5613  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5614  & ' fixed target'//' '
5615  WRITE(mstu(11),5200) chinit
5616  WRITE(mstu(11),5400) win
5617  WRITE(mstu(11),5500) sqrt(s)
5618  ENDIF
5619 
5620 C...Frame defined by user three-vectors.
5621  ELSEIF(chcom(1)(1:1).EQ.'3') THEN
5622  mint(111)=3
5623  p(1,5)=pm(1)
5624  p(2,5)=pm(2)
5625  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
5626  p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
5627  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5628  & (p(1,3)+p(2,3))**2
5629  IF(mstp(122).GE.1) THEN
5630  loffs=(22-(len(2)+len(3)))/2
5631  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5632  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5633  & ' user configuration'//' '
5634  WRITE(mstu(11),5200) chinit
5635  WRITE(mstu(11),5600)
5636  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5637  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5638  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5639  ENDIF
5640 
5641 C...Frame defined by user four-vectors.
5642  ELSEIF(chcom(1)(1:1).EQ.'4') THEN
5643  mint(111)=4
5644  pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
5645  p(1,5)=sign(sqrt(abs(pms1)),pms1)
5646  pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
5647  p(2,5)=sign(sqrt(abs(pms2)),pms2)
5648  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5649  & (p(1,3)+p(2,3))**2
5650  IF(mstp(122).GE.1) THEN
5651  loffs=(22-(len(2)+len(3)))/2
5652  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5653  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5654  & ' user configuration'//' '
5655  WRITE(mstu(11),5200) chinit
5656  WRITE(mstu(11),5600)
5657  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5658  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5659  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5660  ENDIF
5661 
5662 C...Frame defined by user five-vectors.
5663  ELSEIF(chcom(1)(1:1).EQ.'5') THEN
5664  mint(111)=5
5665  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5666  & (p(1,3)+p(2,3))**2
5667  IF(mstp(122).GE.1) THEN
5668  loffs=(22-(len(2)+len(3)))/2
5669  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5670  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5671  & ' user configuration'//' '
5672  WRITE(mstu(11),5200) chinit
5673  WRITE(mstu(11),5600)
5674  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5675  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5676  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5677  ENDIF
5678 
5679 C...Frame defined by HEPRUP common block.
5680  ELSEIF(mint(111).GE.11) THEN
5681  s=(ebmup(1)+ebmup(2))**2-(sqrt(max(0d0,ebmup(1)**2-pm(1)**2))-
5682  & sqrt(max(0d0,ebmup(2)**2-pm(2)**2)))**2
5683  IF(mstp(122).GE.1) THEN
5684  loffs=(22-(len(2)+len(3)))/2
5685  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5686  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5687  & ' user configuration'//' '
5688  WRITE(mstu(11),5200) chinit
5689  WRITE(mstu(11),6000) ebmup(1),ebmup(2)
5690  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5691  ENDIF
5692 
5693 C...Unknown frame. Error for too low CM energy.
5694  ELSE
5695  WRITE(mstu(11),5800) chfram(1:len(1))
5696  CALL pystop(7)
5697  ENDIF
5698  IF(s.LT.parp(2)**2) THEN
5699  WRITE(mstu(11),5900) sqrt(s)
5700  CALL pystop(7)
5701  ENDIF
5702 
5703 C...Formats for initialization and error information.
5704  5000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''D0'/
5705  &1x,'Execution stopped!')
5706  5100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''D0'/
5707  &1x,'Execution stopped!')
5708  5200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I')
5709  5300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',
5710  &19x,'I'/1x,'I',76x,'I'/1x,78('='))
5711  5400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')
5712  5500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,
5713  &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))
5714  5600 FORMAT(1x,'I',76x,'I'/1x,'I',18x,'px (GeV/c)',3x,'py (GeV/c)',3x,
5715  &'pz (GeV/c)',6x,'E (GeV)',9x,'I')
5716  5700 FORMAT(1x,'I',8x,a8,4(2x,f10.3,1x),8x,'I')
5717  5800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''D0'/
5718  &1x,'Execution stopped!')
5719  5900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ',
5720  &'generation.'/1x,'Execution stopped!')
5721  6000 FORMAT(1x,'I',12x,'with',1x,f10.3,1x,'GeV on',1x,f10.3,1x,
5722  &'GeV beam energies',13x,'I')
5723 
5724  RETURN
5725  END
5726 
5727 C*********************************************************************
5728 
5729 C...PYINKI
5730 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5731 
5732  SUBROUTINE pyinki(MODKI)
5733 
5734 C...Double precision and integer declarations.
5735  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5736  IMPLICIT INTEGER(I-N)
5737  INTEGER PYK,PYCHGE,PYCOMP
5738 
5739 C...User process initialization commonblock.
5740  INTEGER MAXPUP
5741  parameter(maxpup=100)
5742  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5743  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5744  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5745  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5746  &lprup(maxpup)
5747  SAVE /heprup/
5748 
5749 C...Commonblocks.
5750  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5751  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5752  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5753  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5754  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5755  common/pyint1/mint(400),vint(400)
5756  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
5757 
5758 C...Set initial flavour state.
5759  n=2
5760  DO 100 i=1,2
5761  k(i,1)=1
5762  k(i,2)=mint(10+i)
5763  IF(mint(140+i).NE.0) k(i,2)=mint(140+i)
5764  100 CONTINUE
5765 
5766 C...Reset boost. Do kinematics for various cases.
5767  DO 110 j=6,10
5768  vint(j)=0d0
5769  110 CONTINUE
5770 
5771 C...Set up kinematics for events defined in CM frame.
5772  IF(mint(111).EQ.1) THEN
5773  win=vint(290)
5774  IF(modki.EQ.1) win=parp(171)*vint(290)
5775  s=win**2
5776  p(1,5)=vint(3)
5777  p(2,5)=vint(4)
5778  IF(mint(141).NE.0) p(1,5)=vint(303)
5779  IF(mint(142).NE.0) p(2,5)=vint(304)
5780  p(1,1)=0d0
5781  p(1,2)=0d0
5782  p(2,1)=0d0
5783  p(2,2)=0d0
5784  p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2d0*p(1,5)*p(2,5))**2)/
5785  & (4d0*s))
5786  p(2,3)=-p(1,3)
5787  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
5788  p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)
5789 
5790 C...Set up kinematics for fixed target events.
5791  ELSEIF(mint(111).EQ.2) THEN
5792  win=vint(290)
5793  IF(modki.EQ.1) win=parp(171)*vint(290)
5794  p(1,5)=vint(3)
5795  p(2,5)=vint(4)
5796  IF(mint(141).NE.0) p(1,5)=vint(303)
5797  IF(mint(142).NE.0) p(2,5)=vint(304)
5798  p(1,1)=0d0
5799  p(1,2)=0d0
5800  p(2,1)=0d0
5801  p(2,2)=0d0
5802  p(1,3)=win
5803  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
5804  p(2,3)=0d0
5805  p(2,4)=p(2,5)
5806  s=p(1,5)**2+p(2,5)**2+2d0*p(2,4)*p(1,4)
5807  vint(10)=p(1,3)/(p(1,4)+p(2,4))
5808  CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
5809 
5810 C...Set up kinematics for events in user-defined frame.
5811  ELSEIF(mint(111).EQ.3) THEN
5812  p(1,5)=vint(3)
5813  p(2,5)=vint(4)
5814  IF(mint(141).NE.0) p(1,5)=vint(303)
5815  IF(mint(142).NE.0) p(2,5)=vint(304)
5816  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
5817  p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
5818  DO 120 j=1,3
5819  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5820  120 CONTINUE
5821  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5822  vint(7)=pyangl(p(1,1),p(1,2))
5823  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5824  vint(6)=pyangl(p(1,3),p(1,1))
5825  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5826  s=p(1,5)**2+p(2,5)**2+2d0*(p(1,4)*p(2,4)-p(1,3)*p(2,3))
5827 
5828 C...Set up kinematics for events with user-defined four-vectors.
5829  ELSEIF(mint(111).EQ.4) THEN
5830  pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
5831  p(1,5)=sign(sqrt(abs(pms1)),pms1)
5832  pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
5833  p(2,5)=sign(sqrt(abs(pms2)),pms2)
5834  DO 130 j=1,3
5835  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5836  130 CONTINUE
5837  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5838  vint(7)=pyangl(p(1,1),p(1,2))
5839  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5840  vint(6)=pyangl(p(1,3),p(1,1))
5841  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5842  s=(p(1,4)+p(2,4))**2
5843 
5844 C...Set up kinematics for events with user-defined five-vectors.
5845  ELSEIF(mint(111).EQ.5) THEN
5846  DO 140 j=1,3
5847  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5848  140 CONTINUE
5849  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5850  vint(7)=pyangl(p(1,1),p(1,2))
5851  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5852  vint(6)=pyangl(p(1,3),p(1,1))
5853  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5854  s=(p(1,4)+p(2,4))**2
5855 
5856 C...Set up kinematics for events with external user processes.
5857  ELSEIF(mint(111).GE.11) THEN
5858  p(1,5)=vint(3)
5859  p(2,5)=vint(4)
5860  IF(mint(141).NE.0) p(1,5)=vint(303)
5861  IF(mint(142).NE.0) p(2,5)=vint(304)
5862  p(1,1)=0d0
5863  p(1,2)=0d0
5864  p(2,1)=0d0
5865  p(2,2)=0d0
5866  p(1,3)=sqrt(max(0d0,ebmup(1)**2-p(1,5)**2))
5867  p(2,3)=-sqrt(max(0d0,ebmup(2)**2-p(2,5)**2))
5868  p(1,4)=ebmup(1)
5869  p(2,4)=ebmup(2)
5870  vint(10)=(p(1,3)+p(2,3))/(p(1,4)+p(2,4))
5871  CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
5872  s=(p(1,4)+p(2,4))**2
5873  ENDIF
5874 
5875 C...Return or error for too low CM energy.
5876  IF(modki.EQ.1.AND.s.LT.parp(2)**2) THEN
5877  IF(mstp(172).LE.1) THEN
5878  CALL pyerrm(23,
5879  & '(PYINKI:) too low invariant mass in this event')
5880  ELSE
5881  msti(61)=1
5882  RETURN
5883  ENDIF
5884  ENDIF
5885 
5886 C...Save information on incoming particles.
5887  vint(1)=sqrt(s)
5888  vint(2)=s
5889  IF(mint(111).GE.4) THEN
5890  IF(mint(141).EQ.0) THEN
5891  vint(3)=p(1,5)
5892  IF(mint(11).EQ.22.AND.p(1,5).LT.0) vint(307)=p(1,5)**2
5893  ELSE
5894  vint(303)=p(1,5)
5895  ENDIF
5896  IF(mint(142).EQ.0) THEN
5897  vint(4)=p(2,5)
5898  IF(mint(12).EQ.22.AND.p(2,5).LT.0) vint(308)=p(2,5)**2
5899  ELSE
5900  vint(304)=p(2,5)
5901  ENDIF
5902  ENDIF
5903  vint(5)=p(1,3)
5904  IF(modki.EQ.0) vint(289)=s
5905  DO 150 j=1,5
5906  v(1,j)=0d0
5907  v(2,j)=0d0
5908  vint(290+j)=p(1,j)
5909  vint(295+j)=p(2,j)
5910  150 CONTINUE
5911 
5912 C...Store pT cut-off and related constants to be used in generation.
5913  IF(modki.EQ.0) vint(285)=ckin(3)
5914  IF(mstp(82).LE.1) THEN
5915  ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
5916  ELSE
5917  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
5918  ENDIF
5919  vint(149)=4d0*ptmn**2/s
5920  vint(154)=ptmn
5921 
5922  RETURN
5923  END
5924 
5925 C*********************************************************************
5926 
5927 C...PYINPR
5928 C...Selects partonic subprocesses to be included in the simulation.
5929 
5930  SUBROUTINE pyinpr
5931 
5932 C...Double precision and integer declarations.
5933  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5934  IMPLICIT INTEGER(I-N)
5935  INTEGER PYK,PYCHGE,PYCOMP
5936 
5937 C...User process initialization commonblock.
5938  INTEGER MAXPUP
5939  parameter(maxpup=100)
5940  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5941  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5942  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5943  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5944  &lprup(maxpup)
5945  SAVE /heprup/
5946 
5947 C...Commonblocks and character variables.
5948  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5949  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
5950  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5951  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5952  common/pyint1/mint(400),vint(400)
5953  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5954  common/pyint6/proc(0:500)
5955  CHARACTER PROC*28
5956  SAVE /pydat1/,/pydat3/,/pysubs/,/pypars/,/pyint1/,/pyint2/,
5957  &/pyint6/
5958  CHARACTER CHIPR*10
5959 
5960 C...Reset processes to be included.
5961  IF(msel.NE.0) THEN
5962  DO 100 i=1,500
5963  msub(i)=0
5964  100 CONTINUE
5965  ENDIF
5966 
5967 C...Set running pTmin scale.
5968  IF(mstp(82).LE.1) THEN
5969  ptmrun=parp(81)*(vint(1)/parp(89))**parp(90)
5970  ELSE
5971  ptmrun=parp(82)*(vint(1)/parp(89))**parp(90)
5972  ENDIF
5973 
5974 C...Begin by assuming incoming photon to enter subprocess.
5975  IF(mint(11).EQ.22) mint(15)=22
5976  IF(mint(12).EQ.22) mint(16)=22
5977 
5978 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5979  IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
5980  msub(10)=1
5981  mint(123)=mint(122)+1
5982 
5983 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5984 C...allow mixture.
5985 C...Here also set a few parameters otherwise normally not touched.
5986  ELSEIF(mint(121).GT.1) THEN
5987 
5988 C...Parton distributions dampened at small Q2; go to low energies,
5989 C...alpha_s <1; no minimum pT cut-off a priori.
5990  IF(mstp(18).EQ.2) THEN
5991  mstp(57)=3
5992  parp(2)=2d0
5993  paru(115)=1d0
5994  ckin(5)=0.2d0
5995  ckin(6)=0.2d0
5996  ENDIF
5997 
5998 C...Define pT cut-off parameters and whether run involves low-pT.
5999  ptmvmd=ptmrun
6000  vint(154)=ptmvmd
6001  ptmdir=ptmvmd
6002  IF(mstp(18).EQ.2) ptmdir=parp(15)
6003  ptmano=ptmvmd
6004  IF(mstp(15).EQ.5) ptmano=0.60d0+
6005  & 0.125d0*log(1d0+0.10d0*vint(1))**2
6006  iptl=1
6007  IF(vint(285).GT.max(ptmvmd,ptmdir,ptmano)) iptl=0
6008  IF(msel.EQ.2) iptl=1
6009 
6010 C...Set up for p/gamma * gamma; real or virtual photons.
6011  IF(mint(121).EQ.3.OR.mint(121).EQ.6.OR.(mint(121).EQ.4.AND.
6012  & mstp(14).EQ.30)) THEN
6013 
6014 C...Set up for p/VMD * VMD.
6015  IF(mint(122).EQ.1) THEN
6016  mint(123)=2
6017  msub(11)=1
6018  msub(12)=1
6019  msub(13)=1
6020  msub(28)=1
6021  msub(53)=1
6022  msub(68)=1
6023  IF(iptl.EQ.1) msub(95)=1
6024  IF(msel.EQ.2) THEN
6025  msub(91)=1
6026  msub(92)=1
6027  msub(93)=1
6028  msub(94)=1
6029  ENDIF
6030  IF(iptl.EQ.1) ckin(3)=0d0
6031 
6032 C...Set up for p/VMD * direct gamma.
6033  ELSEIF(mint(122).EQ.2) THEN
6034  mint(123)=0
6035  IF(mint(121).EQ.6) mint(123)=5
6036  msub(131)=1
6037  msub(132)=1
6038  msub(135)=1
6039  msub(136)=1
6040  IF(iptl.EQ.1) ckin(3)=ptmdir
6041 
6042 C...Set up for p/VMD * anomalous gamma.
6043  ELSEIF(mint(122).EQ.3) THEN
6044  mint(123)=3
6045  IF(mint(121).EQ.6) mint(123)=7
6046  msub(11)=1
6047  msub(12)=1
6048  msub(13)=1
6049  msub(28)=1
6050  msub(53)=1
6051  msub(68)=1
6052  IF(iptl.EQ.1) msub(95)=1
6053  IF(msel.EQ.2) THEN
6054  msub(91)=1
6055  msub(92)=1
6056  msub(93)=1
6057  msub(94)=1
6058  ENDIF
6059  IF(iptl.EQ.1) ckin(3)=0d0
6060 
6061 C...Set up for DIS * p.
6062  ELSEIF(mint(122).EQ.4.AND.(iabs(mint(11)).GT.100.OR.
6063  & iabs(mint(12)).GT.100)) THEN
6064  mint(123)=8
6065  IF(iptl.EQ.1) msub(99)=1
6066 
6067 C...Set up for direct * direct gamma (switch off leptons).
6068  ELSEIF(mint(122).EQ.4) THEN
6069  mint(123)=0
6070  msub(137)=1
6071  msub(138)=1
6072  msub(139)=1
6073  msub(140)=1
6074  DO 110 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6075  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6076  110 CONTINUE
6077  IF(iptl.EQ.1) ckin(3)=ptmdir
6078 
6079 C...Set up for direct * anomalous gamma.
6080  ELSEIF(mint(122).EQ.5) THEN
6081  mint(123)=6
6082  msub(131)=1
6083  msub(132)=1
6084  msub(135)=1
6085  msub(136)=1
6086  IF(iptl.EQ.1) ckin(3)=ptmano
6087 
6088 C...Set up for anomalous * anomalous gamma.
6089  ELSEIF(mint(122).EQ.6) THEN
6090  mint(123)=3
6091  msub(11)=1
6092  msub(12)=1
6093  msub(13)=1
6094  msub(28)=1
6095  msub(53)=1
6096  msub(68)=1
6097  IF(iptl.EQ.1) msub(95)=1
6098  IF(msel.EQ.2) THEN
6099  msub(91)=1
6100  msub(92)=1
6101  msub(93)=1
6102  msub(94)=1
6103  ENDIF
6104  IF(iptl.EQ.1) ckin(3)=0d0
6105  ENDIF
6106 
6107 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6108  ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
6109 
6110 C...Set up for direct * direct gamma (switch off leptons).
6111  IF(mint(122).EQ.1) THEN
6112  mint(123)=0
6113  msub(137)=1
6114  msub(138)=1
6115  msub(139)=1
6116  msub(140)=1
6117  DO 120 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6118  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6119  120 CONTINUE
6120  IF(iptl.EQ.1) ckin(3)=ptmdir
6121 
6122 C...Set up for direct * VMD and VMD * direct gamma.
6123  ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.4) THEN
6124  mint(123)=5
6125  msub(131)=1
6126  msub(132)=1
6127  msub(135)=1
6128  msub(136)=1
6129  IF(iptl.EQ.1) ckin(3)=ptmdir
6130 
6131 C...Set up for direct * anomalous and anomalous * direct gamma.
6132  ELSEIF(mint(122).EQ.3.OR.mint(122).EQ.7) THEN
6133  mint(123)=6
6134  msub(131)=1
6135  msub(132)=1
6136  msub(135)=1
6137  msub(136)=1
6138  IF(iptl.EQ.1) ckin(3)=ptmano
6139 
6140 C...Set up for VMD*VMD.
6141  ELSEIF(mint(122).EQ.5) THEN
6142  mint(123)=2
6143  msub(11)=1
6144  msub(12)=1
6145  msub(13)=1
6146  msub(28)=1
6147  msub(53)=1
6148  msub(68)=1
6149  IF(iptl.EQ.1) msub(95)=1
6150  IF(msel.EQ.2) THEN
6151  msub(91)=1
6152  msub(92)=1
6153  msub(93)=1
6154  msub(94)=1
6155  ENDIF
6156  IF(iptl.EQ.1) ckin(3)=0d0
6157 
6158 C...Set up for VMD * anomalous and anomalous * VMD gamma.
6159  ELSEIF(mint(122).EQ.6.OR.mint(122).EQ.8) THEN
6160  mint(123)=7
6161  msub(11)=1
6162  msub(12)=1
6163  msub(13)=1
6164  msub(28)=1
6165  msub(53)=1
6166  msub(68)=1
6167  IF(iptl.EQ.1) msub(95)=1
6168  IF(msel.EQ.2) THEN
6169  msub(91)=1
6170  msub(92)=1
6171  msub(93)=1
6172  msub(94)=1
6173  ENDIF
6174  IF(iptl.EQ.1) ckin(3)=0d0
6175 
6176 C...Set up for anomalous * anomalous gamma.
6177  ELSEIF(mint(122).EQ.9) THEN
6178  mint(123)=3
6179  msub(11)=1
6180  msub(12)=1
6181  msub(13)=1
6182  msub(28)=1
6183  msub(53)=1
6184  msub(68)=1
6185  IF(iptl.EQ.1) msub(95)=1
6186  IF(msel.EQ.2) THEN
6187  msub(91)=1
6188  msub(92)=1
6189  msub(93)=1
6190  msub(94)=1
6191  ENDIF
6192  IF(iptl.EQ.1) ckin(3)=0d0
6193 
6194 C...Set up for DIS * VMD and VMD * DIS gamma.
6195  ELSEIF(mint(122).EQ.10.OR.mint(122).EQ.12) THEN
6196  mint(123)=8
6197  IF(iptl.EQ.1) msub(99)=1
6198 
6199 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6200  ELSEIF(mint(122).EQ.11.OR.mint(122).EQ.13) THEN
6201  mint(123)=9
6202  IF(iptl.EQ.1) msub(99)=1
6203  ENDIF
6204 
6205 C...Set up for gamma* * p; virtual photons = dir, res.
6206  ELSEIF(mint(121).EQ.2) THEN
6207 
6208 C...Set up for direct * p.
6209  IF(mint(122).EQ.1) THEN
6210  mint(123)=0
6211  msub(131)=1
6212  msub(132)=1
6213  msub(135)=1
6214  msub(136)=1
6215  IF(iptl.EQ.1) ckin(3)=ptmdir
6216 
6217 C...Set up for resolved * p.
6218  ELSEIF(mint(122).EQ.2) THEN
6219  mint(123)=1
6220  msub(11)=1
6221  msub(12)=1
6222  msub(13)=1
6223  msub(28)=1
6224  msub(53)=1
6225  msub(68)=1
6226  IF(iptl.EQ.1) msub(95)=1
6227  IF(msel.EQ.2) THEN
6228  msub(91)=1
6229  msub(92)=1
6230  msub(93)=1
6231  msub(94)=1
6232  ENDIF
6233  IF(iptl.EQ.1) ckin(3)=0d0
6234  ENDIF
6235 
6236 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6237  ELSEIF(mint(121).EQ.4) THEN
6238 
6239 C...Set up for direct * direct gamma (switch off leptons).
6240  IF(mint(122).EQ.1) THEN
6241  mint(123)=0
6242  msub(137)=1
6243  msub(138)=1
6244  msub(139)=1
6245  msub(140)=1
6246  DO 130 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6247  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6248  130 CONTINUE
6249  IF(iptl.EQ.1) ckin(3)=ptmdir
6250 
6251 C...Set up for direct * resolved and resolved * direct gamma.
6252  ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.3) THEN
6253  mint(123)=5
6254  msub(131)=1
6255  msub(132)=1
6256  msub(135)=1
6257  msub(136)=1
6258  IF(iptl.EQ.1) ckin(3)=ptmdir
6259 
6260 C...Set up for resolved * resolved gamma.
6261  ELSEIF(mint(122).EQ.4) THEN
6262  mint(123)=2
6263  msub(11)=1
6264  msub(12)=1
6265  msub(13)=1
6266  msub(28)=1
6267  msub(53)=1
6268  msub(68)=1
6269  IF(iptl.EQ.1) msub(95)=1
6270  IF(msel.EQ.2) THEN
6271  msub(91)=1
6272  msub(92)=1
6273  msub(93)=1
6274  msub(94)=1
6275  ENDIF
6276  IF(iptl.EQ.1) ckin(3)=0d0
6277  ENDIF
6278 
6279 C...End of special set up for gamma-p and gamma-gamma.
6280  ENDIF
6281  ckin(1)=2d0*ckin(3)
6282  ENDIF
6283 
6284 C...Flavour information for individual beams.
6285  DO 140 i=1,2
6286  mint(40+i)=1
6287  IF(mint(123).GE.1.AND.mint(10+i).EQ.22) mint(40+i)=2
6288  IF(iabs(mint(10+i)).GT.100) mint(40+i)=2
6289  mint(44+i)=mint(40+i)
6290  IF(mstp(11).GE.1.AND.(iabs(mint(10+i)).EQ.11.OR.
6291  & iabs(mint(10+i)).EQ.13.OR.iabs(mint(10+i)).EQ.15)) mint(44+i)=3
6292  140 CONTINUE
6293 
6294 C...If two real gammas, whereof one direct, pick the first.
6295 C...For two virtual photons, keep requested order.
6296  IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
6297  IF(mstp(14).LE.10.AND.mint(123).GE.4.AND.mint(123).LE.6) THEN
6298  mint(41)=1
6299  mint(45)=1
6300  ELSEIF(mstp(14).EQ.12.OR.mstp(14).EQ.13.OR.mstp(14).EQ.22.OR.
6301  & mstp(14).EQ.26.OR.mstp(14).EQ.27) THEN
6302  mint(41)=1
6303  mint(45)=1
6304  ELSEIF(mstp(14).EQ.14.OR.mstp(14).EQ.17.OR.mstp(14).EQ.23.OR.
6305  & mstp(14).EQ.28.OR.mstp(14).EQ.29) THEN
6306  mint(42)=1
6307  mint(46)=1
6308  ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.2
6309  & .OR.mint(122).EQ.3.OR.mint(122).EQ.10.OR.mint(122).EQ.11)) THEN
6310  mint(41)=1
6311  mint(45)=1
6312  ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.4
6313  & .OR.mint(122).EQ.7.OR.mint(122).EQ.12.OR.mint(122).EQ.13)) THEN
6314  mint(42)=1
6315  mint(46)=1
6316  ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.2) THEN
6317  mint(41)=1
6318  mint(45)=1
6319  ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.3) THEN
6320  mint(42)=1
6321  mint(46)=1
6322  ENDIF
6323  ELSEIF(mint(11).EQ.22.OR.mint(12).EQ.22) THEN
6324  IF(mstp(14).EQ.26.OR.mstp(14).EQ.28.OR.mint(122).EQ.4) THEN
6325  IF(mint(11).EQ.22) THEN
6326  mint(41)=1
6327  mint(45)=1
6328  ELSE
6329  mint(42)=1
6330  mint(46)=1
6331  ENDIF
6332  ENDIF
6333  IF(mint(123).GE.4.AND.mint(123).LE.7) CALL pyerrm(26,
6334  & '(PYINPR:) unallowed MSTP(14) code for single photon')
6335  ENDIF
6336 
6337 C...Flavour information on combination of incoming particles.
6338  mint(43)=2*mint(41)+mint(42)-2
6339  mint(44)=mint(43)
6340  IF(mint(123).LE.0) THEN
6341  IF(mint(11).EQ.22) mint(43)=mint(43)+2
6342  IF(mint(12).EQ.22) mint(43)=mint(43)+1
6343  ELSEIF(mint(123).LE.3) THEN
6344  IF(mint(11).EQ.22) mint(44)=mint(44)-2
6345  IF(mint(12).EQ.22) mint(44)=mint(44)-1
6346  ELSEIF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
6347  mint(43)=4
6348  mint(44)=1
6349  ENDIF
6350  mint(47)=2*min(2,mint(45))+min(2,mint(46))-2
6351  IF(min(mint(45),mint(46)).EQ.3) mint(47)=5
6352  IF(mint(45).EQ.1.AND.mint(46).EQ.3) mint(47)=6
6353  IF(mint(45).EQ.3.AND.mint(46).EQ.1) mint(47)=7
6354  mint(50)=0
6355  IF(mint(41).EQ.2.AND.mint(42).EQ.2.AND.mint(111).NE.12) mint(50)=1
6356  mint(107)=0
6357  mint(108)=0
6358  IF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
6359  IF((mint(122).GE.4.AND.mint(122).LE.6).OR.mint(122).EQ.12)
6360  & mint(107)=2
6361  IF((mint(122).GE.7.AND.mint(122).LE.9).OR.mint(122).EQ.13)
6362  & mint(107)=3
6363  IF(mint(122).EQ.10.OR.mint(122).EQ.11) mint(107)=4
6364  IF(mint(122).EQ.2.OR.mint(122).EQ.5.OR.mint(122).EQ.8.OR.
6365  & mint(122).EQ.10) mint(108)=2
6366  IF(mint(122).EQ.3.OR.mint(122).EQ.6.OR.mint(122).EQ.9.OR.
6367  & mint(122).EQ.11) mint(108)=3
6368  IF(mint(122).EQ.12.OR.mint(122).EQ.13) mint(108)=4
6369  ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.25) THEN
6370  IF(mint(122).GE.3) mint(107)=1
6371  IF(mint(122).EQ.2.OR.mint(122).EQ.4) mint(108)=1
6372  ELSEIF(mint(121).EQ.2) THEN
6373  IF(mint(122).EQ.2.AND.mint(11).EQ.22) mint(107)=1
6374  IF(mint(122).EQ.2.AND.mint(12).EQ.22) mint(108)=1
6375  ELSE
6376  IF(mint(11).EQ.22) THEN
6377  mint(107)=mint(123)
6378  IF(mint(123).GE.4) mint(107)=0
6379  IF(mint(123).EQ.7) mint(107)=2
6380  IF(mstp(14).EQ.26.OR.mstp(14).EQ.27) mint(107)=4
6381  IF(mstp(14).EQ.28) mint(107)=2
6382  IF(mstp(14).EQ.29) mint(107)=3
6383  IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
6384  & mint(107)=4
6385  ENDIF
6386  IF(mint(12).EQ.22) THEN
6387  mint(108)=mint(123)
6388  IF(mint(123).GE.4) mint(108)=mint(123)-3
6389  IF(mint(123).EQ.7) mint(108)=3
6390  IF(mstp(14).EQ.26) mint(108)=2
6391  IF(mstp(14).EQ.27) mint(108)=3
6392  IF(mstp(14).EQ.28.OR.mstp(14).EQ.29) mint(108)=4
6393  IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
6394  & mint(108)=4
6395  ENDIF
6396  IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.(mstp(14).EQ.14.OR.
6397  & mstp(14).EQ.17.OR.mstp(14).EQ.18.OR.mstp(14).EQ.23)) THEN
6398  minttp=mint(107)
6399  mint(107)=mint(108)
6400  mint(108)=minttp
6401  ENDIF
6402  ENDIF
6403  IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
6404  IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
6405 
6406 C...Select default processes according to incoming beams
6407 C...(already done for gamma-p and gamma-gamma with
6408 C...MSTP(14) = 10, 20, 25 or 30).
6409  IF(mint(121).GT.1) THEN
6410  ELSEIF(msel.EQ.1.OR.msel.EQ.2) THEN
6411 
6412  IF(mint(43).EQ.1) THEN
6413 C...Lepton + lepton -> gamma/Z0 or W.
6414  IF(mint(11)+mint(12).EQ.0) msub(1)=1
6415  IF(mint(11)+mint(12).NE.0) msub(2)=1
6416 
6417  ELSEIF(mint(43).LE.3.AND.mint(123).EQ.0.AND.
6418  & (mint(11).EQ.22.OR.mint(12).EQ.22)) THEN
6419 C...Unresolved photon + lepton: Compton scattering.
6420  msub(133)=1
6421  msub(134)=1
6422 
6423  ELSEIF((mint(123).EQ.8.OR.mint(123).EQ.9).AND.(mint(11).EQ.22
6424  & .OR.mint(12).EQ.22)) THEN
6425 C...DIS as pure gamma* + f -> f process.
6426  msub(99)=1
6427 
6428  ELSEIF(mint(43).LE.3) THEN
6429 C...Lepton + hadron: deep inelastic scattering.
6430  msub(10)=1
6431 
6432  ELSEIF(mint(123).EQ.0.AND.mint(11).EQ.22.AND.
6433  & mint(12).EQ.22) THEN
6434 C...Two unresolved photons: fermion pair production,
6435 C...exclude lepton pairs.
6436  DO 150 isub=137,140
6437  msub(isub)=1
6438  150 CONTINUE
6439  DO 160 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6440  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6441  160 CONTINUE
6442  ptmdir=ptmrun
6443  IF(mstp(18).EQ.2) ptmdir=parp(15)
6444  IF(ckin(3).LT.ptmrun.OR.msel.EQ.2) ckin(3)=ptmdir
6445  ckin(1)=max(ckin(1),2d0*ckin(3))
6446 
6447  ELSEIF((mint(123).EQ.0.AND.(mint(11).EQ.22.OR.mint(12).EQ.22))
6448  & .OR.(mint(123).GE.4.AND.mint(123).LE.6.AND.mint(11).EQ.22.AND.
6449  & mint(12).EQ.22)) THEN
6450 C...Unresolved photon + hadron: photon-parton scattering.
6451  DO 170 isub=131,136
6452  msub(isub)=1
6453  170 CONTINUE
6454 
6455  ELSEIF(msel.EQ.1) THEN
6456 C...High-pT QCD processes:
6457  msub(11)=1
6458  msub(12)=1
6459  msub(13)=1
6460  msub(28)=1
6461  msub(53)=1
6462  msub(68)=1
6463  ptmn=ptmrun
6464  vint(154)=ptmn
6465  IF(ckin(3).LT.ptmn) msub(95)=1
6466  IF(msub(95).EQ.1.AND.mint(50).EQ.0) msub(95)=0
6467 
6468  ELSE
6469 C...All QCD processes:
6470  msub(11)=1
6471  msub(12)=1
6472  msub(13)=1
6473  msub(28)=1
6474  msub(53)=1
6475  msub(68)=1
6476  msub(91)=1
6477  msub(92)=1
6478  msub(93)=1
6479  msub(94)=1
6480  msub(95)=1
6481  ENDIF
6482 
6483  ELSEIF(msel.GE.4.AND.msel.LE.8) THEN
6484 C...Heavy quark production.
6485  msub(81)=1
6486  msub(82)=1
6487  msub(84)=1
6488  DO 180 j=1,min(8,mdcy(21,3))
6489  mdme(mdcy(21,2)+j-1,1)=0
6490  180 CONTINUE
6491  mdme(mdcy(21,2)+msel-1,1)=1
6492  msub(85)=1
6493  DO 190 j=1,min(12,mdcy(22,3))
6494  mdme(mdcy(22,2)+j-1,1)=0
6495  190 CONTINUE
6496  mdme(mdcy(22,2)+msel-1,1)=1
6497 
6498  ELSEIF(msel.EQ.10) THEN
6499 C...Prompt photon production:
6500  msub(14)=1
6501  msub(18)=1
6502  msub(29)=1
6503 
6504  ELSEIF(msel.EQ.11) THEN
6505 C...Z0/gamma* production:
6506  msub(1)=1
6507 
6508  ELSEIF(msel.EQ.12) THEN
6509 C...W+/- production:
6510  msub(2)=1
6511 
6512  ELSEIF(msel.EQ.13) THEN
6513 C...Z0 + jet:
6514  msub(15)=1
6515  msub(30)=1
6516 
6517  ELSEIF(msel.EQ.14) THEN
6518 C...W+/- + jet:
6519  msub(16)=1
6520  msub(31)=1
6521 
6522  ELSEIF(msel.EQ.15) THEN
6523 C...Z0 & W+/- pair production:
6524  msub(19)=1
6525  msub(20)=1
6526  msub(22)=1
6527  msub(23)=1
6528  msub(25)=1
6529 
6530  ELSEIF(msel.EQ.16) THEN
6531 C...h0 production:
6532  msub(3)=1
6533  msub(102)=1
6534  msub(103)=1
6535  msub(123)=1
6536  msub(124)=1
6537 
6538  ELSEIF(msel.EQ.17) THEN
6539 C...h0 & Z0 or W+/- pair production:
6540  msub(24)=1
6541  msub(26)=1
6542 
6543  ELSEIF(msel.EQ.18) THEN
6544 C...h0 production; interesting processes in e+e-.
6545  msub(24)=1
6546  msub(103)=1
6547  msub(123)=1
6548  msub(124)=1
6549 
6550  ELSEIF(msel.EQ.19) THEN
6551 C...h0, H0 and A0 production; interesting processes in e+e-.
6552  msub(24)=1
6553  msub(103)=1
6554  msub(123)=1
6555  msub(124)=1
6556  msub(153)=1
6557  msub(171)=1
6558  msub(173)=1
6559  msub(174)=1
6560  msub(158)=1
6561  msub(176)=1
6562  msub(178)=1
6563  msub(179)=1
6564 
6565  ELSEIF(msel.EQ.21) THEN
6566 C...Z'0 production:
6567  msub(141)=1
6568 
6569  ELSEIF(msel.EQ.22) THEN
6570 C...W'+/- production:
6571  msub(142)=1
6572 
6573  ELSEIF(msel.EQ.23) THEN
6574 C...H+/- production:
6575  msub(143)=1
6576 
6577  ELSEIF(msel.EQ.24) THEN
6578 C...R production:
6579  msub(144)=1
6580 
6581  ELSEIF(msel.EQ.25) THEN
6582 C...LQ (leptoquark) production.
6583  msub(145)=1
6584  msub(162)=1
6585  msub(163)=1
6586  msub(164)=1
6587 
6588  ELSEIF(msel.GE.35.AND.msel.LE.38) THEN
6589 C...Production of one heavy quark (W exchange):
6590  msub(83)=1
6591  DO 200 j=1,min(8,mdcy(21,3))
6592  mdme(mdcy(21,2)+j-1,1)=0
6593  200 CONTINUE
6594  mdme(mdcy(21,2)+msel-31,1)=1
6595 
6596 CMRENNA++Define SUSY alternatives.
6597  ELSEIF(msel.EQ.39) THEN
6598 C...Turn on all SUSY processes.
6599  IF(mint(43).EQ.4) THEN
6600 C...Hadron-hadron processes.
6601  DO 210 i=201,301
6602  IF(iset(i).GE.0) msub(i)=1
6603  210 CONTINUE
6604  ELSEIF(mint(43).EQ.1) THEN
6605 C...Lepton-lepton processes: QED production of squarks.
6606  DO 220 i=201,214
6607  msub(i)=1
6608  220 CONTINUE
6609  msub(210)=0
6610  msub(211)=0
6611  msub(212)=0
6612  DO 230 i=216,228
6613  msub(i)=1
6614  230 CONTINUE
6615  DO 240 i=261,263
6616  msub(i)=1
6617  240 CONTINUE
6618  msub(277)=1
6619  msub(278)=1
6620  ENDIF
6621 
6622  ELSEIF(msel.EQ.40) THEN
6623 C...Gluinos and squarks.
6624  IF(mint(43).EQ.4) THEN
6625  msub(243)=1
6626  msub(244)=1
6627  msub(258)=1
6628  msub(259)=1
6629  msub(261)=1
6630  msub(262)=1
6631  msub(264)=1
6632  msub(265)=1
6633  DO 250 i=271,296
6634  msub(i)=1
6635  250 CONTINUE
6636  ELSEIF(mint(43).EQ.1) THEN
6637  msub(277)=1
6638  msub(278)=1
6639  ENDIF
6640 
6641  ELSEIF(msel.EQ.41) THEN
6642 C...Stop production.
6643  msub(261)=1
6644  msub(262)=1
6645  msub(263)=1
6646  IF(mint(43).EQ.4) THEN
6647  msub(264)=1
6648  msub(265)=1
6649  ENDIF
6650 
6651  ELSEIF(msel.EQ.42) THEN
6652 C...Slepton production.
6653  DO 260 i=201,214
6654  msub(i)=1
6655  260 CONTINUE
6656  IF(mint(43).NE.4) THEN
6657  msub(210)=0
6658  msub(211)=0
6659  msub(212)=0
6660  ENDIF
6661 
6662  ELSEIF(msel.EQ.43) THEN
6663 C...Neutralino/Chargino + Gluino/Squark.
6664  IF(mint(43).EQ.4) THEN
6665  DO 270 i=237,242
6666  msub(i)=1
6667  270 CONTINUE
6668  DO 280 i=246,254
6669  msub(i)=1
6670  280 CONTINUE
6671  msub(256)=1
6672  ENDIF
6673 
6674  ELSEIF(msel.EQ.44) THEN
6675 C...Neutralino/Chargino pair production.
6676  IF(mint(43).EQ.4) THEN
6677  DO 290 i=216,236
6678  msub(i)=1
6679  290 CONTINUE
6680  ELSEIF(mint(43).EQ.1) THEN
6681  DO 300 i=216,228
6682  msub(i)=1
6683  300 CONTINUE
6684  ENDIF
6685 
6686  ELSEIF(msel.EQ.45) THEN
6687 C...Sbottom production.
6688  msub(287)=1
6689  msub(288)=1
6690  IF(mint(43).EQ.4) THEN
6691  DO 310 i=281,296
6692  msub(i)=1
6693  310 CONTINUE
6694  ENDIF
6695 
6696  ELSEIF(msel.EQ.50) THEN
6697 C...Pair production of technipions and gauge bosons.
6698  DO 320 i=361,368
6699  msub(i)=1
6700  320 CONTINUE
6701  IF(mint(43).EQ.4) THEN
6702  DO 330 i=370,377
6703  msub(i)=1
6704  330 CONTINUE
6705  ENDIF
6706 
6707  ELSEIF(msel.EQ.51) THEN
6708 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6709  DO 340 i=381,386
6710  msub(i)=1
6711  340 CONTINUE
6712 
6713  ELSEIF(msel.EQ.61) THEN
6714 C...Charmonium production in colour octet model, with recoiling parton.
6715  DO 342 i=421,439
6716  msub(i)=1
6717  342 CONTINUE
6718 
6719  ELSEIF(msel.EQ.62) THEN
6720 C...Bottomonium production in colour octet model, with recoiling parton.
6721  DO 344 i=461,479
6722  msub(i)=1
6723  344 CONTINUE
6724 
6725  ELSEIF(msel.EQ.63) THEN
6726 C...Charmonium and bottomonium production in colour octet model.
6727  DO 346 i=421,439
6728  msub(i)=1
6729  msub(i+40)=1
6730  346 CONTINUE
6731  ENDIF
6732 
6733 C...Find heaviest new quark flavour allowed in processes 81-84.
6734  kflqm=1
6735  DO 350 i=1,min(8,mdcy(21,3))
6736  idc=i+mdcy(21,2)-1
6737  IF(mdme(idc,1).LE.0) GOTO 350
6738  kflqm=i
6739  350 CONTINUE
6740  IF(mstp(7).GE.1.AND.mstp(7).LE.8.AND.(msel.LE.3.OR.msel.GE.9))
6741  &kflqm=mstp(7)
6742  mint(55)=kflqm
6743  kfpr(81,1)=kflqm
6744  kfpr(81,2)=kflqm
6745  kfpr(82,1)=kflqm
6746  kfpr(82,2)=kflqm
6747  kfpr(83,1)=kflqm
6748  kfpr(84,1)=kflqm
6749  kfpr(84,2)=kflqm
6750 
6751 C...Find heaviest new fermion flavour allowed in process 85.
6752  kflfm=1
6753  DO 360 i=1,min(12,mdcy(22,3))
6754  idc=i+mdcy(22,2)-1
6755  IF(mdme(idc,1).LE.0) GOTO 360
6756  kflfm=kfdp(idc,1)
6757  360 CONTINUE
6758  IF(((mstp(7).GE.1.AND.mstp(7).LE.8).OR.(mstp(7).GE.11.AND.
6759  &mstp(7).LE.18)).AND.(msel.LE.3.OR.msel.GE.9)) kflfm=mstp(7)
6760  mint(56)=kflfm
6761  kfpr(85,1)=kflfm
6762  kfpr(85,2)=kflfm
6763 
6764 C...Import relevant information on external user processes.
6765  IF(mint(111).GE.11) THEN
6766  ipypr=0
6767  DO 390 iup=1,nprup
6768 C...Find next empty PYTHIA process number slot and enable it.
6769  370 ipypr=ipypr+1
6770  IF(ipypr.GT.500) CALL pyerrm(26,
6771  & '(PYINPR.) no more empty slots for user processes')
6772  IF(iset(ipypr).GE.0.AND.iset(ipypr).LE.9) GOTO 370
6773  IF(ipypr.GE.91.AND.ipypr.LE.100) GOTO 370
6774  iset(ipypr)=11
6775 C...Overwrite KFPR with references back to process number and ID.
6776  kfpr(ipypr,1)=iup
6777  kfpr(ipypr,2)=lprup(iup)
6778 C...Process title.
6779  WRITE(chipr,'(I10)') lprup(iup)
6780  ichin=1
6781  DO 380 ich=1,9
6782  IF(chipr(ich:ich).EQ.' ') ichin=ich+1
6783  380 CONTINUE
6784  proc(ipypr)='User process '//chipr(ichin:10)//' '
6785 C...Switch on process.
6786  msub(ipypr)=1
6787  390 CONTINUE
6788  ENDIF
6789 
6790  RETURN
6791  END
6792 
6793 C*********************************************************************
6794 
6795 C...PYXTOT
6796 C...Parametrizes total, elastic and diffractive cross-sections
6797 C...for different energies and beams. Donnachie-Landshoff for
6798 C...total and Schuler-Sjostrand for elastic and diffractive.
6799 C...Process code IPROC:
6800 C...= 1 : p + p;
6801 C...= 2 : pbar + p;
6802 C...= 3 : pi+ + p;
6803 C...= 4 : pi- + p;
6804 C...= 5 : pi0 + p;
6805 C...= 6 : phi + p;
6806 C...= 7 : J/psi + p;
6807 C...= 11 : rho + rho;
6808 C...= 12 : rho + phi;
6809 C...= 13 : rho + J/psi;
6810 C...= 14 : phi + phi;
6811 C...= 15 : phi + J/psi;
6812 C...= 16 : J/psi + J/psi;
6813 C...= 21 : gamma + p (DL);
6814 C...= 22 : gamma + p (VDM).
6815 C...= 23 : gamma + pi (DL);
6816 C...= 24 : gamma + pi (VDM);
6817 C...= 25 : gamma + gamma (DL);
6818 C...= 26 : gamma + gamma (VDM).
6819 
6820  SUBROUTINE pyxtot
6821 
6822 C...Double precision and integer declarations.
6823  IMPLICIT DOUBLE PRECISION(a-h, o-z)
6824  IMPLICIT INTEGER(I-N)
6825  INTEGER PYK,PYCHGE,PYCOMP
6826 C...Commonblocks.
6827  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6828  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6829  common/pypars/mstp(200),parp(200),msti(200),pari(200)
6830  common/pyint1/mint(400),vint(400)
6831  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
6832  common/pyint7/sigt(0:6,0:6,0:5)
6833  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint5/,/pyint7/
6834 C...Local arrays.
6835  dimension nproc(30),xpar(30),ypar(30),ihada(20),ihadb(20),
6836  &pmhad(4),bhad(4),betp(4),ifitsd(20),ifitdd(20),ceffs(10,8),
6837  &ceffd(10,9),sigtmp(6,0:5)
6838 
6839 C...Common constants.
6840  DATA eps/0.0808d0/, eta/-0.4525d0/, alp/0.25d0/, cres/2d0/,
6841  &pmrc/1.062d0/, smp/0.880d0/, facel/0.0511d0/, facsd/0.0336d0/,
6842  &facdd/0.0084d0/
6843 
6844 C...Number of multiple processes to be evaluated (= 0 : undefined).
6845  DATA nproc/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6846 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6847  DATA xpar/2*21.70d0,3*13.63d0,10.01d0,0.970d0,3*0d0,
6848  &8.56d0,6.29d0,0.609d0,4.62d0,0.447d0,0.0434d0,4*0d0,
6849  &0.0677d0,0.0534d0,0.0425d0,0.0335d0,2.11d-4,1.31d-4,4*0d0/
6850  DATA ypar/
6851  &56.08d0,98.39d0,27.56d0,36.02d0,31.79d0,-1.51d0,-0.146d0,3*0d0,
6852  &13.08d0,-0.62d0,-0.060d0,0.030d0,-0.0028d0,0.00028d0,4*0d0,
6853  &0.129d0,0.115d0,0.081d0,0.072d0,2.15d-4,1.70d-4,4*0d0/
6854 
6855 C...Beam and target hadron class:
6856 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6857  DATA ihada/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6858  DATA ihadb/7*1,3*0,2,3,4,3,2*4,4*0/
6859 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6860  DATA pmhad/0.938d0,0.770d0,1.020d0,3.097d0/
6861  DATA bhad/2.3d0,1.4d0,1.4d0,0.23d0/
6862  DATA betp/4.658d0,2.926d0,2.149d0,0.208d0/
6863 
6864 C...Fitting constants used in parametrizations of diffractive results.
6865  DATA ifitsd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6866  DATA ifitdd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6867  DATA ((ceffs(j1,j2),j2=1,8),j1=1,10)/
6868  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.213d0, 0.0d0, -0.47d0, 150d0,
6869  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.267d0, 0.0d0, -0.47d0, 100d0,
6870  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.232d0, 0.0d0, -0.47d0, 110d0,
6871  &0.213d0, 7.0d0, -0.55d0, 800d0, 0.115d0, 0.0d0, -0.47d0, 110d0,
6872  &0.267d0, 0.0d0, -0.46d0, 75d0, 0.267d0, 0.0d0, -0.46d0, 75d0,
6873  &0.232d0, 0.0d0, -0.46d0, 85d0, 0.267d0, 0.0d0, -0.48d0, 100d0,
6874  &0.115d0, 0.0d0, -0.50d0, 90d0, 0.267d0, 6.0d0, -0.56d0, 420d0,
6875  &0.232d0, 0.0d0, -0.48d0, 110d0, 0.232d0, 0.0d0, -0.48d0, 110d0,
6876  &0.115d0, 0.0d0, -0.52d0, 120d0, 0.232d0, 6.0d0, -0.56d0, 470d0,
6877  &0.115d0, 5.5d0, -0.58d0, 570d0, 0.115d0, 5.5d0, -0.58d0, 570d0/
6878  DATA ((ceffd(j1,j2),j2=1,9),j1=1,10)/
6879  &3.11d0, -7.34d0, 9.71d0, 0.068d0, -0.42d0, 1.31d0,
6880  &-1.37d0, 35.0d0, 118d0, 3.11d0, -7.10d0, 10.6d0,
6881  &0.073d0, -0.41d0, 1.17d0, -1.41d0, 31.6d0, 95d0,
6882  &3.12d0, -7.43d0, 9.21d0, 0.067d0, -0.44d0, 1.41d0,
6883  &-1.35d0, 36.5d0, 132d0, 3.13d0, -8.18d0, -4.20d0,
6884  &0.056d0, -0.71d0, 3.12d0, -1.12d0, 55.2d0, 1298d0,
6885  &3.11d0, -6.90d0, 11.4d0, 0.078d0, -0.40d0, 1.05d0,
6886  &-1.40d0, 28.4d0, 78d0, 3.11d0, -7.13d0, 10.0d0,
6887  &0.071d0, -0.41d0, 1.23d0, -1.34d0, 33.1d0, 105d0,
6888  &3.12d0, -7.90d0, -1.49d0, 0.054d0, -0.64d0, 2.72d0,
6889  &-1.13d0, 53.1d0, 995d0, 3.11d0, -7.39d0, 8.22d0,
6890  &0.065d0, -0.44d0, 1.45d0, -1.36d0, 38.1d0, 148d0,
6891  &3.18d0, -8.95d0, -3.37d0, 0.057d0, -0.76d0, 3.32d0,
6892  &-1.12d0, 55.6d0, 1472d0, 4.18d0, -29.2d0, 56.2d0,
6893  &0.074d0, -1.36d0, 6.67d0, -1.14d0, 116.2d0, 6532d0/
6894 
6895 C...Parameters. Combinations of the energy.
6896  aem=paru(101)
6897  pmth=parp(102)
6898  s=vint(2)
6899  srt=vint(1)
6900  seps=s**eps
6901  seta=s**eta
6902  slog=log(s)
6903 
6904 C...Ratio of gamma/pi (for rescaling in parton distributions).
6905  vint(281)=(xpar(22)*seps+ypar(22)*seta)/
6906  &(xpar(5)*seps+ypar(5)*seta)
6907  vint(317)=1d0
6908  IF(mint(50).NE.1) RETURN
6909 
6910 C...Order flavours of incoming particles: KF1 < KF2.
6911  IF(iabs(mint(11)).LE.iabs(mint(12))) THEN
6912  kf1=iabs(mint(11))
6913  kf2=iabs(mint(12))
6914  iord=1
6915  ELSE
6916  kf1=iabs(mint(12))
6917  kf2=iabs(mint(11))
6918  iord=2
6919  ENDIF
6920  isgn12=isign(1,mint(11)*mint(12))
6921 
6922 C...Find process number (for lookup tables).
6923  IF(kf1.GT.1000) THEN
6924  iproc=1
6925  IF(isgn12.LT.0) iproc=2
6926  ELSEIF(kf1.GT.100.AND.kf2.GT.1000) THEN
6927  iproc=3
6928  IF(isgn12.LT.0) iproc=4
6929  IF(kf1.EQ.111) iproc=5
6930  ELSEIF(kf1.GT.100) THEN
6931  iproc=11
6932  ELSEIF(kf2.GT.1000) THEN
6933  iproc=21
6934  IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=22
6935  ELSEIF(kf2.GT.100) THEN
6936  iproc=23
6937  IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=24
6938  ELSE
6939  iproc=25
6940  IF(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7) iproc=26
6941  ENDIF
6942 
6943 C... Number of multiple processes to be stored; beam/target side.
6944  npr=nproc(iproc)
6945  mint(101)=1
6946  mint(102)=1
6947  IF(npr.EQ.3) THEN
6948  mint(100+iord)=4
6949  ELSEIF(npr.EQ.6) THEN
6950  mint(101)=4
6951  mint(102)=4
6952  ENDIF
6953  n1=0
6954  IF(mint(101).EQ.4) n1=4
6955  n2=0
6956  IF(mint(102).EQ.4) n2=4
6957 
6958 C...Do not do any more for user-set or undefined cross-sections.
6959  IF(mstp(31).LE.0) RETURN
6960  IF(npr.EQ.0) CALL pyerrm(26,
6961  &'(PYXTOT:) cross section for this process not yet implemented')
6962 
6963 C...Parameters. Combinations of the energy.
6964  aem=paru(101)
6965  pmth=parp(102)
6966  s=vint(2)
6967  srt=vint(1)
6968  seps=s**eps
6969  seta=s**eta
6970  slog=log(s)
6971 
6972 C...Loop over multiple processes (for VDM).
6973  DO 110 i=1,npr
6974  IF(npr.EQ.1) THEN
6975  ipr=iproc
6976  ELSEIF(npr.EQ.3) THEN
6977  ipr=i+4
6978  IF(kf2.LT.1000) ipr=i+10
6979  ELSEIF(npr.EQ.6) THEN
6980  ipr=i+10
6981  ENDIF
6982 
6983 C...Evaluate hadron species, mass, slope contribution and fit number.
6984  iha=ihada(ipr)
6985  ihb=ihadb(ipr)
6986  pma=pmhad(iha)
6987  pmb=pmhad(ihb)
6988  bha=bhad(iha)
6989  bhb=bhad(ihb)
6990  isd=ifitsd(ipr)
6991  idd=ifitdd(ipr)
6992 
6993 C...Skip if energy too low relative to masses.
6994  DO 100 j=0,5
6995  sigtmp(i,j)=0d0
6996  100 CONTINUE
6997  IF(srt.LT.pma+pmb+parp(104)) GOTO 110
6998 
6999 C...Total cross-section. Elastic slope parameter and cross-section.
7000  sigtmp(i,0)=xpar(ipr)*seps+ypar(ipr)*seta
7001  bel=2d0*bha+2d0*bhb+4d0*seps-4.2d0
7002  sigtmp(i,1)=facel*sigtmp(i,0)**2/bel
7003 
7004 C...Diffractive scattering A + B -> X + B.
7005  bsd=2d0*bhb
7006  sqml=(pma+pmth)**2
7007  sqmu=s*ceffs(isd,1)+ceffs(isd,2)
7008  sum1=log((bsd+2d0*alp*log(s/sqml))/
7009  & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
7010  bxb=ceffs(isd,3)+ceffs(isd,4)/s
7011  sum2=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)/
7012  & (bsd+2d0*alp*log(s/((pma+pmth)*(pma+pmrc)))+bxb)
7013  sigtmp(i,2)=facsd*xpar(ipr)*betp(ihb)*max(0d0,sum1+sum2)
7014 
7015 C...Diffractive scattering A + B -> A + X.
7016  bsd=2d0*bha
7017  sqml=(pmb+pmth)**2
7018  sqmu=s*ceffs(isd,5)+ceffs(isd,6)
7019  sum1=log((bsd+2d0*alp*log(s/sqml))/
7020  & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
7021  bax=ceffs(isd,7)+ceffs(isd,8)/s
7022  sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/
7023  & (bsd+2d0*alp*log(s/((pmb+pmth)*(pmb+pmrc)))+bax)
7024  sigtmp(i,3)=facsd*xpar(ipr)*betp(iha)*max(0d0,sum1+sum2)
7025 
7026 C...Order single diffractive correctly.
7027  IF(iord.EQ.2) THEN
7028  sigsav=sigtmp(i,2)
7029  sigtmp(i,2)=sigtmp(i,3)
7030  sigtmp(i,3)=sigsav
7031  ENDIF
7032 
7033 C...Double diffractive scattering A + B -> X1 + X2.
7034  yeff=log(s*smp/((pma+pmth)*(pmb+pmth))**2)
7035  deff=ceffd(idd,1)+ceffd(idd,2)/slog+ceffd(idd,3)/slog**2
7036  sum1=(deff+yeff*(log(max(1d-10,yeff/deff))-1d0))/(2d0*alp)
7037  IF(yeff.LE.0) sum1=0d0
7038  sqmu=s*(ceffd(idd,4)+ceffd(idd,5)/slog+ceffd(idd,6)/slog**2)
7039  slup=log(max(1.1d0,s/(alp*(pma+pmth)**2*(pmb+pmth)*(pmb+pmrc))))
7040  sldn=log(max(1.1d0,s/(alp*sqmu*(pmb+pmth)*(pmb+pmrc))))
7041  sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)*log(slup/sldn)/
7042  & (2d0*alp)
7043  slup=log(max(1.1d0,s/(alp*(pmb+pmth)**2*(pma+pmth)*(pma+pmrc))))
7044  sldn=log(max(1.1d0,s/(alp*sqmu*(pma+pmth)*(pma+pmrc))))
7045  sum3=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)*log(slup/sldn)/
7046  & (2d0*alp)
7047  bxx=ceffd(idd,7)+ceffd(idd,8)/srt+ceffd(idd,9)/s
7048  slrr=log(s/(alp*(pma+pmth)*(pma+pmrc)*(pmb+pmth)*(pmb+pmrc)))
7049  sum4=cres**2*log(1d0+((pma+pmrc)/(pma+pmth))**2)*
7050  & log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/max(0.1d0,2d0*alp*slrr+bxx)
7051  sigtmp(i,4)=facdd*xpar(ipr)*max(0d0,sum1+sum2+sum3+sum4)
7052 
7053 C...Non-diffractive by unitarity.
7054  sigtmp(i,5)=sigtmp(i,0)-sigtmp(i,1)-sigtmp(i,2)-sigtmp(i,3)-
7055  & sigtmp(i,4)
7056  110 CONTINUE
7057 
7058 C...Put temporary results in output array: only one process.
7059  IF(mint(101).EQ.1.AND.mint(102).EQ.1) THEN
7060  DO 120 j=0,5
7061  sigt(0,0,j)=sigtmp(1,j)
7062  120 CONTINUE
7063 
7064 C...Beam multiple processes.
7065  ELSEIF(mint(101).EQ.4.AND.mint(102).EQ.1) THEN
7066  IF(mint(107).EQ.2) THEN
7067  vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
7068  ELSE
7069  vint(317)=16d0*parp(15)**2*vint(154)**2/
7070  & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
7071  ENDIF
7072  IF(mstp(20).GT.0) THEN
7073  vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)))**mstp(20)
7074  ENDIF
7075  DO 140 i=1,4
7076  IF(mint(107).EQ.2) THEN
7077  conv=(aem/parp(160+i))*vint(317)
7078  ELSEIF(vint(154).GT.parp(15)) THEN
7079  conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
7080  & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7081  ELSE
7082  conv=0d0
7083  ENDIF
7084  i1=max(1,i-1)
7085  DO 130 j=0,5
7086  sigt(i,0,j)=conv*sigtmp(i1,j)
7087  130 CONTINUE
7088  140 CONTINUE
7089  DO 150 j=0,5
7090  sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
7091  150 CONTINUE
7092 
7093 C...Target multiple processes.
7094  ELSEIF(mint(101).EQ.1.AND.mint(102).EQ.4) THEN
7095  IF(mint(108).EQ.2) THEN
7096  vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
7097  ELSE
7098  vint(317)=16d0*parp(15)**2*vint(154)**2/
7099  & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
7100  ENDIF
7101  IF(mstp(20).GT.0) THEN
7102  vint(317)=vint(317)*(vint(2)/(vint(2)+vint(308)))**mstp(20)
7103  ENDIF
7104  DO 170 i=1,4
7105  IF(mint(108).EQ.2) THEN
7106  conv=(aem/parp(160+i))*vint(317)
7107  ELSEIF(vint(154).GT.parp(15)) THEN
7108  conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
7109  & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7110  ELSE
7111  conv=0d0
7112  ENDIF
7113  iv=max(1,i-1)
7114  DO 160 j=0,5
7115  sigt(0,i,j)=conv*sigtmp(iv,j)
7116  160 CONTINUE
7117  170 CONTINUE
7118  DO 180 j=0,5
7119  sigt(0,0,j)=sigt(0,1,j)+sigt(0,2,j)+sigt(0,3,j)+sigt(0,4,j)
7120  180 CONTINUE
7121 
7122 C...Both beam and target multiple processes.
7123  ELSE
7124  IF(mint(107).EQ.2) THEN
7125  vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
7126  ELSE
7127  vint(317)=16d0*parp(15)**2*vint(154)**2/
7128  & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
7129  ENDIF
7130  IF(mint(108).EQ.2) THEN
7131  vint(317)=vint(317)*(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
7132  ELSE
7133  vint(317)=vint(317)*16d0*parp(15)**2*vint(154)**2/
7134  & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
7135  ENDIF
7136  IF(mstp(20).GT.0) THEN
7137  vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)+
7138  & vint(308)))**mstp(20)
7139  ENDIF
7140  DO 210 i1=1,4
7141  DO 200 i2=1,4
7142  IF(mint(107).EQ.2) THEN
7143  conv=(aem/parp(160+i1))*vint(317)
7144  ELSEIF(vint(154).GT.parp(15)) THEN
7145  conv=(aem/paru(1))*(kchg(i1,1)/3d0)**2*parp(18)**2*
7146  & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7147  ELSE
7148  conv=0d0
7149  ENDIF
7150  IF(mint(108).EQ.2) THEN
7151  conv=conv*(aem/parp(160+i2))
7152  ELSEIF(vint(154).GT.parp(15)) THEN
7153  conv=conv*(aem/paru(1))*(kchg(i2,1)/3d0)**2*parp(18)**2*
7154  & (1d0/parp(15)**2-1d0/vint(154)**2)
7155  ELSE
7156  conv=0d0
7157  ENDIF
7158  IF(i1.LE.2) THEN
7159  iv=max(1,i2-1)
7160  ELSEIF(i2.LE.2) THEN
7161  iv=max(1,i1-1)
7162  ELSEIF(i1.EQ.i2) THEN
7163  iv=2*i1-2
7164  ELSE
7165  iv=5
7166  ENDIF
7167  DO 190 j=0,5
7168  jv=j
7169  IF(i2.GT.i1.AND.(j.EQ.2.OR.j.EQ.3)) jv=5-j
7170  sigt(i1,i2,j)=conv*sigtmp(iv,jv)
7171  190 CONTINUE
7172  200 CONTINUE
7173  210 CONTINUE
7174  DO 230 j=0,5
7175  DO 220 i=1,4
7176  sigt(i,0,j)=sigt(i,1,j)+sigt(i,2,j)+sigt(i,3,j)+sigt(i,4,j)
7177  sigt(0,i,j)=sigt(1,i,j)+sigt(2,i,j)+sigt(3,i,j)+sigt(4,i,j)
7178  220 CONTINUE
7179  sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
7180  230 CONTINUE
7181  ENDIF
7182 
7183 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7184  IF(iproc.EQ.21.OR.iproc.EQ.23.OR.iproc.EQ.25) THEN
7185  rfac=(xpar(iproc)*seps+ypar(iproc)*seta)/sigt(0,0,0)
7186  DO 260 i1=0,n1
7187  DO 250 i2=0,n2
7188  DO 240 j=0,5
7189  sigt(i1,i2,j)=rfac*sigt(i1,i2,j)
7190  240 CONTINUE
7191  250 CONTINUE
7192  260 CONTINUE
7193  ENDIF
7194 
7195  RETURN
7196  END
7197 
7198 C*********************************************************************
7199 
7200 C...PYMAXI
7201 C...Finds optimal set of coefficients for kinematical variable selection
7202 C...and the maximum of the part of the differential cross-section used
7203 C...in the event weighting.
7204 
7205  SUBROUTINE pymaxi
7206 
7207 C...Double precision and integer declarations.
7208  IMPLICIT DOUBLE PRECISION(a-h, o-z)
7209  IMPLICIT INTEGER(I-N)
7210  INTEGER PYK,PYCHGE,PYCOMP
7211 C...Parameter statement to help give large particle numbers.
7212  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
7213  &kexcit=4000000,kdimen=5000000)
7214 
7215 C...User process initialization commonblock.
7216  INTEGER MAXPUP
7217  parameter(maxpup=100)
7218  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7219  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7220  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
7221  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
7222  &lprup(maxpup)
7223  SAVE /heprup/
7224 
7225 C...Commonblocks.
7226  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
7227  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
7228  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
7229  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
7230  common/pypars/mstp(200),parp(200),msti(200),pari(200)
7231  common/pyint1/mint(400),vint(400)
7232  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
7233  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
7234  common/pyint4/mwid(500),wids(500,5)
7235  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
7236  common/pyint6/proc(0:500)
7237  CHARACTER PROC*28
7238  common/pyint7/sigt(0:6,0:6,0:5)
7239  common/pytcsm/itcm(0:99),rtcm(0:99)
7240  common/pytcco/coefx(194:380,2)
7241  common/tcpara/ires,jres,xmas(3),xwid(3),ymas(2),ywid(2)
7242  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
7243  &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint6/,/pyint7/,/pytcco/,
7244  &/pytcsm/,/tcpara/
7245 C...Local arrays, character variables and data.
7246  LOGICAL IOK
7247  CHARACTER CVAR(4)*4
7248  dimension npts(4),mvarpt(500,4),vintpt(500,30),sigspt(500),
7249  &narel(9),wtrel(9),wtmat(9,9),wtreln(9),coefu(9),coefo(9),
7250  &iaccmx(4),sigsmx(4),sigssm(3),pmmn(2),wtrsav(9),tempc(9),
7251  &iq(9),ip(9)
7252  DATA cvar/'tau ','tau''','y* ','cth '/
7253  DATA sigssm/3*0d0/
7254 
7255 C...Initial values and loop over subprocesses.
7256  nposi=0
7257  vint(143)=1d0
7258  vint(144)=1d0
7259  xsec(0,1)=0d0
7260  itech=0
7261  DO 460 isub=1,500
7262  mint(1)=isub
7263  mint(51)=0
7264 
7265 C...Find maximum weight factors for photon flux.
7266  IF(msub(isub).EQ.1.OR.(isub.GE.91.AND.isub.LE.100)) THEN
7267  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(2,wtgaga)
7268  ENDIF
7269 
7270 C...Select subprocess to study: skip cases not applicable.
7271  IF(iset(isub).EQ.11) THEN
7272  IF(msub(isub).NE.1) GOTO 460
7273 C...User process intialization: cross section model dependent.
7274  IF(iabs(idwtup).EQ.1) THEN
7275  IF(idwtup.GT.0.AND.xmaxup(kfpr(isub,1)).LT.0d0) call
7276  & pyerrm(26,'(PYMAXI:) Negative XMAXUP for user process')
7277  xsec(isub,1)=1.00000001d-9*abs(xmaxup(kfpr(isub,1)))
7278  ELSE
7279  IF((idwtup.EQ.2.OR.idwtup.EQ.3).AND.
7280  & xsecup(kfpr(isub,1)).LT.0d0) call
7281  & pyerrm(26,'(PYMAXI:) Negative XSECUP for user process')
7282  IF(idwtup.EQ.2.AND.xmaxup(kfpr(isub,1)).LT.0d0) call
7283  & pyerrm(26,'(PYMAXI:) Negative XMAXUP for user process')
7284  xsec(isub,1)=1.00000001d-9*abs(xsecup(kfpr(isub,1)))
7285  ENDIF
7286  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7287  & wtgaga*xsec(isub,1)
7288  nposi=nposi+1
7289  GOTO 450
7290  ELSEIF(isub.GE.91.AND.isub.LE.95) THEN
7291  CALL pysigh(nchn,sigs)
7292  xsec(isub,1)=sigs
7293  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7294  & wtgaga*xsec(isub,1)
7295  IF(msub(isub).NE.1) GOTO 460
7296  nposi=nposi+1
7297  GOTO 450
7298  ELSEIF(isub.EQ.99.AND.msub(isub).EQ.1) THEN
7299  CALL pysigh(nchn,sigs)
7300  xsec(isub,1)=sigs
7301  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7302  & wtgaga*xsec(isub,1)
7303  IF(xsec(isub,1).EQ.0d0) THEN
7304  msub(isub)=0
7305  ELSE
7306  nposi=nposi+1
7307  ENDIF
7308  GOTO 450
7309  ELSEIF(isub.EQ.96) THEN
7310  IF(mint(50).EQ.0) GOTO 460
7311  IF(msub(95).NE.1.AND.mod(mstp(81),10).LE.0.AND.mstp(131).LE.0)
7312  & GOTO 460
7313  IF(mint(49).EQ.0.AND.mstp(131).EQ.0) GOTO 460
7314  ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.
7315  & isub.EQ.53.OR.isub.EQ.68) THEN
7316  IF(msub(isub).NE.1.OR.msub(95).EQ.1) GOTO 460
7317  ELSEIF(isub.GE.381.AND.isub.LE.386) THEN
7318  IF(msub(isub).NE.1.OR.msub(95).EQ.1) GOTO 460
7319  ELSE
7320  IF(msub(isub).NE.1) GOTO 460
7321  ENDIF
7322  istsb=iset(isub)
7323  IF(isub.EQ.96) istsb=2
7324  IF(mstp(122).GE.2) WRITE(mstu(11),5000) isub
7325  mwtxs=0
7326  IF(mstp(142).GE.1.AND.isub.NE.96.AND.msub(91)+msub(92)+msub(93)+
7327  & msub(94)+msub(95).EQ.0) mwtxs=1
7328 
7329 C...Find resonances (explicit or implicit in cross-section).
7330  mint(72)=0
7331  kfr1=0
7332  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
7333  kfr1=kfpr(isub,1)
7334  ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165
7335  & .OR.isub.EQ.171.OR.isub.EQ.176) THEN
7336  kfr1=23
7337  ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172
7338  & .OR.isub.EQ.177) THEN
7339  kfr1=24
7340  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
7341  kfr1=25
7342  IF(mstp(46).EQ.5) THEN
7343  kfr1=89
7344  pmas(89,1)=parp(45)
7345  pmas(89,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
7346  ENDIF
7347  ENDIF
7348  ckmx=ckin(2)
7349  IF(ckmx.LE.0d0) ckmx=vint(1)
7350  kcr1=pycomp(kfr1)
7351  IF(kfr1.NE.0) THEN
7352  IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
7353  & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
7354  ENDIF
7355  IF(kfr1.NE.0) THEN
7356  taur1=pmas(kcr1,1)**2/vint(2)
7357  gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
7358  mint(72)=1
7359  mint(73)=kfr1
7360  vint(73)=taur1
7361  vint(74)=gamr1
7362  ENDIF
7363  kfr2=0
7364  kfr3=0
7365  IF(isub.EQ.141.OR.isub.EQ.194.OR.isub.EQ.195.OR.
7366  $ (isub.GE.361.AND.isub.LE.380))
7367  $ THEN
7368  kfr2=23
7369  IF(isub.EQ.141) THEN
7370  kcr2=pycomp(kfr2)
7371  IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
7372  & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) THEN
7373  kfr2=0
7374  ELSE
7375  taur2=pmas(kcr2,1)**2/vint(2)
7376  gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
7377  mint(72)=2
7378  mint(74)=kfr2
7379  vint(75)=taur2
7380  vint(76)=gamr2
7381  ENDIF
7382  ELSEIF(itech.EQ.0) THEN
7383  alprht=2.16d0*(3d0/dble(itcm(1)))
7384  itech=1
7385  kfr1=ktechn+113
7386  kcr1=pycomp(kfr1)
7387  kfr2=ktechn+223
7388  kcr2=pycomp(kfr2)
7389  kfr3=ktechn+115
7390  kcr3=pycomp(kfr3)
7391  ires=0
7392 C...Order the resonances
7393  IF(pmas(kcr3,1).LT.pmas(kcr2,1)) THEN
7394  kct=kcr3
7395  kcr3=kcr2
7396  kcr2=kct
7397  ENDIF
7398  IF(pmas(kcr3,1).LT.pmas(kcr1,1)) THEN
7399  kct=kcr3
7400  kcr3=kcr1
7401  kcr1=kct
7402  ENDIF
7403  IF(pmas(kcr2,1).LT.pmas(kcr1,1)) THEN
7404  kct=kcr2
7405  kcr2=kcr1
7406  kcr1=kct
7407  ENDIF
7408  DO 101 i=1,3
7409  IF(i.EQ.1) THEN
7410  shn0=pmas(kcr1,1)**2
7411  ELSEIF(i.EQ.2) THEN
7412  IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LE.1d-6) GOTO 101
7413  shn0=pmas(kcr2,1)**2
7414  ELSEIF(i.EQ.3) THEN
7415  IF(abs(pmas(kcr3,1)-pmas(kcr3,1)).LE.1d-6) GOTO 101
7416  shn0=pmas(kcr3,1)**2
7417  ENDIF
7418  aem=pyalem(shn0)
7419  far=sqrt(aem/alprht)
7420  shn=shn0*(1d0-far)
7421  CALL pytecm(shn,s1,wido,1)
7422  res=shn-s1
7423  shn=s1*.99d0
7424  shstep=2d0
7425  102 shn=shn+shstep
7426  CALL pytecm(shn,s1,wido,1)
7427  IF(res.LT.0d0.AND.shn-s1.GE.0d0) THEN
7428  iok=.false.
7429  IF(ires.GT.0) THEN
7430  IF(abs(sqrt(s1)-xmas(ires)).GT.1d-6) iok=.true.
7431  ELSEIF(ires.EQ.0) THEN
7432  iok=.true.
7433  ENDIF
7434  IF(iok) THEN
7435  ires=ires+1
7436  xmas(ires)=sqrt(s1)
7437  xwid(ires)=wido
7438  ENDIF
7439  ENDIF
7440  res=shn-s1
7441  IF(ires.LT.3.AND.shn.LT.shn0*(1d0+far)) GOTO 102
7442  101 CONTINUE
7443  jres=0
7444  kfr1=ktechn+213
7445  kcr1=pycomp(kfr1)
7446  kfr2=ktechn+215
7447  kcr2=pycomp(kfr2)
7448  IF(pmas(kcr2,1).LT.pmas(kcr1,1)) THEN
7449  kct=kcr2
7450  kcr2=kcr1
7451  kcr1=kct
7452  ENDIF
7453  DO 103 i=1,2
7454  IF(i.EQ.1) THEN
7455  shn0=pmas(kcr1,1)**2
7456  ELSEIF(i.EQ.2) THEN
7457  IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LE.1d-6) GOTO 103
7458  shn0=pmas(kcr2,1)**2
7459  ENDIF
7460  aem=pyalem(shn0)
7461  far=sqrt(aem/alprht)
7462  shn=shn0*(1d0-far)
7463  CALL pytecm(shn,s1,wido,2)
7464  res=shn-s1
7465  shn=s1*.99d0
7466  shstep=2d0
7467  104 shn=shn+shstep
7468  CALL pytecm(shn,s1,wido,2)
7469  IF(res.LT.0d0.AND.shn-s1.GE.0d0) THEN
7470  iok=.false.
7471  IF(jres.GT.0) THEN
7472  IF(abs(sqrt(s1)-xmas(ires)).GT.1d-6) iok=.true.
7473  ELSEIF(jres.EQ.0) THEN
7474  iok=.true.
7475  ENDIF
7476  IF(iok) THEN
7477  jres=jres+1
7478  ymas(jres)=sqrt(s1)
7479  ywid(jres)=wido
7480  ENDIF
7481  ENDIF
7482  res=shn-s1
7483  IF(jres.LT.2.AND.shn.LT.shn0*(1d0+far)) GOTO 104
7484  103 CONTINUE
7485  ENDIF
7486  IF(isub.EQ.194.OR.(isub.GE.361.AND.isub.LE.368).OR.
7487  & isub.EQ.379.OR.isub.EQ.380) THEN
7488  mint(72)=ires
7489  IF(ires.GE.1) THEN
7490  vint(73)=xmas(1)**2/vint(2)
7491  vint(74)=xmas(1)*xwid(1)/vint(2)
7492  taur1=vint(73)
7493  gamr1=vint(74)
7494  xm1=xmas(1)
7495  xg1=xwid(1)
7496  kfr1=1
7497  ENDIF
7498  IF(ires.GE.2) THEN
7499  vint(75)=xmas(2)**2/vint(2)
7500  vint(76)=xmas(2)*xwid(2)/vint(2)
7501  taur2=vint(75)
7502  gamr2=vint(76)
7503  xm2=xmas(2)
7504  xg2=xwid(2)
7505  kfr2=2
7506  ENDIF
7507  IF(ires.EQ.3) THEN
7508  vint(77)=xmas(3)**2/vint(2)
7509  vint(78)=xmas(3)*xwid(3)/vint(2)
7510  taur3=vint(77)
7511  gamr3=vint(78)
7512  xm3=xmas(3)
7513  xg3=xwid(3)
7514  kfr3=3
7515  ENDIF
7516 C...Charged current: rho+- and a+-
7517  ELSEIF(isub.EQ.195.OR.isub.GE.370.AND.isub.LE.378) THEN
7518  mint(72)=ires
7519  IF(jres.GE.1) THEN
7520  vint(73)=ymas(1)**2/vint(2)
7521  vint(74)=ymas(1)*ywid(1)/vint(2)
7522  kfr1=1
7523  taur1=vint(73)
7524  gamr1=vint(74)
7525  xm1=ymas(1)
7526  xg1=ywid(1)
7527  ENDIF
7528  IF(jres.GE.2) THEN
7529  vint(75)=ymas(2)**2/vint(2)
7530  vint(76)=ymas(2)*ywid(2)/vint(2)
7531  kfr2=2
7532  taur2=vint(73)
7533  gamr2=vint(74)
7534  xm2=ymas(2)
7535  xg2=ywid(2)
7536  ENDIF
7537  kfr3=0
7538  ENDIF
7539  IF(isub.NE.141) THEN
7540  IF(kfr1.NE.0.AND.(ckin(1).GT.(xm1+20d0*xg1)
7541  & .OR.ckmx.LT.(xm1-20d0*xg1))) kfr1=0
7542  IF(kfr2.NE.0.AND.(ckin(1).GT.(xm2+20d0*xg2)
7543  & .OR.ckmx.LT.(xm2-20d0*xg2))) kfr2=0
7544  IF(kfr3.NE.0.AND.(ckin(1).GT.(xm3+20d0*xg3)
7545  & .OR.ckmx.LT.(xm3-20d0*xg3))) kfr3=0
7546  IF(kfr3.NE.0.AND.kfr2.NE.0.AND.kfr1.NE.0) THEN
7547 
7548  ELSEIF(kfr1.NE.0.AND.kfr2.NE.0) THEN
7549  mint(72)=2
7550  ELSEIF(kfr1.NE.0.AND.kfr3.NE.0) THEN
7551  mint(72)=2
7552  mint(74)=kfr3
7553  vint(75)=taur3
7554  vint(76)=gamr3
7555  ELSEIF(kfr2.NE.0.AND.kfr3.NE.0) THEN
7556  mint(72)=2
7557  mint(73)=kfr2
7558  vint(73)=taur2
7559  vint(74)=gamr2
7560  mint(74)=kfr3
7561  vint(75)=taur3
7562  vint(76)=gamr3
7563  ELSEIF(kfr1.NE.0) THEN
7564  mint(72)=1
7565  ELSEIF(kfr2.NE.0) THEN
7566  mint(72)=1
7567  mint(73)=kfr2
7568  vint(73)=taur2
7569  vint(74)=gamr2
7570  ELSEIF(kfr3.NE.0) THEN
7571  mint(72)=1
7572  mint(73)=kfr3
7573  vint(73)=taur3
7574  vint(74)=gamr3
7575  ELSE
7576  mint(72)=0
7577  ENDIF
7578  ELSE
7579  IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
7580 
7581  ELSEIF(kfr2.NE.0) THEN
7582  kfr1=kfr2
7583  taur1=taur2
7584  gamr1=gamr2
7585  mint(72)=1
7586  mint(73)=kfr1
7587  vint(73)=taur1
7588  vint(74)=gamr1
7589  kfr2=0
7590  ELSE
7591  mint(72)=0
7592  ENDIF
7593  ENDIF
7594  ENDIF
7595 
7596 C...Find product masses and minimum pT of process.
7597  sqm3=0d0
7598  sqm4=0d0
7599  mint(71)=0
7600  vint(71)=ckin(3)
7601  vint(80)=1d0
7602  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
7603  nbw=0
7604  DO 110 i=1,2
7605  pmmn(i)=0d0
7606  IF(kfpr(isub,i).EQ.0) THEN
7607  ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
7608  & parp(41)) THEN
7609  IF(i.EQ.1) sqm3=pmas(pycomp(kfpr(isub,i)),1)**2
7610  IF(i.EQ.2) sqm4=pmas(pycomp(kfpr(isub,i)),1)**2
7611  ELSE
7612  nbw=nbw+1
7613 C...This prevents SUSY/t particles from becoming too light.
7614  kflw=kfpr(isub,i)
7615  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
7616  kcw=pycomp(kflw)
7617  pmmn(i)=pmas(kcw,1)
7618  DO 100 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
7619  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
7620  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
7621  & pmas(pycomp(kfdp(idc,2)),1)
7622  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
7623  & pmas(pycomp(kfdp(idc,3)),1)
7624  pmmn(i)=min(pmmn(i),pmsum)
7625  ENDIF
7626  100 CONTINUE
7627  ELSEIF(kflw.EQ.6) THEN
7628  pmmn(i)=pmas(24,1)+pmas(5,1)
7629  ENDIF
7630  ENDIF
7631  110 CONTINUE
7632  IF(nbw.GE.1) THEN
7633  ckin41=ckin(41)
7634  ckin43=ckin(43)
7635  ckin(41)=max(pmmn(1),ckin(41))
7636  ckin(43)=max(pmmn(2),ckin(43))
7637  CALL pyofsh(3,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
7638  ckin(41)=ckin41
7639  ckin(43)=ckin43
7640  IF(mint(51).EQ.1) THEN
7641  WRITE(mstu(11),5100) isub
7642  msub(isub)=0
7643  GOTO 460
7644  ENDIF
7645  sqm3=pqm3**2
7646  sqm4=pqm4**2
7647  ENDIF
7648  IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1
7649  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
7650  IF(isub.EQ.96.AND.mstp(82).LE.1) THEN
7651  vint(71)=parp(81)*(vint(1)/parp(89))**parp(90)
7652  ELSEIF(isub.EQ.96) THEN
7653  vint(71)=0.08d0*parp(82)*(vint(1)/parp(89))**parp(90)
7654  ENDIF
7655  ENDIF
7656  vint(63)=sqm3
7657  vint(64)=sqm4
7658 
7659 C...Prepare for additional variable choices in 2 -> 3.
7660  IF(istsb.EQ.5) THEN
7661  vint(201)=0d0
7662  IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
7663  vint(206)=vint(201)
7664  IF(isub.EQ.401.OR.isub.EQ.402) vint(206)=pmas(5,1)
7665  vint(204)=pmas(23,1)
7666  IF(isub.EQ.124.OR.isub.EQ.351) vint(204)=pmas(24,1)
7667  IF(isub.EQ.352) vint(204)=pmas(pycomp(9900024),1)
7668  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182
7669  & .OR.isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402)
7670  & vint(204)=vint(201)
7671  vint(209)=vint(204)
7672  IF(isub.EQ.401.OR.isub.EQ.402) vint(209)=vint(206)
7673  ENDIF
7674 
7675 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7676  ipeak7=0
7677  npts(1)=2+2*mint(72)
7678  IF(mint(47).EQ.1) THEN
7679  IF(istsb.EQ.1.OR.istsb.EQ.2) npts(1)=1
7680  ELSEIF(mint(47).GE.5) THEN
7681  IF(istsb.LE.2.OR.istsb.GT.5) THEN
7682  npts(1)=npts(1)+1
7683  ipeak7=1
7684  ENDIF
7685  ENDIF
7686  npts(2)=1
7687  IF(istsb.GE.3.AND.istsb.LE.5) THEN
7688  IF(mint(47).GE.2) npts(2)=2
7689  IF(mint(47).GE.5) npts(2)=3
7690  ENDIF
7691  npts(3)=1
7692  IF(mint(47).EQ.4.OR.mint(47).EQ.5) THEN
7693  npts(3)=3
7694  IF(mint(45).EQ.3) npts(3)=npts(3)+1
7695  IF(mint(46).EQ.3) npts(3)=npts(3)+1
7696  ENDIF
7697  npts(4)=1
7698  IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5
7699  ntry=npts(1)*npts(2)*npts(3)*npts(4)
7700 
7701 C...Reset coefficients of cross-section weighting.
7702  DO 120 j=1,20
7703  coef(isub,j)=0d0
7704  120 CONTINUE
7705  IF(isub.EQ.194.OR.isub.EQ.195.OR.(isub.GE.361
7706  & .AND.isub.LE.380)) THEN
7707  DO 125 j=1,2
7708  coefx(isub,j)=0d0
7709  125 CONTINUE
7710  ENDIF
7711  coef(isub,1)=1d0
7712  coef(isub,8)=0.5d0
7713  coef(isub,9)=0.5d0
7714  coef(isub,13)=1d0
7715  coef(isub,18)=1d0
7716  mcth=0
7717  mtaup=0
7718  metaup=0
7719  vint(23)=0d0
7720  vint(26)=0d0
7721  sigsam=0d0
7722 
7723 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7724 C...in grid of phase space points.
7725  CALL pyklim(1)
7726  metau=mint(51)
7727  nacc=0
7728  DO 150 itry=1,ntry
7729  mint(51)=0
7730  IF(metau.EQ.1) GOTO 150
7731  IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN
7732  mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))
7733  IF(mint(72).LE.2.AND.mtau.GT.2+2*mint(72)) THEN
7734  mtau=7
7735  ELSEIF(mint(72).EQ.3.AND.ipeak7.EQ.0.AND.mtau.GE.7) THEN
7736  mtau=mtau+1
7737  ENDIF
7738  rtau=0.5d0
7739 C...Special case when both resonances have same mass,
7740 C...as is often the case in process 194.
7741 c IF(MINT(72).GE.2) THEN
7742 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7743 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7744 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7745 c RTAU=0.4D0
7746 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7747 c RTAU=0.6D0
7748 c ENDIF
7749 c ENDIF
7750 c ENDIF
7751  CALL pykmap(1,mtau,rtau)
7752  IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)
7753  metaup=mint(51)
7754  ENDIF
7755  IF(metaup.EQ.1) GOTO 150
7756  IF(istsb.GE.3.AND.istsb.LE.5.AND.mod(itry-1,npts(3)*npts(4))
7757  & .EQ.0) THEN
7758  mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2))
7759  CALL pykmap(4,mtaup,0.5d0)
7760  ENDIF
7761  IF(mod(itry-1,npts(3)*npts(4)).EQ.0) THEN
7762  CALL pyklim(2)
7763  meyst=mint(51)
7764  ENDIF
7765  IF(meyst.EQ.1) GOTO 150
7766  IF(mod(itry-1,npts(4)).EQ.0) THEN
7767  myst=1+mod((itry-1)/npts(4),npts(3))
7768  IF(myst.EQ.4.AND.mint(45).NE.3) myst=5
7769  CALL pykmap(2,myst,0.5d0)
7770  CALL pyklim(3)
7771  mecth=mint(51)
7772  ENDIF
7773  IF(mecth.EQ.1) GOTO 150
7774  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
7775  mcth=1+mod(itry-1,npts(4))
7776  CALL pykmap(3,mcth,0.5d0)
7777  ENDIF
7778  IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)
7779 
7780 C...Store position and limits.
7781  mint(51)=0
7782  CALL pyklim(0)
7783  IF(mint(51).EQ.1) GOTO 150
7784  nacc=nacc+1
7785  mvarpt(nacc,1)=mtau
7786  mvarpt(nacc,2)=mtaup
7787  mvarpt(nacc,3)=myst
7788  mvarpt(nacc,4)=mcth
7789  DO 130 j=1,30
7790  vintpt(nacc,j)=vint(10+j)
7791  130 CONTINUE
7792 
7793 C...Normal case: calculate cross-section.
7794  IF(istsb.NE.5) THEN
7795  CALL pysigh(nchn,sigs)
7796  IF(mwtxs.EQ.1) THEN
7797  CALL pyevwt(wtxs)
7798  sigs=wtxs*sigs
7799  ENDIF
7800 
7801 C..2 -> 3: find highest value out of a number of tries.
7802  ELSE
7803  sigs=0d0
7804  DO 140 ikin3=1,mstp(129)
7805  CALL pykmap(5,0,0d0)
7806  IF(mint(51).EQ.1) GOTO 140
7807  CALL pysigh(nchn,sigtmp)
7808  IF(mwtxs.EQ.1) THEN
7809  CALL pyevwt(wtxs)
7810  sigtmp=wtxs*sigtmp
7811  ENDIF
7812  IF(sigtmp.GT.sigs) sigs=sigtmp
7813  140 CONTINUE
7814  ENDIF
7815 
7816 C...Store cross-section.
7817  sigspt(nacc)=sigs
7818  IF(sigs.GT.sigsam) sigsam=sigs
7819  IF(mstp(122).GE.2) WRITE(mstu(11),5200) mtau,myst,mcth,mtaup,
7820  & vint(21),vint(22),vint(23),vint(26),sigs
7821  150 CONTINUE
7822  IF(nacc.EQ.0) THEN
7823  WRITE(mstu(11),5100) isub
7824  msub(isub)=0
7825  GOTO 460
7826  ELSEIF(sigsam.EQ.0d0) THEN
7827  WRITE(mstu(11),5300) isub
7828  msub(isub)=0
7829  GOTO 460
7830  ENDIF
7831  IF(isub.NE.96) nposi=nposi+1
7832 
7833 C...Calculate integrals in tau over maximal phase space limits.
7834  taumin=vint(11)
7835  taumax=vint(31)
7836  atau1=log(taumax/taumin)
7837  IF(npts(1).GE.2) THEN
7838  atau2=(taumax-taumin)/(taumax*taumin)
7839  ENDIF
7840  IF(npts(1).GE.4) THEN
7841  atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
7842  atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/
7843  & gamr1
7844  ENDIF
7845  IF(npts(1).GE.6) THEN
7846  atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
7847  atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/
7848  & gamr2
7849  ENDIF
7850  IF(npts(1).GE.8) THEN
7851  atau8=log(taumax/taumin*(taumin+taur3)/(taumax+taur3))/taur3
7852  atau9=(atan((taumax-taur3)/gamr3)-atan((taumin-taur3)/gamr3))/
7853  & gamr3
7854  ENDIF
7855  IF(ipeak7.EQ.1) THEN
7856  atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
7857  ENDIF
7858 
7859 C...Reset. Sum up cross-sections in points calculated.
7860  DO 320 ivar=1,4
7861  IF(npts(ivar).EQ.1) GOTO 320
7862  IF(isub.EQ.96.AND.ivar.EQ.4) GOTO 320
7863  nbin=npts(ivar)
7864  DO 170 j1=1,nbin
7865  narel(j1)=0
7866  wtrel(j1)=0d0
7867  coefu(j1)=0d0
7868  DO 160 j2=1,nbin
7869  wtmat(j1,j2)=0d0
7870  160 CONTINUE
7871  170 CONTINUE
7872  DO 180 iacc=1,nacc
7873  ibin=mvarpt(iacc,ivar)
7874  IF(ivar.EQ.1) THEN
7875  IF(ibin.GT.7.AND.ipeak7.EQ.0) THEN
7876  ibin=ibin-1
7877  ELSEIF(ibin.EQ.7.AND.ipeak7.EQ.1.AND.mstp(72).LT.3) THEN
7878  ibin=3+2*mint(72)
7879  ENDIF
7880  ENDIF
7881  IF(ivar.EQ.3.AND.ibin.EQ.5.AND.mint(45).NE.3) ibin=4
7882  narel(ibin)=narel(ibin)+1
7883  wtrel(ibin)=wtrel(ibin)+sigspt(iacc)
7884 
7885 C...Sum up tau cross-section pieces in points used.
7886  IF(ivar.EQ.1) THEN
7887  tau=vintpt(iacc,11)
7888  wtmat(ibin,1)=wtmat(ibin,1)+1d0
7889  wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau
7890  IF(nbin.GE.4) THEN
7891  wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1)
7892  wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/
7893  & ((tau-taur1)**2+gamr1**2)
7894  ENDIF
7895  IF(nbin.GE.6) THEN
7896  wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2)
7897  wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/
7898  & ((tau-taur2)**2+gamr2**2)
7899  ENDIF
7900  IF(mint(72).LE.2.AND.ipeak7.EQ.1) THEN
7901  wtmat(ibin,3+2*mint(72))=wtmat(ibin,3+2*mint(72))
7902  & +(atau1/atau7)*tau/max(2d-10,1d0-tau)
7903  ELSEIF(mint(72).EQ.3.AND.ipeak7.EQ.1) THEN
7904  wtmat(ibin,7)=wtmat(ibin,7)
7905  & +(atau1/atau7)*tau/max(2d-10,1d0-tau)
7906  ENDIF
7907  IF(mint(72).EQ.3) THEN
7908  wtmat(ibin,7+ipeak7)=wtmat(ibin,7+ipeak7)
7909  & +(atau1/atau8)/(tau+taur3)
7910  wtmat(ibin,8+ipeak7)=wtmat(ibin,8+ipeak7)
7911  & +(atau1/atau9)*tau/((tau-taur3)**2+gamr3**2)
7912  ENDIF
7913 C...Sum up tau' cross-section pieces in points used.
7914  ELSEIF(ivar.EQ.2) THEN
7915  tau=vintpt(iacc,11)
7916  taup=vintpt(iacc,16)
7917  taupmn=vintpt(iacc,6)
7918  taupmx=vintpt(iacc,26)
7919  ataup1=log(taupmx/taupmn)
7920  ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
7921  wtmat(ibin,1)=wtmat(ibin,1)+1d0
7922  wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*
7923  & (1d0-tau/taup)**3/taup
7924  IF(nbin.GE.3) THEN
7925  ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
7926  wtmat(ibin,3)=wtmat(ibin,3)+(ataup1/ataup3)*
7927  & taup/max(2d-10,1d0-taup)
7928  ENDIF
7929 
7930 C...Sum up y* cross-section pieces in points used.
7931  ELSEIF(ivar.EQ.3) THEN
7932  yst=vintpt(iacc,12)
7933  ystmin=vintpt(iacc,2)
7934  ystmax=vintpt(iacc,22)
7935  ayst0=ystmax-ystmin
7936  ayst1=0.5d0*(ystmax-ystmin)**2
7937  ayst2=ayst1
7938  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
7939  wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)
7940  wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst2)*(ystmax-yst)
7941  wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst)
7942  IF(mint(45).EQ.3) THEN
7943  taue=vintpt(iacc,11)
7944  IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
7945  yst0=-0.5d0*log(taue)
7946  ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
7947  & max(1d-10,exp(yst0-ystmax)-1d0))
7948  wtmat(ibin,4)=wtmat(ibin,4)+(ayst0/ayst4)/
7949  & max(1d-10,1d0-exp(yst-yst0))
7950  ENDIF
7951  IF(mint(46).EQ.3) THEN
7952  taue=vintpt(iacc,11)
7953  IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
7954  yst0=-0.5d0*log(taue)
7955  ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
7956  & max(1d-10,exp(yst0+ystmin)-1d0))
7957  wtmat(ibin,nbin)=wtmat(ibin,nbin)+(ayst0/ayst5)/
7958  & max(1d-10,1d0-exp(-yst-yst0))
7959  ENDIF
7960 
7961 C...Sum up cos(theta-hat) cross-section pieces in points used.
7962  ELSE
7963  rm34=max(1d-20,2d0*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2)
7964  rsqm=1d0+rm34
7965  cthmax=sqrt(1d0-4d0*vint(71)**2/(taumax*vint(2)))
7966  cthmin=-cthmax
7967  IF(cthmax.GT.0.9999d0) rm34=max(rm34,2d0*vint(71)**2/
7968  & (taumax*vint(2)))
7969  acth1=cthmax-cthmin
7970  acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))
7971  acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))
7972  acth4=1d0/max(rm34,rsqm-cthmax)-1d0/max(rm34,rsqm-cthmin)
7973  acth5=1d0/max(rm34,rsqm+cthmin)-1d0/max(rm34,rsqm+cthmax)
7974  cth=vintpt(iacc,13)
7975  wtmat(ibin,1)=wtmat(ibin,1)+1d0
7976  wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/
7977  & max(rm34,rsqm-cth)
7978  wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/
7979  & max(rm34,rsqm+cth)
7980  wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/
7981  & max(rm34,rsqm-cth)**2
7982  wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/
7983  & max(rm34,rsqm+cth)**2
7984  ENDIF
7985  180 CONTINUE
7986 
7987 C...Check that equation system solvable.
7988  IF(mstp(122).GE.2) WRITE(mstu(11),5400) cvar(ivar)
7989  msolv=1
7990  wtrels=0d0
7991  DO 190 ibin=1,nbin
7992  IF(mstp(122).GE.2) WRITE(mstu(11),5500) (wtmat(ibin,ired),
7993  & ired=1,nbin),wtrel(ibin)
7994  IF(narel(ibin).EQ.0) msolv=0
7995  wtrels=wtrels+wtrel(ibin)
7996  190 CONTINUE
7997  IF(abs(wtrels).LT.1d-20) msolv=0
7998 
7999 C...Solve to find relative importance of cross-section pieces.
8000  IF(msolv.EQ.1) THEN
8001  DO 200 ibin=1,nbin
8002  wtreln(ibin)=max(0.1d0,wtrel(ibin)/wtrels)
8003  wtrsav(ibin)=wtrel(ibin)
8004  200 CONTINUE
8005 C...Auxiliary vectors to record order of permutations
8006  DO i=1,nbin
8007  ip(i) = i
8008  iq(i) = i
8009  ENDDO
8010  DO 230 ired=1,nbin-1
8011  mrow=ired
8012  resmax=abs(wtrel(mrow))
8013 C...Find row with largest residual
8014  DO jbin=ired+1,nbin
8015  IF(resmax.LT.abs(wtrel(jbin))) THEN
8016  mrow=jbin
8017  resmax=abs(wtrel(mrow))
8018  ENDIF
8019  ENDDO
8020  IF(resmax.LT.1d-20) THEN
8021  msolv=0
8022  GOTO 260
8023  ENDIF
8024  mcol = ired
8025  amax = abs(wtmat(mrow,mcol))
8026 C...Find column with largest entry
8027  DO jbin=ired+1,nbin
8028  IF (amax.LT.abs(wtmat(mrow,jbin))) THEN
8029  mcol = jbin
8030  amax = abs(wtmat(mrow,mcol))
8031  ENDIF
8032  ENDDO
8033 C...Swap rows if necessary
8034  IF(mrow.NE.ired) THEN
8035  DO jbin=1,nbin
8036  tmpe=wtmat(ired,jbin)
8037  wtmat(ired,jbin)=wtmat(mrow,jbin)
8038  wtmat(mrow,jbin)=tmpe
8039  ENDDO
8040  tmpe=wtrel(ired)
8041  wtrel(ired)=wtrel(mrow)
8042  wtrel(mrow)=tmpe
8043  mtmp=iq(ired)
8044  iq(ired)=iq(mrow)
8045  iq(mrow)=mtmp
8046  ENDIF
8047 C...Swap columns if necessary
8048  IF(mcol.NE.ired) THEN
8049  DO jbin=1,nbin
8050  tmpe=wtmat(jbin,ired)
8051  wtmat(jbin,ired)=wtmat(jbin,mcol)
8052  wtmat(jbin,mcol)=tmpe
8053  ENDDO
8054  mtmp=ip(ired)
8055  ip(ired)=ip(mcol)
8056  ip(mcol)=mtmp
8057  ENDIF
8058 C...Begin eliminating equations
8059  DO 220 ibin=ired+1,nbin
8060  IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
8061  msolv=0
8062  GOTO 260
8063  ENDIF
8064 C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8065  rqtu=wtmat(ibin,ired)
8066  rqtl=wtmat(ired,ired)
8067 C...Switch order of operations
8068  wtrel(ibin)=wtrel(ibin)-rqtu*
8069  $ (wtrel(ired)/rqtl)
8070  DO 210 icoe=ired,nbin
8071  wtmat(ibin,icoe)=wtmat(ibin,icoe)-
8072  $ rqtu*(wtmat(ired,icoe)/rqtl)
8073  210 CONTINUE
8074  220 CONTINUE
8075  230 CONTINUE
8076  DO 250 ired=nbin,1,-1
8077  DO 240 icoe=ired+1,nbin
8078  wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)
8079  240 CONTINUE
8080  IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
8081  msolv=0
8082  GOTO 260
8083  ENDIF
8084  coefu(ired)=wtrel(ired)/wtmat(ired,ired)
8085  tempc(ired)=coefu(ired)
8086  250 CONTINUE
8087 C...Return to original order
8088  DO ibin=1,nbin
8089  mtmp=ip(ibin)
8090  coefu(mtmp)=tempc(ibin)
8091  ENDDO
8092  ENDIF
8093 
8094 C...Share evenly if failure.
8095  260 IF(msolv.EQ.0) THEN
8096  DO 270 ibin=1,nbin
8097  coefu(ibin)=1d0
8098  wtreln(ibin)=0.1d0
8099  IF(wtrels.GT.0d0) wtreln(ibin)=max(0.1d0,
8100  & wtrsav(ibin)/wtrels)
8101  270 CONTINUE
8102  ENDIF
8103 
8104 C...Normalize coefficients, with piece shared democratically.
8105  coefsu=0d0
8106  wtrels=0d0
8107  DO 280 ibin=1,nbin
8108  coefu(ibin)=max(0d0,coefu(ibin))
8109  coefsu=coefsu+coefu(ibin)
8110  wtrels=wtrels+wtreln(ibin)
8111  280 CONTINUE
8112  IF(coefsu.GT.0d0) THEN
8113  DO 290 ibin=1,nbin
8114  coefo(ibin)=parp(122)/nbin+(1d0-parp(122))*0.5d0*
8115  & (coefu(ibin)/coefsu+wtreln(ibin)/wtrels)
8116  290 CONTINUE
8117  ELSE
8118  DO 300 ibin=1,nbin
8119  coefo(ibin)=1d0/nbin
8120  300 CONTINUE
8121  ENDIF
8122  IF(ivar.EQ.1) ioff=0
8123  IF(ivar.EQ.2) ioff=17
8124  IF(ivar.EQ.3) ioff=7
8125  IF(ivar.EQ.4) ioff=12
8126  DO 310 ibin=1,nbin
8127  icof=ioff+ibin
8128  IF(ivar.EQ.1) THEN
8129  IF(ibin.EQ.nbin.AND.(mint(72).LE.2.AND.ipeak7.EQ.1)) THEN
8130  icof=7
8131  ENDIF
8132  ENDIF
8133  IF(ivar.EQ.3.AND.ibin.EQ.4.AND.mint(45).NE.3) icof=icof+1
8134  IF(ivar.EQ.1.AND.ibin.GE.7+ipeak7.AND.mint(72).EQ.3) THEN
8135  coefx(isub,ibin-6-ipeak7)=coefo(ibin)
8136  ELSE
8137  coef(isub,icof)=coefo(ibin)
8138  ENDIF
8139  310 CONTINUE
8140 
8141  IF(mstp(122).GE.2) WRITE(mstu(11),5600) cvar(ivar),
8142  & (coefo(ibin),ibin=1,nbin)
8143 
8144  320 CONTINUE
8145 
8146 C...Find two most promising maxima among points previously determined.
8147  DO 330 j=1,4
8148  iaccmx(j)=0
8149  sigsmx(j)=0d0
8150  330 CONTINUE
8151  nmax=0
8152  DO 390 iacc=1,nacc
8153  DO 340 j=1,30
8154  vint(10+j)=vintpt(iacc,j)
8155  340 CONTINUE
8156  IF(istsb.NE.5) THEN
8157  CALL pysigh(nchn,sigs)
8158  IF(mwtxs.EQ.1) THEN
8159  CALL pyevwt(wtxs)
8160  sigs=wtxs*sigs
8161  ENDIF
8162  ELSE
8163  sigs=0d0
8164  DO 350 ikin3=1,mstp(129)
8165  CALL pykmap(5,0,0d0)
8166  IF(mint(51).EQ.1) GOTO 350
8167  CALL pysigh(nchn,sigtmp)
8168  IF(mwtxs.EQ.1) THEN
8169  CALL pyevwt(wtxs)
8170  sigtmp=wtxs*sigtmp
8171  ENDIF
8172  IF(sigtmp.GT.sigs) sigs=sigtmp
8173  350 CONTINUE
8174  ENDIF
8175  ieq=0
8176  DO 360 imv=1,nmax
8177  IF(abs(sigs-sigsmx(imv)).LT.1d-4*(sigs+sigsmx(imv))) ieq=imv
8178  360 CONTINUE
8179  IF(ieq.EQ.0) THEN
8180  DO 370 imv=nmax,1,-1
8181  iin=imv+1
8182  IF(sigs.LE.sigsmx(imv)) GOTO 380
8183  iaccmx(imv+1)=iaccmx(imv)
8184  sigsmx(imv+1)=sigsmx(imv)
8185  370 CONTINUE
8186  iin=1
8187  380 iaccmx(iin)=iacc
8188  sigsmx(iin)=sigs
8189  IF(nmax.LE.1) nmax=nmax+1
8190  ENDIF
8191  390 CONTINUE
8192 
8193 C...Read out starting position for search.
8194  IF(mstp(122).GE.2) WRITE(mstu(11),5700)
8195  sigsam=sigsmx(1)
8196  DO 440 imax=1,nmax
8197  iacc=iaccmx(imax)
8198  mtau=mvarpt(iacc,1)
8199  mtaup=mvarpt(iacc,2)
8200  myst=mvarpt(iacc,3)
8201  mcth=mvarpt(iacc,4)
8202  vtau=0.5d0
8203  vyst=0.5d0
8204  vcth=0.5d0
8205  vtaup=0.5d0
8206 
8207 C...Starting point and step size in parameter space.
8208  DO 430 irpt=1,2
8209  DO 420 ivar=1,4
8210  IF(npts(ivar).EQ.1) GOTO 420
8211  IF(ivar.EQ.1) vvar=vtau
8212  IF(ivar.EQ.2) vvar=vtaup
8213  IF(ivar.EQ.3) vvar=vyst
8214  IF(ivar.EQ.4) vvar=vcth
8215  IF(ivar.EQ.1) mvar=mtau
8216  IF(ivar.EQ.2) mvar=mtaup
8217  IF(ivar.EQ.3) mvar=myst
8218  IF(ivar.EQ.4) mvar=mcth
8219  IF(irpt.EQ.1) vdel=0.1d0
8220  IF(irpt.EQ.2) vdel=max(0.01d0,min(0.05d0,vvar-0.02d0,
8221  & 0.98d0-vvar))
8222  IF(irpt.EQ.1) vmar=0.02d0
8223  IF(irpt.EQ.2) vmar=0.002d0
8224  imov0=1
8225  IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0
8226  DO 410 imov=imov0,8
8227 
8228 C...Define new point in parameter space.
8229  IF(imov.EQ.0) THEN
8230  inew=2
8231  vnew=vvar
8232  ELSEIF(imov.EQ.1) THEN
8233  inew=3
8234  vnew=vvar+vdel
8235  ELSEIF(imov.EQ.2) THEN
8236  inew=1
8237  vnew=vvar-vdel
8238  ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND.
8239  & vvar+2d0*vdel.LT.1d0-vmar) THEN
8240  vvar=vvar+vdel
8241  sigssm(1)=sigssm(2)
8242  sigssm(2)=sigssm(3)
8243  inew=3
8244  vnew=vvar+vdel
8245  ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND.
8246  & vvar-2d0*vdel.GT.vmar) THEN
8247  vvar=vvar-vdel
8248  sigssm(3)=sigssm(2)
8249  sigssm(2)=sigssm(1)
8250  inew=1
8251  vnew=vvar-vdel
8252  ELSEIF(sigssm(3).GE.sigssm(1)) THEN
8253  vdel=0.5d0*vdel
8254  vvar=vvar+vdel
8255  sigssm(1)=sigssm(2)
8256  inew=2
8257  vnew=vvar
8258  ELSE
8259  vdel=0.5d0*vdel
8260  vvar=vvar-vdel
8261  sigssm(3)=sigssm(2)
8262  inew=2
8263  vnew=vvar
8264  ENDIF
8265 
8266 C...Convert to relevant variables and find derived new limits.
8267  ilerr=0
8268  IF(ivar.EQ.1) THEN
8269  vtau=vnew
8270  CALL pykmap(1,mtau,vtau)
8271  IF(istsb.GE.3.AND.istsb.LE.5) THEN
8272  CALL pyklim(4)
8273  IF(mint(51).EQ.1) ilerr=1
8274  ENDIF
8275  ENDIF
8276  IF(ivar.LE.2.AND.istsb.GE.3.AND.istsb.LE.5.AND.
8277  & ilerr.EQ.0) THEN
8278  IF(ivar.EQ.2) vtaup=vnew
8279  CALL pykmap(4,mtaup,vtaup)
8280  ENDIF
8281  IF(ivar.LE.2.AND.ilerr.EQ.0) THEN
8282  CALL pyklim(2)
8283  IF(mint(51).EQ.1) ilerr=1
8284  ENDIF
8285  IF(ivar.LE.3.AND.ilerr.EQ.0) THEN
8286  IF(ivar.EQ.3) vyst=vnew
8287  CALL pykmap(2,myst,vyst)
8288  CALL pyklim(3)
8289  IF(mint(51).EQ.1) ilerr=1
8290  ENDIF
8291  IF((istsb.EQ.2.OR.istsb.EQ.4.OR.istsb.EQ.6).AND.
8292  & ilerr.EQ.0) THEN
8293  IF(ivar.EQ.4) vcth=vnew
8294  CALL pykmap(3,mcth,vcth)
8295  ENDIF
8296  IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2)
8297 
8298 C...Evaluate cross-section. Save new maximum. Final maximum.
8299  IF(ilerr.NE.0) THEN
8300  sigs=0.
8301  ELSEIF(istsb.NE.5) THEN
8302  CALL pysigh(nchn,sigs)
8303  IF(mwtxs.EQ.1) THEN
8304  CALL pyevwt(wtxs)
8305  sigs=wtxs*sigs
8306  ENDIF
8307  ELSE
8308  sigs=0d0
8309  DO 400 ikin3=1,mstp(129)
8310  CALL pykmap(5,0,0d0)
8311  IF(mint(51).EQ.1) GOTO 400
8312  CALL pysigh(nchn,sigtmp)
8313  IF(mwtxs.EQ.1) THEN
8314  CALL pyevwt(wtxs)
8315  sigtmp=wtxs*sigtmp
8316  ENDIF
8317  IF(sigtmp.GT.sigs) sigs=sigtmp
8318  400 CONTINUE
8319  ENDIF
8320  sigssm(inew)=sigs
8321  IF(sigs.GT.sigsam) sigsam=sigs
8322  IF(mstp(122).GE.2) WRITE(mstu(11),5800) imax,ivar,mvar,
8323  & imov,vnew,vint(21),vint(22),vint(23),vint(26),sigs
8324  410 CONTINUE
8325  420 CONTINUE
8326  430 CONTINUE
8327  440 CONTINUE
8328  IF(mstp(121).EQ.1) sigsam=parp(121)*sigsam
8329  xsec(isub,1)=1.05d0*sigsam
8330 C...Add extra headroom for UED
8331  IF(isub.GT.310.AND.isub.LT.320) xsec(isub,1)=xsec(isub,1)*1.1d0
8332  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
8333  & wtgaga*xsec(isub,1)
8334  450 CONTINUE
8335  IF(mstp(173).EQ.1.AND.isub.NE.96) xsec(isub,1)=
8336  & parp(174)*xsec(isub,1)
8337  IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)
8338  460 CONTINUE
8339  mint(51)=0
8340 
8341 C...Print summary table.
8342  IF(mint(121).EQ.1.AND.nposi.EQ.0) THEN
8343  IF(mstp(127).NE.1) THEN
8344  WRITE(mstu(11),5900)
8345  CALL pystop(1)
8346  ELSE
8347  WRITE(mstu(11),6400)
8348  msti(53)=1
8349  ENDIF
8350  ENDIF
8351  IF(mstp(122).GE.1) THEN
8352  WRITE(mstu(11),6000)
8353  WRITE(mstu(11),6100)
8354  DO 470 isub=1,500
8355  IF(msub(isub).NE.1.AND.isub.NE.96) GOTO 470
8356  IF(isub.EQ.96.AND.mint(50).EQ.0) GOTO 470
8357  IF(isub.EQ.96.AND.msub(95).NE.1.AND.mod(mstp(81),10).LE.0)
8358  & GOTO 470
8359  IF(isub.EQ.96.AND.mint(49).EQ.0.AND.mstp(131).EQ.0) GOTO 470
8360  IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13
8361  & .OR.isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) GOTO 470
8362  IF(msub(95).EQ.1.AND.isub.GE.381.AND.isub.LE.386) GOTO 470
8363  WRITE(mstu(11),6200) isub,proc(isub),xsec(isub,1)
8364  470 CONTINUE
8365  WRITE(mstu(11),6300)
8366  ENDIF
8367 
8368 C...Format statements for maximization results.
8369  5000 FORMAT(/1x,'Coefficient optimization and maximum search for ',
8370  &'subprocess no',i4/1x,'Coefficient modes tau',10x,'y*',9x,
8371  &'cth',9x,'tau''',7x,'sigma')
8372  5100 FORMAT(1x,'Warning: requested subprocess ',i3,' has no allowed ',
8373  &'phase space.'/1x,'Process switched off!')
8374  5200 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,d12.4)
8375  5300 FORMAT(1x,'Warning: requested subprocess ',i3,' has vanishing ',
8376  &'cross-section.'/1x,'Process switched off!')
8377  5400 FORMAT(1x,'Coefficients of equation system to be solved for ',a4)
8378  5500 FORMAT(1x,1p,10d11.3)
8379  5600 FORMAT(1x,'Result for ',a4,':',9f9.4)
8380  5700 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',
8381  &'MOD MOV VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma')
8382  5800 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,d12.4)
8383  5900 FORMAT(1x,'Error: no requested process has non-vanishing ',
8384  &'cross-section.'/1x,'Execution stopped!')
8385  6000 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',
8386  &'cross-section maximum search',1x,8('*'))
8387  6100 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I ISUB ',
8388  &'Subprocess name',15x,'I Maximum value I'/11x,'I',38x,'I',
8389  &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')
8390  6200 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,d12.4,3x,'I')
8391  6300 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))
8392  6400 FORMAT(1x,'Error: no requested process has non-vanishing ',
8393  &'cross-section.'/
8394  &1x,'Execution will stop if you try to generate events.')
8395 
8396  RETURN
8397  END
8398 
8399 C*********************************************************************
8400 
8401 C...PYPILE
8402 C...Initializes multiplicity distribution and selects mutliplicity
8403 C...of pileup events, i.e. several events occuring at the same
8404 C...beam crossing.
8405 
8406  SUBROUTINE pypile(MPILE)
8407 
8408 C...Double precision and integer declarations.
8409  IMPLICIT DOUBLE PRECISION(a-h, o-z)
8410  IMPLICIT INTEGER(I-N)
8411  INTEGER PYK,PYCHGE,PYCOMP
8412 C...Commonblocks.
8413  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
8414  common/pypars/mstp(200),parp(200),msti(200),pari(200)
8415  common/pyint1/mint(400),vint(400)
8416  common/pyint7/sigt(0:6,0:6,0:5)
8417  SAVE /pydat1/,/pypars/,/pyint1/,/pyint7/
8418 C...Local arrays and saved variables.
8419  dimension wti(0:200)
8420  SAVE imin,imax,wti,wts
8421 
8422 C...Sum of allowed cross-sections for pileup events.
8423  IF(mpile.EQ.1) THEN
8424  vint(131)=sigt(0,0,5)
8425  IF(mstp(132).GE.2) vint(131)=vint(131)+sigt(0,0,4)
8426  IF(mstp(132).GE.3) vint(131)=vint(131)+sigt(0,0,2)+sigt(0,0,3)
8427  IF(mstp(132).GE.4) vint(131)=vint(131)+sigt(0,0,1)
8428  IF(mstp(133).LE.0) RETURN
8429 
8430 C...Initialize multiplicity distribution at maximum.
8431  xnave=vint(131)*parp(131)
8432  IF(xnave.GT.120d0) WRITE(mstu(11),5000) xnave
8433  inave=max(1,min(200,nint(xnave)))
8434  wti(inave)=1d0
8435  wts=wti(inave)
8436  wtn=wti(inave)*inave
8437 
8438 C...Find shape of multiplicity distribution below maximum.
8439  imin=inave
8440  DO 100 i=inave-1,1,-1
8441  IF(mstp(133).EQ.1) wti(i)=wti(i+1)*(i+1)/xnave
8442  IF(mstp(133).GE.2) wti(i)=wti(i+1)*i/xnave
8443  IF(wti(i).LT.1d-6) GOTO 110
8444  wts=wts+wti(i)
8445  wtn=wtn+wti(i)*i
8446  imin=i
8447  100 CONTINUE
8448 
8449 C...Find shape of multiplicity distribution above maximum.
8450  110 imax=inave
8451  DO 120 i=inave+1,200
8452  IF(mstp(133).EQ.1) wti(i)=wti(i-1)*xnave/i
8453  IF(mstp(133).GE.2) wti(i)=wti(i-1)*xnave/(i-1)
8454  IF(wti(i).LT.1d-6) GOTO 130
8455  wts=wts+wti(i)
8456  wtn=wtn+wti(i)*i
8457  imax=i
8458  120 CONTINUE
8459  130 vint(132)=xnave
8460  vint(133)=wtn/wts
8461  IF(mstp(133).EQ.1.AND.imin.EQ.1) vint(134)=
8462  & wts/(wts+wti(1)/xnave)
8463  IF(mstp(133).EQ.1.AND.imin.GT.1) vint(134)=1d0
8464  IF(mstp(133).GE.2) vint(134)=xnave
8465 
8466 C...Pick multiplicity of pileup events.
8467  ELSE
8468  IF(mstp(133).LE.0) THEN
8469  mint(81)=max(1,mstp(134))
8470  ELSE
8471  wtr=wts*pyr(0)
8472  DO 140 i=imin,imax
8473  mint(81)=i
8474  wtr=wtr-wti(i)
8475  IF(wtr.LE.0d0) GOTO 150
8476  140 CONTINUE
8477  150 CONTINUE
8478  ENDIF
8479  ENDIF
8480 
8481 C...Format statement for error message.
8482  5000 FORMAT(1x,'Warning: requested average number of events per bunch',
8483  &'crossing too large, ',1p,d12.4)
8484 
8485  RETURN
8486  END
8487 
8488 C*********************************************************************
8489 
8490 C...PYSAVE
8491 C...Saves and restores parameter and cross section values for the
8492 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8493 C...Also makes random choice between alternatives.
8494 
8495  SUBROUTINE pysave(ISAVE,IGA)
8496 
8497 C...Double precision and integer declarations.
8498  IMPLICIT DOUBLE PRECISION(a-h, o-z)
8499  IMPLICIT INTEGER(I-N)
8500  INTEGER PYK,PYCHGE,PYCOMP
8501 C...Commonblocks.
8502  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
8503  common/pypars/mstp(200),parp(200),msti(200),pari(200)
8504  common/pyint1/mint(400),vint(400)
8505  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
8506  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
8507  common/pyint7/sigt(0:6,0:6,0:5)
8508  SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint5/,/pyint7/
8509 C...Local arrays and saved variables.
8510  dimension ncp(15),nsubcp(15,20),msubcp(15,20),coefcp(15,20,20),
8511  &ngencp(15,0:20,3),xseccp(15,0:20,3),sigtcp(15,0:6,0:6,0:5),
8512  &intcp(15,20),recp(15,20)
8513  SAVE ncp,nsubcp,msubcp,coefcp,ngencp,xseccp,sigtcp,intcp,recp
8514 
8515 C...Save list of subprocesses and cross-section information.
8516  IF(isave.EQ.1) THEN
8517  icp=0
8518  DO 120 i=1,500
8519  IF(msub(i).EQ.0.AND.i.NE.96.AND.i.NE.97) GOTO 120
8520  icp=icp+1
8521  nsubcp(iga,icp)=i
8522  msubcp(iga,icp)=msub(i)
8523  DO 100 j=1,20
8524  coefcp(iga,icp,j)=coef(i,j)
8525  100 CONTINUE
8526  DO 110 j=1,3
8527  ngencp(iga,icp,j)=ngen(i,j)
8528  xseccp(iga,icp,j)=xsec(i,j)
8529  110 CONTINUE
8530  120 CONTINUE
8531  ncp(iga)=icp
8532  DO 130 j=1,3
8533  ngencp(iga,0,j)=ngen(0,j)
8534  xseccp(iga,0,j)=xsec(0,j)
8535  130 CONTINUE
8536  DO 160 i1=0,6
8537  DO 150 i2=0,6
8538  DO 140 j=0,5
8539  sigtcp(iga,i1,i2,j)=sigt(i1,i2,j)
8540  140 CONTINUE
8541  150 CONTINUE
8542  160 CONTINUE
8543 
8544 C...Save various common process variables.
8545  DO 170 j=1,10
8546  intcp(iga,j)=mint(40+j)
8547  170 CONTINUE
8548  intcp(iga,11)=mint(101)
8549  intcp(iga,12)=mint(102)
8550  intcp(iga,13)=mint(107)
8551  intcp(iga,14)=mint(108)
8552  intcp(iga,15)=mint(123)
8553  recp(iga,1)=ckin(3)
8554  recp(iga,2)=vint(318)
8555 
8556 C...Save cross-section information only.
8557  ELSEIF(isave.EQ.2) THEN
8558  DO 190 icp=1,ncp(iga)
8559  i=nsubcp(iga,icp)
8560  DO 180 j=1,3
8561  ngencp(iga,icp,j)=ngen(i,j)
8562  xseccp(iga,icp,j)=xsec(i,j)
8563  180 CONTINUE
8564  190 CONTINUE
8565  DO 200 j=1,3
8566  ngencp(iga,0,j)=ngen(0,j)
8567  xseccp(iga,0,j)=xsec(0,j)
8568  200 CONTINUE
8569 
8570 C...Choose between allowed alternatives.
8571  ELSEIF(isave.EQ.3.OR.isave.EQ.4) THEN
8572  IF(isave.EQ.4) THEN
8573  xsumcp=0d0
8574  DO 210 ig=1,mint(121)
8575  xsumcp=xsumcp+xseccp(ig,0,1)
8576  210 CONTINUE
8577  xsumcp=xsumcp*pyr(0)
8578  DO 220 ig=1,mint(121)
8579  iga=ig
8580  xsumcp=xsumcp-xseccp(ig,0,1)
8581  IF(xsumcp.LE.0d0) GOTO 230
8582  220 CONTINUE
8583  230 CONTINUE
8584  ENDIF
8585 
8586 C...Restore cross-section information.
8587  DO 240 i=1,500
8588  msub(i)=0
8589  240 CONTINUE
8590  DO 270 icp=1,ncp(iga)
8591  i=nsubcp(iga,icp)
8592  msub(i)=msubcp(iga,icp)
8593  DO 250 j=1,20
8594  coef(i,j)=coefcp(iga,icp,j)
8595  250 CONTINUE
8596  DO 260 j=1,3
8597  ngen(i,j)=ngencp(iga,icp,j)
8598  xsec(i,j)=xseccp(iga,icp,j)
8599  260 CONTINUE
8600  270 CONTINUE
8601  DO 280 j=1,3
8602  ngen(0,j)=ngencp(iga,0,j)
8603  xsec(0,j)=xseccp(iga,0,j)
8604  280 CONTINUE
8605  DO 310 i1=0,6
8606  DO 300 i2=0,6
8607  DO 290 j=0,5
8608  sigt(i1,i2,j)=sigtcp(iga,i1,i2,j)
8609  290 CONTINUE
8610  300 CONTINUE
8611  310 CONTINUE
8612 
8613 C...Restore various common process variables.
8614  DO 320 j=1,10
8615  mint(40+j)=intcp(iga,j)
8616  320 CONTINUE
8617  mint(101)=intcp(iga,11)
8618  mint(102)=intcp(iga,12)
8619  mint(107)=intcp(iga,13)
8620  mint(108)=intcp(iga,14)
8621  mint(123)=intcp(iga,15)
8622  ckin(3)=recp(iga,1)
8623  ckin(1)=2d0*ckin(3)
8624  vint(318)=recp(iga,2)
8625 
8626 C...Sum up cross-section info (for PYSTAT).
8627  ELSEIF(isave.EQ.5) THEN
8628  DO 330 i=1,500
8629  msub(i)=0
8630  ngen(i,1)=0
8631  ngen(i,3)=0
8632  xsec(i,3)=0d0
8633  330 CONTINUE
8634  ngen(0,1)=0
8635  ngen(0,2)=0
8636  ngen(0,3)=0
8637  xsec(0,3)=0
8638  DO 350 ig=1,mint(121)
8639  DO 340 icp=1,ncp(ig)
8640  i=nsubcp(ig,icp)
8641  IF(msubcp(ig,icp).EQ.1) msub(i)=1
8642  ngen(i,1)=ngen(i,1)+ngencp(ig,icp,1)
8643  ngen(i,3)=ngen(i,3)+ngencp(ig,icp,3)
8644  xsec(i,3)=xsec(i,3)+xseccp(ig,icp,3)
8645  340 CONTINUE
8646  ngen(0,1)=ngen(0,1)+ngencp(ig,0,1)
8647  ngen(0,2)=ngen(0,2)+ngencp(ig,0,2)
8648  ngen(0,3)=ngen(0,3)+ngencp(ig,0,3)
8649  xsec(0,3)=xsec(0,3)+xseccp(ig,0,3)
8650  350 CONTINUE
8651  ENDIF
8652 
8653  RETURN
8654  END
8655 
8656 C*********************************************************************
8657 
8658 C...PYGAGA
8659 C...For lepton beams it gives photon-hadron or photon-photon systems
8660 C...to be treated with the ordinary machinery and combines this with a
8661 C...description of the lepton -> lepton + photon branching.
8662 
8663  SUBROUTINE pygaga(IGAGA,WTGAGA)
8664 
8665 C...Double precision and integer declarations.
8666  IMPLICIT DOUBLE PRECISION(a-h, o-z)
8667  IMPLICIT INTEGER(I-N)
8668  INTEGER PYK,PYCHGE,PYCOMP
8669 C...Commonblocks.
8670  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
8671  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
8672  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
8673  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
8674  common/pypars/mstp(200),parp(200),msti(200),pari(200)
8675  common/pyint1/mint(400),vint(400)
8676  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
8677  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
8678  &/pyint5/
8679 C...Local variables and data statement.
8680  dimension pms(2),xmin(2),xmax(2),q2min(2),q2max(2),pmc(3),
8681  &x(2),q2(2),y(2),theta(2),phi(2),pt(2),beta(3)
8682  SAVE pms,xmin,xmax,q2min,q2max,pmc,x,q2,theta,phi,pt,w2min
8683  DATA eps/1d-4/
8684 
8685 C...Initialize generation of photons inside leptons.
8686  IF(igaga.EQ.1) THEN
8687 
8688 C...Save quantities on incoming lepton system.
8689  vint(301)=vint(1)
8690  vint(302)=vint(2)
8691  pms(1)=vint(303)**2
8692  IF(mint(141).EQ.0) pms(1)=sign(vint(3)**2,vint(3))
8693  pms(2)=vint(304)**2
8694  IF(mint(142).EQ.0) pms(2)=sign(vint(4)**2,vint(4))
8695  pmc(3)=vint(302)-pms(1)-pms(2)
8696  w2min=max(ckin(77),2d0*ckin(3),2d0*ckin(5))**2
8697 
8698 C...Calculate range of x and Q2 values allowed in generation.
8699  DO 100 i=1,2
8700  pmc(i)=vint(302)+pms(i)-pms(3-i)
8701  IF(mint(140+i).NE.0) THEN
8702  xmin(i)=max(ckin(59+2*i),eps)
8703  xmax(i)=min(ckin(60+2*i),1d0-2d0*vint(301)*sqrt(pms(i))/
8704  & pmc(i),1d0-eps)
8705  ymin=max(ckin(71+2*i),eps)
8706  ymax=min(ckin(72+2*i),1d0-eps)
8707  IF(ckin(64+2*i).GT.0d0) xmin(i)=max(xmin(i),
8708  & (ymin*pmc(3)-ckin(64+2*i))/pmc(i))
8709  xmax(i)=min(xmax(i),(ymax*pmc(3)-ckin(63+2*i))/pmc(i))
8710  themin=max(ckin(67+2*i),0d0)
8711  themax=min(ckin(68+2*i),paru(1))
8712  IF(ckin(68+2*i).LT.0d0) themax=paru(1)
8713  q2min(i)=max(ckin(63+2*i),xmin(i)**2*pms(i)/(1d0-xmin(i))+
8714  & ((1d0-xmax(i))*(vint(302)-2d0*pms(3-i))-
8715  & 2d0*pms(i)/(1d0-xmax(i)))*sin(themin/2d0)**2,0d0)
8716  q2max(i)=xmax(i)**2*pms(i)/(1d0-xmax(i))+
8717  & ((1d0-xmin(i))*(vint(302)-2d0*pms(3-i))-
8718  & 2d0*pms(i)/(1d0-xmin(i)))*sin(themax/2d0)**2
8719  IF(ckin(64+2*i).GT.0d0) q2max(i)=min(ckin(64+2*i),q2max(i))
8720 C...W limits when lepton on one side only.
8721  IF(mint(143-i).EQ.0) THEN
8722  xmin(i)=max(xmin(i),(w2min-pms(3-i))/pmc(i))
8723  IF(ckin(78).GT.0d0) xmax(i)=min(xmax(i),
8724  & (ckin(78)**2-pms(3-i))/pmc(i))
8725  ENDIF
8726  ENDIF
8727  100 CONTINUE
8728 
8729 C...W limits when lepton on both sides.
8730  IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8731  IF(ckin(78).GT.0d0) xmax(1)=min(xmax(1),
8732  & (ckin(78)**2+pmc(3)-pmc(2)*xmin(2))/pmc(1))
8733  IF(ckin(78).GT.0d0) xmax(2)=min(xmax(2),
8734  & (ckin(78)**2+pmc(3)-pmc(1)*xmin(1))/pmc(2))
8735  IF(iabs(mint(141)).NE.iabs(mint(142))) THEN
8736  xmin(1)=max(xmin(1),(pms(1)-pms(2)+vint(302)*(w2min-
8737  & pms(1)-pms(2))/(pmc(2)*xmax(2)+pms(1)-pms(2)))/pmc(1))
8738  xmin(2)=max(xmin(2),(pms(2)-pms(1)+vint(302)*(w2min-
8739  & pms(1)-pms(2))/(pmc(1)*xmax(1)+pms(2)-pms(1)))/pmc(2))
8740  ELSE
8741  xmin(1)=max(xmin(1),w2min/(vint(302)*xmax(2)))
8742  xmin(2)=max(xmin(2),w2min/(vint(302)*xmax(1)))
8743  ENDIF
8744  ENDIF
8745 
8746 C...Q2 and W values and photon flux weight factors for initialization.
8747  ELSEIF(igaga.EQ.2) THEN
8748  isub=mint(1)
8749  mint(15)=0
8750  mint(16)=0
8751 
8752 C...W value for photon on one or both sides, and for processes
8753 C...with gamma-gamma cross section peaked at small shat.
8754  IF(mint(141).NE.0.AND.mint(142).EQ.0) THEN
8755  vint(2)=vint(302)+pms(1)-pmc(1)*(1d0-xmax(1))
8756  ELSEIF(mint(141).EQ.0.AND.mint(142).NE.0) THEN
8757  vint(2)=vint(302)+pms(2)-pmc(2)*(1d0-xmax(2))
8758  ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
8759  vint(2)=max(ckin(77)**2,12d0*max(ckin(3),ckin(5))**2)
8760  IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
8761  ELSE
8762  vint(2)=xmax(1)*xmax(2)*vint(302)
8763  IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
8764  ENDIF
8765  vint(1)=sqrt(max(0d0,vint(2)))
8766 
8767 C...Upper estimate of photon flux weight factor.
8768 C...Initialization Q2 scale. Flag incoming unresolved photon.
8769  wtgaga=1d0
8770  DO 110 i=1,2
8771  IF(mint(140+i).NE.0) THEN
8772  wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
8773  & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
8774  IF(isub.EQ.99.AND.mint(106+i).EQ.4.AND.mint(109-i).EQ.3)
8775  & THEN
8776  q2init=5d0+q2min(3-i)
8777  ELSEIF(isub.EQ.99.AND.mint(106+i).EQ.4) THEN
8778  q2init=pmas(pycomp(113),1)**2+q2min(3-i)
8779  ELSEIF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
8780  q2init=max(ckin(1),2d0*ckin(3),2d0*ckin(5))**2/3d0
8781  ELSEIF((isub.EQ.138.AND.i.EQ.2).OR.
8782  & (isub.EQ.139.AND.i.EQ.1)) THEN
8783  q2init=vint(2)/3d0
8784  ELSEIF(isub.EQ.140) THEN
8785  q2init=vint(2)/2d0
8786  ELSE
8787  q2init=q2min(i)
8788  ENDIF
8789  vint(2+i)=-sqrt(max(q2min(i),min(q2max(i),q2init)))
8790  IF(mstp(14).EQ.0.OR.(isub.GE.131.AND.isub.LE.140))
8791  & mint(14+i)=22
8792  vint(306+i)=vint(2+i)**2
8793  ENDIF
8794  110 CONTINUE
8795  vint(320)=wtgaga
8796 
8797 C...Update pTmin and cross section information.
8798  IF(mstp(82).LE.1) THEN
8799  ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
8800  ELSE
8801  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
8802  ENDIF
8803  vint(149)=4d0*ptmn**2/vint(2)
8804  vint(154)=ptmn
8805  CALL pyxtot
8806  vint(318)=vint(317)
8807 
8808 C...Generate photons inside leptons and
8809 C...calculate photon flux weight factors.
8810  ELSEIF(igaga.EQ.3) THEN
8811  isub=mint(1)
8812  mint(15)=0
8813  mint(16)=0
8814 
8815 C...Generate phase space point and check against cuts.
8816  loop=0
8817  120 loop=loop+1
8818  DO 130 i=1,2
8819  IF(mint(140+i).NE.0) THEN
8820 C...Pick x and Q2
8821  x(i)=xmin(i)*(xmax(i)/xmin(i))**pyr(0)
8822  q2(i)=q2min(i)*(q2max(i)/q2min(i))**pyr(0)
8823 C...Cuts on internal consistency in x and Q2.
8824  IF(q2(i).LT.x(i)**2*pms(i)/(1d0-x(i))) GOTO 120
8825  IF(q2(i).GT.(1d0-x(i))*(vint(302)-2d0*pms(3-i))-
8826  & (2d0-x(i)**2)*pms(i)/(1d0-x(i))) GOTO 120
8827 C...Cuts on y and theta.
8828  y(i)=(pmc(i)*x(i)+q2(i))/pmc(3)
8829  IF(y(i).LT.ckin(71+2*i).OR.y(i).GT.ckin(72+2*i)) GOTO 120
8830  rat=((1d0-x(i))*q2(i)-x(i)**2*pms(i))/
8831  & ((1d0-x(i))**2*(vint(302)-2d0*pms(3-i)-2d0*pms(i)))
8832  theta(i)=2d0*asin(sqrt(max(0d0,min(1d0,rat))))
8833  IF(theta(i).LT.ckin(67+2*i)) GOTO 120
8834  IF(ckin(68+2*i).GT.0d0.AND.theta(i).GT.ckin(68+2*i))
8835  & GOTO 120
8836 
8837 C...Phi angle isotropic. Reconstruct pT.
8838  phi(i)=paru(2)*pyr(0)
8839  pt(i)=sqrt(((1d0-x(i))*pmc(i))**2/(4d0*vint(302))-
8840  & pms(i))*sin(theta(i))
8841 
8842 C...Store info on variables selected, for documentation purposes.
8843  vint(2+i)=-sqrt(q2(i))
8844  vint(304+i)=x(i)
8845  vint(306+i)=q2(i)
8846  vint(308+i)=y(i)
8847  vint(310+i)=theta(i)
8848  vint(312+i)=phi(i)
8849  ELSE
8850  vint(304+i)=1d0
8851  vint(306+i)=0d0
8852  vint(308+i)=1d0
8853  vint(310+i)=0d0
8854  vint(312+i)=0d0
8855  ENDIF
8856  130 CONTINUE
8857 
8858 C...Cut on W combines info from two sides.
8859  IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8860  w2=-q2(1)-q2(2)+0.5d0*x(1)*pmc(1)*x(2)*pmc(2)/vint(302)-
8861  & 2d0*pt(1)*pt(2)*cos(phi(1)-phi(2))+2d0*
8862  & sqrt((0.5d0*x(1)*pmc(1)/vint(301))**2+q2(1)-pt(1)**2)*
8863  & sqrt((0.5d0*x(2)*pmc(2)/vint(301))**2+q2(2)-pt(2)**2)
8864  IF(w2.LT.w2min) GOTO 120
8865  IF(ckin(78).GT.0d0.AND.w2.GT.ckin(78)**2) GOTO 120
8866  pms1=-q2(1)
8867  pms2=-q2(2)
8868  ELSEIF(mint(141).NE.0) THEN
8869  w2=(vint(302)+pms(1))*x(1)+pms(2)*(1d0-x(1))
8870  pms1=-q2(1)
8871  pms2=pms(2)
8872  ELSEIF(mint(142).NE.0) THEN
8873  w2=(vint(302)+pms(2))*x(2)+pms(1)*(1d0-x(2))
8874  pms1=pms(1)
8875  pms2=-q2(2)
8876  ENDIF
8877 
8878 C...Store kinematics info for photon(s) in subsystem cm frame.
8879  vint(2)=w2
8880  vint(1)=sqrt(w2)
8881  vint(291)=0d0
8882  vint(292)=0d0
8883  vint(293)=0.5d0*sqrt((w2-pms1-pms2)**2-4d0*pms1*pms2)/vint(1)
8884  vint(294)=0.5d0*(w2+pms1-pms2)/vint(1)
8885  vint(295)=sign(sqrt(abs(pms1)),pms1)
8886  vint(296)=0d0
8887  vint(297)=0d0
8888  vint(298)=-vint(293)
8889  vint(299)=0.5d0*(w2+pms2-pms1)/vint(1)
8890  vint(300)=sign(sqrt(abs(pms2)),pms2)
8891 
8892 C...Assign weight for photon flux; different for transverse and
8893 C...longitudinal photons. Flag incoming unresolved photon.
8894  wtgaga=1d0
8895  DO 140 i=1,2
8896  IF(mint(140+i).NE.0) THEN
8897  wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
8898  & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
8899  IF(mstp(16).EQ.0) THEN
8900  xy=x(i)
8901  ELSE
8902  wtgaga=wtgaga*x(i)/y(i)
8903  xy=y(i)
8904  ENDIF
8905  IF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
8906  wtgaga=wtgaga*(1d0-xy)
8907  ELSEIF(i.EQ.1.AND.(isub.EQ.139.OR.isub.EQ.140)) THEN
8908  wtgaga=wtgaga*(1d0-xy)
8909  ELSEIF(i.EQ.2.AND.(isub.EQ.138.OR.isub.EQ.140)) THEN
8910  wtgaga=wtgaga*(1d0-xy)
8911  ELSE
8912  wtgaga=wtgaga*(0.5d0*(1d0+(1d0-xy)**2)-
8913  & pms(i)*xy**2/q2(i))
8914  ENDIF
8915  IF(mint(106+i).EQ.0) mint(14+i)=22
8916  ENDIF
8917  140 CONTINUE
8918  vint(319)=wtgaga
8919  mint(143)=loop
8920 
8921 C...Update pTmin and cross section information.
8922  IF(mstp(82).LE.1) THEN
8923  ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
8924  ELSE
8925  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
8926  ENDIF
8927  vint(149)=4d0*ptmn**2/vint(2)
8928  vint(154)=ptmn
8929  CALL pyxtot
8930 
8931 C...Reconstruct kinematics of photons inside leptons.
8932  ELSEIF(igaga.EQ.4) THEN
8933 
8934 C...Make place for incoming particles and scattered leptons.
8935  move=3
8936  IF(mint(141).NE.0.AND.mint(142).NE.0) move=4
8937  mint(4)=mint(4)+move
8938  DO 160 i=mint(84)-move,mint(83)+1,-1
8939  IF(k(i,1).EQ.21) THEN
8940  DO 150 j=1,5
8941  k(i+move,j)=k(i,j)
8942  p(i+move,j)=p(i,j)
8943  v(i+move,j)=v(i,j)
8944  150 CONTINUE
8945  IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
8946  & k(i+move,3)=k(i,3)+move
8947  IF(k(i,4).GT.mint(83).AND.k(i,4).LE.mint(84))
8948  & k(i+move,4)=k(i,4)+move
8949  IF(k(i,5).GT.mint(83).AND.k(i,5).LE.mint(84))
8950  & k(i+move,5)=k(i,5)+move
8951  ENDIF
8952  160 CONTINUE
8953  DO 170 i=mint(84)+1,n
8954  IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
8955  & k(i,3)=k(i,3)+move
8956  170 CONTINUE
8957 
8958 C...Fill in incoming particles.
8959  DO 190 i=mint(83)+1,mint(83)+move
8960  DO 180 j=1,5
8961  k(i,j)=0
8962  p(i,j)=0d0
8963  v(i,j)=0d0
8964  180 CONTINUE
8965  190 CONTINUE
8966  DO 200 i=1,2
8967  k(mint(83)+i,1)=21
8968  IF(mint(140+i).NE.0) THEN
8969  k(mint(83)+i,2)=mint(140+i)
8970  p(mint(83)+i,5)=vint(302+i)
8971  ELSE
8972  k(mint(83)+i,2)=mint(10+i)
8973  p(mint(83)+i,5)=vint(2+i)
8974  ENDIF
8975  p(mint(83)+i,3)=0.5d0*sqrt((pmc(3)**2-4d0*pms(1)*pms(2))/
8976  & vint(302))*(-1d0)**(i+1)
8977  p(mint(83)+i,4)=0.5d0*pmc(i)/vint(301)
8978  200 CONTINUE
8979 
8980 C...New mother-daughter relations in documentation section.
8981  IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8982  k(mint(83)+1,4)=mint(83)+3
8983  k(mint(83)+1,5)=mint(83)+5
8984  k(mint(83)+2,4)=mint(83)+4
8985  k(mint(83)+2,5)=mint(83)+6
8986  k(mint(83)+3,3)=mint(83)+1
8987  k(mint(83)+5,3)=mint(83)+1
8988  k(mint(83)+4,3)=mint(83)+2
8989  k(mint(83)+6,3)=mint(83)+2
8990  ELSEIF(mint(141).NE.0) THEN
8991  k(mint(83)+1,4)=mint(83)+3
8992  k(mint(83)+1,5)=mint(83)+4
8993  k(mint(83)+2,4)=mint(83)+5
8994  k(mint(83)+3,3)=mint(83)+1
8995  k(mint(83)+4,3)=mint(83)+1
8996  k(mint(83)+5,3)=mint(83)+2
8997  ELSEIF(mint(142).NE.0) THEN
8998  k(mint(83)+1,4)=mint(83)+4
8999  k(mint(83)+2,4)=mint(83)+3
9000  k(mint(83)+2,5)=mint(83)+5
9001  k(mint(83)+3,3)=mint(83)+2
9002  k(mint(83)+4,3)=mint(83)+1
9003  k(mint(83)+5,3)=mint(83)+2
9004  ENDIF
9005 
9006 C...Fill scattered lepton(s).
9007  DO 210 i=1,2
9008  IF(mint(140+i).NE.0) THEN
9009  lsc=mint(83)+min(i+2,move)
9010  k(lsc,1)=21
9011  k(lsc,2)=mint(140+i)
9012  p(lsc,1)=pt(i)*cos(phi(i))
9013  p(lsc,2)=pt(i)*sin(phi(i))
9014  p(lsc,4)=(1d0-x(i))*p(mint(83)+i,4)
9015  p(lsc,3)=sqrt(p(lsc,4)**2-pms(i))*cos(theta(i))*
9016  & (-1d0)**(i-1)
9017  p(lsc,5)=vint(302+i)
9018  ENDIF
9019  210 CONTINUE
9020 
9021 C...Find incoming four-vectors to subprocess.
9022  k(n+1,1)=21
9023  IF(mint(141).NE.0) THEN
9024  DO 220 j=1,4
9025  p(n+1,j)=p(mint(83)+1,j)-p(mint(83)+3,j)
9026  220 CONTINUE
9027  ELSE
9028  DO 230 j=1,4
9029  p(n+1,j)=p(mint(83)+1,j)
9030  230 CONTINUE
9031  ENDIF
9032  k(n+2,1)=21
9033  IF(mint(142).NE.0) THEN
9034  DO 240 j=1,4
9035  p(n+2,j)=p(mint(83)+2,j)-p(mint(83)+move,j)
9036  240 CONTINUE
9037  ELSE
9038  DO 250 j=1,4
9039  p(n+2,j)=p(mint(83)+2,j)
9040  250 CONTINUE
9041  ENDIF
9042 
9043 C...Define boost and rotation between hadronic subsystem and
9044 C...collision rest frame; boost hadronic subsystem to this frame.
9045  DO 260 j=1,3
9046  beta(j)=(p(n+1,j)+p(n+2,j))/(p(n+1,4)+p(n+2,4))
9047  260 CONTINUE
9048  CALL pyrobo(n+1,n+2,0d0,0d0,-beta(1),-beta(2),-beta(3))
9049  bphi=pyangl(p(n+1,1),p(n+1,2))
9050  CALL pyrobo(n+1,n+2,0d0,-bphi,0d0,0d0,0d0)
9051  btheta=pyangl(p(n+1,3),p(n+1,1))
9052  CALL pyrobo(mint(83)+move+1,n,btheta,bphi,beta(1),beta(2),
9053  & beta(3))
9054 
9055 C...Add on scattered leptons to final state.
9056  DO 280 i=1,2
9057  IF(mint(140+i).NE.0) THEN
9058  lsc=mint(83)+min(i+2,move)
9059  n=n+1
9060  DO 270 j=1,5
9061  k(n,j)=k(lsc,j)
9062  p(n,j)=p(lsc,j)
9063  v(n,j)=v(lsc,j)
9064  270 CONTINUE
9065  k(n,1)=1
9066  k(n,3)=lsc
9067  ENDIF
9068  280 CONTINUE
9069  ENDIF
9070 
9071  RETURN
9072  END
9073 
9074 C*********************************************************************
9075 
9076 C...PYRAND
9077 C...Generates quantities characterizing the high-pT scattering at the
9078 C...parton level according to the matrix elements. Chooses incoming,
9079 C...reacting partons, their momentum fractions and one of the possible
9080 C...subprocesses.
9081 
9082  SUBROUTINE pyrand
9083 
9084 C...Double precision and integer declarations.
9085  IMPLICIT DOUBLE PRECISION(a-h, o-z)
9086  IMPLICIT INTEGER(I-N)
9087  INTEGER PYK,PYCHGE,PYCOMP
9088 C...Parameter statement to help give large particle numbers.
9089  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
9090  &kexcit=4000000,kdimen=5000000)
9091 
9092 C...User process initialization and event commonblocks.
9093  INTEGER MAXPUP
9094  parameter(maxpup=100)
9095  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9096  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9097  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
9098  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
9099  &lprup(maxpup)
9100  INTEGER MAXNUP
9101  parameter(maxnup=500)
9102  INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9103  DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9104  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
9105  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
9106  &vtimup(maxnup),spinup(maxnup)
9107  SAVE /heprup/,/hepeup/
9108 
9109 C...Commonblocks.
9110  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
9111  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
9112  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
9113  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
9114  common/pypars/mstp(200),parp(200),msti(200),pari(200)
9115  common/pyint1/mint(400),vint(400)
9116  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
9117  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
9118  common/pyint4/mwid(500),wids(500,5)
9119  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
9120  common/pyint7/sigt(0:6,0:6,0:5)
9121  common/pymssm/imss(0:99),rmss(0:99)
9122  common/pytcco/coefx(194:380,2)
9123  common/tcpara/ires,jres,xmas(3),xwid(3),ymas(2),ywid(2)
9124  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
9125  &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,/pymssm/,/pytcco/,
9126  &/tcpara/
9127 C...Local arrays.
9128  dimension xpq(-25:25),pmm(2),pdif(4),bhad(4),pmmn(2)
9129 
9130 C...Parameters and data used in elastic/diffractive treatment.
9131  DATA eps/0.0808d0/, alp/0.25d0/, cres/2d0/, pmrc/1.062d0/,
9132  &smp/0.880d0/, bhad/2.3d0,1.4d0,1.4d0,0.23d0/
9133 
9134 C...Initial values, specifically for (first) semihard interaction.
9135  mint(10)=0
9136  mint(17)=0
9137  mint(18)=0
9138  vint(143)=1d0
9139  vint(144)=1d0
9140  vint(157)=0d0
9141  vint(158)=0d0
9142  mfail=0
9143  IF(mstp(171).EQ.1.AND.mstp(172).EQ.2) mfail=1
9144  isub=0
9145  istsb=0
9146  loop=0
9147  100 loop=loop+1
9148  mint(51)=0
9149  mint(143)=1
9150  vint(97)=1d0
9151 
9152 C...Start by assuming incoming photon is entering subprocess.
9153  IF(mint(11).EQ.22) THEN
9154  mint(15)=22
9155  vint(307)=vint(3)**2
9156  ENDIF
9157  IF(mint(12).EQ.22) THEN
9158  mint(16)=22
9159  vint(308)=vint(4)**2
9160  ENDIF
9161  mint(103)=mint(11)
9162  mint(104)=mint(12)
9163 
9164 C...Choice of process type - first event of pileup.
9165  inmult=0
9166  IF(mint(82).EQ.1.AND.isub.GE.91.AND.isub.LE.96) THEN
9167  ELSEIF(mint(82).EQ.1) THEN
9168 
9169 C...For gamma-p or gamma-gamma first pick between alternatives.
9170  iga=0
9171  IF(mint(121).GT.1) CALL pysave(4,iga)
9172  mint(122)=iga
9173 
9174 C...For real gamma + gamma with different nature, flip at random.
9175  IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
9176  & mstp(14).LE.10.AND.pyr(0).GT.0.5d0) THEN
9177  mintsv=mint(41)
9178  mint(41)=mint(42)
9179  mint(42)=mintsv
9180  mintsv=mint(45)
9181  mint(45)=mint(46)
9182  mint(46)=mintsv
9183  mintsv=mint(107)
9184  mint(107)=mint(108)
9185  mint(108)=mintsv
9186  IF(mint(47).EQ.2.OR.mint(47).EQ.3) mint(47)=5-mint(47)
9187  ENDIF
9188 
9189 C...Pick process type, possibly by user process machinery.
9190 C...(If the latter, also event will be picked here.)
9191  IF(mint(111).GE.11.AND.iabs(idwtup).EQ.2.AND.loop.GE.2) THEN
9192  CALL upevnt
9193  CALL pyupre
9194  ELSEIF(mint(111).GE.11.AND.iabs(idwtup).GE.3) THEN
9195  CALL upevnt
9196  CALL pyupre
9197  isub=0
9198  110 isub=isub+1
9199  IF((iset(isub).NE.11.OR.kfpr(isub,2).NE.idprup).AND.
9200  & isub.LT.500) GOTO 110
9201  ELSE
9202  rsub=xsec(0,1)*pyr(0)
9203  DO 120 i=1,500
9204  IF(msub(i).NE.1.OR.i.EQ.96) GOTO 120
9205  isub=i
9206  rsub=rsub-xsec(i,1)
9207  IF(rsub.LE.0d0) GOTO 130
9208  120 CONTINUE
9209  130 IF(isub.EQ.95) isub=96
9210  IF(isub.EQ.96) inmult=1
9211  IF(iset(isub).EQ.11) THEN
9212  idprup=kfpr(isub,2)
9213  CALL upevnt
9214  CALL pyupre
9215  ENDIF
9216  ENDIF
9217 
9218 C...Choice of inclusive process type - pileup events.
9219  ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN
9220  rsub=vint(131)*pyr(0)
9221  isub=96
9222  IF(rsub.GT.sigt(0,0,5)) isub=94
9223  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)) isub=93
9224  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)) isub=92
9225  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)+sigt(0,0,2))
9226  & isub=91
9227  IF(isub.EQ.96) inmult=1
9228  ENDIF
9229 
9230 C...Choice of photon energy and flux factor inside lepton.
9231  IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
9232  CALL pygaga(3,wtgaga)
9233  IF(isub.GE.131.AND.isub.LE.140) THEN
9234  ckin(3)=max(vint(285),vint(154))
9235  ckin(1)=2d0*ckin(3)
9236  ENDIF
9237 C...When necessary set direct/resolved photon by hand.
9238  ELSEIF(mint(15).EQ.22.OR.mint(16).EQ.22) THEN
9239  IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
9240  IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
9241  ENDIF
9242 
9243 C...Restrict direct*resolved processes to pTmin >= Q,
9244 C...to avoid doublecounting with DIS.
9245  IF(mstp(18).EQ.3.AND.isub.GE.131.AND.isub.LE.136) THEN
9246  IF(mint(15).EQ.22) THEN
9247  ckin(3)=max(vint(285),vint(154),abs(vint(3)))
9248  ELSE
9249  ckin(3)=max(vint(285),vint(154),abs(vint(4)))
9250  ENDIF
9251  ckin(1)=2d0*ckin(3)
9252  ENDIF
9253 
9254 C...Set up for multiple interactions (may include impact parameter).
9255  IF(inmult.EQ.1) THEN
9256  IF(mint(35).LE.1) CALL pymult(2)
9257  IF(mint(35).GE.2) CALL pymign(2)
9258  ENDIF
9259 
9260 C...Loopback point for minimum bias in photon physics.
9261  loop2=0
9262  140 loop2=loop2+1
9263  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+mint(143)
9264  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+mint(143)
9265  IF(isub.EQ.96.AND.loop2.EQ.1.AND.mint(82).EQ.1)
9266  &ngen(97,1)=ngen(97,1)+mint(143)
9267  mint(1)=isub
9268  istsb=iset(isub)
9269 
9270 C...Random choice of flavour for some SUSY processes.
9271  IF(isub.GE.201.AND.isub.LE.301) THEN
9272 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9273  IF(isub.EQ.210) THEN
9274  kfpr(isub,1)=ksusy1+11+2*int(0.5d0+pyr(0))
9275  kfpr(isub,2)=kfpr(isub,1)+1
9276 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9277  ELSEIF(isub.EQ.213) THEN
9278  kfpr(isub,1)=ksusy1+12+2*int(0.5d0+pyr(0))
9279  kfpr(isub,2)=kfpr(isub,1)
9280 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9281  ELSEIF(isub.GE.246.AND.isub.LE.259.AND.isub.NE.255.AND.
9282  & isub.NE.257) THEN
9283  IF(isub.GE.258) THEN
9284  rkf=4d0
9285  ELSE
9286  rkf=5d0
9287  ENDIF
9288  IF(mod(isub,2).EQ.0) THEN
9289  kfpr(isub,1)=ksusy1+1+int(rkf*pyr(0))
9290  ELSE
9291  kfpr(isub,1)=ksusy2+1+int(rkf*pyr(0))
9292  ENDIF
9293 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9294  ELSEIF(isub.GE.271.AND.isub.LE.276) THEN
9295  IF(isub.EQ.271.OR.isub.EQ.274) THEN
9296  ksu1=ksusy1
9297  ksu2=ksusy1
9298  ELSEIF(isub.EQ.272.OR.isub.EQ.275) THEN
9299  ksu1=ksusy2
9300  ksu2=ksusy2
9301  ELSEIF(pyr(0).LT.0.5d0) THEN
9302  ksu1=ksusy1
9303  ksu2=ksusy2
9304  ELSE
9305  ksu1=ksusy2
9306  ksu2=ksusy1
9307  ENDIF
9308  kfpr(isub,1)=ksu1+1+int(4d0*pyr(0))
9309  kfpr(isub,2)=ksu2+1+int(4d0*pyr(0))
9310 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9311  ELSEIF(isub.EQ.277.OR.isub.EQ.279) THEN
9312  kfpr(isub,1)=ksusy1+1+int(4d0*pyr(0))
9313  kfpr(isub,2)=kfpr(isub,1)
9314  ELSEIF(isub.EQ.278.OR.isub.EQ.280) THEN
9315  kfpr(isub,1)=ksusy2+1+int(4d0*pyr(0))
9316  kfpr(isub,2)=kfpr(isub,1)
9317 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9318  ELSEIF(isub.GE.281.AND.isub.LE.286) THEN
9319  IF(isub.EQ.281.OR.isub.EQ.284) THEN
9320  ksu1=ksusy1
9321  ksu2=ksusy1
9322  ELSEIF(isub.EQ.282.OR.isub.EQ.285) THEN
9323  ksu1=ksusy2
9324  ksu2=ksusy2
9325  ELSEIF(pyr(0).LT.0.5d0) THEN
9326  ksu1=ksusy1
9327  ksu2=ksusy2
9328  ELSE
9329  ksu1=ksusy2
9330  ksu2=ksusy1
9331  ENDIF
9332  IF(isub.EQ.281.OR.isub.LE.283) THEN
9333  rkf=5d0
9334  ELSE
9335  rkf=4d0
9336  ENDIF
9337  kfpr(isub,2)=ksu2+1+int(rkf*pyr(0))
9338  ENDIF
9339  ENDIF
9340 
9341 C...Random choice of flavours for some UED processes
9342 c...The production processes can generate a doublet pair,
9343 c...a singlet pair, or a doublet + singlet.
9344  IF(isub.EQ.313)THEN
9345 C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9346  IF(pyr(0).LE.0.1)THEN
9347  kfpr(isub,1)=5100001
9348  ELSE
9349  kfpr(isub,1)=5100002
9350  ENDIF
9351  kfpr(isub,2)=kfpr(isub,1)
9352  ELSEIF(isub.EQ.314.OR.isub.EQ.315)THEN
9353 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9354 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9355  IF(pyr(0).LE.0.1)THEN
9356  kfpr(isub,1)=5100001
9357  ELSE
9358  kfpr(isub,1)=5100002
9359  ENDIF
9360  kfpr(isub,2)=-kfpr(isub,1)
9361  ELSEIF(isub.EQ.316)THEN
9362 C...qi + qbarj -> q*_Di + q*_Sbarj
9363  IF(pyr(0).LE.0.5)THEN
9364  kfpr(isub,1)=5100001
9365 c Changed from private pythia6410_ued code
9366 c KFPR(ISUB,2)=-5010001
9367  kfpr(isub,2)=-6100002
9368  ELSE
9369  kfpr(isub,1)=5100002
9370 c Changed from private pythia6410_ued code
9371 c KFPR(ISUB,2)=-5010002
9372  kfpr(isub,2)=-6100001
9373  ENDIF
9374  ELSEIF(isub.EQ.317)THEN
9375 C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9376  IF(pyr(0).LE.0.5)THEN
9377  kfpr(isub,1)=5100001
9378  kfpr(isub,2)=-5100002
9379  ELSE
9380  kfpr(isub,1)=5100002
9381  kfpr(isub,2)=-5100001
9382  ENDIF
9383  ELSEIF(isub.EQ.318)THEN
9384 C...qi + qj -> q*_Di + q*_Sj
9385  IF(pyr(0).LE.0.5)THEN
9386  kfpr(isub,1)=5100001
9387  kfpr(isub,2)=6100002
9388  ELSE
9389  kfpr(isub,1)=5100002
9390  kfpr(isub,2)=6100001
9391  ENDIF
9392  ENDIF
9393 
9394 C...Find resonances (explicit or implicit in cross-section).
9395  mint(72)=0
9396  kfr1=0
9397  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
9398  kfr1=kfpr(isub,1)
9399  ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165.OR.
9400  & isub.EQ.171.OR.isub.EQ.176) THEN
9401  kfr1=23
9402  ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172.OR.
9403  & isub.EQ.177) THEN
9404  kfr1=24
9405  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
9406  kfr1=25
9407  IF(mstp(46).EQ.5) THEN
9408  kfr1=89
9409  pmas(89,1)=parp(45)
9410  pmas(89,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
9411  ENDIF
9412  ENDIF
9413  ckmx=ckin(2)
9414  IF(ckmx.LE.0d0) ckmx=vint(1)
9415  kcr1=pycomp(kfr1)
9416  IF(kfr1.NE.0) THEN
9417  IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
9418  & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
9419  ENDIF
9420  IF(kfr1.NE.0) THEN
9421  taur1=pmas(kcr1,1)**2/vint(2)
9422  gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
9423  mint(72)=1
9424  mint(73)=kfr1
9425  vint(73)=taur1
9426  vint(74)=gamr1
9427  ENDIF
9428  kfr2=0
9429  kfr3=0
9430  IF(isub.EQ.141.OR.isub.EQ.194.OR.isub.EQ.195.OR.
9431  $(isub.GE.361.AND.isub.LE.380))
9432  $THEN
9433  kfr2=23
9434  IF(isub.EQ.141) THEN
9435  kcr2=pycomp(kfr2)
9436  IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
9437  & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) THEN
9438  kfr2=0
9439  ELSE
9440  taur2=pmas(kcr2,1)**2/vint(2)
9441  gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
9442  mint(72)=2
9443  mint(74)=kfr2
9444  vint(75)=taur2
9445  vint(76)=gamr2
9446  ENDIF
9447 C...3 resonances at work: rho, omega, a
9448  ELSEIF(isub.EQ.194.OR.(isub.GE.361.AND.isub.LE.368)
9449  & .OR.isub.EQ.379.OR.isub.EQ.380) THEN
9450  mint(72)=ires
9451  IF(ires.GE.1) THEN
9452  vint(73)=xmas(1)**2/vint(2)
9453  vint(74)=xmas(1)*xwid(1)/vint(2)
9454  taur1=vint(73)
9455  gamr1=vint(74)
9456  kfr1=1
9457  ENDIF
9458  IF(ires.GE.2) THEN
9459  vint(75)=xmas(2)**2/vint(2)
9460  vint(76)=xmas(2)*xwid(2)/vint(2)
9461  taur2=vint(75)
9462  gamr2=vint(76)
9463  kfr2=2
9464  ENDIF
9465  IF(ires.EQ.3) THEN
9466  vint(77)=xmas(3)**2/vint(2)
9467  vint(78)=xmas(3)*xwid(3)/vint(2)
9468  taur3=vint(77)
9469  gamr3=vint(78)
9470  kfr3=3
9471  ENDIF
9472 C...Charged current: rho+- and a+-
9473  ELSEIF(isub.EQ.195.OR.isub.GE.370.AND.isub.LE.378) THEN
9474  mint(72)=ires
9475  IF(jres.GE.1) THEN
9476  vint(73)=ymas(1)**2/vint(2)
9477  vint(74)=ymas(1)*ywid(1)/vint(2)
9478  kfr1=1
9479  taur1=vint(73)
9480  gamr1=vint(74)
9481  ENDIF
9482  IF(jres.GE.2) THEN
9483  vint(75)=ymas(2)**2/vint(2)
9484  vint(76)=ymas(2)*ywid(2)/vint(2)
9485  kfr2=2
9486  taur2=vint(73)
9487  gamr2=vint(74)
9488  ENDIF
9489  kfr3=0
9490  ENDIF
9491  IF(isub.NE.141) THEN
9492  IF(kfr3.NE.0.AND.kfr2.NE.0.AND.kfr1.NE.0) THEN
9493 
9494  ELSEIF(kfr1.NE.0.AND.kfr2.NE.0) THEN
9495  mint(72)=2
9496  ELSEIF(kfr1.NE.0.AND.kfr3.NE.0) THEN
9497  mint(72)=2
9498  mint(74)=kfr3
9499  vint(75)=taur3
9500  vint(76)=gamr3
9501  ELSEIF(kfr2.NE.0.AND.kfr3.NE.0) THEN
9502  mint(72)=2
9503  mint(73)=kfr2
9504  vint(73)=taur2
9505  vint(74)=gamr2
9506  mint(74)=kfr3
9507  vint(75)=taur3
9508  vint(76)=gamr3
9509  ELSEIF(kfr1.NE.0) THEN
9510  mint(72)=1
9511  ELSEIF(kfr2.NE.0) THEN
9512  mint(72)=1
9513  mint(73)=kfr2
9514  vint(73)=taur2
9515  vint(74)=gamr2
9516  ELSEIF(kfr3.NE.0) THEN
9517  mint(72)=1
9518  mint(73)=kfr3
9519  vint(73)=taur3
9520  vint(74)=gamr3
9521  ELSE
9522  mint(72)=0
9523  ENDIF
9524  ELSE
9525  IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
9526 
9527  ELSEIF(kfr2.NE.0) THEN
9528  kfr1=kfr2
9529  taur1=taur2
9530  gamr1=gamr2
9531  mint(72)=1
9532  mint(73)=kfr1
9533  vint(73)=taur1
9534  vint(74)=gamr1
9535  kfr2=0
9536  ELSE
9537  mint(72)=0
9538  ENDIF
9539  ENDIF
9540  ENDIF
9541 
9542 C...Find product masses and minimum pT of process,
9543 C...optionally with broadening according to a truncated Breit-Wigner.
9544  vint(63)=0d0
9545  vint(64)=0d0
9546  mint(71)=0
9547  vint(71)=ckin(3)
9548  IF(mint(82).GE.2) vint(71)=0d0
9549  vint(80)=1d0
9550  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
9551  nbw=0
9552  DO 160 i=1,2
9553  pmmn(i)=0d0
9554  IF(kfpr(isub,i).EQ.0) THEN
9555  ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
9556  & parp(41)) THEN
9557  vint(62+i)=pmas(pycomp(kfpr(isub,i)),1)**2
9558  ELSE
9559  nbw=nbw+1
9560 C...This prevents SUSY/t particles from becoming too light.
9561  kflw=kfpr(isub,i)
9562  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
9563  kcw=pycomp(kflw)
9564  pmmn(i)=pmas(kcw,1)
9565  DO 150 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
9566  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
9567  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
9568  & pmas(pycomp(kfdp(idc,2)),1)
9569  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
9570  & pmas(pycomp(kfdp(idc,3)),1)
9571  pmmn(i)=min(pmmn(i),pmsum)
9572  ENDIF
9573  150 CONTINUE
9574  ELSEIF(kflw.EQ.6) THEN
9575  pmmn(i)=pmas(24,1)+pmas(5,1)
9576  ENDIF
9577  ENDIF
9578  160 CONTINUE
9579  IF(nbw.GE.1) THEN
9580  ckin41=ckin(41)
9581  ckin43=ckin(43)
9582  ckin(41)=max(pmmn(1),ckin(41))
9583  ckin(43)=max(pmmn(2),ckin(43))
9584  CALL pyofsh(4,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
9585  ckin(41)=ckin41
9586  ckin(43)=ckin43
9587  IF(mint(51).EQ.1) THEN
9588  IF(mint(121).GT.1) CALL pysave(2,iga)
9589  IF(mfail.EQ.1) THEN
9590  msti(61)=1
9591  RETURN
9592  ENDIF
9593  GOTO 100
9594  ENDIF
9595  vint(63)=pqm3**2
9596  vint(64)=pqm4**2
9597  ENDIF
9598  IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1
9599  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
9600  ENDIF
9601 
9602 C...Prepare for additional variable choices in 2 -> 3.
9603  IF(istsb.EQ.5) THEN
9604  vint(201)=0d0
9605  IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
9606  vint(206)=vint(201)
9607  IF(isub.EQ.401.OR.isub.EQ.402) vint(206)=pmas(5,1)
9608  vint(204)=pmas(23,1)
9609  IF(isub.EQ.124.OR.isub.EQ.174.OR.isub.EQ.179.OR.isub.EQ.351)
9610  & vint(204)=pmas(24,1)
9611  IF(isub.EQ.352) vint(204)=pmas(pycomp(9900024),1)
9612  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
9613  & isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402)
9614  & vint(204)=vint(201)
9615  vint(209)=vint(204)
9616  IF(isub.EQ.401.OR.isub.EQ.402) vint(209)=vint(206)
9617  ENDIF
9618 
9619 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9620  IF(istsb.NE.0.AND.(mint(101).GE.2.OR.mint(102).GE.2).AND.
9621  &(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7)) THEN
9622  vrn=pyr(0)*sigt(0,0,5)
9623  IF(mint(101).LE.1) THEN
9624  i1mn=0
9625  i1mx=0
9626  ELSE
9627  i1mn=1
9628  i1mx=mint(101)
9629  ENDIF
9630  IF(mint(102).LE.1) THEN
9631  i2mn=0
9632  i2mx=0
9633  ELSE
9634  i2mn=1
9635  i2mx=mint(102)
9636  ENDIF
9637  DO 180 i1=i1mn,i1mx
9638  kfv1=110*i1+3
9639  DO 170 i2=i2mn,i2mx
9640  kfv2=110*i2+3
9641  vrn=vrn-sigt(i1,i2,5)
9642  IF(vrn.LE.0d0) GOTO 190
9643  170 CONTINUE
9644  180 CONTINUE
9645  190 IF(mint(101).GE.2) mint(103)=kfv1
9646  IF(mint(102).GE.2) mint(104)=kfv2
9647  ENDIF
9648 
9649  IF(istsb.EQ.0) THEN
9650 C...Elastic scattering or single or double diffractive scattering.
9651 
9652 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9653  mint(103)=mint(11)
9654  mint(104)=mint(12)
9655  pmm(1)=vint(3)
9656  pmm(2)=vint(4)
9657  IF(mint(101).GE.2.OR.mint(102).GE.2) THEN
9658  jj=isub-90
9659  vrn=pyr(0)*sigt(0,0,jj)
9660  IF(mint(101).LE.1) THEN
9661  i1mn=0
9662  i1mx=0
9663  ELSE
9664  i1mn=1
9665  i1mx=mint(101)
9666  ENDIF
9667  IF(mint(102).LE.1) THEN
9668  i2mn=0
9669  i2mx=0
9670  ELSE
9671  i2mn=1
9672  i2mx=mint(102)
9673  ENDIF
9674  DO 210 i1=i1mn,i1mx
9675  kfv1=110*i1+3
9676  DO 200 i2=i2mn,i2mx
9677  kfv2=110*i2+3
9678  vrn=vrn-sigt(i1,i2,jj)
9679  IF(vrn.LE.0d0) GOTO 220
9680  200 CONTINUE
9681  210 CONTINUE
9682  220 IF(mint(101).GE.2) THEN
9683  mint(103)=kfv1
9684  pmm(1)=pymass(kfv1)
9685  ENDIF
9686  IF(mint(102).GE.2) THEN
9687  mint(104)=kfv2
9688  pmm(2)=pymass(kfv2)
9689  ENDIF
9690  ENDIF
9691  vint(67)=pmm(1)
9692  vint(68)=pmm(2)
9693 
9694 C...Select mass for GVMD states (rejecting previous assignment).
9695  q0s=4d0*parp(15)**2
9696  q1s=4d0*vint(154)**2
9697  loop3=0
9698  230 loop3=loop3+1
9699  DO 240 jt=1,2
9700  IF(mint(106+jt).EQ.3) THEN
9701  ps=vint(2+jt)**2
9702  pmm(jt)=sqrt((q0s+ps)*(q1s+ps)/
9703  & (q0s+pyr(0)*(q1s-q0s)+ps)-ps)
9704  IF(mint(102+jt).GE.333) pmm(jt)=pmm(jt)-
9705  & pmas(pycomp(113),1)+pmas(pycomp(mint(102+jt)),1)
9706  ENDIF
9707  240 CONTINUE
9708  IF(pmm(1)+pmm(2)+parp(104).GE.vint(1)) THEN
9709  IF(loop3.LT.100.AND.(mint(107).EQ.3.OR.mint(108).EQ.3))
9710  & GOTO 230
9711  GOTO 100
9712  ENDIF
9713 
9714 C...Side/sides of diffractive system.
9715  mint(17)=0
9716  mint(18)=0
9717  IF(isub.EQ.92.OR.isub.EQ.94) mint(17)=1
9718  IF(isub.EQ.93.OR.isub.EQ.94) mint(18)=1
9719 
9720 C...Find masses of particles and minimal masses of diffractive states.
9721  DO 250 jt=1,2
9722  pdif(jt)=pmm(jt)
9723  vint(68+jt)=pdif(jt)
9724  IF(mint(16+jt).EQ.1) pdif(jt)=pdif(jt)+parp(102)
9725  250 CONTINUE
9726  sh=vint(2)
9727  sqm1=pmm(1)**2
9728  sqm2=pmm(2)**2
9729  sqm3=pdif(1)**2
9730  sqm4=pdif(2)**2
9731  smres1=(pmm(1)+pmrc)**2
9732  smres2=(pmm(2)+pmrc)**2
9733 
9734 C...Find elastic slope and lower limit diffractive slope.
9735  iha=max(2,iabs(mint(103))/110)
9736  IF(iha.GE.5) iha=1
9737  ihb=max(2,iabs(mint(104))/110)
9738  IF(ihb.GE.5) ihb=1
9739  IF(isub.EQ.91) THEN
9740  bmn=2d0*bhad(iha)+2d0*bhad(ihb)+4d0*sh**eps-4.2d0
9741  ELSEIF(isub.EQ.92) THEN
9742  bmn=max(2d0,2d0*bhad(ihb))
9743  ELSEIF(isub.EQ.93) THEN
9744  bmn=max(2d0,2d0*bhad(iha))
9745  ELSEIF(isub.EQ.94) THEN
9746  bmn=2d0*alp*4d0
9747  ENDIF
9748 
9749 C...Determine maximum possible t range and coefficient of generation.
9750  sqla12=(sh-sqm1-sqm2)**2-4d0*sqm1*sqm2
9751  sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
9752  tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
9753  thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
9754  thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
9755  & (sqm1*sqm4-sqm2*sqm3)/sh
9756  thl=-0.5d0*(tha+thb)
9757  thu=thc/thl
9758  thrnd=exp(max(-50d0,bmn*(thl-thu)))-1d0
9759 
9760 C...Select diffractive mass/masses according to dm^2/m^2.
9761  loop3=0
9762  260 loop3=loop3+1
9763  DO 270 jt=1,2
9764  IF(mint(16+jt).EQ.0) THEN
9765  pdif(2+jt)=pdif(jt)
9766  ELSE
9767  pmmin=pdif(jt)
9768  pmmax=max(vint(2+jt),vint(1)-pdif(3-jt))
9769  pdif(2+jt)=pmmin*(pmmax/pmmin)**pyr(0)
9770  ENDIF
9771  270 CONTINUE
9772  sqm3=pdif(3)**2
9773  sqm4=pdif(4)**2
9774 
9775 C..Additional mass factors, including resonance enhancement.
9776  IF(pdif(3)+pdif(4).GE.vint(1)) THEN
9777  IF(loop3.LT.100) GOTO 260
9778  GOTO 100
9779  ENDIF
9780  IF(isub.EQ.92) THEN
9781  fsd=(1d0-sqm3/sh)*(1d0+cres*smres1/(smres1+sqm3))
9782  IF(fsd.LT.pyr(0)*(1d0+cres)) GOTO 260
9783  ELSEIF(isub.EQ.93) THEN
9784  fsd=(1d0-sqm4/sh)*(1d0+cres*smres2/(smres2+sqm4))
9785  IF(fsd.LT.pyr(0)*(1d0+cres)) GOTO 260
9786  ELSEIF(isub.EQ.94) THEN
9787  fdd=(1d0-(pdif(3)+pdif(4))**2/sh)*(sh*smp/
9788  & (sh*smp+sqm3*sqm4))*(1d0+cres*smres1/(smres1+sqm3))*
9789  & (1d0+cres*smres2/(smres2+sqm4))
9790  IF(fdd.LT.pyr(0)*(1d0+cres)**2) GOTO 260
9791  ENDIF
9792 
9793 C...Select t according to exp(Bmn*t) and correct to right slope.
9794  th=thu+log(1d0+thrnd*pyr(0))/bmn
9795  IF(isub.GE.92) THEN
9796  IF(isub.EQ.92) THEN
9797  badd=2d0*alp*log(sh/sqm3)
9798  IF(bhad(ihb).LT.1d0) badd=max(0d0,badd+2d0*bhad(ihb)-2d0)
9799  ELSEIF(isub.EQ.93) THEN
9800  badd=2d0*alp*log(sh/sqm4)
9801  IF(bhad(iha).LT.1d0) badd=max(0d0,badd+2d0*bhad(iha)-2d0)
9802  ELSEIF(isub.EQ.94) THEN
9803  badd=2d0*alp*(log(exp(4d0)+sh/(alp*sqm3*sqm4))-4d0)
9804  ENDIF
9805  IF(exp(max(-50d0,badd*(th-thu))).LT.pyr(0)) GOTO 260
9806  ENDIF
9807 
9808 C...Check whether m^2 and t choices are consistent.
9809  sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
9810  tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
9811  thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
9812  IF(thb.LE.1d-8) GOTO 260
9813  thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
9814  & (sqm1*sqm4-sqm2*sqm3)/sh
9815  thlm=-0.5d0*(tha+thb)
9816  thum=thc/thlm
9817  IF(th.LT.thlm.OR.th.GT.thum) GOTO 260
9818 
9819 C...Information to output.
9820  vint(21)=1d0
9821  vint(22)=0d0
9822  vint(23)=min(1d0,max(-1d0,(tha+2d0*th)/thb))
9823  vint(45)=th
9824  vint(59)=2d0*sqrt(max(0d0,-(thc+tha*th+th**2)))/thb
9825  vint(63)=pdif(3)**2
9826  vint(64)=pdif(4)**2
9827  vint(283)=pmm(1)**2/4d0
9828  vint(284)=pmm(2)**2/4d0
9829 
9830 C...Note: in the following, by In is meant the integral over the
9831 C...quantity multiplying coefficient cn.
9832 C...Choose tau according to h1(tau)/tau, where
9833 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9834 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9835 C...I1/I5*c5*1/(tau+tau_R') +
9836 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9837 C...I1/I7*c7*tau/(1.-tau), and
9838 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9839  ELSEIF(istsb.GE.1.AND.istsb.LE.5) THEN
9840  CALL pyklim(1)
9841  IF(mint(51).NE.0) THEN
9842  IF(mint(121).GT.1) CALL pysave(2,iga)
9843  IF(mfail.EQ.1) THEN
9844  msti(61)=1
9845  RETURN
9846  ENDIF
9847  GOTO 100
9848  ENDIF
9849  rtau=pyr(0)
9850  mtau=1
9851  IF(rtau.GT.coef(isub,1)) mtau=2
9852  IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3
9853  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4
9854  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4))
9855  & mtau=5
9856  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
9857  & coef(isub,5)) mtau=6
9858  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
9859  & coef(isub,5)+coef(isub,6)) mtau=7
9860 C...Additional check to handle techni-processes with extra resonance
9861 C....Only modify tau treatment
9862  IF(isub.EQ.194.OR.isub.EQ.195.OR.(isub.GE.361.AND.isub.LE.380))
9863  & THEN
9864  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)
9865  & +coef(isub,4)+coef(isub,5)+coef(isub,6)+coef(isub,7)) mtau=8
9866  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)
9867  & +coef(isub,4)+coef(isub,5)+coef(isub,6)+coef(isub,7)
9868  & +coefx(isub,1)) mtau=9
9869  ENDIF
9870  CALL pykmap(1,mtau,pyr(0))
9871 
9872 C...2 -> 3, 4 processes:
9873 C...Choose tau' according to h4(tau,tau')/tau', where
9874 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9875 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9876  IF(istsb.GE.3.AND.istsb.LE.5) THEN
9877  CALL pyklim(4)
9878  IF(mint(51).NE.0) THEN
9879  IF(mint(121).GT.1) CALL pysave(2,iga)
9880  IF(mfail.EQ.1) THEN
9881  msti(61)=1
9882  RETURN
9883  ENDIF
9884  GOTO 100
9885  ENDIF
9886  rtaup=pyr(0)
9887  mtaup=1
9888  IF(rtaup.GT.coef(isub,18)) mtaup=2
9889  IF(rtaup.GT.coef(isub,18)+coef(isub,19)) mtaup=3
9890  CALL pykmap(4,mtaup,pyr(0))
9891  ENDIF
9892 
9893 C...Choose y* according to h2(y*), where
9894 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9895 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9896 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9897 C...and c1 + c2 + c3 + c4 + c5 = 1.
9898  CALL pyklim(2)
9899  IF(mint(51).NE.0) THEN
9900  IF(mint(121).GT.1) CALL pysave(2,iga)
9901  IF(mfail.EQ.1) THEN
9902  msti(61)=1
9903  RETURN
9904  ENDIF
9905  GOTO 100
9906  ENDIF
9907  ryst=pyr(0)
9908  myst=1
9909  IF(ryst.GT.coef(isub,8)) myst=2
9910  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
9911  IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)) myst=4
9912  IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)+
9913  & coef(isub,11)) myst=5
9914  CALL pykmap(2,myst,pyr(0))
9915 
9916 C...2 -> 2 processes:
9917 C...Choose cos(theta-hat) (cth) according to h3(cth), where
9918 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9919 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9920 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9921 C...and c0 + c1 + c2 + c3 + c4 = 1.
9922  CALL pyklim(3)
9923  IF(mint(51).NE.0) THEN
9924  IF(mint(121).GT.1) CALL pysave(2,iga)
9925  IF(mfail.EQ.1) THEN
9926  msti(61)=1
9927  RETURN
9928  ENDIF
9929  GOTO 100
9930  ENDIF
9931  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
9932  rcth=pyr(0)
9933  mcth=1
9934  IF(rcth.GT.coef(isub,13)) mcth=2
9935  IF(rcth.GT.coef(isub,13)+coef(isub,14)) mcth=3
9936  IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)) mcth=4
9937  IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)+
9938  & coef(isub,16)) mcth=5
9939  CALL pykmap(3,mcth,pyr(0))
9940  ENDIF
9941 
9942 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9943  IF(istsb.EQ.5) THEN
9944  CALL pykmap(5,0,0d0)
9945  IF(mint(51).NE.0) THEN
9946  IF(mint(121).GT.1) CALL pysave(2,iga)
9947  IF(mfail.EQ.1) THEN
9948  msti(61)=1
9949  RETURN
9950  ENDIF
9951  GOTO 100
9952  ENDIF
9953  ENDIF
9954 
9955 C...DIS as f + gamma* -> f process: set dummy values.
9956  ELSEIF(istsb.EQ.8) THEN
9957  vint(21)=0.9d0
9958  vint(22)=0d0
9959  vint(23)=0d0
9960  vint(47)=0d0
9961  vint(48)=0d0
9962 
9963 C...Low-pT or multiple interactions (first semihard interaction).
9964  ELSEIF(istsb.EQ.9) THEN
9965  IF(mint(35).LE.1) CALL pymult(3)
9966  IF(mint(35).GE.2) CALL pymign(3)
9967  isub=mint(1)
9968 
9969 C...Study user-defined process: kinematics plus weight.
9970  ELSEIF(istsb.EQ.11) THEN
9971  IF(idwtup.GT.0.AND.xwgtup.LT.0d0) call
9972  & pyerrm(26,'(PYRAND:) Negative XWGTUP for user process')
9973  msti(51)=0
9974  IF(nup.LE.0) THEN
9975  mint(51)=2
9976  msti(51)=1
9977  IF(mint(82).EQ.1) THEN
9978  ngen(0,1)=ngen(0,1)-1
9979  ngen(isub,1)=ngen(isub,1)-1
9980  ENDIF
9981  IF(mint(121).GT.1) CALL pysave(2,iga)
9982  RETURN
9983  ENDIF
9984 
9985 C...Extract cross section event weight.
9986  IF(iabs(idwtup).EQ.1.OR.iabs(idwtup).EQ.4) THEN
9987  sigs=1d-9*xwgtup
9988  ELSE
9989  sigs=1d-9*xsecup(kfpr(isub,1))
9990  ENDIF
9991  IF(iabs(idwtup).GE.1.AND.iabs(idwtup).LE.3) THEN
9992  vint(97)=sign(1d0,xwgtup)
9993  ELSE
9994  vint(97)=1d-9*xwgtup
9995  ENDIF
9996 
9997 C...Construct 'trivial' kinematical variables needed.
9998  kfl1=idup(1)
9999  kfl2=idup(2)
10000  vint(41)=pup(4,1)/ebmup(1)
10001  vint(42)=pup(4,2)/ebmup(2)
10002  IF (vint(41).GT.1.000001.OR.vint(42).GT.1.000001) THEN
10003  CALL pyerrm(9,'(PYRAND:) x > 1 in external event '//
10004  & '(listing follows):')
10005  CALL pylist(7)
10006  ENDIF
10007  vint(21)=vint(41)*vint(42)
10008  vint(22)=0.5d0*log(vint(41)/vint(42))
10009  vint(44)=vint(21)*vint(2)
10010  vint(43)=sqrt(max(0d0,vint(44)))
10011  vint(55)=scalup
10012  IF(scalup.LE.0d0) vint(55)=vint(43)
10013  vint(56)=vint(55)**2
10014  vint(57)=aqedup
10015  vint(58)=aqcdup
10016 
10017 C...Construct other kinematical variables needed (approximately).
10018  vint(23)=0d0
10019  vint(26)=vint(21)
10020  vint(45)=-0.5d0*vint(44)
10021  vint(46)=-0.5d0*vint(44)
10022  vint(49)=vint(43)
10023  vint(50)=vint(44)
10024  vint(51)=vint(55)
10025  vint(52)=vint(56)
10026  vint(53)=vint(55)
10027  vint(54)=vint(56)
10028  vint(25)=0d0
10029  vint(48)=0d0
10030  IF(istup(1).NE.-1.OR.istup(2).NE.-1) CALL pyerrm(26,
10031  & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10032  DO 280 iup=3,nup
10033  IF(istup(iup).LT.1.OR.istup(iup).GT.3) CALL pyerrm(26,
10034  & '(PYRAND:) unacceptable ISTUP code for particles')
10035  IF(istup(iup).EQ.1) vint(25)=vint(25)+2d0*(pup(5,iup)**2+
10036  & pup(1,iup)**2+pup(2,iup)**2)/vint(2)
10037  IF(istup(iup).EQ.1) vint(48)=vint(48)+0.5d0*(pup(1,iup)**2+
10038  & pup(2,iup)**2)
10039  280 CONTINUE
10040  vint(47)=sqrt(vint(48))
10041  ENDIF
10042 
10043 C...Choose azimuthal angle.
10044  vint(24)=0d0
10045  IF(istsb.NE.11) vint(24)=paru(2)*pyr(0)
10046 
10047 C...Check against user cuts on kinematics at parton level.
10048  mint(51)=0
10049  IF((isub.LE.90.OR.isub.GT.100).AND.istsb.LE.10) CALL pyklim(0)
10050  IF(mint(51).NE.0) THEN
10051  IF(mint(121).GT.1) CALL pysave(2,iga)
10052  IF(mfail.EQ.1) THEN
10053  msti(61)=1
10054  RETURN
10055  ENDIF
10056  GOTO 100
10057  ENDIF
10058  IF(mint(82).EQ.1.AND.mstp(141).GE.1.AND.istsb.LE.10) THEN
10059  mcut=0
10060  IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)
10061  & CALL pykcut(mcut)
10062  IF(mcut.NE.0) THEN
10063  IF(mint(121).GT.1) CALL pysave(2,iga)
10064  IF(mfail.EQ.1) THEN
10065  msti(61)=1
10066  RETURN
10067  ENDIF
10068  GOTO 100
10069  ENDIF
10070  ENDIF
10071 
10072 C...Calculate differential cross-section for different subprocesses.
10073  IF(istsb.LE.10) CALL pysigh(nchn,sigs)
10074  sigsor=sigs
10075  siglpt=sigt(0,0,5)*vint(315)*vint(316)
10076 
10077 C...Multiply cross section by lepton -> photon flux factor.
10078  IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
10079  sigs=wtgaga*sigs
10080  DO 290 ichn=1,nchn
10081  sigh(ichn)=wtgaga*sigh(ichn)
10082  290 CONTINUE
10083  siglpt=wtgaga*siglpt
10084  ENDIF
10085 
10086 C...Multiply cross-section by user-defined weights.
10087  IF(mstp(173).EQ.1) THEN
10088  sigs=parp(173)*sigs
10089  DO 300 ichn=1,nchn
10090  sigh(ichn)=parp(173)*sigh(ichn)
10091  300 CONTINUE
10092  siglpt=parp(173)*siglpt
10093  ENDIF
10094  wtxs=1d0
10095  sigswt=sigs
10096  vint(99)=1d0
10097  vint(100)=1d0
10098  IF(mint(82).EQ.1.AND.mstp(142).GE.1) THEN
10099  IF(isub.NE.96.AND.msub(91)+msub(92)+msub(93)+msub(94)+
10100  & msub(95).EQ.0) CALL pyevwt(wtxs)
10101  sigswt=wtxs*sigs
10102  vint(99)=wtxs
10103  IF(mstp(142).EQ.1) vint(100)=1d0/wtxs
10104  ENDIF
10105 
10106 C...Calculations for Monte Carlo estimate of all cross-sections.
10107  IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN
10108  IF(mstp(142).LE.1) THEN
10109  xsec(isub,2)=xsec(isub,2)+sigs
10110  ELSE
10111  xsec(isub,2)=xsec(isub,2)+sigswt
10112  ENDIF
10113  ELSEIF(mint(82).EQ.1) THEN
10114  xsec(isub,2)=xsec(isub,2)+sigs
10115  ENDIF
10116  IF((isub.EQ.95.OR.isub.EQ.96).AND.loop2.EQ.1.AND.
10117  &mint(82).EQ.1) xsec(97,2)=xsec(97,2)+siglpt
10118 
10119 C...Multiple interactions: store results of cross-section calculation.
10120  IF(mint(50).EQ.1.AND.mstp(82).GE.3) THEN
10121  vint(153)=sigsor
10122  IF(mint(35).LE.1) CALL pymult(4)
10123  IF(mint(35).GE.2) CALL pymign(4)
10124  ENDIF
10125 
10126 C...Ratio of actual to maximum cross section.
10127  IF(istsb.NE.11) THEN
10128  viol=sigswt/xsec(isub,1)
10129  IF(isub.EQ.96.AND.mstp(173).EQ.1) viol=viol/parp(174)
10130  ELSEIF(idwtup.EQ.1.OR.idwtup.EQ.2) THEN
10131  viol=xwgtup/xmaxup(kfpr(isub,1))
10132  ELSEIF(idwtup.EQ.-1.OR.idwtup.EQ.-2) THEN
10133  viol=abs(xwgtup)/abs(xmaxup(kfpr(isub,1)))
10134  ELSE
10135  viol=1d0
10136  ENDIF
10137 
10138 C...Check that weight not negative.
10139  IF(mstp(123).LE.0) THEN
10140  IF(viol.LT.-1d-3) THEN
10141  WRITE(mstu(11),5000) viol,ngen(0,3)+1
10142  IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
10143  & vint(22),vint(23),vint(26)
10144  CALL pystop(2)
10145  ENDIF
10146  ELSE
10147  IF(viol.LT.min(-1d-3,vint(109))) THEN
10148  vint(109)=viol
10149  IF(mstp(123).LE.2) WRITE(mstu(11),5200) viol,ngen(0,3)+1
10150  IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
10151  & vint(22),vint(23),vint(26)
10152  ENDIF
10153  ENDIF
10154 
10155 C...Weighting using estimate of maximum of differential cross-section.
10156  ratnd=1d0
10157  IF(mfail.EQ.0.AND.isub.NE.95.AND.isub.NE.96) THEN
10158  IF(viol.LT.pyr(0)) THEN
10159  IF(mint(121).GT.1) CALL pysave(2,iga)
10160  IF(isub.GE.91.AND.isub.LE.94) isub=0
10161  GOTO 100
10162  ENDIF
10163  ELSEIF(mfail.EQ.0) THEN
10164  ratnd=siglpt/xsec(95,1)
10165  viol=viol/ratnd
10166  IF(loop2.EQ.1.AND.ratnd.LT.pyr(0)) THEN
10167  IF(viol.GT.pyr(0).AND.mint(82).EQ.1.AND.msub(95).EQ.1.AND.
10168  & (isub.LE.90.OR.isub.GE.95)) ngen(95,1)=ngen(95,1)+mint(143)
10169  IF(mint(121).GT.1) CALL pysave(2,iga)
10170  isub=0
10171  GOTO 100
10172  ENDIF
10173  IF(viol.LT.pyr(0)) THEN
10174  GOTO 140
10175  ENDIF
10176  ELSEIF(isub.NE.95.AND.isub.NE.96) THEN
10177  IF(viol.LT.pyr(0)) THEN
10178  msti(61)=1
10179  IF(mint(121).GT.1) CALL pysave(2,iga)
10180  RETURN
10181  ENDIF
10182  ELSE
10183  ratnd=siglpt/xsec(95,1)
10184  IF(loop.EQ.1.AND.ratnd.LT.pyr(0)) THEN
10185  msti(61)=1
10186  IF(mint(121).GT.1) CALL pysave(2,iga)
10187  RETURN
10188  ENDIF
10189  viol=viol/ratnd
10190  IF(viol.LT.pyr(0)) THEN
10191  IF(mint(121).GT.1) CALL pysave(2,iga)
10192  GOTO 100
10193  ENDIF
10194  ENDIF
10195 
10196 C...Check for possible violation of estimated maximum of differential
10197 C...cross-section used in weighting.
10198  IF(mstp(123).LE.0) THEN
10199  IF(viol.GT.1d0) THEN
10200  WRITE(mstu(11),5300) viol,ngen(0,3)+1
10201  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10202  & vint(22),vint(23),vint(26)
10203  CALL pystop(2)
10204  ENDIF
10205  ELSEIF(mstp(123).EQ.1) THEN
10206  IF(viol.GT.vint(108)) THEN
10207  vint(108)=viol
10208  IF(viol.GT.1.0001d0) THEN
10209  mint(10)=1
10210  WRITE(mstu(11),5400) viol,ngen(0,3)+1
10211  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10212  & vint(22),vint(23),vint(26)
10213  ENDIF
10214  ENDIF
10215  ELSEIF(viol.GT.vint(108)) THEN
10216  vint(108)=viol
10217  IF(viol.GT.1d0) THEN
10218  mint(10)=1
10219  IF(mstp(123).EQ.2) WRITE(mstu(11),5400) viol,ngen(0,3)+1
10220  IF(istsb.EQ.11.AND.(iabs(idwtup).EQ.1.OR.iabs(idwtup).EQ.2))
10221  & THEN
10222  xmaxup(kfpr(isub,1))=viol*xmaxup(kfpr(isub,1))
10223  IF(kfpr(isub,1).LE.9) THEN
10224  IF(mstp(123).EQ.2) WRITE(mstu(11),5800) kfpr(isub,1),
10225  & xmaxup(kfpr(isub,1))
10226  ELSEIF(kfpr(isub,1).LE.99) THEN
10227  IF(mstp(123).EQ.2) WRITE(mstu(11),5900) kfpr(isub,1),
10228  & xmaxup(kfpr(isub,1))
10229  ELSE
10230  IF(mstp(123).EQ.2) WRITE(mstu(11),6000) kfpr(isub,1),
10231  & xmaxup(kfpr(isub,1))
10232  ENDIF
10233  ENDIF
10234  IF(istsb.NE.11.OR.iabs(idwtup).EQ.1) THEN
10235  xdif=xsec(isub,1)*(viol-1d0)
10236  xsec(isub,1)=xsec(isub,1)+xdif
10237  IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))
10238  & xsec(0,1)=xsec(0,1)+xdif
10239  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10240  & vint(22),vint(23),vint(26)
10241  IF(isub.LE.9) THEN
10242  IF(mstp(123).EQ.2) WRITE(mstu(11),5500) isub,xsec(isub,1)
10243  ELSEIF(isub.LE.99) THEN
10244  IF(mstp(123).EQ.2) WRITE(mstu(11),5600) isub,xsec(isub,1)
10245  ELSE
10246  IF(mstp(123).EQ.2) WRITE(mstu(11),5700) isub,xsec(isub,1)
10247  ENDIF
10248  ENDIF
10249  vint(108)=1d0
10250  ENDIF
10251  ENDIF
10252 
10253 C...Multiple interactions: choose impact parameter (if not already done).
10254  IF(mint(39).EQ.0) vint(148)=1d0
10255  IF(mint(50).EQ.1.AND.(isub.LE.90.OR.isub.GE.96).AND.
10256  &mstp(82).GE.3) THEN
10257  IF(mint(35).LE.1) CALL pymult(5)
10258  IF(mint(35).GE.2) CALL pymign(5)
10259  IF(vint(150).LT.pyr(0)) THEN
10260  IF(mint(121).GT.1) CALL pysave(2,iga)
10261  IF(mfail.EQ.1) THEN
10262  msti(61)=1
10263  RETURN
10264  ENDIF
10265  GOTO 100
10266  ENDIF
10267  ENDIF
10268  IF(mint(82).EQ.1) ngen(0,2)=ngen(0,2)+1
10269  IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN
10270  IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+mint(143)
10271  IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1
10272  ENDIF
10273  IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1
10274 
10275 C...Choose flavour of reacting partons (and subprocess).
10276  IF(istsb.GE.11) GOTO 320
10277  rsigs=sigs*pyr(0)
10278  qt2=vint(48)
10279  rqqbar=parp(87)*(1d0-(qt2/(qt2+(parp(88)*parp(82)*
10280  &(vint(1)/parp(89))**parp(90))**2))**2)
10281  IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.
10282  &pyr(0).GT.rqqbar)) THEN
10283  DO 310 ichn=1,nchn
10284  kfl1=isig(ichn,1)
10285  kfl2=isig(ichn,2)
10286  mint(2)=isig(ichn,3)
10287  rsigs=rsigs-sigh(ichn)
10288  IF(rsigs.LE.0d0) GOTO 320
10289  310 CONTINUE
10290 
10291 C...Multiple interactions: choose qqbar preferentially at small pT.
10292  ELSEIF(isub.EQ.96) THEN
10293  mint(105)=mint(103)
10294  mint(109)=mint(107)
10295  CALL pyspli(mint(11),21,kfl1,kfldum)
10296  mint(105)=mint(104)
10297  mint(109)=mint(108)
10298  CALL pyspli(mint(12),21,kfl2,kfldum)
10299  mint(1)=11
10300  mint(2)=1
10301  IF(kfl1.EQ.kfl2.AND.pyr(0).LT.0.5d0) mint(2)=2
10302 
10303 C...Low-pT: choose string drawing configuration.
10304  ELSE
10305  kfl1=21
10306  kfl2=21
10307  rsigs=6d0*pyr(0)
10308  mint(2)=1
10309  IF(rsigs.GT.1d0) mint(2)=2
10310  IF(rsigs.GT.2d0) mint(2)=3
10311  ENDIF
10312 
10313 C...Reassign QCD process. Partons before initial state radiation.
10314  320 IF(mint(2).GT.10) THEN
10315  mint(1)=mint(2)/10
10316  mint(2)=mod(mint(2),10)
10317  ENDIF
10318  IF(mint(82).EQ.1.AND.mstp(111).GE.0) ngen(mint(1),2)=
10319  &ngen(mint(1),2)+1
10320  mint(15)=kfl1
10321  mint(16)=kfl2
10322  mint(13)=mint(15)
10323  mint(14)=mint(16)
10324  vint(141)=vint(41)
10325  vint(142)=vint(42)
10326  vint(151)=0d0
10327  vint(152)=0d0
10328 
10329 C...Calculate x value of photon for parton inside photon inside e.
10330  DO 350 jt=1,2
10331  mint(18+jt)=0
10332  vint(154+jt)=0d0
10333  mspli=0
10334  IF(jt.EQ.1.AND.mint(43).LE.2) mspli=1
10335  IF(jt.EQ.2.AND.mod(mint(43),2).EQ.1) mspli=1
10336  IF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) mspli=mspli+1
10337  IF(mspli.EQ.2) THEN
10338  kflh=mint(14+jt)
10339  xhrd=vint(140+jt)
10340  q2hrd=vint(54)
10341  mint(105)=mint(102+jt)
10342  mint(109)=mint(106+jt)
10343  vint(120)=vint(2+jt)
10344  IF(mstp(57).LE.1) THEN
10345  CALL pypdfu(22,xhrd,q2hrd,xpq)
10346  ELSE
10347  CALL pypdfl(22,xhrd,q2hrd,xpq)
10348  ENDIF
10349  wtmx=4d0*xpq(kflh)
10350  IF(mstp(13).EQ.2) THEN
10351  q2pms=q2hrd/pmas(11,1)**2
10352  wtmx=wtmx*log(max(2d0,q2pms*(1d0-xhrd)/xhrd**2))
10353  ENDIF
10354  330 xe=xhrd**pyr(0)
10355  xg=min(1d0-1d-10,xhrd/xe)
10356  IF(mstp(57).LE.1) THEN
10357  CALL pypdfu(22,xg,q2hrd,xpq)
10358  ELSE
10359  CALL pypdfl(22,xg,q2hrd,xpq)
10360  ENDIF
10361  wt=(1d0+(1d0-xe)**2)*xpq(kflh)
10362  IF(mstp(13).EQ.2) wt=wt*log(max(2d0,q2pms*(1d0-xe)/xe**2))
10363  IF(wt.LT.pyr(0)*wtmx) GOTO 330
10364  mint(18+jt)=1
10365  vint(154+jt)=xe
10366  DO 340 kfls=-25,25
10367  xsfx(jt,kfls)=xpq(kfls)
10368  340 CONTINUE
10369  ENDIF
10370  350 CONTINUE
10371 
10372 C...Pick scale where photon is resolved.
10373  q0s=parp(15)**2
10374  q1s=vint(154)**2
10375  vint(283)=0d0
10376  IF(mint(107).EQ.3) THEN
10377  IF(mstp(66).EQ.1) THEN
10378  vint(283)=q0s*(vint(54)/q0s)**pyr(0)
10379  ELSEIF(mstp(66).EQ.2) THEN
10380  ps=vint(3)**2
10381  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10382  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10383  q2int=sqrt(q0s*q2eff)
10384  vint(283)=q2int*(vint(54)/q2int)**pyr(0)
10385  ELSEIF(mstp(66).EQ.3) THEN
10386  vint(283)=q0s*(q1s/q0s)**pyr(0)
10387  ELSEIF(mstp(66).GE.4) THEN
10388  ps=0.25d0*vint(3)**2
10389  vint(283)=(q0s+ps)*(q1s+ps)/
10390  & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
10391  ENDIF
10392  ENDIF
10393  vint(284)=0d0
10394  IF(mint(108).EQ.3) THEN
10395  IF(mstp(66).EQ.1) THEN
10396  vint(284)=q0s*(vint(54)/q0s)**pyr(0)
10397  ELSEIF(mstp(66).EQ.2) THEN
10398  ps=vint(4)**2
10399  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10400  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10401  q2int=sqrt(q0s*q2eff)
10402  vint(284)=q2int*(vint(54)/q2int)**pyr(0)
10403  ELSEIF(mstp(66).EQ.3) THEN
10404  vint(284)=q0s*(q1s/q0s)**pyr(0)
10405  ELSEIF(mstp(66).GE.4) THEN
10406  ps=0.25d0*vint(4)**2
10407  vint(284)=(q0s+ps)*(q1s+ps)/
10408  & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
10409  ENDIF
10410  ENDIF
10411  IF(mint(121).GT.1) CALL pysave(2,iga)
10412 
10413 C...Format statements for differential cross-section maximum violations.
10414  5000 FORMAT(/1x,'Error: negative cross-section fraction',1p,d11.3,1x,
10415  &'in event',1x,i7,'D0'/1x,'Execution stopped!')
10416  5100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p,
10417  &d11.3,', y* =',d11.3,', cthe = ',0p,f11.7,', tau'' =',1p,d11.3)
10418  5200 FORMAT(/1x,'Warning: negative cross-section fraction',1p,d11.3,1x,
10419  &'in event',1x,i7)
10420  5300 FORMAT(/1x,'Error: maximum violated by',1p,d11.3,1x,
10421  &'in event',1x,i7,'D0'/1x,'Execution stopped!')
10422  5400 FORMAT(/1x,'Advisory warning: maximum violated by',1p,d11.3,1x,
10423  &'in event',1x,i7)
10424  5500 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,d11.3)
10425  5600 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,d11.3)
10426  5700 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,d11.3)
10427  5800 FORMAT(1x,'XMAXUP(',i1,') increased to',1p,d11.3)
10428  5900 FORMAT(1x,'XMAXUP(',i2,') increased to',1p,d11.3)
10429  6000 FORMAT(1x,'XMAXUP(',i3,') increased to',1p,d11.3)
10430 
10431  RETURN
10432  END
10433 
10434 C*********************************************************************
10435 
10436 C...PYSCAT
10437 C...Finds outgoing flavours and event type; sets up the kinematics
10438 C...and colour flow of the hard scattering
10439 
10440  SUBROUTINE pyscat
10441 
10442 C...Double precision and integer declarations
10443  IMPLICIT DOUBLE PRECISION(a-h, o-z)
10444  IMPLICIT INTEGER(I-N)
10445  INTEGER PYK,PYCHGE,PYCOMP
10446 C...Parameter statement to help give large particle numbers.
10447  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
10448  &kexcit=4000000,kdimen=5000000)
10449 C...Parameter statement for maximum size of showers.
10450  parameter(maxnur=1000)
10451 
10452 C...User process event common block.
10453  INTEGER MAXNUP
10454  parameter(maxnup=500)
10455  INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10456  DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10457  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
10458  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
10459  &vtimup(maxnup),spinup(maxnup)
10460  SAVE /hepeup/
10461 
10462 C...Commonblocks.
10463  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
10464  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10465  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
10466  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
10467  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
10468  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
10469  common/pypars/mstp(200),parp(200),msti(200),pari(200)
10470  common/pyint1/mint(400),vint(400)
10471  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
10472  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
10473  common/pyint4/mwid(500),wids(500,5)
10474  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
10475  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
10476  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
10477  common/pytcsm/itcm(0:99),rtcm(0:99)
10478  common/pypued/iued(0:99),rued(0:99)
10479  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,
10480  &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyssmt/,
10481  &/pytcsm/,/pypued/
10482 C...Local arrays and saved variables
10483  dimension wdtp(0:400),wdte(0:400,0:5),pmq(2),z(2),cthe(2),
10484  &phi(2),kuppo(100),vintsv(41:66),ilab(100)
10485  INTEGER IOKFLA(6),IIFLAV
10486 C...UED related declarations:
10487 C...equivalences between ordered particles (451->475)
10488 C...and UED particle code (5 000 000 + id)
10489  dimension iuedeq(475),mued(2)
10490  DATA (iuedeq(i),i=451,475)/
10491  & 6100001,6100002,6100003,6100004,6100005,6100006,
10492  & 5100001,5100002,5100003,5100004,5100005,5100006,
10493  & 6100011,6100013,6100015,
10494  & 5100012,5100011,5100014,5100013,5100016,5100015,
10495  & 5100021,5100022,5100023,5100024/
10496  SAVE vintsv
10497 
10498 C...Read out process
10499  isub=mint(1)
10500  isubsv=isub
10501 
10502 C...Restore information for low-pT processes
10503  IF(isub.EQ.95.AND.mint(57).GE.1) THEN
10504  DO 100 j=41,66
10505  100 vint(j)=vintsv(j)
10506  ENDIF
10507 
10508 C...Convert H' or A process into equivalent H one
10509  ihigg=1
10510  kfhigg=25
10511  IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
10512  &isub.LE.190)) THEN
10513  ihigg=2
10514  IF(mod(isub-1,10).GE.5) ihigg=3
10515  kfhigg=33+ihigg
10516  IF(isub.EQ.151.OR.isub.EQ.156) isub=3
10517  IF(isub.EQ.152.OR.isub.EQ.157) isub=102
10518  IF(isub.EQ.153.OR.isub.EQ.158) isub=103
10519  IF(isub.EQ.171.OR.isub.EQ.176) isub=24
10520  IF(isub.EQ.172.OR.isub.EQ.177) isub=26
10521  IF(isub.EQ.173.OR.isub.EQ.178) isub=123
10522  IF(isub.EQ.174.OR.isub.EQ.179) isub=124
10523  IF(isub.EQ.181.OR.isub.EQ.186) isub=121
10524  IF(isub.EQ.182.OR.isub.EQ.187) isub=122
10525  IF(isub.EQ.183.OR.isub.EQ.188) isub=111
10526  IF(isub.EQ.184.OR.isub.EQ.189) isub=112
10527  IF(isub.EQ.185.OR.isub.EQ.190) isub=113
10528  ENDIF
10529 
10530  IF(isub.EQ.401.OR.isub.EQ.402) kfhigg=kfpr(isub,1)
10531 
10532 C...Convert bottomonium process into equivalent charmonium ones.
10533  IF(isub.GE.461.AND.isub.LE.479) isub=isub-40
10534 
10535 C...Choice of subprocess, number of documentation lines
10536  idoc=6+iset(isub)
10537  IF(isub.EQ.95) idoc=8
10538  IF(iset(isub).EQ.5) idoc=9
10539  IF(iset(isub).EQ.11) idoc=4+nup
10540  mint(3)=idoc-6
10541  IF(idoc.GE.9.AND.iset(isub).LE.4) idoc=idoc+2
10542  mint(4)=idoc
10543  ipu1=mint(84)+1
10544  ipu2=mint(84)+2
10545  ipu3=mint(84)+3
10546  ipu4=mint(84)+4
10547  ipu5=mint(84)+5
10548  ipu6=mint(84)+6
10549 
10550 C...Reset K, P and V vectors. Store incoming particles
10551  DO 120 jt=1,mstp(126)+100
10552  i=mint(83)+jt
10553  IF(i.GT.mstu(4)) GOTO 120
10554  DO 110 j=1,5
10555  k(i,j)=0
10556  p(i,j)=0d0
10557  v(i,j)=0d0
10558  110 CONTINUE
10559  120 CONTINUE
10560  DO 140 jt=1,2
10561  i=mint(83)+jt
10562  k(i,1)=21
10563  k(i,2)=mint(10+jt)
10564  DO 130 j=1,5
10565  p(i,j)=vint(285+5*jt+j)
10566  130 CONTINUE
10567  140 CONTINUE
10568  mint(6)=2
10569  kfres=0
10570 
10571 C...Store incoming partons in their CM-frame. Save pdf value.
10572  sh=vint(44)
10573  shr=sqrt(sh)
10574  shp=vint(26)*vint(2)
10575  shpr=sqrt(shp)
10576  shuser=shr
10577  IF(iset(isub).GE.3.AND.iset(isub).LE.5) shuser=shpr
10578  DO 150 jt=1,2
10579  i=mint(84)+jt
10580  k(i,1)=14
10581  k(i,2)=mint(14+jt)
10582  k(i,3)=mint(83)+2+jt
10583  p(i,3)=0.5d0*shuser*(-1d0)**(jt-1)
10584  p(i,4)=0.5d0*shuser
10585  vint(38+jt)=xsfx(jt,mint(14+jt))
10586  150 CONTINUE
10587 
10588 C...Copy incoming partons to documentation lines
10589  DO 170 jt=1,2
10590  i1=mint(83)+4+jt
10591  i2=mint(84)+jt
10592  k(i1,1)=21
10593  k(i1,2)=k(i2,2)
10594  k(i1,3)=i1-2
10595  DO 160 j=1,5
10596  p(i1,j)=p(i2,j)
10597  160 CONTINUE
10598  170 CONTINUE
10599 
10600 C...Choose new quark/lepton flavour for relevant annihilation graphs
10601  IF(isub.EQ.12.OR.isub.EQ.53.OR.isub.EQ.54.OR.isub.EQ.58.OR.
10602  &isub.EQ.314.OR.isub.EQ.319.OR.isub.EQ.316.OR.
10603  &(isub.GE.135.AND.isub.LE.140).OR.isub.EQ.382.OR.isub.EQ.385) THEN
10604  iglga=21
10605  IF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) iglga=22
10606  CALL pywidt(iglga,sh,wdtp,wdte)
10607  180 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
10608  DO 190 i=1,mdcy(iglga,3)
10609  kflf=kfdp(i+mdcy(iglga,2)-1,1)
10610  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
10611  IF(rkfl.LE.0d0) GOTO 200
10612  190 CONTINUE
10613  200 CONTINUE
10614  IF((isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319
10615  & .OR.isub.EQ.316).AND.mint(2).LE.2) THEN
10616  IF(kflf.GE.4) GOTO 180
10617  ELSEIF((isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319.
10618  & or.isub.EQ.316).AND.mint(2).LE.4) THEN
10619  kflf=4
10620  mint(2)=mint(2)-2
10621  ELSEIF(isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319.
10622  & or.isub.EQ.316) THEN
10623  kflf=5
10624  mint(2)=mint(2)-4
10625  ELSEIF(isub.EQ.382.AND.itcm(5).EQ.1.AND.iabs(mint(15)).LE.2
10626  & .AND.iabs(kflf).GE.3) THEN
10627  facqqb=vint(58)**2*4d0/9d0*(vint(45)**2+vint(46)**2)/
10628  & vint(44)**2
10629  faccib=vint(46)**2/rtcm(41)**4
10630  IF(facqqb/(facqqb+faccib).LT.pyr(0)) GOTO 180
10631  ELSEIF(isub.EQ.382.AND.itcm(5).EQ.5.AND.mint(2).EQ.2) THEN
10632  kflf=5
10633  mint(2)=1
10634  ELSEIF(isub.EQ.382.AND.itcm(5).EQ.5.AND.mint(2).EQ.1) THEN
10635  IF(kflf.EQ.5) GOTO 180
10636  ELSEIF(isub.EQ.54.OR.isub.EQ.135.OR.isub.EQ.136) THEN
10637  IF((kchg(pycomp(kflf),1)/2d0)**2.LT.pyr(0)) GOTO 180
10638  ELSEIF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) THEN
10639  IF((kchg(pycomp(kflf),1)/3d0)**2.LT.pyr(0)) GOTO 180
10640  ENDIF
10641  ENDIF
10642 
10643 C...Final state flavours and colour flow: default values
10644  js=1
10645  mint(21)=mint(15)
10646  mint(22)=mint(16)
10647  mint(23)=0
10648  mint(24)=0
10649  kcc=20
10650  kcs=isign(1,mint(15))
10651 
10652  IF(iset(isub).EQ.11) THEN
10653 C...User-defined processes: find products
10654  mint(3)=0
10655  DO 210 iup=3,nup
10656  IF(istup(iup).LT.1.OR.istup(iup).GT.3) THEN
10657  ELSEIF(nup.EQ.5.AND.iup.GE.4.AND.mothup(1,4).EQ.3) THEN
10658  mint(21+iup)=idup(iup)
10659  ELSEIF(istup(iup).EQ.1.AND.(istup(mothup(1,iup)).EQ.2.OR.
10660  & istup(mothup(1,iup)).EQ.3).AND.idup(mothup(1,iup)).NE.0) THEN
10661  ELSEIF(idup(iup).EQ.0) THEN
10662  ELSE
10663  mint(3)=mint(3)+1
10664  IF(mint(3).LE.6) mint(20+mint(3))=idup(iup)
10665  ENDIF
10666  210 CONTINUE
10667 
10668  ELSEIF(isub.LE.10) THEN
10669  IF(isub.EQ.1) THEN
10670 C...f + fbar -> gamma*/Z0
10671  kfres=23
10672 
10673  ELSEIF(isub.EQ.2) THEN
10674 C...f + fbar' -> W+/-
10675  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10676  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10677  kfres=isign(24,kch1+kch2)
10678 
10679  ELSEIF(isub.EQ.3) THEN
10680 C...f + fbar -> h0 (or H0, or A0)
10681  kfres=kfhigg
10682 
10683  ELSEIF(isub.EQ.4) THEN
10684 C...gamma + W+/- -> W+/-
10685 
10686  ELSEIF(isub.EQ.5) THEN
10687 C...Z0 + Z0 -> h0
10688  xh=sh/shp
10689  mint(21)=mint(15)
10690  mint(22)=mint(16)
10691  pmq(1)=pymass(mint(21))
10692  pmq(2)=pymass(mint(22))
10693  220 jt=int(1.5d0+pyr(0))
10694  zmin=2d0*pmq(jt)/shpr
10695  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
10696  & (shpr*(shpr-pmq(3-jt)))
10697  zmax=min(1d0-xh,zmax)
10698  z(jt)=zmin+(zmax-zmin)*pyr(0)
10699  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
10700  & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 220
10701  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
10702  IF(sqc1.LT.1d-8) GOTO 220
10703  c1=sqrt(sqc1)
10704  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
10705  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10706  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
10707  z(3-jt)=1d0-xh/(1d0-z(jt))
10708  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
10709  IF(sqc1.LT.1d-8) GOTO 220
10710  c1=sqrt(sqc1)
10711  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
10712  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10713  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
10714  phir=paru(2)*pyr(0)
10715  cphi=cos(phir)
10716  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
10717  & sqrt(1d0-cthe(2)**2)*cphi
10718  z1=2d0-z(jt)
10719  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
10720  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
10721  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
10722  & pmq(3-jt)**2/shp))
10723  zmin=2d0*pmq(3-jt)/shpr
10724  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
10725  zmax=min(1d0-xh,zmax)
10726  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 220
10727  kcc=22
10728  kfres=25
10729 
10730  ELSEIF(isub.EQ.6) THEN
10731 C...Z0 + W+/- -> W+/-
10732 
10733  ELSEIF(isub.EQ.7) THEN
10734 C...W+ + W- -> Z0
10735 
10736  ELSEIF(isub.EQ.8) THEN
10737 C...W+ + W- -> h0
10738  xh=sh/shp
10739  230 DO 260 jt=1,2
10740  i=mint(14+jt)
10741  ia=iabs(i)
10742  IF(ia.LE.10) THEN
10743  rvckm=vint(180+i)*pyr(0)
10744  DO 240 j=1,mstp(1)
10745  ib=2*j-1+mod(ia,2)
10746  ipm=(5-isign(1,i))/2
10747  idc=j+mdcy(ia,2)+2
10748  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 240
10749  mint(20+jt)=isign(ib,i)
10750  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10751  IF(rvckm.LE.0d0) GOTO 250
10752  240 CONTINUE
10753  ELSE
10754  ib=2*((ia+1)/2)-1+mod(ia,2)
10755  mint(20+jt)=isign(ib,i)
10756  ENDIF
10757  250 pmq(jt)=pymass(mint(20+jt))
10758  260 CONTINUE
10759  jt=int(1.5d0+pyr(0))
10760  zmin=2d0*pmq(jt)/shpr
10761  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
10762  & (shpr*(shpr-pmq(3-jt)))
10763  zmax=min(1d0-xh,zmax)
10764  IF(zmin.GE.zmax) GOTO 230
10765  z(jt)=zmin+(zmax-zmin)*pyr(0)
10766  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
10767  & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 230
10768  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
10769  IF(sqc1.LT.1d-8) GOTO 230
10770  c1=sqrt(sqc1)
10771  c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
10772  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10773  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
10774  z(3-jt)=1d0-xh/(1d0-z(jt))
10775  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
10776  IF(sqc1.LT.1d-8) GOTO 230
10777  c1=sqrt(sqc1)
10778  c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
10779  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10780  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
10781  phir=paru(2)*pyr(0)
10782  cphi=cos(phir)
10783  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
10784  & sqrt(1d0-cthe(2)**2)*cphi
10785  z1=2d0-z(jt)
10786  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
10787  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
10788  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
10789  & pmq(3-jt)**2/shp))
10790  zmin=2d0*pmq(3-jt)/shpr
10791  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
10792  zmax=min(1d0-xh,zmax)
10793  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 230
10794  kcc=22
10795  kfres=25
10796 
10797  ELSEIF(isub.EQ.10) THEN
10798 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10799  IF(mint(2).EQ.1) THEN
10800  kcc=22
10801  ELSE
10802 C...W exchange: need to mix flavours according to CKM matrix
10803  DO 280 jt=1,2
10804  i=mint(14+jt)
10805  ia=iabs(i)
10806  IF(ia.LE.10) THEN
10807  rvckm=vint(180+i)*pyr(0)
10808  DO 270 j=1,mstp(1)
10809  ib=2*j-1+mod(ia,2)
10810  ipm=(5-isign(1,i))/2
10811  idc=j+mdcy(ia,2)+2
10812  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 270
10813  mint(20+jt)=isign(ib,i)
10814  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10815  IF(rvckm.LE.0d0) GOTO 280
10816  270 CONTINUE
10817  ELSE
10818  ib=2*((ia+1)/2)-1+mod(ia,2)
10819  mint(20+jt)=isign(ib,i)
10820  ENDIF
10821  280 CONTINUE
10822  kcc=22
10823  ENDIF
10824  ENDIF
10825 
10826  ELSEIF(isub.LE.20) THEN
10827  IF(isub.EQ.11) THEN
10828 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10829  kcc=mint(2)
10830  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
10831 
10832  ELSEIF(isub.EQ.12) THEN
10833 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10834  mint(21)=isign(kflf,mint(15))
10835  mint(22)=-mint(21)
10836  kcc=4
10837 
10838  ELSEIF(isub.EQ.13) THEN
10839 C...f + fbar -> g + g; th arbitrary
10840  mint(21)=21
10841  mint(22)=21
10842  kcc=mint(2)+4
10843 
10844  ELSEIF(isub.EQ.14) THEN
10845 C...f + fbar -> g + gamma; th arbitrary
10846  IF(pyr(0).GT.0.5d0) js=2
10847  mint(20+js)=21
10848  mint(23-js)=22
10849  kcc=17+js
10850 
10851  ELSEIF(isub.EQ.15) THEN
10852 C...f + fbar -> g + Z0; th arbitrary
10853  IF(pyr(0).GT.0.5d0) js=2
10854  mint(20+js)=21
10855  mint(23-js)=23
10856  kcc=17+js
10857 
10858  ELSEIF(isub.EQ.16) THEN
10859 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10860  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10861  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10862  IF(mint(15)*(kch1+kch2).LT.0) js=2
10863  mint(20+js)=21
10864  mint(23-js)=isign(24,kch1+kch2)
10865  kcc=17+js
10866 
10867  ELSEIF(isub.EQ.17) THEN
10868 C...f + fbar -> g + h0; th arbitrary
10869  IF(pyr(0).GT.0.5d0) js=2
10870  mint(20+js)=21
10871  mint(23-js)=25
10872  kcc=17+js
10873 
10874  ELSEIF(isub.EQ.18) THEN
10875 C...f + fbar -> gamma + gamma; th arbitrary
10876  mint(21)=22
10877  mint(22)=22
10878 
10879  ELSEIF(isub.EQ.19) THEN
10880 C...f + fbar -> gamma + Z0; th arbitrary
10881  IF(pyr(0).GT.0.5d0) js=2
10882  mint(20+js)=22
10883  mint(23-js)=23
10884 
10885  ELSEIF(isub.EQ.20) THEN
10886 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10887 C...(p(fbar')-p(W+))**2
10888  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10889  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10890  IF(mint(15)*(kch1+kch2).LT.0) js=2
10891  mint(20+js)=22
10892  mint(23-js)=isign(24,kch1+kch2)
10893  ENDIF
10894 
10895  ELSEIF(isub.LE.30) THEN
10896  IF(isub.EQ.21) THEN
10897 C...f + fbar -> gamma + h0; th arbitrary
10898  IF(pyr(0).GT.0.5d0) js=2
10899  mint(20+js)=22
10900  mint(23-js)=25
10901 
10902  ELSEIF(isub.EQ.22) THEN
10903 C...f + fbar -> Z0 + Z0; th arbitrary
10904  mint(21)=23
10905  mint(22)=23
10906 
10907  ELSEIF(isub.EQ.23) THEN
10908 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10909  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10910  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10911  IF(mint(15)*(kch1+kch2).LT.0) js=2
10912  mint(20+js)=23
10913  mint(23-js)=isign(24,kch1+kch2)
10914 
10915  ELSEIF(isub.EQ.24) THEN
10916 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10917  IF(pyr(0).GT.0.5d0) js=2
10918  mint(20+js)=23
10919  mint(23-js)=kfhigg
10920 
10921  ELSEIF(isub.EQ.25) THEN
10922 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10923  mint(21)=-isign(24,mint(15))
10924  mint(22)=-mint(21)
10925 
10926  ELSEIF(isub.EQ.26) THEN
10927 C...f + fbar' -> W+/- + h0 (or H0, or A0);
10928 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10929  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10930  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10931  IF(mint(15)*(kch1+kch2).GT.0) js=2
10932  mint(20+js)=isign(24,kch1+kch2)
10933  mint(23-js)=kfhigg
10934 
10935  ELSEIF(isub.EQ.27) THEN
10936 C...f + fbar -> h0 + h0
10937 
10938  ELSEIF(isub.EQ.28) THEN
10939 C...f + g -> f + g; th = (p(f)-p(f))**2
10940  IF(mint(15).EQ.21) js=2
10941  kcc=mint(2)+6
10942  IF(mint(15).EQ.21) kcc=kcc+2
10943  IF(mint(15).NE.21) kcs=isign(1,mint(15))
10944  IF(mint(16).NE.21) kcs=isign(1,mint(16))
10945 
10946  ELSEIF(isub.EQ.29) THEN
10947 C...f + g -> f + gamma; th = (p(f)-p(f))**2
10948  IF(mint(15).EQ.21) js=2
10949  mint(23-js)=22
10950  kcc=15+js
10951  kcs=isign(1,mint(14+js))
10952 
10953  ELSEIF(isub.EQ.30) THEN
10954 C...f + g -> f + Z0; th = (p(f)-p(f))**2
10955  IF(mint(15).EQ.21) js=2
10956  mint(23-js)=23
10957  kcc=15+js
10958  kcs=isign(1,mint(14+js))
10959  ENDIF
10960 
10961  ELSEIF(isub.LE.40) THEN
10962  IF(isub.EQ.31) THEN
10963 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10964  IF(mint(15).EQ.21) js=2
10965  i=mint(14+js)
10966  ia=iabs(i)
10967  mint(23-js)=isign(24,kchg(ia,1)*i)
10968  rvckm=vint(180+i)*pyr(0)
10969  DO 290 j=1,mstp(1)
10970  ib=2*j-1+mod(ia,2)
10971  ipm=(5-isign(1,i))/2
10972  idc=j+mdcy(ia,2)+2
10973  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 290
10974  mint(20+js)=isign(ib,i)
10975  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10976  IF(rvckm.LE.0d0) GOTO 300
10977  290 CONTINUE
10978  300 kcc=15+js
10979  kcs=isign(1,mint(14+js))
10980 
10981  ELSEIF(isub.EQ.32) THEN
10982 C...f + g -> f + h0; th = (p(f)-p(f))**2
10983  IF(mint(15).EQ.21) js=2
10984  mint(23-js)=25
10985  kcc=15+js
10986  kcs=isign(1,mint(14+js))
10987 
10988  ELSEIF(isub.EQ.33) THEN
10989 C...f + gamma -> f + g; th=(p(f)-p(f))**2
10990  IF(mint(15).EQ.22) js=2
10991  mint(23-js)=21
10992  kcc=24+js
10993  kcs=isign(1,mint(14+js))
10994 
10995  ELSEIF(isub.EQ.34) THEN
10996 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10997  IF(mint(15).EQ.22) js=2
10998  kcc=22
10999  kcs=isign(1,mint(14+js))
11000 
11001  ELSEIF(isub.EQ.35) THEN
11002 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11003  IF(mint(15).EQ.22) js=2
11004  mint(23-js)=23
11005  kcc=22
11006 
11007  ELSEIF(isub.EQ.36) THEN
11008 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11009  IF(mint(15).EQ.22) js=2
11010  i=mint(14+js)
11011  ia=iabs(i)
11012  mint(23-js)=isign(24,kchg(ia,1)*i)
11013  IF(ia.LE.10) THEN
11014  rvckm=vint(180+i)*pyr(0)
11015  DO 310 j=1,mstp(1)
11016  ib=2*j-1+mod(ia,2)
11017  ipm=(5-isign(1,i))/2
11018  idc=j+mdcy(ia,2)+2
11019  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 310
11020  mint(20+js)=isign(ib,i)
11021  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11022  IF(rvckm.LE.0d0) GOTO 320
11023  310 CONTINUE
11024  ELSE
11025  ib=2*((ia+1)/2)-1+mod(ia,2)
11026  mint(20+js)=isign(ib,i)
11027  ENDIF
11028  320 kcc=22
11029 
11030  ELSEIF(isub.EQ.37) THEN
11031 C...f + gamma -> f + h0
11032 
11033  ELSEIF(isub.EQ.38) THEN
11034 C...f + Z0 -> f + g
11035 
11036  ELSEIF(isub.EQ.39) THEN
11037 C...f + Z0 -> f + gamma
11038 
11039  ELSEIF(isub.EQ.40) THEN
11040 C...f + Z0 -> f + Z0
11041  ENDIF
11042 
11043  ELSEIF(isub.LE.50) THEN
11044  IF(isub.EQ.41) THEN
11045 C...f + Z0 -> f' + W+/-
11046 
11047  ELSEIF(isub.EQ.42) THEN
11048 C...f + Z0 -> f + h0
11049 
11050  ELSEIF(isub.EQ.43) THEN
11051 C...f + W+/- -> f' + g
11052 
11053  ELSEIF(isub.EQ.44) THEN
11054 C...f + W+/- -> f' + gamma
11055 
11056  ELSEIF(isub.EQ.45) THEN
11057 C...f + W+/- -> f' + Z0
11058 
11059  ELSEIF(isub.EQ.46) THEN
11060 C...f + W+/- -> f' + W+/-
11061 
11062  ELSEIF(isub.EQ.47) THEN
11063 C...f + W+/- -> f' + h0
11064 
11065  ELSEIF(isub.EQ.48) THEN
11066 C...f + h0 -> f + g
11067 
11068  ELSEIF(isub.EQ.49) THEN
11069 C...f + h0 -> f + gamma
11070 
11071  ELSEIF(isub.EQ.50) THEN
11072 C...f + h0 -> f + Z0
11073  ENDIF
11074 
11075  ELSEIF(isub.LE.60) THEN
11076  IF(isub.EQ.51) THEN
11077 C...f + h0 -> f' + W+/-
11078 
11079  ELSEIF(isub.EQ.52) THEN
11080 C...f + h0 -> f + h0
11081 
11082  ELSEIF(isub.EQ.53) THEN
11083 C...g + g -> f + fbar; th arbitrary
11084  kcs=(-1)**int(1.5d0+pyr(0))
11085  mint(21)=isign(kflf,kcs)
11086  mint(22)=-mint(21)
11087  kcc=mint(2)+10
11088 
11089  ELSEIF(isub.EQ.54) THEN
11090 C...g + gamma -> f + fbar; th arbitrary
11091  kcs=(-1)**int(1.5d0+pyr(0))
11092  mint(21)=isign(kflf,kcs)
11093  mint(22)=-mint(21)
11094  kcc=27
11095  IF(mint(16).EQ.21) kcc=28
11096 
11097  ELSEIF(isub.EQ.55) THEN
11098 C...g + Z0 -> f + fbar
11099 
11100  ELSEIF(isub.EQ.56) THEN
11101 C...g + W+/- -> f + fbar'
11102 
11103  ELSEIF(isub.EQ.57) THEN
11104 C...g + h0 -> f + fbar
11105 
11106  ELSEIF(isub.EQ.58) THEN
11107 C...gamma + gamma -> f + fbar; th arbitrary
11108  kcs=(-1)**int(1.5d0+pyr(0))
11109  mint(21)=isign(kflf,kcs)
11110  mint(22)=-mint(21)
11111  kcc=21
11112 
11113  ELSEIF(isub.EQ.59) THEN
11114 C...gamma + Z0 -> f + fbar
11115 
11116  ELSEIF(isub.EQ.60) THEN
11117 C...gamma + W+/- -> f + fbar'
11118  ENDIF
11119 
11120  ELSEIF(isub.LE.70) THEN
11121  IF(isub.EQ.61) THEN
11122 C...gamma + h0 -> f + fbar
11123 
11124  ELSEIF(isub.EQ.62) THEN
11125 C...Z0 + Z0 -> f + fbar
11126 
11127  ELSEIF(isub.EQ.63) THEN
11128 C...Z0 + W+/- -> f + fbar'
11129 
11130  ELSEIF(isub.EQ.64) THEN
11131 C...Z0 + h0 -> f + fbar
11132 
11133  ELSEIF(isub.EQ.65) THEN
11134 C...W+ + W- -> f + fbar
11135 
11136  ELSEIF(isub.EQ.66) THEN
11137 C...W+/- + h0 -> f + fbar'
11138 
11139  ELSEIF(isub.EQ.67) THEN
11140 C...h0 + h0 -> f + fbar
11141 
11142  ELSEIF(isub.EQ.68) THEN
11143 C...g + g -> g + g; th arbitrary
11144  kcc=mint(2)+12
11145  kcs=(-1)**int(1.5d0+pyr(0))
11146 
11147  ELSEIF(isub.EQ.69) THEN
11148 C...gamma + gamma -> W+ + W-; th arbitrary
11149  mint(21)=24
11150  mint(22)=-24
11151  kcc=21
11152 
11153  ELSEIF(isub.EQ.70) THEN
11154 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11155  IF(mint(15).EQ.22) mint(21)=23
11156  IF(mint(16).EQ.22) mint(22)=23
11157  kcc=21
11158  ENDIF
11159 
11160  ELSEIF(isub.LE.80) THEN
11161  IF(isub.EQ.71.OR.isub.EQ.72) THEN
11162 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11163  xh=sh/shp
11164  mint(21)=mint(15)
11165  mint(22)=mint(16)
11166  pmq(1)=pymass(mint(21))
11167  pmq(2)=pymass(mint(22))
11168  330 jt=int(1.5d0+pyr(0))
11169  zmin=2d0*pmq(jt)/shpr
11170  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11171  & (shpr*(shpr-pmq(3-jt)))
11172  zmax=min(1d0-xh,zmax)
11173  z(jt)=zmin+(zmax-zmin)*pyr(0)
11174  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11175  & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 330
11176  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11177  IF(sqc1.LT.1d-8) GOTO 330
11178  c1=sqrt(sqc1)
11179  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
11180  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11181  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11182  z(3-jt)=1d0-xh/(1d0-z(jt))
11183  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11184  IF(sqc1.LT.1d-8) GOTO 330
11185  c1=sqrt(sqc1)
11186  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11187  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11188  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11189  phir=paru(2)*pyr(0)
11190  cphi=cos(phir)
11191  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11192  & sqrt(1d0-cthe(2)**2)*cphi
11193  z1=2d0-z(jt)
11194  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11195  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11196  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11197  & pmq(3-jt)**2/shp))
11198  zmin=2d0*pmq(3-jt)/shpr
11199  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11200  zmax=min(1d0-xh,zmax)
11201  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 330
11202  kcc=22
11203 
11204  ELSEIF(isub.EQ.73) THEN
11205 C...Z0 + W+/- -> Z0 + W+/-
11206  js=mint(2)
11207  xh=sh/shp
11208  340 jt=3-mint(2)
11209  i=mint(14+jt)
11210  ia=iabs(i)
11211  IF(ia.LE.10) THEN
11212  rvckm=vint(180+i)*pyr(0)
11213  DO 350 j=1,mstp(1)
11214  ib=2*j-1+mod(ia,2)
11215  ipm=(5-isign(1,i))/2
11216  idc=j+mdcy(ia,2)+2
11217  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 350
11218  mint(20+jt)=isign(ib,i)
11219  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11220  IF(rvckm.LE.0d0) GOTO 360
11221  350 CONTINUE
11222  ELSE
11223  ib=2*((ia+1)/2)-1+mod(ia,2)
11224  mint(20+jt)=isign(ib,i)
11225  ENDIF
11226  360 pmq(jt)=pymass(mint(20+jt))
11227  mint(23-jt)=mint(17-jt)
11228  pmq(3-jt)=pymass(mint(23-jt))
11229  jt=int(1.5d0+pyr(0))
11230  zmin=2d0*pmq(jt)/shpr
11231  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11232  & (shpr*(shpr-pmq(3-jt)))
11233  zmax=min(1d0-xh,zmax)
11234  IF(zmin.GE.zmax) GOTO 340
11235  z(jt)=zmin+(zmax-zmin)*pyr(0)
11236  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11237  & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 340
11238  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11239  IF(sqc1.LT.1d-8) GOTO 340
11240  c1=sqrt(sqc1)
11241  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
11242  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11243  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11244  z(3-jt)=1d0-xh/(1d0-z(jt))
11245  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11246  IF(sqc1.LT.1d-8) GOTO 340
11247  c1=sqrt(sqc1)
11248  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11249  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11250  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11251  phir=paru(2)*pyr(0)
11252  cphi=cos(phir)
11253  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11254  & sqrt(1d0-cthe(2)**2)*cphi
11255  z1=2d0-z(jt)
11256  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11257  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11258  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11259  & pmq(3-jt)**2/shp))
11260  zmin=2d0*pmq(3-jt)/shpr
11261  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11262  zmax=min(1d0-xh,zmax)
11263  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 340
11264  kcc=22
11265 
11266  ELSEIF(isub.EQ.74) THEN
11267 C...Z0 + h0 -> Z0 + h0
11268 
11269  ELSEIF(isub.EQ.75) THEN
11270 C...W+ + W- -> gamma + gamma
11271 
11272  ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN
11273 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11274  xh=sh/shp
11275  370 DO 400 jt=1,2
11276  i=mint(14+jt)
11277  ia=iabs(i)
11278  IF(ia.LE.10) THEN
11279  rvckm=vint(180+i)*pyr(0)
11280  DO 380 j=1,mstp(1)
11281  ib=2*j-1+mod(ia,2)
11282  ipm=(5-isign(1,i))/2
11283  idc=j+mdcy(ia,2)+2
11284  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 380
11285  mint(20+jt)=isign(ib,i)
11286  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11287  IF(rvckm.LE.0d0) GOTO 390
11288  380 CONTINUE
11289  ELSE
11290  ib=2*((ia+1)/2)-1+mod(ia,2)
11291  mint(20+jt)=isign(ib,i)
11292  ENDIF
11293  390 pmq(jt)=pymass(mint(20+jt))
11294  400 CONTINUE
11295  jt=int(1.5d0+pyr(0))
11296  zmin=2d0*pmq(jt)/shpr
11297  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11298  & (shpr*(shpr-pmq(3-jt)))
11299  zmax=min(1d0-xh,zmax)
11300  IF(zmin.GE.zmax) GOTO 370
11301  z(jt)=zmin+(zmax-zmin)*pyr(0)
11302  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11303  & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 370
11304  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11305  IF(sqc1.LT.1d-8) GOTO 370
11306  c1=sqrt(sqc1)
11307  c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
11308  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11309  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11310  z(3-jt)=1d0-xh/(1d0-z(jt))
11311  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11312  IF(sqc1.LT.1d-8) GOTO 370
11313  c1=sqrt(sqc1)
11314  c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11315  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11316  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11317  phir=paru(2)*pyr(0)
11318  cphi=cos(phir)
11319  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11320  & sqrt(1d0-cthe(2)**2)*cphi
11321  z1=2d0-z(jt)
11322  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11323  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11324  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11325  & pmq(3-jt)**2/shp))
11326  zmin=2d0*pmq(3-jt)/shpr
11327  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11328  zmax=min(1d0-xh,zmax)
11329  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 370
11330  kcc=22
11331 
11332  ELSEIF(isub.EQ.78) THEN
11333 C...W+/- + h0 -> W+/- + h0
11334 
11335  ELSEIF(isub.EQ.79) THEN
11336 C...h0 + h0 -> h0 + h0
11337 
11338  ELSEIF(isub.EQ.80) THEN
11339 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11340  IF(mint(15).EQ.22) js=2
11341  i=mint(14+js)
11342  ia=iabs(i)
11343  mint(23-js)=isign(211,kchg(ia,1)*i)
11344  ib=3-ia
11345  mint(20+js)=isign(ib,i)
11346  kcc=22
11347  ENDIF
11348 
11349  ELSEIF(isub.LE.90) THEN
11350  IF(isub.EQ.81) THEN
11351 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11352  mint(21)=isign(mint(55),mint(15))
11353  mint(22)=-mint(21)
11354  kcc=4
11355 
11356  ELSEIF(isub.EQ.82) THEN
11357 C...g + g -> Q + Qbar; th arbitrary
11358  kcs=(-1)**int(1.5d0+pyr(0))
11359  mint(21)=isign(mint(55),kcs)
11360  mint(22)=-mint(21)
11361  kcc=mint(2)+10
11362 
11363  ELSEIF(isub.EQ.83) THEN
11364 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11365  kfold=mint(16)
11366  IF(mint(2).EQ.2) kfold=mint(15)
11367  kfaold=iabs(kfold)
11368  IF(kfaold.GT.10) THEN
11369  kfanew=kfaold+2*mod(kfaold,2)-1
11370  ELSE
11371  rckm=vint(180+kfold)*pyr(0)
11372  ipm=(5-isign(1,kfold))/2
11373  kfanew=-mod(kfaold+1,2)
11374  410 kfanew=kfanew+2
11375  idc=mdcy(kfaold,2)+(kfanew+1)/2+2
11376  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) THEN
11377  IF(mod(kfaold,2).EQ.0) rckm=rckm-
11378  & vckm(kfaold/2,(kfanew+1)/2)
11379  IF(mod(kfaold,2).EQ.1) rckm=rckm-
11380  & vckm(kfanew/2,(kfaold+1)/2)
11381  ENDIF
11382  IF(kfanew.LE.6.AND.rckm.GT.0d0) GOTO 410
11383  ENDIF
11384  IF(mint(2).EQ.1) THEN
11385  mint(21)=isign(mint(55),mint(15))
11386  mint(22)=isign(kfanew,mint(16))
11387  ELSE
11388  mint(21)=isign(kfanew,mint(15))
11389  mint(22)=isign(mint(55),mint(16))
11390  js=2
11391  ENDIF
11392  kcc=22
11393 
11394  ELSEIF(isub.EQ.84) THEN
11395 C...g + gamma -> Q + Qbar; th arbitary
11396  kcs=(-1)**int(1.5d0+pyr(0))
11397  mint(21)=isign(mint(55),kcs)
11398  mint(22)=-mint(21)
11399  kcc=27
11400  IF(mint(16).EQ.21) kcc=28
11401 
11402  ELSEIF(isub.EQ.85) THEN
11403 C...gamma + gamma -> F + Fbar; th arbitary
11404  kcs=(-1)**int(1.5d0+pyr(0))
11405  mint(21)=isign(mint(56),kcs)
11406  mint(22)=-mint(21)
11407  kcc=21
11408 
11409  ELSEIF(isub.GE.86.AND.isub.LE.89) THEN
11410 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11411  mint(21)=kfpr(isub,1)
11412  mint(22)=kfpr(isub,2)
11413  kcc=24
11414  kcs=(-1)**int(1.5d0+pyr(0))
11415  ENDIF
11416 
11417  ELSEIF(isub.LE.100) THEN
11418  IF(isub.EQ.95) THEN
11419 C...Low-pT ( = energyless g + g -> g + g)
11420  kcc=mint(2)+12
11421  kcs=(-1)**int(1.5d0+pyr(0))
11422 
11423  ELSEIF(isub.EQ.96) THEN
11424 C...Multiple interactions (should be reassigned to QCD process)
11425  ENDIF
11426 
11427  ELSEIF(isub.LE.110) THEN
11428  IF(isub.EQ.101) THEN
11429 C...g + g -> gamma*/Z0
11430  kcc=21
11431  kfres=22
11432 
11433  ELSEIF(isub.EQ.102) THEN
11434 C...g + g -> h0 (or H0, or A0)
11435  kcc=21
11436  kfres=kfhigg
11437 
11438  ELSEIF(isub.EQ.103) THEN
11439 C...gamma + gamma -> h0 (or H0, or A0)
11440  kcc=21
11441  kfres=kfhigg
11442 
11443  ELSEIF(isub.EQ.104.OR.isub.EQ.105) THEN
11444 C...g + g -> chi_0c or chi_2c.
11445  kcc=21
11446  kfres=kfpr(isub,1)
11447 
11448  ELSEIF(isub.EQ.106) THEN
11449 C...g + g -> J/Psi + gamma
11450  mint(21)=kfpr(isub,1)
11451  mint(22)=kfpr(isub,2)
11452  kcc=21
11453 
11454  ELSEIF(isub.EQ.107) THEN
11455 C...g + gamma -> J/Psi + g
11456  mint(21)=kfpr(isub,1)
11457  mint(22)=kfpr(isub,2)
11458  kcc=22
11459  IF(mint(16).EQ.22) kcc=33
11460 
11461  ELSEIF(isub.EQ.108) THEN
11462 C...gamma + gamma -> J/Psi + gamma
11463  mint(21)=kfpr(isub,1)
11464  mint(22)=kfpr(isub,2)
11465 
11466  ELSEIF(isub.EQ.110) THEN
11467 C...f + fbar -> gamma + h0; th arbitrary
11468  IF(pyr(0).GT.0.5d0) js=2
11469  mint(20+js)=22
11470  mint(23-js)=kfhigg
11471  ENDIF
11472 
11473  ELSEIF(isub.LE.120) THEN
11474  IF(isub.EQ.111) THEN
11475 C...f + fbar -> g + h0; th arbitrary
11476  IF(pyr(0).GT.0.5d0) js=2
11477  mint(20+js)=21
11478  mint(23-js)=kfhigg
11479  kcc=17+js
11480 
11481  ELSEIF(isub.EQ.112) THEN
11482 C...f + g -> f + h0; th = (p(f) - p(f))**2
11483  IF(mint(15).EQ.21) js=2
11484  mint(23-js)=kfhigg
11485  kcc=15+js
11486  kcs=isign(1,mint(14+js))
11487 
11488  ELSEIF(isub.EQ.113) THEN
11489 C...g + g -> g + h0; th arbitrary
11490  IF(pyr(0).GT.0.5d0) js=2
11491  mint(23-js)=kfhigg
11492  kcc=22+js
11493  kcs=(-1)**int(1.5d0+pyr(0))
11494 
11495  ELSEIF(isub.EQ.114) THEN
11496 C...g + g -> gamma + gamma; th arbitrary
11497  IF(pyr(0).GT.0.5d0) js=2
11498  mint(21)=22
11499  mint(22)=22
11500  kcc=21
11501 
11502  ELSEIF(isub.EQ.115) THEN
11503 C...g + g -> g + gamma; th arbitrary
11504  IF(pyr(0).GT.0.5d0) js=2
11505  mint(23-js)=22
11506  kcc=22+js
11507  kcs=(-1)**int(1.5d0+pyr(0))
11508 
11509  ELSEIF(isub.EQ.116) THEN
11510 C...g + g -> gamma + Z0
11511 
11512  ELSEIF(isub.EQ.117) THEN
11513 C...g + g -> Z0 + Z0
11514 
11515  ELSEIF(isub.EQ.118) THEN
11516 C...g + g -> W+ + W-
11517  ENDIF
11518 
11519  ELSEIF(isub.LE.140) THEN
11520  IF(isub.EQ.121) THEN
11521 C...g + g -> Q + Qbar + h0
11522  kcs=(-1)**int(1.5d0+pyr(0))
11523  mint(21)=isign(kfpr(isubsv,2),kcs)
11524  mint(22)=-mint(21)
11525  kcc=11+int(0.5d0+pyr(0))
11526  kfres=kfhigg
11527 
11528  ELSEIF(isub.EQ.122) THEN
11529 C...q + qbar -> Q + Qbar + h0
11530  mint(21)=isign(kfpr(isubsv,2),mint(15))
11531  mint(22)=-mint(21)
11532  kcc=4
11533  kfres=kfhigg
11534 
11535  ELSEIF(isub.EQ.123) THEN
11536 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11537 C...inner process)
11538  kcc=22
11539  kfres=kfhigg
11540 
11541  ELSEIF(isub.EQ.124) THEN
11542 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11543 C...inner process)
11544  DO 430 jt=1,2
11545  i=mint(14+jt)
11546  ia=iabs(i)
11547  IF(ia.LE.10) THEN
11548  rvckm=vint(180+i)*pyr(0)
11549  DO 420 j=1,mstp(1)
11550  ib=2*j-1+mod(ia,2)
11551  ipm=(5-isign(1,i))/2
11552  idc=j+mdcy(ia,2)+2
11553  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 420
11554  mint(20+jt)=isign(ib,i)
11555  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11556  IF(rvckm.LE.0d0) GOTO 430
11557  420 CONTINUE
11558  ELSE
11559  ib=2*((ia+1)/2)-1+mod(ia,2)
11560  mint(20+jt)=isign(ib,i)
11561  ENDIF
11562  430 CONTINUE
11563  kcc=22
11564  kfres=kfhigg
11565 
11566  ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
11567 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11568  IF(mint(15).EQ.22) js=2
11569  mint(23-js)=21
11570  kcc=24+js
11571  kcs=isign(1,mint(14+js))
11572 
11573  ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
11574 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11575  IF(mint(15).EQ.22) js=2
11576  kcc=22
11577  kcs=isign(1,mint(14+js))
11578 
11579  ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
11580 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11581  kcs=(-1)**int(1.5d0+pyr(0))
11582  mint(21)=isign(kflf,kcs)
11583  mint(22)=-mint(21)
11584  kcc=27
11585  IF(mint(16).EQ.21) kcc=28
11586 
11587  ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
11588 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11589  kcs=(-1)**int(1.5d0+pyr(0))
11590  mint(21)=isign(kflf,kcs)
11591  mint(22)=-mint(21)
11592  kcc=21
11593 
11594  ENDIF
11595 
11596  ELSEIF(isub.LE.160) THEN
11597  IF(isub.EQ.141) THEN
11598 C...f + fbar -> gamma*/Z0/Z'0
11599  kfres=32
11600 
11601  ELSEIF(isub.EQ.142) THEN
11602 C...f + fbar' -> W'+/-
11603  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11604  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11605  kfres=isign(34,kch1+kch2)
11606 
11607  ELSEIF(isub.EQ.143) THEN
11608 C...f + fbar' -> H+/-
11609  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11610  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11611  kfres=isign(37,kch1+kch2)
11612 
11613  ELSEIF(isub.EQ.144) THEN
11614 C...f + fbar' -> R
11615  kfres=isign(41,mint(15)+mint(16))
11616 
11617  ELSEIF(isub.EQ.145) THEN
11618 C...q + l -> LQ (leptoquark)
11619  IF(iabs(mint(16)).LE.8) js=2
11620  kfres=isign(42,mint(14+js))
11621  kcc=28+js
11622  kcs=isign(1,mint(14+js))
11623 
11624  ELSEIF(isub.EQ.146) THEN
11625 C...e + gamma -> e* (excited lepton)
11626  IF(mint(15).EQ.22) js=2
11627  kfres=isign(kfpr(isub,1),mint(14+js))
11628  kcc=22
11629 
11630  ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
11631 C...q + g -> q* (excited quark)
11632  IF(mint(15).EQ.21) js=2
11633  kfres=isign(kfpr(isub,1),mint(14+js))
11634  kcc=30+js
11635  kcs=isign(1,mint(14+js))
11636 
11637  ELSEIF(isub.EQ.149) THEN
11638 C...g + g -> eta_tc
11639  kfres=ktechn+331
11640  kcc=23
11641  kcs=(-1)**int(1.5d0+pyr(0))
11642  ENDIF
11643 
11644  ELSEIF(isub.LE.200) THEN
11645  IF(isub.EQ.161) THEN
11646 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11647  IF(mint(15).EQ.21) js=2
11648  i=mint(14+js)
11649  ia=iabs(i)
11650  mint(23-js)=isign(37,kchg(ia,1)*i)
11651  ib=ia+mod(ia,2)-mod(ia+1,2)
11652  mint(20+js)=isign(ib,i)
11653  kcc=15+js
11654  kcs=isign(1,mint(14+js))
11655 
11656  ELSEIF(isub.EQ.162) THEN
11657 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11658  IF(mint(15).EQ.21) js=2
11659  mint(20+js)=isign(42,mint(14+js))
11660  kflql=kfdp(mdcy(42,2),2)
11661  mint(23-js)=-isign(kflql,mint(14+js))
11662  kcc=15+js
11663  kcs=isign(1,mint(14+js))
11664 
11665  ELSEIF(isub.EQ.163) THEN
11666 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11667  kcs=(-1)**int(1.5d0+pyr(0))
11668  mint(21)=isign(42,kcs)
11669  mint(22)=-mint(21)
11670  kcc=mint(2)+10
11671 
11672  ELSEIF(isub.EQ.164) THEN
11673 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11674  mint(21)=isign(42,mint(15))
11675  mint(22)=-mint(21)
11676  kcc=4
11677 
11678  ELSEIF(isub.EQ.165) THEN
11679 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11680  mint(21)=isign(kfpr(isub,1),mint(15))
11681  mint(22)=-mint(21)
11682 
11683  ELSEIF(isub.EQ.166) THEN
11684 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11685  IF(mod(mint(15),2).EQ.0) THEN
11686  mint(21)=isign(kfpr(isub,1)+1,mint(15))
11687  mint(22)=isign(kfpr(isub,1),mint(16))
11688  ELSE
11689  mint(21)=isign(kfpr(isub,1),mint(15))
11690  mint(22)=isign(kfpr(isub,1)+1,mint(16))
11691  ENDIF
11692 
11693  ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
11694 C...q + q' -> q" + q* (excited quark)
11695  kfqstr=kfpr(isub,2)
11696  kfqexc=mod(kfqstr,kexcit)
11697  js=mint(2)
11698  mint(20+js)=isign(kfqstr,mint(14+js))
11699  IF(iabs(mint(15)).NE.kfqexc.AND.iabs(mint(16)).NE.kfqexc)
11700  & mint(23-js)=isign(kfqexc,mint(17-js))
11701  kcc=22
11702  js=3-js
11703 
11704  ELSEIF(isub.EQ.169) THEN
11705 C...q + qbar -> e + e* (excited lepton)
11706  kfqstr=kfpr(isub,2)
11707  kfqexc=mod(kfqstr,kexcit)
11708  js=mint(2)
11709  mint(20+js)=isign(kfqstr,mint(14+js))
11710  mint(23-js)=isign(kfqexc,mint(17-js))
11711  js=3-js
11712 
11713  ELSEIF(isub.EQ.191) THEN
11714 C...f + fbar -> rho_tc0.
11715  kfres=ktechn+113
11716 
11717  ELSEIF(isub.EQ.192) THEN
11718 C...f + fbar' -> rho_tc+/-
11719  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11720  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11721  kfres=isign(ktechn+213,kch1+kch2)
11722 
11723  ELSEIF(isub.EQ.193) THEN
11724 C...f + fbar -> omega_tc0.
11725  kfres=ktechn+223
11726 
11727  ELSEIF(isub.EQ.194) THEN
11728 C...f + fbar -> f' + fbar' via mixture of s-channel
11729 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11730  mint(21)=isign(kfpr(isub,1),mint(15))
11731  mint(22)=-mint(21)
11732 
11733  ELSEIF(isub.EQ.195) THEN
11734 C...f + fbar' -> f'' + fbar''' via s-channel
11735 C...rho_tc+ th=(p(f)-p(f'))**2
11736 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11737  IF(mod(mint(15),2).EQ.0) THEN
11738  mint(21)=isign(kfpr(isub,1)+1,mint(15))
11739  mint(22)=isign(kfpr(isub,1),mint(16))
11740  ELSE
11741  mint(21)=isign(kfpr(isub,1),mint(15))
11742  mint(22)=isign(kfpr(isub,1)+1,mint(16))
11743  ENDIF
11744  ENDIF
11745 
11746 CMRENNA++
11747  ELSEIF(isub.LE.215) THEN
11748  IF(isub.EQ.201) THEN
11749 C...f + fbar -> ~e_L + ~e_Lbar
11750  mint(21)=isign(ksusy1+11,kcs)
11751  mint(22)=-mint(21)
11752 
11753  ELSEIF(isub.EQ.202) THEN
11754 C...f + fbar -> ~e_R + ~e_Rbar
11755  mint(21)=isign(ksusy2+11,kcs)
11756  mint(22)=-mint(21)
11757 
11758  ELSEIF(isub.EQ.203) THEN
11759 C...f + fbar -> ~e_L + ~e_Rbar
11760  IF(mint(15).LT.0) js=2
11761  IF(mint(2).EQ.1) THEN
11762  mint(20+js)=kfpr(isub,1)
11763  mint(23-js)=-kfpr(isub,2)
11764  ELSE
11765  mint(20+js)=-kfpr(isub,1)
11766  mint(23-js)=kfpr(isub,2)
11767  ENDIF
11768 
11769  ELSEIF(isub.EQ.204) THEN
11770 C...f + fbar -> ~mu_L + ~mu_Lbar
11771  mint(21)=isign(ksusy1+13,kcs)
11772  mint(22)=-mint(21)
11773 
11774  ELSEIF(isub.EQ.205) THEN
11775 C...f + fbar -> ~mu_R + ~mu_Rbar
11776  mint(21)=isign(ksusy2+13,kcs)
11777  mint(22)=-mint(21)
11778 
11779  ELSEIF(isub.EQ.206) THEN
11780 C...f + fbar -> ~mu_L + ~mu_Rbar
11781  IF(mint(15).LT.0) js=2
11782  IF(mint(2).EQ.1) THEN
11783  mint(20+js)=kfpr(isub,1)
11784  mint(23-js)=-kfpr(isub,2)
11785  ELSE
11786  mint(20+js)=-kfpr(isub,1)
11787  mint(23-js)=kfpr(isub,2)
11788  ENDIF
11789 
11790  ELSEIF(isub.EQ.207) THEN
11791 C...f + fbar -> ~tau_1 + ~tau_1bar
11792  mint(21)=isign(ksusy1+15,kcs)
11793  mint(22)=-mint(21)
11794 
11795  ELSEIF(isub.EQ.208) THEN
11796 C...f + fbar -> ~tau_2 + ~tau_2bar
11797  mint(21)=isign(ksusy2+15,kcs)
11798  mint(22)=-mint(21)
11799 
11800  ELSEIF(isub.EQ.209) THEN
11801 C...f + fbar -> ~tau_1 + ~tau_2bar
11802  IF(mint(15).LT.0) js=2
11803  IF(mint(2).EQ.1) THEN
11804  mint(20+js)=kfpr(isub,1)
11805  mint(23-js)=-kfpr(isub,2)
11806  ELSE
11807  mint(20+js)=-kfpr(isub,1)
11808  mint(23-js)=kfpr(isub,2)
11809  ENDIF
11810 
11811  ELSEIF(isub.EQ.210) THEN
11812 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11813  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11814  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11815  mint(21)=-isign(kfpr(isub,1),kch1+kch2)
11816  mint(22)=isign(kfpr(isub,2),kch1+kch2)
11817 
11818  ELSEIF(isub.EQ.211) THEN
11819 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11820  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11821  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11822  mint(21)=-isign(ksusy1+15,kch1+kch2)
11823  mint(22)=isign(ksusy1+16,kch1+kch2)
11824 
11825  ELSEIF(isub.EQ.212) THEN
11826 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11827  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11828  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11829  mint(21)=-isign(ksusy2+15,kch1+kch2)
11830  mint(22)=isign(ksusy1+16,kch1+kch2)
11831 
11832  ELSEIF(isub.EQ.213) THEN
11833 C...f + fbar -> ~nul + ~nulbar
11834  mint(21)=isign(kfpr(isub,1),kcs)
11835  mint(22)=-mint(21)
11836 
11837  ELSEIF(isub.EQ.214) THEN
11838 C...f + fbar -> ~nutau + ~nutaubar
11839  mint(21)=isign(ksusy1+16,kcs)
11840  mint(22)=-mint(21)
11841  ENDIF
11842 
11843  ELSEIF(isub.LE.225) THEN
11844  IF(isub.EQ.216) THEN
11845 C...f + fbar -> ~chi01 + ~chi01
11846  mint(21)=ksusy1+22
11847  mint(22)=ksusy1+22
11848 
11849  ELSEIF(isub.EQ.217) THEN
11850 C...f + fbar -> ~chi02 + ~chi02
11851  mint(21)=ksusy1+23
11852  mint(22)=ksusy1+23
11853 
11854  ELSEIF(isub.EQ.218 ) THEN
11855 C...f + fbar -> ~chi03 + ~chi03
11856  mint(21)=ksusy1+25
11857  mint(22)=ksusy1+25
11858 
11859  ELSEIF(isub.EQ.219 ) THEN
11860 C...f + fbar -> ~chi04 + ~chi04
11861  mint(21)=ksusy1+35
11862  mint(22)=ksusy1+35
11863 
11864  ELSEIF(isub.EQ.220 ) THEN
11865 C...f + fbar -> ~chi01 + ~chi02
11866  IF(mint(15).LT.0) js=2
11867 C IF(PYR(0).GT.0.5D0) JS=2
11868  mint(20+js)=ksusy1+22
11869  mint(23-js)=ksusy1+23
11870 
11871  ELSEIF(isub.EQ.221 ) THEN
11872 C...f + fbar -> ~chi01 + ~chi03
11873  IF(mint(15).LT.0) js=2
11874 C IF(PYR(0).GT.0.5D0) JS=2
11875  mint(20+js)=ksusy1+22
11876  mint(23-js)=ksusy1+25
11877 
11878  ELSEIF(isub.EQ.222) THEN
11879 C...f + fbar -> ~chi01 + ~chi04
11880  IF(mint(15).LT.0) js=2
11881 C IF(PYR(0).GT.0.5D0) JS=2
11882  mint(20+js)=ksusy1+22
11883  mint(23-js)=ksusy1+35
11884 
11885  ELSEIF(isub.EQ.223) THEN
11886 C...f + fbar -> ~chi02 + ~chi03
11887  IF(mint(15).LT.0) js=2
11888 C IF(PYR(0).GT.0.5D0) JS=2
11889  mint(20+js)=ksusy1+23
11890  mint(23-js)=ksusy1+25
11891 
11892  ELSEIF(isub.EQ.224) THEN
11893 C...f + fbar -> ~chi02 + ~chi04
11894  IF(mint(15).LT.0) js=2
11895 C IF(PYR(0).GT.0.5D0) JS=2
11896  mint(20+js)=ksusy1+23
11897  mint(23-js)=ksusy1+35
11898 
11899  ELSEIF(isub.EQ.225) THEN
11900 C...f + fbar -> ~chi03 + ~chi04
11901  IF(mint(15).LT.0) js=2
11902 C IF(PYR(0).GT.0.5D0) JS=2
11903  mint(20+js)=ksusy1+25
11904  mint(23-js)=ksusy1+35
11905  ENDIF
11906 
11907  ELSEIF(isub.LE.236) THEN
11908  IF(isub.EQ.226) THEN
11909 C...f + fbar -> ~chi+-1 + ~chi-+1
11910 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11911  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11912  mint(21)=isign(ksusy1+24,kch1)
11913  mint(22)=-mint(21)
11914 
11915  ELSEIF(isub.EQ.227) THEN
11916 C...f + fbar -> ~chi+-2 + ~chi-+2
11917  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11918  mint(21)=isign(ksusy1+37,kch1)
11919  mint(22)=-mint(21)
11920 
11921  ELSEIF(isub.EQ.228) THEN
11922 C...f + fbar -> ~chi+-1 + ~chi-+2
11923 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11924 C...js=1 if pyr<.5, js=2 if pyr>.5
11925 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11926 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11927 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11928 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11929  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11930  kch2=int(1-kch1)/2
11931  IF(mint(2).EQ.1) THEN
11932  mint(21)= isign(ksusy1+24,kch1)
11933  mint(22)= -isign(ksusy1+37,kch1)
11934 c IF(KCH2.EQ.0) JS=2
11935  ELSE
11936  mint(21)= isign(ksusy1+37,kch1)
11937  mint(22)= -isign(ksusy1+24,kch1)
11938  js=2
11939 c IF(KCH2.EQ.1) JS=2
11940  ENDIF
11941 
11942  ELSEIF(isub.EQ.229) THEN
11943 C...q + qbar' -> ~chi01 + ~chi+-1
11944 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11945  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11946  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11947 C...CHECK THIS
11948  IF(mod(mint(15),2).EQ.0) js=2
11949  mint(20+js)=ksusy1+22
11950  mint(23-js)=isign(ksusy1+24,kch1+kch2)
11951 
11952  ELSEIF(isub.EQ.230) THEN
11953 C...q + qbar' -> ~chi02 + ~chi+-1
11954  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11955  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11956  IF(mod(mint(15),2).EQ.0) js=2
11957  mint(20+js)=ksusy1+23
11958  mint(23-js)=isign(ksusy1+24,kch1+kch2)
11959 
11960  ELSEIF(isub.EQ.231) THEN
11961 C...q + qbar' -> ~chi03 + ~chi+-1
11962  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11963  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11964  IF(mod(mint(15),2).EQ.0) js=2
11965  mint(20+js)=ksusy1+25
11966  mint(23-js)=isign(ksusy1+24,kch1+kch2)
11967 
11968  ELSEIF(isub.EQ.232) THEN
11969 C...q + qbar' -> ~chi04 + ~chi+-1
11970  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11971  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11972  IF(mod(mint(15),2).EQ.0) js=2
11973  mint(20+js)=ksusy1+35
11974  mint(23-js)=isign(ksusy1+24,kch1+kch2)
11975 
11976  ELSEIF(isub.EQ.233) THEN
11977 C...q + qbar' -> ~chi01 + ~chi+-2
11978  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11979  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11980  IF(mod(mint(15),2).EQ.0) js=2
11981  mint(20+js)=ksusy1+22
11982  mint(23-js)=isign(ksusy1+37,kch1+kch2)
11983 
11984  ELSEIF(isub.EQ.234) THEN
11985 C...q + qbar' -> ~chi02 + ~chi+-2
11986  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11987  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11988  IF(mod(mint(15),2).EQ.0) js=2
11989  mint(20+js)=ksusy1+23
11990  mint(23-js)=isign(ksusy1+37,kch1+kch2)
11991 
11992  ELSEIF(isub.EQ.235) THEN
11993 C...q + qbar' -> ~chi03 + ~chi+-2
11994  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11995  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11996  IF(mod(mint(15),2).EQ.0) js=2
11997  mint(20+js)=ksusy1+25
11998  mint(23-js)=isign(ksusy1+37,kch1+kch2)
11999 
12000  ELSEIF(isub.EQ.236) THEN
12001 C...q + qbar' -> ~chi04 + ~chi+-2
12002  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12003  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12004  IF(mod(mint(15),2).EQ.0) js=2
12005  mint(20+js)=ksusy1+35
12006  mint(23-js)=isign(ksusy1+37,kch1+kch2)
12007  ENDIF
12008 
12009  ELSEIF(isub.LE.245) THEN
12010  IF(isub.EQ.237) THEN
12011 C...q + qbar -> ~chi01 + ~g
12012 C...th arbitrary
12013  IF(pyr(0).GT.0.5d0) js=2
12014  mint(20+js)=ksusy1+21
12015  mint(23-js)=ksusy1+22
12016  kcc=17+js
12017 
12018  ELSEIF(isub.EQ.238) THEN
12019 C...q + qbar -> ~chi02 + ~g
12020 C...th arbitrary
12021  IF(pyr(0).GT.0.5d0) js=2
12022  mint(20+js)=ksusy1+21
12023  mint(23-js)=ksusy1+23
12024  kcc=17+js
12025 
12026  ELSEIF(isub.EQ.239) THEN
12027 C...q + qbar -> ~chi03 + ~g
12028 C...th arbitrary
12029  IF(pyr(0).GT.0.5d0) js=2
12030  mint(20+js)=ksusy1+21
12031  mint(23-js)=ksusy1+25
12032  kcc=17+js
12033 
12034  ELSEIF(isub.EQ.240) THEN
12035 C...q + qbar -> ~chi04 + ~g
12036 C...th arbitrary
12037  IF(pyr(0).GT.0.5d0) js=2
12038  mint(20+js)=ksusy1+21
12039  mint(23-js)=ksusy1+35
12040  kcc=17+js
12041 
12042  ELSEIF(isub.EQ.241) THEN
12043 C...q + qbar' -> ~chi+-1 + ~g
12044 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12045 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12046 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12047 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12048 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12049  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12050  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12051  js=1
12052  IF(mint(15)*(kch1+kch2).GT.0) js=2
12053  mint(20+js)=ksusy1+21
12054  mint(23-js)=isign(ksusy1+24,kch1+kch2)
12055  kcc=17+js
12056 
12057  ELSEIF(isub.EQ.242) THEN
12058 C...q + qbar' -> ~chi+-2 + ~g
12059 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12060 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12061 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12062 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12063 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12064  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12065  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12066  js=1
12067  IF(mint(15)*(kch1+kch2).GT.0) js=2
12068  mint(20+js)=ksusy1+21
12069  mint(23-js)=isign(ksusy1+37,kch1+kch2)
12070  kcc=17+js
12071 
12072  ELSEIF(isub.EQ.243) THEN
12073 C...q + qbar -> ~g + ~g ; th arbitrary
12074  mint(21)=ksusy1+21
12075  mint(22)=ksusy1+21
12076  kcc=mint(2)+4
12077 
12078  ELSEIF(isub.EQ.244) THEN
12079 C...g + g -> ~g + ~g ; th arbitrary
12080  kcc=mint(2)+12
12081  kcs=(-1)**int(1.5d0+pyr(0))
12082  mint(21)=ksusy1+21
12083  mint(22)=ksusy1+21
12084  ENDIF
12085 
12086  ELSEIF(isub.LE.260) THEN
12087  IF(isub.EQ.246) THEN
12088 C...qj + g -> ~qj_L + ~chi01
12089  IF(mint(15).EQ.21) js=2
12090  i=mint(14+js)
12091  ia=iabs(i)
12092  mint(20+js)=isign(ksusy1+ia,i)
12093  mint(23-js)=ksusy1+22
12094  kcc=15+js
12095  kcs=isign(1,mint(14+js))
12096 
12097  ELSEIF(isub.EQ.247) THEN
12098 C...qj + g -> ~qj_R + ~chi01
12099  IF(mint(15).EQ.21) js=2
12100  i=mint(14+js)
12101  ia=iabs(i)
12102  mint(20+js)=isign(ksusy2+ia,i)
12103  mint(23-js)=ksusy1+22
12104  kcc=15+js
12105  kcs=isign(1,mint(14+js))
12106 
12107  ELSEIF(isub.EQ.248) THEN
12108 C...qj + g -> ~qj_L + ~chi02
12109  IF(mint(15).EQ.21) js=2
12110  i=mint(14+js)
12111  ia=iabs(i)
12112  mint(20+js)=isign(ksusy1+ia,i)
12113  mint(23-js)=ksusy1+23
12114  kcc=15+js
12115  kcs=isign(1,mint(14+js))
12116 
12117  ELSEIF(isub.EQ.249) THEN
12118 C...qj + g -> ~qj_R + ~chi02
12119  IF(mint(15).EQ.21) js=2
12120  i=mint(14+js)
12121  ia=iabs(i)
12122  mint(20+js)=isign(ksusy2+ia,i)
12123  mint(23-js)=ksusy1+23
12124  kcc=15+js
12125  kcs=isign(1,mint(14+js))
12126 
12127  ELSEIF(isub.EQ.250) THEN
12128 C...qj + g -> ~qj_L + ~chi03
12129  IF(mint(15).EQ.21) js=2
12130  i=mint(14+js)
12131  ia=iabs(i)
12132  mint(20+js)=isign(ksusy1+ia,i)
12133  mint(23-js)=ksusy1+25
12134  kcc=15+js
12135  kcs=isign(1,mint(14+js))
12136 
12137  ELSEIF(isub.EQ.251) THEN
12138 C...qj + g -> ~qj_R + ~chi03
12139  IF(mint(15).EQ.21) js=2
12140  i=mint(14+js)
12141  ia=iabs(i)
12142  mint(20+js)=isign(ksusy2+ia,i)
12143  mint(23-js)=ksusy1+25
12144  kcc=15+js
12145  kcs=isign(1,mint(14+js))
12146 
12147  ELSEIF(isub.EQ.252) THEN
12148 C...qj + g -> ~qj_L + ~chi04
12149  IF(mint(15).EQ.21) js=2
12150  i=mint(14+js)
12151  ia=iabs(i)
12152  mint(20+js)=isign(ksusy1+ia,i)
12153  mint(23-js)=ksusy1+35
12154  kcc=15+js
12155  kcs=isign(1,mint(14+js))
12156 
12157  ELSEIF(isub.EQ.253) THEN
12158 C...qj + g -> ~qj_R + ~chi04
12159  IF(mint(15).EQ.21) js=2
12160  i=mint(14+js)
12161  ia=iabs(i)
12162  mint(20+js)=isign(ksusy2+ia,i)
12163  mint(23-js)=ksusy1+35
12164  kcc=15+js
12165  kcs=isign(1,mint(14+js))
12166 
12167  ELSEIF(isub.EQ.254) THEN
12168 C...qj + g -> ~qk_L + ~chi+-1
12169  IF(mint(15).EQ.21) js=2
12170  i=mint(14+js)
12171  ia=iabs(i)
12172  mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
12173  ib=-ia+int((ia+1)/2)*4-1
12174  mint(20+js)=isign(ksusy1+ib,i)
12175  kcc=15+js
12176  kcs=isign(1,mint(14+js))
12177 
12178  ELSEIF(isub.EQ.255) THEN
12179 C...qj + g -> ~qk_L + ~chi+-1
12180  IF(mint(15).EQ.21) js=2
12181  i=mint(14+js)
12182  ia=iabs(i)
12183  mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
12184  ib=-ia+int((ia+1)/2)*4-1
12185  mint(20+js)=isign(ksusy2+ib,i)
12186  kcc=15+js
12187  kcs=isign(1,mint(14+js))
12188 
12189  ELSEIF(isub.EQ.256) THEN
12190 C...qj + g -> ~qk_L + ~chi+-2
12191  IF(mint(15).EQ.21) js=2
12192  i=mint(14+js)
12193  ia=iabs(i)
12194  ib=-ia+int((ia+1)/2)*4-1
12195  mint(20+js)=isign(ksusy1+ib,i)
12196  mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
12197  kcc=15+js
12198  kcs=isign(1,mint(14+js))
12199 
12200  ELSEIF(isub.EQ.257) THEN
12201 C...qj + g -> ~qk_R + ~chi+-2
12202  IF(mint(15).EQ.21) js=2
12203  i=mint(14+js)
12204  ia=iabs(i)
12205  ib=-ia+int((ia+1)/2)*4-1
12206  mint(20+js)=isign(ksusy2+ib,i)
12207  mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
12208  kcc=15+js
12209  kcs=isign(1,mint(14+js))
12210 
12211  ELSEIF(isub.EQ.258) THEN
12212 C...qj + g -> ~qj_L + ~g
12213  IF(mint(15).EQ.21) js=2
12214  i=mint(14+js)
12215  ia=iabs(i)
12216  mint(20+js)=isign(ksusy1+ia,i)
12217  mint(23-js)=ksusy1+21
12218  kcc=mint(2)+6
12219  IF(js.EQ.2) kcc=kcc+2
12220  kcs=isign(1,i)
12221 
12222  ELSEIF(isub.EQ.259) THEN
12223 C...qj + g -> ~qj_R + ~g
12224  IF(mint(15).EQ.21) js=2
12225  i=mint(14+js)
12226  ia=iabs(i)
12227  mint(20+js)=isign(ksusy2+ia,i)
12228  mint(23-js)=ksusy1+21
12229  kcc=mint(2)+6
12230  IF(js.EQ.2) kcc=kcc+2
12231  kcs=isign(1,i)
12232  ENDIF
12233 
12234  ELSEIF(isub.LE.270) THEN
12235  IF(isub.EQ.261) THEN
12236 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12237  isgn=1
12238  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12239  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12240  mint(22)=-mint(21)
12241 C...Correct color combination
12242  IF(mint(43).EQ.4) kcc=4
12243 
12244  ELSEIF(isub.EQ.262) THEN
12245 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12246  isgn=1
12247  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12248  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12249  mint(22)=-mint(21)
12250 C...Correct color combination
12251  IF(mint(43).EQ.4) kcc=4
12252 
12253  ELSEIF(isub.EQ.263) THEN
12254 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12255  IF((kcs.GT.0.AND.mint(2).EQ.1).OR.
12256  & (kcs.LT.0.AND.mint(2).EQ.2)) THEN
12257  mint(21)=isign(kfpr(isub,1),kcs)
12258  mint(22)=-isign(kfpr(isub,2),kcs)
12259  ELSE
12260  js=2
12261  mint(21)=isign(kfpr(isub,2),kcs)
12262  mint(22)=-isign(kfpr(isub,1),kcs)
12263  ENDIF
12264 C...Correct color combination
12265  IF(mint(43).EQ.4) kcc=4
12266 
12267  ELSEIF(isub.EQ.264) THEN
12268 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12269  kcs=(-1)**int(1.5d0+pyr(0))
12270  mint(21)=isign(kfpr(isub,1),kcs)
12271  mint(22)=-mint(21)
12272  kcc=mint(2)+10
12273 
12274  ELSEIF(isub.EQ.265) THEN
12275 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12276  kcs=(-1)**int(1.5d0+pyr(0))
12277  mint(21)=isign(kfpr(isub,1),kcs)
12278  mint(22)=-mint(21)
12279  kcc=mint(2)+10
12280  ENDIF
12281 
12282  ELSEIF(isub.LE.296) THEN
12283  IF(isub.EQ.271.OR.isub.EQ.281.OR.isub.EQ.291) THEN
12284 C...qi + qj -> ~qi_L + ~qj_L
12285  kcc=mint(2)
12286  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12287  mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
12288  mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
12289 
12290  ELSEIF(isub.EQ.272.OR.isub.EQ.282.OR.isub.EQ.292) THEN
12291 C...qi + qj -> ~qi_R + ~qj_R
12292  kcc=mint(2)
12293  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12294  mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
12295  mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
12296 
12297  ELSEIF(isub.EQ.273.OR.isub.EQ.283.OR.isub.EQ.293) THEN
12298 C...qi + qj -> ~qi_L + ~qj_R
12299  mint(21)=isign(kfpr(isub,1),mint(15))
12300  mint(22)=isign(kfpr(isub,2),mint(16))
12301  kcc=mint(2)
12302  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12303 
12304  ELSEIF(isub.EQ.274.OR.isub.EQ.284) THEN
12305 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12306  mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
12307  mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
12308  kcc=mint(2)
12309  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12310 
12311  ELSEIF(isub.EQ.275.OR.isub.EQ.285) THEN
12312 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12313  mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
12314  mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
12315  kcc=mint(2)
12316  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12317 
12318  ELSEIF(isub.EQ.276.OR.isub.EQ.286.OR.isub.EQ.296) THEN
12319 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12320  mint(21)=isign(kfpr(isub,1),mint(15))
12321  mint(22)=isign(kfpr(isub,2),mint(16))
12322  kcc=mint(2)
12323  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12324 
12325  ELSEIF(isub.EQ.277.OR.isub.EQ.287) THEN
12326 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12327  isgn=1
12328  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12329  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12330  mint(22)=-mint(21)
12331  IF(mint(43).EQ.4) kcc=4
12332 
12333  ELSEIF(isub.EQ.278.OR.isub.EQ.288) THEN
12334 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12335  isgn=1
12336  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12337  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12338  mint(22)=-mint(21)
12339  IF(mint(43).EQ.4) kcc=4
12340 
12341  ELSEIF(isub.EQ.279.OR.isub.EQ.289) THEN
12342 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12343 C...pure LL + RR
12344  kcs=(-1)**int(1.5d0+pyr(0))
12345  mint(21)=isign(kfpr(isub,1),kcs)
12346  mint(22)=-mint(21)
12347  kcc=mint(2)+10
12348 
12349  ELSEIF(isub.EQ.280.OR.isub.EQ.290) THEN
12350 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12351  kcs=(-1)**int(1.5d0+pyr(0))
12352  mint(21)=isign(kfpr(isub,1),kcs)
12353  mint(22)=-mint(21)
12354  kcc=mint(2)+10
12355 
12356  ELSEIF(isub.EQ.294) THEN
12357 C...qj + g -> ~qj_L + ~g
12358  IF(mint(15).EQ.21) js=2
12359  i=mint(14+js)
12360  ia=iabs(i)
12361  mint(20+js)=isign(ksusy1+ia,i)
12362  mint(23-js)=ksusy1+21
12363  kcc=mint(2)+6
12364  IF(js.EQ.2) kcc=kcc+2
12365  kcs=isign(1,i)
12366 
12367  ELSEIF(isub.EQ.295) THEN
12368 C...qj + g -> ~qj_R + ~g
12369  IF(mint(15).EQ.21) js=2
12370  i=mint(14+js)
12371  ia=iabs(i)
12372  mint(20+js)=isign(ksusy2+ia,i)
12373  mint(23-js)=ksusy1+21
12374  kcc=mint(2)+6
12375  IF(js.EQ.2) kcc=kcc+2
12376  kcs=isign(1,i)
12377  ENDIF
12378 
12379  ELSEIF(isub.LE.330) THEN
12380  IF(isub.EQ.311)THEN
12381 C...g + g -> g* + g* (UED)
12382  kcc=mint(2)+12
12383  kcs=(-1)**int(1.5d0+pyr(0))
12384  mued(1)=472
12385  mued(2)=472
12386  mint(21)=iuedeq(472)
12387  mint(22)=iuedeq(472)
12388  ELSEIF(isub.EQ.312)THEN
12389 C...q + g -> q*_D + g*, q*_S + g*
12390 C...The two channels have the same cross section
12391  kkflmi=450
12392  IF(pyr(0).GT.0.5)kkflmi=456
12393  IF(mint(15).EQ.21) js=2
12394  kcc=mint(2)+6
12395  IF(mint(15).EQ.21)kcc=kcc+2
12396  IF(mint(15).NE.21)THEN
12397  kcs=isign(1,mint(15))
12398  mued(2)=472
12399  mued(1)=kcs*(kkflmi+iabs(mint(15)))
12400  mint(22)=iuedeq(472)
12401  mint(21)=kcs*iuedeq(kkflmi+iabs(mint(15)))
12402  ENDIF
12403  IF(mint(16).NE.21)THEN
12404  kcs=isign(1,mint(16))
12405  mued(2)=kcs*(kkflmi+iabs(mint(16)))
12406  mued(1)=472
12407  mint(22)=kcs*iuedeq(kkflmi+iabs(mint(16)))
12408  mint(21)=iuedeq(472)
12409  ENDIF
12410  ELSEIF(isub.EQ.313)THEN
12411 C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12412 C...The two channels have the same cross section
12413  kkflmi=450
12414  IF(pyr(0).GT.0.5)kkflmi=456
12415  kcc=mint(2)
12416  IF(mint(15).EQ.mint(16))THEN
12417  mued(1)=sign(1,mint(15))*(kkflmi+iabs(mint(15)))
12418  mued(2)=mint(21)
12419  mint(21)=sign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12420  mint(22)=mint(21)
12421  ELSE
12422  mued(1)=sign(1,mint(15))*(kkflmi+iabs(mint(15)))
12423  mued(2)=sign(1,mint(16))*(kkflmi+iabs(mint(16)))
12424  mint(21)=sign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12425  mint(22)=sign(1,mint(16))*iuedeq(kkflmi+iabs(mint(16)))
12426  ENDIF
12427  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12428  ELSEIF(isub.EQ.314)THEN
12429 C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12430 C...The two channels have the same cross section
12431  kkflmi=450
12432  IF(pyr(0).GT.0.5)kkflmi=456
12433  kcs=(-1)**int(1.5d0+pyr(0))
12434  xflaout=pyr(0)
12435  IF(xflaout.LE.0.2)THEN
12436  mued(1)=isign(1,kcs)*(kkflmi+1)
12437  mint(21)=isign(1,kcs)*iuedeq(kkflmi+1)
12438  ELSEIF(xflaout.LE.0.4)THEN
12439  mued(1)=isign(1,kcs)*(kkflmi+2)
12440  mint(21)=isign(1,kcs)*iuedeq(kkflmi+2)
12441  ELSEIF(xflaout.LE.0.6)THEN
12442  mued(1)=isign(1,kcs)*(kkflmi+3)
12443  mint(21)=isign(1,kcs)*iuedeq(kkflmi+3)
12444  ELSEIF(xflaout.LE.0.8)THEN
12445  mued(1)=isign(1,kcs)*(kkflmi+4)
12446  mint(21)=isign(1,kcs)*iuedeq(kkflmi+4)
12447  ELSE
12448  mued(1)=isign(1,kcs)*(kkflmi+5)
12449  mint(21)=isign(1,kcs)*iuedeq(kkflmi+5)
12450  ENDIF
12451  mint(22)=-mint(21)
12452  mued(2)=-mued(1)
12453  kcc=mint(2)+10
12454  ELSEIF(isub.EQ.315)THEN
12455 C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12456 C...The two channels have the same cross section
12457  kkflmi=450
12458  IF(pyr(0).GT.0.5)kkflmi=456
12459  mued(1)=isign(1,mint(15))*(kkflmi+iabs(mint(15)))
12460  mued(2)=-mint(21)
12461  mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12462  mint(22)=-mint(21)
12463  kcc=4
12464  ELSEIF(isub.EQ.316)THEN
12465 C...q + qbar' -> q*_D + q*_S_bar'
12466  mued(1)=isign(1,mint(15))*(456+iabs(mint(15)))
12467  mued(2)=isign(1,mint(16))*(450+iabs(mint(16)))
12468  mint(21)=isign(1,mint(15))*iuedeq(456+iabs(mint(15)))
12469  mint(22)=isign(1,mint(16))*iuedeq(450+iabs(mint(16)))
12470  kcc=mint(2)+2
12471  ELSEIF(isub.EQ.317)THEN
12472 C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12473 C...The two channels have the same cross section
12474  kkflmi=450
12475  IF(pyr(0).GT.0.5)kkflmi=456
12476  mued(1)=isign(1,mint(15))*(kkflmi+iabs(mint(15)))
12477  mued(2)=isign(1,mint(16))*(kkflmi+iabs(mint(16)))
12478  mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12479  mint(22)=isign(1,mint(16))*iuedeq(kkflmi+iabs(mint(16)))
12480  kcc=mint(2)+2
12481  ELSEIF(isub.EQ.318)THEN
12482 C...q + q' -> q*_D + q*_S'
12483  kcc=mint(2)
12484  mued(1)=sign(1,mint(15))*(456+iabs(mint(15)))
12485  mued(2)=sign(1,mint(16))*(450+iabs(mint(16)))
12486  mint(21)=sign(1,mint(15))*iuedeq(456+iabs(mint(15)))
12487  mint(22)=sign(1,mint(16))*iuedeq(450+iabs(mint(16)))
12488  ELSEIF(isub.EQ.319)THEN
12489 C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12490 C...The two channels have the same cross section
12491  kkflmi=450
12492  IF(pyr(0).GT.0.5)kkflmi=456
12493  xflaout=pyr(0)
12494  iiflav=0
12495 C...N.B. NFLAVOURS=IUED(3)
12496 C DO I=1,NFLAVOURS
12497  DO 433 i=1,iued(3)
12498  IF(i.NE.iabs(mint(15)))THEN
12499  iiflav=iiflav+1
12500  iokfla(iiflav)=i
12501  ENDIF
12502  433 CONTINUE
12503  flastep=1./(iued(3)-1)
12504  DO i=1,iued(3)-1
12505  flavv=flastep*i
12506  IF(xflaout.LE.flavv)THEN
12507  mued(1)=isign(1,mint(15))*(kkflmi+iokfla(i))
12508  mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iokfla(i))
12509  GOTO 435
12510  ENDIF
12511  ENDDO
12512  435 CONTINUE
12513  IF(iabs(mued(1)).LT.451.AND.iabs(mued(1)).GT.462)THEN
12514  WRITE(mstu(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12515  CALL pystop(5000000)
12516  ENDIF
12517  mint(22)=-mint(21)
12518  kcc=4
12519  ENDIF
12520 
12521  ELSEIF(isub.LE.340) THEN
12522 
12523  IF(isub.EQ.297.OR.isub.EQ.298) THEN
12524 C...q + qbar' -> H+ + H0
12525  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12526  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12527  IF(mint(15)*(kch1+kch2).GT.0) js=2
12528  mint(20+js)=isign(37,kch1+kch2)
12529  mint(23-js)=kfpr(isub,2)
12530  ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
12531 C...f + fbar -> A0 + H0; th arbitrary
12532  IF(pyr(0).GT.0.5d0) js=2
12533  mint(20+js)=kfpr(isub,1)
12534  mint(23-js)=kfpr(isub,2)
12535  ELSEIF(isub.EQ.301) THEN
12536 C...f + fbar -> H+ H-
12537  mint(21)=isign(kfpr(isub,1),kcs)
12538  mint(22)=-mint(21)
12539  ENDIF
12540 CMRENNA--
12541 
12542  ELSEIF(isub.LE.360) THEN
12543 
12544  IF(isub.EQ.341.OR.isub.EQ.342) THEN
12545 C...l + l -> H_L++/--, H_R++/--
12546  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12547  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12548  kfres=isign(kfpr(isub,1),kch1+kch2)
12549 
12550  ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
12551 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12552  IF(mint(15).EQ.22) js=2
12553  mint(20+js)=isign(kfpr(isub,1),-mint(14+js))
12554  mint(23-js)=isign(kfpr(isub,2),-mint(14+js))
12555  kcc=22
12556 
12557  ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
12558 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12559  mint(21)=-isign(kfpr(isub,1),mint(15))
12560  mint(22)=-mint(21)
12561 
12562  ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
12563 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12564 C...as inner process).
12565  DO 450 jt=1,2
12566  i=mint(14+jt)
12567  ia=iabs(i)
12568  IF(ia.LE.10) THEN
12569  rvckm=vint(180+i)*pyr(0)
12570  DO 440 j=1,mstp(1)
12571  ib=2*j-1+mod(ia,2)
12572  ipm=(5-isign(1,i))/2
12573  idc=j+mdcy(ia,2)+2
12574  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 440
12575  mint(20+jt)=isign(ib,i)
12576  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
12577  IF(rvckm.LE.0d0) GOTO 450
12578  440 CONTINUE
12579  ELSE
12580  ib=2*((ia+1)/2)-1+mod(ia,2)
12581  mint(20+jt)=isign(ib,i)
12582  ENDIF
12583  450 CONTINUE
12584  kcc=22
12585  kfres=isign(kfpr(isub,1),mint(15))
12586  IF(mod(mint(15),2).EQ.1) kfres=-kfres
12587 
12588  ELSEIF(isub.EQ.353) THEN
12589 C...f + fbar -> Z_R0
12590  kfres=kfpr(isub,1)
12591 
12592  ELSEIF(isub.EQ.354) THEN
12593 C...f + fbar' -> W+/-
12594  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12595  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12596  kfres=isign(kfpr(isub,1),kch1+kch2)
12597 
12598  ENDIF
12599 
12600  ELSEIF(isub.LE.380) THEN
12601 
12602  IF(isub.LE.363.OR.isub.EQ.368) THEN
12603 C...f + fbar -> charged+ charged- technicolor
12604  ksw=(-1)**int(1.5d0+pyr(0))
12605  mint(21)=isign(kfpr(isub,1),ksw)
12606  mint(22)=-isign(kfpr(isub,2),ksw)
12607 
12608  ELSEIF(isub.LE.367.OR.isub.EQ.379.OR.isub.EQ.380) THEN
12609 C...f + fbar -> neutral neutral technicolor
12610  mint(21)=kfpr(isub,1)
12611  mint(22)=kfpr(isub,2)
12612 
12613  ELSEIF(isub.EQ.374.OR.isub.EQ.375.OR.isub.EQ.378) THEN
12614 C...f + fbar' -> neutral charged technicolor
12615  in=1
12616  ic=2
12617  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12618  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12619  IF(mint(15)*(kch1+kch2).LT.0) js=2
12620  mint(23-js)=isign(kfpr(isub,ic),kch1+kch2)
12621  mint(20+js)=kfpr(isub,in)
12622 
12623  ELSEIF(isub.GE.370.AND.isub.LE.377) THEN
12624 C...f + fbar' -> charged neutral technicolor
12625  in=2
12626  ic=1
12627  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12628  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12629  IF(mint(15)*(kch1+kch2).GT.0) js=2
12630  mint(20+js)=isign(kfpr(isub,ic),kch1+kch2)
12631  mint(23-js)=kfpr(isub,in)
12632  ENDIF
12633 
12634  ELSEIF(isub.LE.400) THEN
12635  IF(isub.EQ.381) THEN
12636 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12637  kcc=mint(2)
12638  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12639 
12640  ELSEIF(isub.EQ.382) THEN
12641 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12642  mint(21)=isign(kflf,mint(15))
12643  mint(22)=-mint(21)
12644  kcc=4
12645 
12646  ELSEIF(isub.EQ.383) THEN
12647 C...f + fbar -> g + g; th arbitrary, TC extensions
12648  mint(21)=21
12649  mint(22)=21
12650  kcc=mint(2)+4
12651 
12652  ELSEIF(isub.EQ.384) THEN
12653 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12654  IF(mint(15).EQ.21) js=2
12655  kcc=mint(2)+6
12656  IF(mint(15).EQ.21) kcc=kcc+2
12657  IF(mint(15).NE.21) kcs=isign(1,mint(15))
12658  IF(mint(16).NE.21) kcs=isign(1,mint(16))
12659 
12660  ELSEIF(isub.EQ.385) THEN
12661 C...g + g -> f + fbar; th arbitrary, TC extensions
12662  kcs=(-1)**int(1.5d0+pyr(0))
12663  mint(21)=isign(kflf,kcs)
12664  mint(22)=-mint(21)
12665  kcc=mint(2)+10
12666 
12667  ELSEIF(isub.EQ.386) THEN
12668 C...g + g -> g + g; th arbitrary, TC extensions
12669  kcc=mint(2)+12
12670  kcs=(-1)**int(1.5d0+pyr(0))
12671 
12672  ELSEIF(isub.EQ.387) THEN
12673 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12674  mint(21)=isign(mint(55),mint(15))
12675  mint(22)=-mint(21)
12676  kcc=4
12677 
12678  ELSEIF(isub.EQ.388) THEN
12679 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12680  kcs=(-1)**int(1.5d0+pyr(0))
12681  mint(21)=isign(mint(55),kcs)
12682  mint(22)=-mint(21)
12683  kcc=mint(2)+10
12684 
12685  ELSEIF(isub.EQ.391) THEN
12686 C...f + fbar -> G*.
12687  kfres=kfpr(isub,1)
12688 
12689  ELSEIF(isub.EQ.392) THEN
12690 C...g + g -> G*.
12691  kcc=21
12692  kfres=kfpr(isub,1)
12693 
12694  ELSEIF(isub.EQ.393) THEN
12695 C...q + qbar -> g + G*; th arbitrary.
12696  IF(pyr(0).GT.0.5d0) js=2
12697  mint(20+js)=kfpr(isub,1)
12698  mint(23-js)=kfpr(isub,2)
12699  kcc=17+js
12700 
12701  ELSEIF(isub.EQ.394) THEN
12702 C...q + g -> q + G*; th = (p(f) - p(f))**2
12703  IF(mint(15).EQ.21) js=2
12704  mint(23-js)=kfpr(isub,2)
12705  kcc=15+js
12706  kcs=isign(1,mint(14+js))
12707 
12708  ELSEIF(isub.EQ.395) THEN
12709 C...g + g -> G* + g; th arbitrary.
12710  IF(pyr(0).GT.0.5d0) js=2
12711  mint(23-js)=kfpr(isub,2)
12712  kcc=22+js
12713  ENDIF
12714 
12715  ELSEIF(isub.LE.420) THEN
12716  IF(isub.EQ.401) THEN
12717 C...g + g -> t + b + H+/-
12718  kcs=(-1)**int(1.5d0+pyr(0))
12719  mint(21)=isign(kfpr(isubsv,2),kcs)
12720  mint(22)=isign(5,-kcs)
12721  kcc=11+int(0.5d0+pyr(0))
12722  kfres=isign(kfhigg,-kcs)
12723 
12724  ELSEIF(isub.EQ.402) THEN
12725 C...q + qbar -> t + b + H+/-
12726  kfl=(-1)**int(1.5d0+pyr(0))
12727  mint(21)=isign(int(6.+.5*kfl),kcs)
12728  mint(22)=isign(int(6.-.5*kfl),-kcs)
12729  kcc=4
12730  kfres=isign(kfhigg,-kfl*kcs)
12731  ENDIF
12732 
12733 C...QUARKONIA+++
12734 C...Additional code by Stefan Wolf
12735  ELSEIF(isub.LE.430) THEN
12736  IF(isub.GE.421.AND.isub.LE.424) THEN
12737 C...g + g -> QQ~[n] + g
12738 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12739 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12740 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12741 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12742 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12743 C...[g + g -> g + g; th arbitrary]
12744  mint(21)=kfpr(isubsv,1)
12745  mint(22)=kfpr(isubsv,2)
12746  IF(isub.EQ.421) THEN
12747  kcc=24
12748  kcs=(-1)**int(1.5d0+pyr(0))
12749  ELSE
12750  kcc=mint(2)+12
12751  kcs=(-1)**int(1.5d0+pyr(0))
12752  ENDIF
12753 
12754  ELSEIF(isub.GE.425.AND.isub.LE.427) THEN
12755 C...q + g -> q + QQ~[n]
12756 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12757 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12758 C...KCC copied from ISUB.EQ.28
12759 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12760  IF(mint(15).EQ.21) js=2
12761  mint(23-js)=kfpr(isubsv,2)
12762  kcc=mint(2)+6
12763  IF(mint(15).EQ.21) kcc=kcc+2
12764  IF(mint(15).NE.21) kcs=isign(1,mint(15))
12765  IF(mint(16).NE.21) kcs=isign(1,mint(16))
12766 
12767  ELSEIF(isub.GE.428.AND.isub.LE.430) THEN
12768 C...q + q~ -> g + QQ~[n]
12769 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12770 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12771 C...KCC copied from ISUB.EQ.13
12772 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12773  IF(pyr(0).GT.0.5) js=2
12774  mint(20+js)=21
12775  mint(23-js)=kfpr(isubsv,2)
12776  kcc=mint(2)+4
12777  ENDIF
12778 
12779  ELSEIF(isub.LE.440) THEN
12780  IF(isub.GE.431.AND.isub.LE.433) THEN
12781 C...g + g -> QQ~[n] + g
12782 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12783 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12784 C...KCC and KCS copied from ISUB.EQ.86-89
12785 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12786  mint(21)=kfpr(isubsv,1)
12787  mint(22)=kfpr(isubsv,2)
12788  kcc=24
12789  kcs=(-1)**int(1.5d0+pyr(0))
12790 
12791  ELSEIF(isub.GE.434.AND.isub.LE.436) THEN
12792 C...q + g -> q + QQ~[n]
12793 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12794 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12795 C...KCC and KCS copied from ISUB.EQ.112
12796 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12797  IF(mint(15).EQ.21) js=2
12798  mint(23-js)=kfpr(isubsv,2)
12799  kcc=15+js
12800  kcs=isign(1,mint(14+js))
12801 
12802  ELSEIF(isub.GE.437.AND.isub.LE.439) THEN
12803 C...q + q~ -> g + QQ~[n]
12804 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12805 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12806 C...KCC copied from ISUB.EQ.111
12807 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12808  IF(pyr(0).GT.0.5) js=2
12809  mint(20+js)=21
12810  mint(23-js)=kfpr(isubsv,2)
12811  kcc=17+js
12812  ENDIF
12813 C...QUARKONIA---
12814 
12815  ENDIF
12816 
12817  IF(iset(isub).EQ.11) THEN
12818 C...Store documentation for user-defined processes
12819  bezup=(pup(3,1)+pup(3,2))/(pup(4,1)+pup(4,2))
12820  kuppo(1)=mint(83)+5
12821  kuppo(2)=mint(83)+6
12822  i=mint(83)+6
12823  DO 470 iup=3,nup
12824  kuppo(iup)=0
12825  IF(mstp(128).GE.2.AND.mothup(1,iup).GE.3) THEN
12826  idoc=idoc-1
12827  mint(4)=mint(4)-1
12828  GOTO 470
12829  ENDIF
12830  i=i+1
12831  kuppo(iup)=i
12832  k(i,1)=21
12833  k(i,2)=idup(iup)
12834  IF(idup(iup).EQ.0) k(i,2)=90
12835  k(i,3)=0
12836  IF(mothup(1,iup).GE.3) k(i,3)=kuppo(mothup(1,iup))
12837  k(i,4)=0
12838  k(i,5)=0
12839  DO 460 j=1,5
12840  p(i,j)=pup(j,iup)
12841  460 CONTINUE
12842  v(i,5)=vtimup(iup)
12843  470 CONTINUE
12844  CALL pyrobo(mint(83)+7,mint(83)+4+nup,0d0,vint(24),0d0,0d0,
12845  & -bezup)
12846 
12847 C...Store final state partons for user-defined processes
12848  n=ipu2
12849  DO 490 iup=3,nup
12850  n=n+1
12851  k(n,1)=1
12852  IF(istup(iup).EQ.2.OR.istup(iup).EQ.3) k(n,1)=11
12853  k(n,2)=idup(iup)
12854  IF(idup(iup).EQ.0) k(n,2)=90
12855  IF(mstp(128).LE.0.OR.mothup(1,iup).EQ.0) THEN
12856  k(n,3)=kuppo(iup)
12857  ELSE
12858  k(n,3)=mint(84)+mothup(1,iup)
12859  ENDIF
12860  k(n,4)=0
12861  k(n,5)=0
12862 C...Search for daughters of intermediate colourless particles.
12863  IF(k(n,1).EQ.11.AND.kchg(pycomp(k(n,2)),2).EQ.0) THEN
12864  DO 475 iupdau=iup+1,nup
12865  IF(mothup(1,iupdau).EQ.iup.AND.k(n,4).EQ.0) k(n,4)=
12866  & n+iupdau-iup
12867  IF(mothup(1,iupdau).EQ.iup) k(n,5)=n+iupdau-iup
12868  475 CONTINUE
12869  ENDIF
12870  DO 480 j=1,5
12871  p(n,j)=pup(j,iup)
12872  480 CONTINUE
12873  v(n,5)=vtimup(iup)
12874  490 CONTINUE
12875  CALL pyrobo(ipu3,n,0d0,vint(24),0d0,0d0,-bezup)
12876 
12877 C...Arrange colour flow for user-defined processes
12878  nlbl=0
12879  DO 540 iup1=1,nup
12880  i1=mint(84)+iup1
12881  IF(kchg(pycomp(k(i1,2)),2).EQ.0) GOTO 540
12882  IF(k(i1,1).EQ.1) k(i1,1)=3
12883  IF(k(i1,1).EQ.11) k(i1,1)=14
12884 C...Find a not yet considered colour/anticolour line.
12885  DO 530 isde1=1,2
12886  IF(icolup(isde1,iup1).EQ.0) GOTO 530
12887  nmat=0
12888  DO 500 ilbl=1,nlbl
12889  IF(icolup(isde1,iup1).EQ.ilab(ilbl)) nmat=1
12890  500 CONTINUE
12891  IF(nmat.EQ.0) THEN
12892  nlbl=nlbl+1
12893  ilab(nlbl)=icolup(isde1,iup1)
12894 C...Find all others belonging to same line.
12895  i3=i1
12896  i4=0
12897  DO 520 iup2=iup1+1,nup
12898  i2=mint(84)+iup2
12899  DO 510 isde2=1,2
12900  IF(icolup(isde2,iup2).EQ.icolup(isde1,iup1)) THEN
12901  IF(isde2.EQ.isde1) THEN
12902  k(i3,3+isde2)=k(i3,3+isde2)+i2
12903  k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i3
12904  i3=i2
12905  ELSEIF(i4.NE.0) THEN
12906  k(i4,3+isde2)=k(i4,3+isde2)+i2
12907  k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i4
12908  i4=i2
12909  ELSEIF(iup2.LE.2) THEN
12910  k(i1,3+isde1)=k(i1,3+isde1)+i2
12911  k(i2,3+isde2)=k(i2,3+isde2)+i1
12912  i4=i2
12913  ELSE
12914  k(i1,3+isde1)=k(i1,3+isde1)+mstu(5)*i2
12915  k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i1
12916  i4=i2
12917  ENDIF
12918  ENDIF
12919  510 CONTINUE
12920  520 CONTINUE
12921  ENDIF
12922  530 CONTINUE
12923  540 CONTINUE
12924 
12925  ELSEIF(idoc.EQ.7) THEN
12926 C...Resonance not decaying; store kinematics
12927  i=mint(83)+7
12928  k(ipu3,1)=1
12929  k(ipu3,2)=kfres
12930  k(ipu3,3)=i
12931  p(ipu3,4)=shuser
12932  p(ipu3,5)=shuser
12933  k(i,1)=21
12934  k(i,2)=kfres
12935  p(i,4)=shuser
12936  p(i,5)=shuser
12937  n=ipu3
12938  mint(21)=kfres
12939  mint(22)=0
12940 
12941 C...Special cases: colour flow in coloured resonances
12942  kcres=pycomp(kfres)
12943  IF(kchg(kcres,2).NE.0) THEN
12944  k(ipu3,1)=3
12945  DO 550 j=1,2
12946  jc=j
12947  IF(kcs.EQ.-1) jc=3-j
12948  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
12949  & mint(84)+icol(kcc,1,jc)
12950  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
12951  & mint(84)+icol(kcc,2,jc)
12952  IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
12953  & mstu(5)*(mint(84)+icol(kcc,3,jc))
12954  550 CONTINUE
12955  ELSE
12956  k(ipu1,4)=ipu2
12957  k(ipu1,5)=ipu2
12958  k(ipu2,4)=ipu1
12959  k(ipu2,5)=ipu1
12960  ENDIF
12961 
12962  ELSEIF(idoc.EQ.8) THEN
12963 C...2 -> 2 processes: store outgoing partons in their CM-frame
12964  DO 560 jt=1,2
12965  i=mint(84)+2+jt
12966  kca=pycomp(mint(20+jt))
12967  k(i,1)=1
12968  IF(kchg(kca,2).NE.0) k(i,1)=3
12969  k(i,2)=mint(20+jt)
12970  k(i,3)=mint(83)+idoc+jt-2
12971  kfaa=iabs(k(i,2))
12972  IF(kfpr(isubsv,1+mod(js+jt,2)).NE.0) THEN
12973  p(i,5)=sqrt(vint(63+mod(js+jt,2)))
12974  ELSE
12975  p(i,5)=pymass(k(i,2))
12976  ENDIF
12977  IF((kfaa.EQ.6.OR.kfaa.EQ.7.OR.kfaa.EQ.8).AND.
12978  & p(i,5).LT.parp(42)) p(i,5)=pymass(k(i,2))
12979  560 CONTINUE
12980  IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN
12981  kfa1=iabs(mint(21))
12982  kfa2=iabs(mint(22))
12983  IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))
12984  & THEN
12985  mint(51)=1
12986  RETURN
12987  ENDIF
12988  p(ipu3,5)=0d0
12989  p(ipu4,5)=0d0
12990  ENDIF
12991  p(ipu3,4)=0.5d0*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr)
12992  p(ipu3,3)=sqrt(max(0d0,p(ipu3,4)**2-p(ipu3,5)**2))
12993  p(ipu4,4)=shr-p(ipu3,4)
12994  p(ipu4,3)=-p(ipu3,3)
12995  n=ipu4
12996  mint(7)=mint(83)+7
12997  mint(8)=mint(83)+8
12998 
12999 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13000  CALL pyrobo(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)
13001 
13002  ELSEIF(idoc.EQ.9) THEN
13003 C...2 -> 3 processes: store outgoing partons in their CM frame
13004  DO 570 jt=1,2
13005  i=mint(84)+2+jt
13006  kca=pycomp(mint(20+jt))
13007  k(i,1)=1
13008  IF(kchg(kca,2).NE.0) k(i,1)=3
13009  k(i,2)=mint(20+jt)
13010  k(i,3)=mint(83)+idoc+jt-3
13011  jta=jt
13012 C...t and b in opposide order in event list as compared to
13013 C...matrix element?
13014  IF(isub.EQ.402.AND.iabs(mint(21)).EQ.5) jta=3-jt
13015  IF(iabs(k(i,2)).LE.22) THEN
13016  p(i,5)=pymass(k(i,2))
13017  ELSE
13018  p(i,5)=sqrt(vint(63+mod(js+jta,2)))
13019  ENDIF
13020  pt=sqrt(max(0d0,vint(197+5*jta)-p(i,5)**2+vint(196+5*jta)**2))
13021  p(i,1)=pt*cos(vint(198+5*jta))
13022  p(i,2)=pt*sin(vint(198+5*jta))
13023  570 CONTINUE
13024  k(ipu5,1)=1
13025  k(ipu5,2)=kfres
13026  k(ipu5,3)=mint(83)+idoc
13027  p(ipu5,5)=shr
13028  p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
13029  p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
13030  pms1=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
13031  pms2=p(ipu4,5)**2+p(ipu4,1)**2+p(ipu4,2)**2
13032  pms3=p(ipu5,5)**2+p(ipu5,1)**2+p(ipu5,2)**2
13033  pmt3=sqrt(pms3)
13034  p(ipu5,3)=pmt3*sinh(vint(211))
13035  p(ipu5,4)=pmt3*cosh(vint(211))
13036  pms12=(shpr-p(ipu5,4))**2-p(ipu5,3)**2
13037  sql12=(pms12-pms1-pms2)**2-4d0*pms1*pms2
13038  IF(sql12.LE.0d0) THEN
13039  mint(51)=1
13040  RETURN
13041  ENDIF
13042  p(ipu3,3)=(-p(ipu5,3)*(pms12+pms1-pms2)+
13043  & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
13044  p(ipu4,3)=-p(ipu3,3)-p(ipu5,3)
13045  IF(isub.EQ.402.AND.iabs(mint(21)).EQ.5) THEN
13046 C...t and b in opposide order in event list as compared to
13047 C...matrix element
13048  p(ipu4,3)=(-p(ipu5,3)*(pms12+pms2-pms1)+
13049  & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
13050  p(ipu3,3)=-p(ipu4,3)-p(ipu5,3)
13051  END IF
13052  p(ipu3,4)=sqrt(pms1+p(ipu3,3)**2)
13053  p(ipu4,4)=sqrt(pms2+p(ipu4,3)**2)
13054  mint(23)=kfres
13055  n=ipu5
13056  mint(7)=mint(83)+7
13057  mint(8)=mint(83)+8
13058 
13059  ELSEIF(idoc.EQ.11) THEN
13060 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13061  phi(1)=paru(2)*pyr(0)
13062  phi(2)=phi(1)-phir
13063  DO 580 jt=1,2
13064  i=mint(84)+2+jt
13065  k(i,1)=1
13066  IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
13067  k(i,2)=mint(20+jt)
13068  k(i,3)=mint(83)+idoc+jt-2
13069  p(i,5)=pymass(k(i,2))
13070  IF(0.5d0*shpr*z(jt).LE.p(i,5)) THEN
13071  mint(51)=1
13072  RETURN
13073  ENDIF
13074  pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
13075  ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
13076  p(i,1)=ptabs*cos(phi(jt))
13077  p(i,2)=ptabs*sin(phi(jt))
13078  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13079  p(i,4)=0.5d0*shpr*z(jt)
13080  izw=mint(83)+6+jt
13081  k(izw,1)=21
13082  k(izw,2)=23
13083  IF(isub.EQ.8) k(izw,2)=isign(24,pychge(mint(14+jt)))
13084  k(izw,3)=izw-2
13085  p(izw,1)=-p(i,1)
13086  p(izw,2)=-p(i,2)
13087  p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13088  p(izw,4)=0.5d0*shpr*(1d0-z(jt))
13089  p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13090  580 CONTINUE
13091  i=mint(83)+9
13092  k(ipu5,1)=1
13093  k(ipu5,2)=kfres
13094  k(ipu5,3)=i
13095  p(ipu5,5)=shr
13096  p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
13097  p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
13098  p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)
13099  p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)
13100  k(i,1)=21
13101  k(i,2)=kfres
13102  DO 590 j=1,5
13103  p(i,j)=p(ipu5,j)
13104  590 CONTINUE
13105  n=ipu5
13106  mint(23)=kfres
13107 
13108  ELSEIF(idoc.EQ.12) THEN
13109 C...Z0 and W+/- scattering: store bosons and outgoing partons
13110  phi(1)=paru(2)*pyr(0)
13111  phi(2)=phi(1)-phir
13112  jtran=int(1.5d0+pyr(0))
13113  DO 600 jt=1,2
13114  i=mint(84)+2+jt
13115  k(i,1)=1
13116  IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
13117  k(i,2)=mint(20+jt)
13118  k(i,3)=mint(83)+idoc+jt-2
13119  p(i,5)=pymass(k(i,2))
13120  IF(0.5d0*shpr*z(jt).LE.p(i,5)) p(i,5)=0d0
13121  pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
13122  ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
13123  p(i,1)=ptabs*cos(phi(jt))
13124  p(i,2)=ptabs*sin(phi(jt))
13125  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13126  p(i,4)=0.5d0*shpr*z(jt)
13127  izw=mint(83)+6+jt
13128  k(izw,1)=21
13129  IF(mint(14+jt).EQ.mint(20+jt)) THEN
13130  k(izw,2)=23
13131  ELSE
13132  k(izw,2)=isign(24,pychge(mint(14+jt))-pychge(mint(20+jt)))
13133  ENDIF
13134  k(izw,3)=izw-2
13135  p(izw,1)=-p(i,1)
13136  p(izw,2)=-p(i,2)
13137  p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13138  p(izw,4)=0.5d0*shpr*(1d0-z(jt))
13139  p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13140  ipu=mint(84)+4+jt
13141  k(ipu,1)=3
13142  k(ipu,2)=kfpr(isub,jt)
13143  IF(isub.EQ.72.AND.jt.EQ.jtran) k(ipu,2)=-k(ipu,2)
13144  IF(isub.EQ.73.OR.isub.EQ.77) k(ipu,2)=k(izw,2)
13145  k(ipu,3)=mint(83)+8+jt
13146  IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN
13147  p(ipu,5)=pymass(k(ipu,2))
13148  ELSE
13149  p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))
13150  ENDIF
13151  mint(22+jt)=k(ipu,2)
13152  600 CONTINUE
13153 C...Find rotation and boost for hard scattering subsystem
13154  i1=mint(83)+7
13155  i2=mint(83)+8
13156  bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))
13157  beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))
13158  bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))
13159  gamcm=(p(i1,4)+p(i2,4))/shr
13160  bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3)
13161  px=p(i1,1)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bexcm
13162  py=p(i1,2)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*beycm
13163  pz=p(i1,3)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bezcm
13164  thecm=pyangl(pz,sqrt(px**2+py**2))
13165  phicm=pyangl(px,py)
13166 C...Store hard scattering subsystem. Rotate and boost it
13167  sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4d0*p(ipu5,5)**2*
13168  & p(ipu6,5)**2
13169  pabs=sqrt(max(0d0,sqlam/(4d0*sh)))
13170  cthwz=vint(23)
13171  sthwz=sqrt(max(0d0,1d0-cthwz**2))
13172  phiwz=vint(24)-phicm
13173  p(ipu5,1)=pabs*sthwz*cos(phiwz)
13174  p(ipu5,2)=pabs*sthwz*sin(phiwz)
13175  p(ipu5,3)=pabs*cthwz
13176  p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)
13177  p(ipu6,1)=-p(ipu5,1)
13178  p(ipu6,2)=-p(ipu5,2)
13179  p(ipu6,3)=-p(ipu5,3)
13180  p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)
13181  CALL pyrobo(ipu5,ipu6,thecm,phicm,bexcm,beycm,bezcm)
13182  DO 620 jt=1,2
13183  i1=mint(83)+8+jt
13184  i2=mint(84)+4+jt
13185  k(i1,1)=21
13186  k(i1,2)=k(i2,2)
13187  DO 610 j=1,5
13188  p(i1,j)=p(i2,j)
13189  610 CONTINUE
13190  620 CONTINUE
13191  n=ipu6
13192  mint(7)=mint(83)+9
13193  mint(8)=mint(83)+10
13194  ENDIF
13195 
13196  IF(iset(isub).EQ.11) THEN
13197  ELSEIF(idoc.GE.8) THEN
13198 C...Store colour connection indices
13199  DO 630 j=1,2
13200  jc=j
13201  IF(kcs.EQ.-1) jc=3-j
13202  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13203  & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)
13204  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13205  & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)
13206  IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
13207  & mstu(5)*(mint(84)+icol(kcc,3,jc))
13208  IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
13209  & mstu(5)*(mint(84)+icol(kcc,4,jc))
13210  630 CONTINUE
13211 
13212 C...Copy outgoing partons to documentation lines
13213  imax=2
13214  IF(idoc.EQ.9) imax=3
13215  DO 650 i=1,imax
13216  i1=mint(83)+idoc-imax+i
13217  i2=mint(84)+2+i
13218  k(i1,1)=21
13219  k(i1,2)=k(i2,2)
13220  IF(idoc.LE.9) k(i1,3)=0
13221  IF(idoc.GE.11) k(i1,3)=mint(83)+2+i
13222  DO 640 j=1,5
13223  p(i1,j)=p(i2,j)
13224  640 CONTINUE
13225  650 CONTINUE
13226 
13227  ELSEIF(idoc.EQ.9) THEN
13228 C...Store colour connection indices
13229  DO 660 j=1,2
13230  jc=j
13231  IF(kcs.EQ.-1) jc=3-j
13232  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13233  & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)+
13234  & max(0,min(1,icol(kcc,1,jc)-2))
13235  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13236  & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)+
13237  & max(0,min(1,icol(kcc,2,jc)-2))
13238  IF(icol(kcc,3,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
13239  & mstu(5)*(mint(84)+icol(kcc,3,jc))
13240  IF(icol(kcc,4,jc).NE.0.AND.k(ipu5,1).EQ.3) k(ipu5,j+3)=
13241  & mstu(5)*(mint(84)+icol(kcc,4,jc))
13242  660 CONTINUE
13243 
13244 C...Copy outgoing partons to documentation lines
13245  DO 680 i=1,3
13246  i1=mint(83)+idoc-3+i
13247  i2=mint(84)+2+i
13248  k(i1,1)=21
13249  k(i1,2)=k(i2,2)
13250  k(i1,3)=0
13251  DO 670 j=1,5
13252  p(i1,j)=p(i2,j)
13253  670 CONTINUE
13254  680 CONTINUE
13255  ENDIF
13256 
13257 C...Copy outgoing partons to list of allowed radiators.
13258  npart=0
13259  IF(mint(35).GE.2.AND.iset(isub).NE.0) THEN
13260  DO 690 i=mint(84)+3,n
13261  npart=npart+1
13262  ipart(npart)=i
13263  ptpart(npart)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2)
13264  690 CONTINUE
13265  ENDIF
13266 
13267 C...Low-pT events: remove gluons used for string drawing purposes
13268  IF(isub.EQ.95) THEN
13269  IF(mint(35).LE.1) THEN
13270  k(ipu3,1)=k(ipu3,1)+10
13271  k(ipu4,1)=k(ipu4,1)+10
13272  ENDIF
13273  DO 700 j=41,66
13274  vintsv(j)=vint(j)
13275  vint(j)=0d0
13276  700 CONTINUE
13277  DO 720 i=mint(83)+5,mint(83)+8
13278  DO 710 j=1,5
13279  p(i,j)=0d0
13280  710 CONTINUE
13281  720 CONTINUE
13282  ENDIF
13283 
13284  RETURN
13285  END
13286 
13287 C***********************************************************************
13288 
13289 C...PYEVOL
13290 C...Handles intertwined pT-ordered spacelike initial-state parton
13291 C...and multiple interactions.
13292 
13293  SUBROUTINE pyevol(MODE,PT2MAX,PT2MIN)
13294 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13295 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13296 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13297 
13298 C...Double precision and integer declarations.
13299  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13300  IMPLICIT INTEGER(I-N)
13301  INTEGER PYK,PYCHGE,PYCOMP
13302 C...External
13303  EXTERNAL pyalps
13304  DOUBLE PRECISION PYALPS
13305 C...Parameter statement for maximum size of showers.
13306  parameter(maxnur=1000)
13307 C...Commonblocks.
13308  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
13309  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13310  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13311  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
13312  common/pypars/mstp(200),parp(200),msti(200),pari(200)
13313  common/pyint1/mint(400),vint(400)
13314  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
13315  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13316  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
13317  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
13318  & xmi(2,240),pt2mi(240),imisep(0:240)
13319  common/pyctag/nct,mct(4000,2)
13320  common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
13321  & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
13322  common/pyisjn/mjn1mx,mjn2mx,mjoind(2,240)
13323 C...Local arrays and saved variables.
13324  dimension vintsv(11:80),ksav(4,5),psav(4,5),vsav(4,5),shat(240)
13325  SAVE nsav,nparts,m15sv,m16sv,m21sv,m22sv,vintsv,shat,isubhd,alam3
13326  & ,psav,ksav,vsav
13327 
13328  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,
13329  & /pyint2/,/pyint3/,/pyintm/,/pyctag/,/pyismx/,/pyisjn/
13330 
13331 C----------------------------------------------------------------------
13332 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13333 C...done only once per event, while MODE=0 is repeated each time the
13334 C...evolution needs to be restarted.
13335  IF (mode.EQ.-1) THEN
13336  isubhd=mint(1)
13337  nsav=n
13338  nparts=npart
13339 C...Store hard scattering variables
13340  m15sv=mint(15)
13341  m16sv=mint(16)
13342  m21sv=mint(21)
13343  m22sv=mint(22)
13344  DO 100 j=11,80
13345  vintsv(j)=vint(j)
13346  100 CONTINUE
13347  DO 120 j=1,5
13348  DO 110 is=1,4
13349  i=is+mint(84)
13350  psav(is,j)=p(i,j)
13351  ksav(is,j)=k(i,j)
13352  vsav(is,j)=v(i,j)
13353  110 CONTINUE
13354  120 CONTINUE
13355 
13356 C...Set shat for hardest scattering
13357  shat(1)=vint(44)
13358  IF(iset(isubhd).GE.3.AND.iset(isubhd).LE.5) shat(1)=vint(26)
13359  & *vint(2)
13360 
13361 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13362  rmc=pmas(4,1)
13363  rmb=pmas(5,1)
13364  alam4=parp(61)
13365  IF(mstu(112).LT.4) alam4=parp(61)*(parp(61)/rmc)**(2d0/25d0)
13366  IF(mstu(112).GT.4) alam4=parp(61)*(rmb/parp(61))**(2d0/25d0)
13367  alam3=alam4*(rmc/alam4)**(2d0/27d0)
13368 
13369 C----------------------------------------------------------------------
13370 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13371 C...interaction initiators, with no previous evolution. Check the input
13372 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13373 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13374 C...smaller than the CM energy / 2.)
13375  ELSEIF (mode.EQ.0) THEN
13376 C...Reset counters and switches
13377  n=nsav
13378  npart=nparts
13379  mint(30)=0
13380  mint(31)=1
13381  mint(36)=1
13382 C...Reset hard scattering variables
13383  mint(1)=isubhd
13384  DO 130 j=11,80
13385  vint(j)=vintsv(j)
13386  130 CONTINUE
13387  DO 150 j=1,5
13388  DO 140 is=1,4
13389  i=is+mint(84)
13390  p(i,j)=psav(is,j)
13391  k(i,j)=ksav(is,j)
13392  v(i,j)=vsav(is,j)
13393  p(mint(83)+4+is,j)=psav(is,j)
13394  v(mint(83)+4+is,j)=vsav(is,j)
13395  140 CONTINUE
13396  150 CONTINUE
13397 C...Reset statistics on activity in event.
13398  DO 160 j=351,359
13399  mint(j)=0
13400  vint(j)=0d0
13401  160 CONTINUE
13402 C...Reset extra companion reweighting factor
13403  vint(140)=1d0
13404 
13405 C...We do not generate MI for soft process (ISUB=95), but the
13406 C...initialization must be done regardless, for later purposes.
13407  mint(36)=1
13408 
13409 C...Initialize multiple interactions.
13410  CALL pyptmi(-1,ptdum1,ptdum2,ptdum3,idum)
13411  IF(mint(51).NE.0) RETURN
13412 
13413 C...Decide whether quarks in hard scattering were valence or sea
13414  pt2hd=vint(54)
13415  DO 170 js=1,2
13416  mint(30)=js
13417  CALL pyptmi(2,pt2hd,ptdum2,ptdum3,idum)
13418  IF(mint(51).NE.0) RETURN
13419  170 CONTINUE
13420 
13421 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13422  vint(18)=0d0
13423  pt2min=max(pt2min,(1.1d0*alam3)**2)
13424  IF (mstp(70).EQ.2) THEN
13425 C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13426  vint(18)=(parp(82)*(vint(1)/parp(89))**parp(90))**2
13427  ELSEIF (mstp(70).EQ.3) THEN
13428 C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13429  alpha0 = max(1d-6,parp(73))
13430  q20 = alam3**2/parp(64)
13431  IF (mstp(64).EQ.3) q20 = q20 * 1.661**2
13432  vint(18) = q20 * (exp(12*paru(1)/27d0/alpha0)-1d0)
13433  ENDIF
13434 C...Also store PT2MIN in VINT(17).
13435  180 vint(17)=pt2min
13436 
13437 C...Set FS masses zero now.
13438  vint(63)=0d0
13439  vint(64)=0d0
13440 
13441 C...Initialize IS showers with VINT(56) as max scale.
13442  pt2isr=vint(56)
13443  pt20=pt2min
13444  IF (mstp(70).EQ.0) THEN
13445  pt20=max(pt2min,parp(62)**2)
13446  ELSEIF (mstp(70).EQ.1) THEN
13447  pt20=max(pt2min,(parp(81)*(vint(1)/parp(89))**parp(90))**2)
13448  ENDIF
13449  CALL pyptis(-1,pt2isr,pt20,pt2dum,ifail)
13450  IF(mint(51).NE.0) RETURN
13451 
13452  RETURN
13453 
13454 C----------------------------------------------------------------------
13455 C...MODE= 1: Evolve event from PTMAX to PTMIN.
13456  ELSEIF (mode.EQ.1) THEN
13457 
13458 C...Skip if no phase space.
13459  190 IF (pt2max.LE.pt2min) GOTO 330
13460 
13461 C...Starting pT2 max scale (to be udpated successively).
13462  pt2cmx=pt2max
13463 
13464 C...Evolve two sides of the event to find which branches at highest pT.
13465  200 jsmx=-1
13466  mimx=0
13467  pt2mx=0d0
13468 
13469 C...Loop over current shower initiators.
13470  IF (mstp(61).GE.1) THEN
13471  DO 230 mi=1,mint(31)
13472  IF (mi.GE.2.AND.mstp(84).LE.0) GOTO 230
13473  isub=96
13474  IF (mi.EQ.1) isub=isubhd
13475  mint(1)=isub
13476  mint(36)=mi
13477 C...Set up shat, initiator x values, and x remaining in BR.
13478  vint(44)=shat(mi)
13479  vint(141)=xmi(1,mi)
13480  vint(142)=xmi(2,mi)
13481  vint(143)=1d0
13482  vint(144)=1d0
13483  DO 210 ji=1,mint(31)
13484  IF (ji.EQ.mint(36)) GOTO 210
13485  vint(143)=vint(143)-xmi(1,ji)
13486  vint(144)=vint(144)-xmi(2,ji)
13487  210 CONTINUE
13488 C...Loop over sides.
13489 C...Generate trial branchings for this interaction. The hardest
13490 C...branching so far is automatically updated if necessary in /PYISMX/.
13491  DO 220 js=1,2
13492  mint(30)=js
13493  pt20=pt2min
13494  IF (mstp(70).EQ.0) THEN
13495  pt20=max(pt2min,parp(62)**2)
13496  ELSEIF (mstp(70).EQ.1) THEN
13497  pt20=max(pt2min,
13498  & (parp(81)*(vint(1)/parp(89))**parp(90))**2)
13499  ENDIF
13500  CALL pyptis(0,pt2cmx,pt20,pt2new,ifail)
13501  IF (mint(51).NE.0) RETURN
13502  220 CONTINUE
13503  230 CONTINUE
13504  ENDIF
13505 
13506 C...Generate trial additional interaction.
13507  mint(36)=mint(31)+1
13508  240 IF (mod(mstp(81),10).GE.1) THEN
13509  mint(1)=96
13510 C...Set up X remaining in BR.
13511  vint(143)=1d0
13512  vint(144)=1d0
13513  DO 250 ji=1,mint(31)
13514  vint(143)=vint(143)-xmi(1,ji)
13515  vint(144)=vint(144)-xmi(2,ji)
13516  250 CONTINUE
13517 C...Generate trial interaction
13518  260 CALL pyptmi(0,pt2cmx,pt2min,pt2new,ifail)
13519  IF (mint(51).EQ.1) RETURN
13520  ENDIF
13521 
13522 C...And the winner is:
13523  IF (pt2mx.LT.pt2min) THEN
13524  GOTO 330
13525  ELSEIF (jsmx.EQ.0) THEN
13526 C...Accept additional interaction (may still fail).
13527  CALL pyptmi(1,pt2new,pt2min,pt2dum,ifail)
13528  IF(mint(51).NE.0) RETURN
13529  IF (ifail.EQ.0) THEN
13530  shat(mint(36))=vint(44)
13531 C...Decide on flavours (valence/sea/companion).
13532  DO 270 js=1,2
13533  mint(30)=js
13534  CALL pyptmi(2,pt2new,pt2min,pt2dum,ifail)
13535  IF(mint(51).NE.0) RETURN
13536  270 CONTINUE
13537  ENDIF
13538  ELSEIF (jsmx.EQ.1.OR.jsmx.EQ.2) THEN
13539 C...Reconstruct kinematics of acceptable ISR branching.
13540 C...Set up shat, initiator x values, and x remaining in BR.
13541  mint(30)=jsmx
13542  mint(36)=mimx
13543  vint(44)=shat(mint(36))
13544  vint(141)=xmi(1,mint(36))
13545  vint(142)=xmi(2,mint(36))
13546  vint(143)=1d0
13547  vint(144)=1d0
13548  DO 280 ji=1,mint(31)
13549  IF (ji.EQ.mint(36)) GOTO 280
13550  vint(143)=vint(143)-xmi(1,ji)
13551  vint(144)=vint(144)-xmi(2,ji)
13552  280 CONTINUE
13553  pt2new=pt2mx
13554  CALL pyptis(1,pt2new,pt2dm1,pt2dm2,ifail)
13555  IF (mint(51).EQ.1) RETURN
13556  ELSEIF (jsmx.EQ.3.OR.jsmx.EQ.4) THEN
13557 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13558  mint(354)=mint(354)+1
13559  vint(354)=vint(354)+sqrt(pt2mx)
13560  IF (mint(354).EQ.1) vint(359)=sqrt(pt2mx)
13561  mjoind(jsmx-2,mjn1mx)=mjn2mx
13562  mjoind(jsmx-2,mjn2mx)=mjn1mx
13563  ENDIF
13564 
13565 C...Update PT2 iteration scale.
13566  pt2cmx=pt2mx
13567 
13568 C...Loop back to continue evolution.
13569  IF(n.GT.mstu(4)-mstu(32)-10) THEN
13570  CALL pyerrm(11,'(PYEVOL:) no more memory left in PYJETS')
13571  ELSE
13572  IF (jsmx.GE.0.AND.pt2cmx.GE.pt2min) GOTO 200
13573  ENDIF
13574 
13575 C----------------------------------------------------------------------
13576 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13577  ELSEIF (mode.EQ.2) THEN
13578 
13579 C...Revert to "ordinary" meanings of some parameters.
13580  290 DO 310 js=1,2
13581  mint(12+js)=k(imi(js,1,1),2)
13582  vint(140+js)=xmi(js,1)
13583  IF(mint(18+js).EQ.1) vint(140+js)=vint(154+js)*xmi(js,1)
13584  vint(142+js)=1d0
13585  DO 300 mi=1,mint(31)
13586  vint(142+js)=vint(142+js)-xmi(js,mi)
13587  300 CONTINUE
13588  310 CONTINUE
13589 
13590 C...Restore saved quantities for hardest interaction.
13591  mint(1)=isubhd
13592  mint(15)=m15sv
13593  mint(16)=m16sv
13594  mint(21)=m21sv
13595  mint(22)=m22sv
13596  DO 320 j=11,80
13597  vint(j)=vintsv(j)
13598  320 CONTINUE
13599 
13600  ENDIF
13601 
13602  330 RETURN
13603  END
13604 
13605 C*********************************************************************
13606 
13607 C...PYSSPA
13608 C...Generates spacelike parton showers.
13609 
13610  SUBROUTINE pysspa(IPU1,IPU2)
13611 
13612 C...Double precision and integer declarations.
13613  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13614  IMPLICIT INTEGER(I-N)
13615  INTEGER PYK,PYCHGE,PYCOMP
13616  parameter(maxnur=1000)
13617 C...Commonblocks.
13618  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
13619  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13620  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13621  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
13622  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
13623  common/pypars/mstp(200),parp(200),msti(200),pari(200)
13624  common/pyint1/mint(400),vint(400)
13625  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
13626  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13627  common/pyctag/nct,mct(4000,2)
13628  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,
13629  &/pyint1/,/pyint2/,/pyint3/,/pyctag/
13630 C...Local arrays and data.
13631  dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevcsv(2),tevesv(2),
13632  &xfs(2,-25:25),xfa(-25:25),xfb(-25:25),xfn(-25:25),wtapc(-25:25),
13633  &wtape(-25:25),wtsf(-25:25),the2(2),alam(2),dq2(3),dpc(3),dpd(4),
13634  &dpb(4),robo(5),more(2),kfbeam(2),q2mncs(2),kcfi(2),nfis(2),
13635  &thefis(2,2),isfi(2),dphi(2),mcesv(2)
13636  DATA is/2*0/
13637 
13638 C...Read out basic information; set global Q^2 scale.
13639  ipus1=ipu1
13640  ipus2=ipu2
13641  isub=mint(1)
13642  q2mx=vint(56)
13643  vint2r=vint(2)*vint(143)*vint(144)
13644  IF(iset(isub).EQ.2.OR.iset(isub).EQ.9.OR.iset(isub).EQ.11) q2mx=
13645  &min(vint2r,parp(67)*vint(56))
13646  fcq2mx=1d0
13647 
13648 C...Define which processes ME corrections have been implemented for.
13649  mecor=0
13650  IF(mstp(68).EQ.1.OR.mstp(68).EQ.3) THEN
13651  IF(isub.EQ.1.OR.isub.EQ.2.OR.isub.EQ.141.OR.isub.EQ.142.OR.
13652  & isub.EQ.144) mecor=1
13653  IF(isub.EQ.102.OR.isub.EQ.152.OR.isub.EQ.157) mecor=2
13654  IF(isub.EQ.3.OR.isub.EQ.151.OR.isub.EQ.156) mecor=3
13655  ENDIF
13656 
13657 C...Initialize QCD evolution and check phase space.
13658  q2mnc=parp(62)**2
13659  q2mncs(1)=q2mnc
13660  q2mncs(2)=q2mnc
13661  IF(mint(107).EQ.2.AND.mstp(66).EQ.2) THEN
13662  q0s=parp(15)**2
13663  ps=vint(3)**2
13664  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
13665  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
13666  q2int=sqrt(q0s*q2eff)
13667  q2mncs(1)=max(q2mnc,q2int)
13668  ELSEIF(mint(107).EQ.3.AND.mstp(66).GE.1) THEN
13669  q2mncs(1)=max(q2mnc,vint(283))
13670  ENDIF
13671  IF(mint(108).EQ.2.AND.mstp(66).EQ.2) THEN
13672  q0s=parp(15)**2
13673  ps=vint(4)**2
13674  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
13675  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
13676  q2int=sqrt(q0s*q2eff)
13677  q2mncs(2)=max(q2mnc,q2int)
13678  ELSEIF(mint(108).EQ.3.AND.mstp(66).GE.1) THEN
13679  q2mncs(2)=max(q2mnc,vint(284))
13680  ENDIF
13681  mcev=0
13682  alams=paru(112)
13683  paru(112)=parp(61)
13684  fq2c=1d0
13685  tcmx=0d0
13686  IF(mint(47).GE.2.AND.(mint(47).LT.5.OR.mstp(12).GE.1)) THEN
13687  mcev=1
13688  IF(mstp(64).EQ.1) fq2c=parp(63)
13689  IF(mstp(64).EQ.2) fq2c=parp(64)
13690  tcmx=log(fq2c*q2mx/parp(61)**2)
13691  IF(q2mx.LT.max(q2mnc,2d0*parp(61)**2).OR.tcmx.LT.0.2d0)
13692  & mcev=0
13693  ENDIF
13694 
13695 C...Initialize QED evolution and check phase space.
13696  meev=0
13697  xee=1d-10
13698  spme=pmas(11,1)**2
13699  IF(iabs(mint(11)).EQ.13.OR.iabs(mint(12)).EQ.13)
13700  &spme=pmas(13,1)**2
13701  IF(iabs(mint(11)).EQ.15.OR.iabs(mint(12)).EQ.15)
13702  &spme=pmas(15,1)**2
13703  q2mne=max(parp(68)**2,2d0*spme)
13704  temx=0d0
13705  fwte=10d0
13706  IF(mint(45).EQ.3.OR.mint(46).EQ.3) THEN
13707  meev=1
13708  temx=log(q2mx/spme)
13709  IF(q2mx.LE.q2mne.OR.temx.LT.0.2d0) meev=0
13710  ENDIF
13711  IF(mstp(61).GE.2.AND.mcev.EQ.1.AND.meev.EQ.0) THEN
13712  meev=2
13713  temx=tcmx
13714  fwte=1d0
13715  ENDIF
13716  IF(mcev.EQ.0.AND.meev.EQ.0) RETURN
13717 
13718 C...Loopback point in case of failure to reconstruct kinematics.
13719  ns=n
13720  nparts=npart
13721  loop=0
13722  mnt352=mint(352)
13723  mnt353=mint(353)
13724  vnt352=vint(352)
13725  vnt353=vint(353)
13726  100 loop=loop+1
13727  IF(loop.GT.100) THEN
13728  mint(51)=1
13729  RETURN
13730  ENDIF
13731  n=ns
13732  npart=nparts
13733  mint(352)=mnt352
13734  mint(353)=mnt353
13735  vint(352)=vnt352
13736  vint(353)=vnt353
13737 
13738 C...Initial values: flavours, momenta, virtualities.
13739  DO 120 jt=1,2
13740  more(jt)=1
13741  kfbeam(jt)=mint(10+jt)
13742  IF(mint(18+jt).EQ.1)kfbeam(jt)=22
13743  kfls(jt)=mint(14+jt)
13744  kfls(jt+2)=kfls(jt)
13745  xs(jt)=vint(40+jt)
13746  IF(mint(18+jt).EQ.1) xs(jt)=vint(40+jt)/vint(154+jt)
13747  IF(mint(31).GE.2) xs(jt)=xs(jt)/vint(142+jt)
13748  zs(jt)=1d0
13749  q2s(jt)=fcq2mx*q2mx
13750  dq2(jt)=0d0
13751  tevcsv(jt)=tcmx
13752  alam(jt)=parp(61)
13753  the2(jt)=1d0
13754  tevesv(jt)=temx
13755  mcesv(jt)=0
13756 C...Calculate initial parton distribution weights.
13757  mint(105)=mint(102+jt)
13758  mint(109)=mint(106+jt)
13759  vint(120)=vint(2+jt)
13760  IF(xs(jt).LT.1d0-xee) THEN
13761  IF(mint(31).GE.2) mint(30)=jt
13762  IF(mstp(57).LE.1) THEN
13763  CALL pypdfu(kfbeam(jt),xs(jt),q2s(jt),xfb)
13764  ELSE
13765  CALL pypdfl(kfbeam(jt),xs(jt),q2s(jt),xfb)
13766  ENDIF
13767  ENDIF
13768  DO 110 kfl=-25,25
13769  xfs(jt,kfl)=xfb(kfl)
13770  110 CONTINUE
13771 C...Special kinematics check for c/b quarks (that g -> c cbar or
13772 C...b bbar kinematically possible).
13773  kflcb=iabs(kfls(jt))
13774  IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5)) THEN
13775  IF(xs(jt).GT.0.9d0*q2s(jt)/(pmas(kflcb,1)**2+q2s(jt))) THEN
13776  mint(51)=1
13777  RETURN
13778  ENDIF
13779  ENDIF
13780  120 CONTINUE
13781  dsh=vint(44)
13782  IF(iset(isub).GE.3.AND.iset(isub).LE.5) dsh=vint(26)*vint(2)
13783 
13784 C...Find if interference with final state partons.
13785  mfis=0
13786  IF(mstp(67).GE.1.AND.mstp(67).LE.3) mfis=mstp(67)
13787  IF(mfis.NE.0) THEN
13788  DO 140 i=1,2
13789  kcfi(i)=0
13790  kca=pycomp(iabs(kfls(i)))
13791  IF(kca.NE.0) kcfi(i)=kchg(kca,2)*isign(1,kfls(i))
13792  nfis(i)=0
13793  IF(kcfi(i).NE.0) THEN
13794  IF(i.EQ.1) ipfs=ipus1
13795  IF(i.EQ.2) ipfs=ipus2
13796  DO 130 j=1,2
13797  icsi=mod(k(ipfs,3+j),mstu(5))
13798  IF(icsi.GT.0.AND.icsi.NE.ipus1.AND.icsi.NE.ipus2.AND.
13799  & (kcfi(i).EQ.(-1)**(j+1).OR.kcfi(i).EQ.2)) THEN
13800  nfis(i)=nfis(i)+1
13801  thefis(i,nfis(i))=pyangl(p(icsi,3),sqrt(p(icsi,1)**2+
13802  & p(icsi,2)**2))
13803  IF(i.EQ.2) thefis(i,nfis(i))=paru(1)-thefis(i,nfis(i))
13804  ENDIF
13805  130 CONTINUE
13806  ENDIF
13807  140 CONTINUE
13808  IF(nfis(1)+nfis(2).EQ.0) mfis=0
13809  ENDIF
13810 
13811 C...Pick up leg with highest virtuality.
13812  jtold=1
13813  150 n=n+1
13814  jt=1
13815  IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2
13816  IF(n.EQ.ns+2.AND.jt.EQ.jtold) jt=3-jt
13817  IF(more(jt).EQ.0) jt=3-jt
13818  jtold=jt
13819  kflb=kfls(jt)
13820  xb=xs(jt)
13821  DO 160 kfl=-25,25
13822  xfb(kfl)=xfs(jt,kfl)
13823  160 CONTINUE
13824  dshr=2d0*sqrt(dsh)
13825  dshz=dsh/zs(jt)
13826 
13827 C...Check if allowed to branch.
13828  mcev=0
13829  IF(iabs(kflb).LE.10.OR.kflb.EQ.21) THEN
13830  mcev=1
13831  xec=max(parp(65)*dshr/vint2r,xb*(1d0/(1d0-parp(66))-1d0))
13832  IF(xb.GE.1d0-2d0*xec) mcev=0
13833  ENDIF
13834  meev=0
13835  IF(mint(44+jt).EQ.3) THEN
13836  meev=1
13837  IF(xb.GE.1d0-2d0*xee) meev=0
13838  IF((iabs(kflb).LE.10.OR.kflb.EQ.21).AND.xb.GE.1d0-2d0*xec)
13839  & meev=0
13840 C***Currently kill QED shower for resolved photoproduction.
13841  IF(mint(18+jt).EQ.1) meev=0
13842 C***Currently kill shower for W inside electron.
13843  IF(iabs(kflb).EQ.24) THEN
13844  mcev=0
13845  meev=0
13846  ENDIF
13847  ENDIF
13848  IF(mstp(61).GE.2.AND.mcev.EQ.1.AND.meev.EQ.0.AND.iabs(kflb).LE.10)
13849  &meev=2
13850  IF(mcev.EQ.0.AND.meev.EQ.0) THEN
13851  q2b=0d0
13852  GOTO 260
13853  ENDIF
13854 
13855 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13856  q2b=q2s(jt)
13857  tevcb=tevcsv(jt)
13858  teveb=tevesv(jt)
13859  IF(mstp(62).LE.1) THEN
13860  IF(zs(jt).GT.0.99999d0) THEN
13861  q2b=q2s(jt)
13862  ELSE
13863  q2b=0.5d0*(1d0/zs(jt)+1d0)*q2s(jt)+0.5d0*(1d0/zs(jt)-1d0)*
13864  & (q2s(3-jt)-dsh+sqrt((dsh+q2s(1)+q2s(2))**2+
13865  & 8d0*q2s(1)*q2s(2)*zs(jt)/(1d0-zs(jt))))
13866  ENDIF
13867  IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
13868  IF(meev.EQ.1) teveb=log(q2b/spme)
13869  ENDIF
13870  IF(mcev.EQ.1) THEN
13871  alsdum=pyalps(fq2c*q2b)
13872  tevcb=tevcb+2d0*log(alam(jt)/paru(117))
13873  alam(jt)=paru(117)
13874  b0=(33d0-2d0*mstu(118))/6d0
13875  ENDIF
13876  IF(meev.EQ.2) teveb=tevcb
13877  tevcbs=tevcb
13878  tevebs=teveb
13879 
13880 C...Select side for interference with final state partons.
13881  IF(mfis.GE.1.AND.n.LE.ns+2) THEN
13882  ifi=n-ns
13883  isfi(ifi)=0
13884  IF(iabs(kcfi(ifi)).EQ.1.AND.nfis(ifi).EQ.1) THEN
13885  isfi(ifi)=1
13886  ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.1) THEN
13887  IF(pyr(0).GT.0.5d0) isfi(ifi)=1
13888  ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.2) THEN
13889  isfi(ifi)=1
13890  IF(pyr(0).GT.0.5d0) isfi(ifi)=2
13891  ENDIF
13892  ENDIF
13893 
13894 C...Calculate preweighting factor for ME-corrected processes.
13895  IF(mecor.GE.1) CALL pymemx(mecor,wtff,wtgf,wtfg,wtgg)
13896 
13897 C...Calculate Altarelli-Parisi weights.
13898  DO 170 kfl=-25,25
13899  wtapc(kfl)=0d0
13900  wtape(kfl)=0d0
13901  wtsf(kfl)=0d0
13902  170 CONTINUE
13903 C...q -> q (g or gamma emission), g -> q.
13904  IF(iabs(kflb).LE.10) THEN
13905  wtapc(kflb)=(8d0/3d0)*log((1d0-xec-xb)*(xb+xec)/(xec*(1d0-xec)))
13906  wtapc(21)=0.5d0*(xb/(xb+xec)-xb/(1d0-xec))
13907  eq2=1d0/9d0
13908  IF(mod(iabs(kflb),2).EQ.0) eq2=4d0*eq2
13909  IF(meev.EQ.2) wtape(kflb)=2.*eq2*log((1d0-xec-xb)*(xb+xec)/
13910  & (xec*(1d0-xec)))
13911  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13912  wtapc(kflb)=wtff*wtapc(kflb)
13913  wtapc(21)=wtgf*wtapc(21)
13914  wtape(kflb)=wtff*wtape(kflb)
13915  ENDIF
13916 C...f -> f, gamma -> f.
13917  ELSEIF(iabs(kflb).LE.20) THEN
13918  wtapf1=log((1d0-xee-xb)*(xb+xee)/(xee*(1d0-xee)))
13919  wtapf2=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))
13920  wtape(kflb)=2d0*(wtapf1+wtapf2)
13921  IF(mstp(12).GE.1) wtape(22)=xb/(xb+xee)-xb/(1d0-xee)
13922  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13923  wtape(kflb)=wtff*wtape(kflb)
13924  wtape(22)=wtgf*wtape(22)
13925  ENDIF
13926 C...f -> g, g -> g.
13927  ELSEIF(kflb.EQ.21) THEN
13928  wtapq=(16d0/3d0)*(sqrt((1d0-xec)/xb)-sqrt((xb+xec)/xb))
13929  DO 180 kfl=1,mstp(58)
13930  wtapc(kfl)=wtapq
13931  wtapc(-kfl)=wtapq
13932  180 CONTINUE
13933  wtapc(21)=6d0*log((1d0-xec-xb)/xec)
13934  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13935  DO 190 kfl=1,mstp(58)
13936  wtapc(kfl)=wtfg*wtapc(kfl)
13937  wtapc(-kfl)=wtfg*wtapc(-kfl)
13938  190 CONTINUE
13939  wtapc(21)=wtgg*wtapc(21)
13940  ENDIF
13941 C...f -> gamma, W+, W-.
13942  ELSEIF(kflb.EQ.22) THEN
13943  wtapf=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))/xb
13944  wtape(11)=wtapf
13945  wtape(-11)=wtapf
13946  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13947  wtape(11)=wtfg*wtape(11)
13948  wtape(-11)=wtfg*wtape(-11)
13949  ENDIF
13950  ELSEIF(kflb.EQ.24) THEN
13951  wtape(-11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
13952  & (xee*(xb+xee)))/xb
13953  ELSEIF(kflb.EQ.-24) THEN
13954  wtape(11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
13955  & (xee*(xb+xee)))/xb
13956  ENDIF
13957 
13958 C...Calculate parton distribution weights and sum.
13959  ntry=0
13960  200 ntry=ntry+1
13961  IF(ntry.GT.500) THEN
13962  mint(51)=1
13963  RETURN
13964  ENDIF
13965  wtsumc=0d0
13966  wtsume=0d0
13967  xfbo=max(1d-10,xfb(kflb))
13968  DO 210 kfl=-25,25
13969  wtsf(kfl)=xfb(kfl)/xfbo
13970  wtsumc=wtsumc+wtapc(kfl)*wtsf(kfl)
13971  wtsume=wtsume+wtape(kfl)*wtsf(kfl)
13972  210 CONTINUE
13973  wtsumc=max(0.0001d0,wtsumc)
13974  wtsume=max(0.0001d0/fwte,wtsume)
13975 
13976 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13977  ntry2=0
13978  220 ntry2=ntry2+1
13979  IF(ntry2.GT.500) THEN
13980  mint(51)=1
13981  RETURN
13982  ENDIF
13983  IF(mcev.EQ.1) THEN
13984  IF(mstp(64).LE.0) THEN
13985  tevcb=tevcb+log(pyr(0))*paru(2)/(paru(111)*wtsumc)
13986  ELSEIF(mstp(64).EQ.1) THEN
13987  tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/wtsumc))
13988  ELSE
13989  tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/(5d0*wtsumc)))
13990  ENDIF
13991  ENDIF
13992  IF(meev.EQ.1) THEN
13993  teveb=teveb*exp(max(-50d0,log(pyr(0))*paru(2)/
13994  & (paru(101)*fwte*wtsume*temx)))
13995  ELSEIF(meev.EQ.2) THEN
13996  teveb=teveb+log(pyr(0))*paru(2)/(paru(101)*wtsume)
13997  ENDIF
13998 
13999 C...Translate t into Q2 scale; choose between QCD and QED evolution.
14000  230 IF(mcev.EQ.1) q2cb=alam(jt)**2*exp(max(-50d0,tevcb))/fq2c
14001  IF(meev.EQ.1) q2eb=spme*exp(max(-50d0,teveb))
14002  IF(meev.EQ.2) q2eb=alam(jt)**2*exp(max(-50d0,teveb))/fq2c
14003 C...Ensure that Q2 is above threshold for charm/bottom.
14004  kflcb=iabs(kflb)
14005  IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5).AND.
14006  &mcev.EQ.1) THEN
14007  IF(q2cb.LT.pmas(kflcb,1)**2) THEN
14008  q2cb=1.1d0*pmas(kflcb,1)**2
14009  tevcb=log(fq2c*q2b/alam(jt)**2)
14010  fcq2mx=min(2d0,1.05d0*fcq2mx)
14011  ENDIF
14012  ENDIF
14013  IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5).AND.
14014  &meev.EQ.2) THEN
14015  IF(q2eb.LT.pmas(kflcb,1)**2) meev=0
14016  ENDIF
14017  mce=0
14018  IF(mcev.EQ.0.AND.meev.EQ.0) THEN
14019  ELSEIF(mcev.EQ.1.AND.meev.EQ.0) THEN
14020  IF(q2cb.GT.q2mncs(jt)) mce=1
14021  ELSEIF(mcev.EQ.0.AND.meev.EQ.1) THEN
14022  IF(q2eb.GT.q2mne) mce=2
14023  ELSEIF(mcev.EQ.0.AND.meev.EQ.2) THEN
14024  IF(q2eb.GT.q2mncs(jt)) mce=2
14025  ELSEIF(mcev.EQ.1.AND.meev.EQ.2) THEN
14026  IF(q2cb.GT.q2eb.AND.q2cb.GT.q2mncs(jt)) mce=1
14027  IF(q2eb.GT.q2cb.AND.q2eb.GT.q2mncs(jt)) mce=2
14028  ELSEIF(q2mncs(jt).GT.q2mne) THEN
14029  mce=1
14030  IF(q2eb.GT.q2cb.OR.q2cb.LE.q2mncs(jt)) mce=2
14031  IF(mce.EQ.2.AND.q2eb.LE.q2mne) mce=0
14032  ELSE
14033  mce=2
14034  IF(q2cb.GT.q2eb.OR.q2eb.LE.q2mne) mce=1
14035  IF(mce.EQ.1.AND.q2cb.LE.q2mncs(jt)) mce=0
14036  ENDIF
14037 
14038 C...Evolution possibly ended. Update t values.
14039  IF(mce.EQ.0) THEN
14040  q2b=0d0
14041  GOTO 260
14042  ELSEIF(mce.EQ.1) THEN
14043  q2b=q2cb
14044  q2ref=fq2c*q2b
14045  IF(meev.EQ.1) teveb=log(q2b/spme)
14046  IF(meev.EQ.2) teveb=log(fq2c*q2b/alam(jt)**2)
14047  ELSE
14048  q2b=q2eb
14049  q2ref=q2b
14050  IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
14051  ENDIF
14052 
14053 C...Select flavour for branching parton.
14054  IF(mce.EQ.1) wtran=pyr(0)*wtsumc
14055  IF(mce.EQ.2) wtran=pyr(0)*wtsume
14056  kfla=-25
14057  240 kfla=kfla+1
14058  IF(mce.EQ.1) wtran=wtran-wtapc(kfla)*wtsf(kfla)
14059  IF(mce.EQ.2) wtran=wtran-wtape(kfla)*wtsf(kfla)
14060  IF(kfla.LE.24.AND.wtran.GT.0d0) GOTO 240
14061  IF(kfla.EQ.25) THEN
14062  q2b=0d0
14063  GOTO 260
14064  ENDIF
14065 
14066 C...Choose z value and corrective weight.
14067  wtz=0d0
14068 C...q -> q + g or q -> q + gamma.
14069  IF(iabs(kfla).LE.10.AND.iabs(kflb).LE.10) THEN
14070  z=1d0-((1d0-xb-xec)/(1d0-xec))*
14071  & (xec*(1d0-xec)/((xb+xec)*(1d0-xb-xec)))**pyr(0)
14072  wtz=0.5d0*(1d0+z**2)
14073 C...q -> g + q.
14074  ELSEIF(iabs(kfla).LE.10.AND.kflb.EQ.21) THEN
14075  z=xb/(sqrt(xb+xec)+pyr(0)*(sqrt(1d0-xec)-sqrt(xb+xec)))**2
14076  wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
14077 C...f -> f + gamma.
14078  ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
14079  IF(wtapf1.GT.pyr(0)*(wtapf1+wtapf2)) THEN
14080  z=1d0-((1d0-xb-xee)/(1d0-xee))*
14081  & (xee*(1d0-xee)/((xb+xee)*(1d0-xb-xee)))**pyr(0)
14082  ELSE
14083  z=xb+xb*(xee/(1d0-xee))*
14084  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14085  ENDIF
14086  wtz=0.5d0*(1d0+z**2)*(z-xb)/(1d0-xb)
14087 C...f -> gamma + f.
14088  ELSEIF(iabs(kfla).LE.20.AND.kflb.EQ.22) THEN
14089  z=xb+xb*(xee/(1d0-xee))*
14090  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14091  wtz=0.5d0*(1d0+(1d0-z)**2)*xb*(z-xb)/z
14092 C...f -> W+- + f.
14093  ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).EQ.24) THEN
14094  z=xb+xb*(xee/(1d0-xee))*
14095  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14096  wtz=0.5d0*(1d0+(1d0-z)**2)*(xb*(z-xb)/z)*
14097  & (q2b/(q2b+pmas(24,1)**2))
14098 C...g -> q + qbar.
14099  ELSEIF(kfla.EQ.21.AND.iabs(kflb).LE.10) THEN
14100  z=xb/(1d0-xec)+pyr(0)*(xb/(xb+xec)-xb/(1d0-xec))
14101  wtz=1d0-2d0*z*(1d0-z)
14102 C...g -> g + g.
14103  ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
14104  z=1d0/(1d0+((1d0-xec-xb)/xb)*(xec/(1d0-xec-xb))**pyr(0))
14105  wtz=(1d0-z*(1d0-z))**2
14106 C...gamma -> f + fbar.
14107  ELSEIF(kfla.EQ.22.AND.iabs(kflb).LE.20) THEN
14108  z=xb/(1d0-xee)+pyr(0)*(xb/(xb+xee)-xb/(1d0-xee))
14109  wtz=1d0-2d0*z*(1d0-z)
14110  ENDIF
14111  IF(mce.EQ.2.AND.meev.EQ.1) wtz=(wtz/fwte)*(teveb/temx)
14112 
14113 C...Option with resummation of soft gluon emission as effective z shift.
14114  IF(mce.EQ.1) THEN
14115  IF(mstp(65).GE.1) THEN
14116  rsoft=6d0
14117  IF(kflb.NE.21) rsoft=8d0/3d0
14118  z=z*(tevcb/tevcsv(jt))**(rsoft*xec/((xb+xec)*b0))
14119  IF(z.LE.xb) GOTO 220
14120  ENDIF
14121 
14122 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14123  IF(mstp(64).GE.2) THEN
14124  IF((1d0-z)*q2b.LT.q2mncs(jt)) GOTO 220
14125  alprat=tevcb/(tevcb+log(1d0-z))
14126  IF(alprat.LT.5d0*pyr(0)) GOTO 220
14127  IF(alprat.GT.5d0) wtz=wtz*alprat/5d0
14128  ENDIF
14129  ENDIF
14130 
14131 C...Remove kinematically impossible branchings.
14132  uhat=q2b-dsh*(1d0-z)/z
14133  IF(mstp(68).GE.0.AND.uhat.GT.0d0) GOTO 220
14134 
14135 C...Select phi angle of branching at random.
14136  phibr=paru(2)*pyr(0)
14137 
14138 C...Matrix-element corrections for some processes.
14139  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
14140  IF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
14141  CALL pymewt(mecor,1,q2b,z,phibr,wtme)
14142  wtz=wtz*wtme/wtff
14143  ELSEIF((kfla.EQ.21.OR.kfla.EQ.22).AND.iabs(kflb).LE.20) THEN
14144  CALL pymewt(mecor,2,q2b,z,phibr,wtme)
14145  wtz=wtz*wtme/wtgf
14146  ELSEIF(iabs(kfla).LE.20.AND.(kflb.EQ.21.OR.kflb.EQ.22)) THEN
14147  CALL pymewt(mecor,3,q2b,z,phibr,wtme)
14148  wtz=wtz*wtme/wtfg
14149  ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
14150  CALL pymewt(mecor,4,q2b,z,phibr,wtme)
14151  wtz=wtz*wtme/wtgg
14152  ENDIF
14153  ENDIF
14154 
14155 C...Impose angular constraint in first branching from interference
14156 C...with final state partons.
14157  IF(mce.EQ.1) THEN
14158  IF(mfis.GE.1.AND.n.LE.ns+2.AND.ntry2.LT.200) THEN
14159  the2d=(4d0*q2b)/(dsh*(1d0-z))
14160  IF(n.EQ.ns+1.AND.isfi(1).GE.1) THEN
14161  IF(the2d.GT.thefis(1,isfi(1))**2) GOTO 220
14162  ELSEIF(n.EQ.ns+2.AND.isfi(2).GE.1) THEN
14163  IF(the2d.GT.thefis(2,isfi(2))**2) GOTO 220
14164  ENDIF
14165  ENDIF
14166 
14167 C...Option with angular ordering requirement.
14168  IF(mstp(62).GE.3.AND.ntry2.LT.200) THEN
14169  the2t=(4d0*z**2*q2b)/(4d0*z**2*q2b+(1d0-z)*xb**2*vint2r)
14170  IF(the2t.GT.the2(jt)) GOTO 220
14171  ENDIF
14172  ENDIF
14173 
14174 C...Weighting with new parton distributions.
14175  mint(105)=mint(102+jt)
14176  mint(109)=mint(106+jt)
14177  vint(120)=vint(2+jt)
14178  IF(mint(31).GE.2) mint(30)=jt
14179  IF(mstp(57).LE.1) THEN
14180  CALL pypdfu(kfbeam(jt),xb,q2ref,xfn)
14181  ELSE
14182  CALL pypdfl(kfbeam(jt),xb,q2ref,xfn)
14183  ENDIF
14184  xfbn=xfn(kflb)
14185  IF(xfbn.LT.1d-20) THEN
14186  IF(kfla.EQ.kflb) THEN
14187  tevcb=tevcbs
14188  teveb=tevebs
14189  wtapc(kflb)=0d0
14190  wtape(kflb)=0d0
14191  GOTO 200
14192  ELSEIF(mce.EQ.1.AND.tevcbs-tevcb.GT.0.2d0) THEN
14193  tevcb=0.5d0*(tevcbs+tevcb)
14194  GOTO 230
14195  ELSEIF(mce.EQ.2.AND.tevebs-teveb.GT.0.2d0) THEN
14196  teveb=0.5d0*(tevebs+teveb)
14197  GOTO 230
14198  ELSE
14199  xfbn=1d-10
14200  xfn(kflb)=xfbn
14201  ENDIF
14202  ENDIF
14203  DO 250 kfl=-25,25
14204  xfb(kfl)=xfn(kfl)
14205  250 CONTINUE
14206  xa=xb/z
14207  IF(mint(31).GE.2) mint(30)=jt
14208  IF(mstp(57).LE.1) THEN
14209  CALL pypdfu(kfbeam(jt),xa,q2ref,xfa)
14210  ELSE
14211  CALL pypdfl(kfbeam(jt),xa,q2ref,xfa)
14212  ENDIF
14213  xfan=xfa(kfla)
14214  IF(xfan.LT.1d-20) GOTO 200
14215  wtsfa=wtsf(kfla)
14216  IF(wtz*xfan/xfbn.LT.pyr(0)*wtsfa) GOTO 200
14217 
14218 C...Define two hard scatterers in their CM-frame.
14219  260 IF(n.EQ.ns+2) THEN
14220  dq2(jt)=q2b
14221  dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr
14222  DO 280 jr=1,2
14223  i=ns+jr
14224  IF(jr.EQ.1) ipo=ipus1
14225  IF(jr.EQ.2) ipo=ipus2
14226  DO 270 j=1,5
14227  k(i,j)=0
14228  p(i,j)=0d0
14229  v(i,j)=0d0
14230  270 CONTINUE
14231  k(i,1)=14
14232  k(i,2)=kfls(jr+2)
14233  k(i,4)=ipo
14234  k(i,5)=ipo
14235  p(i,3)=dplcm*(-1)**(jr+1)
14236  p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr
14237  p(i,5)=-sqrt(dq2(jr))
14238  k(ipo,1)=14
14239  k(ipo,3)=i
14240  k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i
14241  k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i
14242  mct(i,1)=mct(ipo,1)
14243  mct(i,2)=mct(ipo,2)
14244  280 CONTINUE
14245 
14246 C...Find maximum allowed mass of timelike parton.
14247  ELSEIF(n.GT.ns+2) THEN
14248  jr=3-jt
14249  dq2(3)=q2b
14250  dpc(1)=p(is(1),4)
14251  dpc(2)=p(is(2),4)
14252  dpc(3)=0.5d0*(abs(p(is(1),3))+abs(p(is(2),3)))
14253  dpd(1)=dsh+dq2(jr)+dq2(jt)
14254  dpd(2)=dshz+dq2(jr)+dq2(3)
14255  dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))
14256  dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))
14257  ikin=0
14258  IF(q2s(jr).GE.0.25d0*q2mnc.AND.dpd(1)-dpd(3).GE.
14259  & 1d-10*dpd(1)) ikin=1
14260  IF(ikin.EQ.0) dmsma=(dq2(jt)/zs(jt)-dq2(3))*
14261  & (dsh/(dsh+dq2(jt))-dsh/(dshz+dq2(3)))
14262  IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/
14263  & (2d0*dq2(jr))-dq2(jt)-dq2(3)
14264 
14265 C...Generate timelike parton shower (if required).
14266  it=n
14267  DO 290 j=1,5
14268  k(it,j)=0
14269  p(it,j)=0d0
14270  v(it,j)=0d0
14271  290 CONTINUE
14272 C...f -> f + g (gamma).
14273  IF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).LE.20) THEN
14274  k(it,2)=21
14275  IF(mcesv(jt).EQ.2.OR.iabs(kflb).GE.11) k(it,2)=22
14276 C...f -> g (gamma, W+-) + f.
14277  ELSEIF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).GT.20) THEN
14278  k(it,2)=kflb
14279  IF(kfls(jt+2).EQ.24) THEN
14280  k(it,2)=-12
14281  ELSEIF(kfls(jt+2).EQ.-24) THEN
14282  k(it,2)=12
14283  ENDIF
14284 C...g (gamma) -> f + fbar, g + g.
14285  ELSE
14286  k(it,2)=-kfls(jt+2)
14287  IF(kfls(jt+2).GT.20) k(it,2)=kfls(jt+2)
14288  ENDIF
14289  k(it,1)=3
14290  IF((iabs(k(it,2)).GE.11.AND.iabs(k(it,2)).LE.18).OR.
14291  & iabs(k(it,2)).EQ.22) k(it,1)=1
14292  p(it,5)=pymass(k(it,2))
14293  IF(dmsma.LE.p(it,5)**2) GOTO 100
14294  IF(mstp(63).GE.1.AND.mcesv(jt).EQ.1) THEN
14295  mstj48=mstj(48)
14296  parj85=parj(85)
14297  p(it,4)=(dshz-dsh-p(it,5)**2)/dshr
14298  p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)
14299  IF(mstp(63).EQ.1) THEN
14300  q2tim=dmsma
14301  ELSEIF(mstp(63).EQ.2) THEN
14302  q2tim=min(dmsma,parp(71)*q2s(jt))
14303  ELSE
14304  q2tim=dmsma
14305  mstj(48)=1
14306  IF(ikin.EQ.0) dpt2=dmsma*(dshz+dq2(3))/(dsh+dq2(jt))
14307  IF(ikin.EQ.1) dpt2=dmsma*(0.5d0*dpd(1)*dpd(2)+0.5d0*dpd(3)*
14308  & dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)))/(4d0*dsh*dpc(3)**2)
14309  parj(85)=sqrt(max(0d0,dpt2))*
14310  & (1d0/p(it,4)+1d0/p(is(jt),4))
14311  ENDIF
14312 C...Only do timelike shower here if using PYSHOW
14313  IF (mstj(41).NE.11.AND.mstj(41).NE.12) THEN
14314  CALL pyshow(it,0,sqrt(q2tim))
14315  ENDIF
14316  mstj(48)=mstj48
14317  parj(85)=parj85
14318  IF(n.GE.it+1) p(it,5)=p(it+1,5)
14319  ENDIF
14320 
14321 C...Reconstruct kinematics of branching: timelike parton shower.
14322  dms=p(it,5)**2
14323  IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))
14324  IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5d0*dpd(1)*dpd(2)+
14325  & 0.5d0*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/
14326  & (4d0*dsh*dpc(3)**2)
14327  IF(dpt2.LT.0d0) GOTO 100
14328  dpb(1)=(0.5d0*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/
14329  & dshr)/dpc(3)-dpc(3)
14330  p(it,1)=sqrt(dpt2)
14331  p(it,3)=dpb(1)*(-1)**(jt+1)
14332  p(it,4)=sqrt(dpt2+dpb(1)**2+dms)
14333  IF(n.GE.it+1) THEN
14334  dpb(1)=sqrt(dpb(1)**2+dpt2)
14335  dpb(2)=sqrt(dpb(1)**2+dms)
14336  dpb(3)=p(it+1,3)
14337  dpb(4)=sqrt(dpb(3)**2+dms)
14338  dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*
14339  & dpb(1))
14340  CALL pyrobo(it+1,n,0d0,0d0,0d0,0d0,dbez)
14341  the=pyangl(p(it,3),p(it,1))
14342  CALL pyrobo(it+1,n,the,0d0,0d0,0d0,0d0)
14343  ENDIF
14344 
14345 C...Reconstruct kinematics of branching: spacelike parton.
14346  DO 300 j=1,5
14347  k(n+1,j)=0
14348  p(n+1,j)=0d0
14349  v(n+1,j)=0d0
14350  300 CONTINUE
14351  k(n+1,1)=14
14352  k(n+1,2)=kflb
14353  p(n+1,1)=p(it,1)
14354  p(n+1,3)=p(it,3)+p(is(jt),3)
14355  p(n+1,4)=p(it,4)+p(is(jt),4)
14356  p(n+1,5)=-sqrt(dq2(3))
14357  mct(n+1,1)=0
14358  mct(n+1,2)=0
14359 
14360 C...Define colour flow of branching.
14361  k(is(jt),3)=n+1
14362  k(it,3)=n+1
14363  im1=n+1
14364  im2=n+1
14365 C...f -> f + gamma (Z, W).
14366  IF(iabs(k(it,2)).GE.22) THEN
14367  k(it,1)=1
14368  id1=is(jt)
14369  id2=is(jt)
14370 C...f -> gamma (Z, W) + f.
14371  ELSEIF(iabs(k(is(jt),2)).GE.22) THEN
14372  id1=it
14373  id2=it
14374 C...gamma -> q + qbar, g + g.
14375  ELSEIF(k(n+1,2).EQ.22) THEN
14376  id1=is(jt)
14377  id2=it
14378  im1=id2
14379  im2=id1
14380 C...q -> q + g.
14381  ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(it,2).EQ.21) THEN
14382  id1=it
14383  id2=is(jt)
14384 C...q -> g + q.
14385  ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21) THEN
14386  id1=is(jt)
14387  id2=it
14388 C...qbar -> qbar + g.
14389  ELSEIF(k(n+1,2).LT.0.AND.k(it,2).EQ.21) THEN
14390  id1=is(jt)
14391  id2=it
14392 C...qbar -> g + qbar.
14393  ELSEIF(k(n+1,2).LT.0) THEN
14394  id1=it
14395  id2=is(jt)
14396 C...g -> g + g; g -> q + qbar.
14397  ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
14398  id1=is(jt)
14399  id2=it
14400  ELSE
14401  id1=it
14402  id2=is(jt)
14403  ENDIF
14404  IF(im1.EQ.n+1) k(im1,4)=k(im1,4)+id1
14405  IF(im2.EQ.n+1) k(im2,5)=k(im2,5)+id2
14406  k(id1,4)=k(id1,4)+mstu(5)*im1
14407  k(id2,5)=k(id2,5)+mstu(5)*im2
14408  IF(id1.NE.id2) THEN
14409  k(id1,5)=k(id1,5)+mstu(5)*id2
14410  k(id2,4)=k(id2,4)+mstu(5)*id1
14411  ENDIF
14412  n=n+1
14413  IF(k(it,1).EQ.1) THEN
14414  k(it,4)=0
14415  k(it,5)=0
14416  ENDIF
14417 
14418 C...Boost to new CM-frame.
14419  dbsvx=(p(n,1)+p(is(jr),1))/(p(n,4)+p(is(jr),4))
14420  dbsvz=(p(n,3)+p(is(jr),3))/(p(n,4)+p(is(jr),4))
14421  IF(dbsvx**2+dbsvz**2.GE.1d0) GOTO 100
14422  CALL pyrobo(ns+1,n,0d0,0d0,-dbsvx,0d0,-dbsvz)
14423  ir=n+(jt-1)*(is(1)-n)
14424  CALL pyrobo(ns+1,n,-pyangl(p(ir,3),p(ir,1)),dphi(jt),
14425  & 0d0,0d0,0d0)
14426 
14427 C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14428  IF (mstj(41).EQ.11.OR.mstj(41).EQ.12) THEN
14429  npart=npart+1
14430  ipart(npart)=it
14431  ptpart(npart)=sqrt(parp(71)*dpt2)
14432  ENDIF
14433 
14434 C...Global statistics.
14435  mint(352)=mint(352)+1
14436  vint(352)=vint(352)+sqrt(p(it,1)**2+p(it,2)**2)
14437  IF (mint(352).EQ.1) vint(357)=sqrt(p(it,1)**2+p(it,2)**2)
14438 
14439  ENDIF
14440 
14441 C...Update kinematics variables.
14442  is(jt)=n
14443  dq2(jt)=q2b
14444  IF(mstp(62).GE.3.AND.ntry2.LT.200.AND.mce.EQ.1) the2(jt)=the2t
14445  dsh=dshz
14446 
14447 C...Save quantities; loop back.
14448  q2s(jt)=q2b
14449  dphi(jt)=phibr
14450  mcesv(jt)=mce
14451  IF((mcev.EQ.1.AND.q2b.GE.0.25d0*q2mnc).OR.
14452  &(meev.EQ.1.AND.q2b.GE.q2mne)) THEN
14453  kfls(jt+2)=kfls(jt)
14454  kfls(jt)=kfla
14455  xs(jt)=xa
14456  zs(jt)=z
14457  DO 310 kfl=-25,25
14458  xfs(jt,kfl)=xfa(kfl)
14459  310 CONTINUE
14460  tevcsv(jt)=tevcb
14461  tevesv(jt)=teveb
14462  ELSE
14463  more(jt)=0
14464  IF(jt.EQ.1) ipu1=n
14465  IF(jt.EQ.2) ipu2=n
14466  ENDIF
14467  IF(n.GT.mstu(4)-mstu(32)-10) THEN
14468  CALL pyerrm(11,'(PYSSPA:) no more memory left in PYJETS')
14469  IF(mstu(21).GE.1) n=ns
14470  IF(mstu(21).GE.1) RETURN
14471  ENDIF
14472  IF(more(1).EQ.1.OR.more(2).EQ.1) GOTO 150
14473 
14474 C...Boost hard scattering partons to frame of shower initiators.
14475  DO 320 j=1,3
14476  robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4))
14477  320 CONTINUE
14478  k(n+2,1)=1
14479  DO 330 j=1,5
14480  p(n+2,j)=p(ns+1,j)
14481  330 CONTINUE
14482  CALL pyrobo(n+2,n+2,0d0,0d0,-robo(3),-robo(4),-robo(5))
14483  robo(2)=pyangl(p(n+2,1),p(n+2,2))
14484  robo(1)=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
14485  imin=mint(83)+5
14486  IF(mint(31).GE.2) imin=min(ipus1,ipus2)
14487  CALL pyrobo(imin,ns,0d0,-robo(2),0d0,0d0,0d0)
14488  CALL pyrobo(imin,ns,robo(1),robo(2),robo(3),robo(4),robo(5))
14489 
14490 C...Store user information. Reset Lambda value.
14491  IF(mint(31).LE.1) THEN
14492  k(ipu1,3)=mint(83)+3
14493  k(ipu2,3)=mint(83)+4
14494  ELSE
14495  k(ipu1,3)=mint(83)+1
14496  k(ipu2,3)=mint(83)+2
14497  ENDIF
14498  DO 340 jt=1,2
14499  mint(12+jt)=kfls(jt)
14500  vint(140+jt)=xs(jt)
14501  IF(mint(18+jt).EQ.1) vint(140+jt)=vint(154+jt)*xs(jt)
14502  IF(mint(31).GE.2) vint(140+jt)=vint(140+jt)*vint(142+jt)
14503  340 CONTINUE
14504  paru(112)=alams
14505 
14506  RETURN
14507  END
14508 
14509 C*********************************************************************
14510 
14511 C...PYPTIS
14512 C...Generates pT-ordered spacelike initial-state parton showers and
14513 C...trial joinings.
14514 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14515 C... interaction initiators at PT2NOW.
14516 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14517 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14518 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14519 C... is below PT2CUT.
14520 C... (Also generate test joinings if MSTP(96)=1.)
14521 C...MODE= 1: Accept stored shower branching. Update event record etc.
14522 C...PT2NOW : Starting (max) PT2 scale for evolution.
14523 C...PT2CUT : Lower limit for evolution.
14524 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14525 C...IFAIL : Status return code. IFAIL=0 when all is well.
14526 
14527  SUBROUTINE pyptis(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14528 
14529 C...Double precision and integer declarations.
14530  IMPLICIT DOUBLE PRECISION(a-h, o-z)
14531  IMPLICIT INTEGER(I-N)
14532  INTEGER PYK,PYCHGE,PYCOMP
14533 C...Parameter statement for maximum size of showers.
14534  parameter(maxnur=1000)
14535 C...Commonblocks.
14536  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
14537  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
14538  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
14539  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
14540  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14541  common/pyint1/mint(400),vint(400)
14542  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
14543  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
14544  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
14545  & xmi(2,240),pt2mi(240),imisep(0:240)
14546  common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
14547  & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
14548  common/pyctag/nct,mct(4000,2)
14549  common/pyisjn/mjn1mx,mjn2mx,mjoind(2,240)
14550  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,
14551  & /pyint2/,/pyintm/,/pyismx/,/pyctag/,/pyisjn/
14552 C...Local variables
14553  dimension zsav(2,240),pt2sav(2,240),
14554  & xfb(-25:25),xfa(-25:25),xfn(-25:25),xfj(-25:25),
14555  & wtap(-25:25),wtpdf(-25:25),shtnow(240),
14556  & wtapj(240),wtpdfj(240),x1(240),y(240)
14557  SAVE zsav,pt2sav,xfb,xfa,xfn,wtap,wtpdf,xmxc,shtnow,
14558  & rmb2,rmc2,alam3,alam4,alam5,tmin,ptemax,wtemax,aem2pi
14559 C...For check on excessive weights.
14560  CHARACTER CHWT*12
14561 
14562 C...Only give errors for very large weights, otherwise just warnings
14563  DATA wtemax /1.5d0/
14564 C...Only give errors for large pT, otherwise just warnings
14565  DATA ptemax /5d0/
14566 
14567  ifail=-1
14568 
14569 C----------------------------------------------------------------------
14570 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14571 C...starting from the hardest interaction initiators.
14572  IF (mode.EQ.-1) THEN
14573 C...Set hard scattering SHAT.
14574  shtnow(1)=vint(44)
14575 C...Mass thresholds and Lambda for QCD evolution.
14576  aem2pi=paru(101)/paru(2)
14577  rmb=pmas(5,1)
14578  rmc=pmas(4,1)
14579  alam4=parp(61)
14580  IF(mstu(112).LT.4) alam4=parp(61)*(parp(61)/rmc)**(2d0/25d0)
14581  IF(mstu(112).GT.4) alam4=parp(61)*(rmb/parp(61))**(2d0/25d0)
14582  alam5=alam4*(alam4/rmb)**(2d0/23d0)
14583  alam3=alam4*(rmc/alam4)**(2d0/27d0)
14584 C...Optionally use Lambda_MC = Lambda_CMW
14585  IF (mstp(64).EQ.3) THEN
14586  alam5 = alam5 * 1.569
14587  alam4 = alam4 * 1.618
14588  alam3 = alam3 * 1.661
14589  ENDIF
14590  rmb2=rmb**2
14591  rmc2=rmc**2
14592 C...Massive quark forced creation threshold (in M**2).
14593  tmin=1.01d0
14594 C...Set upper limit for X (ensures some X left for beam remnant).
14595  xmxc=1d0-2d0*parp(111)/vint(1)
14596 
14597  IF (mstp(61).GE.1) THEN
14598 C...Initial values: flavours, momenta, virtualities.
14599  DO 100 js=1,2
14600  nisgen(js,1)=0
14601 
14602 C...Special kinematics check for c/b quarks (that g -> c cbar or
14603 C...b bbar kinematically possible).
14604  kflb=k(imi(js,1,1),2)
14605  kflcb=iabs(kflb)
14606  IF(kfbeam(js).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5)) THEN
14607 C...Check PT2MAX > mQ^2
14608  IF (vint(56).LT.1.05d0*pmas(pycomp(kflcb),1)**2) THEN
14609  CALL pyerrm(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14610  & 'No Q creation possible.')
14611  mint(51)=1
14612  RETURN
14613  ELSE
14614 C...Check for physical z values (m == MQ / sqrt(s))
14615 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14616  fmq=pmas(kflcb,1)/sqrt(shtnow(1))
14617  zmxcr=(1d0-fmq)/(1d0+fmq*(1d0-fmq))
14618  IF (xmi(js,1).GT.0.9d0*zmxcr) THEN
14619  CALL pyerrm(9,'(PYPTIS:) No physical z value for '//
14620  & 'Q creation.')
14621  mint(51)=1
14622  RETURN
14623  ENDIF
14624  ENDIF
14625  ENDIF
14626  100 CONTINUE
14627  ENDIF
14628 
14629  mint(354)=0
14630 C...Zero joining array
14631  DO 110 mj=1,240
14632  mjoind(1,mj)=0
14633  mjoind(2,mj)=0
14634  110 CONTINUE
14635 
14636 C----------------------------------------------------------------------
14637 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14638 C...MINT(30). Store if emission PT2 scale is largest so far.
14639 C...Also generate test joinings if MSTP(96)=1.
14640  ELSEIF(mode.EQ.0) THEN
14641  ifail=-1
14642  mecor=0
14643  isub=mint(1)
14644  js=mint(30)
14645 C...No shower for structureless beam
14646  IF (mint(44+js).EQ.1) RETURN
14647  mi=mint(36)
14648  shat=vint(44)
14649 C...Absolute shower max scale = VINT(56)
14650  pt2=min(pt2now,vint(56))
14651  IF (nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) shtnow(mi)=shat
14652 C...Define for which processes ME corrections have been implemented.
14653  IF(mstp(68).EQ.1.OR.mstp(68).EQ.3) THEN
14654  IF(isub.EQ.1.OR.isub.EQ.2.OR.isub.EQ.141.OR.isub.eq
14655  & .142.OR.isub.EQ.144) mecor=1
14656  IF(isub.EQ.102.OR.isub.EQ.152.OR.isub.EQ.157) mecor=2
14657  IF(isub.EQ.3.OR.isub.EQ.151.OR.isub.EQ.156) mecor=3
14658 C...Calculate preweighting factor for ME-corrected processes.
14659  IF(mecor.GE.1) CALL pymemx(mecor,wtff,wtgf,wtfg,wtgg)
14660  ENDIF
14661 C...Basic info on daughter for which to find mother.
14662  kflb=k(imi(js,mi,1),2)
14663  kflba=iabs(kflb)
14664 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14665 C...second companion.
14666  ksvcb=max(-1,imi(js,mi,2))
14667 C...Treat "first" companion of a pair like an ordinary sea quark
14668 C...(except that creation diagram is not allowed)
14669  IF(imi(js,mi,2).GT.imisep(mi)) ksvcb=-1
14670 C...X (rescaled to [0,1])
14671  xb=xmi(js,mi)/vint(142+js)
14672 C...Massive quarks (use physical masses.)
14673  rmq2=0d0
14674  mqmass=0
14675  IF (kflba.EQ.4.OR.kflba.EQ.5) THEN
14676  rmq2=rmc2
14677  IF (kflba.EQ.5) rmq2=rmb2
14678 C...Special threshold treatment for non-photon beams
14679  IF (kfbeam(js).NE.22) mqmass=kflba
14680  ENDIF
14681 
14682 C...Flags for parton distribution calls.
14683  mint(105)=mint(102+js)
14684  mint(109)=mint(106+js)
14685  vint(120)=vint(2+js)
14686 
14687 C...Calculate initial parton distribution weights.
14688  IF(xb.GE.xmxc) THEN
14689  RETURN
14690  ELSEIF(mqmass.EQ.0) THEN
14691  CALL pypdfu(kfbeam(js),xb,pt2,xfb)
14692  ELSE
14693 C...Initialize massive quark PT2 dependent pdf underestimate.
14694  pt20=pt2
14695  CALL pypdfu(kfbeam(js),xb,pt20,xfb)
14696 C.!.Tentative treatment of massive valence quarks.
14697  xq0=max(1d-10,xpsvc(kflb,ksvcb))
14698  xg0=xfb(21)
14699  tpm0=log(pt20/rmq2)
14700  wpdf0=tpm0*xg0/xq0
14701  ENDIF
14702  IF (kflba.LE.6) THEN
14703 C...For quarks, only include respective sea, val, or cmp part.
14704  IF (ksvcb.LE.0) THEN
14705  xfb(kflb)=xpsvc(kflb,ksvcb)
14706  ELSE
14707 C...Find companion's companion
14708  misea=0
14709  120 misea=misea+1
14710  IF (imi(js,misea,2).NE.imi(js,mi,1)) GOTO 120
14711  xs=xmi(js,misea)
14712  xrem=vint(142+js)
14713  ys=xs/(xrem+xs)
14714 C...Momentum fraction of the companion quark.
14715 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14716  yb=xb*(1d0-ys)
14717  xfb(kflb)=pyfcmp(yb/vint(140),ys/vint(140),mstp(87))
14718  ENDIF
14719  ENDIF
14720 
14721 C...Determine overestimated z range: switch at c and b masses.
14722  130 IF (pt2.GT.tmin*rmb2) THEN
14723  izrg=3
14724  pt2mne=max(tmin*rmb2,pt2cut)
14725  b0=23d0/6d0
14726  alam2=alam5**2
14727  ELSEIF(pt2.GT.tmin*rmc2) THEN
14728  izrg=2
14729  pt2mne=max(tmin*rmc2,pt2cut)
14730  b0=25d0/6d0
14731  alam2=alam4**2
14732  ELSE
14733  izrg=1
14734  pt2mne=pt2cut
14735  b0=27d0/6d0
14736  alam2=alam3**2
14737  ENDIF
14738 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14739  alam2=alam2/parp(64)
14740 C...Overestimated ZMAX:
14741  IF (mqmass.EQ.0) THEN
14742 C...Massless
14743  zmax=1d0-0.5d0*(pt2mne/shtnow(mi))*(sqrt(1d0+4d0*shtnow(mi)
14744  & /pt2mne)-1d0)
14745  ELSE
14746 C...Massive (limit for bremsstrahlung diagram > creation)
14747  fmq=sqrt(rmq2/shtnow(mi))
14748  zmax=1d0/(1d0+fmq)
14749  ENDIF
14750  zmin=xb/xmxc
14751 
14752 C...If kinematically impossible then do not evolve.
14753  IF(pt2.LT.pt2cut.OR.zmax.LE.zmin) RETURN
14754 
14755 C...Reset Altarelli-Parisi and PDF weights.
14756  DO 140 kfl=-5,5
14757  wtap(kfl)=0d0
14758  wtpdf(kfl)=0d0
14759  140 CONTINUE
14760  wtap(21)=0d0
14761  wtpdf(21)=0d0
14762 C...Zero joining weights and compute X(partner) and X(mother) values.
14763  IF (mstp(96).NE.0) THEN
14764  njn=0
14765  DO 150 mj=1,mint(31)
14766  wtapj(mj)=0d0
14767  wtpdfj(mj)=0d0
14768  x1(mj)=xmi(js,mj)/(vint(142+js)+xmi(js,mj))
14769  y(mj)=(xmi(js,mi)+xmi(js,mj))/(vint(142+js)+xmi(js,mj)
14770  & +xmi(js,mi))
14771  150 CONTINUE
14772  ENDIF
14773 
14774 C...Approximate Altarelli-Parisi weights (integrated AP dz).
14775 C...q -> q, g -> q or q -> q + gamma (already set which).
14776  IF(kflba.LE.5) THEN
14777 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14778  IF (ksvcb.LT.0) THEN
14779  wtap(kflb)=(8d0/3d0)*log((1d0-zmin)/(1d0-zmax))
14780  ELSE
14781  rmin=(1+sqrt(zmin))/(1-sqrt(zmin))
14782  rmax=(1+sqrt(zmax))/(1-sqrt(zmax))
14783  wtap(kflb)=(8d0/3d0)*log(rmax/rmin)
14784  ENDIF
14785  wtap(21)=0.5d0*(zmax-zmin)
14786  wtape=(2d0/9d0)*log((1d0-zmin)/(1d0-zmax))
14787  IF(mod(kflba,2).EQ.0) wtape=4d0*wtape
14788  IF(mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
14789  wtap(kflb)=wtff*wtap(kflb)
14790  wtap(21)=wtgf*wtap(21)
14791  wtape=wtff*wtape
14792  ENDIF
14793  IF (ksvcb.GE.1) THEN
14794 C...Kill normal creation but add joining diagrams for cmp quark.
14795  wtap(21)=0d0
14796  IF (kflba.EQ.4.OR.kflba.EQ.5) THEN
14797  CALL pyerrm(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14798  & " quark here. Not handled yet, giving up!")
14799  pt2=0d0
14800  mint(51)=1
14801  RETURN
14802  ENDIF
14803 C...Check for possible joinings
14804  IF (mstp(96).NE.0.AND.mjoind(js,mi).EQ.0) THEN
14805 C...Find companion's companion.
14806  mj=0
14807  160 mj=mj+1
14808  IF (imi(js,mj,2).NE.imi(js,mi,1)) GOTO 160
14809  IF (mjoind(js,mj).EQ.0) THEN
14810  y(mi)=yb+ys
14811  z=yb/y(mi)
14812  wtapj(mj)=z*(1d0-z)*0.5d0*(z**2+(1d0-z)**2)
14813  IF (wtapj(mj).GT.1d-6) THEN
14814  njn=1
14815  ELSE
14816  wtapj(mj)=0d0
14817  ENDIF
14818  ENDIF
14819 C...Add trial gluon joinings.
14820  DO 170 mj=1,mint(31)
14821  kflc=k(imi(js,mj,1),2)
14822  IF (kflc.NE.21.OR.mjoind(js,mj).NE.0) GOTO 170
14823  z=xmi(js,mj)/(xmi(js,mi)+xmi(js,mj))
14824  wtapj(mj)=6d0*(z**2+(1d0-z)**2)
14825  IF (wtapj(mj).GT.1d-6) THEN
14826  njn=njn+1
14827  ELSE
14828  wtapj(mj)=0d0
14829  ENDIF
14830  170 CONTINUE
14831  ENDIF
14832  ELSEIF (imi(js,mi,2).GE.0) THEN
14833 C...Kill creation diagram for val quarks and sea quarks with companions.
14834  wtap(21)=0d0
14835  ELSEIF (mqmass.EQ.0) THEN
14836 C...Extra safety factor for massless sea quark creation.
14837  wtap(21)=wtap(21)*1.25d0
14838  ENDIF
14839 
14840 C... q -> g, g -> g.
14841  ELSEIF(kflb.EQ.21) THEN
14842 C...Here we decide later whether a quark picked up is valence or
14843 C...sea, so we maintain the extra factor sqrt(z) since we deal
14844 C...with the *sum* of sea and valence in this context.
14845  wtapq=(16d0/3d0)*(sqrt(1d0/zmin)-sqrt(1d0/zmax))
14846 C...new: do not allow backwards evol to pick up heavy flavour.
14847  DO 180 kfl=1,min(3,mstp(58))
14848  wtap(kfl)=wtapq
14849  wtap(-kfl)=wtapq
14850  180 CONTINUE
14851  wtap(21)=6d0*log(zmax*(1d0-zmin)/(zmin*(1d0-zmax)))
14852  IF(mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
14853  wtapq=wtfg*wtapq
14854  wtap(21)=wtgg*wtap(21)
14855  ENDIF
14856 C...Check for possible joinings (companions handled separately above)
14857  IF (mstp(96).NE.0.AND.mint(31).GE.2.AND.mjoind(js,mi).EQ.0)
14858  & THEN
14859  DO 190 mj=1,mint(31)
14860  IF (mj.EQ.mi.OR.mjoind(js,mj).NE.0) GOTO 190
14861  ksvcc=imi(js,mj,2)
14862  IF (imi(js,mj,2).GT.imisep(mj)) ksvcc=-1
14863  IF (ksvcc.GE.1) GOTO 190
14864  kflc=k(imi(js,mj,1),2)
14865 C...Only try g -> g + g once.
14866  IF (mj.GT.mi.AND.kflc.EQ.21) GOTO 190
14867  z=xmi(js,mj)/(xmi(js,mi)+xmi(js,mj))
14868  IF (kflc.EQ.21) THEN
14869  wtapj(mj)=6d0*(z**2+(1d0-z)**2)
14870  ELSE
14871  wtapj(mj)=z*4d0/3d0*(1d0+z**2)
14872  ENDIF
14873  IF (wtapj(mj).GT.1d-6) THEN
14874  njn=njn+1
14875  ELSE
14876  wtapj(mj)=0d0
14877  ENDIF
14878  190 CONTINUE
14879  ENDIF
14880  ENDIF
14881 
14882 C...Initialize massive quark evolution
14883  IF (mqmass.NE.0) THEN
14884  rml=(rmq2+vint(18))/alam2
14885  tml=log(rml)
14886  tpl=log((pt2+vint(18))/alam2)
14887  tpm=log((pt2+vint(18))/rmq2)
14888  wn=wtap(21)*wpdf0/b0
14889  ENDIF
14890 
14891 
14892 C...Loopback point for iteration
14893  ntry=0
14894  nthres=0
14895  200 ntry=ntry+1
14896  IF(ntry.GT.500) THEN
14897  CALL pyerrm(9,'(PYPTIS:) failed to evolve shower.')
14898  mint(51)=1
14899  RETURN
14900  ENDIF
14901 
14902 C... Calculate PDF weights and sum for evolution rate.
14903  wtsum=0d0
14904  xfbo=max(1d-10,xfb(kflb))
14905  DO 210 kfl=-5,5
14906  wtpdf(kfl)=xfb(kfl)/xfbo
14907  wtsum=wtsum+wtap(kfl)*wtpdf(kfl)
14908  210 CONTINUE
14909 C...Only add gluon mother diagram for massless KFLB.
14910  IF(mqmass.EQ.0) THEN
14911  wtpdf(21)=xfb(21)/xfbo
14912  wtsum=wtsum+wtap(21)*wtpdf(21)
14913  ENDIF
14914  wtsum=max(0.0001d0,wtsum)
14915  wtsums=wtsum
14916 C...Add joining diagrams where applicable.
14917  wtjoin=0d0
14918  IF (mstp(96).NE.0.AND.njn.NE.0) THEN
14919  DO 220 mj=1,mint(31)
14920  IF (wtapj(mj).LT.1d-3) GOTO 220
14921  wtpdfj(mj)=1d0/xfbo
14922 C...x and x*pdf (+ sea/val) for parton C.
14923  kflc=k(imi(js,mj,1),2)
14924  kflca=iabs(kflc)
14925  ksvcc=max(-1,imi(js,mj,2))
14926  IF (imi(js,mj,2).GT.imisep(mj)) ksvcc=-1
14927  mint(30)=js
14928  mint(36)=mj
14929  CALL pypdfu(kfbeam(js),x1(mj),pt2,xfj)
14930  mint(36)=mi
14931  IF (kflca.LE.6.AND.ksvcc.LE.0) THEN
14932  xfj(kflc)=xpsvc(kflc,ksvcc)
14933  ELSEIF (ksvcc.GE.1) THEN
14934  print*, 'error! parton C is companion!'
14935  ENDIF
14936  wtpdfj(mj)=wtpdfj(mj)/xfj(kflc)
14937 C...x and x*pdf (+ sea/val) for parton A.
14938  kfla=21
14939  ksvca=0
14940  IF (kflca.EQ.21.AND.kflba.LE.5) THEN
14941  kfla=kflb
14942  ksvca=ksvcb
14943  ELSEIF (kflba.EQ.21.AND.kflca.LE.5) THEN
14944  kfla=kflc
14945  ksvca=ksvcc
14946  ENDIF
14947  mint(30)=js
14948  IF (ksvca.LE.0) THEN
14949 C...Consider C the "evolved" parton if B is gluon. Val/sea
14950 C...counting will then be done correctly in PYPDFU.
14951  IF (kflba.EQ.21) mint(36)=mj
14952  CALL pypdfu(kfbeam(js),y(mj),pt2,xfj)
14953  mint(36)=mi
14954  IF (iabs(kfla).LE.6) xfj(kfla)=xpsvc(kfla,ksvca)
14955  ELSE
14956 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14957  xfj(kfla)=pyfcmp(y(mi)/vint(140),ys/vint(140),mstp(87))
14958  ENDIF
14959  wtpdfj(mj)=xfj(kfla)*wtpdfj(mj)
14960  wtjoin=wtjoin+wtapj(mj)*wtpdfj(mj)
14961  220 CONTINUE
14962  ENDIF
14963 
14964 C...Pick normal pT2 (in overestimated z range).
14965  230 pt2old=pt2
14966  wtsum=wtsums
14967  pt2=alam2*((pt2+vint(18))/alam2)**(pyr(0)**(b0/wtsum))-vint(18)
14968  kflc=21
14969 
14970 C...Evolve q -> q gamma separately, pick it if larger pT.
14971  IF(kflba.LE.5) THEN
14972  pt2qed=(pt2old+vint(18))*pyr(0)**(1d0/(aem2pi*wtape))-vint(18)
14973  IF(pt2qed.GT.pt2) THEN
14974  pt2=pt2qed
14975  kflc=22
14976  kfla=kflb
14977  ENDIF
14978  ENDIF
14979 
14980 C... Evolve massive quark creation separately.
14981  mcrqq=0
14982  IF (mqmass.NE.0) THEN
14983  pt2cr=(rmq2+vint(18))*(rml**(tpm/(tpl*pyr(0)**(-tml/wn)-tpm)))
14984  & -vint(18)
14985 C... Ensure mininimum PT2CR and force creation near threshold.
14986  IF (pt2cr.LT.tmin*rmq2) THEN
14987  nthres=nthres+1
14988  IF (nthres.GT.50) THEN
14989  CALL pyerrm(9,'(PYPTIS:) no phase space left for '//
14990  & 'massive quark creation. Gave up trying.')
14991  mint(51)=1
14992 C...Special return code if failing before any evolution at all: bad event
14993  IF (nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) mint(51)=2
14994  RETURN
14995  ENDIF
14996  pt2=0d0
14997  pt2cr=tmin*rmq2
14998  mcrqq=2
14999  ENDIF
15000 C... Select largest PT2 (brems or creation):
15001  IF (pt2cr.GT.pt2) THEN
15002  mcrqq=max(mcrqq,1)
15003  wtsum=0d0
15004  pt2=pt2cr
15005  kfla=21
15006  ELSE
15007  mcrqq=0
15008  kfla=kflb
15009  ENDIF
15010 C... Compute logarithms for this PT2
15011  tpl=log((pt2+vint(18))/alam2)
15012  tpm=log((pt2+vint(18))/(rmq2+vint(18)))
15013  wtcrqq=tpm/log(pt2/rmq2)
15014  ENDIF
15015 
15016 C...Evolve joining separately
15017  mjoin=0
15018  IF (mstp(96).NE.0.AND.njn.NE.0) THEN
15019  pt2jn=alam2*((pt2old+vint(18))/alam2)**(pyr(0)**(b0/wtjoin))
15020  & -vint(18)
15021  IF (pt2jn.GE.pt2) THEN
15022  mjoin=1
15023  pt2=pt2jn
15024  ENDIF
15025  ENDIF
15026 
15027 C...Loopback if crossed c/b mass thresholds.
15028  IF(izrg.EQ.3.AND.pt2.LT.rmb2) THEN
15029  pt2=rmb2
15030  GOTO 130
15031  ELSEIF(izrg.EQ.2.AND.pt2.LT.rmc2) THEN
15032  pt2=rmc2
15033  GOTO 130
15034  ENDIF
15035 
15036 C...Speed up shower. Skip if higher-PT acceptable branching
15037 C...already found somewhere else.
15038 C...Also finish if below lower cutoff.
15039 
15040  IF (pt2.LT.pt2mx.OR.pt2.LT.pt2cut) RETURN
15041 
15042 C...Select parton A flavour (massive Q handled above.)
15043  IF (mqmass.EQ.0.AND.kflc.NE.22.AND.mjoin.EQ.0) THEN
15044  wtran=pyr(0)*wtsum
15045  kfla=-6
15046  240 kfla=kfla+1
15047  wtran=wtran-wtap(kfla)*wtpdf(kfla)
15048  IF(kfla.LE.5.AND.wtran.GT.0d0) GOTO 240
15049  IF(kfla.EQ.6) kfla=21
15050  ELSEIF (mjoin.EQ.1) THEN
15051 C...Tentative joining accept/reject.
15052  wtran=pyr(0)*wtjoin
15053  mj=0
15054  250 mj=mj+1
15055  wtran=wtran-wtapj(mj)*wtpdfj(mj)
15056  IF(mj.LE.mint(31)-1.AND.wtran.GT.0d0) GOTO 250
15057  IF(mjoind(js,mj).NE.0.OR.mjoind(js,mi).NE.0) THEN
15058  CALL pyerrm(9,'(PYPTIS:) Attempted double joining.'//
15059  & ' Rejected.')
15060  GOTO 230
15061  ENDIF
15062 C...x*pdf (+ sea/val) at new pT2 for parton B.
15063  IF (ksvcb.LE.0) THEN
15064  mint(30)=js
15065  CALL pypdfu(kfbeam(js),xb,pt2,xfb)
15066  IF (kflba.LE.6) xfb(kflb)=xpsvc(kflb,ksvcb)
15067  ELSE
15068 C...Companion distributions do not evolve.
15069  xfb(kflb)=xfbo
15070  ENDIF
15071  wtveto=1d0/wtpdfj(mj)/xfb(kflb)
15072  kflc=k(imi(js,mj,1),2)
15073  kflca=iabs(kflc)
15074  ksvcc=max(-1,imi(js,mj,2))
15075  IF (ksvcb.GE.1) ksvcc=-1
15076 C...x*pdf (+ sea/val) at new pT2 for parton C.
15077  mint(30)=js
15078  mint(36)=mj
15079  CALL pypdfu(kfbeam(js),x1(mj),pt2,xfj)
15080  mint(36)=mi
15081  IF (kflca.LE.6.AND.ksvcc.LE.0) xfj(kflc)=xpsvc(kflc,ksvcc)
15082  wtveto=wtveto/xfj(kflc)
15083 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15084  kfla=21
15085  ksvca=0
15086  IF (kflca.EQ.21.AND.kflba.LE.5) THEN
15087  kfla=kflb
15088  ksvca=ksvcb
15089  ELSEIF (kflba.EQ.21.AND.kflca.LE.5) THEN
15090  kfla=kflc
15091  ksvca=ksvcc
15092  ENDIF
15093  IF (ksvca.LE.0) THEN
15094  mint(30)=js
15095  IF (kflb.EQ.21) mint(36)=mj
15096  CALL pypdfu(kfbeam(js),y(mj),pt2,xfj)
15097  mint(36)=mi
15098  IF (iabs(kfla).LE.6) xfj(kfla)=xpsvc(kfla,ksvca)
15099  ELSE
15100  xfj(kfla)=pyfcmp(y(mj)/vint(140),ys/vint(140),mstp(87))
15101  ENDIF
15102  wtveto=wtveto*xfj(kfla)
15103 C...Monte Carlo veto.
15104  IF (wtveto.LT.pyr(0)) GOTO 200
15105 C...If accept, save PT2 of this joining.
15106  IF (pt2.GT.pt2mx) THEN
15107  pt2mx=pt2
15108  jsmx=2+js
15109  mjn1mx=mj
15110  mjn2mx=mi
15111  wtapj(mj)=0d0
15112  njn=0
15113  ENDIF
15114 C...Exit and continue evolution.
15115  GOTO 390
15116  ENDIF
15117  kflaa=iabs(kfla)
15118 
15119 C...Choose z value (still in overestimated range) and corrective weight.
15120 C...Unphysical z will be rejected below when Q2 has is computed.
15121  wtz=0d0
15122 
15123 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15124 C...q -> q + g or q -> q + gamma (already set which).
15125  IF (kflaa.LE.5.AND.kflba.LE.5) THEN
15126  IF (ksvcb.LT.0) THEN
15127  z=1d0-(1d0-zmin)*((1d0-zmax)/(1d0-zmin))**pyr(0)
15128  ELSE
15129  zfac=rmin*(rmax/rmin)**pyr(0)
15130  z=((1-zfac)/(1+zfac))**2
15131  ENDIF
15132  wtz=0.5d0*(1d0+z**2)
15133 C...Massive weight correction.
15134  IF (kflba.GE.4) wtz=wtz-z*(1d0-z)**2*rmq2/pt2
15135 C...Valence quark weight correction (extra sqrt)
15136  IF (ksvcb.GE.0) wtz=wtz*sqrt(z)
15137 
15138 C...q -> g + q.
15139 C...NB: MQ>0 not yet implemented. Forced absent above.
15140  ELSEIF (kflaa.LE.5.AND.kflb.EQ.21) THEN
15141  kflc=kfla
15142  z=zmax/(1d0+pyr(0)*(sqrt(zmax/zmin)-1d0))**2
15143  wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
15144 
15145 C...g -> q + qbar.
15146  ELSEIF (kfla.EQ.21.AND.kflba.LE.5) THEN
15147  kflc=-kflb
15148  z=zmin+pyr(0)*(zmax-zmin)
15149  wtz=z**2+(1d0-z)**2
15150 C...Massive correction
15151  IF (mqmass.NE.0) THEN
15152  wtz=wtz+2d0*z*(1d0-z)*rmq2/pt2
15153 C...Extra safety margin for light sea quark creation
15154  ELSEIF (ksvcb.LT.0) THEN
15155  wtz=wtz/1.25d0
15156  ENDIF
15157 
15158 C...g -> g + g.
15159  ELSEIF (kfla.EQ.21.AND.kflb.EQ.21) THEN
15160  kflc=21
15161  z=1d0/(1d0+((1d0-zmin)/zmin)*((1d0-zmax)*zmin/
15162  & (zmax*(1d0-zmin)))**pyr(0))
15163  wtz=(1d0-z*(1d0-z))**2
15164  ENDIF
15165 
15166 C...Derive Q2 from pT2.
15167  q2b=pt2/(1d0-z)
15168  IF (kflba.GE.4) q2b=q2b-rmq2
15169 
15170 C...Loopback if outside allowed z range for given pT2.
15171  rm2c=pymass(kflc)**2
15172  pt2adj=q2b-z*(shtnow(mi)+q2b)*(q2b+rm2c)/shtnow(mi)
15173  IF (pt2adj.LT.1d-6) GOTO 230
15174 
15175 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15176 C...No modification for very first emission if using ME correction
15177  mstp67 = mstp(67)
15178  IF (mecor.GE.1.AND.nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) THEN
15179  mstp67 = 0
15180  ENDIF
15181 
15182 C...For 1st branching, limit phase space by s-hat with color-partner
15183  IF (mstp67.GE.1.AND.nisgen(js,mi).EQ.0) THEN
15184  mside=1
15185  idip=imi(js,mi,1)
15186 C...Use anticolor tag for antiquark, or for gluon half the time
15187  IF ((kflb.LT.0.AND.kflba.LT.10).OR.(
15188  & kflb.EQ.21.AND.pyr(0).GT.0.5)) mside=2
15189 C...Tag
15190  mctag=mct(idip,mside)
15191 C...Default is to set up phase space using the opposite incoming parton
15192  jdip=imi(3-js,mi,1)
15193  ndip=0
15194 C...Alternatively, look for final-state color partner (pick first if several)
15195  DO 260 ifs=1,npart
15196  IF (mct(ipart(ifs),mside).EQ.mctag.AND.ndip.EQ.0) THEN
15197  jdip=ipart(ifs)
15198  ndip=ndip+1
15199  ENDIF
15200  260 CONTINUE
15201 C...Compute mass of pair
15202  sdip=(p(idip,4)+p(jdip,4))**2-(p(idip,3)+p(jdip,3))**2
15203  & -(p(idip,2)+p(jdip,2))**2-(p(idip,1)+p(jdip,1))**2
15204  IF (mstp67.EQ.1) THEN
15205 C...1 Option to completely kill radiation above s_dip * PARP(67)
15206  IF (4*pt2.GT.parp(67)*sdip) GOTO 230
15207  ELSE IF (mstp67.EQ.2) THEN
15208 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15209 C... (-> improved power showers?)
15210  IF (4*pt2*pyr(0).GT.parp(67)*sdip) GOTO 230
15211  ENDIF
15212 
15213 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15214  ELSE IF (mstp(62).GE.3.AND.nisgen(js,mi).GE.1) THEN
15215  IF(pt2.GT.((1d0-z)/(z*(1d0-zsav(js,mi))))**2*pt2sav(js,mi))
15216  & GOTO 230
15217  ENDIF
15218 
15219 C...Select phi angle of branching at random.
15220  phi=paru(2)*pyr(0)
15221 
15222 C...Matrix-element corrections for some processes.
15223  IF (mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
15224  IF (kflaa.LE.20.AND.kflba.LE.20) THEN
15225  CALL pymewt(mecor,1,q2b*shat/shtnow(mi),z,phi,wtme)
15226  wtz=wtz*wtme/wtff
15227  ELSEIF((kfla.EQ.21.OR.kfla.EQ.22).AND.kflba.LE.20) THEN
15228  CALL pymewt(mecor,2,q2b*shat/shtnow(mi),z,phi,wtme)
15229  wtz=wtz*wtme/wtgf
15230  ELSEIF(kflaa.LE.20.AND.(kflb.EQ.21.OR.kflb.EQ.22)) THEN
15231  CALL pymewt(mecor,3,q2b*shat/shtnow(mi),z,phi,wtme)
15232  wtz=wtz*wtme/wtfg
15233  ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
15234  CALL pymewt(mecor,4,q2b*shat/shtnow(mi),z,phi,wtme)
15235  wtz=wtz*wtme/wtgg
15236  ENDIF
15237  ENDIF
15238 
15239 C...Parton distributions at new pT2 but old x.
15240  mint(30)=js
15241  CALL pypdfu(kfbeam(js),xb,pt2,xfn)
15242 C...Treat val and cmp separately
15243  IF (kflba.LE.6.AND.ksvcb.LE.0) xfn(kflb)=xpsvc(kflb,ksvcb)
15244  IF (ksvcb.GE.1)
15245  & xfn(kflb)=pyfcmp(yb/vint(140),ys/vint(140),mstp(87))
15246  xfbn=xfn(kflb)
15247  IF(xfbn.LT.1d-20) THEN
15248  IF(kfla.EQ.kflb) THEN
15249  wtap(kflb)=0d0
15250  GOTO 200
15251  ELSE
15252  xfbn=1d-10
15253  xfn(kflb)=xfbn
15254  ENDIF
15255  ENDIF
15256  DO 270 kfl=-5,5
15257  xfb(kfl)=xfn(kfl)
15258  270 CONTINUE
15259  xfb(21)=xfn(21)
15260 
15261 C...Parton distributions at new pT2 and new x.
15262  xa=xb/z
15263  mint(30)=js
15264  CALL pypdfu(kfbeam(js),xa,pt2,xfa)
15265  IF (kflba.LE.5.AND.kflaa.LE.5) THEN
15266 C...q -> q + g: only consider respective sea, val, or cmp content.
15267  IF (ksvcb.LE.0) THEN
15268  xfa(kfla)=xpsvc(kfla,ksvcb)
15269  ELSE
15270  ya=xa*(1d0-ys)
15271  xfa(kflb)=pyfcmp(ya/vint(140),ys/vint(140),mstp(87))
15272  ENDIF
15273  ENDIF
15274  xfan=xfa(kfla)
15275  IF(xfan.LT.1d-20) THEN
15276  GOTO 200
15277  ENDIF
15278 
15279 C...If weighting fails continue evolution.
15280  wttot=0d0
15281  IF (mcrqq.EQ.0) THEN
15282  wtpdfa=1d0/wtpdf(kfla)
15283  wttot=wtz*xfan/xfbn*wtpdfa
15284  ELSEIF(mcrqq.EQ.1) THEN
15285  wtpdfa=tpm/wpdf0
15286  wttot=wtcrqq*wtz*xfan/xfbn*wtpdfa
15287  xbest=tpm/tpm0*xq0
15288  ELSEIF(mcrqq.EQ.2) THEN
15289 C...Force massive quark creation.
15290  wttot=1d0
15291  ENDIF
15292 
15293 C...Loop back if trial emission fails.
15294  IF(wttot.GE.0d0.AND.wttot.LT.pyr(0)) GOTO 200
15295  wtacc=((1d0+pt2)/(0.25d0+pt2))**2
15296  IF(wttot.LT.0d0) THEN
15297  WRITE(chwt,'(1P,E12.4)') wttot
15298  CALL pyerrm(19,'(PYPTIS:) Weight '//chwt//' negative')
15299  ELSEIF(wttot.GT.wtacc) THEN
15300  WRITE(chwt,'(1P,E12.4)') wttot
15301  IF (pt2.GT.ptemax.OR.wttot.GE.wtemax) THEN
15302 C...Too high weight: write out as error, but do not update error counter
15303  IF(mstu(29).EQ.0) mstu(23)=mstu(23)-1
15304  CALL pyerrm(19,
15305  & '(PYPTIS:) Weight '//chwt//' above unity')
15306  IF (pt2.GT.ptemax) ptemax=pt2
15307  IF (wttot.GT.wtemax) wtemax=wttot
15308  ELSE
15309  CALL pyerrm(9,
15310  & '(PYPTIS:) Weight '//chwt//' above unity')
15311  ENDIF
15312 C...Useful for debugging but commented out for distribution:
15313 C print*, 'JS, MI',JS, MI
15314 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15315 C print*, 'A -> B C',KFLA, KFLB, KFLC
15316 C XFAO=XFBO/WTPDFA
15317 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15318  ENDIF
15319 
15320 C...Save acceptable branching.
15321  IF(pt2.GT.pt2mx) THEN
15322  mimx=mint(36)
15323  jsmx=js
15324  pt2mx=pt2
15325  kflamx=kfla
15326  kflcmx=kflc
15327  rm2cmx=rm2c
15328  q2bmx=q2b
15329  zmx=z
15330  pt2amx=pt2adj
15331  phimx=phi
15332  ENDIF
15333 
15334 C----------------------------------------------------------------------
15335 C...MODE= 1: Accept stored shower branching. Update event record etc.
15336  ELSEIF (mode.EQ.1) THEN
15337  mi=mimx
15338  js=jsmx
15339  shat=shtnow(mi)
15340  side=3d0-2d0*js
15341 C...Shift down rest of event record to make room for insertion.
15342  it=imisep(mi)+1
15343  im=it+1
15344  is=imi(js,mi,1)
15345  DO 290 i=n,it,-1
15346  IF (k(i,3).GE.it) k(i,3)=k(i,3)+2
15347  kt1=k(i,4)/mstu(5)**2
15348  kt2=k(i,5)/mstu(5)**2
15349  id1=mod(k(i,4),mstu(5))
15350  id2=mod(k(i,5),mstu(5))
15351  im1=mod(k(i,4)/mstu(5),mstu(5))
15352  im2=mod(k(i,5)/mstu(5),mstu(5))
15353  IF (id1.GE.it) id1=id1+2
15354  IF (id2.GE.it) id2=id2+2
15355  IF (im1.GE.it) im1=im1+2
15356  IF (im2.GE.it) im2=im2+2
15357  k(i,4)=kt1*mstu(5)**2+im1*mstu(5)+id1
15358  k(i,5)=kt2*mstu(5)**2+im2*mstu(5)+id2
15359  DO 280 ix=1,5
15360  k(i+2,ix)=k(i,ix)
15361  p(i+2,ix)=p(i,ix)
15362  v(i+2,ix)=v(i,ix)
15363  280 CONTINUE
15364  mct(i+2,1)=mct(i,1)
15365  mct(i+2,2)=mct(i,2)
15366  290 CONTINUE
15367  n=n+2
15368 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15369  DO 300 ji=1,mint(31)
15370  IF (imi(1,ji,1).GE.it) imi(1,ji,1)=imi(1,ji,1)+2
15371  IF (imi(1,ji,2).GE.it) imi(1,ji,2)=imi(1,ji,2)+2
15372  IF (imi(2,ji,1).GE.it) imi(2,ji,1)=imi(2,ji,1)+2
15373  IF (imi(2,ji,2).GE.it) imi(2,ji,2)=imi(2,ji,2)+2
15374  IF (ji.GE.mi) imisep(ji)=imisep(ji)+2
15375 C...Also update companion pointers to the present mother.
15376  IF (imi(js,ji,2).EQ.is) imi(js,ji,2)=im
15377  300 CONTINUE
15378  DO 310 ifs=1,npart
15379  IF (ipart(ifs).GE.it) ipart(ifs)=ipart(ifs)+2
15380  310 CONTINUE
15381 C...Zero entries dedicated for new timelike and mother partons.
15382  DO 330 i=it,it+1
15383  DO 320 j=1,5
15384  k(i,j)=0
15385  p(i,j)=0d0
15386  v(i,j)=0d0
15387  320 CONTINUE
15388  mct(i,1)=0
15389  mct(i,2)=0
15390  330 CONTINUE
15391 
15392 C...Define timelike and new mother partons. History.
15393  k(it,1)=3
15394  k(it,2)=kflcmx
15395  k(im,1)=14
15396  k(im,2)=kflamx
15397  k(is,3)=im
15398  k(it,3)=im
15399 C...Set mother origin = side.
15400  k(im,3)=mint(83)+js+2
15401  IF(mi.GE.2) k(im,3)=mint(83)+js
15402 
15403 C...Define colour flow of branching.
15404  im1=im
15405  im2=im
15406 C...q -> q + gamma.
15407  IF(k(it,2).EQ.22) THEN
15408  k(it,1)=1
15409  id1=is
15410  id2=is
15411 C...q -> q + g.
15412  ELSEIF(k(im,2).GT.0.AND.k(im,2).LE.5.AND.k(it,2).EQ.21) THEN
15413  id1=it
15414  id2=is
15415 C...q -> g + q.
15416  ELSEIF(k(im,2).GT.0.AND.k(im,2).LE.5) THEN
15417  id1=is
15418  id2=it
15419 C...qbar -> qbar + g.
15420  ELSEIF(k(im,2).LT.0.AND.k(im,2).GE.-5.AND.k(it,2).EQ.21) THEN
15421  id1=is
15422  id2=it
15423 C...qbar -> g + qbar.
15424  ELSEIF(k(im,2).LT.0.AND.k(im,2).GE.-5) THEN
15425  id1=it
15426  id2=is
15427 C...g -> g + g; g -> q + qbar..
15428  ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
15429  id1=is
15430  id2=it
15431  ELSE
15432  id1=it
15433  id2=is
15434  ENDIF
15435  IF(im1.EQ.im) k(im1,4)=k(im1,4)+id1
15436  IF(im2.EQ.im) k(im2,5)=k(im2,5)+id2
15437  k(id1,4)=k(id1,4)+mstu(5)*im1
15438  k(id2,5)=k(id2,5)+mstu(5)*im2
15439  IF(id1.NE.id2) THEN
15440  k(id1,5)=k(id1,5)+mstu(5)*id2
15441  k(id2,4)=k(id2,4)+mstu(5)*id1
15442  ENDIF
15443  IF(k(it,1).EQ.1) THEN
15444  k(it,4)=0
15445  k(it,5)=0
15446  ENDIF
15447 C...Update IMI and colour tag arrays.
15448  imi(js,mi,1)=im
15449  DO 340 mc=1,2
15450  mct(it,mc)=0
15451  mct(im,mc)=0
15452  340 CONTINUE
15453  DO 350 jcs=4,5
15454  kcs=jcs
15455 C...If mother flag not yet set for spacelike parton, trace it.
15456  IF (k(is,kcs)/mstu(5)**2.LE.1) CALL pycttr(is,-kcs,im)
15457  IF(mint(51).NE.0) RETURN
15458  350 CONTINUE
15459  DO 360 jcs=4,5
15460  kcs=jcs
15461 C...If mother flag not yet set for timelike parton, trace it.
15462  IF (k(it,kcs)/mstu(5)**2.LE.1) CALL pycttr(it,kcs,im)
15463  IF(mint(51).NE.0) RETURN
15464  360 CONTINUE
15465 
15466 C...Boost recoiling parton to compensate for Q2 scale.
15467  betaz=side*(1d0-(1d0+q2bmx/shat)**2)/
15468  & (1d0+(1d0+q2bmx/shat)**2)
15469  ir=imi(3-js,mi,1)
15470  CALL pyrobo(ir,ir,0d0,0d0,0d0,0d0,betaz)
15471 
15472 C...Define system to be rotated and boosted
15473 C...(not including the 2 just added partons)
15474 C...(but including the docu lines for first interaction)
15475  imin=imisep(mi-1)+1
15476  IF (mi.EQ.1) imin=mint(83)+5
15477  imax=imisep(mi)-2
15478 
15479 C...Rotate back system in phi to compensate for subsequent rotation.
15480  CALL pyrobo(imin,imax,0d0,-phimx,0d0,0d0,0d0)
15481 
15482 C...Define kinematics of new partons in old frame.
15483  imax=imisep(mi)
15484  p(im,1)=sqrt(pt2amx)*shat/(zmx*(shat+q2bmx))
15485  p(im,3)=0.5d0*sqrt(shat)*((shat-q2bmx)/((shat
15486  & +q2bmx)*zmx)+(q2bmx+rm2cmx)/shat)*side
15487  p(im,4)=sqrt(p(im,1)**2+p(im,3)**2)
15488  p(it,1)=p(im,1)
15489  p(it,3)=p(im,3)-0.5d0*(shat+q2bmx)/sqrt(shat)*side
15490  p(it,4)=sqrt(p(it,1)**2+p(it,3)**2+rm2cmx)
15491  p(it,5)=sqrt(rm2cmx)
15492 
15493 C...Update internal line, now spacelike
15494  p(is,1)=p(im,1)-p(it,1)
15495  p(is,2)=p(im,2)-p(it,2)
15496  p(is,3)=p(im,3)-p(it,3)
15497  p(is,4)=p(im,4)-p(it,4)
15498  p(is,5)=p(is,4)**2-p(is,1)**2-p(is,2)**2-p(is,3)**2
15499 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15500  IF (p(is,5).LT.0d0) THEN
15501  p(is,5)=-sqrt(abs(p(is,5)))
15502  ELSE
15503  p(is,5)=sqrt(p(is,5))
15504  ENDIF
15505 
15506 C...Boost entire system and rotate to new frame.
15507 C...(including docu lines)
15508  betax=(p(im,1)+p(ir,1))/(p(im,4)+p(ir,4))
15509  betaz=(p(im,3)+p(ir,3))/(p(im,4)+p(ir,4))
15510  IF(betax**2+betaz**2.GE.1d0) THEN
15511  CALL pyerrm(1,'(PYPTIS:) boost bigger than unity')
15512  mint(51)=1
15513  ifail=-1
15514  RETURN
15515  ENDIF
15516  CALL pyrobo(imin,imax,0d0,0d0,-betax,0d0,-betaz)
15517  i1=imi(1,mi,1)
15518  theta=pyangl(p(i1,3),p(i1,1))
15519  CALL pyrobo(imin,imax,-theta,phimx,0d0,0d0,0d0)
15520 
15521 C...Global statistics.
15522  mint(352)=mint(352)+1
15523  vint(352)=vint(352)+sqrt(p(it,1)**2+p(it,2)**2)
15524  IF (mint(352).EQ.1) vint(357)=sqrt(p(it,1)**2+p(it,2)**2)
15525 
15526 C...Add parton with relevant pT scale for timelike shower.
15527  IF (k(it,2).NE.22) THEN
15528  npart=npart+1
15529  ipart(npart)=it
15530  ptpart(npart)=sqrt(pt2amx)
15531  ENDIF
15532 
15533 C...Update saved variables.
15534  shtnow(mimx)=shtnow(mimx)/zmx
15535  nisgen(jsmx,mimx)=nisgen(jsmx,mimx)+1
15536  xmi(jsmx,mimx)=xmi(jsmx,mimx)/zmx
15537  pt2sav(jsmx,mimx)=pt2mx
15538  zsav(js,mimx)=zmx
15539 
15540  ksa=iabs(k(is,2))
15541  kma=iabs(k(im,2))
15542  IF (ksa.EQ.21.AND.kma.GE.1.AND.kma.LE.5) THEN
15543 C...Gluon reconstructs to quark.
15544 C...Decide whether newly created quark is valence or sea:
15545  mint(30)=js
15546  CALL pyptmi(2,pt2now,ptdum1,ptdum2,ifail)
15547  IF(mint(51).NE.0) RETURN
15548  ENDIF
15549  IF(ksa.GE.1.AND.ksa.LE.5.AND.kma.EQ.21) THEN
15550 C...Quark reconstructs to gluon.
15551 C...Now some guy may have lost his companion. Check.
15552  icmp=imi(js,mi,2)
15553  IF (icmp.GT.0) THEN
15554  CALL pyerrm(9,'(PYPTIS:) Sorry, companion quark radiated'
15555  & //' away. Cannot handle that yet. Giving up.')
15556  mint(51)=1
15557  RETURN
15558  ELSEIF(icmp.LT.0) THEN
15559 C...A sea quark with companion still in BR was reconstructed to a gluon.
15560 C...Companion should now be removed from the beam remnant.
15561 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15562  icmp=-icmp
15563  ifl=-k(is,2)
15564  DO 380 jcmp=icmp,nvc(js,ifl)-1
15565  xassoc(js,ifl,jcmp)=xassoc(js,ifl,jcmp+1)
15566  DO 370 ji=1,mint(31)
15567  kmi=-imi(js,ji,2)
15568  jfl=-k(imi(js,ji,1),2)
15569  IF (kmi.EQ.jcmp+1.AND.jfl.EQ.ifl) imi(js,ji,2)=imi(js,ji
15570  & ,2)+1
15571  370 CONTINUE
15572  380 CONTINUE
15573  nvc(js,ifl)=nvc(js,ifl)-1
15574  ENDIF
15575 C...Set gluon IMI(JS,MI,2) = 0.
15576  imi(js,mi,2)=0
15577  ELSEIF(ksa.GE.1.AND.ksa.LE.5.AND.kma.NE.21) THEN
15578 C...Quark reconstructing to quark. If sea with companion still in BR
15579 C...then update associated x value.
15580 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15581  IF (imi(js,mi,2).LT.0) THEN
15582  icmp=-imi(js,mi,2)
15583  ifl=-k(is,2)
15584  xassoc(js,ifl,icmp)=xmi(jsmx,mimx)
15585  ENDIF
15586  ENDIF
15587 
15588  ENDIF
15589 
15590 C...If reached this point, normal exit.
15591  390 ifail=0
15592 
15593  RETURN
15594  END
15595 
15596 C*********************************************************************
15597 
15598 C...PYMEMX
15599 C...Generates maximum ME weight in some initial-state showers.
15600 C...Inparameter MECOR: kind of hard scattering process
15601 C...Outparameter WTFF: maximum weight for fermion -> fermion
15602 C... WTGF: maximum weight for gluon/photon -> fermion
15603 C... WTFG: maximum weight for fermion -> gluon/photon
15604 C... WTGG: maximum weight for gluon -> gluon
15605 
15606  SUBROUTINE pymemx(MECOR,WTFF,WTGF,WTFG,WTGG)
15607 
15608 C...Double precision and integer declarations.
15609  IMPLICIT DOUBLE PRECISION(a-h, o-z)
15610  IMPLICIT INTEGER(I-N)
15611  INTEGER PYK,PYCHGE,PYCOMP
15612 C...Commonblocks.
15613  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15614  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15615  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15616  common/pyint1/mint(400),vint(400)
15617  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15618  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyint2/
15619 
15620 C...Default maximum weight.
15621  wtff=1d0
15622  wtgf=1d0
15623  wtfg=1d0
15624  wtgg=1d0
15625 
15626 C...Select maximum weight by process.
15627  IF(mecor.EQ.1) THEN
15628  wtff=1d0
15629  wtgf=3d0
15630  ELSEIF(mecor.EQ.2) THEN
15631  wtfg=1d0
15632  wtgg=1d0
15633  ENDIF
15634 
15635  RETURN
15636  END
15637 
15638 C*********************************************************************
15639 
15640 C...PYMEWT
15641 C...Calculates actual ME weight in some initial-state showers.
15642 C...Inparameter MECOR: kind of hard scattering process
15643 C... IFLCB: flavour combination of branching,
15644 C... 1 for fermion -> fermion,
15645 C... 2 for gluon/photon -> fermion
15646 C... 3 for fermion -> gluon/photon,
15647 C... 4 for gluon -> gluon
15648 C... Q2: Q2 value of shower branching
15649 C... Z: Z value of branching
15650 C...In+outparameter PHIBR: azimuthal angle of branching
15651 C...Outparameter WTME: actual ME weight
15652 
15653  SUBROUTINE pymewt(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15654 
15655 C...Double precision and integer declarations.
15656  IMPLICIT DOUBLE PRECISION(a-h, o-z)
15657  IMPLICIT INTEGER(I-N)
15658  INTEGER PYK,PYCHGE,PYCOMP
15659 C...Commonblocks.
15660  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15661  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15662  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15663  common/pyint1/mint(400),vint(400)
15664  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15665  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyint2/
15666 
15667 C...Default output.
15668  wtme=1d0
15669 
15670 C...Define kinematics of shower branching in Mandelstam variables.
15671  sqm=vint(44)
15672  sh=sqm/z
15673  th=-q2
15674  uh=q2-sqm*(1d0-z)/z
15675 
15676 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15677  IF(mecor.EQ.1) THEN
15678  IF(iflcb.EQ.1) THEN
15679  wtme=(th**2+uh**2+2d0*sqm*sh)/(sh**2+sqm**2)
15680  ELSEIF(iflcb.EQ.2) THEN
15681  wtme=(sh**2+th**2+2d0*sqm*uh)/((sh-sqm)**2+sqm**2)
15682  ENDIF
15683 
15684 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15685  ELSEIF(mecor.EQ.2) THEN
15686  IF(iflcb.EQ.3) THEN
15687  wtme=(sh**2+uh**2)/(sh**2+(sh-sqm)**2)
15688  ELSEIF(iflcb.EQ.4) THEN
15689  wtme=0.5d0*(sh**4+uh**4+th**4+sqm**4)/(sh**2-sqm*(sh-sqm))**2
15690  ENDIF
15691 
15692 C...Matrix-element corrections for q + qbar -> Higgs (h0)
15693  ELSEIF(mecor.EQ.3) THEN
15694  IF(iflcb.EQ.2) THEN
15695  wtme=(sh**2+th**2+2d0*(sqm-th)*(sqm-sh))/
15696  1 (sh**2+2d0*sqm*(sqm-sh))
15697  ENDIF
15698  ENDIF
15699 
15700  RETURN
15701  END
15702 
15703 C*********************************************************************
15704 
15705 C...PYPTMI
15706 C...Handles the generation of additional interactions in the new
15707 C...multiple interactions framework.
15708 C...MODE=-1 : Initalize MI from scratch.
15709 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15710 C... Sudakov for PT2, abort if below PT2CUT.
15711 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15712 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15713 C...PT2NOW : Starting (max) PT2 scale for evolution.
15714 C...PT2CUT : Lower limit for evolution.
15715 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15716 C...IFAIL : Status return code.
15717 C... = 0: All is well.
15718 C... < 0: Phase space exhausted, generation to be terminated.
15719 C... > 0: Additional interaction vetoed, but continue evolution.
15720 
15721  SUBROUTINE pyptmi(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15722 C...Double precision and integer declarations.
15723  IMPLICIT DOUBLE PRECISION(a-h, o-z)
15724  IMPLICIT INTEGER(I-N)
15725  INTEGER PYK,PYCHGE,PYCOMP
15726 C...Parameter statement for maximum size of showers.
15727  parameter(maxnur=1000)
15728 C...Commonblocks.
15729  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
15730  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15731  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15732  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
15733  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
15734  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15735  common/pyint1/mint(400),vint(400)
15736  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15737  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
15738  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
15739  common/pyint7/sigt(0:6,0:6,0:5)
15740  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
15741  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
15742  & xmi(2,240),pt2mi(240),imisep(0:240)
15743  common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
15744  & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
15745  common/pyctag/nct,mct(4000,2)
15746 C...Local arrays and saved variables.
15747  dimension wdtp(0:400),wdte(0:400,0:5),xpq(-25:25)
15748 
15749  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pydat3/,/pypars/,
15750  & /pyint1/,/pyint2/,/pyint3/,/pyint5/,/pyint7/,/pyintm/,
15751  & /pyismx/,/pyctag/
15752  SAVE xt2fac,sigs
15753 
15754  ifail=0
15755 C...Set MI subprocess = QCD 2 -> 2.
15756  isub=96
15757 
15758 C----------------------------------------------------------------------
15759 C...MODE=-1: Initialize from scratch
15760  IF (mode.EQ.-1) THEN
15761 C...Initialize PT2 array.
15762  pt2mi(1)=vint(54)
15763 C...Initialize list of incoming beams and partons from two sides.
15764  DO 110 js=1,2
15765  DO 100 mi=1,240
15766  imi(js,mi,1)=0
15767  imi(js,mi,2)=0
15768  100 CONTINUE
15769  nmi(js)=1
15770  imi(js,1,1)=mint(84)+js
15771  imi(js,1,2)=0
15772  xmi(js,1)=vint(40+js)
15773 C...Rescale x values to fractions of photon energy.
15774  IF(mint(18+js).EQ.1) xmi(js,1)=vint(40+js)/vint(154+js)
15775 C...Hard reset: hard interaction initiators motherless by definition.
15776  k(mint(84)+js,3)=2+js
15777  k(mint(84)+js,4)=mod(k(mint(84)+js,4),mstu(5))
15778  k(mint(84)+js,5)=mod(k(mint(84)+js,5),mstu(5))
15779  110 CONTINUE
15780  imisep(0)=mint(84)
15781  imisep(1)=n
15782  IF (mod(mstp(81),10).GE.1) THEN
15783  IF(mstp(82).LE.1) THEN
15784  sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0
15785  & ,5))
15786  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
15787  & vint(317)/(vint(318)*vint(320))
15788  xt2fac=sigrat*vint(149)/(1d0-vint(149))
15789  ELSE
15790  xt2fac=vint(146)*vint(148)*xsec(isub,1)/
15791  & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
15792  ENDIF
15793  ENDIF
15794 C...Zero entries relating to scatterings beyond the first.
15795  DO 120 mi=2,240
15796  imi(1,mi,1)=0
15797  imi(2,mi,1)=0
15798  imi(1,mi,2)=0
15799  imi(2,mi,2)=0
15800  imisep(mi)=imisep(1)
15801  pt2mi(mi)=0d0
15802  xmi(1,mi)=0d0
15803  xmi(2,mi)=0d0
15804  120 CONTINUE
15805 C...Initialize factors for PDF reshaping.
15806  DO 140 js=1,2
15807  kfbeam(js)=mint(10+js)
15808  IF(mint(18+js).EQ.1) kfbeam(js)=22
15809  kfabm=iabs(kfbeam(js))
15810  kfsbm=isign(1,kfbeam(js))
15811 
15812 C...Zero flavour content of incoming beam particle.
15813  kfival(js,1)=0
15814  kfival(js,2)=0
15815  kfival(js,3)=0
15816 C... Flavour content of baryon.
15817  IF(kfabm.GT.1000) THEN
15818  kfival(js,1)=kfsbm*mod(kfabm/1000,10)
15819  kfival(js,2)=kfsbm*mod(kfabm/100,10)
15820  kfival(js,3)=kfsbm*mod(kfabm/10,10)
15821 C... Flavour content of pi+-, K+-.
15822  ELSEIF(kfabm.EQ.211) THEN
15823  kfival(js,1)=kfsbm*2
15824  kfival(js,2)=-kfsbm
15825  ELSEIF(kfabm.EQ.321) THEN
15826  kfival(js,1)=-kfsbm*3
15827  kfival(js,2)=kfsbm*2
15828 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15829  ENDIF
15830 
15831 C...Zero initial valence and companion content.
15832  DO 130 ifl=-6,6
15833  nvc(js,ifl)=0
15834  130 CONTINUE
15835  140 CONTINUE
15836 C...Set up colour line tags starting from hard interaction initiators.
15837  nct=0
15838 C...Reset colour tag array and colour processing flags.
15839  DO 150 i=imisep(0)+1,n
15840  mct(i,1)=0
15841  mct(i,2)=0
15842  k(i,4)=mod(k(i,4),mstu(5)**2)
15843  k(i,5)=mod(k(i,5),mstu(5)**2)
15844  150 CONTINUE
15845 C... Consider each side in turn.
15846  DO 170 js=1,2
15847  i1=imi(js,1,1)
15848  i2=imi(3-js,1,1)
15849  DO 160 jcs=4,5
15850  IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
15851  & GOTO 160
15852  IF (k(i1,jcs)/mstu(5)**2.NE.0) GOTO 160
15853  kcs=jcs
15854  CALL pycttr(i1,kcs,i2)
15855  IF(mint(51).NE.0) RETURN
15856  160 CONTINUE
15857  170 CONTINUE
15858 
15859 C...Range checking for companion quark pdf large-x param.
15860  IF (mstp(87).LT.0) THEN
15861  CALL pyerrm(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15862  & ' MSTP(87)=0')
15863  mstp(87)=0
15864  ELSEIF (mstp(87).GT.4) THEN
15865  CALL pyerrm(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15866  & ' MSTP(87)=4')
15867  mstp(87)=4
15868  ENDIF
15869 
15870 C----------------------------------------------------------------------
15871 C...MODE=0: Generate trial interaction. Return codes:
15872 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15873 C...IFAIL = 0: Additional interaction generated at PT2.
15874 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15875  ELSEIF (mode.EQ.0) THEN
15876 C...Abolute MI max scale = VINT(62)
15877  xt2=4d0*min(pt2now,vint(62))/vint(2)
15878  180 IF(mstp(82).LE.1) THEN
15879  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
15880  IF(xt2.LT.vint(149)) ifail=-2
15881  ELSE
15882  IF(xt2.LE.0.01001d0*vint(149)) THEN
15883  ifail=-3
15884  ELSE
15885  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
15886  & log(pyr(0)))-vint(149)
15887  ENDIF
15888  ENDIF
15889 C...Also exit if below lower limit or if higher trial branching
15890 C...already found.
15891  pt2=0.25d0*vint(2)*xt2
15892  IF (pt2.LE.pt2cut) ifail=-4
15893  IF (pt2.LE.pt2mx) ifail=-5
15894  IF (ifail.NE.0) THEN
15895  pt2=0d0
15896  RETURN
15897  ENDIF
15898  IF(mstp(82).GE.2) pt2=max(0.25d0*vint(2)*0.01d0*vint(149),pt2)
15899  vint(25)=4d0*pt2/vint(2)
15900  xt2=vint(25)
15901 
15902 C...Choose tau and y*. Calculate cos(theta-hat).
15903  IF(pyr(0).LE.coef(isub,1)) THEN
15904  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
15905  tau=xt2*(1d0+taut)**2/(4d0*taut)
15906  ELSE
15907  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
15908  ENDIF
15909  vint(21)=tau
15910 C...New: require shat > 1.
15911  IF(tau*vint(2).LT.1d0) GOTO 180
15912  CALL pyklim(2)
15913  ryst=pyr(0)
15914  myst=1
15915  IF(ryst.GT.coef(isub,8)) myst=2
15916  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
15917  CALL pykmap(2,myst,pyr(0))
15918  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
15919 
15920 C...Check that x not used up. Accept or reject kinematical variables.
15921  x1m=sqrt(tau)*exp(vint(22))
15922  x2m=sqrt(tau)*exp(-vint(22))
15923  IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) GOTO 180
15924  vint(71)=0.5d0*vint(1)*sqrt(xt2)
15925  CALL pysigh(nchn,sigs)
15926  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
15927  IF(sigs.LT.xsec(isub,1)*pyr(0)) GOTO 180
15928  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs/vint(320)
15929 
15930 C...Save if highest PT so far.
15931  IF (pt2.GT.pt2mx) THEN
15932  jsmx=0
15933  mimx=mint(31)+1
15934  pt2mx=pt2
15935  ENDIF
15936 
15937 C----------------------------------------------------------------------
15938 C...MODE=1: Generate and save accepted scattering.
15939  ELSEIF (mode.EQ.1) THEN
15940  pt2=pt2now
15941 C...Reset K, P, V, and MCT vectors.
15942  DO 200 i=n+1,n+4
15943  DO 190 j=1,5
15944  k(i,j)=0
15945  p(i,j)=0d0
15946  v(i,j)=0d0
15947  190 CONTINUE
15948  mct(i,1)=0
15949  mct(i,2)=0
15950  200 CONTINUE
15951 
15952  ntry=0
15953 C...Choose flavour of reacting partons (and subprocess).
15954  210 ntry=ntry+1
15955  IF (ntry.GT.50) THEN
15956  CALL pyerrm(9,'(PYPTMI:) Unable to generate additional '
15957  & //'interaction. Giving up!')
15958  mint(51)=1
15959  RETURN
15960  ENDIF
15961  rsigs=sigs*pyr(0)
15962  DO 220 ichn=1,nchn
15963  kfl1=isig(ichn,1)
15964  kfl2=isig(ichn,2)
15965  iconmi=isig(ichn,3)
15966  rsigs=rsigs-sigh(ichn)
15967  IF(rsigs.LE.0d0) GOTO 230
15968  220 CONTINUE
15969 
15970 C...Reassign to appropriate process codes.
15971  230 isubmi=iconmi/10
15972  iconmi=mod(iconmi,10)
15973 
15974 C...Choose new quark flavour for annihilation graphs
15975  IF(isubmi.EQ.12.OR.isubmi.EQ.53) THEN
15976  sh=vint(21)*vint(2)
15977  CALL pywidt(21,sh,wdtp,wdte)
15978  240 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
15979  DO 250 i=1,mdcy(21,3)
15980  kflf=kfdp(i+mdcy(21,2)-1,1)
15981  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
15982  IF(rkfl.LE.0d0) GOTO 260
15983  250 CONTINUE
15984  260 IF(isubmi.EQ.53.AND.iconmi.LE.2) THEN
15985  IF(kflf.GE.4) GOTO 240
15986  ELSEIF(isubmi.EQ.53.AND.iconmi.LE.4) THEN
15987  kflf=4
15988  iconmi=iconmi-2
15989  ELSEIF(isubmi.EQ.53) THEN
15990  kflf=5
15991  iconmi=iconmi-4
15992  ENDIF
15993  ENDIF
15994 
15995 C...Final state flavours and colour flow: default values
15996  js=1
15997  kfl3=kfl1
15998  kfl4=kfl2
15999  kcc=20
16000  kcs=isign(1,kfl1)
16001 
16002  IF(isubmi.EQ.11) THEN
16003 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16004  kcc=iconmi
16005  IF(kfl1*kfl2.LT.0) kcc=kcc+2
16006 
16007  ELSEIF(isubmi.EQ.12) THEN
16008 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16009  kfl3=isign(kflf,kfl1)
16010  kfl4=-kfl3
16011  kcc=4
16012 
16013  ELSEIF(isubmi.EQ.13) THEN
16014 C...f + fbar -> g + g; th arbitrary
16015  kfl3=21
16016  kfl4=21
16017  kcc=iconmi+4
16018 
16019  ELSEIF(isubmi.EQ.28) THEN
16020 C...f + g -> f + g; th = (p(f)-p(f))**2
16021  IF(kfl1.EQ.21) js=2
16022  kcc=iconmi+6
16023  IF(kfl1.EQ.21) kcc=kcc+2
16024  IF(kfl1.NE.21) kcs=isign(1,kfl1)
16025  IF(kfl2.NE.21) kcs=isign(1,kfl2)
16026 
16027  ELSEIF(isubmi.EQ.53) THEN
16028 C...g + g -> f + fbar; th arbitrary
16029  kcs=(-1)**int(1.5d0+pyr(0))
16030  kfl3=isign(kflf,kcs)
16031  kfl4=-kfl3
16032  kcc=iconmi+10
16033 
16034  ELSEIF(isubmi.EQ.68) THEN
16035 C...g + g -> g + g; th arbitrary
16036  kcc=iconmi+12
16037  kcs=(-1)**int(1.5d0+pyr(0))
16038  ENDIF
16039 
16040 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16041  IF (iabs(kfl3).EQ.4.OR.iabs(kfl4).EQ.4.OR.iabs(kfl3).EQ.5
16042  & .OR.iabs(kfl4).EQ.5) THEN
16043  rmmax2=max(pmas(pycomp(kfl3),1),pmas(pycomp(kfl4),1))**2
16044  IF (pt2.LE.1.05*rmmax2) THEN
16045  IF (ntry.EQ.2) CALL pyerrm(9,'(PYPTMI:) Heavy quarks'
16046  & //' too close to threshold (2nd try).')
16047  GOTO 210
16048  ENDIF
16049  ENDIF
16050 
16051 C...Store flavours of scattering.
16052  mint(13)=kfl1
16053  mint(14)=kfl2
16054  mint(15)=kfl1
16055  mint(16)=kfl2
16056  mint(21)=kfl3
16057  mint(22)=kfl4
16058 
16059 C...Set flavours and mothers of scattering partons.
16060  k(n+1,1)=14
16061  k(n+2,1)=14
16062  k(n+3,1)=3
16063  k(n+4,1)=3
16064  k(n+1,2)=kfl1
16065  k(n+2,2)=kfl2
16066  k(n+3,2)=kfl3
16067  k(n+4,2)=kfl4
16068  k(n+1,3)=mint(83)+1
16069  k(n+2,3)=mint(83)+2
16070  k(n+3,3)=n+1
16071  k(n+4,3)=n+2
16072 
16073 C...Store colour connection indices.
16074  DO 270 j=1,2
16075  jc=j
16076  IF(kcs.EQ.-1) jc=3-j
16077  IF(icol(kcc,1,jc).NE.0) k(n+1,j+3)=n+icol(kcc,1,jc)
16078  IF(icol(kcc,2,jc).NE.0) k(n+2,j+3)=n+icol(kcc,2,jc)
16079  IF(icol(kcc,3,jc).NE.0) k(n+3,j+3)=mstu(5)*(n+icol(kcc,3,jc))
16080  IF(icol(kcc,4,jc).NE.0) k(n+4,j+3)=mstu(5)*(n+icol(kcc,4,jc))
16081  270 CONTINUE
16082 
16083 C...Store incoming and outgoing partons in their CM-frame.
16084  shr=sqrt(vint(21))*vint(1)
16085  p(n+1,3)=0.5d0*shr
16086  p(n+1,4)=0.5d0*shr
16087  p(n+2,3)=-0.5d0*shr
16088  p(n+2,4)=0.5d0*shr
16089  p(n+3,5)=pymass(k(n+3,2))
16090  p(n+4,5)=pymass(k(n+4,2))
16091  IF(p(n+3,5)+p(n+4,5).GE.shr) THEN
16092  ifail=1
16093  RETURN
16094  ENDIF
16095  p(n+3,4)=0.5d0*(shr+(p(n+3,5)**2-p(n+4,5)**2)/shr)
16096  p(n+3,3)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,5)**2))
16097  p(n+4,4)=shr-p(n+3,4)
16098  p(n+4,3)=-p(n+3,3)
16099 
16100 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16101  phi=paru(2)*pyr(0)
16102  CALL pyrobo(n+3,n+4,acos(vint(23)),phi,0d0,0d0,0d0)
16103 
16104 C...Global statistics.
16105  mint(351)=mint(351)+1
16106  vint(351)=vint(351)+sqrt(p(n+3,1)**2+p(n+3,2)**2)
16107  IF (mint(351).EQ.1) vint(356)=sqrt(p(n+3,1)**2+p(n+3,2)**2)
16108 
16109 C...Keep track of loose colour ends and information on scattering.
16110  mint(31)=mint(31)+1
16111  mint(36)=mint(31)
16112  pt2mi(mint(36))=pt2
16113  imisep(mint(31))=n+4
16114  DO 280 js=1,2
16115  imi(js,mint(31),1)=n+js
16116  imi(js,mint(31),2)=0
16117  xmi(js,mint(31))=vint(40+js)
16118  nmi(js)=nmi(js)+1
16119 C...Update cumulative counters
16120  vint(142+js)=vint(142+js)-vint(40+js)
16121  vint(150+js)=vint(150+js)+vint(40+js)
16122  280 CONTINUE
16123 
16124 C...Add to list of final state partons
16125  ipart(npart+1)=n+3
16126  ipart(npart+2)=n+4
16127  ptpart(npart+1)=sqrt(pt2)
16128  ptpart(npart+2)=sqrt(pt2)
16129  npart=npart+2
16130 
16131 C...Initialize ISR
16132  nisgen(1,mint(31))=0
16133  nisgen(2,mint(31))=0
16134 
16135 C...Update ER
16136  n=n+4
16137  IF(n.GT.mstu(4)-mstu(32)-10) THEN
16138  CALL pyerrm(11,'(PYMIGN:) no more memory left in PYJETS')
16139  mint(51)=1
16140  RETURN
16141  ENDIF
16142 
16143 C...Finally, assign colour tags to new partons
16144  DO 300 js=1,2
16145  i1=imi(js,mint(31),1)
16146  i2=imi(3-js,mint(31),1)
16147  DO 290 jcs=4,5
16148  IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
16149  & GOTO 290
16150  IF (k(i1,jcs)/mstu(5)**2.NE.0) GOTO 290
16151  kcs=jcs
16152  CALL pycttr(i1,kcs,i2)
16153  IF(mint(51).NE.0) RETURN
16154  290 CONTINUE
16155  300 CONTINUE
16156 
16157 C----------------------------------------------------------------------
16158 C...MODE=2: Decide whether quarks in last scattering were valence,
16159 C...companion, or sea.
16160  ELSEIF (mode.EQ.2) THEN
16161  js=mint(30)
16162  mi=mint(36)
16163  pt2=pt2now
16164  kfsbm=isign(1,mint(10+js))
16165  ifl=k(imi(js,mi,1),2)
16166  imi(js,mi,2)=0
16167  IF (iabs(ifl).GE.6) THEN
16168  IF (iabs(ifl).EQ.6) THEN
16169  CALL pyerrm(29,'(PYPTMI:) top in initial state!')
16170  ENDIF
16171  RETURN
16172  ENDIF
16173 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16174 C...(Do not include the parton itself in the X rescaling.)
16175  x=xmi(js,mi)
16176  xrsc=x/(vint(142+js)+x)
16177 C...Note: XPSVC = x*pdf.
16178  mint(30)=js
16179  CALL pypdfu(kfbeam(js),xrsc,pt2,xpq)
16180  sea=xpsvc(ifl,-1)
16181  val=xpsvc(ifl,0)
16182 C...Ensure that pdfs are positive definite
16183  IF (sea.LT.0d0) THEN
16184  CALL pyerrm(9,'(PYPTMI:) Sea distribution negative.')
16185  sea=max(0d0,sea)
16186  ELSEIF (val.LT.0d0) THEN
16187  CALL pyerrm(9,'(PYPTMI:) Val distribution negative.')
16188  val=max(0d0,val)
16189  ENDIF
16190  cmp=0d0
16191  DO 310 ivc=1,nvc(js,ifl)
16192  cmp=cmp+xpsvc(ifl,ivc)
16193  310 CONTINUE
16194 
16195  ntry=0
16196 C...Decide (Extra factor x cancels in the dvision).
16197  320 rvcs=pyr(0)*(sea+val+cmp)
16198  ivnow=1
16199  ntry=ntry+1
16200  330 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
16201 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16202  ivnow=0
16203  IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
16204  IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
16205  IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
16206  IF(kfival(js,1).EQ.0) THEN
16207  IF(kfbeam(js).EQ.111.AND.iabs(ifl).LE.2) ivnow=1
16208  IF(kfbeam(js).EQ.22.AND.iabs(ifl).LE.5) ivnow=1
16209  IF((kfbeam(js).EQ.130.OR.kfbeam(js).EQ.310).AND.
16210  & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
16211  ELSE
16212 C...Count down valence remaining. Do not count current scattering.
16213  DO 340 i1=1,nmi(js)
16214  IF (i1.EQ.mint(36)) GOTO 340
16215  IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
16216  & ivnow=ivnow-1
16217  340 CONTINUE
16218  ENDIF
16219  IF(ivnow.EQ.0) GOTO 330
16220 C...Mark valence.
16221  imi(js,mi,2)=0
16222 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16223  IF(kfival(js,1).EQ.0) THEN
16224  IF(kfbeam(js).EQ.111.OR.kfbeam(js).EQ.22) THEN
16225  kfival(js,1)=ifl
16226  kfival(js,2)=-ifl
16227  ELSEIF(kfbeam(js).EQ.130.OR.kfbeam(js).EQ.310) THEN
16228  kfival(js,1)=ifl
16229  IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
16230  IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
16231  ENDIF
16232  ENDIF
16233 
16234  ELSEIF (rvcs.LE.val+sea) THEN
16235 C...If sea, add opposite sign companion parton. Store X and I.
16236  nvc(js,-ifl)=nvc(js,-ifl)+1
16237  xassoc(js,-ifl,nvc(js,-ifl))=xmi(js,mi)
16238 C...Set pointer to companion
16239  imi(js,mi,2)=-nvc(js,-ifl)
16240 
16241  ELSE
16242 C...If companion, check whether we've got any in the books
16243  IF (nvc(js,ifl).EQ.0) THEN
16244  cmp=0d0
16245 C...Only report error first time for this event
16246  IF (ntry.EQ.1)
16247  & CALL pyerrm(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16248 C...Try a few times
16249  IF (ntry.LE.10) THEN
16250  GOTO 320
16251 C... But if it stil fails, abort this event
16252  ELSE
16253  mint(51)=1
16254  RETURN
16255  ENDIF
16256  ENDIF
16257 C...If several possibilities, decide which one
16258  cmpsum=val+sea
16259  isel=0
16260  350 isel=isel+1
16261  cmpsum=cmpsum+xpsvc(ifl,isel)
16262  IF (rvcs.GT.cmpsum.AND.isel.LT.nvc(js,ifl)) GOTO 350
16263 C...Find original sea (anti-)quark. Do not consider current scattering.
16264  iassoc=0
16265  DO 360 i1=1,nmi(js)
16266  IF (i1.EQ.mint(36)) GOTO 360
16267  IF (k(imi(js,i1,1),2).NE.-ifl) GOTO 360
16268  IF (-imi(js,i1,2).EQ.isel) THEN
16269  imi(js,mi,2)=imi(js,i1,1)
16270  imi(js,i1,2)=imi(js,mi,1)
16271  ENDIF
16272  360 CONTINUE
16273 C...Mark companion "out-kicked".
16274  xassoc(js,ifl,isel)=-xassoc(js,ifl,isel)
16275  ENDIF
16276 
16277  ENDIF
16278  RETURN
16279  END
16280 
16281 C*********************************************************************
16282 
16283 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16284 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16285 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16286 C...corresponds to an unrescaled range between 0 and 1-X.
16287 
16288  FUNCTION pyfcmp(XC,XS,NPOW)
16289  IMPLICIT NONE
16290  DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16291  INTEGER NPOW
16292 
16293  pyfcmp=0d0
16294 C...Parent gluon momentum fraction
16295  y=xc+xs
16296  IF (y.GE.1d0) RETURN
16297 C...Common factor (includes factor XC, since PYFCMP=x*f)
16298  fac=3d0*xc*xs*(xc**2+xs**2)/(y**4)
16299 C...Store normalized companion x*f distribution.
16300  IF (npow.LE.0) THEN
16301  pyfcmp=fac/(2d0-xs*(3d0-xs*(3d0-2d0*xs)))
16302  ELSEIF (npow.EQ.1) THEN
16303  pyfcmp=fac*(1d0-y)/(2d0+xs**2*(-3d0+xs)+3d0*xs*log(xs))
16304  ELSEIF (npow.EQ.2) THEN
16305  pyfcmp=fac*(1d0-y)**2/(2d0*((1d0-xs)*(1d0+xs*(4d0+xs))
16306  & +3d0*xs*(1d0+xs)*log(xs)))
16307  ELSEIF (npow.EQ.3) THEN
16308  pyfcmp=fac*(1d0-y)**3*2d0/(4d0+27d0*xs-31d0*xs**3
16309  & +6d0*xs*log(xs)*(3d0+2d0*xs*(3d0+xs)))
16310  ELSEIF (npow.GE.4) THEN
16311  pyfcmp=fac*(1d0-y)**4/(2d0*(1d0+2d0*xs)*((1d0-xs)*(1d0+
16312  & xs*(10d0+xs))+6d0*xs*log(xs)*(1d0+xs)))
16313  ENDIF
16314  RETURN
16315  END
16316 
16317 C*********************************************************************
16318 
16319 C...PYPCMP: Auxiliary to PYPDFU.
16320 C...Giving the momentum integral of a companion quark, with its
16321 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16322 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16323 
16324  FUNCTION pypcmp(XS,NPOW)
16325  IMPLICIT NONE
16326  DOUBLE PRECISION XS, PYPCMP
16327  INTEGER NPOW
16328  IF (xs.GE.1d0.OR.xs.LE.0d0) THEN
16329  pypcmp=0d0
16330  ELSEIF (npow.LE.0) THEN
16331  pypcmp=xs*(5d0+xs*(-9d0-2d0*xs*(-3d0+xs))+3d0*log(xs))
16332  pypcmp=pypcmp/((-1d0+xs)*(2d0+xs*(-1d0+2d0*xs)))
16333  ELSEIF (npow.EQ.1) THEN
16334  pypcmp=-1d0-3d0*xs+(2d0*(-1d0+xs)**2*(1d0+xs+xs**2))
16335  & /(2d0+xs**2*(xs-3d0)+3d0*xs*log(xs))
16336  ELSEIF (npow.EQ.2) THEN
16337  pypcmp=xs*((1d0-xs)*(19d0+xs*(43d0+4d0*xs))
16338  & +6d0*log(xs)*(1d0+6d0*xs+4d0*xs**2))
16339  pypcmp=pypcmp/(4d0*((xs-1d0)*(1d0+xs*(4d0+xs))
16340  & -3d0*xs*log(xs)*(1+xs)))
16341  ELSEIF (npow.EQ.3) THEN
16342  pypcmp=3d0*xs*((xs-1)*(7d0+xs*(28d0+13d0*xs))
16343  & -2d0*log(xs)*(1d0+xs*(9d0+2d0*xs*(6d0+xs))))
16344  pypcmp=pypcmp/(4d0+27d0*xs-31d0*xs**3
16345  & +6d0*xs*log(xs)*(3d0+2d0*xs*(3d0+xs)))
16346  ELSE
16347  pypcmp=(-9d0*xs*(xs**2-1d0)*(5d0+xs*(24d0+xs))+12d0*xs*log(xs)
16348  & *(1d0+2d0*xs)*(1d0+2d0*xs*(5d0+2d0*xs)))
16349  pypcmp=pypcmp/(8d0*(1d0+2d0*xs)*((xs-1d0)*(1d0+xs*(10d0+xs))
16350  & -6d0*xs*log(xs)*(1d0+xs)))
16351  ENDIF
16352  RETURN
16353  END
16354 
16355 C*********************************************************************
16356 
16357 C...PYUPRE
16358 C...Rearranges contents of the HEPEUP commonblock so that
16359 C...mothers precede daughters and daughters of a decay are
16360 C...listed consecutively.
16361 
16362  SUBROUTINE pyupre
16363 
16364 C...Double precision and integer declarations.
16365  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16366  IMPLICIT INTEGER(I-N)
16367 
16368 C...User process event common block.
16369  INTEGER MAXNUP
16370  parameter(maxnup=500)
16371  INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16372  DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16373  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
16374  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
16375  &vtimup(maxnup),spinup(maxnup)
16376  SAVE /hepeup/
16377 
16378 C...Local arrays.
16379  dimension newpos(0:maxnup),idupt(maxnup),istupt(maxnup),
16380  &motupt(2,maxnup),icoupt(2,maxnup),pupt(5,maxnup),
16381  &vtiupt(maxnup),spiupt(maxnup)
16382 
16383 C...Check whether a rearrangement is required.
16384  need=0
16385  DO 100 iup=1,nup
16386  IF(mothup(1,iup).GT.iup) need=need+1
16387  100 CONTINUE
16388  DO 110 iup=2,nup
16389  IF(mothup(1,iup).LT.mothup(1,iup-1)) need=need+1
16390  110 CONTINUE
16391 
16392  IF(need.NE.0) THEN
16393 C...Find the new order that particles should have.
16394  newpos(0)=0
16395  nnew=0
16396  inew=-1
16397  120 inew=inew+1
16398  DO 130 iup=1,nup
16399  IF(mothup(1,iup).EQ.newpos(inew)) THEN
16400  nnew=nnew+1
16401  newpos(nnew)=iup
16402  ENDIF
16403  130 CONTINUE
16404  IF(inew.LT.nnew.AND.inew.LT.nup) GOTO 120
16405  IF(nnew.NE.nup) THEN
16406  CALL pyerrm(2,
16407  & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16408  RETURN
16409  ENDIF
16410 
16411 C...Copy old info into temporary storage.
16412  DO 150 i=1,nup
16413  idupt(i)=idup(i)
16414  istupt(i)=istup(i)
16415  motupt(1,i)=mothup(1,i)
16416  motupt(2,i)=mothup(2,i)
16417  icoupt(1,i)=icolup(1,i)
16418  icoupt(2,i)=icolup(2,i)
16419  DO 140 j=1,5
16420  pupt(j,i)=pup(j,i)
16421  140 CONTINUE
16422  vtiupt(i)=vtimup(i)
16423  spiupt(i)=spinup(i)
16424  150 CONTINUE
16425 
16426 C...Copy info back into HEPEUP in right order.
16427  DO 180 i=1,nup
16428  iold=newpos(i)
16429  idup(i)=idupt(iold)
16430  istup(i)=istupt(iold)
16431  mothup(1,i)=0
16432  mothup(2,i)=0
16433  DO 160 imot=1,i-1
16434  IF(motupt(1,iold).EQ.newpos(imot)) mothup(1,i)=imot
16435  IF(motupt(2,iold).EQ.newpos(imot)) mothup(2,i)=imot
16436  160 CONTINUE
16437  IF(mothup(2,i).GT.0.AND.mothup(2,i).LT.mothup(1,i)) THEN
16438  mothsw=mothup(1,i)
16439  mothup(1,i)=mothup(2,i)
16440  mothup(2,i)=mothsw
16441  ENDIF
16442  icolup(1,i)=icoupt(1,iold)
16443  icolup(2,i)=icoupt(2,iold)
16444  DO 170 j=1,5
16445  pup(j,i)=pupt(j,iold)
16446  170 CONTINUE
16447  vtimup(i)=vtiupt(iold)
16448  spinup(i)=spiupt(iold)
16449  180 CONTINUE
16450  ENDIF
16451 
16452 c...If incoming particles are massive recalculate to put them massless.
16453  IF(pup(5,1).NE.0d0.OR.pup(5,2).NE.0d0) THEN
16454  pplus=(pup(4,1)+pup(3,1))+(pup(4,2)+pup(3,2))
16455  pminus=(pup(4,1)-pup(3,1))+(pup(4,2)-pup(3,2))
16456  pup(4,1)=0.5d0*pplus
16457  pup(3,1)=pup(4,1)
16458  pup(5,1)=0d0
16459  pup(4,2)=0.5d0*pminus
16460  pup(3,2)=-pup(4,2)
16461  pup(5,2)=0d0
16462  ENDIF
16463 
16464  RETURN
16465  END
16466 
16467 C*********************************************************************
16468 
16469 C...PYADSH
16470 C...Administers the generation of successive final-state showers
16471 C...in external processes.
16472 
16473  SUBROUTINE pyadsh(NFIN)
16474 
16475 C...Double precision and integer declarations.
16476  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16477  IMPLICIT INTEGER(I-N)
16478  INTEGER PYK,PYCHGE,PYCOMP
16479 C...Parameter statement for maximum size of showers.
16480  parameter(maxnur=1000)
16481 C...Commonblocks.
16482  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
16483  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16484  common/pyctag/nct,mct(4000,2)
16485  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16486  common/pypars/mstp(200),parp(200),msti(200),pari(200)
16487  common/pyint1/mint(400),vint(400)
16488  SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pypars/,/pyint1/
16489 C...Local array.
16490  dimension ibeg(100),ksav(100,5),psum(4),beta(3)
16491 
16492 C...Set primary vertex.
16493  DO 100 j=1,5
16494  v(mint(83)+5,j)=0d0
16495  v(mint(83)+6,j)=0d0
16496  v(mint(84)+1,j)=0d0
16497  v(mint(84)+2,j)=0d0
16498  100 CONTINUE
16499 
16500 C...Isolate systems of particles with the same mother.
16501  nsys=0
16502  ims=-1
16503  DO 140 i=mint(84)+3,nfin
16504  im=k(i,3)
16505  IF(im.GT.0.AND.im.LE.mint(84)) im=k(im,3)
16506  IF(im.NE.ims) THEN
16507  nsys=nsys+1
16508  ibeg(nsys)=i
16509  ims=im
16510  ENDIF
16511 
16512 C...Set production vertices.
16513  IF(im.LE.mint(83)+6.OR.(im.GT.mint(84).AND.im.LE.mint(84)+2))
16514  & THEN
16515  DO 110 j=1,4
16516  v(i,j)=0d0
16517  110 CONTINUE
16518  ELSE
16519  DO 120 j=1,4
16520  v(i,j)=v(im,j)+v(im,5)*p(im,j)/p(im,5)
16521  120 CONTINUE
16522  ENDIF
16523  IF(mstp(125).GE.1) THEN
16524  idoc=i-mstp(126)+4
16525  DO 130 j=1,5
16526  v(idoc,j)=v(i,j)
16527  130 CONTINUE
16528  ENDIF
16529  140 CONTINUE
16530 
16531 C...End loop over systems. Return if no showers to be performed.
16532  ibeg(nsys+1)=nfin+1
16533  IF(mstp(71).LE.0) RETURN
16534 
16535 C...Loop through systems of particles; check that sensible size.
16536  DO 270 isys=1,nsys
16537  nsiz=ibeg(isys+1)-ibeg(isys)
16538  IF(mint(35).LE.2) THEN
16539  IF(nsiz.EQ.1.AND.isys.EQ.1) THEN
16540  GOTO 270
16541  ELSEIF(nsiz.LE.1) THEN
16542  CALL pyerrm(2,'(PYADSH:) only one particle in system')
16543  GOTO 270
16544  ELSEIF(nsiz.GT.80) THEN
16545  CALL pyerrm(2,'(PYADSH:) more than 80 particles in system')
16546  GOTO 270
16547  ENDIF
16548  ENDIF
16549 
16550 C...Save status codes and daughters of showering particles; reset them.
16551  DO 150 j=1,4
16552  psum(j)=0d0
16553  150 CONTINUE
16554  DO 170 ii=1,nsiz
16555  i=ibeg(isys)-1+ii
16556  ksav(ii,1)=k(i,1)
16557  IF(k(i,1).GT.10) THEN
16558  k(i,1)=1
16559  IF(ksav(ii,1).EQ.14) k(i,1)=3
16560  ENDIF
16561  IF(ksav(ii,1).LE.10) THEN
16562  ELSEIF(k(i,1).EQ.1) THEN
16563  ksav(ii,4)=k(i,4)
16564  ksav(ii,5)=k(i,5)
16565  k(i,4)=0
16566  k(i,5)=0
16567  ELSE
16568  ksav(ii,4)=mod(k(i,4),mstu(5))
16569  ksav(ii,5)=mod(k(i,5),mstu(5))
16570  k(i,4)=k(i,4)-ksav(ii,4)
16571  k(i,5)=k(i,5)-ksav(ii,5)
16572  ENDIF
16573  DO 160 j=1,4
16574  psum(j)=psum(j)+p(i,j)
16575  160 CONTINUE
16576  170 CONTINUE
16577 
16578 C...Perform shower.
16579  qmax=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-
16580  & psum(3)**2))
16581  IF(isys.EQ.1) qmax=min(qmax,sqrt(parp(71))*vint(55))
16582  nsav=n
16583  IF(mint(35).LE.2) THEN
16584  IF(nsiz.EQ.2) THEN
16585  CALL pyshow(ibeg(isys),ibeg(isys)+1,qmax)
16586  ELSE
16587  CALL pyshow(ibeg(isys),-nsiz,qmax)
16588  ENDIF
16589 
16590 C...For external processes, first call, also ISR partons radiate.
16591 C...Can use existing PYPART list, removing partons that radiate later.
16592  ELSEIF(isys.EQ.1) THEN
16593  npartn=0
16594  DO 175 ii=1,npart
16595  IF(ipart(ii).LT.ibeg(2).OR.ipart(ii).GE.ibeg(nsys+1)) THEN
16596  npartn=npartn+1
16597  ipart(npartn)=ipart(ii)
16598  ptpart(npartn)=ptpart(ii)
16599  ENDIF
16600  175 CONTINUE
16601  npart=npartn
16602  CALL pyptfs(1,0.5d0*qmax,0d0,ptgen)
16603  ELSE
16604 C...For subsequent calls use the systems excluded above.
16605  npart=nsiz
16606  npartd=0
16607  DO 180 ii=1,nsiz
16608  i=ibeg(isys)-1+ii
16609  ipart(ii)=i
16610  ptpart(ii)=0.5d0*qmax
16611  180 CONTINUE
16612  CALL pyptfs(2,0.5d0*qmax,0d0,ptgen)
16613  ENDIF
16614 
16615 C...Look up showered copies of original showering particles.
16616  DO 260 ii=1,nsiz
16617  i=ibeg(isys)-1+ii
16618  imv=i
16619 C...Particles without daughters need not be studied.
16620  IF(ksav(ii,1).LE.10) GOTO 260
16621  IF(n.EQ.nsav.OR.k(i,1).LE.10) THEN
16622  ELSEIF(k(i,1).EQ.11) THEN
16623  190 imv=mod(k(imv,4),mstu(5))
16624  IF(k(imv,1).EQ.11) GOTO 190
16625  ELSE
16626  kda1=mod(k(i,4),mstu(5))
16627  IF(kda1.GT.0) THEN
16628  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
16629  ENDIF
16630  kda2=mod(k(i,5),mstu(5))
16631  IF(kda2.GT.0) THEN
16632  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
16633  ENDIF
16634  DO 200 i3=i+1,n
16635  IF(k(i3,2).EQ.k(i,2).AND.(i3.EQ.kda1.OR.i3.EQ.kda2))
16636  & THEN
16637  imv=i3
16638  kda1=mod(k(i3,4),mstu(5))
16639  IF(kda1.GT.0) THEN
16640  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
16641  ENDIF
16642  kda2=mod(k(i3,5),mstu(5))
16643  IF(kda2.GT.0) THEN
16644  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
16645  ENDIF
16646  ENDIF
16647  200 CONTINUE
16648  ENDIF
16649 
16650 C...Restore daughter info of original partons to showered copies.
16651  IF(ksav(ii,1).GT.10) k(imv,1)=ksav(ii,1)
16652  IF(ksav(ii,1).LE.10) THEN
16653  ELSEIF(k(i,1).EQ.1) THEN
16654  k(imv,4)=ksav(ii,4)
16655  k(imv,5)=ksav(ii,5)
16656  ELSE
16657  k(imv,4)=k(imv,4)+ksav(ii,4)
16658  k(imv,5)=k(imv,5)+ksav(ii,5)
16659  ENDIF
16660 
16661 C...Reset mother info of existing daughters to showered copies.
16662  DO 210 i3=ibeg(isys+1),nfin
16663  IF(k(i3,3).EQ.i) k(i3,3)=imv
16664  IF(k(i3,1).EQ.3.OR.k(i3,1).EQ.14) THEN
16665  IF(k(i3,4)/mstu(5).EQ.i) k(i3,4)=k(i3,4)+mstu(5)*(imv-i)
16666  IF(k(i3,5)/mstu(5).EQ.i) k(i3,5)=k(i3,5)+mstu(5)*(imv-i)
16667  ENDIF
16668  210 CONTINUE
16669 
16670 C...Boost all original daughters to new frame of showered copy.
16671 C...Also update their colour tags.
16672  IF(imv.NE.i) THEN
16673  DO 220 j=1,3
16674  beta(j)=(p(imv,j)-p(i,j))/(p(imv,4)+p(i,4))
16675  220 CONTINUE
16676  fac=2d0/(1d0+beta(1)**2+beta(2)**2+beta(3)**2)
16677  DO 230 j=1,3
16678  beta(j)=fac*beta(j)
16679  230 CONTINUE
16680  DO 250 i3=ibeg(isys+1),nfin
16681  imo=i3
16682  240 imo=k(imo,3)
16683  IF(mstp(128).LE.0) THEN
16684  IF(imo.GT.0.AND.imo.NE.i.AND.imo.NE.k(i,3)) GOTO 240
16685  IF(imo.EQ.i.OR.(k(i,3).LE.mint(84).AND.imo.EQ.k(i,3)))
16686  & THEN
16687  CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
16688  IF(mct(i3,1).EQ.mct(i,1)) mct(i3,1)=mct(imv,1)
16689  IF(mct(i3,2).EQ.mct(i,2)) mct(i3,2)=mct(imv,2)
16690  ENDIF
16691  ELSE
16692  IF(imo.EQ.imv) THEN
16693  CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
16694  IF(mct(i3,1).EQ.mct(i,1)) mct(i3,1)=mct(imv,1)
16695  IF(mct(i3,2).EQ.mct(i,2)) mct(i3,2)=mct(imv,2)
16696  ELSEIF(imo.GT.0.AND.imo.NE.i.AND.imo.NE.k(i,3)) THEN
16697  GOTO 240
16698  ENDIF
16699  ENDIF
16700  250 CONTINUE
16701  ENDIF
16702  260 CONTINUE
16703 
16704 C...End of loop over showering systems
16705  270 CONTINUE
16706 
16707  RETURN
16708  END
16709 
16710 C*********************************************************************
16711 
16712 C...PYVETO
16713 C...Interface to UPVETO, which allows user to veto event generation
16714 C...on the parton level, after parton showers but before multiple
16715 C...interactions, beam remnants and hadronization is added.
16716 
16717  SUBROUTINE pyveto(IVETO)
16718 
16719 C...All real arithmetic in double precision.
16720  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16721 C...Three Pythia functions return integers, so need declaring.
16722  INTEGER PYK,PYCHGE,PYCOMP
16723 
16724 C...PYTHIA commonblocks.
16725  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16726  common/pypars/mstp(200),parp(200),msti(200),pari(200)
16727  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16728  common/pyint1/mint(400),vint(400)
16729  SAVE /pyjets/,/pypars/,/pyint1/
16730 C...HEPEVT commonblock.
16731  parameter(nmxhep=4000)
16732  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
16733  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
16734  DOUBLE PRECISION PHEP,VHEP
16735  SAVE /hepevt/
16736 C...Local array.
16737  dimension ireso(100)
16738 
16739 C...Define longitudinal boost from initiator rest frame to cm frame.
16740  gamma=0.5d0*(vint(141)+vint(142))/sqrt(vint(141)*vint(142))
16741  gabez=0.5d0*(vint(141)-vint(142))/sqrt(vint(141)*vint(142))
16742 
16743 C...Presentation is different if using pT-ordered shower
16744  IF(mint(35).EQ.3) THEN
16745  gamma=1d0
16746  gabez=0d0
16747  ENDIF
16748 
16749 C... Reset counters.
16750  nevhep=0
16751  nhep=0
16752  nreso=0
16753 
16754 C...Oth pass: identify beam and incoming partons
16755  DO 140 i=mint(83)+1,mint(83)+6
16756  istore=0
16757  IF(k(i,2).EQ.94) THEN
16758 
16759  ELSE
16760  nreso=nreso+1
16761  ireso(nreso)=i
16762  imoth=k(i,3)
16763  ENDIF
16764  140 CONTINUE
16765 
16766 C...First pass: identify final locations of resonances
16767 C...and of their daughters before showering.
16768  DO 150 i=mint(84)+3,n
16769  istore=0
16770  imoth=0
16771 
16772 C...Skip shower CM frame documentation lines.
16773  IF(k(i,2).EQ.94) THEN
16774 
16775 C... Store a new intermediate product, when mother in documentation.
16776  ELSEIF(mstp(128).EQ.0.AND.k(i,3).GT.mint(83)+6.AND.
16777  & k(i,3).LE.mint(84)) THEN
16778  istore=1
16779  nhep=nhep+1
16780  ii=nhep
16781  nreso=nreso+1
16782  ireso(nreso)=i
16783  imoth=max(0,k(k(i,3),3)-(mint(83)+6))
16784 
16785 C... Store a new intermediate product, when mother in main section.
16786  ELSEIF(mstp(128).EQ.1.AND.k(i-mint(84)+mint(83)+4,1).EQ.21.AND.
16787  & k(i-mint(84)+mint(83)+4,2).EQ.k(i,2)) THEN
16788  istore=1
16789  nhep=nhep+1
16790  ii=nhep
16791  nreso=nreso+1
16792  ireso(nreso)=i
16793  imoth=max(0,k(i-mint(84)+mint(83)+4,3)-(mint(83)+6))
16794  ENDIF
16795 
16796  IF(istore.EQ.1) THEN
16797 C...Copy parton info, boosting momenta along z axis to cm frame.
16798  isthep(ii)=2
16799  idhep(ii)=k(i,2)
16800  phep(1,ii)=p(i,1)
16801  phep(2,ii)=p(i,2)
16802  phep(3,ii)=gamma*p(i,3)+gabez*p(i,4)
16803  phep(4,ii)=gamma*p(i,4)+gabez*p(i,3)
16804  phep(5,ii)=p(i,5)
16805 C...Store one mother. Rest of history and vertex info zeroed.
16806  jmohep(1,ii)=imoth
16807  jmohep(2,ii)=0
16808  jdahep(1,ii)=0
16809  jdahep(2,ii)=0
16810  vhep(1,ii)=0d0
16811  vhep(2,ii)=0d0
16812  vhep(3,ii)=0d0
16813  vhep(4,ii)=0d0
16814  ENDIF
16815  150 CONTINUE
16816 
16817 C...Second pass: identify current set of "final" partons.
16818  DO 200 i=mint(84)+3,n
16819  istore=0
16820  imoth=0
16821 
16822 C...Store a final parton.
16823  IF(k(i,1).GE.1.AND.k(i,1).LE.10) THEN
16824  istore=1
16825  nhep=nhep+1
16826  ii=nhep
16827 C..Trace it back through shower, to check if from documented particle.
16828  ihist=i
16829  isave=ihist
16830  160 CONTINUE
16831  IF(ihist.GT.mint(84)) THEN
16832  IF(k(ihist,2).EQ.94) ihist=k(ihist,3)+(isave-1-ihist)
16833  DO 170 iri=1,nreso
16834  IF(ihist.EQ.ireso(iri)) imoth=iri
16835  170 CONTINUE
16836  isave=ihist
16837  ihist=k(ihist,3)
16838  IF(imoth.EQ.0) GOTO 160
16839  imoth=max(0,imoth-6)
16840  ELSEIF(ihist.LE.4) THEN
16841  IF(ihist.EQ.1.OR.ihist.EQ.2) THEN
16842  istore=0
16843  nhep=nhep-1
16844  ELSE
16845  imoth=0
16846  ENDIF
16847  ENDIF
16848  ENDIF
16849 
16850  IF(istore.EQ.1) THEN
16851 C...Copy parton info, boosting momenta along z axis to cm frame.
16852  isthep(ii)=1
16853  idhep(ii)=k(i,2)
16854  phep(1,ii)=p(i,1)
16855  phep(2,ii)=p(i,2)
16856  phep(3,ii)=gamma*p(i,3)+gabez*p(i,4)
16857  phep(4,ii)=gamma*p(i,4)+gabez*p(i,3)
16858  phep(5,ii)=p(i,5)
16859 C...Store one mother. Rest of history and vertex info zeroed.
16860  jmohep(1,ii)=imoth
16861  jmohep(2,ii)=0
16862  jdahep(1,ii)=0
16863  jdahep(2,ii)=0
16864  vhep(1,ii)=0d0
16865  vhep(2,ii)=0d0
16866  vhep(3,ii)=0d0
16867  vhep(4,ii)=0d0
16868  ENDIF
16869  200 CONTINUE
16870 C...Call user-written routine to decide whether to keep events.
16871  CALL upveto(iveto)
16872  RETURN
16873  END
16874 C*********************************************************************
16875 
16876 C...PYRESD
16877 C...Allows resonances to decay (including parton showers for hadronic
16878 C...channels).
16879 
16880  SUBROUTINE pyresd(IRES)
16881 
16882 C...Double precision and integer declarations.
16883  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16884  IMPLICIT INTEGER(I-N)
16885  INTEGER PYK,PYCHGE,PYCOMP
16886 C...Parameter statement to help give large particle numbers.
16887  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
16888  &kexcit=4000000,kdimen=5000000)
16889 C...Parameter statement for maximum size of showers.
16890  parameter(maxnur=1000)
16891 C...Commonblocks.
16892  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
16893  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16894  common/pyctag/nct,mct(4000,2)
16895  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16896  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
16897  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
16898  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
16899  common/pypars/mstp(200),parp(200),msti(200),pari(200)
16900  common/pyint1/mint(400),vint(400)
16901  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
16902  common/pyint4/mwid(500),wids(500,5)
16903  common/pypued/iued(0:99),rued(0:99)
16904  SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,
16905  &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint4/,/pypued/
16906 C...Local arrays and complex and character variables.
16907  dimension iref(50,8),kdcy(3),kfl1(3),kfl2(3),kfl3(3),keql(3),
16908  &kcqm(3),kcq1(3),kcq2(3),kcq3(3),nsd(3),pmmn(3),ilin(6),
16909  &hgz(3,3),coup(6,4),corl(2,2,2),pk(6,4),pkk(6,6),cthe(3),
16910  &phi(3),wdtp(0:400),wdte(0:400,0:5),dpmo(5),xm(5),vdcy(4),
16911  &itjunc(3),ctm2(3),kcq(0:10),iant(3),itri(3),ioct(3)
16912  COMPLEX FGK,HA(6,6),HC(6,6)
16913  REAL TIR,UIR
16914  CHARACTER CODE*9,MASS*9
16915 
16916 C...The F, Xi and Xj functions of Gunion and Kunszt
16917 C...(Phys. Rev. D33, 665, plus errata from the authors).
16918  fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)*
16919  &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))
16920  digk(dt,du)=-4d0*d34*d56+dt*(3d0*dt+4d0*du)+dt**2*(dt*du/
16921  &(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+2d0*(d34/d56+d56/d34))
16922  djgk(dt,du)=8d0*(d34+d56)**2-8d0*(d34+d56)*(dt+du)-6d0*dt*du-
16923  &2d0*dt*du*(dt*du/(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+
16924  &2d0*(d34/d56+d56/d34))
16925 
16926 C...Some general constants.
16927  xw=paru(102)
16928  xwv=xw
16929  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
16930  xw1=1d0-xw
16931  sqmz=pmas(23,1)**2
16932 
16933  gmmz=pmas(23,1)*pmas(23,2)
16934  sqmw=pmas(24,1)**2
16935  gmmw=pmas(24,1)*pmas(24,2)
16936  sh=vint(44)
16937 
16938 C...Boost and rotate to rest frame of incoming partons,
16939 C...to get proper amount of smearing of decay angles.
16940  ibst=0
16941  IF(ires.EQ.0) THEN
16942  ibst=1
16943  iin1=mint(84)+1
16944  iin2=mint(84)+2
16945 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
16946 C...(101,102) are off shell and can have inconsistent momenta, resulting
16947 C...in boosts larger than unity. However, the corresponding docu partons
16948 C...(5,6) are kept on shell, and have consistent momenta that can be used
16949 C...to derive this boost instead. Ultimately, should change the way the new
16950 C...shower stores intermediate partons, but just using partons (5,6) for now
16951 C...does define the boost and furnishes a quick and much needed solution.
16952  IF (mint(35).EQ.3) THEN
16953  iin1=mint(83)+5
16954  iin2=mint(83)+6
16955  ENDIF
16956  etotin=p(iin1,4)+p(iin2,4)
16957  bexin=(p(iin1,1)+p(iin2,1))/etotin
16958  beyin=(p(iin1,2)+p(iin2,2))/etotin
16959  bezin=(p(iin1,3)+p(iin2,3))/etotin
16960  CALL pyrobo(mint(83)+7,n,0d0,0d0,-bexin,-beyin,-bezin)
16961  phiin=pyangl(p(mint(84)+1,1),p(mint(84)+1,2))
16962  CALL pyrobo(mint(83)+7,n,0d0,-phiin,0d0,0d0,0d0)
16963  thein=pyangl(p(mint(84)+1,3),p(mint(84)+1,1))
16964  CALL pyrobo(mint(83)+7,n,-thein,0d0,0d0,0d0,0d0)
16965  ENDIF
16966 
16967 C...Reset original resonance configuration.
16968  DO 100 jt=1,8
16969  iref(1,jt)=0
16970  100 CONTINUE
16971 
16972 C...Define initial one, two or three objects for subprocess.
16973  ihdec=0
16974  IF(ires.EQ.0) THEN
16975  isub=mint(1)
16976  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
16977  iref(1,1)=mint(84)+2+iset(isub)
16978  iref(1,4)=mint(83)+6+iset(isub)
16979  jtmax=1
16980  ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
16981  iref(1,1)=mint(84)+1+iset(isub)
16982  iref(1,2)=mint(84)+2+iset(isub)
16983  iref(1,4)=mint(83)+5+iset(isub)
16984  iref(1,5)=mint(83)+6+iset(isub)
16985  jtmax=2
16986  ELSEIF(iset(isub).EQ.5) THEN
16987  iref(1,1)=mint(84)+3
16988  iref(1,2)=mint(84)+4
16989  iref(1,3)=mint(84)+5
16990  iref(1,4)=mint(83)+7
16991  iref(1,5)=mint(83)+8
16992  iref(1,6)=mint(83)+9
16993  jtmax=3
16994  ENDIF
16995 
16996 C...Define original resonance for odd cases.
16997  ELSE
16998  isub=0
16999  IF(k(ires,2).EQ.25.OR.k(ires,2).EQ.35.OR.k(ires,2).EQ.36)
17000  & ihdec=1
17001  IF(ihdec.EQ.1) isub=3
17002  iref(1,1)=ires
17003  iref(1,4)=k(ires,3)
17004  irestm=ires
17005  IF(iref(1,4).GT.mint(84)) THEN
17006  110 itmpmo=iref(1,4)
17007  IF(k(itmpmo,2).EQ.94) THEN
17008  iref(1,4)=k(itmpmo,3)+(irestm-itmpmo-1)
17009  IF(k(iref(1,4),3).LE.mint(84)) iref(1,4)=k(iref(1,4),3)
17010  ELSEIF(k(itmpmo,2).EQ.k(ires,2)) THEN
17011  irestm=itmpmo
17012 C...Explicitly check that reference particle exists, otherwise stop recursion
17013  IF(itmpmo.GT.0.AND.k(itmpmo,3).GT.0) THEN
17014  iref(1,4)=k(itmpmo,3)
17015  GOTO 110
17016  ENDIF
17017  ENDIF
17018  ENDIF
17019  IF(iref(1,4).GT.mint(84)) THEN
17020  ematch=1d10
17021  iref14=iref(1,4)
17022  DO 120 ii=mint(83)+7,mint(83)+mint(4)
17023  IF(k(ii,2).EQ.k(ires,2).AND.abs(p(ii,4)-p(iref14,4)).LT.
17024  & ematch) THEN
17025  iref(1,4)=ii
17026  ematch=abs(p(ii,4)-p(iref14,4))
17027  ENDIF
17028  120 CONTINUE
17029  ENDIF
17030  jtmax=1
17031  ENDIF
17032 
17033 C...Check if initial resonance has been moved (in resonance + jet).
17034  DO 140 jt=1,3
17035  IF(iref(1,jt).GT.0) THEN
17036  IF(k(iref(1,jt),1).GT.10) THEN
17037  kfa=iabs(k(iref(1,jt),2))
17038  IF(kfa.GE.6.AND.kchg(pycomp(kfa),2).NE.0) THEN
17039  kda1=mod(k(iref(1,jt),4),mstu(5))
17040  kda2=mod(k(iref(1,jt),5),mstu(5))
17041  IF(kda1.GT.iref(1,jt).AND.kda1.LE.n) THEN
17042  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
17043  ENDIF
17044  IF(kda2.GT.iref(1,jt).AND.kda2.LE.n) THEN
17045  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
17046  ENDIF
17047  DO 130 i=iref(1,jt)+1,n
17048  IF(k(i,2).EQ.k(iref(1,jt),2).AND.(i.EQ.kda1.OR.
17049  & i.EQ.kda2)) THEN
17050  iref(1,jt)=i
17051  kda1=mod(k(iref(1,jt),4),mstu(5))
17052  kda2=mod(k(iref(1,jt),5),mstu(5))
17053  IF(kda1.GT.iref(1,jt).AND.kda1.LE.n) THEN
17054  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
17055  ENDIF
17056  IF(kda2.GT.iref(1,jt).AND.kda2.LE.n) THEN
17057  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
17058  ENDIF
17059  ENDIF
17060  130 CONTINUE
17061  ELSE
17062  kda=mod(k(iref(1,jt),4),mstu(5))
17063  IF(mwid(pycomp(kfa)).NE.0.AND.kda.GT.1) iref(1,jt)=kda
17064  ENDIF
17065  ENDIF
17066  ENDIF
17067  140 CONTINUE
17068 
17069 C...Set decay vertex for initial resonances
17070  DO 160 jt=1,jtmax
17071  DO 150 i=1,4
17072  v(iref(1,jt),i)=0d0
17073  150 CONTINUE
17074  160 CONTINUE
17075 
17076 C...Loop over decay history.
17077  np=1
17078  ip=0
17079  170 ip=ip+1
17080  ninh=0
17081  jtmax=2
17082  IF(iref(ip,2).EQ.0) jtmax=1
17083  IF(iref(ip,3).NE.0) jtmax=3
17084  it4=0
17085  nsav=n
17086 
17087 C...Check for Higgs which appears as decay product of user-process.
17088  IF(isub.EQ.0) THEN
17089  ihdec=0
17090  IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
17091  & .EQ.36) ihdec=1
17092  IF(ihdec.EQ.1) isub=3
17093  ENDIF
17094 
17095 C...Start treatment of one, two or three resonances in parallel.
17096  180 n=nsav
17097  DO 340 jt=1,jtmax
17098  id=iref(ip,jt)
17099  kdcy(jt)=0
17100  kfl1(jt)=0
17101  kfl2(jt)=0
17102  kfl3(jt)=0
17103  keql(jt)=0
17104  nsd(jt)=id
17105  itjunc(jt)=0
17106 
17107 C...Check whether particle can/is allowed to decay.
17108  IF(id.EQ.0) GOTO 330
17109  kfa=iabs(k(id,2))
17110  kca=pycomp(kfa)
17111  IF(mwid(kca).EQ.0) GOTO 330
17112  IF(k(id,1).GT.10.OR.mdcy(kca,1).EQ.0) GOTO 330
17113  IF(kfa.EQ.6.OR.kfa.EQ.7.OR.kfa.EQ.8.OR.kfa.EQ.17.OR.
17114  & kfa.EQ.18) it4=it4+1
17115  k(id,4)=mstu(5)*(k(id,4)/mstu(5))
17116  k(id,5)=mstu(5)*(k(id,5)/mstu(5))
17117 
17118 C...Choose lifetime and determine decay vertex.
17119  IF(k(id,1).EQ.5) THEN
17120  v(id,5)=0d0
17121  ELSEIF(k(id,1).NE.4) THEN
17122  v(id,5)=-pmas(kca,4)*log(pyr(0))
17123  ENDIF
17124  DO 190 j=1,4
17125  vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
17126  190 CONTINUE
17127 
17128 C...Determine whether decay allowed or not.
17129  mout=0
17130  IF(mstj(22).EQ.2) THEN
17131  IF(pmas(kca,4).GT.parj(71)) mout=1
17132  ELSEIF(mstj(22).EQ.3) THEN
17133  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
17134  ELSEIF(mstj(22).EQ.4) THEN
17135  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
17136  IF(abs(vdcy(3)).GT.parj(74)) mout=1
17137  ENDIF
17138  IF(mout.EQ.1.AND.k(id,1).NE.5) THEN
17139  k(id,1)=4
17140  GOTO 330
17141  ENDIF
17142 
17143 C...Info for selection of decay channel: sign, pairings.
17144  IF(kchg(kca,3).EQ.0) THEN
17145  ipm=2
17146  ELSE
17147  ipm=(5-isign(1,k(id,2)))/2
17148  ENDIF
17149  kfb=0
17150  IF(jtmax.EQ.2) THEN
17151  kfb=iabs(k(iref(ip,3-jt),2))
17152  ELSEIF(jtmax.EQ.3) THEN
17153  jt2=jt+1-3*(jt/3)
17154  kfb=iabs(k(iref(ip,jt2),2))
17155  IF(kfb.NE.kfa) THEN
17156  jt2=jt+2-3*((jt+1)/3)
17157  kfb=iabs(k(iref(ip,jt2),2))
17158  ENDIF
17159  ENDIF
17160 
17161 C...Select decay channel.
17162  IF(isub.EQ.1.OR.isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.
17163  & isub.EQ.30.OR.isub.EQ.35.OR.isub.EQ.141) mint(61)=1
17164  CALL pywidt(kfa,p(id,5)**2,wdtp,wdte)
17165  wdte0s=wdte(0,1)+wdte(0,ipm)+wdte(0,4)
17166  IF(kfb.EQ.kfa) wdte0s=wdte0s+wdte(0,5)
17167  IF(wdte0s.LE.0d0) GOTO 330
17168  rkfl=wdte0s*pyr(0)
17169  idl=0
17170  200 idl=idl+1
17171  idc=idl+mdcy(kca,2)-1
17172  rkfl=rkfl-(wdte(idl,1)+wdte(idl,ipm)+wdte(idl,4))
17173  IF(kfb.EQ.kfa) rkfl=rkfl-wdte(idl,5)
17174  IF(idl.LT.mdcy(kca,3).AND.rkfl.GT.0d0) GOTO 200
17175 
17176 C...Read out flavours and colour charges of decay channel chosen.
17177  kcqm(jt)=kchg(kca,2)*isign(1,k(id,2))
17178  IF(kcqm(jt).EQ.-2) kcqm(jt)=2
17179  kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))
17180  kfc1a=pycomp(iabs(kfl1(jt)))
17181  IF(kchg(kfc1a,3).EQ.0) kfl1(jt)=iabs(kfl1(jt))
17182  kcq1(jt)=kchg(kfc1a,2)*isign(1,kfl1(jt))
17183  IF(kcq1(jt).EQ.-2) kcq1(jt)=2
17184  kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))
17185  kfc2a=pycomp(iabs(kfl2(jt)))
17186  IF(kchg(kfc2a,3).EQ.0) kfl2(jt)=iabs(kfl2(jt))
17187  kcq2(jt)=kchg(kfc2a,2)*isign(1,kfl2(jt))
17188  IF(kcq2(jt).EQ.-2) kcq2(jt)=2
17189  kfl3(jt)=kfdp(idc,3)*isign(1,k(id,2))
17190  kcq3(jt)=0
17191  IF(kfl3(jt).NE.0) THEN
17192  kfc3a=pycomp(iabs(kfl3(jt)))
17193  IF(kchg(kfc3a,3).EQ.0) kfl3(jt)=iabs(kfl3(jt))
17194  kcq3(jt)=kchg(kfc3a,2)*isign(1,kfl3(jt))
17195  IF(kcq3(jt).EQ.-2) kcq3(jt)=2
17196  ENDIF
17197 
17198 C...Set/save further info on channel.
17199  kdcy(jt)=1
17200  IF(kfb.EQ.kfa) keql(jt)=mdme(idc,1)
17201  nsd(jt)=n
17202  hgz(jt,1)=vint(111)
17203  hgz(jt,2)=vint(112)
17204  hgz(jt,3)=vint(114)
17205  jtz=jt
17206 
17207 C...Select masses; to begin with assume resonances narrow.
17208  DO 220 i=1,3
17209  p(n+i,5)=0d0
17210  pmmn(i)=0d0
17211  IF(i.EQ.1) THEN
17212  kflw=iabs(kfl1(jt))
17213  kcw=kfc1a
17214  ELSEIF(i.EQ.2) THEN
17215  kflw=iabs(kfl2(jt))
17216  kcw=kfc2a
17217  ELSEIF(i.EQ.3) THEN
17218  IF(kfl3(jt).EQ.0) GOTO 220
17219  kflw=iabs(kfl3(jt))
17220  kcw=kfc3a
17221  ENDIF
17222  p(n+i,5)=pmas(kcw,1)
17223 CMRENNA++
17224 C...This prevents SUSY/t particles from becoming too light.
17225  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
17226  pmmn(i)=pmas(kcw,1)
17227  DO 210 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
17228  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
17229  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
17230  & pmas(pycomp(kfdp(idc,2)),1)
17231  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
17232  & pmas(pycomp(kfdp(idc,3)),1)
17233  pmmn(i)=min(pmmn(i),pmsum)
17234  ENDIF
17235  210 CONTINUE
17236 C MRENNA--
17237  ELSEIF(kflw.EQ.6) THEN
17238  pmmn(i)=pmas(24,1)+pmas(5,1)
17239  ENDIF
17240 C...UED: select a graviton mass from continuous distribution
17241 C...(stored in PMAS(39,1) so no value returned)
17242  IF (iued(1).EQ.1.AND.iued(2).EQ.1.AND.kflw.EQ.39)
17243  & CALL pygram(1)
17244  220 CONTINUE
17245 
17246 C...Check which two out of three are widest.
17247  iwid1=1
17248  iwid2=2
17249  pwid1=pmas(kfc1a,2)
17250  pwid2=pmas(kfc2a,2)
17251  kflw1=iabs(kfl1(jt))
17252  kflw2=iabs(kfl2(jt))
17253  IF(kfl3(jt).NE.0) THEN
17254  pwid3=pmas(kfc3a,2)
17255  IF(pwid3.GT.pwid1.AND.pwid2.GE.pwid1) THEN
17256  iwid1=3
17257  pwid1=pwid3
17258  kflw1=iabs(kfl3(jt))
17259  ELSEIF(pwid3.GT.pwid2) THEN
17260  iwid2=3
17261  pwid2=pwid3
17262  kflw2=iabs(kfl3(jt))
17263  ENDIF
17264  ENDIF
17265 
17266 C...If all narrow then only check that masses consistent.
17267  IF(mstp(42).LE.0.OR.(pwid1.LT.parp(41).AND.
17268  & pwid2.LT.parp(41))) THEN
17269 CMRENNA++
17270 C....Handle near degeneracy cases.
17271  IF(kfa/ksusy1.EQ.1.OR.kfa/ksusy1.EQ.2) THEN
17272  IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
17273  p(n+1,5)=p(id,5)-p(n+2,5)-0.5d0
17274  IF(p(n+1,5).LT.0d0) p(n+1,5)=0d0
17275  ENDIF
17276  ENDIF
17277 CMRENNA--
17278  IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
17279  CALL pyerrm(13,'(PYRESD:) daughter masses too large')
17280  mint(51)=1
17281  GOTO 720
17282  ELSEIF(p(n+1,5)+p(n+2,5)+p(n+3,5)+parj(64).GT.p(id,5)) THEN
17283  CALL pyerrm(3,'(PYRESD:) daughter masses too large')
17284  mint(51)=1
17285  GOTO 720
17286  ENDIF
17287 
17288 C...For three wide resonances select narrower of three
17289 C...according to BW decoupled from rest.
17290  ELSE
17291  pmtot=p(id,5)
17292  IF(kfl3(jt).NE.0) THEN
17293  iwid3=6-iwid1-iwid2
17294  kflw3=iabs(kfl1(jt))+iabs(kfl2(jt))+iabs(kfl3(jt))-
17295  & kflw1-kflw2
17296  loop=0
17297  230 loop=loop+1
17298  p(n+iwid3,5)=pymass(kflw3)
17299  IF(loop.LE.10.AND. p(n+iwid3,5).LE.pmmn(iwid3)) GOTO 230
17300  pmtot=pmtot-p(n+iwid3,5)
17301  ENDIF
17302 C...Select other two correlated within remaining phase space.
17303  IF(ip.EQ.1) THEN
17304  ckin45=ckin(45)
17305  ckin47=ckin(47)
17306  ckin(45)=max(pmmn(iwid1),ckin(45))
17307  ckin(47)=max(pmmn(iwid2),ckin(47))
17308  CALL pyofsh(2,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
17309  & p(n+iwid2,5))
17310  ckin(45)=ckin45
17311  ckin(47)=ckin47
17312  ELSE
17313  ckin(49)=pmmn(iwid1)
17314  ckin(50)=pmmn(iwid2)
17315  CALL pyofsh(5,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
17316  & p(n+iwid2,5))
17317  ckin(49)=0d0
17318  ckin(50)=0d0
17319  ENDIF
17320  IF(mint(51).EQ.1) GOTO 720
17321  ENDIF
17322 
17323 C...Begin fill decay products, with colour flow for coloured objects.
17324  mstu10=mstu(10)
17325  mstu(10)=1
17326  mstu(19)=1
17327 
17328 C...Three-body decays
17329  IF(kfl3(jt).NE.0) THEN
17330  DO 250 i=n+1,n+3
17331  DO 240 j=1,5
17332  k(i,j)=0
17333  v(i,j)=0d0
17334  240 CONTINUE
17335  mct(i,1)=0
17336  mct(i,2)=0
17337  250 CONTINUE
17338  k(n+1,1)=1
17339  k(n+1,2)=kfl1(jt)
17340  k(n+2,1)=1
17341  k(n+2,2)=kfl2(jt)
17342  k(n+3,1)=1
17343  k(n+3,2)=kfl3(jt)
17344  idin=id
17345 
17346 C...Generate kinematics (default is flat)
17347  CALL pytbdy(idin)
17348 
17349 C...Set generic colour flows whenever unambiguous,
17350 C...(independently of the order of the decay products)
17351 C...Sum up total colour content
17352  nant=0
17353  ntri=0
17354  noct=0
17355  kcq(0)=kcqm(jt)
17356  kcq(1)=kcq1(jt)
17357  kcq(2)=kcq2(jt)
17358  kcq(3)=kcq3(jt)
17359  DO 255 j=0,3
17360  IF (kcq(j).EQ.-1) THEN
17361  nant=nant+1
17362  iant(nant)=n+j
17363  ELSEIF (kcq(j).EQ.1) THEN
17364  ntri=ntri+1
17365  itri(ntri)=n+j
17366  ELSEIF (kcq(j).EQ.2) THEN
17367  noct=noct+1
17368  ioct(noct)=n+j
17369  ENDIF
17370  255 CONTINUE
17371 
17372 C...Set color flow for generic 1 -> N processes (N arbitrary)
17373  IF (ntri.EQ.0.AND.nant.EQ.0.AND.noct.EQ.0) THEN
17374 C...All singlets: do nothing
17375 
17376  ELSEIF (noct.EQ.2.AND.ntri.EQ.0.AND.nant.EQ.0) THEN
17377 C...Two octets, zero triplets, n singlets:
17378  IF (kcq(0).EQ.2) THEN
17379 C...8 -> 8 + n(1)
17380  k(id,4)=k(id,4)+ioct(2)
17381  k(id,5)=k(id,5)+ioct(2)
17382  k(ioct(2),1)=3
17383  k(ioct(2),4)=mstu(5)*id
17384  k(ioct(2),5)=mstu(5)*id
17385  mct(ioct(2),1)=mct(id,1)
17386  mct(ioct(2),2)=mct(id,2)
17387  ELSE
17388 C...1 -> 8 + 8 + n(1)
17389  k(ioct(1),1)=3
17390  k(ioct(1),4)=mstu(5)*ioct(2)
17391  k(ioct(1),5)=mstu(5)*ioct(2)
17392  k(ioct(2),1)=3
17393  k(ioct(2),4)=mstu(5)*ioct(1)
17394  k(ioct(2),5)=mstu(5)*ioct(1)
17395  nct=nct+1
17396  mct(ioct(1),1)=nct
17397  mct(ioct(2),2)=nct
17398  nct=nct+1
17399  mct(ioct(2),1)=nct
17400  mct(ioct(1),2)=nct
17401  ENDIF
17402 
17403  ELSEIF (ntri+nant.EQ.2.AND.noct.EQ.0) THEN
17404 C...Two triplets, zero octets, n singlets.
17405  IF (kcq(0).EQ.1) THEN
17406 C...3 -> 3 + n(1)
17407  k(id,4)=k(id,4)+itri(2)
17408  k(itri(2),1)=3
17409  k(itri(2),4)=mstu(5)*id
17410  mct(itri(2),1)=mct(id,1)
17411  ELSEIF (kcq(0).EQ.-1) THEN
17412 C...3bar -> 3bar + n(1)
17413  k(id,5)=k(id,5)+iant(2)
17414  k(iant(2),1)=3
17415  k(iant(2),5)=mstu(5)*id
17416  mct(iant(2),2)=mct(id,2)
17417  ELSE
17418 C...1 -> 3 + 3bar + n(1)
17419  k(itri(1),1)=3
17420  k(itri(1),4)=mstu(5)*iant(1)
17421  k(iant(1),1)=3
17422  k(iant(1),5)=mstu(5)*itri(1)
17423  nct=nct+1
17424  mct(itri(1),1)=nct
17425  mct(iant(1),2)=nct
17426  ENDIF
17427 
17428  ELSEIF(ntri+nant.EQ.2.AND.noct.EQ.1) THEN
17429 C...Two triplets, one octet, n singlets.
17430  IF (kcq(0).EQ.2) THEN
17431 C...8 -> 3 + 3bar + n(1)
17432  k(id,4)=k(id,4)+itri(1)
17433  k(id,5)=k(id,5)+iant(1)
17434  k(itri(1),1)=3
17435  k(itri(1),4)=mstu(5)*id
17436  k(iant(1),1)=3
17437  k(iant(1),5)=mstu(5)*id
17438  mct(itri(1),1)=mct(id,1)
17439  mct(iant(1),2)=mct(id,2)
17440  ELSEIF (kcq(0).EQ.1) THEN
17441 C...3 -> 8 + 3 + n(1)
17442  k(id,4)=k(id,4)+ioct(1)
17443  k(ioct(1),1)=3
17444  k(ioct(1),4)=mstu(5)*id
17445  k(ioct(1),5)=mstu(5)*itri(2)
17446  k(itri(2),1)=3
17447  k(itri(2),4)=mstu(5)*ioct(1)
17448  mct(ioct(1),1)=mct(id,1)
17449  nct=nct+1
17450  mct(ioct(1),2)=nct
17451  mct(itri(2),1)=nct
17452  ELSEIF (kcq(0).EQ.-1) THEN
17453 C...3bar -> 8 + 3bar + n(1)
17454  k(id,5)=k(id,5)+ioct(1)
17455  k(ioct(1),1)=3
17456  k(ioct(1),5)=mstu(5)*id
17457  k(ioct(1),4)=mstu(5)*iant(2)
17458  k(iant(2),1)=3
17459  k(iant(2),5)=mstu(5)*ioct(1)
17460  mct(ioct(1),2)=mct(id,2)
17461  nct=nct+1
17462  mct(ioct(1),1)=nct
17463  mct(iant(2),2)=nct
17464  ELSE
17465 C...1 -> 3 + 3bar + 8 + n(1)
17466  k(itri(1),1)=3
17467  k(itri(1),4)=mstu(5)*ioct(1)
17468  k(ioct(1),1)=3
17469  k(ioct(1),5)=mstu(5)*itri(1)
17470  k(ioct(1),4)=mstu(5)*iant(1)
17471  k(iant(1),1)=3
17472  k(iant(1),5)=mstu(5)*ioct(1)
17473  nct=nct+1
17474  mct(itri(1),1)=nct
17475  mct(ioct(1),2)=nct
17476  nct=nct+1
17477  mct(ioct(1),1)=nct
17478  mct(iant(1),2)=nct
17479  ENDIF
17480 CPS-- End of generic cases
17481 C...(could three octets also be handled?)
17482 C...(could (some of) the RPV cases be made generic as well?)
17483 
17484 C...Special cases (= old treatment)
17485 C...Set colour flow for t -> W + b + Z.
17486  ELSEIF(kfa.EQ.6) THEN
17487  k(n+2,1)=3
17488  isid=4
17489  IF(kcqm(jt).EQ.-1) isid=5
17490  idau=n+2
17491  k(id,isid)=k(id,isid)+idau
17492  k(idau,isid)=mstu(5)*id
17493 
17494 C...Set colour flow in three-body decays - programmed as special cases.
17495 
17496  ELSEIF(kfc2a.LE.6) THEN
17497  k(n+2,1)=3
17498  k(n+3,1)=3
17499  isid=4
17500  IF(kfl2(jt).LT.0) isid=5
17501  k(n+2,isid)=mstu(5)*(n+3)
17502  k(n+3,9-isid)=mstu(5)*(n+2)
17503 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17504  ELSEIF(kfa.GT.ksusy1.AND.mod(kfa,ksusy1).LT.10
17505  & .AND.kfl3(jt).NE.0) THEN
17506  kqsuma=iabs(kcq1(jt))+iabs(kcq2(jt))+iabs(kcq3(jt))
17507 C...3-body decays of squarks to colour singlets plus one quark
17508  IF (kqsuma.EQ.1) THEN
17509 C...Find quark
17510  iq=0
17511  IF (kcq1(jt).NE.0) iq=1
17512  IF (kcq2(jt).NE.0) iq=2
17513  IF (kcq3(jt).NE.0) iq=3
17514  isid=4
17515  IF (k(n+iq,2).LT.0) isid=5
17516  k(n+iq,1)=3
17517  k(id,isid)=k(id,isid)+(n+iq)
17518  k(n+iq,isid)=mstu(5)*id
17519  ENDIF
17520 C...PS--
17521  ELSEIF(kfl1(jt).EQ.ksusy1+21) THEN
17522  k(n+1,1)=3
17523  k(n+2,1)=3
17524  k(n+3,1)=3
17525  isid=4
17526  IF(kfl2(jt).LT.0) isid=5
17527  k(n+1,isid)=mstu(5)*(n+2)
17528  k(n+1,9-isid)=mstu(5)*(n+3)
17529  k(n+2,isid)=mstu(5)*(n+1)
17530  k(n+3,9-isid)=mstu(5)*(n+1)
17531  ELSEIF(kfa.EQ.ksusy1+21) THEN
17532  k(n+2,1)=3
17533  k(n+3,1)=3
17534  isid=4
17535  IF(kfl2(jt).LT.0) isid=5
17536  k(id,isid)=k(id,isid)+(n+2)
17537  k(id,9-isid)=k(id,9-isid)+(n+3)
17538  k(n+2,isid)=mstu(5)*id
17539  k(n+3,9-isid)=mstu(5)*id
17540 CMRENNA--
17541 
17542  ELSEIF(kfa.GE.ksusy1+22.AND.kfa.LE.ksusy1+37.AND.
17543  & iabs(kcq2(jt)).EQ.1) THEN
17544  k(n+2,1)=3
17545  k(n+3,1)=3
17546  isid=4
17547  IF(kfl2(jt).LT.0) isid=5
17548  k(n+2,isid)=mstu(5)*(n+3)
17549  k(n+3,9-isid)=mstu(5)*(n+2)
17550  ENDIF
17551 
17552  nsav=n
17553 
17554 C...Set colour flow in three-body decays with baryon number violation.
17555 C...Neutralino and chargino decays first.
17556  kcqsum=kcq1(jt)+kcq2(jt)+kcq3(jt)
17557  IF(kcqm(jt).EQ.0.AND.iabs(kcqsum).EQ.3) THEN
17558  itjunc(jt)=(1+(1-kcq1(jt))/2)
17559  k(n+4,4)=itjunc(jt)*mstu(5)
17560 C...Insert junction to keep track of colours.
17561  IF(kcq1(jt).NE.0) k(n+1,1)=3
17562  IF(kcq2(jt).NE.0) k(n+2,1)=3
17563  IF(kcq3(jt).NE.0) k(n+3,1)=3
17564 C...Set special junction codes:
17565  k(n+4,1)=42
17566  k(n+4,2)=88
17567 
17568 C...Order decay products by invariant mass. (will be used in PYSTRF).
17569  pm12=p(n+1,4)*p(n+2,4)-p(n+1,1)*p(n+2,1)-p(n+1,2)*p(n+2,2)-
17570  & p(n+1,3)*p(n+2,3)
17571  pm13=p(n+1,4)*p(n+3,4)-p(n+1,1)*p(n+3,1)-p(n+1,2)*p(n+3,2)-
17572  & p(n+1,3)*p(n+3,3)
17573  pm23=p(n+2,4)*p(n+3,4)-p(n+2,1)*p(n+3,1)-p(n+2,2)*p(n+3,2)-
17574  & p(n+2,3)*p(n+3,3)
17575  IF(pm12.LT.pm13.AND.pm12.LT.pm23) THEN
17576  k(n+4,4)=n+3+k(n+4,4)
17577  k(n+4,5)=n+1+mstu(5)*(n+2)
17578  ELSEIF(pm13.LT.pm23) THEN
17579  k(n+4,4)=n+2+k(n+4,4)
17580  k(n+4,5)=n+1+mstu(5)*(n+3)
17581  ELSE
17582  k(n+4,4)=n+1+k(n+4,4)
17583  k(n+4,5)=n+2+mstu(5)*(n+3)
17584  ENDIF
17585  DO 260 j=1,5
17586  p(n+4,j)=0d0
17587  v(n+4,j)=0d0
17588  260 CONTINUE
17589 C...Connect daughters to junction.
17590  DO 270 ii=n+1,n+3
17591  k(ii,4)=0
17592  k(ii,5)=0
17593  k(ii,itjunc(jt)+3)=mstu(5)*(n+4)
17594  270 CONTINUE
17595 C...Particle counter should be stepped up one extra for junction.
17596  n=n+1
17597 
17598 C...Gluino decays.
17599  ELSEIF (kcqm(jt).EQ.2.AND.iabs(kcqsum).EQ.3) THEN
17600  itjunc(jt)=(5+(1-kcq1(jt))/2)
17601  k(n+4,4)=itjunc(jt)*mstu(5)
17602 C...Insert junction to keep track of colours.
17603  IF(kcq1(jt).NE.0) k(n+1,1)=3
17604  IF(kcq2(jt).NE.0) k(n+2,1)=3
17605  IF(kcq3(jt).NE.0) k(n+3,1)=3
17606  k(n+4,1)=42
17607  k(n+4,2)=88
17608  DO 280 j=1,5
17609  p(n+4,j)=0d0
17610  v(n+4,j)=0d0
17611  280 CONTINUE
17612  ctmsum=0d0
17613  DO 290 ii=n+1,n+3
17614  k(ii,4)=0
17615  k(ii,5)=0
17616 C...Start by connecting all daughters to junction.
17617  k(ii,itjunc(jt)-1)=mstu(5)*(n+4)
17618 C...Only consider colour topologies with off shell resonances.
17619  rmq1=pmas(pycomp(k(ii,2)),1)
17620  rmres=pmas(pycomp(ksusy1+iabs(k(ii,2))),1)
17621  rmglu=pmas(pycomp(ksusy1+21),1)
17622  IF (rmglu-rmq1.LT.rmres) THEN
17623 C...Calculate propagators for each colour topology.
17624  rm2q23=rmglu**2+rmq1**2-2d0*(p(ii,4)*p(id,4)+p(ii,1)
17625  & *p(id,1)+p(ii,2)*p(id,2)+p(ii,3)*p(id,3))
17626  ctm2(ii-n)=1d0/(rm2q23-rmres**2)**2
17627  ELSE
17628  ctm2(ii-n)=0d0
17629  ENDIF
17630  ctmsum=ctmsum+ctm2(ii-n)
17631  290 CONTINUE
17632  ctmsum=pyr(0)*ctmsum
17633 C...Select colour topology J, with most off shell least likely.
17634  j=0
17635  300 j=j+1
17636  ctmsum=ctmsum-ctm2(j)
17637  IF (ctmsum.GT.0d0) GOTO 300
17638 C...The lucky winner gets its colour (anti-colour) directly from gluino.
17639  k(n+j,itjunc(jt)-1)=mstu(5)*id
17640  k(id,itjunc(jt)-1)=n+j+(k(id,itjunc(jt)-1)/mstu(5))*mstu(5)
17641 C...The other gluino colour is connected to junction
17642  k(id,10-itjunc(jt))=n+4+(k(id,10-itjunc(jt))/mstu(5))*
17643  & mstu(5)
17644  k(n+4,4)=k(n+4,4)+id
17645 C...Lastly, connect junction to remaining daughters.
17646  k(n+4,5)=n+1+mod(j,3)+mstu(5)*(n+1+mod(j+1,3))
17647 C...Particle counter should be stepped up one extra for junction.
17648  n=n+1
17649  ENDIF
17650 
17651 C...Update particle counter.
17652  n=n+3
17653 
17654 C...2) Everything else two-body decay.
17655  ELSE
17656  CALL py2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))
17657  mct(n-1,1)=0
17658  mct(n-1,2)=0
17659  mct(n,1)=0
17660  mct(n,2)=0
17661 C...First set colour flow as if mother colour singlet.
17662  IF(kcq1(jt).NE.0) THEN
17663  k(n-1,1)=3
17664  IF(kcq1(jt).NE.-1) k(n-1,4)=mstu(5)*n
17665  IF(kcq1(jt).NE.1) k(n-1,5)=mstu(5)*n
17666  ENDIF
17667  IF(kcq2(jt).NE.0) THEN
17668  k(n,1)=3
17669  IF(kcq2(jt).NE.-1) k(n,4)=mstu(5)*(n-1)
17670  IF(kcq2(jt).NE.1) k(n,5)=mstu(5)*(n-1)
17671  ENDIF
17672 C...Then redirect colour flow if mother (anti)triplet.
17673  IF(kcqm(jt).EQ.0) THEN
17674  ELSEIF(kcqm(jt).NE.2) THEN
17675  isid=4
17676  IF(kcqm(jt).EQ.-1) isid=5
17677  idau=n-1
17678  IF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.2) idau=n
17679  k(id,isid)=k(id,isid)+idau
17680  k(idau,isid)=mstu(5)*id
17681 C...Then redirect colour flow if mother octet.
17682  ELSEIF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.0) THEN
17683  idau=n-1
17684  IF(kcq1(jt).EQ.0) idau=n
17685  k(id,4)=k(id,4)+idau
17686  k(id,5)=k(id,5)+idau
17687  k(idau,4)=mstu(5)*id
17688  k(idau,5)=mstu(5)*id
17689  ELSE
17690  isid=4
17691  IF(kcq1(jt).EQ.-1) isid=5
17692  IF(kcq1(jt).EQ.2) isid=int(4.5d0+pyr(0))
17693  k(id,isid)=k(id,isid)+(n-1)
17694  k(id,9-isid)=k(id,9-isid)+n
17695  k(n-1,isid)=mstu(5)*id
17696  k(n,9-isid)=mstu(5)*id
17697  ENDIF
17698 
17699 C...Insert junction
17700  IF(iabs(kcq1(jt)+kcq2(jt)-kcqm(jt)).EQ.3) THEN
17701  n=n+1
17702 C...~q* mother: type 3 junction. ~q mother: type 4.
17703  itjunc(jt)=(7+kcqm(jt))/2
17704 C...Specify junction KF and set colour flow from junction
17705  k(n,1)=42
17706  k(n,2)=88
17707  k(n,3)=id
17708 C...Junction type encoded together with mother:
17709  k(n,4)=id+itjunc(jt)*mstu(5)
17710  k(n,5)=n-1+mstu(5)*(n-2)
17711 C...Zero P and V for junction (V filled later)
17712  DO 310 j=1,5
17713  p(n,j)=0d0
17714  v(n,j)=0d0
17715  310 CONTINUE
17716 C...Set colour flow from mother to junction
17717  k(id,8-itjunc(jt))= n + mstu(5)*(k(id,8-itjunc(jt))/mstu(5))
17718 C...Set colour flow from daughters to junction
17719  DO 320 ii=n-2,n-1
17720  k(ii,4) = 0
17721  k(ii,5) = 0
17722 C...(Anti-)colour mother is junction.
17723  k(ii,1+itjunc(jt)) = mstu(5)*(n)
17724  320 CONTINUE
17725  ENDIF
17726  ENDIF
17727 
17728 C...End loop over resonances for daughter flavour and mass selection.
17729  mstu(10)=mstu10
17730  330 IF(mwid(kca).NE.0.AND.(kfl1(jt).EQ.0.OR.kfl3(jt).NE.0))
17731  & ninh=ninh+1
17732  IF(ires.GT.0.AND.mwid(kca).NE.0.AND.mdcy(kca,1).NE.0.AND.
17733  & kfl1(jt).EQ.0) THEN
17734  WRITE(code,'(I9)') k(id,2)
17735  WRITE(mass,'(F9.3)') p(id,5)
17736  CALL pyerrm(3,'(PYRESD:) Failed to decay particle'//
17737  & code//' with mass'//mass)
17738  mint(51)=1
17739  GOTO 720
17740  ENDIF
17741  340 CONTINUE
17742 
17743 C...Check for allowed combinations. Skip if no decays.
17744  IF(jtmax.EQ.1) THEN
17745  IF(kdcy(1).EQ.0) GOTO 710
17746  ELSEIF(jtmax.EQ.2) THEN
17747  IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0) GOTO 710
17748  IF(keql(1).EQ.4.AND.keql(2).EQ.4) GOTO 180
17749  IF(keql(1).EQ.5.AND.keql(2).EQ.5) GOTO 180
17750  ELSEIF(jtmax.EQ.3) THEN
17751  IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0.AND.kdcy(3).EQ.0) GOTO 710
17752  IF(keql(1).EQ.4.AND.keql(2).EQ.4) GOTO 180
17753  IF(keql(1).EQ.4.AND.keql(3).EQ.4) GOTO 180
17754  IF(keql(2).EQ.4.AND.keql(3).EQ.4) GOTO 180
17755  IF(keql(1).EQ.5.AND.keql(2).EQ.5) GOTO 180
17756  IF(keql(1).EQ.5.AND.keql(3).EQ.5) GOTO 180
17757  IF(keql(2).EQ.5.AND.keql(3).EQ.5) GOTO 180
17758  ENDIF
17759 
17760 C...Special case: matrix element option for Z0 decay to quarks.
17761  IF(mstp(48).EQ.1.AND.isub.EQ.1.AND.jtmax.EQ.1.AND.
17762  &iabs(mint(11)).EQ.11.AND.iabs(kfl1(1)).LE.5) THEN
17763 
17764 C...Check consistency of MSTJ options set.
17765  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
17766  CALL pyerrm(6,
17767  & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17768  mstj(110)=1
17769  ENDIF
17770  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
17771  CALL pyerrm(6,
17772  & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17773 
17774  mstj(111)=0
17775  ENDIF
17776 
17777 C...Select alpha_strong behaviour.
17778  mst111=mstu(111)
17779  par112=paru(112)
17780  mstu(111)=mstj(108)
17781  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
17782  & mstu(111)=1
17783  paru(112)=parj(121)
17784  IF(mstu(111).EQ.2) paru(112)=parj(122)
17785 
17786 C...Find axial fraction in total cross section for scalar gluon model.
17787  parj(171)=0d0
17788  IF((iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.1).OR.
17789  & (mstj(101).EQ.5.AND.mstj(49).EQ.1)) THEN
17790  poll=1d0-parj(131)*parj(132)
17791  sff=1d0/(16d0*xw*xw1)
17792  sfw=p(id,5)**4/((p(id,5)**2-parj(123)**2)**2+
17793  & (parj(123)*parj(124))**2)
17794  sfi=sfw*(1d0-(parj(123)/p(id,5))**2)
17795  ve=4d0*xw-1d0
17796  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
17797  hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*
17798  & (parj(132)-parj(131)))
17799  kflc=iabs(kfl1(1))
17800  pmq=pymass(kflc)
17801  qf=kchg(kflc,1)/3d0
17802  vq=1d0
17803  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,
17804  & 1d0-(2d0*pmq/p(id,5))**2))
17805  vf=sign(1d0,qf)-4d0*qf*xw
17806  rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+
17807  & vf**2*hf1w)+vq**3*hf1w
17808  IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
17809  ENDIF
17810 
17811 C...Choice of jet configuration.
17812  CALL pyxjet(p(id,5),njet,cut)
17813  kflc=iabs(kfl1(1))
17814  kfln=21
17815  IF(njet.EQ.4) THEN
17816  CALL pyx4jt(njet,cut,kflc,p(id,5),kfln,x1,x2,x4,x12,x14)
17817  ELSEIF(njet.EQ.3) THEN
17818  CALL pyx3jt(njet,cut,kflc,p(id,5),x1,x3)
17819  ELSE
17820  mstj(120)=1
17821  ENDIF
17822 
17823 C...Fill jet configuration; return if incorrect kinematics.
17824  nc=n-2
17825  IF(njet.EQ.2.AND.mstj(101).NE.5) THEN
17826  CALL py2ent(nc+1,kflc,-kflc,p(id,5))
17827  ELSEIF(njet.EQ.2) THEN
17828  CALL py2ent(-(nc+1),kflc,-kflc,p(id,5))
17829  ELSEIF(njet.EQ.3) THEN
17830  CALL py3ent(nc+1,kflc,21,-kflc,p(id,5),x1,x3)
17831  ELSEIF(kfln.EQ.21) THEN
17832  CALL py4ent(nc+1,kflc,kfln,kfln,-kflc,p(id,5),x1,x2,x4,
17833  & x12,x14)
17834  ELSE
17835  CALL py4ent(nc+1,kflc,-kfln,kfln,-kflc,p(id,5),x1,x2,x4,
17836  & x12,x14)
17837  ENDIF
17838  IF(mstu(24).NE.0) THEN
17839  mint(51)=1
17840  mstu(111)=mst111
17841  paru(112)=par112
17842  GOTO 720
17843  ENDIF
17844 
17845 C...Angular orientation according to matrix element.
17846  IF(mstj(106).EQ.1) THEN
17847  CALL pyxdif(nc,njet,kflc,p(id,5),chiz,thez,phiz)
17848  IF(mint(11).LT.0) thez=paru(1)-thez
17849  cthe(1)=cos(thez)
17850  CALL pyrobo(nc+1,n,0d0,chiz,0d0,0d0,0d0)
17851  CALL pyrobo(nc+1,n,thez,phiz,0d0,0d0,0d0)
17852  ENDIF
17853 
17854 C...Boost partons to Z0 rest frame.
17855  CALL pyrobo(nc+1,n,0d0,0d0,p(id,1)/p(id,4),
17856  & p(id,2)/p(id,4),p(id,3)/p(id,4))
17857 
17858 C...Mark decayed resonance and add documentation lines,
17859  k(id,1)=k(id,1)+10
17860  idoc=mint(83)+mint(4)
17861  DO 360 i=nc+1,n
17862  i1=mint(83)+mint(4)+1
17863  k(i,3)=i1
17864  IF(mstp(128).GE.1) k(i,3)=id
17865  IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
17866  mint(4)=mint(4)+1
17867  k(i1,1)=21
17868  k(i1,2)=k(i,2)
17869  k(i1,3)=iref(ip,4)
17870  DO 350 j=1,5
17871  p(i1,j)=p(i,j)
17872  350 CONTINUE
17873  ENDIF
17874  360 CONTINUE
17875 
17876 C...Generate parton shower.
17877  IF(mstj(101).EQ.5.AND.mint(35).LE.1) THEN
17878  CALL pyshow(n-1,n,p(id,5))
17879  ELSEIF(mstj(101).EQ.5.AND.mint(35).GE.2) THEN
17880  npart=2
17881  ipart(1)=n-1
17882  ipart(2)=n
17883  ptpart(1)=0.5d0*p(id,5)
17884  ptpart(2)=ptpart(1)
17885  nct=nct+1
17886  IF(k(n-1,2).GT.0) THEN
17887  mct(n-1,1)=nct
17888  mct(n,2)=nct
17889  ELSE
17890  mct(n-1,2)=nct
17891  mct(n,1)=nct
17892  ENDIF
17893  CALL pyptfs(2,0.5d0*p(id,5),0d0,ptgen)
17894  ENDIF
17895 
17896 C... End special case for Z0: skip ahead.
17897  mstu(111)=mst111
17898  paru(112)=par112
17899  GOTO 700
17900  ENDIF
17901 
17902 C...Order incoming partons and outgoing resonances.
17903  IF(jtmax.EQ.2.AND.isub.NE.0.AND.mstp(47).GE.1.AND.
17904  &ninh.EQ.0) THEN
17905  ilin(1)=mint(84)+1
17906  IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2
17907  IF(k(ilin(1),2).EQ.21.OR.k(ilin(1),2).EQ.22)
17908  & ilin(1)=2*mint(84)+3-ilin(1)
17909  ilin(2)=2*mint(84)+3-ilin(1)
17910  imin=1
17911  IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
17912  & .EQ.36) imin=3
17913  imax=2
17914  iord=1
17915  IF(k(iref(ip,1),2).EQ.23) iord=2
17916  IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2
17917  iakipd=iabs(k(iref(ip,iord),2))
17918  IF(iakipd.EQ.25.OR.iakipd.EQ.35.OR.iakipd.EQ.36) iord=3-iord
17919  IF(kdcy(iord).EQ.0) iord=3-iord
17920 
17921 C...Order decay products of resonances.
17922  DO 370 jt=iord,3-iord,3-2*iord
17923  IF(kdcy(jt).EQ.0) THEN
17924  ilin(imax+1)=nsd(jt)
17925  imax=imax+1
17926  ELSEIF(k(nsd(jt)+1,2).GT.0) THEN
17927  ilin(imax+1)=n+2*jt-1
17928  ilin(imax+2)=n+2*jt
17929  imax=imax+2
17930  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
17931  k(n+2*jt,2)=k(nsd(jt)+2,2)
17932  ELSE
17933  ilin(imax+1)=n+2*jt
17934 
17935  ilin(imax+2)=n+2*jt-1
17936  imax=imax+2
17937  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
17938  k(n+2*jt,2)=k(nsd(jt)+2,2)
17939  ENDIF
17940  370 CONTINUE
17941 
17942 C...Find charge, isospin, left- and righthanded couplings.
17943  DO 390 i=imin,imax
17944  DO 380 j=1,4
17945  coup(i,j)=0d0
17946  380 CONTINUE
17947  kfa=iabs(k(ilin(i),2))
17948  IF(kfa.EQ.0.OR.kfa.GT.20) GOTO 390
17949  coup(i,1)=kchg(kfa,1)/3d0
17950  coup(i,2)=(-1)**mod(kfa,2)
17951  coup(i,4)=-2d0*coup(i,1)*xwv
17952  coup(i,3)=coup(i,2)+coup(i,4)
17953  390 CONTINUE
17954 
17955 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
17956  IF(isub.EQ.22) THEN
17957  DO 420 i=3,5,2
17958  i1=iord
17959  IF(i.EQ.5) i1=3-iord
17960  DO 410 j1=1,2
17961  DO 400 j2=1,2
17962  corl(i/2,j1,j2)=coup(1,1)**2*hgz(i1,1)*coup(i,1)**2/
17963  & 16d0+coup(1,1)*coup(1,j1+2)*hgz(i1,2)*coup(i,1)*
17964  & coup(i,j2+2)/4d0+coup(1,j1+2)**2*hgz(i1,3)*
17965  & coup(i,j2+2)**2
17966  400 CONTINUE
17967  410 CONTINUE
17968  420 CONTINUE
17969  cowt12=(corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
17970  & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2))
17971  comx12=(corl(1,1,1)+corl(1,1,2)+corl(1,2,1)+corl(1,2,2))*
17972  & (corl(2,1,1)+corl(2,1,2)+corl(2,2,1)+corl(2,2,2))
17973 
17974  IF(cowt12.LT.pyr(0)*comx12) GOTO 180
17975  ENDIF
17976  ENDIF
17977 
17978 C...Select angular orientation type - Z'/W' only.
17979  mzpwp=0
17980  IF(isub.EQ.141) THEN
17981  IF(pyr(0).LT.paru(130)) mzpwp=1
17982  IF(ip.EQ.2) THEN
17983  IF(iabs(k(iref(2,1),2)).EQ.37) mzpwp=2
17984  iakir=iabs(k(iref(2,2),2))
17985  IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
17986  IF(iakir.LE.20) mzpwp=2
17987  ENDIF
17988  IF(ip.GE.3) mzpwp=2
17989  ELSEIF(isub.EQ.142) THEN
17990  IF(pyr(0).LT.paru(136)) mzpwp=1
17991  IF(ip.EQ.2) THEN
17992  iakir=iabs(k(iref(2,2),2))
17993  IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
17994  IF(iakir.LE.20) mzpwp=2
17995  ENDIF
17996  IF(ip.GE.3) mzpwp=2
17997  ENDIF
17998 
17999 C...Select random angles (begin of weighting procedure).
18000  430 DO 440 jt=1,jtmax
18001  IF(kdcy(jt).EQ.0) GOTO 440
18002  IF(jtmax.EQ.1.AND.isub.NE.0.AND.ihdec.EQ.0) THEN
18003  cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*pyr(0)
18004  IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)
18005  phi(jt)=vint(24)
18006  ELSE
18007  cthe(jt)=2d0*pyr(0)-1d0
18008  phi(jt)=paru(2)*pyr(0)
18009  ENDIF
18010  440 CONTINUE
18011 
18012  IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN
18013 C...Construct massless four-vectors.
18014  DO 460 i=n+1,n+4
18015  k(i,1)=1
18016  DO 450 j=1,5
18017  p(i,j)=0d0
18018  v(i,j)=0d0
18019  450 CONTINUE
18020  460 CONTINUE
18021  DO 470 jt=1,jtmax
18022  IF(kdcy(jt).EQ.0) GOTO 470
18023  id=iref(ip,jt)
18024  p(n+2*jt-1,3)=0.5d0*p(id,5)
18025  p(n+2*jt-1,4)=0.5d0*p(id,5)
18026  p(n+2*jt,3)=-0.5d0*p(id,5)
18027  p(n+2*jt,4)=0.5d0*p(id,5)
18028  CALL pyrobo(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),
18029  & p(id,1)/p(id,4),p(id,2)/p(id,4),p(id,3)/p(id,4))
18030  470 CONTINUE
18031 
18032 C...Store incoming and outgoing momenta, with random rotation to
18033 C...avoid accidental zeroes in HA expressions.
18034  IF(isub.NE.0) THEN
18035  DO 490 i=imin,imax
18036  k(n+4+i,1)=1
18037  p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+
18038  & p(ilin(i),3)**2+p(ilin(i),5)**2)
18039  p(n+4+i,5)=p(ilin(i),5)
18040  DO 480 j=1,3
18041  p(n+4+i,j)=p(ilin(i),j)
18042  480 CONTINUE
18043  490 CONTINUE
18044  500 therr=acos(2d0*pyr(0)-1d0)
18045  phirr=paru(2)*pyr(0)
18046  CALL pyrobo(n+4+imin,n+4+imax,therr,phirr,0d0,0d0,0d0)
18047  DO 520 i=imin,imax
18048  IF(p(n+4+i,1)**2+p(n+4+i,2)**2.LT.1d-4*(p(n+4+i,1)**2+
18049  & p(n+4+i,2)**2+p(n+4+i,3)**2)) GOTO 500
18050  DO 510 j=1,4
18051  pk(i,j)=p(n+4+i,j)
18052  510 CONTINUE
18053  520 CONTINUE
18054  ENDIF
18055 
18056 C...Calculate internal products.
18057  IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25.OR.isub.EQ.141.OR.
18058  & isub.EQ.142) THEN
18059  DO 540 i1=imin,imax-1
18060  DO 530 i2=i1+1,imax
18061  ha(i1,i2)=sngl(sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+
18062  & pk(i2,3))/(1d-20+pk(i1,1)**2+pk(i1,2)**2)))*
18063  & cmplx(sngl(pk(i1,1)),sngl(pk(i1,2)))-
18064  & sngl(sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/
18065  & (1d-20+pk(i2,1)**2+pk(i2,2)**2)))*
18066  & cmplx(sngl(pk(i2,1)),sngl(pk(i2,2)))
18067  hc(i1,i2)=conjg(ha(i1,i2))
18068  IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)
18069  IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)
18070  ha(i2,i1)=-ha(i1,i2)
18071  hc(i2,i1)=-hc(i1,i2)
18072  530 CONTINUE
18073  540 CONTINUE
18074  ENDIF
18075 
18076 C...Calculate four-products.
18077  IF(isub.NE.0) THEN
18078  DO 560 i=1,2
18079  DO 550 j=1,4
18080  pk(i,j)=-pk(i,j)
18081  550 CONTINUE
18082  560 CONTINUE
18083  DO 580 i1=imin,imax-1
18084  DO 570 i2=i1+1,imax
18085  pkk(i1,i2)=2d0*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-
18086  & pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))
18087  pkk(i2,i1)=pkk(i1,i2)
18088  570 CONTINUE
18089  580 CONTINUE
18090  ENDIF
18091  ENDIF
18092 
18093  kfagm=iabs(iref(ip,7))
18094  IF(mstp(47).LE.0.OR.ninh.NE.0) THEN
18095 C...Isotropic decay selected by user.
18096  wt=1d0
18097  wtmax=1d0
18098 
18099  ELSEIF(jtmax.EQ.3) THEN
18100 C...Isotropic decay when three mother particles.
18101  wt=1d0
18102  wtmax=1d0
18103 
18104  ELSEIF(it4.GE.1) THEN
18105 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18106  wt=1d0
18107  wtmax=1d0
18108 
18109  ELSEIF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.
18110  & iref(ip,7).EQ.36) THEN
18111 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18112 C...CP-odd case added by Kari Ertresvag Myklevoll.
18113 C...Now also with mixed Higgs CP-states
18114  eta=parp(25)
18115  IF(ip.EQ.1) wtmax=sh**2
18116  IF(ip.GE.2) wtmax=p(iref(ip,8),5)**4
18117  kfa=iabs(k(iref(ip,1),2))
18118  kft=iabs(k(iref(ip,2),2))
18119 
18120  IF((kfa.EQ.kft).AND.(kfa.EQ.23.OR.kfa.EQ.24).AND.
18121  & mstp(25).GE.3) THEN
18122 C...For mixed CP states need epsilon product.
18123  p10=pk(3,4)
18124  p20=pk(4,4)
18125  p30=pk(5,4)
18126  p40=pk(6,4)
18127  p11=pk(3,1)
18128  p21=pk(4,1)
18129  p31=pk(5,1)
18130  p41=pk(6,1)
18131  p12=pk(3,2)
18132  p22=pk(4,2)
18133  p32=pk(5,2)
18134  p42=pk(6,2)
18135  p13=pk(3,3)
18136  p23=pk(4,3)
18137  p33=pk(5,3)
18138  p43=pk(6,3)
18139  epsi=p10*p21*p32*p43-p10*p21*p33*p42-p10*p22*p31*p43+p10*p22*
18140  & p33*p41+p10*p23*p31*p42-p10*p23*p32*p41-p11*p20*p32*p43+p11*
18141  & p20*p33*p42+p11*p22*p30*p43-p11*p22*p33*p40-p11*p23*p30*p42+
18142  & p11*p23*p32*p40+p12*p20*p31*p43-p12*p20*p33*p41-p12*p21*p30*
18143  & p43+p12*p21*p33*p40+p12*p23*p30*p41-p12*p23*p31*p40-p13*p20*
18144  & p31*p42+p13*p20*p32*p41+p13*p21*p30*p42-p13*p21*p32*p40-p13*
18145  & p22*p30*p41+p13*p22*p31*p40
18146 C...For mixed CP states need gauge boson masses.
18147  xma=sqrt(max(0d0,(pk(3,4)+pk(4,4))**2-(pk(3,1)+pk(4,1))**2-
18148  & (pk(3,2)+pk(4,2))**2-(pk(3,3)+pk(4,3))**2))
18149  xmb=sqrt(max(0d0,(pk(5,4)+pk(6,4))**2-(pk(5,1)+pk(6,1))**2-
18150  & (pk(5,2)+pk(6,2))**2-(pk(5,3)+pk(6,3))**2))
18151  xmv=pmas(kfa,1)
18152  ENDIF
18153 
18154 C...Z decay
18155  IF(kfa.EQ.23.AND.kfa.EQ.kft) THEN
18156  kflf1a=iabs(kfl1(1))
18157  ef1=kchg(kflf1a,1)/3d0
18158  af1=sign(1d0,ef1+0.1d0)
18159  vf1=af1-4d0*ef1*xwv
18160  kflf2a=iabs(kfl1(2))
18161  ef2=kchg(kflf2a,1)/3d0
18162  af2=sign(1d0,ef2+0.1d0)
18163  vf2=af2-4d0*ef2*xwv
18164  va12as=4d0*vf1*af1*vf2*af2/((vf1**2+af1**2)*(vf2**2+af2**2))
18165  IF((mstp(25).EQ.0.AND.iref(ip,7).NE.36).OR.mstp(25).EQ.1)
18166  & THEN
18167 C...CP-even decay
18168  wt=8d0*(1d0+va12as)*pkk(3,5)*pkk(4,6)+
18169  & 8d0*(1d0-va12as)*pkk(3,6)*pkk(4,5)
18170  ELSEIF(mstp(25).LE.2) THEN
18171 C...CP-odd decay
18172  wt=((pkk(3,5)+pkk(4,6))**2 +(pkk(3,6)+pkk(4,5))**2
18173  & -2*pkk(3,4)*pkk(5,6)
18174  & -2*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2/
18175  & (pkk(3,4)*pkk(5,6))
18176  & +va12as*(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))*
18177  & (pkk(3,5)+pkk(4,5)-pkk(3,6)-pkk(4,6)))/(1+va12as)
18178  ELSE
18179 C...Mixed CP states.
18180  wt=32d0*(0.25d0*((1d0+va12as)*pkk(3,5)*pkk(4,6)
18181  & +(1d0-va12as)*pkk(3,6)*pkk(4,5))
18182  & -0.5d0*eta/xmv**2*epsi*((1d0+va12as)*(pkk(3,5)+pkk(4,6))
18183  & -(1d0-va12as)*(pkk(3,6)+pkk(4,5)))
18184  & +6.25d-2*eta**2/xmv**4*(-2d0*pkk(3,4)**2*pkk(5,6)**2
18185  & -2d0*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2
18186  & +pkk(3,4)*pkk(5,6)
18187  & *((pkk(3,5)+pkk(4,6))**2+(pkk(3,6)+pkk(4,5))**2)
18188  & +va12as*pkk(3,4)*pkk(5,6)
18189  & *(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))
18190  & *(pkk(3,5)-pkk(3,6)+pkk(4,5)-pkk(4,6))))
18191  & /(1d0 +2d0*eta*xma*xmb/xmv**2
18192  & +2d0*(eta*xma*xmb/xmv**2)**2*(1d0+va12as))
18193  ENDIF
18194 
18195 C...W decay
18196  ELSEIF(kfa.EQ.24.AND.kfa.EQ.kft) THEN
18197  IF((mstp(25).EQ.0.AND.iref(ip,7).NE.36).OR.mstp(25).EQ.1)
18198  & THEN
18199 C...CP-even decay
18200  wt=16d0*pkk(3,5)*pkk(4,6)
18201  ELSEIF(mstp(25).LE.2) THEN
18202 C...CP-odd decay
18203  wt=0.5d0*((pkk(3,5)+pkk(4,6))**2 +(pkk(3,6)+pkk(4,5))**2
18204  & -2*pkk(3,4)*pkk(5,6)
18205  & -2*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2/
18206  & (pkk(3,4)*pkk(5,6))
18207  & +(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))*
18208  & (pkk(3,5)+pkk(4,5)-pkk(3,6)-pkk(4,6)))
18209  ELSE
18210 C...Mixed CP states.
18211  wt=32d0*(0.25d0*2d0*pkk(3,5)*pkk(4,6)
18212  & -0.5d0*eta/xmv**2*epsi*2d0*(pkk(3,5)+pkk(4,6))
18213  & +6.25d-2*eta**2/xmv**4*(-2d0*pkk(3,4)**2*pkk(5,6)**2
18214  & -2d0*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2
18215  & +pkk(3,4)*pkk(5,6)
18216  & *((pkk(3,5)+pkk(4,6))**2+(pkk(3,6)+pkk(4,5))**2)
18217  & +pkk(3,4)*pkk(5,6)
18218  & *(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))
18219  & *(pkk(3,5)-pkk(3,6)+pkk(4,5)-pkk(4,6))))
18220  & /(1d0 +2d0*eta*xma*xmb/xmv**2
18221  & +(2d0*eta*xma*xmb/xmv**2)**2)
18222  ENDIF
18223 
18224 C...No angular correlations in other Higgs decays.
18225  ELSE
18226  wt=wtmax
18227  ENDIF
18228 
18229  ELSEIF((kfagm.EQ.6.OR.kfagm.EQ.7.OR.kfagm.EQ.8.OR.
18230  & kfagm.EQ.17.OR.kfagm.EQ.18).AND.iabs(k(iref(ip,1),2)).EQ.24)
18231  & THEN
18232 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18233  i1=iref(ip,8)
18234  IF(mod(kfagm,2).EQ.0) THEN
18235  i2=n+1
18236  i3=n+2
18237  ELSE
18238  i2=n+2
18239  i3=n+1
18240  ENDIF
18241  i4=iref(ip,2)
18242  wt=(p(i1,4)*p(i2,4)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
18243  & p(i1,3)*p(i2,3))*(p(i3,4)*p(i4,4)-p(i3,1)*p(i4,1)-
18244  & p(i3,2)*p(i4,2)-p(i3,3)*p(i4,3))
18245  wtmax=(p(i1,5)**4-p(iref(ip,1),5)**4)/8d0
18246 
18247  ELSEIF(isub.EQ.1) THEN
18248 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18249  ei=kchg(iabs(mint(15)),1)/3d0
18250  ai=sign(1d0,ei+0.1d0)
18251  vi=ai-4d0*ei*xwv
18252  ef=kchg(iabs(kfl1(1)),1)/3d0
18253  af=sign(1d0,ef+0.1d0)
18254 
18255  vf=af-4d0*ef*xwv
18256  rmf=min(1d0,4d0*pmas(iabs(kfl1(1)),1)**2/sh)
18257  wt1=ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18258  & (vi**2+ai**2)*vint(114)*(vf**2+(1d0-rmf)*af**2)
18259  wt2=rmf*(ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18260  & (vi**2+ai**2)*vint(114)*vf**2)
18261  wt3=sqrt(1d0-rmf)*(ei*ai*vint(112)*ef*af+
18262  & 4d0*vi*ai*vint(114)*vf*af)
18263  wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
18264  & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
18265  wtmax=2d0*(wt1+abs(wt3))
18266 
18267  ELSEIF(isub.EQ.2) THEN
18268 C...Angular weight for W+/- -> 2 quarks/leptons.
18269  rm3=pmas(iabs(kfl1(1)),1)**2/sh
18270  rm4=pmas(iabs(kfl2(1)),1)**2/sh
18271  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18272  wt=(1d0+be34*cthe(1)*isign(1,mint(15)*kfl1(1)))**2-(rm3-rm4)**2
18273  wtmax=4d0
18274 
18275  ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN
18276 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18277 C...-> gluon/gamma + 2 quarks/leptons.
18278  clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18279  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18280  & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
18281  clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18282  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18283  & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
18284  crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18285  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18286  & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
18287  crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18288  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18289  & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
18290  wt=(clilf+crirf)*(pkk(1,3)**2+pkk(2,4)**2)+
18291  & (clirf+crilf)*(pkk(1,4)**2+pkk(2,3)**2)
18292  wtmax=(clilf+clirf+crilf+crirf)*
18293  & ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)
18294 
18295  ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN
18296 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18297 C...-> gluon/gamma + 2 quarks/leptons.
18298  wt=pkk(1,3)**2+pkk(2,4)**2
18299  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2
18300 
18301  ELSEIF(isub.EQ.22) THEN
18302 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18303  s34=p(iref(ip,iord),5)**2
18304  s56=p(iref(ip,3-iord),5)**2
18305  ti=pkk(1,3)+pkk(1,4)+s34
18306  ui=pkk(1,5)+pkk(1,6)+s56
18307  tir=real(ti)
18308  uir=real(ui)
18309  fgk135=abs(fgk(1,2,3,4,5,6)/tir+fgk(1,2,5,6,3,4)/uir)**2
18310  fgk145=abs(fgk(1,2,4,3,5,6)/tir+fgk(1,2,5,6,4,3)/uir)**2
18311  fgk136=abs(fgk(1,2,3,4,6,5)/tir+fgk(1,2,6,5,3,4)/uir)**2
18312  fgk146=abs(fgk(1,2,4,3,6,5)/tir+fgk(1,2,6,5,4,3)/uir)**2
18313  fgk253=abs(fgk(2,1,5,6,3,4)/tir+fgk(2,1,3,4,5,6)/uir)**2
18314  fgk263=abs(fgk(2,1,6,5,3,4)/tir+fgk(2,1,3,4,6,5)/uir)**2
18315  fgk254=abs(fgk(2,1,5,6,4,3)/tir+fgk(2,1,4,3,5,6)/uir)**2
18316  fgk264=abs(fgk(2,1,6,5,4,3)/tir+fgk(2,1,4,3,6,5)/uir)**2
18317 
18318  wt=
18319  & corl(1,1,1)*corl(2,1,1)*fgk135+corl(1,1,2)*corl(2,1,1)*fgk145+
18320  & corl(1,1,1)*corl(2,1,2)*fgk136+corl(1,1,2)*corl(2,1,2)*fgk146+
18321  & corl(1,2,1)*corl(2,2,1)*fgk253+corl(1,2,2)*corl(2,2,1)*fgk263+
18322  & corl(1,2,1)*corl(2,2,2)*fgk254+corl(1,2,2)*corl(2,2,2)*fgk264
18323  wtmax=16d0*((corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
18324  & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2)))*s34*s56*
18325  & ((ti**2+ui**2+2d0*sh*(s34+s56))/(ti*ui)-s34*s56*(1d0/ti**2+
18326  & 1d0/ui**2))
18327 
18328  ELSEIF(isub.EQ.23) THEN
18329 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18330  d34=p(iref(ip,iord),5)**2
18331  d56=p(iref(ip,3-iord),5)**2
18332  dt=pkk(1,3)+pkk(1,4)+d34
18333  du=pkk(1,5)+pkk(1,6)+d56
18334  facbw=1d0/((sh-sqmw)**2+gmmw**2)
18335  cawz=coup(2,3)/dt-2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
18336  cbwz=coup(1,3)/du+2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
18337  fgk135=abs(real(cawz)*fgk(1,2,3,4,5,6)+
18338 
18339  & real(cbwz)*fgk(1,2,5,6,3,4))
18340  fgk136=abs(real(cawz)*fgk(1,2,3,4,6,5)+
18341  & real(cbwz)*fgk(1,2,6,5,3,4))
18342  wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
18343  wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*
18344  & digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))
18345 
18346  ELSEIF(isub.EQ.24.OR.isub.EQ.171.OR.isub.EQ.176) THEN
18347 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18348 C...(or H0, or A0).
18349  wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*
18350  & pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)*
18351  & coup(3,3))**2)*pkk(1,4)*pkk(2,3)
18352  wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
18353  & (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
18354 
18355  ELSEIF(isub.EQ.25) THEN
18356 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18357  polr=(1d0+parj(132))*(1d0-parj(131))
18358  poll=(1d0-parj(132))*(1d0+parj(131))
18359  d34=p(iref(ip,iord),5)**2
18360  d56=p(iref(ip,3-iord),5)**2
18361  dt=pkk(1,3)+pkk(1,4)+d34
18362  du=pkk(1,5)+pkk(1,6)+d56
18363  facbw=1d0/((sh-sqmz)**2+sqmz*pmas(23,2)**2)
18364  cdww=(coup(1,3)*sqmz*(sh-sqmz)*facbw+coup(1,2))/sh
18365  caww=cdww+0.5d0*(coup(1,2)+1d0)/dt
18366  cbww=cdww+0.5d0*(coup(1,2)-1d0)/du
18367  ccww=coup(1,4)*sqmz*(sh-sqmz)*facbw/sh
18368  fgk135=abs(real(caww)*fgk(1,2,3,4,5,6)-
18369  & real(cbww)*fgk(1,2,5,6,3,4))
18370  fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
18371  IF(mstp(50).LE.0) THEN
18372  wt=fgk135**2+(ccww*fgk253)**2
18373  wtmax=4d0*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-
18374  & caww*cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-
18375  & djgk(dt,du)))
18376  ELSE
18377  wt=poll*fgk135**2+polr*(ccww*fgk253)**2
18378  wtmax=4d0*d34*d56*(poll*(caww**2*digk(dt,du)+
18379  & cbww**2*digk(du,dt)-caww*cbww*djgk(dt,du))+
18380  & polr*ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du)))
18381  ENDIF
18382 
18383  ELSEIF(isub.EQ.26.OR.isub.EQ.172.OR.isub.EQ.177) THEN
18384 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18385 C...(or H0, or A0).
18386  wt=pkk(1,3)*pkk(2,4)
18387  wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
18388 
18389  ELSEIF(isub.EQ.30.OR.isub.EQ.35) THEN
18390 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18391 C...-> f + 2 quarks/leptons.
18392  clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18393  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18394  & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
18395  clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18396  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18397  & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
18398  crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18399  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18400  & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
18401  crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18402  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18403  & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
18404  IF(k(ilin(1),2).GT.0) wt=(clilf+crirf)*(pkk(1,4)**2+
18405  & pkk(3,5)**2)+(clirf+crilf)*(pkk(1,3)**2+pkk(4,5)**2)
18406  IF(k(ilin(1),2).LT.0) wt=(clilf+crirf)*(pkk(1,3)**2+
18407  & pkk(4,5)**2)+(clirf+crilf)*(pkk(1,4)**2+pkk(3,5)**2)
18408  wtmax=(clilf+clirf+crilf+crirf)*
18409  & ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)
18410 
18411  ELSEIF(isub.EQ.31.OR.isub.EQ.36) THEN
18412 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18413  IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2
18414  IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2
18415  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2
18416 
18417  ELSEIF(isub.EQ.71.OR.isub.EQ.72.OR.isub.EQ.73.OR.isub.EQ.76.OR.
18418  & isub.EQ.77) THEN
18419 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18420  wt=16d0*pkk(3,5)*pkk(4,6)
18421  wtmax=sh**2
18422 
18423  ELSEIF(isub.EQ.110) THEN
18424 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18425  wt=1d0
18426  wtmax=1d0
18427 
18428  ELSEIF(isub.EQ.141) THEN
18429 C...Special case: if only branching ratios known then isotropic decay.
18430  IF(mwid(32).EQ.2) THEN
18431  wt=1d0
18432  wtmax=1d0
18433  ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
18434 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18435 C...Couplings of incoming flavour.
18436  kfai=iabs(mint(15))
18437  ei=kchg(kfai,1)/3d0
18438  ai=sign(1d0,ei+0.1d0)
18439  vi=ai-4d0*ei*xwv
18440  kfaic=1
18441  IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
18442  IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
18443  IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
18444  IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
18445  vpi=paru(119+2*kfaic)
18446  api=paru(120+2*kfaic)
18447  ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
18448  vpi=parj(178+2*kfaic)
18449  api=parj(179+2*kfaic)
18450  ELSE
18451  vpi=parj(186+2*kfaic)
18452  api=parj(187+2*kfaic)
18453  ENDIF
18454 C...Couplings of final flavour.
18455  kfaf=iabs(kfl1(1))
18456  ef=kchg(kfaf,1)/3d0
18457  af=sign(1d0,ef+0.1d0)
18458  vf=af-4d0*ef*xwv
18459  kfafc=1
18460  IF(kfaf.LE.10.AND.mod(kfaf,2).EQ.0) kfafc=2
18461  IF(kfaf.GT.10.AND.mod(kfaf,2).NE.0) kfafc=3
18462  IF(kfaf.GT.10.AND.mod(kfaf,2).EQ.0) kfafc=4
18463  IF(kfaf.LE.2.OR.kfaf.EQ.11.OR.kfaf.EQ.12) THEN
18464  vpf=paru(119+2*kfafc)
18465  apf=paru(120+2*kfafc)
18466  ELSEIF(kfaf.LE.4.OR.kfaf.EQ.13.OR.kfaf.EQ.14) THEN
18467  vpf=parj(178+2*kfafc)
18468  apf=parj(179+2*kfafc)
18469  ELSE
18470  vpf=parj(186+2*kfafc)
18471  apf=parj(187+2*kfafc)
18472  ENDIF
18473 C...Asymmetry and weight.
18474  asym=2d0*(ei*ai*vint(112)*ef*af+ei*api*vint(113)*ef*apf+
18475  & 4d0*vi*ai*vint(114)*vf*af+(vi*api+vpi*ai)*vint(115)*
18476  & (vf*apf+vpf*af)+4d0*vpi*api*vint(116)*vpf*apf)/
18477  & (ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18478  & ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
18479  & (vf**2+af**2)+(vi*vpi+ai*api)*vint(115)*(vf*vpf+af*apf)+
18480  & (vpi**2+api**2)*vint(116)*(vpf**2+apf**2))
18481  wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
18482  wtmax=2d0+abs(asym)
18483  ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).EQ.24) THEN
18484 C...Angular weight for f + fbar -> Z' -> W+ + W-.
18485  rm1=p(nsd(1)+1,5)**2/sh
18486  rm2=p(nsd(1)+2,5)**2/sh
18487  ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
18488  & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
18489  cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
18490  & (rm2-rm1)**2)
18491  wt=cflat+ccos2*cthe(1)**2
18492  wtmax=cflat+max(0d0,ccos2)
18493  ELSEIF(ip.EQ.1.AND.(kfl1(1).EQ.25.OR.kfl1(1).EQ.35.OR.
18494  & iabs(kfl1(1)).EQ.37)) THEN
18495 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18496  wt=1d0-cthe(1)**2
18497  wtmax=1d0
18498  ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
18499 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18500  rm1=p(nsd(1)+1,5)**2/sh
18501  rm2=p(nsd(1)+2,5)**2/sh
18502  flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
18503  wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
18504  wtmax=1d0+flam2/(8d0*rm1)
18505  ELSEIF(mzpwp.EQ.0) THEN
18506 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18507 C...(W:s like if intermediate Z).
18508  d34=p(iref(ip,iord),5)**2
18509  d56=p(iref(ip,3-iord),5)**2
18510  dt=pkk(1,3)+pkk(1,4)+d34
18511  du=pkk(1,5)+pkk(1,6)+d56
18512  fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
18513  fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
18514  wt=(coup(1,3)*fgk135)**2+(coup(1,4)*fgk253)**2
18515  wtmax=4d0*d34*d56*(coup(1,3)**2+coup(1,4)**2)*
18516  & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
18517  ELSEIF(mzpwp.EQ.1) THEN
18518 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18519 C...(W:s approximately longitudinal, like if intermediate H).
18520  wt=16d0*pkk(3,5)*pkk(4,6)
18521  wtmax=sh**2
18522  ELSE
18523 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18524 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18525  wt=1d0
18526  wtmax=1d0
18527  ENDIF
18528 
18529  ELSEIF(isub.EQ.142) THEN
18530 C...Special case: if only branching ratios known then isotropic decay.
18531  IF(mwid(34).EQ.2) THEN
18532  wt=1d0
18533  wtmax=1d0
18534  ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
18535 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18536  kfai=iabs(mint(15))
18537  kfaic=1
18538  IF(kfai.GT.10) kfaic=2
18539  vi=paru(129+2*kfaic)
18540  ai=paru(130+2*kfaic)
18541  kfaf=iabs(kfl1(1))
18542  kfafc=1
18543  IF(kfaf.GT.10) kfafc=2
18544  vf=paru(129+2*kfafc)
18545  af=paru(130+2*kfafc)
18546  asym=8d0*vi*ai*vf*af/((vi**2+ai**2)*(vf**2+af**2))
18547  wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
18548  wtmax=2d0+abs(asym)
18549  ELSEIF(ip.EQ.1.AND.iabs(kfl2(1)).EQ.23) THEN
18550 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18551  rm1=p(nsd(1)+1,5)**2/sh
18552  rm2=p(nsd(1)+2,5)**2/sh
18553  ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
18554  & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
18555  cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
18556  & (rm2-rm1)**2)
18557  wt=cflat+ccos2*cthe(1)**2
18558  wtmax=cflat+max(0d0,ccos2)
18559  ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
18560 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18561  rm1=p(nsd(1)+1,5)**2/sh
18562  rm2=p(nsd(1)+2,5)**2/sh
18563  flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
18564  wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
18565  wtmax=1d0+flam2/(8d0*rm1)
18566  ELSEIF(mzpwp.EQ.0) THEN
18567 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18568 C...(W/Z like if intermediate W).
18569  d34=p(iref(ip,iord),5)**2
18570  d56=p(iref(ip,3-iord),5)**2
18571  dt=pkk(1,3)+pkk(1,4)+d34
18572  du=pkk(1,5)+pkk(1,6)+d56
18573  fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
18574  fgk136=abs(fgk(1,2,3,4,6,5)-fgk(1,2,6,5,3,4))
18575  wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
18576  wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*
18577  & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
18578  ELSEIF(mzpwp.EQ.1) THEN
18579 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18580 C...(W/Z approximately longitudinal, like if intermediate H).
18581  wt=16d0*pkk(3,5)*pkk(4,6)
18582  wtmax=sh**2
18583  ELSE
18584 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18585 C...t + bbar -> t + W + bbar.
18586  wt=1d0
18587  wtmax=1d0
18588  ENDIF
18589 
18590  ELSEIF(isub.EQ.145.OR.isub.EQ.162.OR.isub.EQ.163.OR.isub.EQ.164)
18591  & THEN
18592 C...Isotropic decay of leptoquarks (assumed spin 0).
18593  wt=1d0
18594  wtmax=1d0
18595 
18596  ELSEIF(isub.GE.146.AND.isub.LE.148) THEN
18597 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18598  side=1d0
18599  IF(mint(16).EQ.21.OR.mint(16).EQ.22) side=-1d0
18600  IF(ip.EQ.1.AND.(kfl1(1).EQ.21.OR.kfl1(1).EQ.22)) THEN
18601  wt=1d0+side*cthe(1)
18602  wtmax=2d0
18603  ELSEIF(ip.EQ.1) THEN
18604 
18605  rm1=p(nsd(1)+1,5)**2/sh
18606  wt=1d0+side*cthe(1)*(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
18607  wtmax=1d0+(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
18608  ELSE
18609 C...W/Z decay assumed isotropic, since not known.
18610  wt=1d0
18611  wtmax=1d0
18612  ENDIF
18613 
18614  ELSEIF(isub.EQ.149) THEN
18615 C...Isotropic decay of techni-eta.
18616  wt=1d0
18617  wtmax=1d0
18618 
18619  ELSEIF(isub.EQ.191) THEN
18620  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
18621 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18622 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18623  wt=1d0-cthe(1)**2
18624  wtmax=1d0
18625  ELSEIF(ip.EQ.1) THEN
18626 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18627  cthesg=cthe(1)*isign(1,mint(15))
18628  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
18629  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
18630  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
18631  kfai=iabs(mint(15))
18632  ei=kchg(kfai,1)/3d0
18633  ai=sign(1d0,ei+0.1d0)
18634  vi=ai-4d0*ei*xwv
18635  vali=0.5d0*(vi+ai)
18636  vari=0.5d0*(vi-ai)
18637  alefti=(ei+vali*bwzr)**2+(vali*bwzi)**2
18638  arighi=(ei+vari*bwzr)**2+(vari*bwzi)**2
18639  kfaf=iabs(kfl1(1))
18640  ef=kchg(kfaf,1)/3d0
18641  af=sign(1d0,ef+0.1d0)
18642  vf=af-4d0*ef*xwv
18643  valf=0.5d0*(vf+af)
18644  varf=0.5d0*(vf-af)
18645  aleftf=(ef+valf*bwzr)**2+(valf*bwzi)**2
18646  arighf=(ef+varf*bwzr)**2+(varf*bwzi)**2
18647  asame=alefti*aleftf+arighi*arighf
18648  aflip=alefti*arighf+arighi*aleftf
18649  wt=asame*(1d0+cthesg)**2+aflip*(1d0-cthesg)**2
18650  wtmax=4d0*max(asame,aflip)
18651  ELSE
18652 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18653  wt=1d0
18654  wtmax=1d0
18655  ENDIF
18656 
18657  ELSEIF(isub.EQ.192) THEN
18658  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
18659 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18660 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18661  wt=1d0-cthe(1)**2
18662  wtmax=1d0
18663  ELSEIF(ip.EQ.1) THEN
18664 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18665  cthesg=cthe(1)*isign(1,mint(15))
18666  wt=(1d0+cthesg)**2
18667  wtmax=4d0
18668  ELSE
18669 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18670  wt=1d0
18671  wtmax=1d0
18672  ENDIF
18673 
18674  ELSEIF(isub.EQ.193) THEN
18675  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
18676 C...Angular weight for f + fbar -> omega_tc0 ->
18677 C...gamma pi_tc0 or Z0 pi_tc0.
18678  wt=1d0+cthe(1)**2
18679  wtmax=2d0
18680  ELSEIF(ip.EQ.1) THEN
18681 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18682  cthesg=cthe(1)*isign(1,mint(15))
18683  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
18684  bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
18685  kfai=iabs(mint(15))
18686  ei=kchg(kfai,1)/3d0
18687  ai=sign(1d0,ei+0.1d0)
18688  vi=ai-4d0*ei*xwv
18689  vali=0.5d0*(vi+ai)
18690  vari=0.5d0*(vi-ai)
18691  blefti=(ei-vali*bwzr)**2+(vali*bwzi)**2
18692  brighi=(ei-vari*bwzr)**2+(vari*bwzi)**2
18693  kfaf=iabs(kfl1(1))
18694  ef=kchg(kfaf,1)/3d0
18695  af=sign(1d0,ef+0.1d0)
18696  vf=af-4d0*ef*xwv
18697  valf=0.5d0*(vf+af)
18698  varf=0.5d0*(vf-af)
18699  bleftf=(ef-valf*bwzr)**2+(valf*bwzi)**2
18700  brighf=(ef-varf*bwzr)**2+(varf*bwzi)**2
18701  bsame=blefti*bleftf+brighi*brighf
18702  bflip=blefti*brighf+brighi*bleftf
18703  wt=bsame*(1d0+cthesg)**2+bflip*(1d0-cthesg)**2
18704  wtmax=4d0*max(bsame,bflip)
18705  ELSE
18706 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18707  wt=1d0
18708  wtmax=1d0
18709  ENDIF
18710 
18711  ELSEIF(isub.EQ.353) THEN
18712 C...Angular weight for Z_R0 -> 2 quarks/leptons.
18713  ei=kchg(iabs(mint(15)),1)/3d0
18714  ai=sign(1d0,ei+0.1d0)
18715  vi=ai-4d0*ei*xwv
18716  ef=kchg(pycomp(kfl1(1)),1)/3d0
18717  af=sign(1d0,ef+0.1d0)
18718  vf=af-4d0*ef*xwv
18719  rmf=min(1d0,4d0*pmas(pycomp(kfl1(1)),1)**2/sh)
18720  wt1=(vi**2+ai**2)*(vf**2+(1d0-rmf)*af**2)
18721  wt2=rmf*(vi**2+ai**2)*vf**2
18722  wt3=sqrt(1d0-rmf)*4d0*vi*ai*vf*af
18723  wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
18724  & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
18725  wtmax=2d0*(wt1+abs(wt3))
18726 
18727  ELSEIF(isub.EQ.354) THEN
18728 C...Angular weight for W_R+/- -> 2 quarks/leptons.
18729  rm3=pmas(pycomp(kfl1(1)),1)**2/sh
18730  rm4=pmas(pycomp(kfl2(1)),1)**2/sh
18731  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18732  wt=(1d0+be34*cthe(1)*isign(1,mint(15)*kfl1(1)))**2-(rm3-rm4)**2
18733  wtmax=4d0
18734 
18735  ELSEIF(isub.EQ.391) THEN
18736 C...Angular weight for f + fbar -> G* -> f + fbar
18737  IF(ip.EQ.1.AND.iabs(kfl1(1)).LE.18) THEN
18738  wt=1d0-3d0*cthe(1)**2+4d0*cthe(1)**4
18739  wtmax=2d0
18740 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18741 C...implemented by M.-C. Lemaire
18742  ELSEIF(ip.EQ.1.AND.(iabs(kfl1(1)).EQ.21.OR.
18743  & iabs(kfl1(1)).EQ.22)) THEN
18744  wt=1d0-cthe(1)**4
18745  wtmax=1d0
18746 C...Other G* decays not yet implemented angular distributions.
18747  ELSE
18748  wt=1d0
18749  wtmax=1d0
18750  ENDIF
18751 
18752  ELSEIF(isub.EQ.392) THEN
18753 C...Angular weight for g + g -> G* -> f + fbar
18754  IF(ip.EQ.1.AND.iabs(kfl1(1)).LE.18) THEN
18755  wt=1d0-cthe(1)**4
18756  wtmax=1d0
18757 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18758 C...implemented by M.-C. Lemaire
18759  ELSEIF(ip.EQ.1.AND.(iabs(kfl1(1)).EQ.21.OR.
18760  & iabs(kfl1(1)).EQ.22)) THEN
18761  wt=1d0+6d0*cthe(1)**2+cthe(1)**4
18762  wtmax=8d0
18763 C...Other G* decays not yet implemented angular distributions.
18764  ELSE
18765  wt=1d0
18766  wtmax=1d0
18767  ENDIF
18768 
18769 C...Obtain correct angular distribution by rejection techniques.
18770  ELSE
18771  wt=1d0
18772  wtmax=1d0
18773  ENDIF
18774  IF(wt.LT.pyr(0)*wtmax) GOTO 430
18775 
18776 C...Construct massive four-vectors using angles chosen.
18777  590 DO 690 jt=1,jtmax
18778  IF(kdcy(jt).EQ.0) GOTO 690
18779  id=iref(ip,jt)
18780  DO 600 j=1,5
18781  dpmo(j)=p(id,j)
18782  600 CONTINUE
18783  dpmo(4)=sqrt(dpmo(1)**2+dpmo(2)**2+dpmo(3)**2+dpmo(5)**2)
18784 CMRENNA++
18785  IF(kfl3(jt).EQ.0) THEN
18786  CALL pyrobo(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),
18787  & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
18788  n0=nsd(jt)+2
18789  ELSE
18790  CALL pyrobo(nsd(jt)+1,nsd(jt)+3,acos(cthe(jt)),phi(jt),
18791  & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
18792  n0=nsd(jt)+3
18793  ENDIF
18794 
18795  DO 610 j=1,4
18796  vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
18797  610 CONTINUE
18798 C...Fill in position of decay vertex.
18799  DO 630 i=nsd(jt)+1,n0
18800  DO 620 j=1,4
18801  v(i,j)=vdcy(j)
18802  620 CONTINUE
18803  v(i,5)=0d0
18804 
18805  630 CONTINUE
18806 CMRENNA--
18807 
18808 C...Mark decayed resonances; trace history.
18809  k(id,1)=k(id,1)+10
18810  kfa=iabs(k(id,2))
18811  kca=pycomp(kfa)
18812  IF(kcqm(jt).NE.0) THEN
18813 C...Do not kill colour flow through coloured resonance!
18814  ELSE
18815  k(id,4)=nsd(jt)+1
18816  k(id,5)=nsd(jt)+2
18817 C...If 3-body or 2-body with junction:
18818  IF(kfl3(jt).NE.0.OR.itjunc(jt).NE.0) k(id,5)=nsd(jt)+3
18819 C...If 3-body with junction:
18820  IF(itjunc(jt).NE.0.AND.kfl3(jt).NE.0) k(id,5)=nsd(jt)+4
18821  ENDIF
18822 
18823 C...Add documentation lines.
18824  isubrg=max(1,min(500,mint(1)))
18825  IF(ires.EQ.0.OR.iset(isubrg).EQ.11) THEN
18826  idoc=mint(83)+mint(4)
18827 CMRENNA+++
18828  ihi=nsd(jt)+2
18829  IF(kfl3(jt).NE.0) ihi=ihi+1
18830  DO 650 i=nsd(jt)+1,ihi
18831 CMRENNA---
18832  i1=mint(83)+mint(4)+1
18833  k(i,3)=i1
18834  IF(mstp(128).GE.1) k(i,3)=id
18835  IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
18836  mint(4)=mint(4)+1
18837  k(i1,1)=21
18838  k(i1,2)=k(i,2)
18839  k(i1,3)=iref(ip,jt+3)
18840  DO 640 j=1,5
18841  p(i1,j)=p(i,j)
18842  640 CONTINUE
18843  ENDIF
18844  650 CONTINUE
18845  ELSE
18846  k(nsd(jt)+1,3)=id
18847  k(nsd(jt)+2,3)=id
18848 C...If 3-body or 2-body with junction:
18849  IF(kfl3(jt).NE.0.OR.itjunc(jt).GT.0) k(nsd(jt)+3,3)=id
18850 C...If 3-body with junction:
18851  IF(kfl3(jt).NE.0.AND.itjunc(jt).GT.0) k(nsd(jt)+4,3)=id
18852  ENDIF
18853 
18854 C...Do showering of two or three objects.
18855  nshbef=n
18856  IF(mstp(71).GE.1.AND.mint(35).LE.1) THEN
18857  IF(kfl3(jt).EQ.0) THEN
18858  CALL pyshow(nsd(jt)+1,nsd(jt)+2,p(id,5))
18859  ELSE
18860  CALL pyshow(nsd(jt)+1,-3,p(id,5))
18861  ENDIF
18862 
18863 c...For pT-ordered shower need set up first, especially colour tags.
18864 C...(Need to set up colour tags even if MSTP(71) = 0)
18865  ELSEIF(mint(35).GE.2) THEN
18866  npart=2
18867  IF(kfl3(jt).NE.0) npart=3
18868  ipart(1)=nsd(jt)+1
18869  ipart(2)=nsd(jt)+2
18870  ipart(3)=nsd(jt)+3
18871  ptpart(1)=0.5d0*p(id,5)
18872  ptpart(2)=ptpart(1)
18873  ptpart(3)=ptpart(1)
18874  IF(kcq1(jt).EQ.1.OR.kcq1(jt).EQ.2) THEN
18875  mother=k(nsd(jt)+1,4)/mstu(5)
18876  IF(mother.LE.nsd(jt)) THEN
18877  mct(nsd(jt)+1,1)=mct(mother,1)
18878  ELSE
18879  nct=nct+1
18880  mct(nsd(jt)+1,1)=nct
18881  mct(mother,2)=nct
18882  ENDIF
18883  ENDIF
18884  IF(kcq1(jt).EQ.-1.OR.kcq1(jt).EQ.2) THEN
18885  mother=k(nsd(jt)+1,5)/mstu(5)
18886  IF(mother.LE.nsd(jt)) THEN
18887  mct(nsd(jt)+1,2)=mct(mother,2)
18888  ELSE
18889  nct=nct+1
18890  mct(nsd(jt)+1,2)=nct
18891  mct(mother,1)=nct
18892  ENDIF
18893  ENDIF
18894  IF(mct(nsd(jt)+2,1).EQ.0.AND.(kcq2(jt).EQ.1.OR.
18895  & kcq2(jt).EQ.2)) THEN
18896  mother=k(nsd(jt)+2,4)/mstu(5)
18897  IF(mother.LE.nsd(jt)) THEN
18898  mct(nsd(jt)+2,1)=mct(mother,1)
18899  ELSE
18900  nct=nct+1
18901  mct(nsd(jt)+2,1)=nct
18902  mct(mother,2)=nct
18903  ENDIF
18904  ENDIF
18905  IF(mct(nsd(jt)+2,2).EQ.0.AND.(kcq2(jt).EQ.-1.OR.
18906  & kcq2(jt).EQ.2)) THEN
18907  mother=k(nsd(jt)+2,5)/mstu(5)
18908  IF(mother.LE.nsd(jt)) THEN
18909  mct(nsd(jt)+2,2)=mct(mother,2)
18910  ELSE
18911  nct=nct+1
18912  mct(nsd(jt)+2,2)=nct
18913  mct(mother,1)=nct
18914  ENDIF
18915  ENDIF
18916  IF(npart.EQ.3.AND.mct(nsd(jt)+3,1).EQ.0.AND.
18917  & (kcq3(jt).EQ.1.OR. kcq3(jt).EQ.2)) THEN
18918  mother=k(nsd(jt)+3,4)/mstu(5)
18919  mct(nsd(jt)+3,1)=mct(mother,1)
18920  ENDIF
18921  IF(npart.EQ.3.AND.mct(nsd(jt)+3,2).EQ.0.AND.
18922  & (kcq3(jt).EQ.-1.OR.kcq3(jt).EQ.2)) THEN
18923  mother=k(nsd(jt)+3,5)/mstu(5)
18924  mct(nsd(jt)+2,2)=mct(mother,2)
18925  ENDIF
18926  IF (mstp(71).GE.1) CALL pyptfs(2,0.5d0*p(id,5),0d0,ptgen)
18927  ENDIF
18928  nshaft=n
18929  IF(jt.EQ.1) naft1=n
18930 
18931 C...Check if decay products moved by shower.
18932  nsd1=nsd(jt)+1
18933  nsd2=nsd(jt)+2
18934  nsd3=nsd(jt)+3
18935  IF(nshaft.GT.nshbef) THEN
18936  IF(k(nsd1,1).GT.10) THEN
18937  DO 660 i=nshbef+1,nshaft
18938  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd1,2)) nsd1=i
18939  660 CONTINUE
18940  ENDIF
18941  IF(k(nsd2,1).GT.10) THEN
18942  DO 670 i=nshbef+1,nshaft
18943  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd2,2).AND.
18944  & i.NE.nsd1) nsd2=i
18945  670 CONTINUE
18946  ENDIF
18947  IF(kfl3(jt).NE.0.AND.k(nsd3,1).GT.10) THEN
18948  DO 680 i=nshbef+1,nshaft
18949  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd3,2).AND.
18950  & i.NE.nsd1.AND.i.NE.nsd2) nsd3=i
18951  680 CONTINUE
18952  ENDIF
18953  ENDIF
18954 
18955 C...Store decay products for further treatment.
18956  np=np+1
18957  iref(np,1)=nsd1
18958  iref(np,2)=nsd2
18959  iref(np,3)=0
18960  IF(kfl3(jt).NE.0) iref(np,3)=nsd3
18961  iref(np,4)=idoc+1
18962  iref(np,5)=idoc+2
18963  iref(np,6)=0
18964  IF(kfl3(jt).NE.0) iref(np,6)=idoc+3
18965  iref(np,7)=k(iref(ip,jt),2)
18966  iref(np,8)=iref(ip,jt)
18967  690 CONTINUE
18968 
18969 
18970 C...Fill information for 2 -> 1 -> 2.
18971  700 IF(jtmax.EQ.1.AND.kdcy(1).NE.0.AND.isub.NE.0) THEN
18972  mint(7)=mint(83)+6+2*iset(isub)
18973  mint(8)=mint(83)+7+2*iset(isub)
18974  mint(25)=kfl1(1)
18975  mint(26)=kfl2(1)
18976  vint(23)=cthe(1)
18977  rm3=p(n-1,5)**2/sh
18978  rm4=p(n,5)**2/sh
18979  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18980  vint(45)=-0.5d0*sh*(1d0-rm3-rm4-be34*cthe(1))
18981  vint(46)=-0.5d0*sh*(1d0-rm3-rm4+be34*cthe(1))
18982  vint(48)=0.25d0*sh*be34**2*max(0d0,1d0-cthe(1)**2)
18983  vint(47)=sqrt(vint(48))
18984  ENDIF
18985 
18986 C...Possibility of colour rearrangement in W+W- events.
18987  IF((isub.EQ.25.OR.isub.EQ.22).AND.mstp(115).GE.1) THEN
18988  iakf1=iabs(kfl1(1))
18989  iakf2=iabs(kfl1(2))
18990  iakf3=iabs(kfl2(1))
18991  iakf4=iabs(kfl2(2))
18992  IF(min(iakf1,iakf2,iakf3,iakf4).GE.1.AND.
18993  & max(iakf1,iakf2,iakf3,iakf4).LE.5) call
18994  & pyreco(iref(1,1),iref(1,2),nsd(1),naft1)
18995  IF(mint(51).NE.0) RETURN
18996  ENDIF
18997 
18998 C...Loop back if needed.
18999  710 IF(ip.LT.np) GOTO 170
19000 
19001 C...Boost back to standard frame.
19002  720 IF(ibst.EQ.1) CALL pyrobo(mint(83)+7,n,thein,phiin,bexin,beyin,
19003  &bezin)
19004 
19005  RETURN
19006  END
19007 
19008 C*********************************************************************
19009 
19010 C...PYMULT
19011 C...Initializes treatment of multiple interactions, selects kinematics
19012 C...of hardest interaction if low-pT physics included in run, and
19013 C...generates all non-hardest interactions.
19014 
19015  SUBROUTINE pymult(MMUL)
19016 
19017 C...Double precision and integer declarations.
19018  IMPLICIT DOUBLE PRECISION(a-h, o-z)
19019  IMPLICIT INTEGER(I-N)
19020  INTEGER PYK,PYCHGE,PYCOMP
19021 C...Commonblocks.
19022  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
19023  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
19024  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
19025  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
19026  common/pypars/mstp(200),parp(200),msti(200),pari(200)
19027  common/pyint1/mint(400),vint(400)
19028  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
19029  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
19030  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
19031  common/pyint7/sigt(0:6,0:6,0:5)
19032  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
19033  &/pyint2/,/pyint3/,/pyint5/,/pyint7/
19034 C...Local arrays and saved variables.
19035  dimension nmul(20),sigm(20),kstr(500,2),vintsv(80)
19036  SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm,p83a,p83b,p83c,
19037  &cq2i,cq2r,pik,bdiv,b,plowb,phighb,pallb,s4a,s4b,s4c,powip,
19038  &rpwip,b2rpdv,b2rpmx,bavg,vnt145,vnt146,vnt147
19039 
19040 C...Initialization of multiple interaction treatment.
19041  IF(mmul.EQ.1) THEN
19042  IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
19043  isub=96
19044  mint(1)=96
19045  vint(63)=0d0
19046  vint(64)=0d0
19047  vint(143)=1d0
19048  vint(144)=1d0
19049 
19050 C...Loop over phase space points: xT2 choice in 20 bins.
19051  100 sigsum=0d0
19052  DO 120 ixt2=1,20
19053  nmul(ixt2)=mstp(83)
19054  sigm(ixt2)=0d0
19055  DO 110 itry=1,mstp(83)
19056  rsca=0.05d0*((21-ixt2)-pyr(0))
19057  xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
19058  xt2=max(0.01d0*vint(149),xt2)
19059  vint(25)=xt2
19060 
19061 C...Choose tau and y*. Calculate cos(theta-hat).
19062  IF(pyr(0).LE.coef(isub,1)) THEN
19063  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19064  tau=xt2*(1d0+taut)**2/(4d0*taut)
19065  ELSE
19066  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19067  ENDIF
19068  vint(21)=tau
19069  CALL pyklim(2)
19070  ryst=pyr(0)
19071  myst=1
19072  IF(ryst.GT.coef(isub,8)) myst=2
19073  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19074  CALL pykmap(2,myst,pyr(0))
19075  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19076 
19077 C...Calculate differential cross-section.
19078  vint(71)=0.5d0*vint(1)*sqrt(xt2)
19079  CALL pysigh(nchn,sigs)
19080  sigm(ixt2)=sigm(ixt2)+sigs
19081  110 CONTINUE
19082  sigsum=sigsum+sigm(ixt2)
19083  120 CONTINUE
19084  sigsum=sigsum/(20d0*mstp(83))
19085 
19086 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19087  IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
19088  IF(mstp(122).GE.1) WRITE(mstu(11),5100)
19089  & parp(82)*(vint(1)/parp(89))**parp(90),sigsum
19090  parp(82)=0.9d0*parp(82)
19091  vint(149)=4d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
19092  & vint(2)
19093  GOTO 100
19094  ENDIF
19095  IF(mstp(122).GE.1) WRITE(mstu(11),5200)
19096  & parp(82)*(vint(1)/parp(89))**parp(90), sigsum
19097 
19098 C...Start iteration to find k factor.
19099  yke=sigsum/max(1d-10,sigt(0,0,5))
19100  p83a=(1d0-parp(83))**2
19101  p83b=2d0*parp(83)*(1d0-parp(83))
19102  p83c=parp(83)**2
19103  cq2i=1d0/parp(84)**2
19104  cq2r=2d0/(1d0+parp(84)**2)
19105  so=0.5d0
19106  xi=0d0
19107  yi=0d0
19108  xf=0d0
19109  yf=0d0
19110  xk=0.5d0
19111  iit=0
19112  130 IF(iit.EQ.0) THEN
19113  xk=2d0*xk
19114  ELSEIF(iit.EQ.1) THEN
19115  xk=0.5d0*xk
19116  ELSE
19117  xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
19118  ENDIF
19119 
19120 C...Evaluate overlap integrals. Find where to divide the b range.
19121  IF(mstp(82).EQ.2) THEN
19122  sp=0.5d0*paru(1)*(1d0-exp(-xk))
19123  sop=sp/paru(1)
19124  ELSE
19125  IF(mstp(82).EQ.3) THEN
19126  deltab=0.02d0
19127  ELSEIF(mstp(82).EQ.4) THEN
19128  deltab=min(0.01d0,0.05d0*parp(84))
19129  ELSE
19130  powip=max(0.4d0,parp(83))
19131  rpwip=2d0/powip-1d0
19132  deltab=max(0.02d0,0.02d0*(2d0/powip)**(1d0/powip))
19133  so=0d0
19134  ENDIF
19135  sp=0d0
19136  sop=0d0
19137  bsp=0d0
19138  sohigh=0d0
19139  ibdiv=0
19140  b=-0.5d0*deltab
19141  140 b=b+deltab
19142  IF(mstp(82).EQ.3) THEN
19143  ov=exp(-b**2)/paru(2)
19144  ELSEIF(mstp(82).EQ.4) THEN
19145  ov=(p83a*exp(-min(50d0,b**2))+
19146  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19147  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19148  ELSE
19149  ov=exp(-b**powip)/paru(2)
19150  so=so+paru(2)*b*deltab*ov
19151  ENDIF
19152  IF(ibdiv.EQ.1) sohigh=sohigh+paru(2)*b*deltab*ov
19153  pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
19154  sp=sp+paru(2)*b*deltab*pacc
19155  sop=sop+paru(2)*b*deltab*ov*pacc
19156  bsp=bsp+b*paru(2)*b*deltab*pacc
19157  IF(ibdiv.EQ.0.AND.paru(1)*xk*ov.LT.1d0) THEN
19158  ibdiv=1
19159  bdiv=b+0.5d0*deltab
19160  ENDIF
19161  IF(b.LT.1d0.OR.b*pacc.GT.1d-6) GOTO 140
19162  ENDIF
19163  yk=paru(1)*xk*so/sp
19164 
19165 C...Continue iteration until convergence.
19166  IF(yk.LT.yke) THEN
19167  xi=xk
19168  yi=yk
19169  IF(iit.EQ.1) iit=2
19170  ELSE
19171  xf=xk
19172  yf=yk
19173  IF(iit.EQ.0) iit=1
19174  ENDIF
19175  IF(abs(yk-yke).GE.1d-5*yke) GOTO 130
19176 
19177 C...Store some results for subsequent use.
19178  bavg=bsp/sp
19179  vint(145)=sigsum
19180  vint(146)=sop/so
19181  vint(147)=sop/sp
19182  vnt145=vint(145)
19183  vnt146=vint(146)
19184  vnt147=vint(147)
19185 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19186  pik=(vnt146/vnt147)*yke
19187 
19188 C...Find relative weight for low and high impact parameter.
19189  plowb=paru(1)*bdiv**2
19190  IF(mstp(82).EQ.3) THEN
19191  phighb=pik*0.5*exp(-bdiv**2)
19192  ELSEIF(mstp(82).EQ.4) THEN
19193  s4a=p83a*exp(-bdiv**2)
19194  s4b=p83b*exp(-bdiv**2*cq2r)
19195  s4c=p83c*exp(-bdiv**2*cq2i)
19196  phighb=pik*0.5*(s4a+s4b+s4c)
19197  ELSEIF(parp(83).GE.1.999d0) THEN
19198  phighb=pik*sohigh
19199  b2rpdv=bdiv**powip
19200  ELSE
19201  phighb=pik*sohigh
19202  b2rpdv=bdiv**powip
19203  b2rpmx=max(2d0*rpwip,b2rpdv)
19204  ENDIF
19205  pallb=plowb+phighb
19206 
19207 C...Initialize iteration in xT2 for hardest interaction.
19208  ELSEIF(mmul.EQ.2) THEN
19209  vint(145)=vnt145
19210  vint(146)=vnt146
19211  vint(147)=vnt147
19212  IF(mstp(82).LE.0) THEN
19213  ELSEIF(mstp(82).EQ.1) THEN
19214  xt2=1d0
19215  sigrat=xsec(96,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
19216  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
19217  & vint(317)/(vint(318)*vint(320))
19218  xt2fac=sigrat*vint(149)/(1d0-vint(149))
19219  ELSEIF(mstp(82).EQ.2) THEN
19220  xt2=1d0
19221  xt2fac=vnt146*xsec(96,1)/max(1d-10,sigt(0,0,5))*
19222  & vint(149)*(1d0+vint(149))
19223  ELSE
19224  xc2=4d0*ckin(3)**2/vint(2)
19225  IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
19226  ENDIF
19227 
19228 C...Select impact parameter for hardest interaction.
19229  IF(mstp(82).LE.2) RETURN
19230  142 IF(pyr(0)*pallb.LT.plowb) THEN
19231 C...Treatment in low b region.
19232  mint(39)=1
19233  b=bdiv*sqrt(pyr(0))
19234  IF(mstp(82).EQ.3) THEN
19235  ov=exp(-b**2)/paru(2)
19236  ELSEIF(mstp(82).EQ.4) THEN
19237  ov=(p83a*exp(-min(50d0,b**2))+
19238  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19239  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19240  ELSE
19241  ov=exp(-b**powip)/paru(2)
19242  ENDIF
19243  vint(148)=ov/vnt147
19244  pacc=1d0-exp(-min(50d0,pik*ov))
19245  xt2=1d0
19246  xt2fac=vnt146*vint(148)*xsec(96,1)/max(1d-10,sigt(0,0,5))*
19247  & vint(149)*(1d0+vint(149))
19248  ELSE
19249 C...Treatment in high b region.
19250  mint(39)=2
19251  IF(mstp(82).EQ.3) THEN
19252  b=sqrt(bdiv**2-log(pyr(0)))
19253  ov=exp(-b**2)/paru(2)
19254  ELSEIF(mstp(82).EQ.4) THEN
19255  s4rndm=pyr(0)*(s4a+s4b+s4c)
19256  IF(s4rndm.LT.s4a) THEN
19257  b=sqrt(bdiv**2-log(pyr(0)))
19258  ELSEIF(s4rndm.LT.s4a+s4b) THEN
19259  b=sqrt(bdiv**2-log(pyr(0))/cq2r)
19260  ELSE
19261  b=sqrt(bdiv**2-log(pyr(0))/cq2i)
19262  ENDIF
19263  ov=(p83a*exp(-min(50d0,b**2))+
19264  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19265  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19266  ELSEIF(parp(83).GE.1.999d0) THEN
19267  144 b2rpw=b2rpdv-log(pyr(0))
19268  accip=(b2rpw/b2rpdv)**rpwip
19269  IF(accip.LT.pyr(0)) GOTO 144
19270  ov=exp(-b2rpw)/paru(2)
19271  b=b2rpw**(1d0/powip)
19272  ELSE
19273  146 b2rpw=b2rpdv-2d0*log(pyr(0))
19274  accip=(b2rpw/b2rpmx)**rpwip*exp(-0.5d0*(b2rpw-b2rpmx))
19275  IF(accip.LT.pyr(0)) GOTO 146
19276  ov=exp(-b2rpw)/paru(2)
19277  b=b2rpw**(1d0/powip)
19278  ENDIF
19279  vint(148)=ov/vnt147
19280  pacc=(1d0-exp(-min(50d0,pik*ov)))/(pik*ov)
19281  ENDIF
19282  IF(pacc.LT.pyr(0)) GOTO 142
19283  vint(139)=b/bavg
19284 
19285  ELSEIF(mmul.EQ.3) THEN
19286 C...Low-pT or multiple interactions (first semihard interaction):
19287 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19288 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19289  isub=mint(1)
19290  vint(145)=vnt145
19291  vint(146)=vnt146
19292  vint(147)=vnt147
19293  IF(mstp(82).LE.0) THEN
19294  xt2=0d0
19295  ELSEIF(mstp(82).EQ.1) THEN
19296  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
19297 C...Use with "Sudakov" for low b values when impact parameter dependence.
19298  ELSEIF(mstp(82).EQ.2.OR.mint(39).EQ.1) THEN
19299  IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
19300  & vint(149)))).GT.pyr(0)) xt2=1d0
19301  IF(xt2.GE.1d0) THEN
19302  xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
19303  & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
19304  & vint(149)
19305  ELSE
19306  xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
19307  & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
19308  & vint(149)
19309  ENDIF
19310  xt2=max(0.01d0*vint(149),xt2)
19311 C...Use without "Sudakov" for high b values when impact parameter dep.
19312  ELSE
19313  xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
19314  & pyr(0)*(1d0-xc2))-vint(149)
19315  xt2=max(0.01d0*vint(149),xt2)
19316  ENDIF
19317  vint(25)=xt2
19318 
19319 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19320  IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
19321  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-mint(143)
19322  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-mint(143)
19323  isub=95
19324  mint(1)=isub
19325  vint(21)=0.01d0*vint(149)
19326  vint(22)=0d0
19327  vint(23)=0d0
19328  vint(25)=0.01d0*vint(149)
19329 
19330  ELSE
19331 C...Multiple interactions (first semihard interaction).
19332 C...Choose tau and y*. Calculate cos(theta-hat).
19333  IF(pyr(0).LE.coef(isub,1)) THEN
19334  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19335  tau=xt2*(1d0+taut)**2/(4d0*taut)
19336  ELSE
19337  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19338  ENDIF
19339  vint(21)=tau
19340  CALL pyklim(2)
19341  ryst=pyr(0)
19342  myst=1
19343  IF(ryst.GT.coef(isub,8)) myst=2
19344  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19345  CALL pykmap(2,myst,pyr(0))
19346  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19347  ENDIF
19348  vint(71)=0.5d0*vint(1)*sqrt(vint(25))
19349 
19350 C...Store results of cross-section calculation.
19351  ELSEIF(mmul.EQ.4) THEN
19352  isub=mint(1)
19353  vint(145)=vnt145
19354  vint(146)=vnt146
19355  vint(147)=vnt147
19356  xts=vint(25)
19357  IF(iset(isub).EQ.1) xts=vint(21)
19358  IF(iset(isub).EQ.2)
19359  & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
19360  IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
19361  rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
19362  & (xts+vint(149))))
19363  irbin=int(1d0+20d0*rbin)
19364  IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
19365  nmul(irbin)=nmul(irbin)+1
19366  sigm(irbin)=sigm(irbin)+vint(153)
19367  ENDIF
19368 
19369 C...Choose impact parameter if not already done.
19370  ELSEIF(mmul.EQ.5) THEN
19371  isub=mint(1)
19372  vint(145)=vnt145
19373  vint(146)=vnt146
19374  vint(147)=vnt147
19375  150 IF(mint(39).GT.0) THEN
19376  ELSEIF(mstp(82).EQ.3) THEN
19377  expb2=pyr(0)
19378  b2=-log(pyr(0))
19379  vint(148)=expb2/(paru(2)*vnt147)
19380  vint(139)=sqrt(b2)/bavg
19381  ELSEIF(mstp(82).EQ.4) THEN
19382  rtype=pyr(0)
19383  IF(rtype.LT.p83a) THEN
19384  b2=-log(pyr(0))
19385  ELSEIF(rtype.LT.p83a+p83b) THEN
19386  b2=-log(pyr(0))/cq2r
19387  ELSE
19388  b2=-log(pyr(0))/cq2i
19389  ENDIF
19390  vint(148)=(p83a*exp(-min(50d0,b2))+
19391  & p83b*cq2r*exp(-min(50d0,b2*cq2r))+
19392  & p83c*cq2i*exp(-min(50d0,b2*cq2i)))/(paru(2)*vnt147)
19393  vint(139)=sqrt(b2)/bavg
19394  ELSEIF(parp(83).GE.1.999d0) THEN
19395  powip=max(2d0,parp(83))
19396  rpwip=2d0/powip-1d0
19397  prob1=powip/(2d0*exp(-1d0)+powip)
19398  160 IF(pyr(0).LT.prob1) THEN
19399  b2rpw=pyr(0)**(0.5d0*powip)
19400  accip=exp(-b2rpw)
19401  ELSE
19402  b2rpw=1d0-log(pyr(0))
19403  accip=b2rpw**rpwip
19404  ENDIF
19405  IF(accip.LT.pyr(0)) GOTO 160
19406  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
19407  vint(139)=b2rpw**(1d0/powip)/bavg
19408  ELSE
19409  powip=max(0.4d0,parp(83))
19410  rpwip=2d0/powip-1d0
19411  prob1=rpwip/(rpwip+2d0**rpwip*exp(-rpwip))
19412  170 IF(pyr(0).LT.prob1) THEN
19413  b2rpw=2d0*rpwip*pyr(0)
19414  accip=(b2rpw/rpwip)**rpwip*exp(rpwip-b2rpw)
19415  ELSE
19416  b2rpw=2d0*(rpwip-log(pyr(0)))
19417  accip=(0.5d0*b2rpw/rpwip)**rpwip*exp(rpwip-0.5d0*b2rpw)
19418  ENDIF
19419  IF(accip.lt .pyr(0)) GOTO 170
19420  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
19421  vint(139)=b2rpw**(1d0/powip)/bavg
19422  ENDIF
19423 
19424 C...Multiple interactions (variable impact parameter) : reject with
19425 C...probability exp(-overlap*cross-section above pT/normalization).
19426 C...Does not apply to low-b region, where "Sudakov" already included.
19427  vint(150)=1d0
19428  IF(mint(39).NE.1) THEN
19429  rncor=(irbin-20d0*rbin)*nmul(irbin)
19430  sigcor=(irbin-20d0*rbin)*sigm(irbin)
19431  DO 180 ibin=irbin+1,20
19432  rncor=rncor+nmul(ibin)
19433  sigcor=sigcor+sigm(ibin)
19434  180 CONTINUE
19435  sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
19436  IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
19437  vint(150)=exp(-min(50d0,vnt146*vint(148)*
19438  & sigabv/max(1d-10,sigt(0,0,5))))
19439  ENDIF
19440  IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isub.NE.11.AND.
19441  & isub.NE.12.AND.isub.NE.13.AND.isub.NE.28.AND.isub.NE.53
19442  & .AND.isub.NE.68.AND.isub.NE.95.AND.isub.NE.96)) THEN
19443  IF(vint(150).LT.pyr(0)) GOTO 150
19444  vint(150)=1d0
19445  ENDIF
19446 
19447 C...Generate additional multiple semihard interactions.
19448  ELSEIF(mmul.EQ.6) THEN
19449  isubsv=mint(1)
19450  vint(145)=vnt145
19451  vint(146)=vnt146
19452  vint(147)=vnt147
19453  DO 190 j=11,80
19454  vintsv(j)=vint(j)
19455  190 CONTINUE
19456  isub=96
19457  mint(1)=96
19458  vint(151)=0d0
19459  vint(152)=0d0
19460 
19461 C...Reconstruct strings in hard scattering.
19462  nmax=mint(84)+4
19463  IF(iset(isubsv).EQ.1) nmax=mint(84)+2
19464  IF(iset(isubsv).EQ.11) nmax=mint(84)+2+mint(3)
19465  nstr=0
19466  DO 210 i=mint(84)+1,nmax
19467  kcs=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
19468  IF(kcs.EQ.0) GOTO 210
19469  DO 200 j=1,4
19470  IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) GOTO 200
19471  IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) GOTO 200
19472  IF(j.LE.2) THEN
19473  ist=mod(k(i,j+3)/mstu(5),mstu(5))
19474  ELSE
19475  ist=mod(k(i,j+1),mstu(5))
19476  ENDIF
19477  IF(ist.LT.mint(84).OR.ist.GT.i) GOTO 200
19478  IF(kchg(pycomp(k(ist,2)),2).EQ.0) GOTO 200
19479  nstr=nstr+1
19480  IF(j.EQ.1.OR.j.EQ.4) THEN
19481  kstr(nstr,1)=i
19482  kstr(nstr,2)=ist
19483  ELSE
19484  kstr(nstr,1)=ist
19485  kstr(nstr,2)=i
19486  ENDIF
19487  200 CONTINUE
19488  210 CONTINUE
19489 
19490 C...Set up starting values for iteration in xT2.
19491  xt2=4d0*vint(62)/vint(2)
19492  IF(mstp(82).LE.1) THEN
19493  sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
19494  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
19495  & vint(317)/(vint(318)*vint(320))
19496  xt2fac=sigrat*vint(149)/(1d0-vint(149))
19497  ELSE
19498  xt2fac=vnt146*vint(148)*xsec(isub,1)/
19499  & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
19500  ENDIF
19501  vint(63)=0d0
19502  vint(64)=0d0
19503  vint(143)=1d0-vint(141)
19504  vint(144)=1d0-vint(142)
19505 
19506 C...Iterate downwards in xT2.
19507  220 IF(mstp(82).LE.1) THEN
19508  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
19509  IF(xt2.LT.vint(149)) GOTO 270
19510  ELSE
19511  IF(xt2.LE.0.01001d0*vint(149)) GOTO 270
19512  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
19513  & log(pyr(0)))-vint(149)
19514  IF(xt2.LE.0d0) GOTO 270
19515  xt2=max(0.01d0*vint(149),xt2)
19516  ENDIF
19517  vint(25)=xt2
19518 
19519 C...Choose tau and y*. Calculate cos(theta-hat).
19520  IF(pyr(0).LE.coef(isub,1)) THEN
19521  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19522  tau=xt2*(1d0+taut)**2/(4d0*taut)
19523  ELSE
19524  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19525  ENDIF
19526  vint(21)=tau
19527  CALL pyklim(2)
19528  ryst=pyr(0)
19529  myst=1
19530  IF(ryst.GT.coef(isub,8)) myst=2
19531  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19532  CALL pykmap(2,myst,pyr(0))
19533  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19534 
19535 C...Check that x not used up. Accept or reject kinematical variables.
19536  x1m=sqrt(tau)*exp(vint(22))
19537  x2m=sqrt(tau)*exp(-vint(22))
19538  IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) GOTO 220
19539  vint(71)=0.5d0*vint(1)*sqrt(xt2)
19540  CALL pysigh(nchn,sigs)
19541  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
19542  IF(sigs.LT.xsec(isub,1)*pyr(0)) GOTO 220
19543 
19544 C...Reset K, P and V vectors. Select some variables.
19545  DO 240 i=n+1,n+2
19546  DO 230 j=1,5
19547  k(i,j)=0
19548  p(i,j)=0d0
19549  v(i,j)=0d0
19550  230 CONTINUE
19551  240 CONTINUE
19552  rflav=pyr(0)
19553  pt=0.5d0*vint(1)*sqrt(xt2)
19554  phi=paru(2)*pyr(0)
19555  cth=vint(23)
19556 
19557 C...Add first parton to event record.
19558  k(n+1,1)=3
19559  k(n+1,2)=21
19560  IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=
19561  & 1+int((2d0+parj(2))*pyr(0))
19562  p(n+1,1)=pt*cos(phi)
19563  p(n+1,2)=pt*sin(phi)
19564  p(n+1,3)=0.25d0*vint(1)*(vint(41)*(1d0+cth)-vint(42)*(1d0-cth))
19565  p(n+1,4)=0.25d0*vint(1)*(vint(41)*(1d0+cth)+vint(42)*(1d0-cth))
19566  p(n+1,5)=0d0
19567 
19568 C...Add second parton to event record.
19569  k(n+2,1)=3
19570  k(n+2,2)=21
19571  IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)
19572  p(n+2,1)=-p(n+1,1)
19573  p(n+2,2)=-p(n+1,2)
19574  p(n+2,3)=0.25d0*vint(1)*(vint(41)*(1d0-cth)-vint(42)*(1d0+cth))
19575  p(n+2,4)=0.25d0*vint(1)*(vint(41)*(1d0-cth)+vint(42)*(1d0+cth))
19576  p(n+2,5)=0d0
19577 
19578  IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN
19579 C....Choose relevant string pieces to place gluons on.
19580  DO 260 i=n+1,n+2
19581  dmin=1d8
19582  DO 250 istr=1,nstr
19583  i1=kstr(istr,1)
19584  i2=kstr(istr,2)
19585  dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-
19586  & p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-
19587  & p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1d0,p(i1,4)*p(i2,4)-
19588  & p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))
19589  IF(istr.EQ.1.OR.dist.LT.dmin) THEN
19590  dmin=dist
19591  ist1=i1
19592  ist2=i2
19593  istm=istr
19594  ENDIF
19595  250 CONTINUE
19596 
19597 C....Colour flow adjustments, new string pieces.
19598  IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+
19599  & mod(k(ist1,4),mstu(5))
19600  IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)=
19601  & mstu(5)*(k(ist1,5)/mstu(5))+i
19602  k(i,5)=mstu(5)*ist1
19603  k(i,4)=mstu(5)*ist2
19604  IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+
19605  & mod(k(ist2,5),mstu(5))
19606  IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)=
19607  & mstu(5)*(k(ist2,4)/mstu(5))+i
19608  kstr(istm,2)=i
19609  kstr(nstr+1,1)=i
19610  kstr(nstr+1,2)=ist2
19611  nstr=nstr+1
19612  260 CONTINUE
19613 
19614 C...String drawing and colour flow for gluon loop.
19615  ELSEIF(k(n+1,2).EQ.21) THEN
19616  k(n+1,4)=mstu(5)*(n+2)
19617  k(n+1,5)=mstu(5)*(n+2)
19618  k(n+2,4)=mstu(5)*(n+1)
19619  k(n+2,5)=mstu(5)*(n+1)
19620  kstr(nstr+1,1)=n+1
19621  kstr(nstr+1,2)=n+2
19622  kstr(nstr+2,1)=n+2
19623  kstr(nstr+2,2)=n+1
19624  nstr=nstr+2
19625 
19626 C...String drawing and colour flow for qqbar pair.
19627  ELSE
19628  k(n+1,4)=mstu(5)*(n+2)
19629  k(n+2,5)=mstu(5)*(n+1)
19630  kstr(nstr+1,1)=n+1
19631  kstr(nstr+1,2)=n+2
19632  nstr=nstr+1
19633  ENDIF
19634 
19635 C...Global statistics.
19636  mint(351)=mint(351)+1
19637  vint(351)=vint(351)+pt
19638  IF (mint(351).EQ.1) vint(356)=pt
19639 
19640 C...Update remaining energy; iterate.
19641  n=n+2
19642  IF(n.GT.mstu(4)-mstu(32)-10) THEN
19643  CALL pyerrm(11,'(PYMULT:) no more memory left in PYJETS')
19644  mint(51)=1
19645  RETURN
19646  ENDIF
19647  mint(31)=mint(31)+1
19648  vint(151)=vint(151)+vint(41)
19649  vint(152)=vint(152)+vint(42)
19650  vint(143)=vint(143)-vint(41)
19651  vint(144)=vint(144)-vint(42)
19652 C...Allow FSR for UE (always handle with old showers)
19653  IF(mstp(152).EQ.1) THEN
19654  m41sav=mstj(41)
19655  IF (mstj(41).EQ.10) mstj(41)=2
19656  mstj(41)=mod(mstj(41),10)
19657  CALL pyshow(n-1,n,sqrt(parp(71))*pt)
19658  mstj(41)=m41sav
19659  ENDIF
19660  IF(mint(31).LT.240) GOTO 220
19661  270 CONTINUE
19662  mint(1)=isubsv
19663  DO 280 j=11,80
19664  vint(j)=vintsv(j)
19665  280 CONTINUE
19666  ENDIF
19667 
19668 C...Format statements for printout.
19669  5000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter',
19670  &'actions for MSTP(82) =',i2,' ******')
19671  5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
19672  &d9.2,' mb: rejected')
19673  5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
19674  &d9.2,' mb: accepted')
19675 
19676  RETURN
19677  END
19678 
19679 C*********************************************************************
19680 
19681 C...PYREMN
19682 C...Adds on target remnants (one or two from each side) and
19683 C...includes primordial kT for hadron beams.
19684 
19685  SUBROUTINE pyremn(IPU1,IPU2)
19686 
19687 C...Double precision and integer declarations.
19688  IMPLICIT DOUBLE PRECISION(a-h, o-z)
19689  IMPLICIT INTEGER(I-N)
19690  INTEGER PYK,PYCHGE,PYCOMP
19691 C...Commonblocks.
19692  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
19693  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
19694  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
19695  common/pypars/mstp(200),parp(200),msti(200),pari(200)
19696  common/pyint1/mint(400),vint(400)
19697  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
19698 C...Local arrays.
19699  dimension kflch(2),kflsp(2),chi(2),pms(0:6),is(2),isn(2),robo(5),
19700  &psys(0:2,5),pmin(0:2),qold(4),qnew(4),dbe(3),psum(4)
19701 
19702 C...Find event type and remaining energy.
19703  isub=mint(1)
19704  ns=n
19705  IF(mint(50).EQ.0.OR.mod(mstp(81),10).LE.0) THEN
19706  vint(143)=1d0-vint(141)
19707  vint(144)=1d0-vint(142)
19708  ENDIF
19709 
19710 C...Define initial partons.
19711  ntry=0
19712  100 ntry=ntry+1
19713  DO 130 jt=1,2
19714  i=mint(83)+jt+2
19715  IF(jt.EQ.1) ipu=ipu1
19716  IF(jt.EQ.2) ipu=ipu2
19717  k(i,1)=21
19718  k(i,2)=k(ipu,2)
19719  k(i,3)=i-2
19720  pms(jt)=0d0
19721  vint(156+jt)=0d0
19722  vint(158+jt)=0d0
19723  IF(mint(47).EQ.1) THEN
19724  DO 110 j=1,5
19725  p(i,j)=p(i-2,j)
19726  110 CONTINUE
19727  ELSEIF(isub.EQ.95) THEN
19728  k(i,2)=21
19729  ELSE
19730  p(i,5)=p(ipu,5)
19731 
19732 C...No primordial kT, or chosen according to truncated Gaussian or
19733 C...exponential, or (for photon) predetermined or power law.
19734  120 IF(mint(40+jt).EQ.2.AND.mint(10+jt).NE.22) THEN
19735  IF(mstp(91).LE.0) THEN
19736  pt=0d0
19737  ELSEIF(mstp(91).EQ.1) THEN
19738  pt=parp(91)*sqrt(-log(pyr(0)))
19739  ELSE
19740  rpt1=pyr(0)
19741  rpt2=pyr(0)
19742  pt=-parp(92)*log(rpt1*rpt2)
19743  ENDIF
19744  IF(pt.GT.parp(93)) GOTO 120
19745  ELSEIF(mint(106+jt).EQ.3) THEN
19746  pta=sqrt(vint(282+jt))
19747  ptb=0d0
19748  IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
19749  ptb=parp(99)*sqrt(-log(pyr(0)))
19750  ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
19751  rpt1=pyr(0)
19752  rpt2=pyr(0)
19753  ptb=-parp(99)*log(rpt1*rpt2)
19754  ENDIF
19755  IF(ptb.GT.parp(100)) GOTO 120
19756  pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
19757  pt=pt*0.8d0**mint(57)
19758  IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
19759  ELSEIF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) THEN
19760  IF(mstp(93).LE.0) THEN
19761  pt=0d0
19762  ELSEIF(mstp(93).EQ.1) THEN
19763  pt=parp(99)*sqrt(-log(pyr(0)))
19764  ELSEIF(mstp(93).EQ.2) THEN
19765  rpt1=pyr(0)
19766  rpt2=pyr(0)
19767  pt=-parp(99)*log(rpt1*rpt2)
19768  ELSEIF(mstp(93).EQ.3) THEN
19769  ha=parp(99)**2
19770  hb=parp(100)**2
19771  pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
19772  ELSE
19773  ha=parp(99)**2
19774  hb=parp(100)**2
19775  IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
19776  pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
19777  ENDIF
19778  IF(pt.GT.parp(100)) GOTO 120
19779  ELSE
19780  pt=0d0
19781  ENDIF
19782  vint(156+jt)=pt
19783  phi=paru(2)*pyr(0)
19784  p(i,1)=pt*cos(phi)
19785  p(i,2)=pt*sin(phi)
19786  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
19787  ENDIF
19788  130 CONTINUE
19789  IF(mint(47).EQ.1) RETURN
19790 
19791 C...Kinematics construction for initial partons.
19792  i1=mint(83)+3
19793  i2=mint(83)+4
19794  IF(isub.EQ.95) THEN
19795  shs=0d0
19796  shr=0d0
19797  ELSE
19798  shs=vint(141)*vint(142)*vint(2)+(p(i1,1)+p(i2,1))**2+
19799  & (p(i1,2)+p(i2,2))**2
19800  shr=sqrt(max(0d0,shs))
19801  IF((shs-pms(1)-pms(2))**2-4d0*pms(1)*pms(2).LE.0d0) GOTO 100
19802  p(i1,4)=0.5d0*(shr+(pms(1)-pms(2))/shr)
19803  p(i1,3)=sqrt(max(0d0,p(i1,4)**2-pms(1)))
19804  p(i2,4)=shr-p(i1,4)
19805  p(i2,3)=-p(i1,3)
19806 
19807 C...Transform partons to overall CM-frame.
19808  robo(3)=(p(i1,1)+p(i2,1))/shr
19809  robo(4)=(p(i1,2)+p(i2,2))/shr
19810  CALL pyrobo(i1,i2,0d0,0d0,-robo(3),-robo(4),0d0)
19811  robo(2)=pyangl(p(i1,1),p(i1,2))
19812  CALL pyrobo(i1,i2,0d0,-robo(2),0d0,0d0,0d0)
19813  robo(1)=pyangl(p(i1,3),p(i1,1))
19814  CALL pyrobo(i1,i2,-robo(1),0d0,0d0,0d0,0d0)
19815  CALL pyrobo(i2+1,mint(52),0d0,-robo(2),0d0,0d0,0d0)
19816  CALL pyrobo(i1,mint(52),robo(1),robo(2),robo(3),robo(4),0d0)
19817  robo(5)=(vint(141)-vint(142))/(vint(141)+vint(142))
19818  CALL pyrobo(i1,mint(52),0d0,0d0,0d0,0d0,robo(5))
19819  ENDIF
19820 
19821 C...Optionally fix up x and Q2 definitions for leptoproduction.
19822  idisxq=0
19823  IF((mint(43).EQ.2.OR.mint(43).EQ.3).AND.((isub.EQ.10.AND.
19824  &mstp(23).GE.1).OR.(isub.EQ.83.AND.mstp(23).GE.2))) idisxq=1
19825  IF(idisxq.EQ.1) THEN
19826 
19827 C...Find where incoming and outgoing leptons/partons are sitting.
19828  lesd=1
19829  IF(mint(42).EQ.1) lesd=2
19830  lpin=mint(83)+3-lesd
19831  lein=mint(84)+lesd
19832  lqin=mint(84)+3-lesd
19833  leout=mint(84)+2+lesd
19834  lqout=mint(84)+5-lesd
19835  IF(k(lein,3).GT.lein) lein=k(lein,3)
19836  IF(k(lqin,3).GT.lqin) lqin=k(lqin,3)
19837  lscms=0
19838  DO 140 i=mint(84)+5,n
19839  IF(k(i,2).EQ.94) THEN
19840  lscms=i
19841  leout=i+lesd
19842  lqout=i+3-lesd
19843  ENDIF
19844  140 CONTINUE
19845  lqbg=ipu1
19846  IF(lesd.EQ.1) lqbg=ipu2
19847 
19848 C...Calculate actual and wanted momentum transfer.
19849  xnom=vint(43-lesd)
19850  q2nom=-vint(45)
19851  hpk=2d0*(p(lpin,4)*p(lein,4)-p(lpin,1)*p(lein,1)-
19852  & p(lpin,2)*p(lein,2)-p(lpin,3)*p(lein,3))*
19853  & (p(mint(83)+lesd,4)*vint(40+lesd)/p(lein,4))
19854  hpt2=max(0d0,q2nom*(1d0-q2nom/(xnom*hpk)))
19855  fac=sqrt(hpt2/(p(leout,1)**2+p(leout,2)**2))
19856  p(n+1,1)=fac*p(leout,1)
19857  p(n+1,2)=fac*p(leout,2)
19858  p(n+1,3)=0.25d0*((hpk-q2nom/xnom)/p(lpin,4)-
19859  & q2nom/(p(mint(83)+lesd,4)*vint(40+lesd)))*(-1)**(lesd+1)
19860  p(n+1,4)=sqrt(p(leout,5)**2+p(n+1,1)**2+p(n+1,2)**2+
19861  & p(n+1,3)**2)
19862  DO 150 j=1,4
19863  qold(j)=p(lein,j)-p(leout,j)
19864  qnew(j)=p(lein,j)-p(n+1,j)
19865  150 CONTINUE
19866 
19867 C...Boost outgoing electron and daughters.
19868  IF(lscms.EQ.0) THEN
19869  DO 160 j=1,4
19870  p(leout,j)=p(n+1,j)
19871  160 CONTINUE
19872  ELSE
19873  DO 170 j=1,3
19874  p(n+2,j)=(p(n+1,j)-p(leout,j))/(p(n+1,4)+p(leout,4))
19875  170 CONTINUE
19876  pinv=2d0/(1d0+p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2)
19877  DO 180 j=1,3
19878  dbe(j)=pinv*p(n+2,j)
19879  180 CONTINUE
19880  DO 200 i=lscms+1,n
19881  iorig=i
19882  190 iorig=k(iorig,3)
19883  IF(iorig.GT.leout) GOTO 190
19884  IF(i.EQ.leout.OR.iorig.EQ.leout)
19885  & CALL pyrobo(i,i,0d0,0d0,dbe(1),dbe(2),dbe(3))
19886  200 CONTINUE
19887  ENDIF
19888 
19889 C...Copy shower initiator and all outgoing partons.
19890  ncop=n+1
19891  k(ncop,3)=lqbg
19892  DO 210 j=1,5
19893  p(ncop,j)=p(lqbg,j)
19894  210 CONTINUE
19895  DO 240 i=mint(84)+1,n
19896  icop=0
19897  IF(k(i,1).GT.10) GOTO 240
19898  IF(i.EQ.lqbg.OR.i.EQ.lqout) THEN
19899  icop=i
19900  ELSE
19901  iorig=i
19902  220 iorig=k(iorig,3)
19903  IF(iorig.EQ.lqbg.OR.iorig.EQ.lqout) THEN
19904  icop=iorig
19905  ELSEIF(iorig.GT.mint(84).AND.iorig.LE.n) THEN
19906  GOTO 220
19907  ENDIF
19908  ENDIF
19909  IF(icop.NE.0) THEN
19910  ncop=ncop+1
19911  k(ncop,3)=i
19912  DO 230 j=1,5
19913  p(ncop,j)=p(i,j)
19914  230 CONTINUE
19915  ENDIF
19916  240 CONTINUE
19917 
19918 C...Calculate relative rescaling factors.
19919  slc=3-2*lesd
19920  plcsum=0d0
19921  DO 250 i=n+2,ncop
19922  plcsum=plcsum+(p(i,4)+slc*p(i,3))
19923  250 CONTINUE
19924  DO 260 i=n+2,ncop
19925  v(i,1)=(p(i,4)+slc*p(i,3))/plcsum
19926  260 CONTINUE
19927 
19928 C...Transfer extra three-momentum of current.
19929  DO 280 i=n+2,ncop
19930  DO 270 j=1,3
19931  p(i,j)=p(i,j)+v(i,1)*(qnew(j)-qold(j))
19932  270 CONTINUE
19933  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
19934  280 CONTINUE
19935 
19936 C...Iterate change of initiator momentum to get energy right.
19937  iter=0
19938  290 iter=iter+1
19939  peex=-p(n+1,4)-qnew(4)
19940  pemv=-p(n+1,3)/p(n+1,4)
19941  DO 300 i=n+2,ncop
19942  peex=peex+p(i,4)
19943  pemv=pemv+v(i,1)*p(i,3)/p(i,4)
19944  300 CONTINUE
19945  IF(abs(pemv).LT.1d-10) THEN
19946  mint(51)=1
19947  mint(57)=mint(57)+1
19948  RETURN
19949  ENDIF
19950  pzch=-peex/pemv
19951  p(n+1,3)=p(n+1,3)+pzch
19952  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)
19953  DO 310 i=n+2,ncop
19954  p(i,3)=p(i,3)+v(i,1)*pzch
19955  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
19956  310 CONTINUE
19957  IF(iter.LT.10.AND.abs(peex).GT.1d-6*p(n+1,4)) GOTO 290
19958 
19959 C...Modify momenta in event record.
19960  hbe=2d0*(p(n+1,4)+p(lqbg,4))*(p(n+1,3)-p(lqbg,3))/
19961  & ((p(n+1,4)+p(lqbg,4))**2+(p(n+1,3)-p(lqbg,3))**2)
19962  IF(abs(hbe).GE.1d0) THEN
19963  mint(51)=1
19964  mint(57)=mint(57)+1
19965  RETURN
19966  ENDIF
19967  i=mint(83)+5-lesd
19968  CALL pyrobo(i,i,0d0,0d0,0d0,0d0,hbe)
19969  DO 330 i=n+1,ncop
19970  icop=k(i,3)
19971  DO 320 j=1,4
19972  p(icop,j)=p(i,j)
19973  320 CONTINUE
19974  330 CONTINUE
19975  ENDIF
19976 
19977 C...Check minimum invariant mass of remnant system(s).
19978  psys(0,4)=p(i1,4)+p(i2,4)+0.5d0*vint(1)*(vint(151)+vint(152))
19979  psys(0,3)=p(i1,3)+p(i2,3)+0.5d0*vint(1)*(vint(151)-vint(152))
19980  pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
19981  pmin(0)=sqrt(pms(0))
19982  DO 340 jt=1,2
19983  psys(jt,4)=0.5d0*vint(1)*vint(142+jt)
19984  psys(jt,3)=psys(jt,4)*(-1)**(jt-1)
19985  pmin(jt)=0d0
19986  IF(mint(44+jt).EQ.1) GOTO 340
19987  mint(105)=mint(102+jt)
19988  mint(109)=mint(106+jt)
19989  CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))
19990  IF(mint(51).NE.0) THEN
19991  mint(57)=mint(57)+1
19992  RETURN
19993  ENDIF
19994  IF(kflch(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflch(jt))
19995  IF(kflsp(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflsp(jt))
19996  IF(kflch(jt)*kflsp(jt).NE.0) pmin(jt)=pmin(jt)+0.5d0*parp(111)
19997  pmin(jt)=sqrt(pmin(jt)**2+p(mint(83)+jt+2,1)**2+
19998  & p(mint(83)+jt+2,2)**2)
19999  340 CONTINUE
20000  IF(pmin(0)+pmin(1)+pmin(2).GT.vint(1).OR.(mint(45).GE.2.AND.
20001  &pmin(1).GT.psys(1,4)).OR.(mint(46).GE.2.AND.pmin(2).GT.
20002  &psys(2,4))) THEN
20003  mint(51)=1
20004  mint(57)=mint(57)+1
20005  RETURN
20006  ENDIF
20007 
20008 C...Loop over two remnants; skip if none there.
20009  i=ns
20010  DO 410 jt=1,2
20011  isn(jt)=0
20012  IF(mint(44+jt).EQ.1) GOTO 410
20013  IF(jt.EQ.1) ipu=ipu1
20014  IF(jt.EQ.2) ipu=ipu2
20015 
20016 C...Store first remnant parton.
20017  i=i+1
20018  is(jt)=i
20019  isn(jt)=1
20020  DO 350 j=1,5
20021  k(i,j)=0
20022  p(i,j)=0d0
20023  v(i,j)=0d0
20024  350 CONTINUE
20025  k(i,1)=1
20026  k(i,2)=kflsp(jt)
20027  k(i,3)=mint(83)+jt
20028  p(i,5)=pymass(k(i,2))
20029 
20030 C...First parton colour connections and kinematics.
20031  kcol=kchg(pycomp(kflsp(jt)),2)
20032  IF(kcol.EQ.2) THEN
20033  k(i,1)=3
20034  k(i,4)=mstu(5)*ipu+ipu
20035  k(i,5)=mstu(5)*ipu+ipu
20036  k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
20037  k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
20038  ELSEIF(kcol.NE.0) THEN
20039  k(i,1)=3
20040  kfls=(3-kcol*isign(1,kflsp(jt)))/2
20041  k(i,kfls+3)=ipu
20042  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
20043  ENDIF
20044  IF(kflch(jt).EQ.0) THEN
20045  p(i,1)=-p(mint(83)+jt+2,1)
20046  p(i,2)=-p(mint(83)+jt+2,2)
20047  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
20048  psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
20049  p(i,3)=psys(jt,3)
20050  p(i,4)=psys(jt,4)
20051 
20052 C...When extra remnant parton or hadron: store extra remnant.
20053  ELSE
20054  i=i+1
20055  isn(jt)=2
20056  DO 360 j=1,5
20057  k(i,j)=0
20058  p(i,j)=0d0
20059  v(i,j)=0d0
20060  360 CONTINUE
20061  k(i,1)=1
20062  k(i,2)=kflch(jt)
20063  k(i,3)=mint(83)+jt
20064  p(i,5)=pymass(k(i,2))
20065 
20066 C...Find parton colour connections of extra remnant.
20067  kcol=kchg(pycomp(kflch(jt)),2)
20068  IF(kcol.EQ.2) THEN
20069  k(i,1)=3
20070  k(i,4)=mstu(5)*ipu+ipu
20071  k(i,5)=mstu(5)*ipu+ipu
20072  k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
20073  k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
20074  ELSEIF(kcol.NE.0) THEN
20075  k(i,1)=3
20076  kfls=(3-kcol*isign(1,kflch(jt)))/2
20077  k(i,kfls+3)=ipu
20078  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
20079  ENDIF
20080 
20081 C...Relative transverse momentum when two remnants.
20082  loop=0
20083  370 loop=loop+1
20084  CALL pyptdi(1,p(i-1,1),p(i-1,2))
20085  IF(iabs(mint(10+jt)).LT.20) THEN
20086  p(i-1,1)=0d0
20087  p(i-1,2)=0d0
20088  ELSE
20089  p(i-1,1)=p(i-1,1)-0.5d0*p(mint(83)+jt+2,1)
20090  p(i-1,2)=p(i-1,2)-0.5d0*p(mint(83)+jt+2,2)
20091  ENDIF
20092  pms(jt+2)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
20093  p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1)
20094  p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2)
20095  pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
20096 
20097 C...Meson or baryon; photon as meson. For splitup below.
20098  imb=1
20099  IF(mod(mint(10+jt)/1000,10).NE.0) imb=2
20100 
20101 C***Relative distribution for electron into two electrons. Temporary!
20102  IF(iabs(mint(10+jt)).LT.20.AND.mint(14+jt).EQ.-mint(10+jt))
20103  & THEN
20104  chi(jt)=pyr(0)
20105 
20106 C...Relative distribution of electron energy into electron plus parton.
20107  ELSEIF(iabs(mint(10+jt)).LT.20) THEN
20108  xhrd=vint(140+jt)
20109  xe=vint(154+jt)
20110  chi(jt)=(xe-xhrd)/(1d0-xhrd)
20111 
20112 C...Relative distribution of energy for particle into two jets.
20113  ELSEIF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN
20114  chik=parp(92+2*imb)
20115  IF(mstp(92).LE.1) THEN
20116  IF(imb.EQ.1) chi(jt)=pyr(0)
20117  IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
20118  ELSEIF(mstp(92).EQ.2) THEN
20119  chi(jt)=1d0-pyr(0)**(1d0/(1d0+chik))
20120  ELSEIF(mstp(92).EQ.3) THEN
20121  cut=2d0*0.3d0/vint(1)
20122  380 chi(jt)=pyr(0)**2
20123  IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25d0*
20124  & (1d0-chi(jt))**chik.LT.pyr(0)) GOTO 380
20125  ELSEIF(mstp(92).EQ.4) THEN
20126  cut=2d0*0.3d0/vint(1)
20127  cutr=(1d0+sqrt(1d0+cut**2))/cut
20128  390 chir=cut*cutr**pyr(0)
20129  chi(jt)=(chir**2-cut**2)/(2d0*chir)
20130  IF((1d0-chi(jt))**chik.LT.pyr(0)) GOTO 390
20131  ELSE
20132  cut=2d0*0.3d0/vint(1)
20133  cuta=cut**(1d0-parp(98))
20134  cutb=(1d0+cut)**(1d0-parp(98))
20135  400 chi(jt)=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
20136  IF(((chi(jt)+cut)**2/(2d0*(chi(jt)**2+cut**2)))**
20137  & (0.5d0*parp(98))*(1d0-chi(jt))**chik.LT.pyr(0)) GOTO 400
20138  ENDIF
20139 
20140 C...Relative distribution of energy for particle into jet plus particle.
20141  ELSE
20142  IF(mstp(94).LE.1) THEN
20143  IF(imb.EQ.1) chi(jt)=pyr(0)
20144  IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
20145  IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
20146  ELSEIF(mstp(94).EQ.2) THEN
20147  chi(jt)=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
20148  IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
20149  ELSEIF(mstp(94).EQ.3) THEN
20150  CALL pyzdis(1,0,pms(jt+4),zz)
20151  chi(jt)=zz
20152  ELSE
20153  CALL pyzdis(1000,0,pms(jt+4),zz)
20154  chi(jt)=zz
20155  ENDIF
20156  ENDIF
20157 
20158 C...Construct total transverse mass; reject if too large.
20159  chi(jt)=max(1d-8,min(1d0-1d-8,chi(jt)))
20160  pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1d0-chi(jt))
20161  IF(pms(jt).GT.psys(jt,4)**2) THEN
20162  IF(loop.LT.100) THEN
20163  GOTO 370
20164  ELSE
20165  mint(51)=1
20166  mint(57)=mint(57)+1
20167  RETURN
20168  ENDIF
20169  ENDIF
20170  psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
20171  vint(158+jt)=chi(jt)
20172 
20173 C...Subdivide longitudinal momentum according to value selected above.
20174  pw1=chi(jt)*(psys(jt,4)+abs(psys(jt,3)))
20175  p(is(jt)+1,4)=0.5d0*(pw1+pms(jt+4)/pw1)
20176  p(is(jt)+1,3)=0.5d0*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)
20177  p(is(jt),4)=psys(jt,4)-p(is(jt)+1,4)
20178  p(is(jt),3)=psys(jt,3)-p(is(jt)+1,3)
20179  ENDIF
20180  410 CONTINUE
20181  n=i
20182 
20183 C...Check if longitudinal boosts needed - if so pick two systems.
20184  pdev=abs(psys(0,4)+psys(1,4)+psys(2,4)-vint(1))+
20185  &abs(psys(0,3)+psys(1,3)+psys(2,3))
20186  IF(pdev.LE.1d-6*vint(1)) RETURN
20187  IF(isn(1).EQ.0) THEN
20188  ir=0
20189  il=2
20190  ELSEIF(isn(2).EQ.0) THEN
20191  ir=1
20192  il=0
20193  ELSEIF(vint(143).GT.0.2d0.AND.vint(144).GT.0.2d0) THEN
20194  ir=1
20195  il=2
20196  ELSEIF(vint(143).GT.0.2d0) THEN
20197  ir=1
20198  il=0
20199  ELSEIF(vint(144).GT.0.2d0) THEN
20200  ir=0
20201  il=2
20202  ELSEIF(pms(1)/psys(1,4)**2.GT.pms(2)/psys(2,4)**2) THEN
20203  ir=1
20204  il=0
20205  ELSE
20206  ir=0
20207  il=2
20208  ENDIF
20209  ig=3-ir-il
20210 
20211 C...E+-pL wanted for system to be modified.
20212  IF((ig.EQ.1.AND.isn(1).EQ.0).OR.(ig.EQ.2.AND.isn(2).EQ.0)) THEN
20213  ppb=vint(1)
20214  pnb=vint(1)
20215  ELSE
20216  ppb=vint(1)-(psys(ig,4)+psys(ig,3))
20217  pnb=vint(1)-(psys(ig,4)-psys(ig,3))
20218  ENDIF
20219 
20220 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20221  IF(idisxq.EQ.1.AND.ig.NE.0) THEN
20222  ppb=ppb-(psys(0,4)+psys(0,3))
20223  pnb=pnb-(psys(0,4)-psys(0,3))
20224  DO 420 j=1,4
20225  psys(0,j)=0d0
20226  420 CONTINUE
20227  DO 450 i=mint(84)+1,ns
20228  IF(k(i,1).GT.10) GOTO 450
20229  incl=0
20230  iorig=i
20231  430 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20232  iorig=k(iorig,3)
20233  IF(iorig.GT.lpin) GOTO 430
20234  IF(incl.EQ.0) GOTO 450
20235  DO 440 j=1,4
20236  psys(0,j)=psys(0,j)+p(i,j)
20237  440 CONTINUE
20238  450 CONTINUE
20239  pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
20240  ppb=ppb+(psys(0,4)+psys(0,3))
20241  pnb=pnb+(psys(0,4)-psys(0,3))
20242  ENDIF
20243 
20244 C...Construct longitudinal boosts.
20245  dpmtb=ppb*pnb
20246  dpmtr=pms(ir)
20247  dpmtl=pms(il)
20248  dsqlam=sqrt(max(0d0,(dpmtb-dpmtr-dpmtl)**2-4d0*dpmtr*dpmtl))
20249  IF(dsqlam.LE.1d-6*dpmtb) THEN
20250  mint(51)=1
20251  mint(57)=mint(57)+1
20252  RETURN
20253  ENDIF
20254  dsqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))
20255  drkr=(dpmtb+dpmtr-dpmtl+dsqlam*dsqsgn)/
20256  &(2d0*(psys(ir,4)+psys(ir,3))*pnb)
20257  drkl=(dpmtb+dpmtl-dpmtr+dsqlam*dsqsgn)/
20258  &(2d0*(psys(il,4)-psys(il,3))*ppb)
20259  dber=(drkr**2-1d0)/(drkr**2+1d0)
20260  dbel=-(drkl**2-1d0)/(drkl**2+1d0)
20261 
20262 C...Perform longitudinal boosts.
20263  IF(ir.EQ.1.AND.isn(1).EQ.1.AND.dber.LE.-0.99999999d0) THEN
20264  p(is(1),3)=0d0
20265  p(is(1),4)=sqrt(p(is(1),5)**2+p(is(1),1)**2+p(is(1),2)**2)
20266  ELSEIF(ir.EQ.1) THEN
20267  CALL pyrobo(is(1),is(1)+isn(1)-1,0d0,0d0,0d0,0d0,dber)
20268  ELSEIF(idisxq.EQ.1) THEN
20269  DO 470 i=i1,ns
20270  incl=0
20271  iorig=i
20272  460 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20273  iorig=k(iorig,3)
20274  IF(iorig.GT.lpin) GOTO 460
20275  IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dber)
20276  470 CONTINUE
20277  ELSE
20278  CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dber)
20279  ENDIF
20280  IF(il.EQ.2.AND.isn(2).EQ.1.AND.dbel.GE.0.99999999d0) THEN
20281  p(is(2),3)=0d0
20282  p(is(2),4)=sqrt(p(is(2),5)**2+p(is(2),1)**2+p(is(2),2)**2)
20283  ELSEIF(il.EQ.2) THEN
20284  CALL pyrobo(is(2),is(2)+isn(2)-1,0d0,0d0,0d0,0d0,dbel)
20285  ELSEIF(idisxq.EQ.1) THEN
20286  DO 490 i=i1,ns
20287  incl=0
20288  iorig=i
20289  480 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20290  iorig=k(iorig,3)
20291  IF(iorig.GT.lpin) GOTO 480
20292  IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dbel)
20293  490 CONTINUE
20294  ELSE
20295  CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dbel)
20296  ENDIF
20297 
20298 C...Final check that energy-momentum conservation worked.
20299  pesum=0d0
20300  pzsum=0d0
20301  DO 500 i=mint(84)+1,n
20302  IF(k(i,1).GT.10) GOTO 500
20303  pesum=pesum+p(i,4)
20304  pzsum=pzsum+p(i,3)
20305  500 CONTINUE
20306  pdev=abs(pesum-vint(1))+abs(pzsum)
20307  IF(pdev.GT.1d-4*vint(1)) THEN
20308  mint(51)=1
20309  mint(57)=mint(57)+1
20310  RETURN
20311  ENDIF
20312 
20313 C...Calculate rotation and boost from overall CM frame to
20314 C...hadronic CM frame in leptoproduction.
20315  mint(91)=0
20316  IF(mint(82).EQ.1.AND.(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
20317  mint(91)=1
20318  lesd=1
20319  IF(mint(42).EQ.1) lesd=2
20320  lpin=mint(83)+3-lesd
20321 
20322 C...Sum upp momenta of everything not lepton or photon to define boost.
20323  DO 510 j=1,4
20324  psum(j)=0d0
20325  510 CONTINUE
20326  DO 530 i=1,n
20327  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 530
20328  IF(iabs(k(i,2)).GE.11.AND.iabs(k(i,2)).LE.20) GOTO 530
20329  IF(k(i,2).EQ.22) GOTO 530
20330  DO 520 j=1,4
20331  psum(j)=psum(j)+p(i,j)
20332  520 CONTINUE
20333  530 CONTINUE
20334  vint(223)=-psum(1)/psum(4)
20335  vint(224)=-psum(2)/psum(4)
20336  vint(225)=-psum(3)/psum(4)
20337 
20338 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20339  k(n+1,1)=1
20340  DO 540 j=1,5
20341  p(n+1,j)=p(lpin,j)
20342  v(n+1,j)=v(lpin,j)
20343  540 CONTINUE
20344  CALL pyrobo(n+1,n+1,0d0,0d0,vint(223),vint(224),vint(225))
20345  vint(222)=-pyangl(p(n+1,1),p(n+1,2))
20346  CALL pyrobo(n+1,n+1,0d0,vint(222),0d0,0d0,0d0)
20347  IF(lesd.EQ.2) THEN
20348  vint(221)=-pyangl(p(n+1,3),p(n+1,1))
20349  ELSE
20350  vint(221)=pyangl(-p(n+1,3),p(n+1,1))
20351  ENDIF
20352  ENDIF
20353 
20354  RETURN
20355  END
20356 
20357 C*********************************************************************
20358 
20359 C...PYMIGN
20360 C...Initializes treatment of new multiple interactions scenario,
20361 C...selects kinematics of hardest interaction if low-pT physics
20362 C...included in run, and generates all non-hardest interactions.
20363 
20364  SUBROUTINE pymign(MMUL)
20365 
20366 C...Double precision and integer declarations.
20367  IMPLICIT DOUBLE PRECISION(a-h, o-z)
20368  IMPLICIT INTEGER(I-N)
20369  INTEGER PYK,PYCHGE,PYCOMP
20370  EXTERNAL pyalps
20371  DOUBLE PRECISION PYALPS
20372 C...Commonblocks.
20373  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
20374  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
20375  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
20376  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
20377  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
20378  common/pypars/mstp(200),parp(200),msti(200),pari(200)
20379  common/pyint1/mint(400),vint(400)
20380  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
20381  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
20382  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
20383  common/pyint7/sigt(0:6,0:6,0:5)
20384  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
20385  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
20386  & xmi(2,240),pt2mi(240),imisep(0:240)
20387  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
20388  &/pyint1/,/pyint2/,/pyint3/,/pyint5/,/pyint7/,/pyintm/
20389 C...Local arrays and saved variables.
20390  dimension nmul(20),sigm(20),kstr(500,2),vintsv(80),
20391  &wdtp(0:400),wdte(0:400,0:5),xpq(-25:25),ksav(4,5),psav(4,5)
20392  SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm,p83a,p83b,p83c,
20393  &cq2i,cq2r,pik,bdiv,b,plowb,phighb,pallb,s4a,s4b,s4c,powip,
20394  &rpwip,b2rpdv,b2rpmx,bavg,vnt145,vnt146,vnt147
20395 
20396 C...Initialization of multiple interaction treatment.
20397  IF(mmul.EQ.1) THEN
20398  IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
20399  isub=96
20400  mint(1)=96
20401  vint(63)=0d0
20402  vint(64)=0d0
20403  vint(143)=1d0
20404  vint(144)=1d0
20405 
20406 C...Loop over phase space points: xT2 choice in 20 bins.
20407  100 sigsum=0d0
20408  DO 120 ixt2=1,20
20409  nmul(ixt2)=mstp(83)
20410  sigm(ixt2)=0d0
20411  DO 110 itry=1,mstp(83)
20412  rsca=0.05d0*((21-ixt2)-pyr(0))
20413  xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
20414  xt2=max(0.01d0*vint(149),xt2)
20415  vint(25)=xt2
20416 
20417 C...Choose tau and y*. Calculate cos(theta-hat).
20418  IF(pyr(0).LE.coef(isub,1)) THEN
20419  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20420  tau=xt2*(1d0+taut)**2/(4d0*taut)
20421  ELSE
20422  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20423  ENDIF
20424  vint(21)=tau
20425  CALL pyklim(2)
20426  ryst=pyr(0)
20427  myst=1
20428  IF(ryst.GT.coef(isub,8)) myst=2
20429  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20430  CALL pykmap(2,myst,pyr(0))
20431  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20432 
20433 C...Calculate differential cross-section.
20434  vint(71)=0.5d0*vint(1)*sqrt(xt2)
20435  CALL pysigh(nchn,sigs)
20436  sigm(ixt2)=sigm(ixt2)+sigs
20437  110 CONTINUE
20438  sigsum=sigsum+sigm(ixt2)
20439  120 CONTINUE
20440  sigsum=sigsum/(20d0*mstp(83))
20441 
20442 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20443  IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
20444  IF(mstp(122).GE.1) WRITE(mstu(11),5100)
20445  & parp(82)*(vint(1)/parp(89))**parp(90),sigsum
20446  parp(82)=0.9d0*parp(82)
20447  vint(149)=4d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
20448  & vint(2)
20449  GOTO 100
20450  ENDIF
20451  IF(mstp(122).GE.1) WRITE(mstu(11),5200)
20452  & parp(82)*(vint(1)/parp(89))**parp(90), sigsum
20453 
20454 C...Start iteration to find k factor.
20455  yke=sigsum/max(1d-10,sigt(0,0,5))
20456  p83a=(1d0-parp(83))**2
20457  p83b=2d0*parp(83)*(1d0-parp(83))
20458  p83c=parp(83)**2
20459  cq2i=1d0/parp(84)**2
20460  cq2r=2d0/(1d0+parp(84)**2)
20461  so=0.5d0
20462  xi=0d0
20463  yi=0d0
20464  xf=0d0
20465  yf=0d0
20466  xk=0.5d0
20467  iit=0
20468  130 IF(iit.EQ.0) THEN
20469  xk=2d0*xk
20470  ELSEIF(iit.EQ.1) THEN
20471  xk=0.5d0*xk
20472  ELSE
20473  xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
20474  ENDIF
20475 
20476 C...Evaluate overlap integrals. Find where to divide the b range.
20477  IF(mstp(82).EQ.2) THEN
20478  sp=0.5d0*paru(1)*(1d0-exp(-xk))
20479  sop=sp/paru(1)
20480  ELSE
20481  IF(mstp(82).EQ.3) THEN
20482  deltab=0.02d0
20483  ELSEIF(mstp(82).EQ.4) THEN
20484  deltab=min(0.01d0,0.05d0*parp(84))
20485  ELSE
20486  powip=max(0.4d0,parp(83))
20487  rpwip=2d0/powip-1d0
20488  deltab=max(0.02d0,0.02d0*(2d0/powip)**(1d0/powip))
20489  so=0d0
20490  ENDIF
20491  sp=0d0
20492  sop=0d0
20493  bsp=0d0
20494  sohigh=0d0
20495  ibdiv=0
20496  b=-0.5d0*deltab
20497  140 b=b+deltab
20498  IF(mstp(82).EQ.3) THEN
20499  ov=exp(-b**2)/paru(2)
20500  ELSEIF(mstp(82).EQ.4) THEN
20501  ov=(p83a*exp(-min(50d0,b**2))+
20502  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
20503  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
20504  ELSE
20505  ov=exp(-b**powip)/paru(2)
20506  so=so+paru(2)*b*deltab*ov
20507  ENDIF
20508  IF(ibdiv.EQ.1) sohigh=sohigh+paru(2)*b*deltab*ov
20509  pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
20510  sp=sp+paru(2)*b*deltab*pacc
20511  sop=sop+paru(2)*b*deltab*ov*pacc
20512  bsp=bsp+b*paru(2)*b*deltab*pacc
20513  IF(ibdiv.EQ.0.AND.paru(1)*xk*ov.LT.1d0) THEN
20514  ibdiv=1
20515  bdiv=b+0.5d0*deltab
20516  ENDIF
20517  IF(b.LT.1d0.OR.b*pacc.GT.1d-6) GOTO 140
20518  ENDIF
20519  yk=paru(1)*xk*so/sp
20520 
20521 C...Continue iteration until convergence.
20522  IF(yk.LT.yke) THEN
20523  xi=xk
20524  yi=yk
20525  IF(iit.EQ.1) iit=2
20526  ELSE
20527  xf=xk
20528  yf=yk
20529  IF(iit.EQ.0) iit=1
20530  ENDIF
20531  IF(abs(yk-yke).GE.1d-5*yke) GOTO 130
20532 
20533 C...Store some results for subsequent use.
20534  bavg=bsp/sp
20535  vint(145)=sigsum
20536  vint(146)=sop/so
20537  vint(147)=sop/sp
20538  vnt145=vint(145)
20539  vnt146=vint(146)
20540  vnt147=vint(147)
20541 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20542  pik=(vnt146/vnt147)*yke
20543 
20544 C...Find relative weight for low and high impact parameter..
20545  plowb=paru(1)*bdiv**2
20546  IF(mstp(82).EQ.3) THEN
20547  phighb=pik*0.5*exp(-bdiv**2)
20548  ELSEIF(mstp(82).EQ.4) THEN
20549  s4a=p83a*exp(-bdiv**2)
20550  s4b=p83b*exp(-bdiv**2*cq2r)
20551  s4c=p83c*exp(-bdiv**2*cq2i)
20552  phighb=pik*0.5*(s4a+s4b+s4c)
20553  ELSEIF(parp(83).GE.1.999d0) THEN
20554  phighb=pik*sohigh
20555  b2rpdv=bdiv**powip
20556  ELSE
20557  phighb=pik*sohigh
20558  b2rpdv=bdiv**powip
20559  b2rpmx=max(2d0*rpwip,b2rpdv)
20560  ENDIF
20561  pallb=plowb+phighb
20562 
20563 C...Initialize iteration in xT2 for hardest interaction.
20564  ELSEIF(mmul.EQ.2) THEN
20565  vint(145)=vnt145
20566  vint(146)=vnt146
20567  vint(147)=vnt147
20568  IF(mstp(82).LE.0) THEN
20569  ELSEIF(mstp(82).EQ.1) THEN
20570  xt2=1d0
20571  sigrat=xsec(96,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
20572  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
20573  & vint(317)/(vint(318)*vint(320))
20574  xt2fac=sigrat*vint(149)/(1d0-vint(149))
20575  ELSEIF(mstp(82).EQ.2) THEN
20576  xt2=1d0
20577  xt2fac=vnt146*xsec(96,1)/max(1d-10,sigt(0,0,5))*
20578  & vint(149)*(1d0+vint(149))
20579  ELSE
20580  xc2=4d0*ckin(3)**2/vint(2)
20581  IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
20582  ENDIF
20583 
20584 C...Select impact parameter for hardest interaction.
20585  IF(mstp(82).LE.2) RETURN
20586  142 IF(pyr(0)*pallb.LT.plowb) THEN
20587 C...Treatment in low b region.
20588  mint(39)=1
20589  b=bdiv*sqrt(pyr(0))
20590  IF(mstp(82).EQ.3) THEN
20591  ov=exp(-b**2)/paru(2)
20592  ELSEIF(mstp(82).EQ.4) THEN
20593  ov=(p83a*exp(-min(50d0,b**2))+
20594  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
20595  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
20596  ELSE
20597  ov=exp(-b**powip)/paru(2)
20598  ENDIF
20599  vint(148)=ov/vnt147
20600  pacc=1d0-exp(-min(50d0,pik*ov))
20601  xt2=1d0
20602  xt2fac=vnt146*vint(148)*xsec(96,1)/max(1d-10,sigt(0,0,5))*
20603  & vint(149)*(1d0+vint(149))
20604  ELSE
20605 C...Treatment in high b region.
20606  mint(39)=2
20607  IF(mstp(82).EQ.3) THEN
20608  b=sqrt(bdiv**2-log(pyr(0)))
20609  ov=exp(-b**2)/paru(2)
20610  ELSEIF(mstp(82).EQ.4) THEN
20611  s4rndm=pyr(0)*(s4a+s4b+s4c)
20612  IF(s4rndm.LT.s4a) THEN
20613  b=sqrt(bdiv**2-log(pyr(0)))
20614  ELSEIF(s4rndm.LT.s4a+s4b) THEN
20615  b=sqrt(bdiv**2-log(pyr(0))/cq2r)
20616  ELSE
20617  b=sqrt(bdiv**2-log(pyr(0))/cq2i)
20618  ENDIF
20619  ov=(p83a*exp(-min(50d0,b**2))+
20620  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
20621  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
20622  ELSEIF(parp(83).GE.1.999d0) THEN
20623  144 b2rpw=b2rpdv-log(pyr(0))
20624  accip=(b2rpw/b2rpdv)**rpwip
20625  IF(accip.LT.pyr(0)) GOTO 144
20626  ov=exp(-b2rpw)/paru(2)
20627  b=b2rpw**(1d0/powip)
20628  ELSE
20629  146 b2rpw=b2rpdv-2d0*log(pyr(0))
20630  accip=(b2rpw/b2rpmx)**rpwip*exp(-0.5d0*(b2rpw-b2rpmx))
20631  IF(accip.LT.pyr(0)) GOTO 146
20632  ov=exp(-b2rpw)/paru(2)
20633  b=b2rpw**(1d0/powip)
20634  ENDIF
20635  vint(148)=ov/vnt147
20636  pacc=(1d0-exp(-min(50d0,pik*ov)))/(pik*ov)
20637  ENDIF
20638  IF(pacc.LT.pyr(0)) GOTO 142
20639  vint(139)=b/bavg
20640 
20641  ELSEIF(mmul.EQ.3) THEN
20642 C...Low-pT or multiple interactions (first semihard interaction):
20643 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20644 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20645  isub=mint(1)
20646  vint(145)=vnt145
20647  vint(146)=vnt146
20648  vint(147)=vnt147
20649  IF(mstp(82).LE.0) THEN
20650  xt2=0d0
20651  ELSEIF(mstp(82).EQ.1) THEN
20652  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
20653 C...Use with "Sudakov" for low b values when impact parameter dependence.
20654  ELSEIF(mstp(82).EQ.2.OR.mint(39).EQ.1) THEN
20655  IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
20656  & vint(149)))).GT.pyr(0)) xt2=1d0
20657  IF(xt2.GE.1d0) THEN
20658  xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
20659  & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
20660  & vint(149)
20661  ELSE
20662  xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
20663  & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
20664  & vint(149)
20665  ENDIF
20666  xt2=max(0.01d0*vint(149),xt2)
20667 C...Use without "Sudakov" for high b values when impact parameter dep.
20668  ELSE
20669  xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
20670  & pyr(0)*(1d0-xc2))-vint(149)
20671  xt2=max(0.01d0*vint(149),xt2)
20672  ENDIF
20673  vint(25)=xt2
20674 
20675 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20676  IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
20677  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-mint(143)
20678  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-mint(143)
20679  isub=95
20680  mint(1)=isub
20681  vint(21)=1d-12*vint(149)
20682  vint(22)=0d0
20683  vint(23)=0d0
20684  vint(25)=1d-12*vint(149)
20685 
20686  ELSE
20687 C...Multiple interactions (first semihard interaction).
20688 C...Choose tau and y*. Calculate cos(theta-hat).
20689  IF(pyr(0).LE.coef(isub,1)) THEN
20690  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20691  tau=xt2*(1d0+taut)**2/(4d0*taut)
20692  ELSE
20693  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20694  ENDIF
20695  vint(21)=tau
20696  CALL pyklim(2)
20697  ryst=pyr(0)
20698  myst=1
20699  IF(ryst.GT.coef(isub,8)) myst=2
20700  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20701  CALL pykmap(2,myst,pyr(0))
20702  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20703  ENDIF
20704  vint(71)=0.5d0*vint(1)*sqrt(vint(25))
20705 
20706 C...Store results of cross-section calculation.
20707  ELSEIF(mmul.EQ.4) THEN
20708  isub=mint(1)
20709  vint(145)=vnt145
20710  vint(146)=vnt146
20711  vint(147)=vnt147
20712  xts=vint(25)
20713  IF(iset(isub).EQ.1) xts=vint(21)
20714  IF(iset(isub).EQ.2)
20715  & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
20716  IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
20717  rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
20718  & (xts+vint(149))))
20719  irbin=int(1d0+20d0*rbin)
20720  IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
20721  nmul(irbin)=nmul(irbin)+1
20722  sigm(irbin)=sigm(irbin)+vint(153)
20723  ENDIF
20724 
20725 C...Choose impact parameter if not already done.
20726  ELSEIF(mmul.EQ.5) THEN
20727  isub=mint(1)
20728  vint(145)=vnt145
20729  vint(146)=vnt146
20730  vint(147)=vnt147
20731  150 IF(mint(39).GT.0) THEN
20732  ELSEIF(mstp(82).EQ.3) THEN
20733  expb2=pyr(0)
20734  b2=-log(pyr(0))
20735  vint(148)=expb2/(paru(2)*vnt147)
20736  vint(139)=sqrt(b2)/bavg
20737  ELSEIF(mstp(82).EQ.4) THEN
20738  rtype=pyr(0)
20739  IF(rtype.LT.p83a) THEN
20740  b2=-log(pyr(0))
20741  ELSEIF(rtype.LT.p83a+p83b) THEN
20742  b2=-log(pyr(0))/cq2r
20743  ELSE
20744  b2=-log(pyr(0))/cq2i
20745  ENDIF
20746  vint(148)=(p83a*exp(-min(50d0,b2))+
20747  & p83b*cq2r*exp(-min(50d0,b2*cq2r))+
20748  & p83c*cq2i*exp(-min(50d0,b2*cq2i)))/(paru(2)*vnt147)
20749  vint(139)=sqrt(b2)/bavg
20750  ELSEIF(parp(83).GE.1.999d0) THEN
20751  powip=max(2d0,parp(83))
20752  rpwip=2d0/powip-1d0
20753  prob1=powip/(2d0*exp(-1d0)+powip)
20754  160 IF(pyr(0).LT.prob1) THEN
20755  b2rpw=pyr(0)**(0.5d0*powip)
20756  accip=exp(-b2rpw)
20757  ELSE
20758  b2rpw=1d0-log(pyr(0))
20759  accip=b2rpw**rpwip
20760  ENDIF
20761  IF(accip.LT.pyr(0)) GOTO 160
20762  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
20763  vint(139)=b2rpw**(1d0/powip)/bavg
20764  ELSE
20765  powip=max(0.4d0,parp(83))
20766  rpwip=2d0/powip-1d0
20767  prob1=rpwip/(rpwip+2d0**rpwip*exp(-rpwip))
20768  170 IF(pyr(0).LT.prob1) THEN
20769  b2rpw=2d0*rpwip*pyr(0)
20770  accip=(b2rpw/rpwip)**rpwip*exp(rpwip-b2rpw)
20771  ELSE
20772  b2rpw=2d0*(rpwip-log(pyr(0)))
20773  accip=(0.5d0*b2rpw/rpwip)**rpwip*exp(rpwip-0.5d0*b2rpw)
20774  ENDIF
20775  IF(accip.lt .pyr(0)) GOTO 170
20776  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
20777  vint(139)=b2rpw**(1d0/powip)/bavg
20778  ENDIF
20779 
20780 C...Multiple interactions (variable impact parameter) : reject with
20781 C...probability exp(-overlap*cross-section above pT/normalization).
20782 C...Does not apply to low-b region, where "Sudakov" already included.
20783  vint(150)=1d0
20784  IF(mint(39).NE.1) THEN
20785  rncor=(irbin-20d0*rbin)*nmul(irbin)
20786  sigcor=(irbin-20d0*rbin)*sigm(irbin)
20787  DO 180 ibin=irbin+1,20
20788  rncor=rncor+nmul(ibin)
20789  sigcor=sigcor+sigm(ibin)
20790  180 CONTINUE
20791  sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
20792  IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
20793  vint(150)=exp(-min(50d0,vnt146*vint(148)*
20794  & sigabv/max(1d-10,sigt(0,0,5))))
20795  ENDIF
20796  IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isub.NE.11.AND.
20797  & isub.NE.12.AND.isub.NE.13.AND.isub.NE.28.AND.isub.NE.53
20798  & .AND.isub.NE.68.AND.isub.NE.95.AND.isub.NE.96)) THEN
20799  IF(vint(150).LT.pyr(0)) GOTO 150
20800  vint(150)=1d0
20801  ENDIF
20802 
20803 C...Generate additional multiple semihard interactions.
20804  ELSEIF(mmul.EQ.6) THEN
20805 
20806 C...Save data for hardest initeraction, to be restored.
20807  isubsv=mint(1)
20808  vint(145)=vnt145
20809  vint(146)=vnt146
20810  vint(147)=vnt147
20811  m13sv=mint(13)
20812  m14sv=mint(14)
20813  m15sv=mint(15)
20814  m16sv=mint(16)
20815  m21sv=mint(21)
20816  m22sv=mint(22)
20817  DO 190 j=11,80
20818  vintsv(j)=vint(j)
20819  190 CONTINUE
20820  v141sv=vint(141)
20821  v142sv=vint(142)
20822 
20823 C...Store data on hardest interaction.
20824  xmi(1,1)=vint(141)
20825  xmi(2,1)=vint(142)
20826  pt2mi(1)=vint(54)
20827  imisep(0)=mint(84)
20828  imisep(1)=n
20829 
20830 C...Change process to generate; sum of x values so far.
20831  isub=96
20832  mint(1)=96
20833  vint(143)=1d0-vint(141)
20834  vint(144)=1d0-vint(142)
20835  vint(151)=0d0
20836  vint(152)=0d0
20837 
20838 C...Initialize factors for PDF reshaping.
20839  DO 230 js=1,2
20840  kfbeam=mint(10+js)
20841  kfabm=iabs(kfbeam)
20842  kfsbm=isign(1,kfbeam)
20843 
20844 C...Zero flavour content of incoming beam particle.
20845  kfival(js,1)=0
20846  kfival(js,2)=0
20847  kfival(js,3)=0
20848 C...Flavour content of baryon.
20849  IF(kfabm.GT.1000) THEN
20850  kfival(js,1)=kfsbm*mod(kfabm/1000,10)
20851  kfival(js,2)=kfsbm*mod(kfabm/100,10)
20852  kfival(js,3)=kfsbm*mod(kfabm/10,10)
20853 C...Flavour content of pi+-, K+-.
20854  ELSEIF(kfabm.EQ.211) THEN
20855  kfival(js,1)=kfsbm*2
20856  kfival(js,2)=-kfsbm
20857  ELSEIF(kfabm.EQ.321) THEN
20858  kfival(js,1)=-kfsbm*3
20859  kfival(js,2)=kfsbm*2
20860 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20861  ENDIF
20862 
20863 C...Zero initial valence and companion content.
20864  DO 200 ifl=-6,6
20865  nvc(js,ifl)=0
20866  200 CONTINUE
20867 
20868 C...Initiate listing of all incoming partons from two sides.
20869  nmi(js)=0
20870  DO 210 i=mint(84)+1,n
20871  IF(k(i,3).EQ.mint(83)+2+js) THEN
20872  imi(js,1,1)=i
20873  imi(js,1,2)=0
20874  ENDIF
20875  210 CONTINUE
20876 
20877 C...Decide whether quarks in hard scattering were valence or sea.
20878  ifl=k(imi(js,1,1),2)
20879  IF (iabs(ifl).GT.6) GOTO 230
20880 
20881 C...Get PDFs at X and Q2 of the parton shower initiator for the
20882 C...hard scattering.
20883  x=vint(140+js)
20884  IF(mstp(61).GE.1) THEN
20885  q2=parp(62)**2
20886  ELSE
20887  q2=vint(54)
20888  ENDIF
20889 C...Note: XPSVC = x*pdf.
20890  mint(30)=js
20891  CALL pypdfu(kfbeam,x,q2,xpq)
20892  sea=xpsvc(ifl,-1)
20893  val=xpsvc(ifl,0)
20894 
20895 C...Decide (Extra factor x cancels in the division).
20896  rvcs=pyr(0)*(sea+val)
20897  ivnow=1
20898  220 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
20899 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20900  ivnow=0
20901  IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
20902  IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
20903  IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
20904  IF(kfival(js,1).EQ.0) THEN
20905  IF(kfbeam.EQ.111.AND.iabs(ifl).LE.2) ivnow=1
20906  IF(kfbeam.EQ.22.AND.iabs(ifl).LE.5) ivnow=1
20907  IF((kfbeam.EQ.130.OR.kfbeam.EQ.310).AND.
20908  & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
20909  ENDIF
20910  IF(ivnow.EQ.0) GOTO 220
20911 C...Mark valence.
20912  imi(js,1,2)=0
20913 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20914  IF(kfival(js,1).EQ.0) THEN
20915  IF(kfbeam.EQ.111.OR.kfbeam.EQ.22) THEN
20916  kfival(js,1)=ifl
20917  kfival(js,2)=-ifl
20918  ELSEIF(kfbeam.EQ.130.OR.kfbeam.EQ.310) THEN
20919  kfival(js,1)=ifl
20920  IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
20921  IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
20922  ENDIF
20923  ENDIF
20924 
20925 C...If sea, add opposite sign companion parton. Store X and I.
20926  ELSE
20927  nvc(js,-ifl)=nvc(js,-ifl)+1
20928  xassoc(js,-ifl,nvc(js,-ifl))=x
20929 C...Set pointer to companion
20930  imi(js,1,2)=-nvc(js,-ifl)
20931  ENDIF
20932  230 CONTINUE
20933 
20934 C...Update counter number of multiple interactions.
20935  nmi(1)=1
20936  nmi(2)=1
20937 
20938 C...Set up starting values for iteration in xT2.
20939  IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isubsv.NE.11.AND.
20940  & isubsv.NE.12.AND.isubsv.NE.13.AND.isubsv.NE.28.AND.
20941  & isubsv.NE.53.AND.isubsv.NE.68.AND.isubsv.NE.95.AND.
20942  & isubsv.NE.96)) THEN
20943  xt2=(1d0-vint(141))*(1d0-vint(142))
20944  ELSE
20945  xt2=vint(25)
20946  IF(iset(isubsv).EQ.1) xt2=vint(21)
20947  IF(iset(isubsv).EQ.2)
20948  & xt2=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
20949  IF(iset(isubsv).GE.3.AND.iset(isubsv).LE.5) xt2=vint(26)
20950  ENDIF
20951  IF(mstp(82).LE.1) THEN
20952  sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
20953  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
20954  & vint(317)/(vint(318)*vint(320))
20955  xt2fac=sigrat*vint(149)/(1d0-vint(149))
20956  ELSE
20957  xt2fac=vnt146*vint(148)*xsec(isub,1)/
20958  & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
20959  ENDIF
20960  vint(63)=0d0
20961  vint(64)=0d0
20962 
20963 C...Iterate downwards in xT2.
20964  240 IF((mint(35).EQ.2.AND.mstp(81).EQ.10).OR.isubsv.EQ.95) THEN
20965  xt2=0d0
20966  GOTO 440
20967  ELSEIF(mstp(82).LE.1) THEN
20968  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
20969  IF(xt2.LT.vint(149)) GOTO 440
20970  ELSE
20971  IF(xt2.LE.0.01001d0*vint(149)) GOTO 440
20972  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
20973  & log(pyr(0)))-vint(149)
20974  IF(xt2.LE.0d0) GOTO 440
20975  xt2=max(0.01d0*vint(149),xt2)
20976  ENDIF
20977  vint(25)=xt2
20978 
20979 C...Choose tau and y*. Calculate cos(theta-hat).
20980  IF(pyr(0).LE.coef(isub,1)) THEN
20981  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20982  tau=xt2*(1d0+taut)**2/(4d0*taut)
20983  ELSE
20984  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20985  ENDIF
20986  vint(21)=tau
20987 C...New: require shat > 1.
20988  IF(tau*vint(2).LT.1d0) GOTO 240
20989  CALL pyklim(2)
20990  ryst=pyr(0)
20991  myst=1
20992  IF(ryst.GT.coef(isub,8)) myst=2
20993  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20994  CALL pykmap(2,myst,pyr(0))
20995  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20996 
20997 C...Check that x not used up. Accept or reject kinematical variables.
20998  x1m=sqrt(tau)*exp(vint(22))
20999  x2m=sqrt(tau)*exp(-vint(22))
21000  IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) GOTO 240
21001  vint(71)=0.5d0*vint(1)*sqrt(xt2)
21002  CALL pysigh(nchn,sigs)
21003  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
21004  IF(sigs.LT.xsec(isub,1)*pyr(0)) GOTO 240
21005  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs/vint(320)
21006 
21007 C...Reset K, P and V vectors.
21008  DO 260 i=n+1,n+4
21009  DO 250 j=1,5
21010  k(i,j)=0
21011  p(i,j)=0d0
21012  v(i,j)=0d0
21013  250 CONTINUE
21014  260 CONTINUE
21015  pt=0.5d0*vint(1)*sqrt(xt2)
21016 
21017 C...Choose flavour of reacting partons (and subprocess).
21018  rsigs=sigs*pyr(0)
21019  DO 270 ichn=1,nchn
21020  kfl1=isig(ichn,1)
21021  kfl2=isig(ichn,2)
21022  iconmi=isig(ichn,3)
21023  rsigs=rsigs-sigh(ichn)
21024  IF(rsigs.LE.0d0) GOTO 280
21025  270 CONTINUE
21026 
21027 C...Reassign to appropriate process codes.
21028  280 isubmi=iconmi/10
21029  iconmi=mod(iconmi,10)
21030 
21031 C...Choose new quark flavour for annihilation graphs
21032  IF(isubmi.EQ.12.OR.isubmi.EQ.53) THEN
21033  sh=tau*vint(2)
21034  CALL pywidt(21,sh,wdtp,wdte)
21035  290 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
21036  DO 300 i=1,mdcy(21,3)
21037  kflf=kfdp(i+mdcy(21,2)-1,1)
21038  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
21039  IF(rkfl.LE.0d0) GOTO 310
21040  300 CONTINUE
21041  310 IF(isubmi.EQ.53.AND.iconmi.LE.2) THEN
21042  IF(kflf.GE.4) GOTO 290
21043  ELSEIF(isubmi.EQ.53.AND.iconmi.LE.4) THEN
21044  kflf=4
21045  iconmi=iconmi-2
21046  ELSEIF(isubmi.EQ.53) THEN
21047  kflf=5
21048  iconmi=iconmi-4
21049  ENDIF
21050  ENDIF
21051 
21052 C...Final state flavours and colour flow: default values
21053  js=1
21054  kfl3=kfl1
21055  kfl4=kfl2
21056  kcc=20
21057  kcs=isign(1,kfl1)
21058 
21059  IF(isubmi.EQ.11) THEN
21060 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21061  kcc=iconmi
21062  IF(kfl1*kfl2.LT.0) kcc=kcc+2
21063 
21064  ELSEIF(isubmi.EQ.12) THEN
21065 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21066  kfl3=isign(kflf,kfl1)
21067  kfl4=-kfl3
21068  kcc=4
21069 
21070  ELSEIF(isubmi.EQ.13) THEN
21071 C...f + fbar -> g + g; th arbitrary
21072  kfl3=21
21073  kfl4=21
21074  kcc=iconmi+4
21075 
21076  ELSEIF(isubmi.EQ.28) THEN
21077 C...f + g -> f + g; th = (p(f)-p(f))**2
21078  IF(kfl1.EQ.21) js=2
21079  kcc=iconmi+6
21080  IF(kfl1.EQ.21) kcc=kcc+2
21081  IF(kfl1.NE.21) kcs=isign(1,kfl1)
21082  IF(kfl2.NE.21) kcs=isign(1,kfl2)
21083 
21084  ELSEIF(isubmi.EQ.53) THEN
21085 C...g + g -> f + fbar; th arbitrary
21086  kcs=(-1)**int(1.5d0+pyr(0))
21087  kfl3=isign(kflf,kcs)
21088  kfl4=-kfl3
21089  kcc=iconmi+10
21090 
21091  ELSEIF(isubmi.EQ.68) THEN
21092 C...g + g -> g + g; th arbitrary
21093  kcc=iconmi+12
21094  kcs=(-1)**int(1.5d0+pyr(0))
21095  ENDIF
21096 
21097 C...Store flavours of scattering.
21098  mint(13)=kfl1
21099  mint(14)=kfl2
21100  mint(15)=kfl1
21101  mint(16)=kfl2
21102  mint(21)=kfl3
21103  mint(22)=kfl4
21104 
21105 C...Set flavours and mothers of scattering partons.
21106  k(n+1,1)=14
21107  k(n+2,1)=14
21108  k(n+3,1)=3
21109  k(n+4,1)=3
21110  k(n+1,2)=kfl1
21111  k(n+2,2)=kfl2
21112  k(n+3,2)=kfl3
21113  k(n+4,2)=kfl4
21114  k(n+1,3)=mint(83)+1
21115  k(n+2,3)=mint(83)+2
21116  k(n+3,3)=n+1
21117  k(n+4,3)=n+2
21118 
21119 C...Store colour connection indices.
21120  DO 320 j=1,2
21121  jc=j
21122  IF(kcs.EQ.-1) jc=3-j
21123  IF(icol(kcc,1,jc).NE.0) k(n+1,j+3)=n+icol(kcc,1,jc)
21124  IF(icol(kcc,2,jc).NE.0) k(n+2,j+3)=n+icol(kcc,2,jc)
21125  IF(icol(kcc,3,jc).NE.0) k(n+3,j+3)=mstu(5)*(n+icol(kcc,3,jc))
21126  IF(icol(kcc,4,jc).NE.0) k(n+4,j+3)=mstu(5)*(n+icol(kcc,4,jc))
21127  320 CONTINUE
21128 
21129 C...Store incoming and outgoing partons in their CM-frame.
21130  shr=sqrt(tau)*vint(1)
21131  p(n+1,3)=0.5d0*shr
21132  p(n+1,4)=0.5d0*shr
21133  p(n+2,3)=-0.5d0*shr
21134  p(n+2,4)=0.5d0*shr
21135  p(n+3,5)=pymass(k(n+3,2))
21136  p(n+4,5)=pymass(k(n+4,2))
21137  IF(p(n+3,5)+p(n+4,5).GE.shr) GOTO 240
21138  p(n+3,4)=0.5d0*(shr+(p(n+3,5)**2-p(n+4,5)**2)/shr)
21139  p(n+3,3)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,5)**2))
21140  p(n+4,4)=shr-p(n+3,4)
21141  p(n+4,3)=-p(n+3,3)
21142 
21143 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21144  phi=paru(2)*pyr(0)
21145  CALL pyrobo(n+3,n+4,acos(vint(23)),phi,0d0,0d0,0d0)
21146 
21147 C...Set up default values before showers.
21148  mint(31)=mint(31)+1
21149  ipu1=n+1
21150  ipu2=n+2
21151  ipu3=n+3
21152  ipu4=n+4
21153  vint(141)=vint(41)
21154  vint(142)=vint(42)
21155  n=n+4
21156 
21157 C...Showering of initial state partons (optional).
21158 C...Note: no showering of final state partons here; it comes later.
21159  IF(mstp(84).GE.1.AND.mstp(61).GE.1) THEN
21160  mint(51)=0
21161  alamsv=parj(81)
21162  parj(81)=parp(72)
21163  nsav=n
21164  DO 340 i=1,4
21165  DO 330 j=1,5
21166  ksav(i,j)=k(n-4+i,j)
21167  psav(i,j)=p(n-4+i,j)
21168  330 CONTINUE
21169  340 CONTINUE
21170  CALL pysspa(ipu1,ipu2)
21171  parj(81)=alamsv
21172 C...If shower failed then restore to situation before shower.
21173  IF(mint(51).GE.1) THEN
21174  n=nsav
21175  DO 360 i=1,4
21176  DO 350 j=1,5
21177  k(n-4+i,j)=ksav(i,j)
21178  p(n-4+i,j)=psav(i,j)
21179  350 CONTINUE
21180  360 CONTINUE
21181  ipu1=n-3
21182  ipu2=n-2
21183  vint(141)=vint(41)
21184  vint(142)=vint(42)
21185  ENDIF
21186  ENDIF
21187 
21188 C...Keep track of loose colour ends and information on scattering.
21189  370 imi(1,mint(31),1)=ipu1
21190  imi(2,mint(31),1)=ipu2
21191  imi(1,mint(31),2)=0
21192  imi(2,mint(31),2)=0
21193  xmi(1,mint(31))=vint(141)
21194  xmi(2,mint(31))=vint(142)
21195  pt2mi(mint(31))=vint(54)
21196  imisep(mint(31))=n
21197 
21198 C...Decide whether quarks in last scattering were valence, companion or
21199 C...sea.
21200  DO 430 js=1,2
21201  kfbeam=mint(10+js)
21202  kfsbm=isign(1,mint(10+js))
21203  ifl=k(imi(js,mint(31),1),2)
21204  imi(js,mint(31),2)=0
21205  IF (iabs(ifl).GT.6) GOTO 430
21206 
21207 C...Get PDFs at X and Q2 of the parton shower initiator for the
21208 C...last scattering. At this point VINT(143:144) do not yet
21209 C...include the scattered x values VINT(141:142).
21210  x=vint(140+js)/vint(142+js)
21211  IF(mstp(84).GE.1.AND.mstp(61).GE.1) THEN
21212  q2=parp(62)**2
21213  ELSE
21214  q2=vint(54)
21215  ENDIF
21216 C...Note: XPSVC = x*pdf.
21217  mint(30)=js
21218  CALL pypdfu(kfbeam,x,q2,xpq)
21219  sea=xpsvc(ifl,-1)
21220  val=xpsvc(ifl,0)
21221  cmp=0d0
21222  DO 380 ivc=1,nvc(js,ifl)
21223  cmp=cmp+xpsvc(ifl,ivc)
21224  380 CONTINUE
21225 
21226 C...Decide (Extra factor x cancels in the dvision).
21227  rvcs=pyr(0)*(sea+val+cmp)
21228  ivnow=1
21229  390 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
21230 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21231  ivnow=0
21232  IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
21233  IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
21234  IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
21235  IF(kfival(js,1).EQ.0) THEN
21236  IF(kfbeam.EQ.111.AND.iabs(ifl).LE.2) ivnow=1
21237  IF(kfbeam.EQ.22.AND.iabs(ifl).LE.5) ivnow=1
21238  IF((kfbeam.EQ.130.OR.kfbeam.EQ.310).AND.
21239  & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
21240  ELSE
21241  DO 400 i1=1,nmi(js)
21242  IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
21243  & ivnow=ivnow-1
21244  400 CONTINUE
21245  ENDIF
21246  IF(ivnow.EQ.0) GOTO 390
21247 C...Mark valence.
21248  imi(js,mint(31),2)=0
21249 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21250  IF(kfival(js,1).EQ.0) THEN
21251  IF(kfbeam.EQ.111.OR.kfbeam.EQ.22) THEN
21252  kfival(js,1)=ifl
21253  kfival(js,2)=-ifl
21254  ELSEIF(kfbeam.EQ.130.OR.kfbeam.EQ.310) THEN
21255  kfival(js,1)=ifl
21256  IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
21257  IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
21258  ENDIF
21259  ENDIF
21260 
21261  ELSEIF (rvcs.LE.val+sea.OR.nvc(js,ifl).EQ.0) THEN
21262 C...If sea, add opposite sign companion parton. Store X and I.
21263  nvc(js,-ifl)=nvc(js,-ifl)+1
21264  xassoc(js,-ifl,nvc(js,-ifl))=x
21265 C...Set pointer to companion
21266  imi(js,mint(31),2)=-nvc(js,-ifl)
21267  ELSE
21268 C...If companion, decide which one.
21269  cmpsum=val+sea
21270  isel=0
21271  410 isel=isel+1
21272  cmpsum=cmpsum+xpsvc(ifl,isel)
21273  IF (rvcs.GT.cmpsum.AND.isel.LT.nvc(js,ifl)) GOTO 410
21274 C...Find original sea (anti-)quark:
21275  iassoc=0
21276  DO 420 i1=1,nmi(js)
21277  IF (k(imi(js,i1,1),2).NE.-ifl) GOTO 420
21278  IF (-imi(js,i1,2).EQ.isel) THEN
21279  imi(js,mint(31),2)=imi(js,i1,1)
21280  imi(js,i1,2)=imi(js,mint(31),1)
21281  ENDIF
21282  420 CONTINUE
21283 C...Change X to what associated companion had, so that the correct
21284 C...amount of momentum can be subtracted from the companion sum below.
21285  x=xassoc(js,ifl,isel)
21286 C...Mark companion read.
21287  xassoc(js,ifl,isel)=0d0
21288  ENDIF
21289  430 CONTINUE
21290 
21291 C...Global statistics.
21292  mint(351)=mint(351)+1
21293  vint(351)=vint(351)+pt
21294  IF (mint(351).EQ.1) vint(356)=pt
21295 
21296 C...Update remaining energy and other counters.
21297  IF(n.GT.mstu(4)-mstu(32)-10) THEN
21298  CALL pyerrm(11,'(PYMIGN:) no more memory left in PYJETS')
21299  mint(51)=1
21300  RETURN
21301  ENDIF
21302  nmi(1)=nmi(1)+1
21303  nmi(2)=nmi(2)+1
21304  vint(151)=vint(151)+vint(41)
21305  vint(152)=vint(152)+vint(42)
21306  vint(143)=vint(143)-vint(141)
21307  vint(144)=vint(144)-vint(142)
21308 
21309 C...Iterate, with more interactions allowed.
21310  IF(mint(31).LT.240) GOTO 240
21311  440 CONTINUE
21312 
21313 C...Restore saved quantities for hardest interaction.
21314  mint(1)=isubsv
21315  mint(13)=m13sv
21316  mint(14)=m14sv
21317  mint(15)=m15sv
21318  mint(16)=m16sv
21319  mint(21)=m21sv
21320  mint(22)=m22sv
21321  DO 450 j=11,80
21322  vint(j)=vintsv(j)
21323  450 CONTINUE
21324  vint(141)=v141sv
21325  vint(142)=v142sv
21326 
21327  ENDIF
21328 
21329 C...Format statements for printout.
21330  5000 FORMAT(/1x,'****** PYMIGN: initialization of multiple inter',
21331  &'actions for MSTP(82) =',i2,' ******')
21332  5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
21333  &d9.2,' mb: rejected')
21334  5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
21335  &d9.2,' mb: accepted')
21336 
21337  RETURN
21338  END
21339 
21340 C*********************************************************************
21341 
21342 C...PYMIHK
21343 C...Finds left-behind remnant flavour content and hooks up
21344 C...the colour flow between the hard scattering and remnants
21345 
21346  SUBROUTINE pymihk
21347 
21348 C...Double precision and integer declarations.
21349  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21350  IMPLICIT INTEGER(I-N)
21351  INTEGER PYK,PYCHGE,PYCOMP
21352 C...The event record
21353  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
21354 C...Parameters
21355  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
21356  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
21357  common/pypars/mstp(200),parp(200),msti(200),pari(200)
21358  common/pyint1/mint(400),vint(400)
21359 C...The common block of dangling ends
21360  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
21361  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
21362  & xmi(2,240),pt2mi(240),imisep(0:240)
21363  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyintm/
21364 C...Local variables
21365  parameter(nersiz=4000)
21366  COMMON /pycbls/mco(nersiz,2),ncc,jcco(nersiz,2),jccn(nersiz,2)
21367  & ,maccpt
21368  COMMON /pyctag/nct,mct(nersiz,2)
21369  SAVE /pycbls/,/pyctag/
21370  dimension jst(2,3),iv(2,3),idq(3),nvsum(2),nbrtot(2),ng(2)
21371  & ,itjunc(2),mout(2),insr(1000,3),istr(6),ymi(240)
21372  DATA nerrpr/0/
21373  SAVE nerrpr
21374  four(i,j)=p(i,4)*p(j,4)-p(i,3)*p(j,3)-p(i,2)*p(j,2)-p(i,1)*p(j,1)
21375 
21376 C...Set up error checkers
21377  iboost=0
21378 
21379 C...Initialize colour arrays: MCO (Original) and MCT (New)
21380  DO 110 i=mint(84)+1,nersiz
21381  DO 100 jc=1,2
21382  mct(i,jc)=0
21383  mco(i,jc)=0
21384  100 CONTINUE
21385 C...Also zero colour tracing information, if existed.
21386  IF (i.LE.n) THEN
21387  k(i,4)=mod(k(i,4),mstu(5)**2)
21388  k(i,5)=mod(k(i,5),mstu(5)**2)
21389  ENDIF
21390  110 CONTINUE
21391 
21392 C...Initialize colour tag collapse arrays:
21393 C...JCCO (Original) and JCCN (New).
21394  DO 130 mg=mint(84)+1,nersiz
21395  DO 120 jc=1,2
21396  jcco(mg,jc)=0
21397  jccn(mg,jc)=0
21398  120 CONTINUE
21399  130 CONTINUE
21400 
21401 C...Zero gluon insertion array
21402  DO 150 im=1,1000
21403  DO 140 j=1,3
21404  insr(im,j)=0
21405  140 CONTINUE
21406  150 CONTINUE
21407 
21408 C...Compute hard scattering system rapidities
21409  IF (mstp(89).EQ.1) THEN
21410  DO 160 im=1,240
21411  IF (im.LE.mint(31)) THEN
21412  ymi(im)=log(xmi(1,im)/xmi(2,im))
21413  ELSE
21414 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21415  ymi(im)=100d0
21416  ENDIF
21417  160 CONTINUE
21418  ENDIF
21419 
21420 C...Treat each side separately
21421  DO 290 js=1,2
21422 
21423 C...Initialize side.
21424  ng(js)=0
21425  jv=0
21426  kfs=isign(1,mint(10+js))
21427 
21428 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21429  IF(kfival(js,1).EQ.0) THEN
21430  IF(mint(10+js).EQ.111) THEN
21431  kfival(js,1)=int(1.5d0+pyr(0))
21432  kfival(js,2)=-kfival(js,1)
21433  ELSEIF(mint(10+js).EQ.22) THEN
21434  pyrkf=pyr(0)
21435  kfival(js,1)=1
21436  IF(pyrkf.GT.0.1d0) kfival(js,1)=2
21437  IF(pyrkf.GT.0.5d0) kfival(js,1)=3
21438  IF(pyrkf.GT.0.6d0) kfival(js,1)=4
21439  kfival(js,2)=-kfival(js,1)
21440  ELSEIF(mint(10+js).EQ.130.OR.mint(10+js).EQ.310) THEN
21441  IF(pyr(0).GT.0.5d0) THEN
21442  kfival(js,1)=1
21443  kfival(js,2)=-3
21444  ELSE
21445  kfival(js,1)=3
21446  kfival(js,2)=-1
21447  ENDIF
21448  ENDIF
21449  ENDIF
21450 
21451 C...Initialize beam remnant sea and valence content flavour by flavour.
21452  nvsum(js)=0
21453  nbrtot(js)=0
21454  DO 210 jfa=1,6
21455 C...Count up original number of JFA valence quarks and antiquarks.
21456  nvalq=0
21457  nvalqb=0
21458  nsea=0
21459  DO 170 j=1,3
21460  IF(kfival(js,j).EQ.jfa) nvalq=nvalq+1
21461  IF(kfival(js,j).EQ.-jfa) nvalqb=nvalqb+1
21462  170 CONTINUE
21463  nvsum(js)=nvsum(js)+nvalq+nvalqb
21464 C...Subtract kicked out valence and determine sea from flavour cons.
21465  DO 180 im=1,nmi(js)
21466  ifl = k(imi(js,im,1),2)
21467  ifa = iabs(ifl)
21468  ifs = isign(1,ifl)
21469  IF (ifl.EQ.jfa.AND.imi(js,im,2).EQ.0) THEN
21470 C...Subtract K.O. valence quark from remainder.
21471  nvalq=nvalq-1
21472  jv=nvsum(js)-nvalq-nvalqb
21473  iv(js,jv)=imi(js,im,1)
21474  ELSEIF (ifl.EQ.-jfa.AND.imi(js,im,2).EQ.0) THEN
21475 C...Subtract K.O. valence antiquark from remainder.
21476  nvalqb=nvalqb-1
21477  jv=nvsum(js)-nvalq-nvalqb
21478  iv(js,jv)=imi(js,im,1)
21479  ELSEIF (ifa.EQ.jfa) THEN
21480 C...Outside sea without companion: add opposite sea flavour inside.
21481  IF (imi(js,im,2).LT.0) nsea=nsea-ifs
21482  ENDIF
21483  180 CONTINUE
21484 C...Check if space left in PYJETS for additional BR flavours
21485  nflsum=iabs(nsea)+nvalq+nvalqb
21486  nbrtot(js)=nbrtot(js)+nflsum
21487  IF (n+nflsum+1.GT.mstu(4)) THEN
21488  CALL pyerrm(11,'(PYMIHK:) no more memory left in PYJETS')
21489  mint(51)=1
21490  RETURN
21491  ENDIF
21492 C...Add required val+sea content to beam remnant.
21493  IF (nflsum.GT.0) THEN
21494  DO 200 ia=1,nflsum
21495 C...Insert beam remnant quark as p.t. symbolic parton in ER.
21496  n=n+1
21497  DO 190 ix=1,5
21498  k(n,ix)=0
21499  p(n,ix)=0d0
21500  v(n,ix)=0d0
21501  190 CONTINUE
21502  k(n,1)=3
21503  k(n,2)=isign(jfa,nsea)
21504  IF (ia.LE.nvalq) k(n,2)=jfa
21505  IF (ia.GT.nvalq.AND.ia.LE.nvalq+nvalqb) k(n,2)=-jfa
21506  k(n,3)=mint(83)+js
21507 C...Also update NMI, IMI, and IV arrays.
21508  nmi(js)=nmi(js)+1
21509  imi(js,nmi(js),1)=n
21510  imi(js,nmi(js),2)=-1
21511  IF (ia.LE.nvalq+nvalqb) THEN
21512  imi(js,nmi(js),2)=0
21513  jv=jv+1
21514  iv(js,jv)=imi(js,nmi(js),1)
21515  ENDIF
21516  200 CONTINUE
21517  ENDIF
21518  210 CONTINUE
21519 
21520  im=0
21521  220 im=im+1
21522  IF (im.LE.nmi(js)) THEN
21523  IF (k(imi(js,im,1),2).EQ.21) THEN
21524  ng(js)=ng(js)+1
21525 C...Add fictitious parent gluons for companion pairs.
21526  ELSEIF (imi(js,im,2).NE.0.AND.k(imi(js,im,1),2).GT.0) THEN
21527 C...Randomly assign companions to sea quarks which have none.
21528  IF (imi(js,im,2).LT.0) THEN
21529  imc=pyr(0)*nmi(js)
21530  230 imc=mod(imc,nmi(js))+1
21531  IF (k(imi(js,imc,1),2).NE.-k(imi(js,im,1),2)) GOTO 230
21532  IF (imi(js,imc,2).GE.0) GOTO 230
21533  imi(js, im,2) = imi(js,imc,1)
21534  imi(js,imc,2) = imi(js, im,1)
21535  ENDIF
21536 C...Add fictitious parent gluon
21537  n=n+1
21538  DO 240 ix=1,5
21539  k(n,ix)=0
21540  p(n,ix)=0d0
21541  v(n,ix)=0d0
21542  240 CONTINUE
21543  k(n,1)=14
21544  k(n,2)=21
21545  k(n,3)=mint(83)+js
21546 C...Set gluon (anti-)colour daughter pointers
21547  k(n,4)=imi(js, im,1)
21548  k(n,5)=imi(js, im,2)
21549 C...Set quark (anti-)colour parent pointers
21550  k(imi(js, im,2),5)=k(imi(js, im,2),5)+mstu(5)*n
21551  k(imi(js, im,1),4)=k(imi(js, im,1),4)+mstu(5)*n
21552 C...Add gluon to IMI
21553  nmi(js)=nmi(js)+1
21554  imi(js,nmi(js),1)=n
21555  imi(js,nmi(js),2)=0
21556  ENDIF
21557  GOTO 220
21558  ENDIF
21559 
21560 C...If incoming (anti-)baryon, insert inside (anti-)junction.
21561 C...Set up initial v-v-j-v configuration. Otherwise set up
21562 C...mesonic v-vbar configuration
21563  IF (iabs(mint(10+js)).GT.1000) THEN
21564 C...Determine junction type (1: B=1 2: B=-1)
21565  itjunc(js) = (3-kfs)/2
21566 C...Insert junction.
21567  n=n+1
21568  DO 250 ix=1,5
21569  k(n,ix)=0
21570  p(n,ix)=0d0
21571  v(n,ix)=0d0
21572  250 CONTINUE
21573 C...Set special junction codes:
21574  k(n,1)=42
21575  k(n,2)=88
21576 C...Set parent to side.
21577  k(n,3)=mint(83)+js
21578  k(n,4)=itjunc(js)*mstu(5)
21579  k(n,5)=0
21580 C...Connect valence quarks to junction.
21581  mout(js)=0
21582  manti=itjunc(js)-1
21583 C...Set (anti)colour mother = junction.
21584  DO 260 jv=1,3
21585  k(iv(js,jv),4+manti)=mod(k(iv(js,jv),4+manti),mstu(5))
21586  & +mstu(5)*n
21587 C...Keep track of partons adjacent to junction:
21588  jst(js,jv)=iv(js,jv)
21589  260 CONTINUE
21590  ELSE
21591 C...Mesons: set up initial q-qbar topology
21592  itjunc(js)=0
21593  IF (k(iv(js,1),2).GT.0) THEN
21594  iq=iv(js,1)
21595  iqbar=iv(js,2)
21596  ELSE
21597  iq=iv(js,2)
21598  iqbar=iv(js,1)
21599  ENDIF
21600  iv(js,3)=0
21601  jst(js,1)=iq
21602  jst(js,2)=iqbar
21603  jst(js,3)=0
21604  k(iq,4)=mod(k(iq,4),mstu(5))+mstu(5)*iqbar
21605  k(iqbar,5)=mod(k(iqbar,5),mstu(5))+mstu(5)*iq
21606 C...Special for mesons. Insert gluon if BR empty.
21607  IF (nbrtot(js).EQ.0) THEN
21608  n=n+1
21609  DO 270 ix=1,5
21610  k(n,ix)=0
21611  p(n,ix)=0d0
21612  v(n,ix)=0d0
21613  270 CONTINUE
21614  k(n,1)=3
21615  k(n,2)=21
21616  k(n,3)=mint(83)+js
21617  k(n,4)=0
21618  k(n,5)=0
21619  nbrtot(js)=1
21620  ng(js)=ng(js)+1
21621 C...Add gluon to IMI
21622  nmi(js)=nmi(js)+1
21623  imi(js,nmi(js),1)=n
21624  imi(js,nmi(js),2)=0
21625  ENDIF
21626  mout(js)=0
21627  ENDIF
21628 
21629 C...Count up number of valence quarks outside BR.
21630  DO 280 jv=1,3
21631  IF (jst(js,jv).LE.mint(53).AND.jst(js,jv).GT.0)
21632  & mout(js)=mout(js)+1
21633  280 CONTINUE
21634 
21635  290 CONTINUE
21636 
21637 C...Now both sides have been prepared in an initial vvjv (baryonic) or
21638 C...v(g)vbar (mesonic) configuration.
21639 
21640 C...Create colour line tags starting from initiators.
21641  nct=0
21642  DO 320 im=1,mint(31)
21643 C...Consider each side in turn.
21644  DO 310 js=1,2
21645  i1=imi(js,im,1)
21646  i2=imi(3-js,im,1)
21647  DO 300 jcs=4,5
21648  IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
21649  & GOTO 300
21650  IF (k(i1,jcs)/mstu(5)**2.NE.0) GOTO 300
21651 
21652  kcs=jcs
21653  CALL pycttr(i1,kcs,i2)
21654  IF(mint(51).NE.0) RETURN
21655 
21656  300 CONTINUE
21657  310 CONTINUE
21658  320 CONTINUE
21659 
21660  DO 340 js=1,2
21661 C...Create colour tags for beam remnant partons.
21662  DO 330 im=mint(31)+1,nmi(js)
21663  ip=imi(js,im,1)
21664  IF (k(ip,2).NE.21) THEN
21665  jc=(3-isign(1,k(ip,2)))/2
21666  IF (mct(ip,jc).EQ.0) THEN
21667  nct=nct+1
21668  mct(ip,jc)=nct
21669  ENDIF
21670  ELSE
21671 C...Gluons
21672  icd=k(ip,4)
21673  iad=k(ip,5)
21674  IF (icd.NE.0) THEN
21675 C...Fictituous gluons just inherit from their quark daughters.
21676  icc=mct(icd,1)
21677  iac=mct(iad,2)
21678  ELSE
21679 C...Real beam remnant gluons get their own colours
21680  icc=nct+1
21681  iac=nct+2
21682  nct=nct+2
21683  ENDIF
21684  mct(ip,1)=icc
21685  mct(ip,2)=iac
21686  ENDIF
21687  330 CONTINUE
21688  340 CONTINUE
21689 
21690 C...Create colour tags for colour lines which are detached from the
21691 C...initial state.
21692 
21693  DO 360 mqgst=1,2
21694  DO 350 i=mint(84)+1,n
21695 
21696 C...Look for coloured string endpoint, or (later) leftover gluon.
21697  IF (k(i,1).NE.3) GOTO 350
21698  kc=pycomp(k(i,2))
21699  IF(kc.EQ.0) GOTO 350
21700  kq=kchg(kc,2)
21701  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 350
21702 
21703 C...Pick up loose string end with no previous tag.
21704  kcs=4
21705  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
21706  IF(mct(i,kcs-3).NE.0) GOTO 350
21707 
21708  CALL pycttr(i,kcs,i)
21709  IF(mint(51).NE.0) RETURN
21710 
21711  350 CONTINUE
21712  360 CONTINUE
21713 
21714 C...Store original colour tags
21715  DO 370 i=mint(84)+1,n
21716  mco(i,1)=mct(i,1)
21717  mco(i,2)=mct(i,2)
21718  370 CONTINUE
21719 
21720 C...Iteratively add gluons to already existing string pieces, enforcing
21721 C...various possible orderings, and rejecting insertions that would give
21722 C...rise to singlet gluons.
21723 C...<kappa tau> normalization.
21724  rm0=1.5d0
21725  mretry=0
21726  parp80=parp(80)
21727 
21728 C...Set up simplified kinematics.
21729 C...Boost hard interaction systems.
21730  iboost=iboost+1
21731  DO 380 im=1,mint(31)
21732  beta=(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
21733  CALL pyrobo(imisep(im-1)+1,imisep(im),0d0,0d0,0d0,0d0,beta)
21734  380 CONTINUE
21735 C...Assign preliminary beam remnant momenta.
21736  DO 390 i=mint(53)+1,n
21737  js=k(i,3)
21738  p(i,1)=0d0
21739  p(i,2)=0d0
21740  IF (k(i,2).NE.88) THEN
21741  p(i,4)=0.5d0*vint(142+js)*vint(1)/max(1,nmi(js)-mint(31))
21742  p(i,3)=p(i,4)
21743  IF (js.EQ.2) p(i,3)=-p(i,3)
21744  ELSE
21745 C...Junctions are wildcards for the present.
21746  p(i,4)=0d0
21747  p(i,3)=0d0
21748  ENDIF
21749  390 CONTINUE
21750 
21751 C...Reset colour processing information.
21752  400 DO 410 i=mint(84)+1,n
21753  k(i,4)=mod(k(i,4),mstu(5)**2)
21754  k(i,5)=mod(k(i,5),mstu(5)**2)
21755  410 CONTINUE
21756 
21757  ncc=0
21758  DO 430 js=1,2
21759 C...If meson, without gluon in BR, collapse q-qbar colour tags:
21760  IF (itjunc(js).EQ.0) THEN
21761  jc1=mct(jst(js,1),1)
21762  jc2=mct(jst(js,2),2)
21763  ncc=ncc+1
21764  jcco(ncc,1)=max(jc1,jc2)
21765  jcco(ncc,2)=min(jc1,jc2)
21766 C...Collapse colour tags in event record
21767  DO 420 i=mint(84)+1,n
21768  IF (mct(i,1).EQ.jcco(ncc,1)) mct(i,1)=jcco(ncc,2)
21769  IF (mct(i,2).EQ.jcco(ncc,1)) mct(i,2)=jcco(ncc,2)
21770  420 CONTINUE
21771  ENDIF
21772  430 CONTINUE
21773 
21774  440 js=1
21775  IF (pyr(0).GT.0.5d0.OR.ng(1).EQ.0) js=2
21776  IF (ng(js).GT.0) THEN
21777  nopt=0
21778  rlopt=1d9
21779 C...Start at random gluon (optimizes speed for random attachments)
21780  nmgl=0
21781  imgl=pyr(0)*nmi(js)+1
21782  450 imgl=mod(imgl,nmi(js))+1
21783  nmgl=nmgl+1
21784 C...Only loop through NMI once (with upper limit to save time)
21785  IF (nmgl.LE.nmi(js).AND.nopt.LE.3) THEN
21786  igl = imi(js,imgl,1)
21787 C...If not gluon or if already connected, try next.
21788  IF (k(igl,2).NE.21.OR.k(igl,4)/mstu(5).NE.0
21789  & .OR.k(igl,5)/mstu(5).NE.0) GOTO 450
21790 C...Now loop through all possible insertions of this gluon.
21791  nmp1=0
21792  imp1=pyr(0)*nmi(js)+1
21793  460 imp1=mod(imp1,nmi(js))+1
21794  nmp1=nmp1+1
21795  IF (imp1.EQ.imgl) GOTO 460
21796 C...Only loop through NMI once (with upper limit to save time).
21797  IF (nmp1.LE.nmi(js).AND.nopt.LE.3) THEN
21798  ip1 = imi(js,imp1,1)
21799 C...Try both colour mother and colour anti-mother.
21800 C...Randomly select which one to try first.
21801  nanti=0
21802  manti=pyr(0)*2
21803  470 manti=mod(manti+1,2)
21804  nanti=nanti+1
21805  IF (nanti.LE.2) THEN
21806  ip2 =mod(k(ip1,4+manti)/mstu(5),mstu(5))
21807 C...Reject if no appropriate mother (or if mother is fictitious
21808 C...parent gluon.)
21809  IF (ip2.LE.0) GOTO 470
21810  IF (k(ip2,2).EQ.21.AND.ip2.GT.mint(53)) GOTO 470
21811 C...Also reject if this link has already been tried.
21812  IF (k(ip1,4+manti)/mstu(5)**2.EQ.2) GOTO 470
21813  IF (k(ip2,5-manti)/mstu(5)**2.EQ.2) GOTO 470
21814 C...Set flag to indicate that this link has now been tried for this
21815 C...gluon. IP2 may be junction, which has several mothers.
21816  k(ip1,4+manti)=k(ip1,4+manti)+2*mstu(5)**2
21817  IF (k(ip2,2).NE.88) THEN
21818  k(ip2,5-manti)=k(ip2,5-manti)+2*mstu(5)**2
21819  ENDIF
21820 
21821 C...JCG1: Original colour tag of gluon on IP1 side
21822 C...JCG2: Original colour tag of gluon on IP2 side
21823 C...JCP1: Original colour tag of IP1 on gluon side
21824 C...JCP2: Original colour tag of IP2 on gluon side.
21825  jcg1=mco(igl,2-manti)
21826  jcg2=mco(igl,1+manti)
21827  jcp1=mco(ip1,1+manti)
21828  jcp2=mco(ip2,2-manti)
21829 
21830  CALL pymihg(jcp1,jcg1,jcp2,jcg2)
21831 C...Reject gluon attachments that give rise to singlet gluons.
21832  IF (maccpt.EQ.0) GOTO 470
21833 
21834 C...Update colours
21835  jcg1=mct(igl,2-manti)
21836  jcg2=mct(igl,1+manti)
21837  jcp1=mct(ip1,1+manti)
21838  jcp2=mct(ip2,2-manti)
21839 
21840 C...Select whether to accept this insertion
21841  IF (mstp(89).EQ.0) THEN
21842 C...Random insertions: no measure.
21843  rl=1d0
21844 C...For random ordering, we want to suppress beam remnant breakups
21845 C...already at this point.
21846  IF (ip1.GT.mint(53).AND.ip2.GT.mint(53)
21847  & .AND.mout(js).NE.0.AND.pyr(0).GT.parp80) THEN
21848  nmp1=0
21849  nmgl=0
21850  GOTO 470
21851  ENDIF
21852  ELSEIF (mstp(89).EQ.1) THEN
21853 C...Rapidity ordering:
21854 C...YGL = Rapidity of gluon.
21855  ygl=ymi(imgl)
21856 C...If fictitious gluon
21857  IF (ygl.EQ.100d0) THEN
21858  ygl=(3-2*js)*100d0
21859  ida1=mod(k(igl,4),mstu(5))
21860  ida2=mod(k(igl,5),mstu(5))
21861  DO 480 imt=1,nmi(js)
21862 C...Select (arbitrarily) the most central daughter.
21863  IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2)
21864  & THEN
21865  IF (abs(ygl).GT.abs(ymi(imt))) ygl=ymi(imt)
21866  ENDIF
21867  480 CONTINUE
21868  ENDIF
21869 C...YP1 = Rapidity IP1
21870  yp1=ymi(imp1)
21871 C...If fictitious gluon
21872  IF (yp1.EQ.100d0) THEN
21873  yp1=(3-2*js)*yp1
21874  ida1=mod(k(ip1,4),mstu(5))
21875  ida2=mod(k(ip1,5),mstu(5))
21876  DO 490 imt=1,nmi(js)
21877 C...Select (arbitrarily) the most central daughter.
21878  IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2)
21879  & THEN
21880  IF (abs(yp1).GT.abs(ymi(imt))) yp1=ymi(imt)
21881  ENDIF
21882  490 CONTINUE
21883  ENDIF
21884 C...YP2 = Rapidity of mother system
21885  IF (k(ip2,2).NE.88) THEN
21886  DO 500 imt=1,nmi(js)
21887  IF (imi(js,imt,1).EQ.ip2) yp2=ymi(imt)
21888  500 CONTINUE
21889 C...If fictitious gluon
21890  IF (yp2.EQ.100d0) THEN
21891  yp2=(3-2*js)*yp2
21892  ida1=mod(k(ip2,4),mstu(5))
21893  ida2=mod(k(ip2,5),mstu(5))
21894  DO 510 imt=1,nmi(js)
21895 C...Select (arbitrarily) the most central daughter.
21896  IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2
21897  & ) THEN
21898  IF (abs(yp2).GT.abs(ymi(imt))) yp2=ymi(imt)
21899  ENDIF
21900  510 CONTINUE
21901  ENDIF
21902 C...Assign (arbitrarily) 100D0 to junction also
21903  ELSE
21904  yp2=(3-2*js)*100d0
21905  ENDIF
21906  rl=abs(ygl-yp1)+abs(ygl-yp2)
21907  ELSEIF (mstp(89).EQ.2) THEN
21908 C...Lambda ordering:
21909 C...Compute lambda measure for this insertion.
21910  rl=1d0
21911  DO 520 ist=1,6
21912  istr(ist)=0
21913  520 CONTINUE
21914 C...If IP2 is junction, not caught below.
21915  IF (jcp2.EQ.0) THEN
21916  itju=mod(k(ip2,4)/mstu(5),mstu(5))
21917 C...Anti-junction is colour endpoint et vv., always on JCG2.
21918  istr(5-itju)=ip2
21919  ENDIF
21920  DO 530 i=mint(84)+1,n
21921  IF (k(i,1).LT.10) THEN
21922 C...The new string pieces
21923  IF (mct(i,1).EQ.jcg1) istr(1)=i
21924  IF (mct(i,2).EQ.jcg1) istr(2)=i
21925  IF (mct(i,1).EQ.jcg2) istr(3)=i
21926  IF (mct(i,2).EQ.jcg2) istr(4)=i
21927  ENDIF
21928  530 CONTINUE
21929 C...Also identify junctions as string endpoints.
21930  DO 540 i=mint(84)+1,n
21931  icmo=mod(k(i,4)/mstu(5),mstu(5))
21932  iamo=mod(k(i,5)/mstu(5),mstu(5))
21933 C...Find partons adjacent to junctions.
21934  IF (icmo.GT.0.AND.icmo.LE.n) THEN
21935  IF (k(icmo,1).EQ.42.AND.mct(i,1).EQ.jcg1.AND.istr(2)
21936  & .EQ.0) istr(2) = icmo
21937  IF (k(icmo,1).EQ.42.AND.mct(i,1).EQ.jcg2.AND.istr(4)
21938  & .EQ.0) istr(4) = icmo
21939  ENDIF
21940  IF (iamo.GT.0.AND.iamo.LE.n) THEN
21941  IF (k(iamo,1).EQ.42.AND.mct(i,2).EQ.jcg1.AND.istr(1)
21942  & .EQ.0) istr(1) = iamo
21943  IF (k(iamo,1).EQ.42.AND.mct(i,2).EQ.jcg2.AND.istr(3)
21944  & .EQ.0) istr(3) = iamo
21945  ENDIF
21946  540 CONTINUE
21947 C...The old string piece
21948  istr(5)=istr(1+2*manti)
21949  istr(6)=istr(4-2*manti)
21950  IF (istr(1).EQ.0.OR.istr(2).EQ.0.OR.istr(3).EQ.0.OR.
21951  & istr(4).EQ.0.OR.istr(5).EQ.0.OR.istr(6).EQ.0) THEN
21952 C...If one or more of the colour tags for this connection is/are still
21953 C...dangling, skip this attempt for the time being.
21954  rl=1d6
21955  ELSE
21956  rl=max(1d0,four(istr(1),istr(2)))*max(1d0,four(istr(3)
21957  & ,istr(4)))/max(1d0,four(istr(5),istr(6)))
21958  rl=log(rl)
21959  ENDIF
21960  ENDIF
21961 C...Allow some breadth to speed things up.
21962  IF (abs(1d0-rl/rlopt).LT.0.05d0) THEN
21963  nopt=nopt+1
21964  ELSEIF (rl.GT.rlopt) THEN
21965  GOTO 470
21966  ELSE
21967  nopt=1
21968  rlopt=rl
21969  ENDIF
21970 C...INSR(NOPT,1)=Gluon colour mother
21971 C...INSR(NOPT,2)=Gluon
21972 C...INSR(NOPT,3)=Gluon anticolour mother
21973  IF (nopt.GT.1000) GOTO 470
21974  insr(nopt,1+2*manti)=ip2
21975  insr(nopt,2)=igl
21976  insr(nopt,3-2*manti)=ip1
21977  IF (mstp(89).GT.0.OR.nopt.EQ.0) GOTO 470
21978  ENDIF
21979  IF (mstp(89).GT.0.OR.nopt.EQ.0) GOTO 460
21980  ENDIF
21981 C...Reset link test information.
21982  DO 550 i=mint(84)+1,n
21983  k(i,4)=mod(k(i,4),mstu(5)**2)
21984  k(i,5)=mod(k(i,5),mstu(5)**2)
21985  550 CONTINUE
21986  IF (mstp(89).GT.0.OR.nopt.EQ.0) GOTO 450
21987  ENDIF
21988 C...Now we have a list of best gluon insertions, none of which cause
21989 C...singlets to arise. If list is empty, try again a few times. Note:
21990 C...this should never happen if we have a meson with a gluon inserted
21991 C...in the beam remnant, since that breaks up the colour line.
21992  IF (nopt.EQ.0) THEN
21993 C...Abandon BR-g-BR suppression for retries. This is not serious, it
21994 C...just means we happened to start with trying a bad sequence.
21995  parp80=1d0
21996  IF (mretry.LE.10.AND.(itjunc(1).NE.0.OR.jst(1,3).EQ.0).and
21997  & .(itjunc(2).NE.0.OR.jst(2,3).EQ.0)) THEN
21998  mretry=mretry+1
21999  DO 590 js=1,2
22000  IF (itjunc(js).NE.0) THEN
22001  jst(js,1)=iv(js,1)
22002  jst(js,2)=iv(js,2)
22003  jst(js,3)=iv(js,3)
22004 C...Reset valence quark parent pointers
22005  DO 560 i=mint(53)+1,n
22006  IF (k(i,2).EQ.88.AND.k(i,3).EQ.js) iju=i
22007  560 CONTINUE
22008  manti=itjunc(js)-1
22009 C...Set (anti)colour mother = junction.
22010  DO 570 jv=1,3
22011  k(iv(js,jv),4+manti)=mod(k(iv(js,jv),4+manti),mstu(5))
22012  & +mstu(5)*iju
22013  570 CONTINUE
22014  ELSE
22015 C...Same for mesons. JST unchanged, so needn't be restored.
22016  iq=jst(js,1)
22017  iqbar=jst(js,2)
22018  k(iq,4)=mod(k(iq,4),mstu(5))+mstu(5)*iqbar
22019  k(iqbar,5)=mod(k(iqbar,5),mstu(5))+mstu(5)*iq
22020  ENDIF
22021 C...Also reset gluon parent pointers.
22022  ng(js)=0
22023  DO 580 im=1,nmi(js)
22024  i=imi(js,im,1)
22025  IF (k(i,2).EQ.21) THEN
22026  k(i,4)=mod(k(i,4),mstu(5))
22027  k(i,5)=mod(k(i,5),mstu(5))
22028  ng(js)=ng(js)+1
22029  ENDIF
22030  580 CONTINUE
22031  590 CONTINUE
22032 C...Reset colour tags
22033  DO 600 i=mint(84)+1,n
22034  mct(i,1)=mco(i,1)
22035  mct(i,2)=mco(i,2)
22036  600 CONTINUE
22037  GOTO 400
22038  ELSE
22039  IF(nerrpr.LT.5) THEN
22040  nerrpr=nerrpr+1
22041  CALL pylist(4)
22042  CALL pyerrm(19,'(PYMIHK:) No physical colour flow found!')
22043  WRITE(mstu(11),*) 'NG:', ng,' MOUT:', mout(js)
22044  ENDIF
22045 C...Kill event and start another.
22046  mint(51)=1
22047  RETURN
22048  ENDIF
22049  ELSE
22050 C...Select between insertions, suppressing insertions wholly in the BR.
22051  iin=pyr(0)*nopt+1
22052  610 iin=mod(iin,nopt)+1
22053  IF (insr(iin,1).GT.mint(53).AND.insr(iin,3).GT.mint(53)
22054  & .AND.mout(js).NE.0.AND.pyr(0).GT.parp80) GOTO 610
22055  ENDIF
22056 
22057 C...Now we know which gluon to insert where. Colour tags in JCCO and
22058 C...colour connection information should be updated, NG(JS) should be
22059 C...counted down, and a new loop performed if there are still gluons
22060 C...left on any side.
22061  icm=insr(iin,1)
22062  iacm=insr(iin,3)
22063  igl=insr(iin,2)
22064 C...JCG : Original gluon colour tag
22065 C...JCAG: Original gluon anticolour tag.
22066 C...JCM : Original anticolour tag of gluon colour mother
22067 C...JACM: Original colour tag of gluon anticolour mother
22068  jcg=mco(igl,1)
22069  jcm=mco(icm,2)
22070  jacg=mco(igl,2)
22071  jacm=mco(iacm,1)
22072 
22073  CALL pymihg(jacm,jacg,jcm,jcg)
22074  IF (maccpt.EQ.0) THEN
22075  IF(nerrpr.LT.5) THEN
22076  nerrpr=nerrpr+1
22077  CALL pylist(4)
22078  CALL pyerrm(11,'(PYMIHK:) Unphysical colour flow!')
22079  WRITE(mstu(11),*) 'attaching', igl,' between', icm, iacm
22080  ENDIF
22081 C...Kill event and start another.
22082  mint(51)=1
22083  RETURN
22084  ELSE
22085 C...If everything went fine, store new JCCN in JCCO.
22086  ncc=ncc+1
22087  DO 620 icc=1,ncc
22088  jcco(icc,1)=jccn(icc,1)
22089  jcco(icc,2)=jccn(icc,2)
22090  620 CONTINUE
22091  ENDIF
22092 
22093 C...One gluon attached is counted as equivalent to one end outside.
22094  mout(js)=1
22095 C...Set IGL colour mother = ICM.
22096  k(igl,4)=mod(k(igl,4),mstu(5))+mstu(5)*icm
22097 C...Set ICM anticolour mother = IGL colour.
22098  IF (k(icm,2).NE.88) THEN
22099  k(icm,5)=mod(k(icm,5),mstu(5))+mstu(5)*igl
22100  ELSE
22101 C...If ICM is junction, just update JST array for now.
22102  DO 630 msj=1,3
22103  IF (jst(js,msj).EQ.iacm) jst(js,msj)=igl
22104  630 CONTINUE
22105  ENDIF
22106 C...Set IGL anticolour mother = IACM.
22107  k(igl,5)=mod(k(igl,5),mstu(5))+mstu(5)*iacm
22108 C...Set IACM anticolour mother = IGL anticolour.
22109  IF (k(iacm,2).NE.88) THEN
22110  k(iacm,4)=mod(k(iacm,4),mstu(5))+mstu(5)*igl
22111  ELSE
22112 C...If IACM is junction, just update JST array for now.
22113  DO 640 msj=1,3
22114  IF (jst(js,msj).EQ.icm) jst(js,msj)=igl
22115  640 CONTINUE
22116  ENDIF
22117 C...Count down # unconnected gluons.
22118  ng(js)=ng(js)-1
22119  ENDIF
22120  IF (ng(1).GT.0.OR.ng(2).GT.0) GOTO 440
22121 
22122  DO 840 js=1,2
22123 C...Collapse fictitious gluons.
22124  DO 670 igl=mint(53)+1,n
22125  IF (k(igl,2).EQ.21.AND.k(igl,3).EQ.mint(83)+js.AND.
22126  & k(igl,1).EQ.14) THEN
22127  icm=k(igl,4)/mstu(5)
22128  iam=k(igl,5)/mstu(5)
22129  icd=mod(k(igl,4),mstu(5))
22130  iad=mod(k(igl,5),mstu(5))
22131 C...Set gluon daughters pointing to gluon mothers
22132  k(iad,5)=mod(k(iad,5),mstu(5))+mstu(5)*iam
22133  k(icd,4)=mod(k(icd,4),mstu(5))+mstu(5)*icm
22134 C...Set gluon mothers pointing to gluon daughters.
22135  IF (k(icm,2).NE.88) THEN
22136  k(icm,5)=mod(k(icm,5),mstu(5))+mstu(5)*icd
22137  ELSE
22138 C...Special case: mother=junction. Just update JST array for now.
22139  DO 650 msj=1,3
22140  IF (jst(js,msj).EQ.igl) jst(js,msj)=icd
22141  650 CONTINUE
22142  ENDIF
22143  IF (k(iam,2).NE.88) THEN
22144  k(iam,4)=mod(k(iam,4),mstu(5))+mstu(5)*iad
22145  ELSE
22146  DO 660 msj=1,3
22147  IF (jst(js,msj).EQ.igl) jst(js,msj)=iad
22148  660 CONTINUE
22149  ENDIF
22150  ENDIF
22151  670 CONTINUE
22152 
22153 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22154  im=nmi(js)+1
22155  680 im=im-1
22156  IF (im.GT.mint(31).AND.k(imi(js,im,1),2).NE.21) GOTO 680
22157  IF (im.GT.mint(31)) THEN
22158  nmi(js)=nmi(js)-1
22159  DO 690 imr=im,nmi(js)
22160  imi(js,imr,1)=imi(js,imr+1,1)
22161  imi(js,imr,2)=imi(js,imr+1,2)
22162  690 CONTINUE
22163  GOTO 680
22164  ENDIF
22165 
22166 C...Finally, connect junction.
22167  IF (itjunc(js).NE.0) THEN
22168  DO 700 i=mint(53)+1,n
22169  IF (k(i,2).EQ.88.AND.k(i,3).EQ.mint(83)+js) iju=i
22170  700 CONTINUE
22171 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22172  nbrjq =0
22173  nbrvq =0
22174  DO 720 msj=1,3
22175  idq(msj)=0
22176 C...Find jq with no glue inbetween inside beam remnant.
22177  IF (jst(js,msj).GT.mint(53).AND.iabs(k(jst(js,msj),2)).LE.5)
22178  & THEN
22179  nbrjq=nbrjq+1
22180 C...Set IDQ = -I if q non-valence and = +I if q valence.
22181  idq(nbrjq)=-jst(js,msj)
22182  DO 710 jv=1,3
22183  IF (iv(js,jv).EQ.jst(js,msj)) THEN
22184  idq(nbrjq)=jst(js,msj)
22185  nbrvq=nbrvq+1
22186  ENDIF
22187  710 CONTINUE
22188  ENDIF
22189  i12=mod(msj+1,2)
22190  i45=5
22191  IF (msj.EQ.3) i45=4
22192  k(iju,i45)=k(iju,i45)+(mstu(5)**i12)*jst(js,msj)
22193  720 CONTINUE
22194 
22195 C...Check if diquark can be formed.
22196  IF ((mstp(88).GE.0.AND.nbrvq.GE.2).OR.(nbrjq.GE.2.AND.mstp(88)
22197  & .GE.1)) THEN
22198 C...If there is less than 2 valence quarks connected to junction
22199 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22200  IF (nbrvq.LE.1) THEN
22201  ndiq=nbrvq
22202  730 jflip=nbrjq*pyr(0)+1
22203  IF (idq(jflip).LT.0) THEN
22204  idq(jflip)=-idq(jflip)
22205  ndiq=ndiq+1
22206  ENDIF
22207  IF (ndiq.LE.1) GOTO 730
22208  ENDIF
22209 C...Place selected quarks first in IDQ, ordered in flavour.
22210  DO 740 jdq=1,3
22211  IF (idq(jdq).LE.0) THEN
22212  itemp1 = idq(jdq)
22213  idq(jdq)= idq(3)
22214  idq(3) = -itemp1
22215  IF (iabs(k(idq(1),2)).LT.iabs(k(idq(2),2))) THEN
22216  itemp1 = idq(1)
22217  idq(1) = idq(2)
22218  idq(2) = itemp1
22219  ENDIF
22220  ENDIF
22221  740 CONTINUE
22222 C...Choose diquark spin.
22223  IF (nbrvq.EQ.2) THEN
22224 C...If the selected quarks are both valence, we may use SU(6) rules
22225 C...to figure out which spin the diquark has, by a subdivision of the
22226 C...original beam hadron into the selected diquark system plus a kicked
22227 C...out quark, IKO.
22228  jko=6
22229  DO 760 jdq=1,2
22230  DO 750 jv=1,3
22231  IF (idq(jdq).EQ.iv(js,jv)) jko=jko-jv
22232  750 CONTINUE
22233  760 CONTINUE
22234  iko=iv(js,jko)
22235  CALL pyspli(mint(10+js),k(iko,2),kfdum,kfdq)
22236  ELSE
22237 C...If one or more of the selected quarks are not valence, we cannot use
22238 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22239 C...flavours of the diquark already selected, we assume for now
22240 C...50:50 spin-1:spin-0 (where spin-0 possible).
22241  kfdq=1000*k(idq(1),2)+100*k(idq(2),2)
22242  is=3
22243  IF (k(idq(1),2).NE.k(idq(2),2).AND.
22244  & (1d0+3d0*parj(4))*pyr(0).LT.1d0) is=1
22245  kfdq=kfdq+isign(is,kfdq)
22246  ENDIF
22247 
22248 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22249 C...Note: third quark can per definition not also be valence,
22250 C...therefore we can only do this if we are allowed to use sea quarks.
22251  770 IF (idq(3).NE.0.AND.mstp(88).GE.2) THEN
22252  ntry=0
22253  780 ntry=ntry+1
22254  CALL pykfdi(kfdq,k(iabs(idq(3)),2),kfdum,kfbar)
22255  IF (kfbar.EQ.0.AND.ntry.LE.100) THEN
22256  GOTO 780
22257  ELSEIF(ntry.GT.100) THEN
22258 C...If no baryon can be found, give up and form diquark.
22259  idq(3)=0
22260  GOTO 770
22261  ELSE
22262 C...Replace junction by baryon.
22263  k(iju,1)=1
22264  k(iju,2)=kfbar
22265  k(iju,3)=mint(83)+js
22266  k(iju,4)=0
22267  k(iju,5)=0
22268  p(iju,5)=pymass(kfbar)
22269  DO 790 msj=1,3
22270 C...Prepare removal of participating quarks from ER.
22271  k(jst(js,msj),1)=-1
22272  790 CONTINUE
22273  ENDIF
22274  ELSE
22275 C...If collapse to baryon not possible or not allowed, replace junction
22276 C...by diquark. This way, collapsed gluons that were pointing at the
22277 C...junction will now point (correctly) at diquark.
22278  manti=itjunc(js)-1
22279  k(iju,1)=3
22280  k(iju,2)=kfdq
22281  k(iju,3)=mint(83)+js
22282  k(iju,4)=0
22283  k(iju,5)=0
22284  DO 800 msj=1,3
22285  ip=jst(js,msj)
22286  IF (ip.NE.idq(1).AND.ip.NE.idq(2)) THEN
22287  k(iju,4+manti)=0
22288  k(iju,5-manti)=ip*mstu(5)
22289  k(ip,4+manti)=mod(k(ip,4+manti),mstu(5))+
22290  & mstu(5)*iju
22291  mct(iju,2-manti)=mct(ip,1+manti)
22292  ELSE
22293 C...Prepare removal of participating quarks from ER.
22294  k(ip,1)=-1
22295  ENDIF
22296  800 CONTINUE
22297  ENDIF
22298 
22299 C...Update so ER pointers to collapsed quarks
22300 C...now go to collapsed object.
22301  DO 820 i=mint(84)+1,n
22302  IF ((k(i,3).EQ.mint(83)+js.OR.k(i,3).EQ.mint(83)+2+js).and
22303  & .k(i,1).GT.0) THEN
22304  DO 810 isid=4,5
22305  imo=k(i,isid)/mstu(5)
22306  ida=mod(k(i,isid),mstu(5))
22307  IF (imo.GT.0) THEN
22308  IF (k(imo,1).EQ.-1) imo=iju
22309  ENDIF
22310  IF (ida.GT.0) THEN
22311  IF (k(ida,1).EQ.-1) ida=iju
22312  ENDIF
22313  k(i,isid)=ida+mstu(5)*imo
22314  810 CONTINUE
22315  ENDIF
22316  820 CONTINUE
22317  ENDIF
22318  ENDIF
22319 
22320 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22321 C...(this only happens for baryons, where we want to force the gluon
22322 C...to sit next to the junction. Mesons handled above.)
22323  IF (nbrtot(js).EQ.0) THEN
22324  n=n+1
22325  DO 830 ix=1,5
22326  k(n,ix)=0
22327  p(n,ix)=0d0
22328  v(n,ix)=0d0
22329  830 CONTINUE
22330  igl=n
22331  k(igl,1)=3
22332  k(igl,2)=21
22333  k(igl,3)=mint(83)+js
22334  IF (itjunc(js).NE.0) THEN
22335 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22336  jleg=pyr(0)*nvsum(js)+1
22337  i1=jst(js,jleg)
22338  jst(js,jleg)=igl
22339  jct=mct(i1,itjunc(js))
22340  mct(igl,3-itjunc(js))=jct
22341  nct=nct+1
22342  mct(igl,itjunc(js))=nct
22343  manti=itjunc(js)-1
22344  ELSE
22345 C...Meson. Should not happen.
22346  CALL pyerrm(19,'(PYMIHK:) Empty meson beam remnant')
22347  IF(nerrpr.LT.5) THEN
22348  WRITE(mstu(11),*) 'This should not have been possible!'
22349  CALL pylist(4)
22350  nerrpr=nerrpr+1
22351  ENDIF
22352  mint(51)=1
22353  RETURN
22354  ENDIF
22355  i2=mod(k(i1,4+manti)/mstu(5),mstu(5))
22356  k(i1,4+manti)=mod(k(i1,4+manti),mstu(5))+mstu(5)*igl
22357  k(igl,5-manti)=mod(k(igl,5-manti),mstu(5))+mstu(5)*i1
22358  k(igl,4+manti)=mod(k(igl,4+manti),mstu(5))+mstu(5)*i2
22359  IF (k(i2,2).NE.88) THEN
22360  k(i2,5-manti)=mod(k(i2,5-manti),mstu(5))+mstu(5)*igl
22361  ELSE
22362  IF (mod(k(i2,4),mstu(5)).EQ.i1) THEN
22363  k(i2,4)=(k(i2,4)/mstu(5))*mstu(5)+igl
22364  ELSEIF(mod(k(i2,5)/mstu(5),mstu(5)).EQ.i1) THEN
22365  k(i2,5)=mod(k(i2,5),mstu(5))+mstu(5)*igl
22366  ELSE
22367  k(i2,5)=(k(i2,5)/mstu(5))*mstu(5)+igl
22368  ENDIF
22369  ENDIF
22370  ENDIF
22371  840 CONTINUE
22372 
22373 C...Remove collapsed quarks and junctions from ER and update IMI.
22374  CALL pyedit(11)
22375 
22376 C...Also update beam remnant part of IMI.
22377  nmi(1)=mint(31)
22378  nmi(2)=mint(31)
22379  DO 850 i=mint(53)+1,n
22380  IF (k(i,1).LE.0) GOTO 850
22381 C...Restore BR quark/diquark/baryon pointers in IMI.
22382  IF ((k(i,2).NE.21.OR.k(i,1).NE.14).AND.k(i,2).NE.88) THEN
22383  js=k(i,3)-mint(83)
22384  nmi(js)=nmi(js)+1
22385  imi(js,nmi(js),1)=i
22386  imi(js,nmi(js),2)=0
22387  ENDIF
22388  850 CONTINUE
22389 
22390 C...Restore companion information from collapsed gluons.
22391  DO 870 i=mint(53)+1,n
22392  IF (k(i,2).EQ.21.AND.k(i,1).EQ.14) THEN
22393  js=k(i,3)-mint(83)
22394  jcd=mod(k(i,4),mstu(5))
22395  jad=mod(k(i,5),mstu(5))
22396  DO 860 im=1,nmi(js)
22397  IF (imi(js,im,1).EQ.jcd) imc=im
22398  IF (imi(js,im,1).EQ.jad) ima=im
22399  860 CONTINUE
22400  imi(js,imc,2)=imi(js,ima,1)
22401  imi(js,ima,2)=imi(js,imc,1)
22402  ENDIF
22403  870 CONTINUE
22404 
22405 C...Renumber colour lines (since some have disappeared)
22406  jct=0
22407  jcd=0
22408  880 jct=jct+1
22409  mfound=0
22410  i=mint(84)
22411  890 i=i+1
22412  IF (i.EQ.n+1) THEN
22413  IF (mfound.EQ.0) jcd=jcd+1
22414  ELSEIF (mct(i,1).EQ.jct.AND.k(i,1).GE.1) THEN
22415  mct(i,1)=jct-jcd
22416  mfound=1
22417  ELSEIF (mct(i,2).EQ.jct.AND.k(i,1).GE.1) THEN
22418  mct(i,2)=jct-jcd
22419  mfound=1
22420  ENDIF
22421  IF (i.LE.n) GOTO 890
22422  IF (jct.LT.nct) GOTO 880
22423  nct=jct-jcd
22424 
22425 C...Reset hard interaction subsystems to their CM frames.
22426  IF (iboost.EQ.1) THEN
22427  DO 900 im=1,mint(31)
22428  beta=-(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
22429  CALL pyrobo(imisep(im-1)+1,imisep(im),0d0,0d0,0d0,0d0,beta)
22430  900 CONTINUE
22431 C...Zero beam remnant longitudinal momenta and energies
22432  DO 910 i=mint(53)+1,n
22433  p(i,3)=0d0
22434  p(i,4)=0d0
22435  910 CONTINUE
22436  ELSE
22437  CALL pyerrm(9
22438  & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22439 C...Kill event and start another.
22440  mint(51)=1
22441  RETURN
22442  ENDIF
22443 
22444  9999 RETURN
22445  END
22446 C*********************************************************************
22447 
22448 C...PYCTTR
22449 C...Adapted from PYPREP.
22450 C...Assigns LHA1 colour tags to coloured partons based on
22451 C...K(I,4) and K(I,5) colour connection record.
22452 C...KCS negative signifies that a previous tracing should be continued.
22453 C...(in case the tag to be continued is empty, the routine exits)
22454 C...Starts at I and ends at I or IEND.
22455 C...Special considerations for systems with junctions.
22456 C...Special: if IEND=-1, means trace this parton to its color partner,
22457 C... then exit. If no partner found, exit with 0.
22458 
22459  SUBROUTINE pycttr(I,KCS,IEND)
22460 C...Double precision and integer declarations.
22461  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22462  INTEGER PYK,PYCHGE,PYCOMP
22463 C...Commonblocks.
22464  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
22465  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
22466  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
22467  common/pyint1/mint(400),vint(400)
22468 C...The common block of colour tags.
22469  common/pyctag/nct,mct(4000,2)
22470  SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/,/pyctag/
22471  DATA nerrpr/0/
22472  SAVE nerrpr
22473 
22474 C...Skip if parton not existing or does not have KCS
22475  IF (k(i,1).LE.0) GOTO 120
22476  kc=pycomp(k(i,2))
22477  IF (kc.EQ.0) GOTO 120
22478  kq=kchg(kc,2)
22479  IF (kq.EQ.0) GOTO 120
22480  IF (iabs(kq).EQ.1.AND.kq*(9-2*abs(kcs)).NE.isign(1,k(i,2)))
22481  & GOTO 120
22482 
22483  IF (kcs.GT.0) THEN
22484  nct=nct+1
22485 C...Set colour tag of first parton.
22486  mct(i,kcs-3)=nct
22487  ncs=nct
22488  ELSE
22489  kcs=-kcs
22490  ncs=mct(i,kcs-3)
22491  IF (ncs.EQ.0) GOTO 120
22492  ENDIF
22493 
22494  ia=i
22495  nstp=0
22496  100 nstp=nstp+1
22497  IF(nstp.GT.4*n) THEN
22498  CALL pyerrm(14,'(PYCTTR:) caught in infinite loop')
22499  GOTO 120
22500  ENDIF
22501 
22502 C...Finished if reached final-state triplet.
22503  IF(k(ia,1).EQ.3) THEN
22504  IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) GOTO 120
22505  ENDIF
22506 
22507 C...Also finished if reached junction.
22508  IF(k(ia,1).EQ.42) THEN
22509  GOTO 120
22510  ENDIF
22511 
22512 C...GOTO next parton in colour space.
22513  110 ib=ia
22514 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22515  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))
22516  & .NE.0) THEN
22517  ia=mod(k(ib,kcs),mstu(5))
22518  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
22519  mrev=0
22520  ELSE
22521 C...If KCS mother traced or KCS mother nonexistent, switch colour.
22522  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
22523  & mstu(5)).EQ.0) THEN
22524  kcs=9-kcs
22525  nct=nct+1
22526  ncs=nct
22527 C...Assign new colour tag on other side of old parton.
22528  mct(ib,kcs-3)=nct
22529  ENDIF
22530 C...Goto (new) KCS mother, set mother traced tag
22531  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
22532  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
22533  mrev=1
22534  ENDIF
22535  IF(ia.LE.0.OR.ia.GT.n) THEN
22536  IF (iend.EQ.-1) THEN
22537  iend=0
22538  GOTO 120
22539  ENDIF
22540  CALL pyerrm(12,'(PYCTTR:) colour tag tracing failed')
22541  IF(nerrpr.LT.5) THEN
22542  write(*,*) 'began at ',i
22543  write(*,*) 'ended going from', ib, ' to', ia, ' KCS=',kcs,
22544  & ' NCS=',ncs,' MREV=',mrev
22545  CALL pylist(4)
22546  nerrpr=nerrpr+1
22547  ENDIF
22548  mint(51)=1
22549  RETURN
22550  ENDIF
22551  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
22552  & mstu(5)).EQ.ib) THEN
22553  IF(mrev.EQ.1) kcs=9-kcs
22554  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
22555 C...Set KSC mother traced tag for IA
22556  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
22557  ELSE
22558  IF(mrev.EQ.0) kcs=9-kcs
22559  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
22560 C...Set KCS daughter traced tag for IA
22561  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
22562  ENDIF
22563 C...Assign new colour tag
22564  mct(ia,kcs-3)=ncs
22565 C...Finish if IEND=-1 and found final-state color partner
22566  IF (iend.EQ.-1.AND.k(ia,1).LT.10) THEN
22567  iend=ia
22568  GOTO 120
22569  ENDIF
22570  IF (ia.NE.i.AND.ia.NE.iend) GOTO 100
22571 
22572  120 RETURN
22573  END
22574 
22575 *********************************************************************
22576 
22577 C...PYMIHG
22578 C...Collapse JCP1 and connecting tags to JCG1.
22579 C...Collapse JCP2 and connecting tags to JCG2.
22580 
22581  SUBROUTINE pymihg(JCP1,JCG1,JCP2,JCG2)
22582 C...Double precision and integer declarations.
22583  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22584  IMPLICIT INTEGER(I-N)
22585  INTEGER PYK,PYCHGE,PYCOMP
22586 C...The event record
22587  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
22588 C...Parameters
22589  common/pyint1/mint(400),vint(400)
22590  SAVE /pyjets/,/pyint1/
22591 C...Local variables
22592  COMMON /pycbls/mco(4000,2),ncc,jcco(4000,2),jccn(4000,2),maccpt
22593  COMMON /pyctag/nct,mct(4000,2)
22594  SAVE /pycbls/,/pyctag/
22595 
22596 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22597 C...in temporary tag collapse array JCCN. Only break up one connection.
22598  maccpt=1
22599  mclps=0
22600  DO 100 icc=1,ncc
22601  jccn(icc,1)=jcco(icc,1)
22602  jccn(icc,2)=jcco(icc,2)
22603 C...If there was a mother, it was previously connected to JCP1.
22604 C...Should be changed to JCP2.
22605  IF (mclps.EQ.0) THEN
22606  IF (jccn(icc,1).EQ.max(jcp1,jcp2).AND.jccn(icc,2).EQ.min(jcp1
22607  & ,jcp2)) THEN
22608  jccn(icc,1)=max(jcg2,jcp2)
22609  jccn(icc,2)=min(jcg2,jcp2)
22610  mclps=1
22611  ENDIF
22612  ENDIF
22613  100 CONTINUE
22614 C...Also collapse colours on JCP1 side of JCG1
22615  IF (jcp1.NE.0) THEN
22616  jccn(ncc+1,1)=max(jcp1,jcg1)
22617  jccn(ncc+1,2)=min(jcp1,jcg1)
22618  ELSE
22619  jccn(ncc+1,1)=max(jcp2,jcg2)
22620  jccn(ncc+1,2)=min(jcp2,jcg2)
22621  ENDIF
22622 
22623 C...Initialize event record colour tag array MCT array to MCO.
22624  DO 110 i=mint(84)+1,n
22625  mct(i,1)=mco(i,1)
22626  mct(i,2)=mco(i,2)
22627  110 CONTINUE
22628 
22629 C...Collapse tags:
22630 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22631 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22632 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22633 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22634  DO 160 is=1,4
22635 C...Skip if junction.
22636  IF ((is.EQ.4.AND.jcp2.EQ.0).OR.(is.EQ.3).AND.jcp1.EQ.0) GOTO 160
22637 C...Define starting point in tag space.
22638 C...JCA = previous tag
22639 C...JCO = present tag
22640 C...JCN = new tag
22641  IF (mod(is,2).EQ.1) THEN
22642  jco=jcp1
22643  jcn=jcg1
22644  jcall=jcg1
22645  ELSEIF (mod(is,2).EQ.0) THEN
22646  jco=jcp2
22647  jcn=jcg2
22648  jcall=jcg2
22649  ENDIF
22650  itrace=0
22651  120 itrace=itrace+1
22652  IF (itrace.GT.1000) THEN
22653 C...NB: Proper error message should be defined here.
22654  CALL pyerrm(14
22655  & ,'(PYMIHG:) Inf loop when collapsing colours.')
22656  mint(57)=mint(57)+1
22657  mint(51)=1
22658  RETURN
22659  ENDIF
22660 C...Collapse all JCN tags to JCALL
22661  DO 130 i=mint(84)+1,n
22662  IF (mco(i,1).EQ.jcn) mct(i,1)=jcall
22663  IF (mco(i,2).EQ.jcn) mct(i,2)=jcall
22664  130 CONTINUE
22665 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22666  IF (is.GT.2.AND.(jcn.EQ.jcall)) THEN
22667  jca=jcn
22668  jcn=jco
22669  ELSE
22670  jca=jco
22671  jco=jcn
22672  ENDIF
22673 C...If possible, step from JCO to new tag JCN not equal to JCA.
22674  DO 140 icc=1,ncc+1
22675  IF (jccn(icc,1).EQ.jco.AND.jccn(icc,2).NE.jca) jcn=
22676  & jccn(icc,2)
22677  IF (jccn(icc,2).EQ.jco.AND.jccn(icc,1).NE.jca) jcn=
22678  & jccn(icc,1)
22679  140 CONTINUE
22680 C...Iterate if new colour was arrived at, but don't go in circles.
22681  IF (jcn.NE.jco.AND.jcn.NE.jcall) GOTO 120
22682 C...Change all JCN tags in MCO to JCALL in MCT.
22683  DO 150 i=mint(84)+1,n
22684  IF (mco(i,1).EQ.jcn) mct(i,1)=jcall
22685  IF (mco(i,2).EQ.jcn) mct(i,2)=jcall
22686 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22687  IF (k(i,2).EQ.21.AND.mct(i,1).EQ.mct(i,2).AND.mct(i,1)
22688  & .NE.0) maccpt=0
22689  150 CONTINUE
22690  160 CONTINUE
22691 
22692  DO 200 jcl=nct,1,-1
22693  jca=0
22694  jcn=jcl
22695  170 jco=jcn
22696  DO 180 icc=1,ncc+1
22697  IF (jccn(icc,1).EQ.jco.AND.jccn(icc,2).NE.jca) jcn
22698  & =jccn(icc,2)
22699  IF (jccn(icc,2).EQ.jco.AND.jccn(icc,1).NE.jca) jcn
22700  & =jccn(icc,1)
22701  180 CONTINUE
22702 C...Overpaint all JCN with JCL
22703  IF (jcn.NE.jco.AND.jcn.NE.jcl) THEN
22704  DO 190 i=mint(84)+1,n
22705  IF (mct(i,1).EQ.jcn) mct(i,1)=jcl
22706  IF (mct(i,2).EQ.jcn) mct(i,2)=jcl
22707 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22708  IF (k(i,2).EQ.21.AND.mct(i,1).EQ.mct(i,2).AND.mct(i,1)
22709  & .NE.0) maccpt=0
22710  190 CONTINUE
22711  jca=jco
22712  GOTO 170
22713  ENDIF
22714  200 CONTINUE
22715 
22716  RETURN
22717  END
22718 
22719 C*********************************************************************
22720 
22721 C...PYMIRM
22722 C...Picks primordial kT and shares longitudinal momentum among
22723 C...beam remnants.
22724 
22725  SUBROUTINE pymirm
22726 
22727 C...Double precision and integer declarations.
22728  IMPLICIT DOUBLE PRECISION(a-h, o-z)
22729  IMPLICIT INTEGER(I-N)
22730  INTEGER PYK,PYCHGE,PYCOMP
22731 C...The event record
22732  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
22733 C...Parameters
22734  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
22735  common/pypars/mstp(200),parp(200),msti(200),pari(200)
22736  common/pyint1/mint(400),vint(400)
22737 C...The common block of colour tags.
22738  common/pyctag/nct,mct(4000,2)
22739 C...The common block of dangling ends
22740  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
22741  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
22742  & xmi(2,240),pt2mi(240),imisep(0:240)
22743  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyintm/,/pyctag/
22744 C...Local variables
22745  dimension w(0:2,0:2),vb(3),nnxt(2),ivalq(2),icomq(2)
22746 C...W(I,J)| J=0 | 1 | 2 |
22747 C... I=0 | Wrem**2 | W+ | W- |
22748 C... 1 | W1**2 | W1+ | W1- |
22749 C... 2 | W2**2 | W2+ | W2- |
22750 C...4-product
22751  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)
22752 C...Tentative parametrization of <kT> as a function of Q.
22753  sigpt(q)=max(parj(21),2.1d0*q/(7d0+q))
22754 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22755 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22756  getpt(q,sigma)=min(sigma*sqrt(-log(pyr(0))),parp(93))
22757 C...Lambda kinematic function.
22758  flam(a,b,c)=a**2+b**2+c**2-2d0*(a*b+b*c+c*a)
22759 
22760 C...Beginning and end of beam remnant partons
22761  nout=mint(53)
22762  isub=mint(1)
22763 
22764 C...Loopback point if kinematic choices gives impossible configuration.
22765  ntry=0
22766  100 ntry=ntry+1
22767 
22768 C...Assign kT values on each side separately.
22769  DO 180 js=1,2
22770 
22771 C...First zero all kT on this side. Skip if no kT to generate.
22772  DO 110 im=1,nmi(js)
22773  p(imi(js,im,1),1)=0d0
22774  p(imi(js,im,1),2)=0d0
22775  110 CONTINUE
22776  IF(mstp(91).LE.0) GOTO 180
22777 
22778 C...Now assign kT to each (non-collapsed) parton in IMI.
22779  DO 170 im=1,nmi(js)
22780  i=imi(js,im,1)
22781 C...Select kT according to truncated gaussian or 1/kt6 tails.
22782 C...For first interaction, either use rms width = PARP(91) or fitted.
22783  IF (im.EQ.1) THEN
22784  sigma=parp(91)
22785  IF (mstp(91).GE.11.AND.mstp(91).LE.20) THEN
22786  q=sqrt(pt2mi(im))
22787  sigma=sigpt(q)
22788  ENDIF
22789  ELSE
22790 C...For subsequent interactions and BR partons use fragmentation width.
22791  sigma=parj(21)
22792  ENDIF
22793  phi=paru(2)*pyr(0)
22794  pt=0d0
22795  IF(ntry.LE.100) THEN
22796  111 IF (mstp(91).EQ.1.OR.mstp(91).EQ.11) THEN
22797  pt=getpt(q,sigma)
22798  ptx=pt*cos(phi)
22799  pty=pt*sin(phi)
22800  ELSEIF (mstp(91).EQ.2) THEN
22801  CALL pyerrm(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22802  & 'available, using MSTP(91)=1.')
22803  CALL pygive('MSTP(91)=1')
22804  GOTO 111
22805  ELSEIF(mstp(91).EQ.3.OR.mstp(91).EQ.13) THEN
22806 C...Use distribution with kt**6 tails, rms width = PARP(91).
22807  eps=sqrt(3d0/2d0)*sigma
22808 C...Generate PTX and PTY separately, each propto 1/KT**6
22809  DO 119 ixy=1,2
22810 C...Decide which interval to try
22811  112 p12=1d0/(1d0+27d0/40d0*sigma**6/eps**6)
22812  IF (pyr(0).LT.p12) THEN
22813 C...Use flat approx with accept/reject up to EPS.
22814  pt=pyr(0)*eps
22815  wt=(3d0/2d0*sigma**2/(pt**2+3d0/2d0*sigma**2))**3
22816  IF (pyr(0).GT.wt) GOTO 112
22817  ELSE
22818 C...Above EPS, use 1/kt**6 approx with accept/reject.
22819  pt=eps/(pyr(0)**(1d0/5d0))
22820  wt=pt**6/(pt**2+3d0/2d0*sigma**2)**3
22821  IF (pyr(0).GT.wt) GOTO 112
22822  ENDIF
22823  msign=1
22824  IF (pyr(0).GT.0.5d0) msign=-1
22825  IF (ixy.EQ.1) ptx=msign*pt
22826  IF (ixy.EQ.2) pty=msign*pt
22827  119 CONTINUE
22828  ELSEIF (mstp(91).EQ.4.OR.mstp(91).EQ.14) THEN
22829  ptx=sigma*(sqrt(6d0)*pyr(0)-sqrt(3d0/2d0))
22830  pty=sigma*(sqrt(6d0)*pyr(0)-sqrt(3d0/2d0))
22831  ENDIF
22832 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22833  pt=sqrt(ptx**2+pty**2)
22834  wt=1d0
22835  IF (pt.GT.parp(93)) wt=sqrt(parp(93)/pt)
22836  IF(isub.EQ.95.AND.im.EQ.1) wt=0d0
22837  ptx=ptx*wt
22838  pty=pty*wt
22839  pt=sqrt(ptx**2+pty**2)
22840  ENDIF
22841 
22842  p(i,1)=p(i,1)+ptx
22843  p(i,2)=p(i,2)+pty
22844 
22845 C...Compensation kicks, with varying degree of local anticorrelations.
22846  mcorr=mstp(90)
22847  IF (mcorr.EQ.0.OR.isub.EQ.95) THEN
22848  ptcx=-ptx/(nmi(js)-1)
22849  ptcy=-pty/(nmi(js)-1)
22850  IF(isub.EQ.95) THEN
22851  ptcx=-ptx/(nmi(js)-2)
22852  ptcy=-pty/(nmi(js)-2)
22853  ENDIF
22854  DO 120 imc=1,nmi(js)
22855  IF (imc.EQ.im) GOTO 120
22856  IF(isub.EQ.95.AND.imc.EQ.1) GOTO 120
22857  p(imi(js,imc,1),1)=p(imi(js,imc,1),1)+ptcx
22858  p(imi(js,imc,1),2)=p(imi(js,imc,1),2)+ptcy
22859  120 CONTINUE
22860  ELSEIF (mcorr.GE.1) THEN
22861  DO 140 msid=4,5
22862  nnxt(msid-3)=0
22863 C...Count up # of neighbours on either side
22864  imo=i
22865  130 imo=k(imo,msid)/mstu(5)
22866  IF (imo.EQ.0) GOTO 140
22867  nnxt(msid-3)=nnxt(msid-3)+1
22868 C...Stop at quarks and junctions
22869  IF (mcorr.EQ.1.AND.k(imo,2).EQ.21) GOTO 130
22870  140 CONTINUE
22871 C...How should compensation be shared when unequal numbers on the
22872 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22873  nsum=nnxt(1)+nnxt(2)
22874  t1=0
22875  DO 160 msid=4,5
22876 C...Total momentum to be compensated on this side
22877  IF (nnxt(msid-3).EQ.0) GOTO 160
22878  ptcx=-(nnxt(msid-3)*ptx)/nsum
22879  ptcy=-(nnxt(msid-3)*pty)/nsum
22880 C...RS: compensation supression factor as we go out from parton I.
22881 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22882 C...since (for now) MSTP(90) provides enough variability.
22883  rs=0.5d0
22884  fac=(1d0-rs)/(rs*(1-rs**nnxt(msid-3)))
22885  imo=i
22886  150 ida=imo
22887  imo=k(imo,msid)/mstu(5)
22888  IF (imo.EQ.0) GOTO 160
22889  fac=fac*rs
22890  IF (k(imo,2).NE.88) THEN
22891  p(imo,1)=p(imo,1)+fac*ptcx
22892  p(imo,2)=p(imo,2)+fac*ptcy
22893  IF (mcorr.EQ.1.AND.k(imo,2).EQ.21) GOTO 150
22894 C...If we reach junction, divide out the kT that would have been
22895 C...assigned to the junction on each of its other legs.
22896  ELSE
22897  l1=mod(k(imo,4),mstu(5))
22898  l2=k(imo,5)/mstu(5)
22899  l3=mod(k(imo,5),mstu(5))
22900  p(l1,1)=p(l1,1)+0.5d0*fac*ptcx
22901  p(l1,2)=p(l1,2)+0.5d0*fac*ptcy
22902  p(l2,1)=p(l2,1)+0.5d0*fac*ptcx
22903  p(l2,2)=p(l2,2)+0.5d0*fac*ptcy
22904  p(l3,1)=p(l3,1)+0.5d0*fac*ptcx
22905  p(l3,2)=p(l3,2)+0.5d0*fac*ptcy
22906  p(ida,1)=p(ida,1)-0.5d0*fac*ptcx
22907  p(ida,2)=p(ida,2)-0.5d0*fac*ptcy
22908  ENDIF
22909 
22910  160 CONTINUE
22911  ENDIF
22912  170 CONTINUE
22913 C...End assignment of kT values to initiators and remnants.
22914  180 CONTINUE
22915 
22916 C...Check kinematics constraints for non-BR partons.
22917  DO 190 im=1,mint(31)
22918  shat=xmi(1,im)*xmi(2,im)*vint(2)
22919  pt1=sqrt(p(imi(1,im,1),1)**2+p(imi(1,im,1),2)**2)
22920  pt2=sqrt(p(imi(2,im,1),1)**2+p(imi(2,im,1),2)**2)
22921  pt1pt2=p(imi(1,im,1),1)*p(imi(2,im,1),1)
22922  & +p(imi(1,im,1),2)*p(imi(2,im,1),2)
22923  IF (shat.LT.2d0*(pt1*pt2-pt1pt2).AND.ntry.LE.100) THEN
22924  IF(ntry.GE.100) THEN
22925 C...Kill this event and start another.
22926  CALL pyerrm(1,
22927  & '(PYMIRM:) No consistent (x,kT) sets found')
22928  mint(51)=1
22929  RETURN
22930  ENDIF
22931  GOTO 100
22932  ENDIF
22933  190 CONTINUE
22934 
22935 C...Calculate W+ and W- available for combined remnant system.
22936  w(0,1)=vint(1)
22937  w(0,2)=vint(1)
22938  DO 200 im=1,mint(31)
22939  pt2 = (p(imi(1,im,1),1)+p(imi(2,im,1),1))**2
22940  & +(p(imi(1,im,1),2)+p(imi(2,im,1),2))**2
22941  st=xmi(1,im)*xmi(2,im)*vint(2)+pt2
22942  w(0,1)=w(0,1)-sqrt(xmi(1,im)/xmi(2,im)*st)
22943  w(0,2)=w(0,2)-sqrt(xmi(2,im)/xmi(1,im)*st)
22944  200 CONTINUE
22945 C...Also store Wrem**2 = W+ * W-
22946  w(0,0)=w(0,1)*w(0,2)
22947 
22948  IF ((w(0,0).LT.0d0.OR.w(0,1)+w(0,2).LT.0d0).AND.ntry.LE.100) THEN
22949  IF(ntry.GE.100) THEN
22950 C...Kill this event and start another.
22951  CALL pyerrm(1,
22952  & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
22953  mint(51)=1
22954  RETURN
22955  ENDIF
22956  GOTO 100
22957  ENDIF
22958 
22959 C...Assign unscaled x values to partons/hadrons in each of the
22960 C...beam remnants and calculate unscaled W+ and W- from them.
22961  ntryx=0
22962  210 ntryx=ntryx+1
22963  DO 280 js=1,2
22964  w(js,1)=0d0
22965  w(js,2)=0d0
22966  DO 270 im=mint(31)+1,nmi(js)
22967  i=imi(js,im,1)
22968  kf=k(i,2)
22969  kfa=iabs(kf)
22970  icomp=imi(js,im,2)
22971 
22972 C...Skip collapsed gluons and junctions. Reset.
22973  IF (kfa.EQ.21.AND.k(i,1).EQ.14) GOTO 270
22974  IF (kfa.EQ.88) GOTO 270
22975  x=0d0
22976  ivalq(1)=0
22977  ivalq(2)=0
22978  icomq(1)=0
22979  icomq(2)=0
22980 
22981 C...If gluon then only beam remnant, so takes all.
22982  IF(kfa.EQ.21) THEN
22983  x=1d0
22984 C...If valence quark then use parametrized valence distribution.
22985  ELSEIF(kfa.LE.6.AND.icomp.EQ.0) THEN
22986  ivalq(1)=kf
22987 C...If companion quark then derive from companion x.
22988  ELSEIF(kfa.LE.6) THEN
22989  icomq(1)=icomp
22990 C...If valence diquark then use two parametrized valence distributions.
22991  ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0.AND.
22992  & icomp.EQ.0) THEN
22993  ivalq(1)=isign(kfa/1000,kf)
22994  ivalq(2)=isign(mod(kfa/100,10),kf)
22995 C...If valence+sea diquark then combine valence + companion choices.
22996  ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0.AND.
22997  & icomp.LT.mstu(5)) THEN
22998  IF(kfa/1000.EQ.iabs(k(icomp,2))) THEN
22999  ivalq(1)=isign(mod(kfa/100,10),kf)
23000  ELSE
23001  ivalq(1)=isign(kfa/1000,kf)
23002  ENDIF
23003  icomq(1)=icomp
23004 C...Extra code: workaround for diquark made out of two sea
23005 C...quarks, but where not (yet) ICOMP > MSTU(5).
23006  DO 220 im1=1,mint(31)
23007  IF(imi(js,im1,2).EQ.i.AND.imi(js,im1,1).NE.icomp) THEN
23008  icomq(2)=imi(js,im1,1)
23009  ivalq(1)=0
23010  ENDIF
23011  220 CONTINUE
23012 C...If sea diquark then sum of two derived from companion x.
23013  ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0) THEN
23014  icomq(1)=mod(icomp,mstu(5))
23015  icomq(2)=icomp/mstu(5)
23016 C...If meson or baryon then use fragmentation function.
23017 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23018  ELSE
23019  kfl3=mod(kfa/10,10)
23020  IF(mod(kfa/1000,10).EQ.0) THEN
23021  kfl1=mod(kfa/100,10)
23022  ELSE
23023  kfl1=mod(kfa,10000)-10*kfl3-1
23024  IF(mod(kfa/1000,10).EQ.mod(kfa/100,10).AND.
23025  & mod(kfa,10).EQ.2) kfl1=kfl1+2
23026  ENDIF
23027  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
23028  CALL pyzdis(kfl1,kfl3,pr,x)
23029  ENDIF
23030 
23031  DO 260 iq=1,2
23032 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23033 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23034 C...In other baryons combine u and d from proton appropriately.
23035  IF(ivalq(iq).NE.0) THEN
23036  nval=0
23037  IF(kfival(js,1).EQ.ivalq(iq)) nval=nval+1
23038  IF(kfival(js,2).EQ.ivalq(iq)) nval=nval+1
23039  IF(kfival(js,3).EQ.ivalq(iq)) nval=nval+1
23040 C...Meson.
23041  IF(kfival(js,3).EQ.0) THEN
23042  mdu=0
23043 C...Baryon with three identical quarks: mix u and d forms.
23044  ELSEIF(nval.EQ.3) THEN
23045  mdu=int(pyr(0)+5d0/3d0)
23046 C...Baryon, one of two identical quarks: u form.
23047  ELSEIF(nval.EQ.2) THEN
23048  mdu=2
23049 C...Baryon with two identical quarks, but not the one picked: d form.
23050  ELSEIF(kfival(js,1).EQ.kfival(js,2).OR.kfival(js,2).EQ.
23051  & kfival(js,3).OR.kfival(js,1).EQ.kfival(js,3)) THEN
23052  mdu=1
23053 C...Baryon with three nonidentical quarks: mix u and d forms.
23054  ELSE
23055  mdu=int(pyr(0)+5d0/3d0)
23056  ENDIF
23057  xpow=0.8d0
23058  IF(mdu.EQ.1) xpow=3.5d0
23059  IF(mdu.EQ.2) xpow=2d0
23060  230 xx=pyr(0)**2
23061  IF((1d0-xx)**xpow.LT.pyr(0)) GOTO 230
23062  x=x+xx
23063  ENDIF
23064 
23065 C...Calculation of x of companion quark.
23066  IF(icomq(iq).NE.0) THEN
23067  xcomp=1d-4
23068  DO 240 im1=1,mint(31)
23069  IF(imi(js,im1,1).EQ.icomq(iq)) xcomp=xmi(js,im1)
23070  240 CONTINUE
23071  npow=max(0,min(4,mstp(87)))
23072  250 xx=xcomp*(1d0/(1d0-pyr(0)*(1d0-xcomp))-1d0)
23073  corr=((1d0-xcomp-xx)/(1d0-xcomp))**npow*
23074  & (xcomp**2+xx**2)/(xcomp+xx)**2
23075  IF(corr.LT.pyr(0)) GOTO 250
23076  x=x+xx
23077  ENDIF
23078  260 CONTINUE
23079 
23080 C...Optionally enchance x of composite systems (e.g. diquarks)
23081  IF (kfa.GT.100) x=parp(79)*x
23082 
23083 C...Store x. Also calculate light cone energies of each system.
23084  xmi(js,im)=x
23085  w(js,js)=w(js,js)+x
23086  w(js,3-js)=w(js,3-js)+(p(i,5)**2+p(i,1)**2+p(i,2)**2)/x
23087  270 CONTINUE
23088  w(js,js)=w(js,js)*w(0,js)
23089  w(js,3-js)=w(js,3-js)/w(0,js)
23090  w(js,0)=w(js,1)*w(js,2)
23091  280 CONTINUE
23092 
23093 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23094 C...insensitive to global rescalings of the BR x values).
23095  IF (sqrt(w(1,0))+sqrt(w(2,0)).GT.sqrt(w(0,0)).AND.ntryx.LE.100)
23096  & THEN
23097  GOTO 210
23098  ELSEIF (ntryx.GT.100.AND.ntry.LE.100) THEN
23099  GOTO 100
23100  ELSEIF (ntryx.GT.100) THEN
23101  CALL pyerrm(1,'(PYMIRM:) No consistent (x,kT) sets found')
23102  mint(57)=mint(57)+1
23103  mint(51)=1
23104  RETURN
23105  ENDIF
23106 
23107 C...Compute x rescaling factors
23108  comtrm=w(0,0)+sqrt(flam(w(0,0),w(1,0),w(2,0)))
23109  r1=(comtrm+w(1,0)-w(2,0))/(2d0*w(1,1)*w(0,2))
23110  r2=(comtrm+w(2,0)-w(1,0))/(2d0*w(2,2)*w(0,1))
23111 
23112  IF (r1.LT.0.OR.r2.LT.0) THEN
23113  CALL pyerrm(19,'(PYMIRM:) negative rescaling factors !')
23114  mint(57)=mint(57)+1
23115  mint(51)=1
23116  ENDIF
23117 
23118 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23119  w(1,1)=w(1,1)*r1
23120  w(1,2)=w(1,2)/r1
23121  w(2,1)=w(2,1)/r2
23122  w(2,2)=w(2,2)*r2
23123 
23124 C...Rescale BR x values.
23125  DO 290 im=mint(31)+1,max(nmi(1),nmi(2))
23126  xmi(1,im)=xmi(1,im)*r1
23127  xmi(2,im)=xmi(2,im)*r2
23128  290 CONTINUE
23129 
23130 C...Now we have a consistent set of x and kT values.
23131 C...First set up the initiators and their daughters correctly.
23132  DO 300 im=1,mint(31)
23133  i1=imi(1,im,1)
23134  i2=imi(2,im,1)
23135  st=xmi(1,im)*xmi(2,im)*vint(2)+(p(i1,1)+p(i2,1))**2+
23136  & (p(i1,2)+p(i2,2))**2
23137  pt12=p(i1,1)**2+p(i1,2)**2
23138  pt22=p(i2,1)**2+p(i2,2)**2
23139 C...p_z
23140  p(i1,3)=sqrt(flam(st,pt12,pt22)/(4d0*st))
23141  p(i2,3)=-p(i1,3)
23142 C...Energies (masses should be zero at this stage)
23143  p(i1,4)=sqrt(pt12+p(i1,3)**2)
23144  p(i2,4)=sqrt(pt22+p(i2,3)**2)
23145 
23146 C...Transverse 12 system initiator velocity:
23147  vb(1)=(p(i1,1)+p(i2,1))/sqrt(st)
23148  vb(2)=(p(i1,2)+p(i2,2))/sqrt(st)
23149 C...Boost to overall initiator system rest frame
23150  CALL pyrobo(i1,i1,0d0,0d0,-vb(1),-vb(2),0d0)
23151  CALL pyrobo(i2,i2,0d0,0d0,-vb(1),-vb(2),0d0)
23152 
23153 C...Compute phi,theta coordinates of I1 and rotate z axis.
23154  phi=pyangl(p(i1,1),p(i1,2))
23155  the=pyangl(p(i1,3),sqrt(p(i1,1)**2+p(i1,2)**2))
23156  imin=imisep(im-1)+1
23157 C...(include documentation lines if MI = 1)
23158  IF (im.EQ.1) imin=mint(83)+5
23159  imax=imisep(im)
23160 C...Rotate entire system in phi
23161  CALL pyrobo(imin,imax,0d0,-phi,0d0,0d0,0d0)
23162 C...Only rotate 12 system in theta
23163  CALL pyrobo(i1,i1,-the,0d0,0d0,0d0,0d0)
23164  CALL pyrobo(i2,i2,-the,0d0,0d0,0d0,0d0)
23165 
23166 C...Now boost entire system back to LAB
23167  vb(3)=(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
23168  CALL pyrobo(imin,imax,the,phi,vb(1),vb(2),0d0)
23169  CALL pyrobo(imin,imax,0d0,0d0,0d0,0d0,vb(3))
23170 
23171  300 CONTINUE
23172 
23173 
23174 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23175  DO 320 js=1,2
23176  DO 310 im=mint(31)+1,nmi(js)
23177  i=imi(js,im,1)
23178 C...Skip collapsed gluons and junctions.
23179  IF (k(i,2).EQ.21.AND.k(i,1).EQ.14) GOTO 310
23180  IF (kfa.EQ.88) GOTO 310
23181  rmt2=p(i,5)**2+p(i,1)**2+p(i,2)**2
23182  p(i,4)=0.5d0*(xmi(js,im)*w(0,js)+rmt2/(xmi(js,im)*w(0,js)))
23183  p(i,3)=0.5d0*(xmi(js,im)*w(0,js)-rmt2/(xmi(js,im)*w(0,js)))
23184  IF (js.EQ.2) p(i,3)=-p(i,3)
23185  310 CONTINUE
23186  320 CONTINUE
23187 
23188 
23189 C...Documentation lines
23190  DO 340 js=1,2
23191  in=mint(83)+js+2
23192  io=imi(js,1,1)
23193  k(in,1)=21
23194  k(in,2)=k(io,2)
23195  k(in,3)=mint(83)+js
23196  k(in,4)=0
23197  k(in,5)=0
23198  DO 330 j=1,5
23199  p(in,j)=p(io,j)
23200  v(in,j)=v(io,j)
23201  330 CONTINUE
23202  mct(in,1)=mct(io,1)
23203  mct(in,2)=mct(io,2)
23204  340 CONTINUE
23205 
23206 C...Final state colour reconnections.
23207  IF (mstp(95).NE.1.OR.mint(31).LE.1) GOTO 380
23208 
23209 C...Number of colour tags for which a recoupling will be tried.
23210  ntot=nct
23211 C...Number of recouplings to try
23212  mint(34)=0
23213  nrecp=0
23214  niter=0
23215  350 nrecp=mint(34)
23216  niter=niter+1
23217  iiter=0
23218  360 iiter=iiter+1
23219  IF (iiter.LE.parp(78)*ntot) THEN
23220 C...Select two colour tags at random
23221 C...NB: jj strings do not have colour tags assigned to them,
23222 C...thus they are as yet not affected by anything done here.
23223  jct=pyr(0)*nct+1
23224  kct=mod(int(jct+pyr(0)*nct),nct)+1
23225  ij1=0
23226  ij2=0
23227  ik1=0
23228  ik2=0
23229 C...Find final state partons with this (anti)colour
23230  DO 370 i=mint(84)+1,n
23231  IF (k(i,1).EQ.3) THEN
23232  IF (mct(i,1).EQ.jct) ij1=i
23233  IF (mct(i,2).EQ.jct) ij2=i
23234  IF (mct(i,1).EQ.kct) ik1=i
23235  IF (mct(i,2).EQ.kct) ik2=i
23236  ENDIF
23237  370 CONTINUE
23238 C...Only consider recouplings not involving junctions for now.
23239  IF (ij1.EQ.0.OR.ij2.EQ.0.OR.ik1.EQ.0.OR.ik2.EQ.0) GOTO 360
23240 
23241  rlo=2d0*four(ij1,ij2)*2d0*four(ik1,ik2)
23242  rln=2d0*four(ij1,ik2)*2d0*four(ik1,ij2)
23243  IF (rln.LT.rlo.AND.mct(ij2,1).NE.kct.AND.mct(ik2,1).NE.jct) THEN
23244  mct(ij2,2)=kct
23245  mct(ik2,2)=jct
23246 C...Count up number of reconnections
23247  mint(34)=mint(34)+1
23248  ENDIF
23249  IF (mint(34).LE.1000) THEN
23250  GOTO 360
23251  ELSE
23252  CALL pyerrm(4,'(PYMIRM:) caught in infinite loop')
23253  GOTO 380
23254  ENDIF
23255  ENDIF
23256  IF (nrecp.LT.mint(34)) GOTO 350
23257 
23258 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23259  380 mint(33)=1
23260 
23261  RETURN
23262  END
23263 
23264 C*********************************************************************
23265 
23266 C...PYFSCR
23267 C...Performs colour annealing.
23268 C...MSTP(95) : CR Type
23269 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23270 C... = 2 : Type I(no gg loops); hadron-hadron only
23271 C... = 3 : Type I(no gg loops); all beams
23272 C... = 4 : Type II(gg loops) ; hadron-hadron only
23273 C... = 5 : Type II(gg loops) ; all beams
23274 C... = 6 : Type S ; hadron-hadron only
23275 C... = 7 : Type S ; all beams
23276 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23277 C...Type S is driven by starting only from free triplets, not octets.
23278 C...A string piece remains unchanged with probability
23279 C... PKEEP = (1-PARP(78))**N
23280 C...This scaling corresponds to each string piece having to go through
23281 C...N other ones, each with probability PARP(78) for reconnection, where
23282 C...N is here chosen simply as the number of multiple interactions,
23283 C...for a rough scaling with the general level of activity.
23284 
23285  SUBROUTINE pyfscr(IP)
23286 C...Double precision and integer declarations.
23287  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23288  INTEGER PYK,PYCHGE,PYCOMP
23289 C...Commonblocks.
23290  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23291  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23292  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23293  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
23294  common/pyint1/mint(400),vint(400)
23295 C...The common block of colour tags.
23296  common/pyctag/nct,mct(4000,2)
23297  SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/,/pyctag/,
23298  &/pypars/
23299 C...MCN: Temporary storage of new colour tags
23300  INTEGER MCN(4000,2)
23301 C...Arrays for storing color string lengths
23302  INTEGER ICR(4000),MSCR(4000)
23303  INTEGER IOPT(4000)
23304  DOUBLE PRECISION RLOPTC(4000)
23305 
23306 C...Function to give four-product.
23307  four(i,j)=p(i,4)*p(j,4)
23308  & -p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)
23309 
23310 C...Check valid range of MSTP(95), local copy
23311  IF (mstp(95).LE.1.OR.mstp(95).GE.10) RETURN
23312  mstp95=mod(mstp(95),10)
23313 C...Set whether CR allowed inside resonance systems or not
23314 C...(not implemented yet)
23315 C MRESCR=1
23316 C IF (MSTP(95).GE.10) MRESCR=0
23317 
23318 C...Check whether colour tags already defined
23319  IF (mint(33).EQ.0) THEN
23320 C...Erase any existing colour tags for this event
23321  DO 100 i=1,n
23322  mct(i,1)=0
23323  mct(i,2)=0
23324  100 CONTINUE
23325 C...Create colour tags for this event
23326  DO 120 i=1,n
23327  IF (k(i,1).EQ.3) THEN
23328  DO 110 kcs=4,5
23329  kcsin=kcs
23330  IF (mct(i,kcsin-3).EQ.0) THEN
23331  CALL pycttr(i,kcsin,i)
23332  ENDIF
23333  110 CONTINUE
23334  ENDIF
23335  120 CONTINUE
23336 C...Instruct PYPREP to use colour tags
23337  mint(33)=1
23338  ENDIF
23339 
23340 C...For MSTP(95) even, only apply to hadron-hadron
23341  ka1=iabs(mint(11))
23342  ka2=iabs(mint(12))
23343  IF (mod(mstp(95),2).EQ.0.AND.(ka1.LT.100.OR.ka2.LT.100)) GOTO 9999
23344 
23345 C...Initialize new tag array (but do not delete old yet)
23346  lct=nct
23347  DO 130 i=max(1,ip),n
23348  mcn(i,1)=0
23349  mcn(i,2)=0
23350  130 CONTINUE
23351 
23352 C...For each final-state dipole, check whether string should be
23353 C...preserved.
23354  ncr=0
23355  ia=0
23356  ic=0
23357 
23358  DO 150 ict=1,nct
23359  ia=0
23360  ic=0
23361  DO 140 i=max(1,ip),n
23362  IF (k(i,1).EQ.3.AND.mct(i,1).EQ.ict) ic=i
23363  IF (k(i,1).EQ.3.AND.mct(i,2).EQ.ict) ia=i
23364  140 CONTINUE
23365  IF (ic.NE.0.AND.ia.NE.0) THEN
23366  crmodf=1d0
23367 C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23368 C...(so far ignores the possibility that the whole "muck" may be moving.)
23369  IF (parp(77).GT.0d0) THEN
23370  pt2str=(p(ia,1)+p(ic,1))**2+(p(ia,2)+p(ic,2))**2
23371 C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23372  IF (ka1.LT.100.AND.ka2.LT.100) THEN
23373  p2str = pt2str + (p(ia,3)+p(ic,3))**2
23374  ELSE
23375  p2str = 3d0/2d0 * pt2str
23376  ENDIF
23377  rm2str=(p(ia,4)+p(ic,4))**2-(p(ia,3)+p(ic,3))**2-pt2str
23378  rm2str=max(rm2str,pmas(pycomp(111),1)**2)
23379 C...Estimate number of particles ~ log(M2), cut off at 1.
23380  rlogm2=max(1d0,log(rm2str))
23381  p2avg=p2str/rlogm2
23382 C...Supress reconnection probability by 1/(1+P77*P2AVG)
23383  crmodf=1d0/(1d0+parp(77)**2*p2avg)
23384  ENDIF
23385  pkeep=(1d0-parp(78)*crmodf)**mint(31)
23386  IF (pyr(0).LE.pkeep) THEN
23387  lct=lct+1
23388  mcn(ic,1)=lct
23389  mcn(ia,2)=lct
23390  ELSE
23391 C...Add coloured parton
23392  ncr=ncr+1
23393  icr(ncr)=ic
23394  mscr(ncr)=1
23395  iopt(ncr)=0
23396  rloptc(ncr)=1d19
23397 C...Add anti-coloured parton
23398  ncr=ncr+1
23399  icr(ncr)=ia
23400  mscr(ncr)=2
23401  iopt(ncr)=0
23402  rloptc(ncr)=1d19
23403  ENDIF
23404  ENDIF
23405  150 CONTINUE
23406 
23407 C...Skip if there is only one possibility
23408  IF (ncr.LE.2) THEN
23409  GOTO 9999
23410  ENDIF
23411 
23412 C...Reorder, so ordered in I (in order to correspond to old algorithm)
23413  nloop=0
23414  151 nloop=nloop+1
23415  mord=1
23416  DO 155 ic1=1,ncr-1
23417  i1=icr(ic1)
23418  i2=icr(ic1+1)
23419  IF (i1.GT.i2) THEN
23420  it=i1
23421  mst=mscr(ic1)
23422  icr(ic1)=i2
23423  mscr(ic1)=mscr(ic1+1)
23424  icr(ic1+1)=it
23425  mscr(ic1+1)=mst
23426  mord=0
23427  ENDIF
23428  155 CONTINUE
23429 C...Max do 1000 reordering loops
23430  IF (mord.EQ.0.AND.nloop.LE.1000) GOTO 151
23431 
23432 C...Loop over CR partons
23433 C...(Ignore junctions for now.)
23434  nloop=0
23435  160 nloop=nloop+1
23436  rlmax=0d0
23437  icrmax=0
23438 C...Loop over coloured partons
23439  DO 230 ic1=1,ncr
23440 C...Retrieve parton Event Record index and Colour Side
23441  i=icr(ic1)
23442  msi=mscr(ic1)
23443 C...Skip already connected partons
23444  IF (mcn(i,msi).NE.0) GOTO 230
23445 C...Shorthand for colour charge
23446  mci=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
23447 C...For Seattle algorithm, only start from partons with one dangling
23448 C...colour tag
23449  IF (mstp(95).GE.6.AND.mstp(95).LE.9) THEN
23450  IF (mci.EQ.2.AND.mcn(i,1).EQ.0.AND.mcn(i,2).EQ.0) GOTO 230
23451  ENDIF
23452 C...Retrieve saved optimal partner
23453  io=iopt(ic1)
23454  IF (io.NE.0) THEN
23455 C...Reject saved optimal partner if latter is now connected
23456 C...(Also reject if using model S1, since saved partner may
23457 C...now give rise to gg loop.)
23458  IF (mcn(io,3-msi).NE.0.OR.mstp(95).LE.3) THEN
23459  iopt(ic1)=0
23460  rloptc(ic1)=1d19
23461  ENDIF
23462  ENDIF
23463  rlopt=rloptc(ic1)
23464 C...Search for new optimal partner if necessary
23465  IF (iopt(ic1).EQ.0) THEN
23466  mbropt=0
23467  mggopt=0
23468  rlopt=1d19
23469 C...Loop over partons you can connect to
23470  DO 210 ic2=1,ncr
23471  j=icr(ic2)
23472  msj=mscr(ic2)
23473 C...Skip if already connected
23474  IF (mcn(j,msj).NE.0) GOTO 210
23475 C...Skip if this not colour-anticolour pair
23476  IF (msi.EQ.msj) GOTO 210
23477 C...And do not let gluons connect to themselves
23478  IF (i.EQ.j) GOTO 210
23479 C...Suppress direct connections between partons in same Beam Remnant
23480  mbrstr=0
23481  IF (k(i,3).LE.2.AND.k(i,3).GE.1.AND.k(i,3).EQ.k(j,3))
23482  & mbrstr=1
23483 C...Shorthand for colour charge
23484  mcj=kchg(pycomp(k(j,2)),2)*isign(1,k(j,2))
23485 C...Check for gluon loops
23486  mggstr=0
23487  IF (mcj.EQ.2.AND.mci.EQ.2) THEN
23488  IF (mcn(i,2).EQ.mcn(j,1).AND.mstp(95).LE.3.AND.
23489  & mcn(i,2).NE.0) mggstr=1
23490  ENDIF
23491 C...Save connection with smallest lambda measure
23492  rl=four(i,j)
23493 C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23494  IF (mstp(95).GE.7.AND.mstp(95).LE.8) THEN
23495  IF (k(i,2).EQ.21) rl=0.5d0*rl
23496  IF (k(j,2).EQ.21) rl=0.5d0*rl
23497  ENDIF
23498 C...If best so far was a BR string and this is not, also save.
23499 C...If best so far was a gg string and this is not, also save.
23500 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23501 C...string with a small Lambda measure as the last step, this connection
23502 C...will be saved regardless of whether other possibilities existed.
23503 C...I.e., there should really be a check whether another possibility has
23504 C...already been found, but since these models are now actively in use
23505 C...and uncertainties are anyway large, the algorithm is left as it is.
23506 C...(correction --> Pythia 8 ?)
23507  IF (rl.LT.rlopt.OR.(rl.EQ.rlopt.AND.pyr(0).LE.0.5d0)
23508  & .OR.(mbropt.EQ.1.AND.mbrstr.EQ.0)
23509  & .OR.(mggopt.EQ.1.AND.mggstr.EQ.0)) THEN
23510  rlopt=rl
23511  rloptc(ic1)=rlopt
23512  iopt(ic1)=j
23513  mbropt=mbrstr
23514  mggopt=mggstr
23515  ENDIF
23516  210 CONTINUE
23517  ENDIF
23518  IF (iopt(ic1).NE.0) THEN
23519 C...Save pair with largest RLOPT so far
23520  IF (rlopt.GE.rlmax) THEN
23521  icrmax=ic1
23522  rlmax=rlopt
23523  ENDIF
23524  ENDIF
23525  230 CONTINUE
23526 C...Save and iterate
23527  IF (icrmax.GT.0) THEN
23528  lct=lct+1
23529  ilmax=icr(icrmax)
23530  jlmax=iopt(icrmax)
23531  icmax=mscr(icrmax)
23532  jcmax=3-icmax
23533  mcn(ilmax,icmax)=lct
23534  mcn(jlmax,jcmax)=lct
23535  IF (nloop.LE.2*(n-ip)) THEN
23536  GOTO 160
23537  ELSE
23538  CALL pyerrm(31,' PYFSCR: infinite loop in color annealing')
23539  CALL pystop(11)
23540  ENDIF
23541  ELSE
23542 C...Save and exit. First check for leftover gluon(s)
23543  DO 260 i=max(1,ip),n
23544 C...Check colour charge
23545  mci=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
23546  IF (k(i,1).NE.3.OR.mci.NE.2) GOTO 260
23547  IF(mcn(i,1).EQ.0.AND.mcn(i,2).EQ.0) THEN
23548 C...Decide where to put left-over gluon (minimal insertion)
23549  ilmax=0
23550  rlmax=1d19
23551  DO 250 kct=nct+1,lct
23552  DO 240 it=max(1,ip),n
23553  IF (it.EQ.i.OR.k(it,1).NE.3) GOTO 240
23554  IF (mcn(it,1).EQ.kct) ic=it
23555  IF (mcn(it,2).EQ.kct) ia=it
23556  240 CONTINUE
23557  rl=four(ic,i)*four(ia,i)
23558  IF (rl.LT.rlmax) THEN
23559  rlmax=rl
23560  icmax=ic
23561  iamax=ia
23562  ENDIF
23563  250 CONTINUE
23564  lct=lct+1
23565  mcn(i,1)=mcn(icmax,1)
23566  mcn(i,2)=lct
23567  mcn(icmax,1)=lct
23568  ENDIF
23569  260 CONTINUE
23570 C...Here we need to loop over entire event.
23571  DO 270 iz=max(1,ip),n
23572 C...Do not erase parton shower colour history
23573  IF (k(iz,1).NE.3) GOTO 270
23574 C...Check colour charge
23575  mci=kchg(pycomp(k(iz,2)),2)*isign(1,k(iz,2))
23576  IF (mci.EQ.0) GOTO 270
23577  IF (mcn(iz,1).NE.0) mct(iz,1)=mcn(iz,1)
23578  IF (mcn(iz,2).NE.0) mct(iz,2)=mcn(iz,2)
23579  270 CONTINUE
23580  ENDIF
23581 
23582  9999 RETURN
23583  END
23584 
23585 C*********************************************************************
23586 
23587 C...PYDIFF
23588 C...Handles diffractive and elastic scattering.
23589 
23590  SUBROUTINE pydiff
23591 
23592 C...Double precision and integer declarations.
23593  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23594  IMPLICIT INTEGER(I-N)
23595  INTEGER PYK,PYCHGE,PYCOMP
23596 C...Commonblocks.
23597  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23598  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23599  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23600  common/pyint1/mint(400),vint(400)
23601  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
23602 
23603 C...Reset K, P and V vectors. Store incoming particles.
23604  DO 110 jt=1,mstp(126)+10
23605  i=mint(83)+jt
23606  DO 100 j=1,5
23607  k(i,j)=0
23608  p(i,j)=0d0
23609  v(i,j)=0d0
23610  100 CONTINUE
23611  110 CONTINUE
23612  n=mint(84)
23613  mint(3)=0
23614  mint(21)=0
23615  mint(22)=0
23616  mint(23)=0
23617  mint(24)=0
23618  mint(4)=4
23619  DO 130 jt=1,2
23620  i=mint(83)+jt
23621  k(i,1)=21
23622  k(i,2)=mint(10+jt)
23623  DO 120 j=1,5
23624  p(i,j)=vint(285+5*jt+j)
23625  120 CONTINUE
23626  130 CONTINUE
23627  mint(6)=2
23628 
23629 C...Subprocess; kinematics.
23630  sqlam=(vint(2)-vint(63)-vint(64))**2-4d0*vint(63)*vint(64)
23631  pz=sqrt(sqlam)/(2d0*vint(1))
23632  DO 200 jt=1,2
23633  i=mint(83)+jt
23634  pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2d0*vint(1))
23635  kfh=mint(102+jt)
23636 
23637 C...Elastically scattered particle. (Except elastic GVMD states.)
23638  IF(mint(16+jt).LE.0.AND.(mint(10+jt).NE.22.OR.
23639  & mint(106+jt).NE.3)) THEN
23640  n=n+1
23641  k(n,1)=1
23642  k(n,2)=kfh
23643  k(n,3)=i+2
23644  p(n,3)=pz*(-1)**(jt+1)
23645  p(n,4)=pe
23646  p(n,5)=sqrt(vint(62+jt))
23647 
23648 C...Decay rho from elastic scattering of gamma with sin**2(theta)
23649 C...distribution of decay products (in rho rest frame).
23650  IF(kfh.EQ.113.AND.mint(10+jt).EQ.22.AND.mstp(102).EQ.1) THEN
23651  nsav=n
23652  dbetaz=p(n,3)/sqrt(p(n,3)**2+p(n,5)**2)
23653  p(n,3)=0d0
23654  p(n,4)=p(n,5)
23655  CALL pydecy(nsav)
23656  IF(n.EQ.nsav+2.AND.iabs(k(nsav+1,2)).EQ.211) THEN
23657  phi=pyangl(p(nsav+1,1),p(nsav+1,2))
23658  CALL pyrobo(nsav+1,nsav+2,0d0,-phi,0d0,0d0,0d0)
23659  the=pyangl(p(nsav+1,3),p(nsav+1,1))
23660  CALL pyrobo(nsav+1,nsav+2,-the,0d0,0d0,0d0,0d0)
23661  140 cthe=2d0*pyr(0)-1d0
23662  IF(1d0-cthe**2.LT.pyr(0)) GOTO 140
23663  CALL pyrobo(nsav+1,nsav+2,acos(cthe),phi,0d0,0d0,0d0)
23664  ENDIF
23665  CALL pyrobo(nsav,nsav+2,0d0,0d0,0d0,0d0,dbetaz)
23666  ENDIF
23667 
23668 C...Diffracted particle: low-mass system to two particles.
23669  ELSEIF(vint(62+jt).LT.(vint(66+jt)+parp(103))**2) THEN
23670  n=n+2
23671  k(n-1,1)=1
23672  k(n,1)=1
23673  k(n-1,3)=i+2
23674  k(n,3)=i+2
23675  pmmas=sqrt(vint(62+jt))
23676  ntry=0
23677  150 ntry=ntry+1
23678  IF(ntry.LT.20) THEN
23679  mint(105)=mint(102+jt)
23680  mint(109)=mint(106+jt)
23681  CALL pyspli(kfh,21,kfl1,kfl2)
23682  CALL pykfdi(kfl1,0,kfl3,kf1)
23683  IF(kf1.EQ.0) GOTO 150
23684  CALL pykfdi(kfl2,-kfl3,kfldum,kf2)
23685  IF(kf2.EQ.0) GOTO 150
23686  ELSE
23687  kf1=kfh
23688  kf2=111
23689  ENDIF
23690  pm1=pymass(kf1)
23691  pm2=pymass(kf2)
23692  IF(pm1+pm2+parj(64).GT.pmmas) GOTO 150
23693  k(n-1,2)=kf1
23694  k(n,2)=kf2
23695  p(n-1,5)=pm1
23696  p(n,5)=pm2
23697  pzp=sqrt(max(0d0,(pmmas**2-pm1**2-pm2**2)**2-
23698  & 4d0*pm1**2*pm2**2))/(2d0*pmmas)
23699  p(n-1,3)=pzp
23700  p(n,3)=-pzp
23701  p(n-1,4)=sqrt(pm1**2+pzp**2)
23702  p(n,4)=sqrt(pm2**2+pzp**2)
23703  CALL pyrobo(n-1,n,acos(2d0*pyr(0)-1d0),paru(2)*pyr(0),
23704  & 0d0,0d0,0d0)
23705  dbetaz=pz*(-1)**(jt+1)/sqrt(pz**2+pmmas**2)
23706  CALL pyrobo(n-1,n,0d0,0d0,0d0,0d0,dbetaz)
23707 
23708 C...Diffracted particle: valence quark kicked out.
23709  ELSEIF(mstp(101).EQ.1.OR.(mstp(101).EQ.3.AND.pyr(0).LT.
23710  & parp(101))) THEN
23711  n=n+2
23712  k(n-1,1)=2
23713  k(n,1)=1
23714  k(n-1,3)=i+2
23715  k(n,3)=i+2
23716  mint(105)=mint(102+jt)
23717  mint(109)=mint(106+jt)
23718  CALL pyspli(kfh,21,k(n,2),k(n-1,2))
23719  p(n-1,5)=pymass(k(n-1,2))
23720  p(n,5)=pymass(k(n,2))
23721  sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-
23722  & 4d0*p(n-1,5)**2*p(n,5)**2
23723  p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-
23724  & p(n,5)**2))/(2d0*vint(62+jt))*(-1)**(jt+1)
23725  p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)
23726  p(n,3)=pz*(-1)**(jt+1)-p(n-1,3)
23727  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
23728 
23729 C...Diffracted particle: gluon kicked out.
23730  ELSE
23731  n=n+3
23732  k(n-2,1)=2
23733  k(n-1,1)=2
23734  k(n,1)=1
23735  k(n-2,3)=i+2
23736  k(n-1,3)=i+2
23737  k(n,3)=i+2
23738  mint(105)=mint(102+jt)
23739  mint(109)=mint(106+jt)
23740  CALL pyspli(kfh,21,k(n,2),k(n-2,2))
23741  k(n-1,2)=21
23742  p(n-2,5)=pymass(k(n-2,2))
23743  p(n-1,5)=0d0
23744  p(n,5)=pymass(k(n,2))
23745 C...Energy distribution for particle into two jets.
23746  160 imb=1
23747  IF(mod(kfh/1000,10).NE.0) imb=2
23748  chik=parp(92+2*imb)
23749  IF(mstp(92).LE.1) THEN
23750  IF(imb.EQ.1) chi=pyr(0)
23751  IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
23752  ELSEIF(mstp(92).EQ.2) THEN
23753  chi=1d0-pyr(0)**(1d0/(1d0+chik))
23754  ELSEIF(mstp(92).EQ.3) THEN
23755  cut=2d0*0.3d0/vint(1)
23756  170 chi=pyr(0)**2
23757  IF((chi**2/(chi**2+cut**2))**0.25d0*(1d0-chi)**chik.LT.
23758  & pyr(0)) GOTO 170
23759  ELSEIF(mstp(92).EQ.4) THEN
23760  cut=2d0*0.3d0/vint(1)
23761  cutr=(1d0+sqrt(1d0+cut**2))/cut
23762  180 chir=cut*cutr**pyr(0)
23763  chi=(chir**2-cut**2)/(2d0*chir)
23764  IF((1d0-chi)**chik.LT.pyr(0)) GOTO 180
23765  ELSE
23766  cut=2d0*0.3d0/vint(1)
23767  cuta=cut**(1d0-parp(98))
23768  cutb=(1d0+cut)**(1d0-parp(98))
23769  190 chi=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
23770  IF(((chi+cut)**2/(2d0*(chi**2+cut**2)))**
23771  & (0.5d0*parp(98))*(1d0-chi)**chik.LT.pyr(0)) GOTO 190
23772  ENDIF
23773  IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1d0-p(n-2,5)**2/
23774  & vint(62+jt)) GOTO 160
23775  sqm=p(n-2,5)**2/(1d0-chi)+p(n,5)**2/chi
23776  pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/
23777  & (2d0*vint(62+jt))
23778  pei=sqrt(pzi**2+sqm)
23779  pqqp=(1d0-chi)*(pei+pzi)
23780  p(n-2,3)=0.5d0*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)
23781  p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)
23782  p(n-1,4)=0.5d0*(vint(62+jt)-sqm)/(pei+pzi)
23783  p(n-1,3)=p(n-1,4)*(-1)**jt
23784  p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)
23785  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
23786  ENDIF
23787 
23788 C...Documentation lines.
23789  k(i+2,1)=21
23790  IF(mint(16+jt).EQ.0) k(i+2,2)=kfh
23791  IF(mint(16+jt).NE.0.OR.(mint(10+jt).EQ.22.AND.
23792  & mint(106+jt).EQ.3)) k(i+2,2)=isign(9900000,kfh)+10*(kfh/10)
23793  k(i+2,3)=i
23794  p(i+2,3)=pz*(-1)**(jt+1)
23795  p(i+2,4)=pe
23796  p(i+2,5)=sqrt(vint(62+jt))
23797  200 CONTINUE
23798 
23799 C...Rotate outgoing partons/particles using cos(theta).
23800  IF(vint(23).LT.0.9d0) THEN
23801  CALL pyrobo(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0)
23802  ELSE
23803  CALL pyrobo(mint(83)+3,n,asin(vint(59)),vint(24),0d0,0d0,0d0)
23804  ENDIF
23805 
23806  RETURN
23807  END
23808 
23809 C*********************************************************************
23810 
23811 C...PYDISG
23812 C...Set up a DIS process as gamma* + f -> f, with beam remnant
23813 C...and showering added consecutively. Photon flux by the PYGAGA
23814 C...routine (if at all).
23815 
23816  SUBROUTINE pydisg
23817 
23818 C...Double precision and integer declarations.
23819  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23820  IMPLICIT INTEGER(I-N)
23821  INTEGER PYK,PYCHGE,PYCOMP
23822 C...Parameter statement to help give large particle numbers.
23823  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
23824  &kexcit=4000000,kdimen=5000000)
23825 C...Commonblocks.
23826  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23827  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23828  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
23829  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
23830  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23831  common/pyint1/mint(400),vint(400)
23832  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
23833 C...Local arrays.
23834  dimension pms(4)
23835 
23836 C...Choice of subprocess, number of documentation lines
23837  idoc=7
23838  mint(3)=idoc-6
23839  mint(4)=idoc
23840  ipu1=mint(84)+1
23841  ipu2=mint(84)+2
23842  ipu3=mint(84)+3
23843  iside=1
23844  IF(mint(107).EQ.4) iside=2
23845 
23846 C...Reset K, P and V vectors. Store incoming particles
23847  DO 110 jt=1,mstp(126)+20
23848  i=mint(83)+jt
23849  DO 100 j=1,5
23850  k(i,j)=0
23851  p(i,j)=0d0
23852  v(i,j)=0d0
23853  100 CONTINUE
23854  110 CONTINUE
23855  DO 130 jt=1,2
23856  i=mint(83)+jt
23857  k(i,1)=21
23858  k(i,2)=mint(10+jt)
23859  DO 120 j=1,5
23860  p(i,j)=vint(285+5*jt+j)
23861  120 CONTINUE
23862  130 CONTINUE
23863  mint(6)=2
23864 
23865 C...Store incoming partons in hadronic CM-frame
23866  DO 140 jt=1,2
23867  i=mint(84)+jt
23868  k(i,1)=14
23869  k(i,2)=mint(14+jt)
23870  k(i,3)=mint(83)+2+jt
23871  140 CONTINUE
23872  IF(mint(15).EQ.22) THEN
23873  p(mint(84)+1,3)=0.5d0*(vint(1)+vint(307)/vint(1))
23874  p(mint(84)+1,4)=0.5d0*(vint(1)-vint(307)/vint(1))
23875  p(mint(84)+1,5)=-sqrt(vint(307))
23876  p(mint(84)+2,3)=-0.5d0*vint(307)/vint(1)
23877  p(mint(84)+2,4)=0.5d0*vint(307)/vint(1)
23878  kfres=mint(16)
23879  iside=2
23880  ELSE
23881  p(mint(84)+1,3)=0.5d0*vint(308)/vint(1)
23882  p(mint(84)+1,4)=0.5d0*vint(308)/vint(1)
23883  p(mint(84)+2,3)=-0.5d0*(vint(1)+vint(308)/vint(1))
23884  p(mint(84)+2,4)=0.5d0*(vint(1)-vint(308)/vint(1))
23885  p(mint(84)+1,5)=-sqrt(vint(308))
23886  kfres=mint(15)
23887  iside=1
23888  ENDIF
23889  sidesg=(-1d0)**(iside-1)
23890 
23891 C...Copy incoming partons to documentation lines.
23892  DO 170 jt=1,2
23893  i1=mint(83)+4+jt
23894  i2=mint(84)+jt
23895  k(i1,1)=21
23896  k(i1,2)=k(i2,2)
23897  k(i1,3)=i1-2
23898  DO 150 j=1,5
23899  p(i1,j)=p(i2,j)
23900  150 CONTINUE
23901 
23902 C...Second copy for partons before ISR shower, since no such.
23903  i1=mint(83)+2+jt
23904  k(i1,1)=21
23905  k(i1,2)=k(i2,2)
23906  k(i1,3)=i1-2
23907  DO 160 j=1,5
23908  p(i1,j)=p(i2,j)
23909  160 CONTINUE
23910  170 CONTINUE
23911 
23912 C...Define initial partons.
23913  ntry=0
23914  180 ntry=ntry+1
23915  IF(ntry.GT.100) THEN
23916  mint(51)=1
23917  RETURN
23918  ENDIF
23919 
23920 C...Scattered quark in hadronic CM frame.
23921  i=mint(83)+7
23922  k(ipu3,1)=3
23923  k(ipu3,2)=kfres
23924  k(ipu3,3)=i
23925  p(ipu3,5)=pymass(kfres)
23926  p(ipu3,3)=p(ipu1,3)+p(ipu2,3)
23927  p(ipu3,4)=p(ipu1,4)+p(ipu2,4)
23928  p(ipu3,5)=0d0
23929  k(i,1)=21
23930  k(i,2)=kfres
23931  k(i,3)=mint(83)+4+iside
23932  p(i,3)=p(ipu3,3)
23933  p(i,4)=p(ipu3,4)
23934  p(i,5)=p(ipu3,5)
23935  n=ipu3
23936  mint(21)=kfres
23937  mint(22)=0
23938 
23939 C...No primordial kT, or chosen according to truncated Gaussian or
23940 C...exponential, or (for photon) predetermined or power law.
23941  190 IF(mint(40+iside).EQ.2.AND.mint(10+iside).NE.22) THEN
23942  IF(mstp(91).LE.0) THEN
23943  pt=0d0
23944  ELSEIF(mstp(91).EQ.1) THEN
23945  pt=parp(91)*sqrt(-log(pyr(0)))
23946  ELSE
23947  rpt1=pyr(0)
23948  rpt2=pyr(0)
23949  pt=-parp(92)*log(rpt1*rpt2)
23950  ENDIF
23951  IF(pt.GT.parp(93)) GOTO 190
23952  ELSEIF(mint(106+iside).EQ.3) THEN
23953  pta=sqrt(vint(282+iside))
23954  ptb=0d0
23955  IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
23956  ptb=parp(99)*sqrt(-log(pyr(0)))
23957  ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
23958  rpt1=pyr(0)
23959  rpt2=pyr(0)
23960  ptb=-parp(99)*log(rpt1*rpt2)
23961  ENDIF
23962  IF(ptb.GT.parp(100)) GOTO 190
23963  pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
23964  IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
23965  ELSEIF(iabs(mint(14+iside)).LE.8.OR.mint(14+iside).EQ.21) THEN
23966  IF(mstp(93).LE.0) THEN
23967  pt=0d0
23968  ELSEIF(mstp(93).EQ.1) THEN
23969  pt=parp(99)*sqrt(-log(pyr(0)))
23970  ELSEIF(mstp(93).EQ.2) THEN
23971  rpt1=pyr(0)
23972  rpt2=pyr(0)
23973  pt=-parp(99)*log(rpt1*rpt2)
23974  ELSEIF(mstp(93).EQ.3) THEN
23975  ha=parp(99)**2
23976  hb=parp(100)**2
23977  pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
23978  ELSE
23979  ha=parp(99)**2
23980  hb=parp(100)**2
23981  IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
23982  pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
23983  ENDIF
23984  IF(pt.GT.parp(100)) GOTO 190
23985  ELSE
23986  pt=0d0
23987  ENDIF
23988  vint(156+iside)=pt
23989  phi=paru(2)*pyr(0)
23990  p(ipu3,1)=pt*cos(phi)
23991  p(ipu3,2)=pt*sin(phi)
23992  p(ipu3,4)=sqrt(p(ipu3,5)**2+pt**2+p(ipu3,3)**2)
23993  pms(3-iside)=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
23994  pcp=p(ipu3,4)+abs(p(ipu3,3))
23995 
23996 C...Find one or two beam remnants.
23997  mint(105)=mint(102+iside)
23998  mint(109)=mint(106+iside)
23999  CALL pyspli(mint(10+iside),mint(12+iside),kflch,kflsp)
24000  IF(mint(51).NE.0) THEN
24001  mint(51)=0
24002  GOTO 180
24003  ENDIF
24004 
24005 C...Store first remnant parton, with colour info and kinematics.
24006  i=n+1
24007  k(i,1)=1
24008  k(i,2)=kflsp
24009  k(i,3)=mint(83)+iside
24010  p(i,5)=pymass(k(i,2))
24011  kcol=kchg(pycomp(kflsp),2)
24012  IF(kcol.NE.0) THEN
24013  k(i,1)=3
24014  kfls=(3-kcol*isign(1,kflsp))/2
24015  k(i,kfls+3)=mstu(5)*ipu3
24016  k(ipu3,6-kfls)=mstu(5)*i
24017  icolr=i
24018  ENDIF
24019  IF(kflch.EQ.0) THEN
24020  p(i,1)=-p(ipu3,1)
24021  p(i,2)=-p(ipu3,2)
24022  pms(iside)=p(i,5)**2+p(i,1)**2+p(i,2)**2
24023  p(i,3)=-p(ipu3,3)
24024  p(i,4)=sqrt(pms(iside)+p(i,3)**2)
24025  prp=p(i,4)+abs(p(i,3))
24026 
24027 C...When extra remnant parton or hadron: store extra remnant.
24028  ELSE
24029  i=i+1
24030  k(i,1)=1
24031  k(i,2)=kflch
24032  k(i,3)=mint(83)+iside
24033  p(i,5)=pymass(k(i,2))
24034  kcol=kchg(pycomp(kflch),2)
24035  IF(kcol.NE.0) THEN
24036  k(i,1)=3
24037  kfls=(3-kcol*isign(1,kflch))/2
24038  k(i,kfls+3)=mstu(5)*ipu3
24039  k(ipu3,6-kfls)=mstu(5)*i
24040  icolr=i
24041  ENDIF
24042 
24043 C...Relative transverse momentum when two remnants.
24044  loop=0
24045  200 loop=loop+1
24046  CALL pyptdi(1,p(i-1,1),p(i-1,2))
24047  p(i-1,1)=p(i-1,1)-0.5d0*p(ipu3,1)
24048  p(i-1,2)=p(i-1,2)-0.5d0*p(ipu3,2)
24049  pms(3)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
24050  p(i,1)=-p(ipu3,1)-p(i-1,1)
24051  p(i,2)=-p(ipu3,2)-p(i-1,2)
24052  pms(4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
24053 
24054 C...Relative distribution of energy for particle into jet plus particle.
24055  imb=1
24056  IF(mod(mint(10+iside)/1000,10).NE.0) imb=2
24057  IF(mstp(94).LE.1) THEN
24058  IF(imb.EQ.1) chi=pyr(0)
24059  IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
24060  IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
24061  ELSEIF(mstp(94).EQ.2) THEN
24062  chi=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
24063  IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
24064  ELSEIF(mstp(94).EQ.3) THEN
24065  CALL pyzdis(1,0,pms(4),zz)
24066  chi=zz
24067  ELSE
24068  CALL pyzdis(1000,0,pms(4),zz)
24069  chi=zz
24070  ENDIF
24071 
24072 C...Construct total transverse mass; reject if too large.
24073  chi=max(1d-8,min(1d0-1d-8,chi))
24074  pms(iside)=pms(4)/chi+pms(3)/(1d0-chi)
24075  IF(pms(iside).GT.p(ipu3,4)**2) THEN
24076  IF(loop.LT.10) GOTO 200
24077  GOTO 180
24078  ENDIF
24079  vint(158+iside)=chi
24080 
24081 C...Subdivide longitudinal momentum according to value selected above.
24082  prp=sqrt(pms(iside)+p(ipu3,3)**2)+abs(p(ipu3,3))
24083  pw1=(1d0-chi)*prp
24084  p(i-1,4)=0.5d0*(pw1+pms(3)/pw1)
24085  p(i-1,3)=0.5d0*(pw1-pms(3)/pw1)*sidesg
24086  pw2=chi*prp
24087  p(i,4)=0.5d0*(pw2+pms(4)/pw2)
24088  p(i,3)=0.5d0*(pw2-pms(4)/pw2)*sidesg
24089  ENDIF
24090  n=i
24091 
24092 C...Boost current and remnant systems to correct frame.
24093  IF(sqrt(pms(1))+sqrt(pms(2)).GT.0.99d0*vint(1)) GOTO 180
24094  dsqlam=sqrt(max(0d0,(vint(2)-pms(1)-pms(2))**2-4d0*pms(1)*pms(2)))
24095  drkc=(vint(2)+pms(3-iside)-pms(iside)+dsqlam)/
24096  &(2d0*vint(1)*pcp)
24097  drkr=(vint(2)+pms(iside)-pms(3-iside)+dsqlam)/
24098  &(2d0*vint(1)*prp)
24099  dbec=-sidesg*(drkc**2-1d0)/(drkc**2+1d0)
24100  dber=sidesg*(drkr**2-1d0)/(drkr**2+1d0)
24101  CALL pyrobo(ipu3,ipu3,0d0,0d0,0d0,0d0,dbec)
24102  CALL pyrobo(ipu3+1,n,0d0,0d0,0d0,0d0,dber)
24103 
24104 C...Let current quark shower; recoil but no showering by colour partner.
24105  qmax=2d0*sqrt(vint(309-iside))
24106  mstj48=mstj(48)
24107  mstj(48)=1
24108  parj86=parj(86)
24109  parj(86)=0d0
24110  IF(mstp(71).EQ.1) CALL pyshow(ipu3,icolr,qmax)
24111  mstj(48)=mstj48
24112  parj(86)=parj86
24113 
24114  RETURN
24115  END
24116 
24117 C*********************************************************************
24118 
24119 C...PYDOCU
24120 C...Handles the documentation of the process in MSTI and PARI,
24121 C...and also computes cross-sections based on accumulated statistics.
24122 
24123  SUBROUTINE pydocu
24124 
24125 C...Double precision and integer declarations.
24126  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24127  IMPLICIT INTEGER(I-N)
24128  INTEGER PYK,PYCHGE,PYCOMP
24129 C...Commonblocks.
24130  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
24131  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24132  common/pypars/mstp(200),parp(200),msti(200),pari(200)
24133  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
24134  common/pyint1/mint(400),vint(400)
24135  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
24136  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
24137  SAVE /pyjets/,/pydat1/,/pysubs/,/pypars/,/pyint1/,/pyint2/,
24138  &/pyint5/
24139 
24140 C...Calculate Monte Carlo estimates of cross-sections.
24141  isub=mint(1)
24142  IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1
24143  ngen(0,3)=ngen(0,3)+1
24144  xsec(0,3)=0d0
24145  DO 100 i=1,500
24146  IF(i.EQ.96.OR.i.EQ.97) THEN
24147  xsec(i,3)=0d0
24148  ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR.
24149  & i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN
24150  xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
24151  & dble(ngen(96,2)))
24152  ELSEIF(msub(95).EQ.1.AND.i.GE.381.AND.i.LE.386) THEN
24153  xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
24154  & dble(ngen(96,2)))
24155  ELSEIF(msub(i).EQ.0.OR.ngen(i,1).EQ.0) THEN
24156  xsec(i,3)=0d0
24157  ELSEIF(ngen(i,2).EQ.0) THEN
24158  xsec(i,3)=xsec(i,2)*ngen(0,3)/(dble(ngen(i,1))*
24159  & dble(ngen(0,2)))
24160  ELSE
24161  xsec(i,3)=xsec(i,2)*ngen(i,3)/(dble(ngen(i,1))*
24162  & dble(ngen(i,2)))
24163  ENDIF
24164  xsec(0,3)=xsec(0,3)+xsec(i,3)
24165  100 CONTINUE
24166 
24167 C...Rescale to known low-pT cross-section for standard QCD processes.
24168  IF(msub(95).EQ.1) THEN
24169  xsech=xsec(11,3)+xsec(12,3)+xsec(13,3)+xsec(28,3)+xsec(53,3)+
24170  & xsec(68,3)+xsec(95,3)
24171  xsecw=xsec(97,2)/max(1d0,dble(ngen(97,1)))
24172  IF(xsech.GT.1d-20.AND.xsecw.GT.1d-20) THEN
24173  fac=xsecw/xsech
24174  xsec(11,3)=fac*xsec(11,3)
24175  xsec(12,3)=fac*xsec(12,3)
24176  xsec(13,3)=fac*xsec(13,3)
24177  xsec(28,3)=fac*xsec(28,3)
24178  xsec(53,3)=fac*xsec(53,3)
24179  xsec(68,3)=fac*xsec(68,3)
24180  xsec(95,3)=fac*xsec(95,3)
24181  xsec(0,3)=xsec(0,3)-xsech+xsecw
24182  ENDIF
24183  ENDIF
24184 
24185 C...Save information for gamma-p and gamma-gamma.
24186  IF(mint(121).GT.1) THEN
24187  iga=mint(122)
24188  CALL pysave(2,iga)
24189  CALL pysave(5,0)
24190  ENDIF
24191 
24192 C...Reset information on hard interaction.
24193  DO 110 j=1,200
24194  msti(j)=0
24195  pari(j)=0d0
24196  110 CONTINUE
24197 
24198 C...Copy integer valued information from MINT into MSTI.
24199  DO 120 j=1,32
24200  msti(j)=mint(j)
24201  120 CONTINUE
24202  IF(mint(121).GT.1) msti(9)=mint(122)
24203 
24204 C...Store cross-section variables in PARI.
24205  pari(1)=xsec(0,3)
24206  pari(2)=xsec(0,3)/mint(5)
24207  pari(7)=vint(97)
24208  pari(9)=vint(99)
24209  pari(10)=vint(100)
24210  vint(98)=vint(98)+vint(100)
24211  IF(mstp(142).EQ.1) pari(2)=xsec(0,3)/vint(98)
24212 
24213 C...Store kinematics variables in PARI.
24214  pari(11)=vint(1)
24215  pari(12)=vint(2)
24216  IF(isub.NE.95) THEN
24217  DO 130 j=13,26
24218  pari(j)=vint(30+j)
24219  130 CONTINUE
24220  pari(29)=vint(39)
24221  pari(30)=vint(40)
24222  pari(31)=vint(141)
24223  pari(32)=vint(142)
24224  pari(33)=vint(41)
24225  pari(34)=vint(42)
24226  pari(35)=pari(33)-pari(34)
24227  pari(36)=vint(21)
24228  pari(37)=vint(22)
24229  pari(38)=vint(26)
24230  pari(39)=vint(157)
24231  pari(40)=vint(158)
24232  pari(41)=vint(23)
24233  pari(42)=2d0*vint(47)/vint(1)
24234  ENDIF
24235 
24236 C...Store information on scattered partons in PARI.
24237  IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN
24238  DO 140 is=7,8
24239  i=mint(is)
24240  pari(36+is)=p(i,3)/vint(1)
24241  pari(38+is)=p(i,4)/vint(1)
24242  pr=max(1d-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)
24243  pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
24244  & sqrt(pr),1d20)),p(i,3))
24245  pr=max(1d-20,p(i,1)**2+p(i,2)**2)
24246  pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
24247  & sqrt(pr),1d20)),p(i,3))
24248  pari(44+is)=p(i,3)/sqrt(1d-20+p(i,1)**2+p(i,2)**2+p(i,3)**2)
24249  pari(46+is)=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
24250  pari(48+is)=pyangl(p(i,1),p(i,2))
24251  140 CONTINUE
24252  ENDIF
24253 
24254 C...Store sum up transverse and longitudinal momenta.
24255  pari(65)=2d0*pari(17)
24256  IF(isub.LE.90.OR.isub.GE.95) THEN
24257  DO 150 i=mstp(126)+1,n
24258  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150
24259  pt=sqrt(p(i,1)**2+p(i,2)**2)
24260  pari(69)=pari(69)+pt
24261  IF(i.LE.mint(52)) pari(66)=pari(66)+pt
24262  IF(i.GT.mint(52).AND.i.LE.mint(53)) pari(68)=pari(68)+pt
24263  150 CONTINUE
24264  pari(67)=pari(68)
24265  pari(71)=vint(151)
24266  pari(72)=vint(152)
24267  pari(73)=vint(151)
24268  pari(74)=vint(152)
24269  ELSE
24270  pari(66)=pari(65)
24271  pari(69)=pari(65)
24272  ENDIF
24273 
24274 C...Store various other pieces of information into PARI.
24275  pari(61)=vint(148)
24276  pari(75)=vint(155)
24277  pari(76)=vint(156)
24278  pari(77)=vint(159)
24279  pari(78)=vint(160)
24280  pari(81)=vint(138)
24281 
24282 C...Store information on lepton -> lepton + gamma in PYGAGA.
24283  msti(71)=mint(141)
24284  msti(72)=mint(142)
24285  pari(101)=vint(301)
24286  pari(102)=vint(302)
24287  DO 160 i=103,114
24288  pari(i)=vint(i+202)
24289  160 CONTINUE
24290 
24291 C...Set information for PYTABU.
24292  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
24293  mstu(161)=mint(21)
24294  mstu(162)=0
24295  ELSEIF(iset(isub).EQ.5) THEN
24296  mstu(161)=mint(23)
24297  mstu(162)=0
24298  ELSE
24299  mstu(161)=mint(21)
24300  mstu(162)=mint(22)
24301  ENDIF
24302 
24303  RETURN
24304  END
24305 
24306 C*********************************************************************
24307 
24308 C...PYFRAM
24309 C...Performs transformations between different coordinate frames.
24310 
24311  SUBROUTINE pyfram(IFRAME)
24312 
24313 C...Double precision and integer declarations.
24314  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24315  IMPLICIT INTEGER(I-N)
24316  INTEGER PYK,PYCHGE,PYCOMP
24317 C...Commonblocks.
24318  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24319  common/pypars/mstp(200),parp(200),msti(200),pari(200)
24320  common/pyint1/mint(400),vint(400)
24321  SAVE /pydat1/,/pypars/,/pyint1/
24322 
24323 C...Check that transformation can and should be done.
24324  IF(iframe.EQ.1.OR.iframe.EQ.2.OR.(iframe.EQ.3.AND.
24325  &mint(91).EQ.1)) THEN
24326  IF(iframe.EQ.mint(6)) RETURN
24327  ELSE
24328  WRITE(mstu(11),5000) iframe,mint(6)
24329  RETURN
24330  ENDIF
24331 
24332  IF(mint(6).EQ.1) THEN
24333 C...Transform from fixed target or user specified frame to
24334 C...overall CM frame.
24335  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
24336  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
24337  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
24338  ELSEIF(mint(6).EQ.3) THEN
24339 C...Transform from hadronic CM frame in DIS to overall CM frame.
24340  CALL pyrobo(0,0,-vint(221),-vint(222),-vint(223),-vint(224),
24341  & -vint(225))
24342  ENDIF
24343 
24344  IF(iframe.EQ.1) THEN
24345 C...Transform from overall CM frame to fixed target or user specified
24346 C...frame.
24347  CALL pyrobo(0,0,vint(6),vint(7),vint(8),vint(9),vint(10))
24348  ELSEIF(iframe.EQ.3) THEN
24349 C...Transform from overall CM frame to hadronic CM frame in DIS.
24350  CALL pyrobo(0,0,0d0,0d0,vint(223),vint(224),vint(225))
24351  CALL pyrobo(0,0,0d0,vint(222),0d0,0d0,0d0)
24352  CALL pyrobo(0,0,vint(221),0d0,0d0,0d0,0d0)
24353  ENDIF
24354 
24355 C...Set information about new frame.
24356  mint(6)=iframe
24357  msti(6)=iframe
24358 
24359  5000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,
24360  &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =',
24361  &1x,i5)
24362 
24363  RETURN
24364  END
24365 
24366 C*********************************************************************
24367 
24368 C...PYWIDT
24369 C...Calculates full and partial widths of resonances.
24370 
24371  SUBROUTINE pywidt(KFLR,SH,WDTP,WDTE)
24372 
24373 C...Double precision and integer declarations.
24374  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24375  IMPLICIT INTEGER(I-N)
24376  INTEGER PYK,PYCHGE,PYCOMP
24377 C...Parameter statement to help give large particle numbers.
24378  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
24379  &kexcit=4000000,kdimen=5000000)
24380 C...Commonblocks.
24381  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24382  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24383  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
24384  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
24385  common/pypars/mstp(200),parp(200),msti(200),pari(200)
24386  common/pyint1/mint(400),vint(400)
24387  common/pyint4/mwid(500),wids(500,5)
24388  common/pymssm/imss(0:99),rmss(0:99)
24389  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
24390  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
24391  common/pytcsm/itcm(0:99),rtcm(0:99)
24392  common/pypued/iued(0:99),rued(0:99)
24393  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
24394  &/pyint4/,/pymssm/,/pyssmt/,/pytcsm/,/pypued/
24395 C...Local arrays and saved variables.
24396  COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24397  dimension wdtp(0:400),wdte(0:400,0:5),mofsv(3,2),widwsv(3,2),
24398  &wid2sv(3,2),wdtpp(0:400),wdtep(0:400,0:5)
24399 C...UED: equivalences between ordered particles (451->475)
24400 C...and UED particle code (5 000 000 + id)
24401  parameter(kkflmi=451,kkflma=475)
24402  dimension chidel(3), iuedpr(25)
24403  dimension iuedeq(kkflma),mued(2)
24404  common/sw1/sw21,cw21
24405  DATA (iuedeq(i),i=kkflmi,kkflma)/
24406  & 6100001,6100002,6100003,6100004,6100005,6100006,
24407  & 5100001,5100002,5100003,5100004,5100005,5100006,
24408  & 6100011,6100013,6100015,
24409  & 5100012,5100011,5100014,5100013,5100016,5100015,
24410  & 5100021,5100022,5100023,5100024/
24411 C...Save local variables
24412  SAVE mofsv,widwsv,wid2sv
24413 C...Initial values
24414  DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
24415  DATA chidel/1.1d-03,1.d0,7.4d+2/
24416  DATA iuedpr/25*0/
24417 C...UED: inline functions used in kk width calculus
24418  fkac1(x,y)=1.-x**2/y**2
24419  fkac2(x,y)=2.+x**2/y**2
24420 
24421 C...Compressed code and sign; mass.
24422  kfla=iabs(kflr)
24423  kfls=isign(1,kflr)
24424  kc=pycomp(kfla)
24425  shr=sqrt(sh)
24426  pmr=pmas(kc,1)
24427 
24428 C...Reset width information.
24429  DO 110 i=0,mdcy(kc,3)
24430  wdtp(i)=0d0
24431  DO 100 j=0,5
24432  wdte(i,j)=0d0
24433  100 CONTINUE
24434  110 CONTINUE
24435 
24436 C...Allow for fudge factor to rescale resonance width.
24437  fudge=1d0
24438  IF(mstp(110).NE.0.AND.(mwid(kc).EQ.1.OR.mwid(kc).EQ.2.OR.
24439  &(mwid(kc).EQ.3.AND.mint(63).EQ.1))) THEN
24440  IF(mstp(110).EQ.kfla) THEN
24441  fudge=parp(110)
24442  ELSEIF(mstp(110).EQ.-1) THEN
24443  IF(kfla.NE.6.AND.kfla.NE.23.AND.kfla.NE.24) fudge=parp(110)
24444  ELSEIF(mstp(110).EQ.-2) THEN
24445  fudge=parp(110)
24446  ENDIF
24447  ENDIF
24448 
24449 C...Not to be treated as a resonance: return.
24450  IF((mwid(kc).LE.0.OR.mwid(kc).GE.4).AND.kfla.NE.21.AND.
24451  &kfla.NE.22) THEN
24452  wdtp(0)=1d0
24453  wdte(0,0)=1d0
24454  mint(61)=0
24455  mint(62)=0
24456  mint(63)=0
24457  RETURN
24458 
24459 C...Treatment as a resonance based on tabulated branching ratios.
24460  ELSEIF(mwid(kc).EQ.2.OR.(mwid(kc).EQ.3.AND.mint(63).EQ.0)) THEN
24461 C...Loop over possible decay channels; skip irrelevant ones.
24462  DO 120 i=1,mdcy(kc,3)
24463  idc=i+mdcy(kc,2)-1
24464  IF(mdme(idc,1).LT.0) GOTO 120
24465 
24466 C...Read out decay products and nominal masses.
24467  kfd1=kfdp(idc,1)
24468  kfc1=pycomp(kfd1)
24469  IF(kchg(kfc1,3).EQ.1) kfd1=kfls*kfd1
24470  pm1=pmas(kfc1,1)
24471  kfd2=kfdp(idc,2)
24472  kfc2=pycomp(kfd2)
24473  IF(kchg(kfc2,3).EQ.1) kfd2=kfls*kfd2
24474  pm2=pmas(kfc2,1)
24475  kfd3=kfdp(idc,3)
24476  pm3=0d0
24477  IF(kfd3.NE.0) THEN
24478  kfc3=pycomp(kfd3)
24479  IF(kchg(kfc3,3).EQ.1) kfd3=kfls*kfd3
24480  pm3=pmas(kfc3,1)
24481  ENDIF
24482 
24483 C...Naive partial width and alternative threshold factors.
24484  wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)
24485  IF(mdme(idc,2).GE.51.AND.mdme(idc,2).LE.53.AND.
24486  & pm1+pm2+pm3.GE.shr) THEN
24487  wdtp(i)=0d0
24488  ELSEIF(mdme(idc,2).EQ.52.AND.kfd3.EQ.0) THEN
24489  wdtp(i)=wdtp(i)*sqrt(max(0d0,(sh-pm1**2-pm2**2)**2-
24490  & 4d0*pm1**2*pm2**2))/sh
24491  ELSEIF(mdme(idc,2).EQ.52) THEN
24492  pma=max(pm1,pm2,pm3)
24493  pmc=min(pm1,pm2,pm3)
24494  pmb=pm1+pm2+pm3-pma-pmc
24495  pmbc=pmb+pmc+0.5d0*(shr-pma-pmc-pmc)
24496  pman=pma**2/sh
24497  pmbn=pmb**2/sh
24498  pmcn=pmc**2/sh
24499  pmbcn=pmbc**2/sh
24500  wdtp(i)=wdtp(i)*sqrt(max(0d0,
24501  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
24502  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
24503  & ((shr-pma)**2-(pmb+pmc)**2)*
24504  & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
24505  & ((1d0-pmbcn)*pmbcn*sh)
24506  ELSEIF(mdme(idc,2).EQ.53.AND.kfd3.EQ.0) THEN
24507  wdtp(i)=wdtp(i)*sqrt(
24508  & max(0d0,(sh-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2)/
24509  & max(1d-4,(pmr**2-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2))
24510  ELSEIF(mdme(idc,2).EQ.53) THEN
24511  pma=max(pm1,pm2,pm3)
24512  pmc=min(pm1,pm2,pm3)
24513  pmb=pm1+pm2+pm3-pma-pmc
24514  pmbc=pmb+pmc+0.5d0*(shr-pma-pmb-pmc)
24515  pman=pma**2/sh
24516  pmbn=pmb**2/sh
24517  pmcn=pmc**2/sh
24518  pmbcn=pmbc**2/sh
24519  facact=sqrt(max(0d0,
24520  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
24521  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
24522  & ((shr-pma)**2-(pmb+pmc)**2)*
24523  & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
24524  & ((1d0-pmbcn)*pmbcn*sh)
24525  pmbc=pmb+pmc+0.5d0*(pmr-pma-pmb-pmc)
24526  pman=pma**2/pmr**2
24527  pmbn=pmb**2/pmr**2
24528  pmcn=pmc**2/pmr**2
24529  pmbcn=pmbc**2/pmr**2
24530  facnom=sqrt(max(0d0,
24531  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
24532  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
24533  & ((pmr-pma)**2-(pmb+pmc)**2)*
24534  & (1d0+0.25d0*(pma+pmb+pmc)/pmr)/
24535  & ((1d0-pmbcn)*pmbcn*pmr**2)
24536  wdtp(i)=wdtp(i)*facact/max(1d-6,facnom)
24537  ENDIF
24538  wdtp(i)=fudge*wdtp(i)
24539  wdtp(0)=wdtp(0)+wdtp(i)
24540 
24541 C...Calculate secondary width (at most two identical/opposite).
24542  wid2=1d0
24543  IF(mdme(idc,1).GT.0) THEN
24544  IF(kfd2.EQ.kfd1) THEN
24545  IF(kchg(kfc1,3).EQ.0) THEN
24546  wid2=wids(kfc1,1)
24547  ELSEIF(kfd1.GT.0) THEN
24548  wid2=wids(kfc1,4)
24549  ELSE
24550  wid2=wids(kfc1,5)
24551  ENDIF
24552  IF(kfd3.GT.0) THEN
24553  wid2=wid2*wids(kfc3,2)
24554  ELSEIF(kfd3.LT.0) THEN
24555  wid2=wid2*wids(kfc3,3)
24556  ENDIF
24557  ELSEIF(kfd2.EQ.-kfd1) THEN
24558  wid2=wids(kfc1,1)
24559  IF(kfd3.GT.0) THEN
24560  wid2=wid2*wids(kfc3,2)
24561  ELSEIF(kfd3.LT.0) THEN
24562  wid2=wid2*wids(kfc3,3)
24563  ENDIF
24564  ELSEIF(kfd3.EQ.kfd1) THEN
24565  IF(kchg(kfc1,3).EQ.0) THEN
24566  wid2=wids(kfc1,1)
24567  ELSEIF(kfd1.GT.0) THEN
24568  wid2=wids(kfc1,4)
24569  ELSE
24570  wid2=wids(kfc1,5)
24571  ENDIF
24572  IF(kfd2.GT.0) THEN
24573  wid2=wid2*wids(kfc2,2)
24574  ELSEIF(kfd2.LT.0) THEN
24575  wid2=wid2*wids(kfc2,3)
24576  ENDIF
24577  ELSEIF(kfd3.EQ.-kfd1) THEN
24578  wid2=wids(kfc1,1)
24579  IF(kfd2.GT.0) THEN
24580  wid2=wid2*wids(kfc2,2)
24581  ELSEIF(kfd2.LT.0) THEN
24582  wid2=wid2*wids(kfc2,3)
24583  ENDIF
24584  ELSEIF(kfd3.EQ.kfd2) THEN
24585  IF(kchg(kfc2,3).EQ.0) THEN
24586  wid2=wids(kfc2,1)
24587  ELSEIF(kfd2.GT.0) THEN
24588  wid2=wids(kfc2,4)
24589  ELSE
24590  wid2=wids(kfc2,5)
24591  ENDIF
24592  IF(kfd1.GT.0) THEN
24593  wid2=wid2*wids(kfc1,2)
24594  ELSEIF(kfd1.LT.0) THEN
24595  wid2=wid2*wids(kfc1,3)
24596  ENDIF
24597  ELSEIF(kfd3.EQ.-kfd2) THEN
24598  wid2=wids(kfc2,1)
24599  IF(kfd1.GT.0) THEN
24600  wid2=wid2*wids(kfc1,2)
24601  ELSEIF(kfd1.LT.0) THEN
24602  wid2=wid2*wids(kfc1,3)
24603  ENDIF
24604  ELSE
24605  IF(kfd1.GT.0) THEN
24606  wid2=wids(kfc1,2)
24607  ELSE
24608  wid2=wids(kfc1,3)
24609  ENDIF
24610  IF(kfd2.GT.0) THEN
24611  wid2=wid2*wids(kfc2,2)
24612  ELSE
24613  wid2=wid2*wids(kfc2,3)
24614  ENDIF
24615  IF(kfd3.GT.0) THEN
24616  wid2=wid2*wids(kfc3,2)
24617  ELSEIF(kfd3.LT.0) THEN
24618  wid2=wid2*wids(kfc3,3)
24619  ENDIF
24620  ENDIF
24621 
24622 C...Store effective widths according to case.
24623  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24624  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24625  wdte(i,0)=wdte(i,mdme(idc,1))
24626  wdte(0,0)=wdte(0,0)+wdte(i,0)
24627  ENDIF
24628  120 CONTINUE
24629 C...Return.
24630  mint(61)=0
24631  mint(62)=0
24632  mint(63)=0
24633  RETURN
24634  ENDIF
24635 
24636 C...Here begins detailed dynamical calculation of resonance widths.
24637 C...Shared treatment of Higgs states.
24638  kfhigg=25
24639  ihigg=1
24640  IF(kfla.EQ.35.OR.kfla.EQ.36) THEN
24641  kfhigg=kfla
24642  ihigg=kfla-33
24643  ENDIF
24644 
24645 C...Common electroweak and strong constants.
24646  xw=paru(102)
24647  xwv=xw
24648  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
24649  xw1=1d0-xw
24650  aem=pyalem(sh)
24651  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
24652  as=pyalps(sh)
24653  radc=1d0+as/paru(1)
24654 
24655  IF(kfla.EQ.6) THEN
24656 C...t quark.
24657  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24658  radct=1d0-2.5d0*as/paru(1)
24659  DO 140 i=1,mdcy(kc,3)
24660  idc=i+mdcy(kc,2)-1
24661  IF(mdme(idc,1).LT.0) GOTO 140
24662  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24663  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24664  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 140
24665  wid2=1d0
24666  IF(i.GE.4.AND.i.LE.7) THEN
24667 C...t -> W + q; including approximate QCD correction factor.
24668  wdtp(i)=fac*vckm(3,i-3)*radct*
24669  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24670  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24671  IF(kflr.GT.0) THEN
24672  wid2=wids(24,2)
24673  IF(i.EQ.7) wid2=wid2*wids(7,2)
24674  ELSE
24675  wid2=wids(24,3)
24676  IF(i.EQ.7) wid2=wid2*wids(7,3)
24677  ENDIF
24678  ELSEIF(i.EQ.9) THEN
24679 C...t -> H + b.
24680  rm2r=pymrun(kfdp(idc,2),sh)**2/sh
24681  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24682  & ((1d0+rm2-rm1)*(rm2r*paru(141)**2+1d0/paru(141)**2)+
24683  & 4d0*sqrt(rm2r*rm2))
24684  wid2=wids(37,2)
24685  IF(kflr.LT.0) wid2=wids(37,3)
24686 CMRENNA++
24687  ELSEIF(i.GE.10.AND.i.LE.13.AND.imss(1).NE.0) THEN
24688 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24689  beta=atan(rmss(5))
24690  sinb=sin(beta)
24691  tanw=sqrt(paru(102)/(1d0-paru(102)))
24692  et=kchg(6,1)/3d0
24693  t3l=sign(0.5d0,et)
24694  kfc1=pycomp(kfdp(idc,1))
24695  kfc2=pycomp(kfdp(idc,2))
24696  pmnchi=pmas(kfc1,1)
24697  pmstop=pmas(kfc2,1)
24698  IF(shr.GT.pmnchi+pmstop) THEN
24699  iz=i-9
24700  DO 130 ik=1,4
24701  zmixc(iz,ik)=dcmplx(zmix(iz,ik),zmixi(iz,ik))
24702  130 CONTINUE
24703  al=shr*dconjg(zmixc(iz,4))/(2.0d0*pmas(24,1)*sinb)
24704  ar=-et*zmixc(iz,1)*tanw
24705  bl=t3l*(zmixc(iz,2)-zmixc(iz,1)*tanw)-ar
24706  br=al
24707  fl=sfmix(6,1)*al+sfmix(6,2)*ar
24708  fr=sfmix(6,1)*bl+sfmix(6,2)*br
24709  pcm=sqrt((sh-(pmnchi+pmstop)**2)*
24710  & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
24711  wdtp(i)=(0.5d0*pyalem(sh)/paru(102))*pcm*
24712  & ((abs(fl)**2+abs(fr)**2)*(sh+pmnchi**2-pmstop**2)+
24713  & smz(iz)*4d0*shr*dble(fl*dconjg(fr)))/sh
24714  IF(kflr.GT.0) THEN
24715  wid2=wids(kfc1,2)*wids(kfc2,2)
24716  ELSE
24717  wid2=wids(kfc1,2)*wids(kfc2,3)
24718  ENDIF
24719  ENDIF
24720  ELSEIF(i.EQ.14.AND.imss(1).NE.0) THEN
24721 C...t -> ~g + ~t
24722  kfc1=pycomp(kfdp(idc,1))
24723  kfc2=pycomp(kfdp(idc,2))
24724  pmnchi=pmas(kfc1,1)
24725  pmstop=pmas(kfc2,1)
24726  IF(shr.GT.pmnchi+pmstop) THEN
24727  rl=sfmix(6,1)
24728  rr=-sfmix(6,2)
24729  pcm=sqrt((sh-(pmnchi+pmstop)**2)*
24730  & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
24731  wdtp(i)=4d0/3d0*0.5d0*pyalps(sh)*pcm*((rl**2+rr**2)*
24732  & (sh+pmnchi**2-pmstop**2)+pmnchi*4d0*shr*rl*rr)/sh
24733  IF(kflr.GT.0) THEN
24734  wid2=wids(kfc1,2)*wids(kfc2,2)
24735  ELSE
24736  wid2=wids(kfc1,2)*wids(kfc2,3)
24737  ENDIF
24738  ENDIF
24739  ELSEIF(i.EQ.15.AND.imss(1).NE.0) THEN
24740 C...t -> ~gravitino + ~t
24741  xmp2=rmss(29)**2
24742  kfc1=pycomp(kfdp(idc,1))
24743  xmgr2=pmas(kfc1,1)**2
24744  wdtp(i)=sh**2*shr/(96d0*paru(1)*xmp2*xmgr2)*(1d0-rm2)**4
24745  kfc2=pycomp(kfdp(idc,2))
24746  wid2=wids(kfc2,2)
24747  IF(kflr.LT.0) wid2=wids(kfc2,3)
24748 CMRENNA--
24749  ENDIF
24750  wdtp(i)=fudge*wdtp(i)
24751  wdtp(0)=wdtp(0)+wdtp(i)
24752  IF(mdme(idc,1).GT.0) THEN
24753  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24754  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24755  wdte(i,0)=wdte(i,mdme(idc,1))
24756  wdte(0,0)=wdte(0,0)+wdte(i,0)
24757  ENDIF
24758  140 CONTINUE
24759 
24760  ELSEIF(kfla.EQ.7) THEN
24761 C...b' quark.
24762  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24763  DO 150 i=1,mdcy(kc,3)
24764  idc=i+mdcy(kc,2)-1
24765  IF(mdme(idc,1).LT.0) GOTO 150
24766  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24767  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24768  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 150
24769  wid2=1d0
24770  IF(i.GE.4.AND.i.LE.7) THEN
24771 C...b' -> W + q.
24772  wdtp(i)=fac*vckm(i-3,4)*
24773  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24774  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24775  IF(kflr.GT.0) THEN
24776  wid2=wids(24,3)
24777  IF(i.EQ.6) wid2=wid2*wids(6,2)
24778  IF(i.EQ.7) wid2=wid2*wids(8,2)
24779  ELSE
24780  wid2=wids(24,2)
24781  IF(i.EQ.6) wid2=wid2*wids(6,3)
24782  IF(i.EQ.7) wid2=wid2*wids(8,3)
24783  ENDIF
24784  wid2=wids(24,3)
24785  IF(kflr.LT.0) wid2=wids(24,2)
24786  ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
24787 C...b' -> H + q.
24788  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24789  & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
24790  IF(kflr.GT.0) THEN
24791  wid2=wids(37,3)
24792  IF(i.EQ.10) wid2=wid2*wids(6,2)
24793  ELSE
24794  wid2=wids(37,2)
24795  IF(i.EQ.10) wid2=wid2*wids(6,3)
24796  ENDIF
24797  ENDIF
24798  wdtp(i)=fudge*wdtp(i)
24799  wdtp(0)=wdtp(0)+wdtp(i)
24800  IF(mdme(idc,1).GT.0) THEN
24801  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24802  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24803  wdte(i,0)=wdte(i,mdme(idc,1))
24804  wdte(0,0)=wdte(0,0)+wdte(i,0)
24805  ENDIF
24806  150 CONTINUE
24807 
24808  ELSEIF(kfla.EQ.8) THEN
24809 C...t' quark.
24810  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24811  DO 160 i=1,mdcy(kc,3)
24812  idc=i+mdcy(kc,2)-1
24813  IF(mdme(idc,1).LT.0) GOTO 160
24814  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24815  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24816  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 160
24817  wid2=1d0
24818  IF(i.GE.4.AND.i.LE.7) THEN
24819 C...t' -> W + q.
24820  wdtp(i)=fac*vckm(4,i-3)*
24821  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24822  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24823  IF(kflr.GT.0) THEN
24824  wid2=wids(24,2)
24825  IF(i.EQ.7) wid2=wid2*wids(7,2)
24826  ELSE
24827  wid2=wids(24,3)
24828  IF(i.EQ.7) wid2=wid2*wids(7,3)
24829  ENDIF
24830  ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
24831 C...t' -> H + q.
24832  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24833  & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
24834  IF(kflr.GT.0) THEN
24835  wid2=wids(37,2)
24836  IF(i.EQ.10) wid2=wid2*wids(7,2)
24837  ELSE
24838  wid2=wids(37,3)
24839  IF(i.EQ.10) wid2=wid2*wids(7,3)
24840  ENDIF
24841  ENDIF
24842  wdtp(i)=fudge*wdtp(i)
24843  wdtp(0)=wdtp(0)+wdtp(i)
24844  IF(mdme(idc,1).GT.0) THEN
24845  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24846  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24847  wdte(i,0)=wdte(i,mdme(idc,1))
24848  wdte(0,0)=wdte(0,0)+wdte(i,0)
24849  ENDIF
24850  160 CONTINUE
24851 
24852  ELSEIF(kfla.EQ.17) THEN
24853 C...tau' lepton.
24854  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24855  DO 170 i=1,mdcy(kc,3)
24856  idc=i+mdcy(kc,2)-1
24857  IF(mdme(idc,1).LT.0) GOTO 170
24858  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24859  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24860  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 170
24861  wid2=1d0
24862  IF(i.EQ.3) THEN
24863 C...tau' -> W + nu'_tau.
24864  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24865  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24866  IF(kflr.GT.0) THEN
24867  wid2=wids(24,3)
24868  wid2=wid2*wids(18,2)
24869  ELSE
24870  wid2=wids(24,2)
24871  wid2=wid2*wids(18,3)
24872  ENDIF
24873  ELSEIF(i.EQ.5) THEN
24874 C...tau' -> H + nu'_tau.
24875  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24876  & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
24877  IF(kflr.GT.0) THEN
24878  wid2=wids(37,3)
24879  wid2=wid2*wids(18,2)
24880  ELSE
24881  wid2=wids(37,2)
24882  wid2=wid2*wids(18,3)
24883  ENDIF
24884  ENDIF
24885  wdtp(i)=fudge*wdtp(i)
24886  wdtp(0)=wdtp(0)+wdtp(i)
24887  IF(mdme(idc,1).GT.0) THEN
24888  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24889  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24890  wdte(i,0)=wdte(i,mdme(idc,1))
24891  wdte(0,0)=wdte(0,0)+wdte(i,0)
24892  ENDIF
24893  170 CONTINUE
24894 
24895  ELSEIF(kfla.EQ.18) THEN
24896 C...nu'_tau neutrino.
24897  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24898  DO 180 i=1,mdcy(kc,3)
24899  idc=i+mdcy(kc,2)-1
24900  IF(mdme(idc,1).LT.0) GOTO 180
24901  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24902  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24903  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 180
24904  wid2=1d0
24905  IF(i.EQ.2) THEN
24906 C...nu'_tau -> W + tau'.
24907  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24908  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24909  IF(kflr.GT.0) THEN
24910  wid2=wids(24,2)
24911  wid2=wid2*wids(17,2)
24912  ELSE
24913  wid2=wids(24,3)
24914  wid2=wid2*wids(17,3)
24915  ENDIF
24916  ELSEIF(i.EQ.3) THEN
24917 C...nu'_tau -> H + tau'.
24918  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24919  & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
24920  IF(kflr.GT.0) THEN
24921  wid2=wids(37,2)
24922  wid2=wid2*wids(17,2)
24923  ELSE
24924  wid2=wids(37,3)
24925  wid2=wid2*wids(17,3)
24926  ENDIF
24927  ENDIF
24928  wdtp(i)=fudge*wdtp(i)
24929  wdtp(0)=wdtp(0)+wdtp(i)
24930  IF(mdme(idc,1).GT.0) THEN
24931  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24932  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24933  wdte(i,0)=wdte(i,mdme(idc,1))
24934  wdte(0,0)=wdte(0,0)+wdte(i,0)
24935  ENDIF
24936  180 CONTINUE
24937 
24938  ELSEIF(kfla.EQ.21) THEN
24939 C...QCD:
24940 C***Note that widths are not given in dimensional quantities here.
24941  DO 190 i=1,mdcy(kc,3)
24942  idc=i+mdcy(kc,2)-1
24943  IF(mdme(idc,1).LT.0) GOTO 190
24944  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
24945  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
24946  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 190
24947  wid2=1d0
24948  IF(i.LE.8) THEN
24949 C...QCD -> q + qbar
24950  wdtp(i)=(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
24951  IF(i.EQ.6) wid2=wids(6,1)
24952  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
24953  ENDIF
24954  wdtp(i)=fudge*wdtp(i)
24955  wdtp(0)=wdtp(0)+wdtp(i)
24956  IF(mdme(idc,1).GT.0) THEN
24957  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24958  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24959  wdte(i,0)=wdte(i,mdme(idc,1))
24960  wdte(0,0)=wdte(0,0)+wdte(i,0)
24961  ENDIF
24962  190 CONTINUE
24963 
24964  ELSEIF(kfla.EQ.22) THEN
24965 C...QED photon.
24966 C***Note that widths are not given in dimensional quantities here.
24967  DO 200 i=1,mdcy(kc,3)
24968  idc=i+mdcy(kc,2)-1
24969  IF(mdme(idc,1).LT.0) GOTO 200
24970  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
24971  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
24972  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 200
24973  wid2=1d0
24974  IF(i.LE.8) THEN
24975 C...QED -> q + qbar.
24976  ef=kchg(i,1)/3d0
24977  fcof=3d0*radc
24978  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
24979  wdtp(i)=fcof*ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
24980  IF(i.EQ.6) wid2=wids(6,1)
24981  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
24982  ELSEIF(i.LE.12) THEN
24983 C...QED -> l+ + l-.
24984  ef=kchg(9+2*(i-8),1)/3d0
24985  wdtp(i)=ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
24986  IF(i.EQ.12) wid2=wids(17,1)
24987  ENDIF
24988  wdtp(i)=fudge*wdtp(i)
24989  wdtp(0)=wdtp(0)+wdtp(i)
24990  IF(mdme(idc,1).GT.0) THEN
24991  wdte(i,mdme(idc,1))=wdtp(i)*wid2
24992  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24993  wdte(i,0)=wdte(i,mdme(idc,1))
24994  wdte(0,0)=wdte(0,0)+wdte(i,0)
24995  ENDIF
24996  200 CONTINUE
24997 
24998  ELSEIF(kfla.EQ.23) THEN
24999 C...Z0:
25000  icase=1
25001  xwc=1d0/(16d0*xw*xw1)
25002  fac=(aem*xwc/3d0)*shr
25003  210 CONTINUE
25004  IF(mint(61).GE.1.AND.icase.EQ.2) THEN
25005  vint(111)=0d0
25006  vint(112)=0d0
25007  vint(114)=0d0
25008  ENDIF
25009  IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25010  kfi=iabs(mint(15))
25011  IF(kfi.GT.20) kfi=iabs(mint(16))
25012  ei=kchg(kfi,1)/3d0
25013  ai=sign(1d0,ei)
25014  vi=ai-4d0*ei*xwv
25015  sqmz=pmas(23,1)**2
25016  hz=shr*wdtp(0)
25017  IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=1d0
25018  IF(mstp(43).EQ.3) vint(112)=
25019  & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
25020  IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
25021  & xwc**2*sh**2/((sh-sqmz)**2+hz**2)
25022  ENDIF
25023  DO 220 i=1,mdcy(kc,3)
25024  idc=i+mdcy(kc,2)-1
25025  IF(mdme(idc,1).LT.0) GOTO 220
25026  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25027  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25028  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 220
25029  wid2=1d0
25030  IF(i.LE.8) THEN
25031 C...Z0 -> q + qbar
25032  ef=kchg(i,1)/3d0
25033  af=sign(1d0,ef+0.1d0)
25034  vf=af-4d0*ef*xwv
25035  fcof=3d0*radc
25036  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
25037  IF(i.EQ.6) wid2=wids(6,1)
25038  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25039  ELSEIF(i.LE.16) THEN
25040 C...Z0 -> l+ + l-, nu + nubar
25041  ef=kchg(i+2,1)/3d0
25042  af=sign(1d0,ef+0.1d0)
25043  vf=af-4d0*ef*xwv
25044  fcof=1d0
25045  IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
25046  ENDIF
25047  be34=sqrt(max(0d0,1d0-4d0*rm1))
25048  IF(icase.EQ.1) THEN
25049  wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
25050  & be34
25051  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25052  wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
25053  & ef*vf+(vi**2+ai**2)*vint(114)*vf**2)*(1d0+2d0*rm1)+
25054  & (vi**2+ai**2)*vint(114)*af**2*(1d0-4d0*rm1))*be34
25055  ELSEIF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25056  fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
25057  fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
25058  fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
25059  ENDIF
25060  IF(icase.EQ.1) wdtp(i)=fudge*wdtp(i)
25061  IF(icase.EQ.1) wdtp(0)=wdtp(0)+wdtp(i)
25062  IF(mdme(idc,1).GT.0) THEN
25063  IF((icase.EQ.1.AND.mint(61).NE.1).OR.
25064  & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
25065  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25066  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
25067  & wdte(i,mdme(idc,1))
25068  wdte(i,0)=wdte(i,mdme(idc,1))
25069  wdte(0,0)=wdte(0,0)+wdte(i,0)
25070  ENDIF
25071  IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25072  IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=
25073  & vint(111)+fggf*wid2
25074  IF(mstp(43).EQ.3) vint(112)=vint(112)+fgzf*wid2
25075  IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
25076  & vint(114)+fzzf*wid2
25077  ENDIF
25078  ENDIF
25079  220 CONTINUE
25080  IF(mint(61).GE.1) icase=3-icase
25081  IF(icase.EQ.2) GOTO 210
25082 
25083  ELSEIF(kfla.EQ.24) THEN
25084 C...W+/-:
25085  fac=(aem/(24d0*xw))*shr
25086  DO 230 i=1,mdcy(kc,3)
25087  idc=i+mdcy(kc,2)-1
25088  IF(mdme(idc,1).LT.0) GOTO 230
25089  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25090  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25091  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 230
25092  wid2=1d0
25093  IF(i.LE.16) THEN
25094 C...W+/- -> q + qbar'
25095  fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
25096  IF(kflr.GT.0) THEN
25097  IF(mod(i,4).EQ.3) wid2=wids(6,2)
25098  IF(mod(i,4).EQ.0) wid2=wids(8,2)
25099  IF(i.GE.13) wid2=wid2*wids(7,3)
25100  ELSE
25101  IF(mod(i,4).EQ.3) wid2=wids(6,3)
25102  IF(mod(i,4).EQ.0) wid2=wids(8,3)
25103  IF(i.GE.13) wid2=wid2*wids(7,2)
25104  ENDIF
25105  ELSEIF(i.LE.20) THEN
25106 C...W+/- -> l+/- + nu
25107  fcof=1d0
25108  IF(kflr.GT.0) THEN
25109  IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
25110  ELSE
25111  IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
25112  ENDIF
25113  ENDIF
25114  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
25115  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25116  wdtp(i)=fudge*wdtp(i)
25117  wdtp(0)=wdtp(0)+wdtp(i)
25118  IF(mdme(idc,1).GT.0) THEN
25119  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25120  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25121  wdte(i,0)=wdte(i,mdme(idc,1))
25122  wdte(0,0)=wdte(0,0)+wdte(i,0)
25123  ENDIF
25124  230 CONTINUE
25125 
25126  ELSEIF(kfla.EQ.25.OR.kfla.EQ.35.OR.kfla.EQ.36) THEN
25127 C...h0 (or H0, or A0):
25128  shfs=sh
25129  fac=(aem/(8d0*xw))*(shfs/pmas(24,1)**2)*shr
25130  DO 270 i=1,mdcy(kfhigg,3)
25131  idc=i+mdcy(kfhigg,2)-1
25132  IF(mdme(idc,1).LT.0) GOTO 270
25133  kfc1=pycomp(kfdp(idc,1))
25134  kfc2=pycomp(kfdp(idc,2))
25135  rm1=pmas(kfc1,1)**2/sh
25136  rm2=pmas(kfc2,1)**2/sh
25137  IF(i.NE.16.AND.i.NE.17.AND.sqrt(rm1)+sqrt(rm2).GT.1d0)
25138  & GOTO 270
25139  wid2=1d0
25140 
25141  IF(i.LE.8) THEN
25142 C...h0 -> q + qbar
25143  wdtp(i)=fac*3d0*(pymrun(kfdp(idc,1),sh)**2/shfs)*
25144  & sqrt(max(0d0,1d0-4d0*rm1))*radc
25145 C...A0 behaves like beta, ho and H0 like beta**3.
25146  IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
25147  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25148  IF(mod(i,2).EQ.1) wdtp(i)=wdtp(i)*paru(151+10*ihigg)**2
25149  IF(mod(i,2).EQ.0) wdtp(i)=wdtp(i)*paru(152+10*ihigg)**2
25150  IF(imss(1).NE.0.AND.kfc1.EQ.5) THEN
25151  wdtp(i)=wdtp(i)/(1d0+rmss(41))**2
25152  IF(ihigg.NE.3) THEN
25153  wdtp(i)=wdtp(i)*(1d0+rmss(41)*paru(152+10*ihigg)/
25154  & paru(151+10*ihigg))**2
25155  ENDIF
25156  ENDIF
25157  ENDIF
25158  IF(i.EQ.6) wid2=wids(6,1)
25159  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25160  ELSEIF(i.LE.12) THEN
25161 C...h0 -> l+ + l-
25162  wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))*(sh/shfs)
25163 C...A0 behaves like beta, ho and H0 like beta**3.
25164  IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
25165  IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
25166  & paru(153+10*ihigg)**2
25167  IF(i.EQ.12) wid2=wids(17,1)
25168 
25169  ELSEIF(i.EQ.13) THEN
25170 C...h0 -> g + g; quark loop contribution only
25171  etare=0d0
25172  etaim=0d0
25173  DO 240 j=1,2*mstp(1)
25174  eps=(2d0*pmas(j,1))**2/sh
25175 C...Loop integral; function of eps=4m^2/shat; different for A0.
25176  IF(eps.LE.1d0) THEN
25177  IF(eps.GT.1d-4) THEN
25178  root=sqrt(1d0-eps)
25179  rln=log((1d0+root)/(1d0-root))
25180  ELSE
25181  rln=log(4d0/eps-2d0)
25182  ENDIF
25183  phire=-0.25d0*(rln**2-paru(1)**2)
25184  phiim=0.5d0*paru(1)*rln
25185  ELSE
25186  phire=(asin(1d0/sqrt(eps)))**2
25187  phiim=0d0
25188  ENDIF
25189  IF(ihigg.LE.2) THEN
25190  etarej=-0.5d0*eps*(1d0+(1d0-eps)*phire)
25191  etaimj=-0.5d0*eps*(1d0-eps)*phiim
25192  ELSE
25193  etarej=-0.5d0*eps*phire
25194  etaimj=-0.5d0*eps*phiim
25195  ENDIF
25196 C...Couplings (=1 for standard model Higgs).
25197  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25198  IF(mod(j,2).EQ.1) THEN
25199  etarej=etarej*paru(151+10*ihigg)
25200  etaimj=etaimj*paru(151+10*ihigg)
25201  ELSE
25202  etarej=etarej*paru(152+10*ihigg)
25203  etaimj=etaimj*paru(152+10*ihigg)
25204  ENDIF
25205  ENDIF
25206  etare=etare+etarej
25207  etaim=etaim+etaimj
25208  240 CONTINUE
25209  eta2=etare**2+etaim**2
25210  wdtp(i)=fac*(as/paru(1))**2*eta2
25211 
25212  ELSEIF(i.EQ.14) THEN
25213 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25214  etare=0d0
25215  etaim=0d0
25216  jmax=3*mstp(1)+1
25217  IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
25218  DO 250 j=1,jmax
25219  IF(j.LE.2*mstp(1)) THEN
25220  ej=kchg(j,1)/3d0
25221  eps=(2d0*pmas(j,1))**2/sh
25222  ELSEIF(j.LE.3*mstp(1)) THEN
25223  jl=2*(j-2*mstp(1))-1
25224  ej=kchg(10+jl,1)/3d0
25225  eps=(2d0*pmas(10+jl,1))**2/sh
25226  ELSEIF(j.EQ.3*mstp(1)+1) THEN
25227  eps=(2d0*pmas(24,1))**2/sh
25228  ELSE
25229  eps=(2d0*pmas(37,1))**2/sh
25230  ENDIF
25231 C...Loop integral; function of eps=4m^2/shat.
25232  IF(eps.LE.1d0) THEN
25233  IF(eps.GT.1d-4) THEN
25234  root=sqrt(1d0-eps)
25235  rln=log((1d0+root)/(1d0-root))
25236  ELSE
25237  rln=log(4d0/eps-2d0)
25238  ENDIF
25239  phire=-0.25d0*(rln**2-paru(1)**2)
25240  phiim=0.5d0*paru(1)*rln
25241  ELSE
25242  phire=(asin(1d0/sqrt(eps)))**2
25243  phiim=0d0
25244  ENDIF
25245  IF(j.LE.3*mstp(1)) THEN
25246 C...Fermion loops: loop integral different for A0; charges.
25247  IF(ihigg.LE.2) THEN
25248  phipre=-0.5d0*eps*(1d0+(1d0-eps)*phire)
25249  phipim=-0.5d0*eps*(1d0-eps)*phiim
25250  ELSE
25251  phipre=-0.5d0*eps*phire
25252  phipim=-0.5d0*eps*phiim
25253  ENDIF
25254  IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
25255  ejc=3d0*ej**2
25256  ejh=paru(151+10*ihigg)
25257  ELSEIF(j.LE.2*mstp(1)) THEN
25258  ejc=3d0*ej**2
25259  ejh=paru(152+10*ihigg)
25260  ELSE
25261  ejc=ej**2
25262  ejh=paru(153+10*ihigg)
25263  ENDIF
25264  IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
25265  etarej=ejc*ejh*phipre
25266  etaimj=ejc*ejh*phipim
25267  ELSEIF(j.EQ.3*mstp(1)+1) THEN
25268 C...W loops: loop integral and charges.
25269  etarej=0.5d0+0.75d0*eps*(1d0+(2d0-eps)*phire)
25270  etaimj=0.75d0*eps*(2d0-eps)*phiim
25271  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25272  etarej=etarej*paru(155+10*ihigg)
25273  etaimj=etaimj*paru(155+10*ihigg)
25274  ENDIF
25275  ELSE
25276 C...Charged H loops: loop integral and charges.
25277  fachhh=(pmas(24,1)/pmas(37,1))**2*
25278  & paru(158+10*ihigg+2*(ihigg/3))
25279  etarej=eps*(1d0-eps*phire)*fachhh
25280  etaimj=-eps**2*phiim*fachhh
25281  ENDIF
25282  etare=etare+etarej
25283  etaim=etaim+etaimj
25284  250 CONTINUE
25285  eta2=etare**2+etaim**2
25286  wdtp(i)=fac*(aem/paru(1))**2*0.5d0*eta2
25287 
25288  ELSEIF(i.EQ.15) THEN
25289 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25290  etare=0d0
25291  etaim=0d0
25292  jmax=3*mstp(1)+1
25293  IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
25294  DO 260 j=1,jmax
25295  IF(j.LE.2*mstp(1)) THEN
25296  ej=kchg(j,1)/3d0
25297  aj=sign(1d0,ej+0.1d0)
25298  vj=aj-4d0*ej*xwv
25299  eps=(2d0*pmas(j,1))**2/sh
25300  epsp=(2d0*pmas(j,1)/pmas(23,1))**2
25301  ELSEIF(j.LE.3*mstp(1)) THEN
25302  jl=2*(j-2*mstp(1))-1
25303  ej=kchg(10+jl,1)/3d0
25304  aj=sign(1d0,ej+0.1d0)
25305  vj=aj-4d0*ej*xwv
25306  eps=(2d0*pmas(10+jl,1))**2/sh
25307  epsp=(2d0*pmas(10+jl,1)/pmas(23,1))**2
25308  ELSE
25309  eps=(2d0*pmas(24,1))**2/sh
25310  epsp=(2d0*pmas(24,1)/pmas(23,1))**2
25311  ENDIF
25312 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25313  IF(eps.LE.1d0) THEN
25314  root=sqrt(1d0-eps)
25315  IF(eps.GT.1d-4) THEN
25316  rln=log((1d0+root)/(1d0-root))
25317  ELSE
25318  rln=log(4d0/eps-2d0)
25319  ENDIF
25320  phire=-0.25d0*(rln**2-paru(1)**2)
25321  phiim=0.5d0*paru(1)*rln
25322  psire=0.5d0*root*rln
25323  psiim=-0.5d0*root*paru(1)
25324  ELSE
25325  phire=(asin(1d0/sqrt(eps)))**2
25326  phiim=0d0
25327  psire=sqrt(eps-1d0)*asin(1d0/sqrt(eps))
25328  psiim=0d0
25329  ENDIF
25330  IF(epsp.LE.1d0) THEN
25331  root=sqrt(1d0-epsp)
25332  IF(epsp.GT.1d-4) THEN
25333  rln=log((1d0+root)/(1d0-root))
25334  ELSE
25335  rln=log(4d0/epsp-2d0)
25336  ENDIF
25337  phirep=-0.25d0*(rln**2-paru(1)**2)
25338  phiimp=0.5d0*paru(1)*rln
25339  psirep=0.5d0*root*rln
25340  psiimp=-0.5d0*root*paru(1)
25341  ELSE
25342  phirep=(asin(1d0/sqrt(epsp)))**2
25343  phiimp=0d0
25344  psirep=sqrt(epsp-1d0)*asin(1d0/sqrt(epsp))
25345  psiimp=0d0
25346  ENDIF
25347  fxyre=eps*epsp/(8d0*(eps-epsp))*(1d0+eps*epsp/(eps-epsp)*
25348  & (phire-phirep)+2d0*eps/(eps-epsp)*(psire-psirep))
25349  fxyim=eps**2*epsp/(8d0*(eps-epsp)**2)*
25350  & (epsp*(phiim-phiimp)+2d0*(psiim-psiimp))
25351  f1re=-eps*epsp/(2d0*(eps-epsp))*(phire-phirep)
25352  f1im=-eps*epsp/(2d0*(eps-epsp))*(phiim-phiimp)
25353  IF(j.LE.3*mstp(1)) THEN
25354 C...Fermion loops: loop integral different for A0; charges.
25355  IF(ihigg.EQ.3) fxyre=0d0
25356  IF(ihigg.EQ.3) fxyim=0d0
25357  IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
25358  ejc=-3d0*ej*vj
25359  ejh=paru(151+10*ihigg)
25360  ELSEIF(j.LE.2*mstp(1)) THEN
25361  ejc=-3d0*ej*vj
25362  ejh=paru(152+10*ihigg)
25363  ELSE
25364  ejc=-ej*vj
25365  ejh=paru(153+10*ihigg)
25366  ENDIF
25367  IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
25368  etarej=ejc*ejh*(fxyre-0.25d0*f1re)
25369  etaimj=ejc*ejh*(fxyim-0.25d0*f1im)
25370  ELSEIF(j.EQ.3*mstp(1)+1) THEN
25371 C...W loops: loop integral and charges.
25372  heps=(1d0+2d0/eps)*xw/xw1-(5d0+2d0/eps)
25373  etarej=-xw1*((3d0-xw/xw1)*f1re+heps*fxyre)
25374  etaimj=-xw1*((3d0-xw/xw1)*f1im+heps*fxyim)
25375  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25376  etarej=etarej*paru(155+10*ihigg)
25377  etaimj=etaimj*paru(155+10*ihigg)
25378  ENDIF
25379  ELSE
25380 C...Charged H loops: loop integral and charges.
25381  fachhh=(pmas(24,1)/pmas(37,1))**2*(1d0-2d0*xw)*
25382  & paru(158+10*ihigg+2*(ihigg/3))
25383  etarej=fachhh*fxyre
25384  etaimj=fachhh*fxyim
25385  ENDIF
25386  etare=etare+etarej
25387  etaim=etaim+etaimj
25388  260 CONTINUE
25389  eta2=(etare**2+etaim**2)/(xw*xw1)
25390  wdtp(i)=fac*(aem/paru(1))**2*(1d0-pmas(23,1)**2/sh)**3*eta2
25391  wid2=wids(23,2)
25392 
25393  ELSEIF(i.LE.17) THEN
25394 C...h0 -> Z0 + Z0, W+ + W-
25395  pm1=pmas(iabs(kfdp(idc,1)),1)
25396  pg1=pmas(iabs(kfdp(idc,1)),2)
25397  IF(mint(62).GE.1) THEN
25398  IF(mstp(42).EQ.0.OR.(4d0*(pm1+10d0*pg1)**2.LT.sh.AND.
25399  & ckin(46).LT.ckin(45).AND.ckin(48).LT.ckin(47).AND.
25400  & max(ckin(45),ckin(47)).LT.pm1-10d0*pg1)) THEN
25401  mofsv(ihigg,i-15)=0
25402  widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
25403  & 1d0-4d0*rm1))
25404  wid2=1d0
25405  ELSE
25406  mofsv(ihigg,i-15)=1
25407  rmas=sqrt(max(0d0,sh))
25408  CALL pyofsh(1,kfla,kfdp(idc,1),kfdp(idc,2),rmas,widw,
25409  & wid2)
25410  widwsv(ihigg,i-15)=widw
25411  wid2sv(ihigg,i-15)=wid2
25412  ENDIF
25413  ELSE
25414  IF(mofsv(ihigg,i-15).EQ.0) THEN
25415  widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
25416  & 1d0-4d0*rm1))
25417  wid2=1d0
25418  ELSE
25419  widw=widwsv(ihigg,i-15)
25420  wid2=wid2sv(ihigg,i-15)
25421  ENDIF
25422  ENDIF
25423  wdtp(i)=fac*widw/(2d0*(18-i))
25424  IF(mstp(49).NE.0) wdtp(i)=wdtp(i)*pmas(kfhigg,1)**2/shfs
25425  IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
25426  & paru(138+i+10*ihigg)**2
25427  wid2=wid2*wids(7+i,1)
25428 
25429  ELSEIF(i.EQ.18.AND.ihigg.GE.2) THEN
25430 C...H0 -> Z0 + h0, A0-> Z0 + h0
25431  wdtp(i)=fac*0.5d0*sqrt(max(0d0,
25432  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25433  IF(ihigg.EQ.2) THEN
25434  wdtp(i)=wdtp(i)*paru(179)**2
25435  ELSEIF(ihigg.EQ.3) THEN
25436  wdtp(i)=wdtp(i)*paru(186)**2
25437  ENDIF
25438  wid2=wids(23,2)*wids(25,2)
25439 
25440  ELSEIF(i.EQ.19.AND.ihigg.GE.2) THEN
25441 C...H0 -> h0 + h0, A0-> h0 + h0
25442  wdtp(i)=fac*0.25d0*
25443  & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
25444  IF(ihigg.EQ.2) THEN
25445  wdtp(i)=wdtp(i)*paru(176)**2
25446  ELSEIF(ihigg.EQ.3) THEN
25447  wdtp(i)=wdtp(i)*paru(169)**2
25448  ENDIF
25449  wid2=wids(25,1)
25450  ELSEIF((i.EQ.20.OR.i.EQ.21).AND.ihigg.GE.2) THEN
25451 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25452  wdtp(i)=fac*0.5d0*sqrt(max(0d0,
25453  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25454  & *paru(195+ihigg)**2
25455  IF(i.EQ.20) THEN
25456  wid2=wids(24,2)*wids(37,3)
25457  ELSEIF(i.EQ.21) THEN
25458  wid2=wids(24,3)*wids(37,2)
25459  ENDIF
25460 
25461  ELSEIF(i.EQ.22.AND.ihigg.EQ.2) THEN
25462 C...H0 -> Z0 + A0.
25463  wdtp(i)=fac*0.5d0*paru(187)**2*sqrt(max(0d0,
25464  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25465  wid2=wids(36,2)*wids(23,2)
25466 
25467  ELSEIF(i.EQ.23.AND.ihigg.EQ.2) THEN
25468 C...H0 -> h0 + A0.
25469  wdtp(i)=fac*0.5d0*paru(180)**2*
25470  & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
25471  wid2=wids(25,2)*wids(36,2)
25472 
25473  ELSEIF(i.EQ.24.AND.ihigg.EQ.2) THEN
25474 C...H0 -> A0 + A0
25475  wdtp(i)=fac*0.25d0*paru(177)**2*
25476  & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
25477  wid2=wids(36,1)
25478 
25479 CMRENNA++
25480  ELSE
25481 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25482  rm10=rm1*sh/pmr**2
25483  rm20=rm2*sh/pmr**2
25484  wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
25485  wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
25486  IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
25487  wfac=0d0
25488  ELSE
25489  wfac=wfac/wfac0
25490  ENDIF
25491  wdtp(i)=pmas(kfla,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
25492 CMRENNA--
25493  IF(kfc2.EQ.kfc1) THEN
25494  wid2=wids(kfc1,1)
25495  ELSE
25496  ksgn1=2
25497  IF(kfdp(idc,1).LT.0) ksgn1=3
25498  ksgn2=2
25499  IF(kfdp(idc,2).LT.0) ksgn2=3
25500  wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
25501  ENDIF
25502  ENDIF
25503  wdtp(i)=fudge*wdtp(i)
25504  wdtp(0)=wdtp(0)+wdtp(i)
25505  IF(mdme(idc,1).GT.0) THEN
25506  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25507  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25508  wdte(i,0)=wdte(i,mdme(idc,1))
25509  wdte(0,0)=wdte(0,0)+wdte(i,0)
25510  ENDIF
25511  270 CONTINUE
25512 
25513  ELSEIF(kfla.EQ.32) THEN
25514 C...Z'0:
25515  icase=1
25516  xwc=1d0/(16d0*xw*xw1)
25517  fac=(aem*xwc/3d0)*shr
25518  vint(117)=0d0
25519  280 CONTINUE
25520  IF(mint(61).GE.1.AND.icase.EQ.2) THEN
25521  vint(111)=0d0
25522  vint(112)=0d0
25523  vint(113)=0d0
25524  vint(114)=0d0
25525  vint(115)=0d0
25526  vint(116)=0d0
25527  ENDIF
25528  IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25529  kfai=iabs(mint(15))
25530  ei=kchg(kfai,1)/3d0
25531  ai=sign(1d0,ei+0.1d0)
25532  vi=ai-4d0*ei*xwv
25533  kfaic=1
25534  IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
25535  IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
25536  IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
25537  IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
25538  vpi=paru(119+2*kfaic)
25539  api=paru(120+2*kfaic)
25540  ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
25541  vpi=parj(178+2*kfaic)
25542  api=parj(179+2*kfaic)
25543  ELSE
25544  vpi=parj(186+2*kfaic)
25545  api=parj(187+2*kfaic)
25546  ENDIF
25547  sqmz=pmas(23,1)**2
25548  hz=shr*vint(117)
25549  sqmzp=pmas(32,1)**2
25550  hzp=shr*wdtp(0)
25551  IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
25552  & mstp(44).EQ.7) vint(111)=1d0
25553  IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=
25554  & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
25555  IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=
25556  & 2d0*xwc*sh*(sh-sqmzp)/((sh-sqmzp)**2+hzp**2)
25557  IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
25558  & mstp(44).EQ.7) vint(114)=xwc**2*sh**2/((sh-sqmz)**2+hz**2)
25559  IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=
25560  & 2d0*xwc**2*sh**2*((sh-sqmz)*(sh-sqmzp)+hz*hzp)/
25561  & (((sh-sqmz)**2+hz**2)*((sh-sqmzp)**2+hzp**2))
25562  IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
25563  & mstp(44).EQ.7) vint(116)=xwc**2*sh**2/((sh-sqmzp)**2+hzp**2)
25564  ENDIF
25565  DO 290 i=1,mdcy(kc,3)
25566  idc=i+mdcy(kc,2)-1
25567  IF(mdme(idc,1).LT.0) GOTO 290
25568  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25569  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25570  IF(sqrt(rm1)+sqrt(rm2).GT.1d0.OR.mdme(idc,1).LT.0) GOTO 290
25571  wid2=1d0
25572  IF(i.LE.16) THEN
25573  IF(i.LE.8) THEN
25574 C...Z'0 -> q + qbar
25575  ef=kchg(i,1)/3d0
25576  af=sign(1d0,ef+0.1d0)
25577  vf=af-4d0*ef*xwv
25578  IF(i.LE.2) THEN
25579  vpf=paru(123-2*mod(i,2))
25580  apf=paru(124-2*mod(i,2))
25581  ELSEIF(i.LE.4) THEN
25582  vpf=parj(182-2*mod(i,2))
25583  apf=parj(183-2*mod(i,2))
25584  ELSE
25585  vpf=parj(190-2*mod(i,2))
25586  apf=parj(191-2*mod(i,2))
25587  ENDIF
25588  fcof=3d0*radc
25589  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
25590  & pyhfth(sh,sh*rm1,1d0)
25591  IF(i.EQ.6) wid2=wids(6,1)
25592  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25593  ELSEIF(i.LE.16) THEN
25594 C...Z'0 -> l+ + l-, nu + nubar
25595  ef=kchg(i+2,1)/3d0
25596  af=sign(1d0,ef+0.1d0)
25597  vf=af-4d0*ef*xwv
25598  IF(i.LE.10) THEN
25599  vpf=paru(127-2*mod(i,2))
25600  apf=paru(128-2*mod(i,2))
25601  ELSEIF(i.LE.12) THEN
25602  vpf=parj(186-2*mod(i,2))
25603  apf=parj(187-2*mod(i,2))
25604  ELSE
25605  vpf=parj(194-2*mod(i,2))
25606  apf=parj(195-2*mod(i,2))
25607  ENDIF
25608  fcof=1d0
25609  IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
25610  ENDIF
25611  be34=sqrt(max(0d0,1d0-4d0*rm1))
25612  IF(icase.EQ.1) THEN
25613  wdtpz=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
25614  wdtp(i)=fac*fcof*(vpf**2*(1d0+2d0*rm1)+
25615  & apf**2*(1d0-4d0*rm1))*be34
25616  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25617  wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
25618  & ef*vf+ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
25619  & vf**2+(vi*vpi+ai*api)*vint(115)*vf*vpf+(vpi**2+api**2)*
25620  & vint(116)*vpf**2)*(1d0+2d0*rm1)+((vi**2+ai**2)*vint(114)*
25621  & af**2+(vi*vpi+ai*api)*vint(115)*af*apf+(vpi**2+api**2)*
25622  & vint(116)*apf**2)*(1d0-4d0*rm1))*be34
25623  ELSEIF(mint(61).EQ.2) THEN
25624  fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
25625  fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
25626  fgzpf=fcof*ef*vpf*(1d0+2d0*rm1)*be34
25627  fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
25628  fzzpf=fcof*(vf*vpf*(1d0+2d0*rm1)+af*apf*(1d0-4d0*rm1))*
25629  & be34
25630  fzpzpf=fcof*(vpf**2*(1d0+2d0*rm1)+apf**2*(1d0-4d0*rm1))*
25631  & be34
25632  ENDIF
25633  ELSEIF(i.EQ.17) THEN
25634 C...Z'0 -> W+ + W-
25635  wdtpzp=paru(129)**2*xw1**2*
25636  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
25637  & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
25638  IF(icase.EQ.1) THEN
25639  wdtpz=0d0
25640  wdtp(i)=fac*wdtpzp
25641  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25642  wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
25643  ELSEIF(mint(61).EQ.2) THEN
25644  fggf=0d0
25645  fgzf=0d0
25646  fgzpf=0d0
25647  fzzf=0d0
25648  fzzpf=0d0
25649  fzpzpf=wdtpzp
25650  ENDIF
25651  wid2=wids(24,1)
25652  ELSEIF(i.EQ.18) THEN
25653 C...Z'0 -> H+ + H-
25654  czc=2d0*(1d0-2d0*xw)
25655  be34c=(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
25656  IF(icase.EQ.1) THEN
25657  wdtpz=0.25d0*paru(142)**2*czc**2*be34c
25658  wdtp(i)=fac*0.25d0*paru(143)**2*czc**2*be34c
25659  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25660  wdtp(i)=fac*0.25d0*(ei**2*vint(111)+paru(142)*ei*vi*
25661  & vint(112)*czc+paru(143)*ei*vpi*vint(113)*czc+paru(142)**2*
25662  & (vi**2+ai**2)*vint(114)*czc**2+paru(142)*paru(143)*
25663  & (vi*vpi+ai*api)*vint(115)*czc**2+paru(143)**2*
25664  & (vpi**2+api**2)*vint(116)*czc**2)*be34c
25665  ELSEIF(mint(61).EQ.2) THEN
25666  fggf=0.25d0*be34c
25667  fgzf=0.25d0*paru(142)*czc*be34c
25668  fgzpf=0.25d0*paru(143)*czc*be34c
25669  fzzf=0.25d0*paru(142)**2*czc**2*be34c
25670  fzzpf=0.25d0*paru(142)*paru(143)*czc**2*be34c
25671  fzpzpf=0.25d0*paru(143)**2*czc**2*be34c
25672  ENDIF
25673  wid2=wids(37,1)
25674  ELSEIF(i.EQ.19) THEN
25675 C...Z'0 -> Z0 + gamma.
25676  ELSEIF(i.EQ.20) THEN
25677 C...Z'0 -> Z0 + h0
25678  flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25679  wdtpzp=paru(145)**2*4d0*abs(1d0-2d0*xw)*
25680  & (3d0*rm1+0.25d0*flam**2)*flam
25681  IF(icase.EQ.1) THEN
25682  wdtpz=0d0
25683  wdtp(i)=fac*wdtpzp
25684  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25685  wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
25686  ELSEIF(mint(61).EQ.2) THEN
25687  fggf=0d0
25688  fgzf=0d0
25689  fgzpf=0d0
25690  fzzf=0d0
25691  fzzpf=0d0
25692  fzpzpf=wdtpzp
25693  ENDIF
25694  wid2=wids(23,2)*wids(25,2)
25695  ELSEIF(i.EQ.21.OR.i.EQ.22) THEN
25696 C...Z' -> h0 + A0 or H0 + A0.
25697  be34c=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25698  IF(i.EQ.21) THEN
25699  czah=paru(186)
25700  czpah=paru(188)
25701  ELSE
25702  czah=paru(187)
25703  czpah=paru(189)
25704  ENDIF
25705  IF(icase.EQ.1) THEN
25706  wdtpz=czah**2*be34c
25707  wdtp(i)=fac*czpah**2*be34c
25708  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25709  wdtp(i)=fac*(czah**2*(vi**2+ai**2)*vint(114)+czah*czpah*
25710  & (vi*vpi+ai*api)*vint(115)+czpah**2*(vpi**2+api**2)*
25711  & vint(116))*be34c
25712  ELSEIF(mint(61).EQ.2) THEN
25713  fggf=0d0
25714  fgzf=0d0
25715  fgzpf=0d0
25716  fzzf=czah**2*be34c
25717  fzzpf=czah*czpah*be34c
25718  fzpzpf=czpah**2*be34c
25719  ENDIF
25720  IF(i.EQ.21) wid2=wids(25,2)*wids(36,2)
25721  IF(i.EQ.22) wid2=wids(35,2)*wids(36,2)
25722  ENDIF
25723  IF(icase.EQ.1) THEN
25724  vint(117)=vint(117)+fac*wdtpz
25725  wdtp(i)=fudge*wdtp(i)
25726  wdtp(0)=wdtp(0)+wdtp(i)
25727  ENDIF
25728  IF(mdme(idc,1).GT.0) THEN
25729  IF((icase.EQ.1.AND.mint(61).NE.1).OR.
25730  & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
25731  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25732  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
25733  & wdte(i,mdme(idc,1))
25734  wdte(i,0)=wdte(i,mdme(idc,1))
25735  wdte(0,0)=wdte(0,0)+wdte(i,0)
25736  ENDIF
25737  IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25738  IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
25739  & mstp(44).EQ.7) vint(111)=vint(111)+fggf*wid2
25740  IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=vint(112)+
25741  & fgzf*wid2
25742  IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=vint(113)+
25743  & fgzpf*wid2
25744  IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
25745  & mstp(44).EQ.7) vint(114)=vint(114)+fzzf*wid2
25746  IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=vint(115)+
25747  & fzzpf*wid2
25748  IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
25749  & mstp(44).EQ.7) vint(116)=vint(116)+fzpzpf*wid2
25750  ENDIF
25751  ENDIF
25752  290 CONTINUE
25753  IF(mint(61).GE.1) icase=3-icase
25754  IF(icase.EQ.2) GOTO 280
25755 
25756  ELSEIF(kfla.EQ.34) THEN
25757 C...W'+/-:
25758  fac=(aem/(24d0*xw))*shr
25759  DO 300 i=1,mdcy(kc,3)
25760  idc=i+mdcy(kc,2)-1
25761  IF(mdme(idc,1).LT.0) GOTO 300
25762  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25763  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25764  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 300
25765  wid2=1d0
25766  IF(i.LE.20) THEN
25767  IF(i.LE.16) THEN
25768 C...W'+/- -> q + qbar'
25769  fcof=3d0*radc*(paru(131)**2+paru(132)**2)*
25770  & vckm((i-1)/4+1,mod(i-1,4)+1)
25771  IF(kflr.GT.0) THEN
25772  IF(mod(i,4).EQ.3) wid2=wids(6,2)
25773  IF(mod(i,4).EQ.0) wid2=wids(8,2)
25774  IF(i.GE.13) wid2=wid2*wids(7,3)
25775  ELSE
25776  IF(mod(i,4).EQ.3) wid2=wids(6,3)
25777  IF(mod(i,4).EQ.0) wid2=wids(8,3)
25778  IF(i.GE.13) wid2=wid2*wids(7,2)
25779  ENDIF
25780  ELSEIF(i.LE.20) THEN
25781 C...W'+/- -> l+/- + nu
25782  fcof=paru(133)**2+paru(134)**2
25783  IF(kflr.GT.0) THEN
25784  IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
25785  ELSE
25786  IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
25787  ENDIF
25788  ENDIF
25789  wdtp(i)=fac*fcof*0.5d0*(2d0-rm1-rm2-(rm1-rm2)**2)*
25790  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25791  ELSEIF(i.EQ.21) THEN
25792 C...W'+/- -> W+/- + Z0
25793  wdtp(i)=fac*paru(135)**2*0.5d0*xw1*(rm1/rm2)*
25794  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
25795  & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
25796  IF(kflr.GT.0) wid2=wids(24,2)*wids(23,2)
25797  IF(kflr.LT.0) wid2=wids(24,3)*wids(23,2)
25798  ELSEIF(i.EQ.23) THEN
25799 C...W'+/- -> W+/- + h0
25800  flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25801  wdtp(i)=fac*paru(146)**2*2d0*(3d0*rm1+0.25d0*flam**2)*flam
25802  IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
25803  IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
25804  ENDIF
25805  wdtp(i)=fudge*wdtp(i)
25806  wdtp(0)=wdtp(0)+wdtp(i)
25807  IF(mdme(idc,1).GT.0) THEN
25808  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25809  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25810  wdte(i,0)=wdte(i,mdme(idc,1))
25811  wdte(0,0)=wdte(0,0)+wdte(i,0)
25812  ENDIF
25813  300 CONTINUE
25814 
25815  ELSEIF(kfla.EQ.37) THEN
25816 C...H+/-:
25817 C IF(MSTP(49).EQ.0) THEN
25818  shfs=sh
25819 C ELSE
25820 C SHFS=PMAS(37,1)**2
25821 C ENDIF
25822  fac=(aem/(8d0*xw))*(shfs/pmas(24,1)**2)*shr
25823  DO 310 i=1,mdcy(kc,3)
25824  idc=i+mdcy(kc,2)-1
25825  IF(mdme(idc,1).LT.0) GOTO 310
25826  kfc1=pycomp(kfdp(idc,1))
25827  kfc2=pycomp(kfdp(idc,2))
25828  rm1=pmas(kfc1,1)**2/sh
25829  rm2=pmas(kfc2,1)**2/sh
25830  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 310
25831  wid2=1d0
25832  IF(i.LE.4) THEN
25833 C...H+/- -> q + qbar'
25834  rm1r=pymrun(kfdp(idc,1),sh)**2/sh
25835  rm2r=pymrun(kfdp(idc,2),sh)**2/sh
25836  wdtp(i)=fac*3d0*radc*max(0d0,(rm1r*paru(141)**2+
25837  & rm2r/paru(141)**2)*(1d0-rm1r-rm2r)-4d0*rm1r*rm2r)*
25838  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*(sh/shfs)
25839  IF(kflr.GT.0) THEN
25840  IF(i.EQ.3) wid2=wids(6,2)
25841  IF(i.EQ.4) wid2=wids(7,3)*wids(8,2)
25842  ELSE
25843  IF(i.EQ.3) wid2=wids(6,3)
25844  IF(i.EQ.4) wid2=wids(7,2)*wids(8,3)
25845  ENDIF
25846  ELSEIF(i.LE.8) THEN
25847 C...H+/- -> l+/- + nu
25848  wdtp(i)=fac*((rm1*paru(141)**2+rm2/paru(141)**2)*
25849  & (1d0-rm1-rm2)-4d0*rm1*rm2)*sqrt(max(0d0,
25850  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))*(sh/shfs)
25851  IF(kflr.GT.0) THEN
25852  IF(i.EQ.8) wid2=wids(17,3)*wids(18,2)
25853  ELSE
25854  IF(i.EQ.8) wid2=wids(17,2)*wids(18,3)
25855  ENDIF
25856  ELSEIF(i.EQ.9) THEN
25857 C...H+/- -> W+/- + h0.
25858  wdtp(i)=fac*paru(195)**2*0.5d0*sqrt(max(0d0,
25859  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25860  IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
25861  IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
25862 
25863 CMRENNA++
25864  ELSE
25865 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25866  rm10=rm1*sh/pmr**2
25867  rm20=rm2*sh/pmr**2
25868  wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
25869  wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
25870  IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
25871  wfac=0d0
25872  ELSE
25873  wfac=wfac/wfac0
25874  ENDIF
25875  wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
25876 CMRENNA--
25877  ksgn1=2
25878  IF(kfls*kfdp(idc,1).LT.0.AND.kchg(kfc1,3).EQ.1) ksgn1=3
25879  ksgn2=2
25880  IF(kfls*kfdp(idc,2).LT.0.AND.kchg(kfc2,3).EQ.1) ksgn2=3
25881  wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
25882  ENDIF
25883  wdtp(i)=fudge*wdtp(i)
25884  wdtp(0)=wdtp(0)+wdtp(i)
25885  IF(mdme(idc,1).GT.0) THEN
25886  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25887  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25888  wdte(i,0)=wdte(i,mdme(idc,1))
25889  wdte(0,0)=wdte(0,0)+wdte(i,0)
25890  ENDIF
25891  310 CONTINUE
25892 
25893  ELSEIF(kfla.EQ.41) THEN
25894 C...R:
25895  fac=(aem/(12d0*xw))*shr
25896  DO 320 i=1,mdcy(kc,3)
25897  idc=i+mdcy(kc,2)-1
25898  IF(mdme(idc,1).LT.0) GOTO 320
25899  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25900  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25901  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 320
25902  wid2=1d0
25903  IF(i.LE.6) THEN
25904 C...R -> q + qbar'
25905  fcof=3d0*radc
25906  ELSEIF(i.LE.9) THEN
25907 C...R -> l+ + l'-
25908  fcof=1d0
25909  ENDIF
25910  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
25911  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25912  IF(kflr.GT.0) THEN
25913  IF(i.EQ.4) wid2=wids(6,3)
25914  IF(i.EQ.5) wid2=wids(7,3)
25915  IF(i.EQ.6) wid2=wids(6,2)*wids(8,3)
25916  IF(i.EQ.9) wid2=wids(17,3)
25917  ELSE
25918  IF(i.EQ.4) wid2=wids(6,2)
25919  IF(i.EQ.5) wid2=wids(7,2)
25920  IF(i.EQ.6) wid2=wids(6,3)*wids(8,2)
25921  IF(i.EQ.9) wid2=wids(17,2)
25922  ENDIF
25923  wdtp(i)=fudge*wdtp(i)
25924  wdtp(0)=wdtp(0)+wdtp(i)
25925  IF(mdme(idc,1).GT.0) THEN
25926  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25927  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25928  wdte(i,0)=wdte(i,mdme(idc,1))
25929  wdte(0,0)=wdte(0,0)+wdte(i,0)
25930  ENDIF
25931  320 CONTINUE
25932 
25933  ELSEIF(kfla.EQ.42) THEN
25934 C...LQ (leptoquark).
25935  fac=(aem/4d0)*paru(151)*shr
25936  DO 330 i=1,mdcy(kc,3)
25937  idc=i+mdcy(kc,2)-1
25938  IF(mdme(idc,1).LT.0) GOTO 330
25939  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25940  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25941  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 330
25942  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25943  wid2=1d0
25944  ilqq=kfdp(idc,1)*isign(1,kflr)
25945  IF(ilqq.GE.6) wid2=wids(ilqq,2)
25946  IF(ilqq.LE.-6) wid2=wids(-ilqq,3)
25947  ilql=kfdp(idc,2)*isign(1,kflr)
25948  IF(ilql.GE.17) wid2=wid2*wids(ilql,2)
25949  IF(ilql.LE.-17) wid2=wid2*wids(-ilql,3)
25950  wdtp(i)=fudge*wdtp(i)
25951  wdtp(0)=wdtp(0)+wdtp(i)
25952  IF(mdme(idc,1).GT.0) THEN
25953  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25954  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25955  wdte(i,0)=wdte(i,mdme(idc,1))
25956  wdte(0,0)=wdte(0,0)+wdte(i,0)
25957  ENDIF
25958  330 CONTINUE
25959 
25960 C...UED: kk state width decays : flav: 451 476
25961  ELSEIF(iued(1).EQ.1.AND.
25962  & pycomp(abs(kfla)).GE.kkflmi.AND.
25963  & pycomp(abs(kfla)).LE.kkflma) THEN
25964  kcla=pycomp(kfla)
25965 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
25966  rmflas=pmas(kcla,1)
25967  facsh=sh/pmas(kcla,1)**2
25968  alphem=pyalem(rmflas**2)
25969  alphs=pyalps(rmflas**2)
25970 
25971 C...uedcor parameters (alpha_s is calculated at mkk scale)
25972 C...alpha_em is calculated at z pole !
25973  alphem=paru(101)
25974  facsh=1.
25975 
25976  DO 1070 i=1,mdcy(kcla,3)
25977  idc=i+mdcy(kcla,2)-1
25978 
25979  IF(mdme(idc,1).LT.0) GOTO 1070
25980  kfc1=pycomp(abs(kfdp(idc,1)))
25981  kfc2=pycomp(abs(kfdp(idc,2)))
25982  rm1=pmas(kfc1,1)**2/sh
25983  rm2=pmas(kfc2,1)**2/sh
25984  IF(sqrt(rm1)+sqrt(rm2).GT.1d0)
25985  & GOTO 1070
25986  wid2=1d0
25987 
25988 C...N.B. RINV=RUED(1)
25989  rmkk=rued(1)
25990  rmwkk=pmas(475,1)
25991  rmzkk=pmas(474,1)
25992  sw2=paru(102)
25993  cw2=1.-sw2
25994  kkcla=kcla-kkflmi+1
25995  IF(abs(kfc1).GE.kkflmi)kkpart=kfc1
25996  IF(abs(kfc2).GE.kkflmi)kkpart=kfc2
25997  IF(kkcla.LE.6) THEN
25998 C...q*_S -> q + gamma* (in first time sw21=0)
25999  fac=0.25*alphem*rmflas*0.5*cw21/cw2*kchg(kcla,1)**2/9.
26000 C...Eventually change the following by enabling a choice of open or closed.
26001 C...Only the gamma_kk channel is open.
26002  IF(mod(i,2).EQ.0)
26003  + wdtp(i)=fac*fkac2(rmflas,rmkk)*fkac1(rmkk,rmflas)**2
26004  wdtp(i)=facsh*wdtp(i)
26005  wid2=wids(473,2)
26006  ELSEIF(kkcla.GT.6.AND.kkcla.LE.12)THEN
26007 C...q*_D -> q + Z*/W*
26008  fac=0.25*alphem*rmflas/(4.*sw2)
26009  gammaw=fac*fkac2(rmflas,rmwkk)*fkac1(rmwkk,rmflas)**2
26010  IF(i.EQ.1)THEN
26011 C...q*_D -> q + Z*
26012  wdtp(i)=0.5*gammaw
26013  wid2=wids(474,2)
26014  ELSEIF(i.EQ.2)THEN
26015 C...q*_D -> q + W*
26016  wdtp(i)=gammaw
26017  wid2=wids(475,2)
26018  ENDIF
26019  wdtp(i)=facsh*wdtp(i)
26020 C...q*_D -> q + gamma* is closed
26021  ELSEIF(kkcla.GT.12.AND.kkcla.LE.21)THEN
26022 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26023  fac=alphem/4.*rmflas/cw2/8.
26024  rmgakk=pmas(473,1)
26025  wdtp(i)=fac*fkac2(rmflas,rmgakk)*
26026  + fkac1(rmgakk,rmflas)**2
26027  wdtp(i)=facsh*wdtp(i)
26028  wid2=wids(473,2)
26029  ELSEIF(kkcla.EQ.22)THEN
26030  rmqst=pmas(kkpart,1)
26031  wid2=wids(kkpart,2)
26032 C...g* -> q*_S/q*_D + q
26033  fac=10.*alphs/12.*rmflas
26034  wdtp(i)=fac*fkac1(rmqst,rmflas)**2*fkac2(rmqst,rmflas)
26035  wdtp(i)=facsh*wdtp(i)
26036  ELSEIF(kkcla.EQ.23)THEN
26037 C...gamma* decays to graviton + gamma : initial value is used
26038  ichi=iued(4)/2
26039  wdtp(i)=rmflas*(rmflas/rued(2))**(iued(4)+2)
26040  & *chidel(ichi)
26041  ELSEIF(kkcla.EQ.24)THEN
26042 C...Z* -> l*_S + l is closed
26043 C... Z* -> l*_D + l
26044  IF(i.LE.3)GOTO 1070
26045 c... After closing the channels for a Z* decaying into positively charged
26046 C... KK lepton singlets, close the channels for a Z* decaying into negatively
26047 C... charged KK lepton singlets + positively charged SM particles
26048  IF(i.GE.10.AND.i.LE.12)GOTO 1070
26049  fac=3./2.*alphem/24./sw2*rmzkk
26050  rmlst=pmas(kkpart,1)
26051  wdtp(i)=fac*fkac1(rmlst,rmzkk)**2*fkac2(rmlst,rmzkk)
26052  wdtp(i)=facsh*wdtp(i)
26053  wid2=wids(kkpart,2)
26054  ELSEIF(kkcla.EQ.25)THEN
26055 C...W* -> l*_D lbar
26056  fac=3.*alphem/12./sw2*rmwkk
26057  rmlst=pmas(kkpart,1)
26058  wdtp(i)=fac*fkac1(rmlst,rmwkk)**2*fkac2(rmlst,rmwkk)
26059  wdtp(i)=facsh*wdtp(i)
26060  wid2=wids(kkpart,2)
26061  ENDIF
26062  wdtp(0)=wdtp(0)+wdtp(i)
26063  IF(mdme(idc,1).GT.0) THEN
26064  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26065  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26066  wdte(i,0)=wdte(i,mdme(idc,1))
26067  wdte(0,0)=wdte(0,0)+wdte(i,0)
26068  ENDIF
26069  1070 CONTINUE
26070  iuedpr(kkcla)=1
26071 
26072  ELSEIF(kfla.EQ.ktechn+111.OR.kfla.EQ.ktechn+221) THEN
26073 C...Techni-pi0 and techni-pi0':
26074  fac=(1d0/(32d0*paru(1)*rtcm(1)**2))*shr
26075  DO 340 i=1,mdcy(kc,3)
26076  idc=i+mdcy(kc,2)-1
26077  IF(mdme(idc,1).LT.0) GOTO 340
26078  pm1=pmas(pycomp(kfdp(idc,1)),1)
26079  pm2=pmas(pycomp(kfdp(idc,2)),1)
26080  rm1=pm1**2/sh
26081  rm2=pm2**2/sh
26082  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 340
26083  wid2=1d0
26084 C...pi_tc -> g + g
26085  IF(i.EQ.8) THEN
26086  facp=(as/(4d0*paru(1))*itcm(1)/rtcm(1))**2
26087  & /(8d0*paru(1))*sh*shr
26088  IF(kfla.EQ.ktechn+111) THEN
26089  facp=facp*rtcm(9)
26090  ELSE
26091  facp=facp*rtcm(10)
26092  ENDIF
26093  wdtp(i)=facp
26094  ELSE
26095 C...pi_tc -> f + fbar.
26096  fcof=1d0
26097  ika=iabs(kfdp(idc,1))
26098  IF(ika.LT.10) fcof=3d0*radc
26099  hm1=pm1
26100  hm2=pm2
26101  IF(ika.GE.4.AND.ika.LE.6) THEN
26102  fcof=fcof*rtcm(1+ika)**2
26103  hm1=pymrun(kfdp(idc,1),sh)
26104  hm2=pymrun(kfdp(idc,2),sh)
26105  ELSEIF(ika.EQ.15) THEN
26106  fcof=fcof*rtcm(8)**2
26107  ENDIF
26108  wdtp(i)=fac*fcof*(hm1+hm2)**2*
26109  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26110  ENDIF
26111  wdtp(i)=fudge*wdtp(i)
26112  wdtp(0)=wdtp(0)+wdtp(i)
26113  IF(mdme(idc,1).GT.0) THEN
26114  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26115  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26116  wdte(i,0)=wdte(i,mdme(idc,1))
26117  wdte(0,0)=wdte(0,0)+wdte(i,0)
26118  ENDIF
26119  340 CONTINUE
26120 
26121  ELSEIF(kfla.EQ.ktechn+211) THEN
26122 C...pi+_tc
26123  fac=(1d0/(32d0*paru(1)*rtcm(1)**2))*shr
26124  DO 350 i=1,mdcy(kc,3)
26125  idc=i+mdcy(kc,2)-1
26126  IF(mdme(idc,1).LT.0) GOTO 350
26127  pm1=pmas(pycomp(kfdp(idc,1)),1)
26128  pm2=pmas(pycomp(kfdp(idc,2)),1)
26129  pm3=0d0
26130  IF(i.EQ.5) pm3=pmas(pycomp(kfdp(idc,3)),1)
26131  rm1=pm1**2/sh
26132  rm2=pm2**2/sh
26133  rm3=pm3**2/sh
26134  IF(sqrt(rm1)+sqrt(rm2)+sqrt(rm3).GT.1d0) GOTO 350
26135  wid2=1d0
26136 C...pi_tc -> f + f'.
26137  fcof=1d0
26138  IF(iabs(kfdp(idc,1)).LT.10) fcof=3d0*radc
26139 C...pi_tc+ -> W b b~
26140  IF(i.EQ.5.AND.shr.LT.pmas(6,1)+pmas(5,1)) THEN
26141  fcof=3d0*radc
26142  xmt2=pmas(6,1)**2/sh
26143  facp=fac/(4d0*paru(1))*fcof*xmt2*rtcm(7)**2
26144  kfc3=pycomp(kfdp(idc,3))
26145  check = sqrt(rm1)+sqrt(rm2)+sqrt(rm3)
26146  check = sqrt(rm1)
26147  t0 = (1d0-check**2)*
26148  & (xmt2*(6d0*xmt2**2+3d0*xmt2*rm1-4d0*rm1**2)-
26149  & (5d0*xmt2**2+2d0*xmt2*rm1-8d0*rm1**2))/(4d0*xmt2**2)
26150  t1 = (1d0-xmt2)*(rm1-xmt2)*((xmt2**2+xmt2*rm1+4d0*rm1**2)
26151  & -3d0*xmt2**2*(xmt2+rm1))/(2d0*xmt2**3)
26152  t3 = rm1**2/xmt2**3*(3d0*xmt2-4d0*rm1+4d0*xmt2*rm1)
26153  wdtp(i)=facp*(t0 + t1*log((xmt2-check**2)/(xmt2-1d0))
26154  & +t3*log(check))
26155  IF(kflr.GT.0) THEN
26156  wid2=wids(24,2)
26157  ELSE
26158  wid2=wids(24,3)
26159  ENDIF
26160  ELSE
26161  fcof=1d0
26162  ika=iabs(kfdp(idc,1))
26163  IF(ika.LT.10) fcof=3d0*radc
26164  hm1=pm1
26165  hm2=pm2
26166  IF(i.GE.1.AND.i.LE.5) THEN
26167  IF(i.LE.2) THEN
26168  fcof=fcof*rtcm(5)**2
26169  ELSEIF(i.LE.4) THEN
26170  fcof=fcof*rtcm(6)**2
26171  ELSEIF(i.EQ.5) THEN
26172  fcof=fcof*rtcm(7)**2
26173  ENDIF
26174  hm1=pymrun(kfdp(idc,1),sh)
26175  hm2=pymrun(kfdp(idc,2),sh)
26176  ELSEIF(i.EQ.8) THEN
26177  fcof=fcof*rtcm(8)**2
26178  ENDIF
26179  wdtp(i)=fac*fcof*(hm1+hm2)**2*
26180  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26181  ENDIF
26182  wdtp(i)=fudge*wdtp(i)
26183  wdtp(0)=wdtp(0)+wdtp(i)
26184  IF(mdme(idc,1).GT.0) THEN
26185  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26186  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26187  wdte(i,0)=wdte(i,mdme(idc,1))
26188  wdte(0,0)=wdte(0,0)+wdte(i,0)
26189  ENDIF
26190  350 CONTINUE
26191 
26192  ELSEIF(kfla.EQ.ktechn+331) THEN
26193 C...Techni-eta.
26194  fac=(sh/parp(46)**2)*shr
26195  DO 360 i=1,mdcy(kc,3)
26196  idc=i+mdcy(kc,2)-1
26197  IF(mdme(idc,1).LT.0) GOTO 360
26198  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26199  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26200  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 360
26201  wid2=1d0
26202  IF(i.LE.2) THEN
26203  wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))/(4d0*paru(1))
26204  IF(i.EQ.2) wid2=wids(6,1)
26205  ELSE
26206  wdtp(i)=fac*5d0*as**2/(96d0*paru(1)**3)
26207  ENDIF
26208  wdtp(i)=fudge*wdtp(i)
26209  wdtp(0)=wdtp(0)+wdtp(i)
26210  IF(mdme(idc,1).GT.0) THEN
26211  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26212  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26213  wdte(i,0)=wdte(i,mdme(idc,1))
26214  wdte(0,0)=wdte(0,0)+wdte(i,0)
26215  ENDIF
26216  360 CONTINUE
26217 
26218  ELSEIF(kfla.EQ.ktechn+113) THEN
26219 C...Techni-rho0:
26220  alprht=2.16d0*(3d0/itcm(1))
26221  fac=(alprht/12d0)*shr
26222  facf=(1d0/6d0)*(aem**2/alprht)*shr
26223  sqmz=pmas(23,1)**2
26224  sqmw=pmas(24,1)**2
26225  shp=sh
26226  CALL pywidx(23,shp,wdtpp,wdtep)
26227  gmmz=shr*wdtpp(0)
26228  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
26229  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
26230  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
26231  DO 370 i=1,mdcy(kc,3)
26232  idc=i+mdcy(kc,2)-1
26233  IF(mdme(idc,1).LT.0) GOTO 370
26234  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26235  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26236  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 370
26237  wid2=1d0
26238  IF(i.EQ.1) THEN
26239 C...rho_tc0 -> W+ + W-.
26240 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26241  wdtp(i)=fac*rtcm(3)**4*
26242  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26243  & 2d0*aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26244  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
26245  & rtcm(3)**2/4d0/xw/24d0/rtcm(13)**2*shr**3
26246  wid2=wids(24,1)
26247  ELSEIF(i.EQ.2) THEN
26248 C...rho_tc0 -> W+ + pi_tc-.
26249 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26250  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26251  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26252  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26253  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*rm1)*
26254  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26255  wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
26256  ELSEIF(i.EQ.3) THEN
26257 C...rho_tc0 -> pi_tc+ + W-.
26258  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26259  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26260  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26261  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*rm2)*
26262  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26263  wid2=wids(pycomp(ktechn+211),2)*wids(24,3)
26264  ELSEIF(i.EQ.4) THEN
26265 C...rho_tc0 -> pi_tc+ + pi_tc-.
26266  wdtp(i)=fac*(1d0-rtcm(3)**2)**2*
26267  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26268  wid2=wids(pycomp(ktechn+211),1)
26269  ELSEIF(i.EQ.5) THEN
26270 C...rho_tc0 -> gamma + pi_tc0
26271  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26272  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26273  & shr**3
26274  wid2=wids(pycomp(ktechn+111),2)
26275  ELSEIF(i.EQ.6) THEN
26276 C...rho_tc0 -> gamma + pi_tc0'
26277  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26278  & (1d0-rtcm(4)**2)/24d0/rtcm(12)**2*shr**3
26279  wid2=wids(pycomp(ktechn+221),2)
26280  ELSEIF(i.EQ.7) THEN
26281 C...rho_tc0 -> Z0 + pi_tc0
26282  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26283  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26284  & xw/xw1*shr**3
26285  wid2=wids(23,2)*wids(pycomp(ktechn+111),2)
26286  ELSEIF(i.EQ.8) THEN
26287 C...rho_tc0 -> Z0 + pi_tc0'
26288  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26289  & (1d0-rtcm(4)**2)/24d0/rtcm(12)**2*(1d0-2d0*xw)**2/4d0/
26290  & xw/xw1*shr**3
26291  wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
26292  ELSEIF(i.EQ.9) THEN
26293 C...rho_tc0 -> gamma + Z0
26294  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26295  & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2/24d0/rtcm(12)**2*shr**3
26296  wid2=wids(23,2)
26297  ELSEIF(i.EQ.10) THEN
26298 C...rho_tc0 -> Z0 + Z0
26299  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26300  & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2*xw/xw1/24d0/rtcm(12)**2*
26301  & shr**3
26302  wid2=wids(23,1)
26303  ELSE
26304 C...rho_tc0 -> f + fbar.
26305  wid2=1d0
26306  IF(i.LE.18) THEN
26307  ia=i-10
26308  fcof=3d0*radc
26309  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
26310  ELSE
26311  ia=i-6
26312  fcof=1d0
26313  IF(ia.GE.17) wid2=wids(ia,1)
26314  ENDIF
26315  ei=kchg(ia,1)/3d0
26316  ai=sign(1d0,ei+0.1d0)
26317  vi=ai-4d0*ei*xwv
26318  vali=0.5d0*(vi+ai)
26319  vari=0.5d0*(vi-ai)
26320  wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
26321  & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
26322  & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
26323  & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
26324  ENDIF
26325  wdtp(i)=fudge*wdtp(i)
26326  wdtp(0)=wdtp(0)+wdtp(i)
26327  IF(mdme(idc,1).GT.0) THEN
26328  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26329  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26330  wdte(i,0)=wdte(i,mdme(idc,1))
26331  wdte(0,0)=wdte(0,0)+wdte(i,0)
26332  ENDIF
26333  370 CONTINUE
26334 
26335  ELSEIF(kfla.EQ.ktechn+213) THEN
26336 C...Techni-rho+/-:
26337  alprht=2.16d0*(3d0/itcm(1))
26338  fac=(alprht/12d0)*shr
26339  sqmz=pmas(23,1)**2
26340  sqmw=pmas(24,1)**2
26341  shp=sh
26342  CALL pywidx(24,shp,wdtpp,wdtep)
26343  gmmw=shr*wdtpp(0)
26344  facf=(1d0/12d0)*(aem**2/alprht)*shr*
26345  & (0.125d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
26346  DO 380 i=1,mdcy(kc,3)
26347  idc=i+mdcy(kc,2)-1
26348  IF(mdme(idc,1).LT.0) GOTO 380
26349  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26350  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26351  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 380
26352  wid2=1d0
26353  pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26354 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26355 c & /3D0*SHR**3
26356  IF(i.EQ.1) THEN
26357 C...rho_tc+ -> W+ + Z0.
26358 C......Goldstone
26359  wdtp(i)=fac*rtcm(3)**4*
26360  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26361  va2=rtcm(3)**2*(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(12)**2
26362  aa2=rtcm(3)**2/rtcm(13)**2/4d0/xw/xw1
26363 C......W_L Z_T
26364  wdtp(i)=wdtp(i)+aem*pcm*(aa2*(pcm**2+1.5d0*rm2)+pcm**2*va2)
26365  & /3d0*shr**3
26366  va2=0d0
26367  aa2=rtcm(3)**2/rtcm(13)**2/4d0/xw
26368 C......W_T Z_L
26369  wdtp(i)=wdtp(i)+aem*pcm*(aa2*(pcm**2+1.5d0*rm1)+pcm**2*va2)
26370  & /3d0*shr**3
26371  IF(kflr.GT.0) THEN
26372  wid2=wids(24,2)*wids(23,2)
26373  ELSE
26374  wid2=wids(24,3)*wids(23,2)
26375  ENDIF
26376  ELSEIF(i.EQ.2) THEN
26377 C...rho_tc+ -> W+ + pi_tc0.
26378  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26379  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26380  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26381  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
26382  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26383  IF(kflr.GT.0) THEN
26384  wid2=wids(24,2)*wids(pycomp(ktechn+111),2)
26385  ELSE
26386  wid2=wids(24,3)*wids(pycomp(ktechn+111),2)
26387  ENDIF
26388  ELSEIF(i.EQ.3) THEN
26389 C...rho_tc+ -> pi_tc+ + Z0.
26390  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26391  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26392  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26393  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmz/sh)*
26394  & (1d0-rtcm(3)**2)/4d0/xw/xw1/24d0/rtcm(13)**2*shr**3+
26395  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26396  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26397  & shr**3*xw/xw1
26398  IF(kflr.GT.0) THEN
26399  wid2=wids(pycomp(ktechn+211),2)*wids(23,2)
26400  ELSE
26401  wid2=wids(pycomp(ktechn+211),3)*wids(23,2)
26402  ENDIF
26403  ELSEIF(i.EQ.4) THEN
26404 C...rho_tc+ -> pi_tc+ + pi_tc0.
26405  wdtp(i)=fac*(1d0-rtcm(3)**2)**2*
26406  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26407  IF(kflr.GT.0) THEN
26408  wid2=wids(pycomp(ktechn+211),2)*wids(pycomp(ktechn+111),2)
26409  ELSE
26410  wid2=wids(pycomp(ktechn+211),3)*wids(pycomp(ktechn+111),2)
26411  ENDIF
26412  ELSEIF(i.EQ.5) THEN
26413 C...rho_tc+ -> pi_tc+ + gamma
26414  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26415  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26416  & shr**3
26417  IF(kflr.GT.0) THEN
26418  wid2=wids(pycomp(ktechn+211),2)
26419  ELSE
26420  wid2=wids(pycomp(ktechn+211),3)
26421  ENDIF
26422  ELSEIF(i.EQ.6) THEN
26423 C...rho_tc+ -> W+ + pi_tc0'
26424  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26425  & (1d0-rtcm(4)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3
26426  IF(kflr.GT.0) THEN
26427  wid2=wids(24,2)*wids(pycomp(ktechn+221),2)
26428  ELSE
26429  wid2=wids(24,3)*wids(pycomp(ktechn+221),2)
26430  ENDIF
26431  ELSEIF(i.EQ.7) THEN
26432 C...rho_tc+ -> W+ + gamma
26433  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26434  & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2/24d0/rtcm(12)**2*shr**3
26435  IF(kflr.GT.0) THEN
26436  wid2=wids(24,2)
26437  ELSE
26438  wid2=wids(24,3)
26439  ENDIF
26440  ELSE
26441 C...rho_tc+ -> f + fbar'.
26442  ia=i-7
26443  wid2=1d0
26444  IF(ia.LE.16) THEN
26445  fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
26446  IF(kflr.GT.0) THEN
26447  IF(mod(ia,4).EQ.3) wid2=wids(6,2)
26448  IF(mod(ia,4).EQ.0) wid2=wids(8,2)
26449  IF(ia.GE.13) wid2=wid2*wids(7,3)
26450  ELSE
26451  IF(mod(ia,4).EQ.3) wid2=wids(6,3)
26452  IF(mod(ia,4).EQ.0) wid2=wids(8,3)
26453  IF(ia.GE.13) wid2=wid2*wids(7,2)
26454  ENDIF
26455  ELSE
26456  fcof=1d0
26457  IF(kflr.GT.0) THEN
26458  IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
26459  ELSE
26460  IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
26461  ENDIF
26462  ENDIF
26463  wdtp(i)=facf*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
26464  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26465  ENDIF
26466  wdtp(i)=fudge*wdtp(i)
26467  wdtp(0)=wdtp(0)+wdtp(i)
26468  IF(mdme(idc,1).GT.0) THEN
26469  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26470  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26471  wdte(i,0)=wdte(i,mdme(idc,1))
26472  wdte(0,0)=wdte(0,0)+wdte(i,0)
26473  ENDIF
26474  380 CONTINUE
26475 
26476  ELSEIF(kfla.EQ.ktechn+223) THEN
26477 C...Techni-omega:
26478  alprht=2.16d0*(3d0/itcm(1))
26479  fac=(alprht/12d0)*shr
26480  facf=(1d0/6d0)*(aem**2/alprht)*shr*(2d0*rtcm(2)-1d0)**2
26481  sqmz=pmas(23,1)**2
26482  shp=sh
26483  CALL pywidx(23,shp,wdtpp,wdtep)
26484  gmmz=shr*wdtpp(0)
26485  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
26486  bwzi=-(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
26487  DO 390 i=1,mdcy(kc,3)
26488  idc=i+mdcy(kc,2)-1
26489  IF(mdme(idc,1).LT.0) GOTO 390
26490  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26491  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26492  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 390
26493  wid2=1d0
26494  IF(i.EQ.1) THEN
26495 C...omega_tc0 -> gamma + pi_tc0.
26496  wdtp(i)=aem/24d0/rtcm(12)**2*(1d0-rtcm(3)**2)*
26497  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*shr**3
26498  wid2=wids(pycomp(ktechn+111),2)
26499  ELSEIF(i.EQ.2) THEN
26500 C...omega_tc0 -> Z0 + pi_tc0
26501  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26502  & (1d0-rtcm(3)**2)/24d0/rtcm(12)**2*(1d0-2d0*xw)**2/4d0/
26503  & xw/xw1*shr**3
26504  wid2=wids(23,2)*wids(pycomp(ktechn+111),2)
26505  ELSEIF(i.EQ.3) THEN
26506 C...omega_tc0 -> gamma + pi_tc0'
26507  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26508  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(4)**2)/24d0/rtcm(12)**2*
26509  & shr**3
26510  wid2=wids(pycomp(ktechn+221),2)
26511  ELSEIF(i.EQ.4) THEN
26512 C...omega_tc0 -> Z0 + pi_tc0'
26513  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26514  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(4)**2)/24d0/rtcm(12)**2*
26515  & xw/xw1*shr**3
26516  wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
26517  ELSEIF(i.EQ.5) THEN
26518 C...omega_tc0 -> W+ + pi_tc-
26519  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26520  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3+
26521  & fac*rtcm(3)**2*(1d0-rtcm(3)**2)*rtcm(11)**2*
26522  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26523  wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
26524  ELSEIF(i.EQ.6) THEN
26525 C...omega_tc0 -> pi_tc+ + W-
26526  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26527  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3+
26528  & fac*rtcm(3)**2*(1d0-rtcm(3)**2)*rtcm(11)**2*
26529  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26530  wid2=wids(24,3)*wids(pycomp(ktechn+211),2)
26531  ELSEIF(i.EQ.7) THEN
26532 C...omega_tc0 -> W+ + W-.
26533 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26534  wdtp(i)=fac*rtcm(3)**4*rtcm(11)**2*
26535  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26536  & 2d0*aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26537  & rtcm(3)**2/4d0/xw/24d0/rtcm(12)**2*shr**3
26538  wid2=wids(24,1)
26539  ELSEIF(i.EQ.8) THEN
26540 C...omega_tc0 -> pi_tc+ + pi_tc-.
26541  wdtp(i)=fac*(1d0-rtcm(3)**2)**2*rtcm(11)**2*
26542  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26543  wid2=wids(pycomp(ktechn+211),1)
26544 C...omega_tc0 -> gamma + Z0
26545  ELSEIF(i.EQ.9) THEN
26546  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26547  & rtcm(3)**2/24d0/rtcm(12)**2*shr**3
26548  wid2=wids(23,2)
26549 C...omega_tc0 -> Z0 + Z0
26550  ELSEIF(i.EQ.10) THEN
26551  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26552  & rtcm(3)**2*(xw1-xw)**2/xw/xw1/4d0
26553  & /24d0/rtcm(12)**2*shr**3
26554  wid2=wids(23,1)
26555  ELSE
26556 C...omega_tc0 -> f + fbar.
26557  wid2=1d0
26558  IF(i.LE.18) THEN
26559  ia=i-10
26560  fcof=3d0*radc
26561  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
26562  ELSE
26563  ia=i-8
26564  fcof=1d0
26565  IF(ia.GE.17) wid2=wids(ia,1)
26566  ENDIF
26567  ei=kchg(ia,1)/3d0
26568  ai=sign(1d0,ei+0.1d0)
26569  vi=ai-4d0*ei*xwv
26570  vali=-0.5d0*(vi+ai)
26571  vari=-0.5d0*(vi-ai)
26572  wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
26573  & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
26574  & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
26575  & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
26576  ENDIF
26577  wdtp(i)=fudge*wdtp(i)
26578  wdtp(0)=wdtp(0)+wdtp(i)
26579  IF(mdme(idc,1).GT.0) THEN
26580  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26581  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26582  wdte(i,0)=wdte(i,mdme(idc,1))
26583  wdte(0,0)=wdte(0,0)+wdte(i,0)
26584  ENDIF
26585  390 CONTINUE
26586 
26587 C.....V8 -> quark anti-quark
26588  ELSEIF(kfla.EQ.ktechn+100021) THEN
26589  fac=as/6d0*shr
26590  tant3=rtcm(21)
26591  IF(itcm(2).EQ.0) THEN
26592  imdl=1
26593  ELSEIF(itcm(2).EQ.1) THEN
26594  imdl=2
26595  ENDIF
26596  DO 400 i=1,mdcy(kc,3)
26597  idc=i+mdcy(kc,2)-1
26598  IF(mdme(idc,1).LT.0) GOTO 400
26599  pm1=pmas(pycomp(kfdp(idc,1)),1)
26600  rm1=pm1**2/sh
26601  IF(rm1.GT.0.25d0) GOTO 400
26602  wid2=1d0
26603  IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
26604  fmix=1d0/tant3**2
26605  ELSE
26606  fmix=tant3**2
26607  ENDIF
26608  wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*fmix
26609  IF(i.EQ.6) wid2=wids(6,1)
26610  wdtp(i)=fudge*wdtp(i)
26611  wdtp(0)=wdtp(0)+wdtp(i)
26612  IF(mdme(idc,1).GT.0) THEN
26613  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26614  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26615  wdte(i,0)=wdte(i,mdme(idc,1))
26616  wdte(0,0)=wdte(0,0)+wdte(i,0)
26617  ENDIF
26618  400 CONTINUE
26619 
26620  ELSEIF(kfla.EQ.ktechn+100111.OR.kfla.EQ.ktechn+200111) THEN
26621  fac=(1d0/(4d0*paru(1)*rtcm(1)**2))*shr
26622  clebf=0d0
26623  DO 410 i=1,mdcy(kc,3)
26624  idc=i+mdcy(kc,2)-1
26625  IF(mdme(idc,1).LT.0) GOTO 410
26626  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26627  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26628  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 410
26629  wid2=1d0
26630 C...pi_tc -> g + g
26631  IF(i.EQ.7) THEN
26632  IF(kfla.EQ.ktechn+100111) THEN
26633  clebg=4d0/3d0
26634  ELSE
26635  clebg=5d0/3d0
26636  ENDIF
26637  facp=(as/(8d0*paru(1))*itcm(1)/rtcm(1))**2
26638  & /(2d0*paru(1))*sh*shr*clebg
26639  wdtp(i)=facp
26640  ELSE
26641 C...pi_tc -> f + fbar.
26642  IF(i.EQ.6) wid2=wids(6,1)
26643  fcof=1d0
26644  ika=iabs(kfdp(idc,1))
26645  IF(ika.LT.10) fcof=3d0*radc
26646  hm1=pymrun(kfdp(idc,1),sh)
26647  wdtp(i)=fac*fcof*hm1**2*clebf*
26648  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26649  ENDIF
26650  wdtp(i)=fudge*wdtp(i)
26651  wdtp(0)=wdtp(0)+wdtp(i)
26652  IF(mdme(idc,1).GT.0) THEN
26653  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26654  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26655  wdte(i,0)=wdte(i,mdme(idc,1))
26656  wdte(0,0)=wdte(0,0)+wdte(i,0)
26657  ENDIF
26658  410 CONTINUE
26659 
26660  ELSEIF(kfla.GE.ktechn+100113.AND.kfla.LE.ktechn+400113) THEN
26661  fac=as/6d0*shr
26662  alprht=2.16d0*(3d0/itcm(1))
26663  tant3=rtcm(21)
26664  sin2t=2d0*tant3/(tant3**2+1d0)
26665  sint3=tant3/sqrt(tant3**2+1d0)
26666  csxpp=rtcm(22)
26667  rm82=rtcm(27)**2
26668  x12=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*cos(rtcm(30))+
26669  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*cos(rtcm(32)))/sqrt(2d0)
26670  x21=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*sin(rtcm(30))+
26671  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*sin(rtcm(32)))/sqrt(2d0)
26672  x11=(.25d0*(rtcm(29)**2+rtcm(31)**2+2d0)-
26673  & sint3**2)*2d0
26674  x22=(.25d0*(2d0-rtcm(29)**2-rtcm(31)**2)-
26675  & sint3**2)*2d0
26676  CALL pywidx(ktechn+100021,sh,wdtpp,wdtep)
26677 
26678  IF(wdtpp(0).GT.rtcm(33)*shr) wdtpp(0)=rtcm(33)*shr
26679  gmv8=shr*wdtpp(0)
26680  rmv8=pmas(pycomp(ktechn+100021),1)
26681  fv8re=sh*(sh-rmv8**2)/((sh-rmv8**2)**2+gmv8**2)
26682  fv8im=sh*gmv8/((sh-rmv8**2)**2+gmv8**2)
26683  IF(itcm(2).EQ.0) THEN
26684  imdl=1
26685  ELSE
26686  imdl=2
26687  ENDIF
26688  DO 420 i=1,mdcy(kc,3)
26689  IF(i.EQ.7.AND.(kfla.EQ.ktechn+200113.OR.
26690  & kfla.EQ.ktechn+300113)) GOTO 420
26691  idc=i+mdcy(kc,2)-1
26692  IF(mdme(idc,1).LT.0) GOTO 420
26693  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26694  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26695  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 420
26696  wid2=1d0
26697  IF(i.LE.6) THEN
26698  IF(i.EQ.6) wid2=wids(6,1)
26699  xig=1d0
26700  IF(kfla.EQ.ktechn+200113) THEN
26701  xig=0d0
26702  xij=x12
26703  ELSEIF(kfla.EQ.ktechn+300113) THEN
26704  xig=0d0
26705  xij=x21
26706  ELSEIF(kfla.EQ.ktechn+100113) THEN
26707  xij=x11
26708  ELSE
26709  xij=x22
26710  ENDIF
26711  IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
26712  fmix=1d0/tant3/sin2t
26713  ELSE
26714  fmix=-tant3/sin2t
26715  ENDIF
26716  xfac=(xig+fmix*xij*fv8re)**2+(fmix*xij*fv8im)**2
26717  wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*as/alprht*xfac
26718  ELSEIF(i.EQ.7) THEN
26719  wdtp(i)=shr*as**2/(4d0*alprht)
26720  ELSEIF(kfla.EQ.ktechn+400113.AND.i.LE.9) THEN
26721  psh=shr*(1d0-rm1)/2d0
26722  wdtp(i)=as/9d0*psh**3/rm82
26723  IF(i.EQ.8) THEN
26724  wdtp(i)=2d0*wdtp(i)*csxpp**2
26725  wid2=wids(pycomp(kfdp(idc,1)),2)
26726  ELSE
26727  wdtp(i)=5d0*wdtp(i)
26728  wid2=wids(pycomp(kfdp(idc,1)),2)
26729  ENDIF
26730  ENDIF
26731  wdtp(i)=fudge*wdtp(i)
26732  wdtp(0)=wdtp(0)+wdtp(i)
26733  IF(mdme(idc,1).GT.0) THEN
26734  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26735  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26736  wdte(i,0)=wdte(i,mdme(idc,1))
26737  wdte(0,0)=wdte(0,0)+wdte(i,0)
26738  ENDIF
26739  420 CONTINUE
26740 
26741  ELSEIF(kfla.EQ.kexcit+1) THEN
26742 C...d* excited quark.
26743  fac=(sh/rtcm(41)**2)*shr
26744  DO 430 i=1,mdcy(kc,3)
26745  idc=i+mdcy(kc,2)-1
26746  IF(mdme(idc,1).LT.0) GOTO 430
26747  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26748  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26749  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 430
26750  wid2=1d0
26751  IF(i.EQ.1) THEN
26752 C...d* -> g + d.
26753  wdtp(i)=fac*as*rtcm(45)**2/3d0
26754  wid2=1d0
26755  ELSEIF(i.EQ.2) THEN
26756 C...d* -> gamma + d.
26757  qf=-rtcm(43)/2d0+rtcm(44)/6d0
26758  wdtp(i)=fac*aem*qf**2/4d0
26759  wid2=1d0
26760  ELSEIF(i.EQ.3) THEN
26761 C...d* -> Z0 + d.
26762  qf=-rtcm(43)*xw1/2d0-rtcm(44)*xw/6d0
26763  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26764  & (1d0-rm1)**2*(2d0+rm1)
26765  wid2=wids(23,2)
26766  ELSEIF(i.EQ.4) THEN
26767 C...d* -> W- + u.
26768  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26769  & (1d0-rm1)**2*(2d0+rm1)
26770  IF(kflr.GT.0) wid2=wids(24,3)
26771  IF(kflr.LT.0) wid2=wids(24,2)
26772  ENDIF
26773  wdtp(i)=fudge*wdtp(i)
26774  wdtp(0)=wdtp(0)+wdtp(i)
26775  IF(mdme(idc,1).GT.0) THEN
26776  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26777  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26778  wdte(i,0)=wdte(i,mdme(idc,1))
26779  wdte(0,0)=wdte(0,0)+wdte(i,0)
26780  ENDIF
26781  430 CONTINUE
26782 
26783  ELSEIF(kfla.EQ.kexcit+2) THEN
26784 C...u* excited quark.
26785  fac=(sh/rtcm(41)**2)*shr
26786  DO 440 i=1,mdcy(kc,3)
26787  idc=i+mdcy(kc,2)-1
26788  IF(mdme(idc,1).LT.0) GOTO 440
26789  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26790  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26791  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 440
26792  wid2=1d0
26793  IF(i.EQ.1) THEN
26794 C...u* -> g + u.
26795  wdtp(i)=fac*as*rtcm(45)**2/3d0
26796  wid2=1d0
26797  ELSEIF(i.EQ.2) THEN
26798 C...u* -> gamma + u.
26799  qf=rtcm(43)/2d0+rtcm(44)/6d0
26800  wdtp(i)=fac*aem*qf**2/4d0
26801  wid2=1d0
26802  ELSEIF(i.EQ.3) THEN
26803 C...u* -> Z0 + u.
26804  qf=rtcm(43)*xw1/2d0-rtcm(44)*xw/6d0
26805  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26806  & (1d0-rm1)**2*(2d0+rm1)
26807  wid2=wids(23,2)
26808  ELSEIF(i.EQ.4) THEN
26809 C...u* -> W+ + d.
26810  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26811  & (1d0-rm1)**2*(2d0+rm1)
26812  IF(kflr.GT.0) wid2=wids(24,2)
26813  IF(kflr.LT.0) wid2=wids(24,3)
26814  ENDIF
26815  wdtp(i)=fudge*wdtp(i)
26816  wdtp(0)=wdtp(0)+wdtp(i)
26817  IF(mdme(idc,1).GT.0) THEN
26818  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26819  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26820  wdte(i,0)=wdte(i,mdme(idc,1))
26821  wdte(0,0)=wdte(0,0)+wdte(i,0)
26822  ENDIF
26823  440 CONTINUE
26824 
26825  ELSEIF(kfla.EQ.kexcit+11) THEN
26826 C...e* excited lepton.
26827  fac=(sh/rtcm(41)**2)*shr
26828  DO 450 i=1,mdcy(kc,3)
26829  idc=i+mdcy(kc,2)-1
26830  IF(mdme(idc,1).LT.0) GOTO 450
26831  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26832  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26833  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 450
26834  wid2=1d0
26835  IF(i.EQ.1) THEN
26836 C...e* -> gamma + e.
26837  qf=-rtcm(43)/2d0-rtcm(44)/2d0
26838  wdtp(i)=fac*aem*qf**2/4d0
26839  wid2=1d0
26840  ELSEIF(i.EQ.2) THEN
26841 C...e* -> Z0 + e.
26842  qf=-rtcm(43)*xw1/2d0+rtcm(44)*xw/2d0
26843  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26844  & (1d0-rm1)**2*(2d0+rm1)
26845  wid2=wids(23,2)
26846  ELSEIF(i.EQ.3) THEN
26847 C...e* -> W- + nu.
26848  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26849  & (1d0-rm1)**2*(2d0+rm1)
26850  IF(kflr.GT.0) wid2=wids(24,3)
26851  IF(kflr.LT.0) wid2=wids(24,2)
26852  ENDIF
26853  wdtp(i)=fudge*wdtp(i)
26854  wdtp(0)=wdtp(0)+wdtp(i)
26855  IF(mdme(idc,1).GT.0) THEN
26856  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26857  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26858  wdte(i,0)=wdte(i,mdme(idc,1))
26859  wdte(0,0)=wdte(0,0)+wdte(i,0)
26860  ENDIF
26861  450 CONTINUE
26862 
26863  ELSEIF(kfla.EQ.kexcit+12) THEN
26864 C...nu*_e excited neutrino.
26865  fac=(sh/rtcm(41)**2)*shr
26866  DO 460 i=1,mdcy(kc,3)
26867  idc=i+mdcy(kc,2)-1
26868  IF(mdme(idc,1).LT.0) GOTO 460
26869  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26870  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26871  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 460
26872  wid2=1d0
26873  IF(i.EQ.1) THEN
26874 C...nu*_e -> Z0 + nu*_e.
26875  qf=rtcm(43)*xw1/2d0+rtcm(44)*xw/2d0
26876  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26877  & (1d0-rm1)**2*(2d0+rm1)
26878  wid2=wids(23,2)
26879  ELSEIF(i.EQ.2) THEN
26880 C...nu*_e -> W+ + e.
26881  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26882  & (1d0-rm1)**2*(2d0+rm1)
26883  IF(kflr.GT.0) wid2=wids(24,2)
26884  IF(kflr.LT.0) wid2=wids(24,3)
26885  ENDIF
26886  wdtp(i)=fudge*wdtp(i)
26887  wdtp(0)=wdtp(0)+wdtp(i)
26888  IF(mdme(idc,1).GT.0) THEN
26889  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26890  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26891  wdte(i,0)=wdte(i,mdme(idc,1))
26892  wdte(0,0)=wdte(0,0)+wdte(i,0)
26893  ENDIF
26894  460 CONTINUE
26895 
26896  ELSEIF(kfla.EQ.kdimen+39) THEN
26897 C...G* (graviton resonance):
26898  fac=(parp(50)**2/paru(1))*shr
26899  DO 470 i=1,mdcy(kc,3)
26900  idc=i+mdcy(kc,2)-1
26901  IF(mdme(idc,1).LT.0) GOTO 470
26902  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26903  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26904  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 470
26905  wid2=1d0
26906  IF(i.LE.8) THEN
26907 C...G* -> q + qbar
26908  fcof=3d0*radc
26909  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
26910  & pyhfth(sh,sh*rm1,1d0)
26911  wdtp(i)=fac*fcof*sqrt(max(0d0,1d0-4d0*rm1))**3*
26912  & (1d0+8d0*rm1/3d0)/320d0
26913  IF(i.EQ.6) wid2=wids(6,1)
26914  IF(i.EQ.7.OR.i.EQ.8) wid2=wids(i,1)
26915  ELSEIF(i.LE.16) THEN
26916 C...G* -> l+ + l-, nu + nubar
26917  fcof=1d0
26918  wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))**3*
26919  & (1d0+8d0*rm1/3d0)/320d0
26920  IF(i.EQ.15.OR.i.EQ.16) wid2=wids(2+i,1)
26921  ELSEIF(i.EQ.17) THEN
26922 C...G* -> g + g.
26923  wdtp(i)=fac/20d0
26924  ELSEIF(i.EQ.18) THEN
26925 C...G* -> gamma + gamma.
26926  wdtp(i)=fac/160d0
26927  ELSEIF(i.EQ.19) THEN
26928 C...G* -> Z0 + Z0.
26929  wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))*(13d0/12d0+
26930  & 14d0*rm1/3d0+4d0*rm1**2)/160d0
26931  wid2=wids(23,1)
26932  ELSEIF(i.EQ.20) THEN
26933 C...G* -> W+ + W-.
26934  wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))*(13d0/12d0+
26935  & 14d0*rm1/3d0+4d0*rm1**2)/80d0
26936  wid2=wids(24,1)
26937  ENDIF
26938  wdtp(i)=fudge*wdtp(i)
26939  wdtp(0)=wdtp(0)+wdtp(i)
26940  IF(mdme(idc,1).GT.0) THEN
26941  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26942  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26943  wdte(i,0)=wdte(i,mdme(idc,1))
26944  wdte(0,0)=wdte(0,0)+wdte(i,0)
26945  ENDIF
26946  470 CONTINUE
26947 
26948  ELSEIF(kfla.EQ.9900012.OR.kfla.EQ.9900014.OR.kfla.EQ.9900016) THEN
26949 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
26950  pmwr=max(1.001d0*shr,pmas(pycomp(9900024),1))
26951  fac=(aem**2/(768d0*paru(1)*xw**2))*shr**5/pmwr**4
26952  DO 480 i=1,mdcy(kc,3)
26953  idc=i+mdcy(kc,2)-1
26954  IF(mdme(idc,1).LT.0) GOTO 480
26955  pm1=pmas(pycomp(kfdp(idc,1)),1)
26956  pm2=pmas(pycomp(kfdp(idc,2)),1)
26957  pm3=pmas(pycomp(kfdp(idc,3)),1)
26958  IF(pm1+pm2+pm3.GE.shr) GOTO 480
26959  wid2=1d0
26960  IF(i.LE.9) THEN
26961 C...nu_lR -> l- qbar q'
26962  fcof=3d0*radc*vckm((i-1)/3+1,mod(i-1,3)+1)
26963  IF(mod(i,3).EQ.0) wid2=wids(6,2)
26964  ELSEIF(i.LE.18) THEN
26965 C...nu_lR -> l+ q qbar'
26966  fcof=3d0*radc*vckm((i-10)/3+1,mod(i-10,3)+1)
26967  IF(mod(i-9,3).EQ.0) wid2=wids(6,3)
26968  ELSE
26969 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
26970  fcof=1d0
26971  wid2=wids(pycomp(kfdp(idc,3)),2)
26972  ENDIF
26973  x=(pm1+pm2+pm3)/shr
26974  fx=1d0-8d0*x**2+8d0*x**6-x**8-24d0*x**4*log(x)
26975  y=(shr/pmwr)**2
26976  fy=(12d0*(1d0-y)*log(1d0-y)+12d0*y-6d0*y**2-2d0*y**3)/y**4
26977  wdtp(i)=fac*fcof*fx*fy
26978  wdtp(i)=fudge*wdtp(i)
26979  wdtp(0)=wdtp(0)+wdtp(i)
26980  IF(mdme(idc,1).GT.0) THEN
26981  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26982  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26983  wdte(i,0)=wdte(i,mdme(idc,1))
26984  wdte(0,0)=wdte(0,0)+wdte(i,0)
26985  ENDIF
26986  480 CONTINUE
26987 
26988  ELSEIF(kfla.EQ.9900023) THEN
26989 C...Z_R0:
26990  fac=(aem/(48d0*xw*xw1*(1d0-2d0*xw)))*shr
26991  DO 490 i=1,mdcy(kc,3)
26992  idc=i+mdcy(kc,2)-1
26993  IF(mdme(idc,1).LT.0) GOTO 490
26994  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26995  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26996  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 490
26997  wid2=1d0
26998  symmet=1d0
26999  IF(i.LE.6) THEN
27000 C...Z_R0 -> q + qbar
27001  ef=kchg(i,1)/3d0
27002  af=sign(1d0,ef+0.1d0)*(1d0-2d0*xw)
27003  vf=sign(1d0,ef+0.1d0)-4d0*ef*xw
27004  fcof=3d0*radc
27005  IF(i.EQ.6) wid2=wids(6,1)
27006  ELSEIF(i.EQ.7.OR.i.EQ.10.OR.i.EQ.13) THEN
27007 C...Z_R0 -> l+ + l-
27008  af=-(1d0-2d0*xw)
27009  vf=-1d0+4d0*xw
27010  fcof=1d0
27011  ELSEIF(i.EQ.8.OR.i.EQ.11.OR.i.EQ.14) THEN
27012 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27013  af=-2d0*xw
27014  vf=0d0
27015  fcof=1d0
27016  symmet=0.5d0
27017  ELSEIF(i.LE.15) THEN
27018 C...Z0 -> nu_R + nu_R, assumed Majorana.
27019  af=2d0*xw1
27020  vf=0d0
27021  fcof=1d0
27022  wid2=wids(pycomp(kfdp(idc,1)),1)
27023  symmet=0.5d0
27024  ENDIF
27025  wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
27026  & sqrt(max(0d0,1d0-4d0*rm1))*symmet
27027  wdtp(i)=fudge*wdtp(i)
27028  wdtp(0)=wdtp(0)+wdtp(i)
27029  IF(mdme(idc,1).GT.0) THEN
27030  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27031  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27032  wdte(i,0)=wdte(i,mdme(idc,1))
27033  wdte(0,0)=wdte(0,0)+wdte(i,0)
27034  ENDIF
27035  490 CONTINUE
27036 
27037  ELSEIF(kfla.EQ.9900024) THEN
27038 C...W_R+/-:
27039  fac=(aem/(24d0*xw))*shr
27040  DO 500 i=1,mdcy(kc,3)
27041  idc=i+mdcy(kc,2)-1
27042  IF(mdme(idc,1).LT.0) GOTO 500
27043  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27044  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27045  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 500
27046  wid2=1d0
27047  IF(i.LE.9) THEN
27048 C...W_R+/- -> q + qbar'
27049  fcof=3d0*radc*vckm((i-1)/3+1,mod(i-1,3)+1)
27050  IF(kflr.GT.0) THEN
27051  IF(mod(i,3).EQ.0) wid2=wids(6,2)
27052  ELSE
27053  IF(mod(i,3).EQ.0) wid2=wids(6,3)
27054  ENDIF
27055  ELSEIF(i.LE.12) THEN
27056 C...W_R+/- -> l+/- + nu_R
27057  fcof=1d0
27058  ENDIF
27059  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
27060  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27061  wdtp(i)=fudge*wdtp(i)
27062  wdtp(0)=wdtp(0)+wdtp(i)
27063  IF(mdme(idc,1).GT.0) THEN
27064  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27065  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27066  wdte(i,0)=wdte(i,mdme(idc,1))
27067  wdte(0,0)=wdte(0,0)+wdte(i,0)
27068  ENDIF
27069  500 CONTINUE
27070 
27071  ELSEIF(kfla.EQ.9900041) THEN
27072 C...H_L++/--:
27073  fac=(1d0/(8d0*paru(1)))*shr
27074  DO 510 i=1,mdcy(kc,3)
27075  idc=i+mdcy(kc,2)-1
27076  IF(mdme(idc,1).LT.0) GOTO 510
27077  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27078  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27079  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 510
27080  wid2=1d0
27081  IF(i.LE.6) THEN
27082 C...H_L++/-- -> l+/- + l'+/-
27083  fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
27084  & (iabs(kfdp(idc,2))-9)/2)**2
27085  IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
27086  ELSEIF(i.EQ.7) THEN
27087 C...H_L++/-- -> W_L+/- + W_L+/-
27088  fcof=0.5d0*parp(190)**4*parp(192)**2/pmas(24,1)**2*
27089  & (3d0*rm1+0.25d0/rm1-1d0)
27090  wid2=wids(24,4+(1-kfls)/2)
27091  ENDIF
27092  wdtp(i)=fac*fcof*
27093  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27094  wdtp(i)=fudge*wdtp(i)
27095  wdtp(0)=wdtp(0)+wdtp(i)
27096  IF(mdme(idc,1).GT.0) THEN
27097  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27098  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27099  wdte(i,0)=wdte(i,mdme(idc,1))
27100  wdte(0,0)=wdte(0,0)+wdte(i,0)
27101  ENDIF
27102  510 CONTINUE
27103 
27104  ELSEIF(kfla.EQ.9900042) THEN
27105 C...H_R++/--:
27106  fac=(1d0/(8d0*paru(1)))*shr
27107  DO 520 i=1,mdcy(kc,3)
27108  idc=i+mdcy(kc,2)-1
27109  IF(mdme(idc,1).LT.0) GOTO 520
27110  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27111  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27112  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 520
27113  wid2=1d0
27114  IF(i.LE.6) THEN
27115 C...H_R++/-- -> l+/- + l'+/-
27116  fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
27117  & (iabs(kfdp(idc,2))-9)/2)**2
27118  IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
27119  ELSEIF(i.EQ.7) THEN
27120 C...H_R++/-- -> W_R+/- + W_R+/-
27121  fcof=parp(191)**2*(3d0*rm1+0.25d0/rm1-1d0)
27122  wid2=wids(pycomp(9900024),4+(1-kfls)/2)
27123  ENDIF
27124  wdtp(i)=fac*fcof*
27125  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27126  wdtp(i)=fudge*wdtp(i)
27127  wdtp(0)=wdtp(0)+wdtp(i)
27128  IF(mdme(idc,1).GT.0) THEN
27129  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27130  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27131  wdte(i,0)=wdte(i,mdme(idc,1))
27132  wdte(0,0)=wdte(0,0)+wdte(i,0)
27133  ENDIF
27134  520 CONTINUE
27135 
27136  ELSEIF(kfla.EQ.ktechn+115) THEN
27137 C...Techni-a2:
27138 C...Need to update to alpha_rho
27139  alprht=2.16d0*(3d0/itcm(1))*rtcm(47)**2
27140  fac=(alprht/12d0)*shr
27141  facf=(1d0/6d0)*(aem**2/alprht)*shr
27142  sqmz=pmas(23,1)**2
27143  sqmw=pmas(24,1)**2
27144  shp=sh
27145  CALL pywidx(23,shp,wdtpp,wdtep)
27146  gmmz=shr*wdtpp(0)
27147  xwrht=1d0/(4d0*xw*(1d0-xw))
27148  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
27149  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
27150  DO 530 i=1,mdcy(kc,3)
27151  idc=i+mdcy(kc,2)-1
27152  IF(mdme(idc,1).LT.0) GOTO 530
27153  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27154  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27155  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 530
27156  wid2=1d0
27157  pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27158  IF(i.LE.4) THEN
27159  facpv=pcm**2
27160  facpa=pcm**2+1.5d0*rm1
27161  va2=0d0
27162  aa2=0d0
27163 C...a2_tc0 -> W+ + W-
27164  IF(i.EQ.1) THEN
27165  aa2=2d0*rtcm(3)**2/4d0/xw/rtcm(49)**2
27166 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27167  wid2=wids(24,1)
27168 C...a2_tc0 -> W+ + pi_tc- + c.c.
27169  ELSEIF(i.EQ.2.OR.i.EQ.3) THEN
27170  aa2=(1d0-rtcm(3)**2)/4d0/xw/rtcm(49)**2
27171  IF(i.EQ.6) THEN
27172  wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
27173  ELSE
27174  wid2=wids(24,3)*wids(pycomp(ktechn+211),2)
27175  ENDIF
27176  ELSEIF(i.EQ.4) THEN
27177 C...a2_tc0 -> Z0 + pi_tc0'
27178  va2=(1d0-rtcm(4)**2)/4d0/xw/xw1/rtcm(48)**2
27179  wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
27180  ENDIF
27181  wdtp(i)=aem*shr**3*pcm/3d0*(va2*facpv+aa2*facpa)
27182  ELSEIF(i.GE.5.AND.i.LE.10) THEN
27183  facpv=pcm**2*(1d0+rm1+rm2)+3d0*rm1*rm2
27184  facpa=pcm**2*(1d0+rm1+rm2)
27185  va2=0d0
27186  aa2=0d0
27187  IF(i.EQ.5) THEN
27188 C...a_T^0 -> gamma rho_T^0
27189  va2=(2d0*rtcm(2)-1d0)**2/rtcm(50)**4
27190  wid2=wids(pycomp(ktechn+113),2)
27191  ELSEIF(i.EQ.6) THEN
27192 C...a_T^0 -> gamma omega_T
27193  va2=1d0/rtcm(50)**4
27194  wid2=wids(pycomp(ktechn+223),2)
27195  ELSEIF(i.EQ.7.OR.i.EQ.8) THEN
27196 C...a_T^0 -> W^+- rho_T^-+
27197  aa2=.25d0/xw/rtcm(51)**4
27198  IF(i.EQ.7) THEN
27199  wid2=wids(24,2)*wids(pycomp(ktechn+213),3)
27200  ELSE
27201  wid2=wids(24,3)*wids(pycomp(ktechn+213),2)
27202  ENDIF
27203  ELSEIF(i.EQ.9) THEN
27204 C...a_T^0 -> Z^0 rho_T^0
27205  va2=(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(50)**4
27206  wid2=wids(23,2)*wids(pycomp(ktechn+113),2)
27207  ELSEIF(i.EQ.10) THEN
27208 C...a_T^0 -> Z^0 omega_T
27209  va2=.25d0*(1d0-2d0*xw)**2/xw/xw1/rtcm(50)**4
27210  wid2=wids(23,2)*wids(pycomp(ktechn+223),2)
27211  ENDIF
27212  wdtp(i)=aem*shr**5*pcm/12d0*(va2*facpv+aa2*facpa)
27213  ELSE
27214 C...a2_tc0 -> f + fbar.
27215  wid2=1d0
27216  IF(i.LE.18) THEN
27217  ia=i-10
27218  fcof=3d0*radc
27219  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
27220  ELSE
27221  ia=i-8
27222  fcof=1d0
27223  IF(ia.GE.17) wid2=wids(ia,1)
27224  ENDIF
27225  ei=kchg(ia,1)/3d0
27226  ai=sign(1d0,ei+0.1d0)
27227  vi=ai-4d0*ei*xwv
27228  vali=0.5d0*(vi+ai)
27229  vari=0.5d0*(vi-ai)
27230  wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
27231  & ((vali*bwzr)**2+(vali*bwzi)**2+
27232  & (vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
27233  & (vali*bwzr)*(vari*bwzr)+vali*vari*bwzi**2))
27234  ENDIF
27235  wdtp(i)=fudge*wdtp(i)
27236  wdtp(0)=wdtp(0)+wdtp(i)
27237  IF(mdme(idc,1).GT.0) THEN
27238  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27239  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27240  wdte(i,0)=wdte(i,mdme(idc,1))
27241  wdte(0,0)=wdte(0,0)+wdte(i,0)
27242  ENDIF
27243  530 CONTINUE
27244 
27245  ELSEIF(kfla.EQ.ktechn+215) THEN
27246 C...Techni-a2+/-:
27247  alprht=2.16d0*(3d0/itcm(1))*rtcm(47)**2
27248  fac=(alprht/12d0)*shr
27249  sqmz=pmas(23,1)**2
27250  sqmw=pmas(24,1)**2
27251  shp=sh
27252  CALL pywidx(24,shp,wdtpp,wdtep)
27253  gmmw=shr*wdtpp(0)
27254  facf=(1d0/12d0)*(aem**2/alprht)*shr*
27255  & (0.125d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
27256  DO 540 i=1,mdcy(kc,3)
27257  idc=i+mdcy(kc,2)-1
27258  IF(mdme(idc,1).LT.0) GOTO 540
27259  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27260  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27261  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 540
27262  wid2=1d0
27263  pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27264  IF(kflr.GT.0) THEN
27265  ichann=2
27266  ELSE
27267  ichann=3
27268  ENDIF
27269  IF(i.LE.7) THEN
27270  aa2=0
27271  va2=0
27272 C...a2_tc+ -> gamma + W+.
27273  IF(i.EQ.1) THEN
27274  aa2=rtcm(3)**2/rtcm(49)**2
27275  wid2=wids(24,ichann)
27276 C...a2_tc+ -> gamma + pi_tc+.
27277  ELSEIF(i.EQ.2) THEN
27278  aa2=(1d0-rtcm(3)**2)/rtcm(49)**2
27279  wid2=wids(pycomp(ktechn+211),ichann)
27280 C...a2_tc+ -> W+ + Z
27281  ELSEIF(i.EQ.3) THEN
27282  aa2=rtcm(3)**2*(1d0/4d0/xw1 +
27283  & (xw-xw1)**2/4./xw/xw1)/rtcm(49)**2
27284  wid2=wids(24,ichann)*wids(23,2)
27285 C...a2_tc+ -> W+ + pi_tc0.
27286  ELSEIF(i.EQ.4) THEN
27287  aa2=(1d0-rtcm(3)**2)/4d0/xw/rtcm(49)**2
27288  wid2=wids(24,ichann)*wids(pycomp(ktechn+111),2)
27289 C...a2_tc+ -> W+ + pi_tc'0.
27290  ELSEIF(i.EQ.5) THEN
27291  va2=(1d0-rtcm(4)**2)/4d0/xw/rtcm(48)**2
27292  wid2=wids(24,ichann)*wids(pycomp(ktechn+221),2)
27293 C...a2_tc+ -> Z0 + pi_tc+.
27294  ELSEIF(i.EQ.6) THEN
27295  aa2=(1d0-rtcm(3)**2)/4d0/xw/xw1*(1d0-2d0*xw)**2/
27296  & rtcm(49)**2
27297  wid2=wids(23,2)*wids(pycomp(ktechn+211),ichann)
27298  ENDIF
27299  wdtp(i)=aem*pcm*(aa2*(pcm**2+1.5d0*rm1)+pcm**2*va2)
27300  & /3d0*shr**3
27301  ELSEIF(i.LE.10) THEN
27302  facpv=pcm**2*(1d0+rm1+rm2)+3d0*rm1*rm2
27303  facpa=pcm**2*(1d0+rm1+rm2)
27304  va2=0d0
27305  aa2=0d0
27306 C...a2_tc+ -> gamma + rho_tc+
27307  IF(i.EQ.7) THEN
27308  va2=(2d0*rtcm(2)-1d0)**2/rtcm(50)**4
27309  wid2=wids(pycomp(ktechn+213),ichann)
27310 C...a2_tc+ -> W+ + rho_T^0
27311  ELSEIF(i.EQ.8) THEN
27312  aa2=1d0/(4d0*xw)/rtcm(51)**4
27313  wid2=wids(24,ichann)*wids(pycomp(ktechn+113),2)
27314 C...a2_tc+ -> W+ + omega_T
27315  ELSEIF(i.EQ.9) THEN
27316  va2=.25d0/xw/rtcm(50)**4
27317  wid2=wids(24,ichann)*wids(pycomp(ktechn+223),2)
27318 C...a2_tc+ -> Z^0 + rho_T^+
27319  ELSEIF(i.EQ.10) THEN
27320  va2=(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(50)**4
27321  aa2=1d0/(4d0*xw*xw1)/rtcm(51)**4
27322  wid2=wids(23,2)*wids(pycomp(ktechn+213),ichann)
27323  ENDIF
27324  wdtp(i)=aem*shr**5*pcm/12d0*(va2*facpv+aa2*facpa)
27325  ELSE
27326 C...a2_tc+ -> f + fbar'.
27327  ia=i-10
27328  wid2=1d0
27329  IF(ia.LE.16) THEN
27330  fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
27331  IF(kflr.GT.0) THEN
27332  IF(mod(ia,4).EQ.3) wid2=wids(6,2)
27333  IF(mod(ia,4).EQ.0) wid2=wids(8,2)
27334  IF(ia.GE.13) wid2=wid2*wids(7,3)
27335  ELSE
27336  IF(mod(ia,4).EQ.3) wid2=wids(6,3)
27337  IF(mod(ia,4).EQ.0) wid2=wids(8,3)
27338  IF(ia.GE.13) wid2=wid2*wids(7,2)
27339  ENDIF
27340  ELSE
27341  fcof=1d0
27342  IF(kflr.GT.0) THEN
27343  IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
27344  ELSE
27345  IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
27346  ENDIF
27347  ENDIF
27348  wdtp(i)=facf*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
27349  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27350  ENDIF
27351  wdtp(i)=fudge*wdtp(i)
27352  wdtp(0)=wdtp(0)+wdtp(i)
27353  IF(mdme(idc,1).GT.0) THEN
27354  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27355  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27356  wdte(i,0)=wdte(i,mdme(idc,1))
27357  wdte(0,0)=wdte(0,0)+wdte(i,0)
27358  ENDIF
27359  540 CONTINUE
27360 
27361  ENDIF
27362  mint(61)=0
27363  mint(62)=0
27364  mint(63)=0
27365  RETURN
27366  END
27367 
27368 C***********************************************************************
27369 
27370 C...PYOFSH
27371 C...Calculates partial width and differential cross-section maxima
27372 C...of channels/processes not allowed on mass-shell, and selects
27373 C...masses in such channels/processes.
27374 
27375  SUBROUTINE pyofsh(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27376 
27377 C...Double precision and integer declarations.
27378  IMPLICIT DOUBLE PRECISION(a-h, o-z)
27379  IMPLICIT INTEGER(I-N)
27380  INTEGER PYK,PYCHGE,PYCOMP
27381 C...Commonblocks.
27382  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27383  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27384  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
27385  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
27386  common/pypars/mstp(200),parp(200),msti(200),pari(200)
27387  common/pyint1/mint(400),vint(400)
27388  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
27389  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
27390  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
27391  &/pyint2/,/pyint5/
27392 C...Local arrays.
27393  dimension kfd(2),mbw(2),pmd(2),pgd(2),pmg(2),pml(2),pmu(2),
27394  &pmh(2),atl(2),atu(2),ath(2),rmg(2),inx1(100),xpt1(100),
27395  &fpt1(100),inx2(100),xpt2(100),fpt2(100),wdtp(0:400),
27396  &wdte(0:400,0:5)
27397 
27398 C...Find if particles equal, maximum mass, matrix elements, etc.
27399  mint(51)=0
27400  isub=mint(1)
27401  kfd(1)=iabs(kfd1)
27402  kfd(2)=iabs(kfd2)
27403  meql=0
27404  IF(kfd(1).EQ.kfd(2)) meql=1
27405  mlm=0
27406  IF(mofsh.GE.2.AND.meql.EQ.1) mlm=int(1.5d0+pyr(0))
27407  IF(mofsh.LE.2.OR.mofsh.EQ.5) THEN
27408  noff=44
27409  pmmx=pmmo
27410  ELSE
27411  noff=40
27412  pmmx=vint(1)
27413  IF(ckin(2).GT.ckin(1)) pmmx=min(ckin(2),vint(1))
27414  ENDIF
27415  mmed=0
27416  IF((kfmo.EQ.25.OR.kfmo.EQ.35.OR.kfmo.EQ.36).AND.meql.EQ.1.AND.
27417  &(kfd(1).EQ.23.OR.kfd(1).EQ.24)) mmed=1
27418  IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(1).EQ.23.OR.
27419  &kfd(1).EQ.24).AND.(kfd(2).EQ.23.OR.kfd(2).EQ.24)) mmed=2
27420  IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(2).EQ.25.OR.
27421  &kfd(2).EQ.35.OR.kfd(2).EQ.36)) mmed=3
27422  loop=1
27423 
27424 C...Find where Breit-Wigners are required, else select discrete masses.
27425  100 DO 110 i=1,2
27426  kfca=pycomp(kfd(i))
27427  IF(kfca.GT.0) THEN
27428  pmd(i)=pmas(kfca,1)
27429  pgd(i)=pmas(kfca,2)
27430  ELSE
27431  pmd(i)=0d0
27432  pgd(i)=0d0
27433  ENDIF
27434  IF(mstp(42).LE.0.OR.pgd(i).LT.parp(41)) THEN
27435  mbw(i)=0
27436  pmg(i)=pmd(i)
27437  rmg(i)=(pmg(i)/pmmx)**2
27438  ELSE
27439  mbw(i)=1
27440  ENDIF
27441  110 CONTINUE
27442 
27443 C...Find allowed mass range and Breit-Wigner parameters.
27444  DO 120 i=1,2
27445  IF(mofsh.EQ.1.AND.loop.EQ.1.AND.mbw(i).EQ.1) THEN
27446  pml(i)=parp(42)
27447  pmu(i)=pmmx-parp(42)
27448  IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
27449  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
27450  ELSEIF(mbw(i).EQ.1.AND.mofsh.NE.5) THEN
27451  ilm=i
27452  IF(mlm.EQ.2) ilm=3-i
27453  pml(i)=max(ckin(noff+2*ilm-1),parp(42))
27454  IF(mbw(3-i).EQ.0) THEN
27455  pmu(i)=pmmx-pmd(3-i)
27456  ELSE
27457  pmu(i)=pmmx-max(ckin(noff+5-2*ilm),parp(42))
27458  ENDIF
27459  IF(ckin(noff+2*ilm).GT.ckin(noff+2*ilm-1)) pmu(i)=
27460  & min(pmu(i),ckin(noff+2*ilm))
27461  IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
27462  IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
27463  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
27464  IF(mbw(i).EQ.1) THEN
27465  atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27466  atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27467  IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
27468  & pgd(i)))
27469  ENDIF
27470  ELSEIF(mbw(i).EQ.1.AND.mofsh.EQ.5) THEN
27471  ilm=i
27472  IF(mlm.EQ.2) ilm=3-i
27473  pml(i)=max(ckin(48+i),parp(42))
27474  pmu(i)=pmmx-max(ckin(51-i),parp(42))
27475  IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
27476  IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
27477  IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
27478  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
27479  IF(mbw(i).EQ.1) THEN
27480  atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27481  atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27482  IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
27483  & pgd(i)))
27484  ENDIF
27485  ENDIF
27486  120 CONTINUE
27487  IF(mbw(1).LT.0.OR.mbw(2).LT.0.OR.(mbw(1).EQ.0.AND.mbw(2).EQ.0))
27488  &THEN
27489  CALL pyerrm(3,'(PYOFSH:) no allowed decay product masses')
27490  mint(51)=1
27491  RETURN
27492  ENDIF
27493 
27494 C...Calculation of partial width of resonance.
27495  IF(mofsh.EQ.1) THEN
27496 
27497 C..If only one integration, pick that to be the inner.
27498  IF(mbw(1).EQ.0) THEN
27499  pm2=pmd(1)
27500  pmd(1)=pmd(2)
27501  pgd(1)=pgd(2)
27502  pml(1)=pml(2)
27503  pmu(1)=pmu(2)
27504  ELSEIF(mbw(2).EQ.0) THEN
27505  pm2=pmd(2)
27506  ENDIF
27507 
27508 C...Start outer loop of integration.
27509  IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
27510  atl2=atan((pml(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
27511  atu2=atan((pmu(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
27512  npt2=1
27513  xpt2(1)=1d0
27514  inx2(1)=0
27515  fmax2=0d0
27516  ENDIF
27517  130 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
27518  pm2s=pmd(2)**2+pmd(2)*pgd(2)*tan(atl2+xpt2(npt2)*(atu2-atl2))
27519  pm2=min(pmu(2),max(pml(2),sqrt(max(0d0,pm2s))))
27520  ENDIF
27521  rm2=(pm2/pmmx)**2
27522 
27523 C...Start inner loop of integration.
27524  pml1=pml(1)
27525  pmu1=min(pmu(1),pmmx-pm2)
27526  IF(meql.EQ.1) pmu1=min(pmu1,pm2)
27527  atl1=atan((pml1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
27528  atu1=atan((pmu1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
27529  IF(pml1+parj(64).GE.pmu1.OR.atl1+1d-7.GE.atu1) THEN
27530  func2=0d0
27531  GOTO 180
27532  ENDIF
27533  npt1=1
27534  xpt1(1)=1d0
27535  inx1(1)=0
27536  fmax1=0d0
27537  140 pm1s=pmd(1)**2+pmd(1)*pgd(1)*tan(atl1+xpt1(npt1)*(atu1-atl1))
27538  pm1=min(pmu1,max(pml1,sqrt(max(0d0,pm1s))))
27539  rm1=(pm1/pmmx)**2
27540 
27541 C...Evaluate function value - inner loop.
27542  func1=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27543  IF(mmed.EQ.1) func1=func1*((1d0-rm1-rm2)**2+8d0*rm1*rm2)
27544  IF(mmed.EQ.2) func1=func1**3*(1d0+10d0*rm1+10d0*rm2+rm1**2+
27545  & rm2**2+10d0*rm1*rm2)
27546  IF(func1.GT.fmax1) fmax1=func1
27547  fpt1(npt1)=func1
27548 
27549 C...Go to next position in inner loop.
27550  IF(npt1.EQ.1) THEN
27551  npt1=npt1+1
27552  xpt1(npt1)=0d0
27553  inx1(npt1)=1
27554  GOTO 140
27555  ELSEIF(npt1.LE.8) THEN
27556  npt1=npt1+1
27557  IF(npt1.LE.4.OR.npt1.EQ.6) ish1=1
27558  ish1=ish1+1
27559  xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
27560  inx1(npt1)=inx1(ish1)
27561  inx1(ish1)=npt1
27562  GOTO 140
27563  ELSEIF(npt1.LT.100) THEN
27564  isn1=ish1
27565  150 ish1=ish1+1
27566  IF(ish1.GT.npt1) ish1=2
27567  IF(ish1.EQ.isn1) GOTO 160
27568  dfpt1=abs(fpt1(ish1)-fpt1(inx1(ish1)))
27569  IF(dfpt1.LT.parp(43)*fmax1) GOTO 150
27570  npt1=npt1+1
27571  xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
27572  inx1(npt1)=inx1(ish1)
27573  inx1(ish1)=npt1
27574  GOTO 140
27575  ENDIF
27576 
27577 C...Calculate integral over inner loop.
27578  160 fsum1=0d0
27579  DO 170 ipt1=2,npt1
27580  fsum1=fsum1+0.5d0*(fpt1(ipt1)+fpt1(inx1(ipt1)))*
27581  & (xpt1(inx1(ipt1))-xpt1(ipt1))
27582  170 CONTINUE
27583  func2=fsum1*(atu1-atl1)/paru(1)
27584  180 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
27585  IF(func2.GT.fmax2) fmax2=func2
27586  fpt2(npt2)=func2
27587 
27588 C...Go to next position in outer loop.
27589  IF(npt2.EQ.1) THEN
27590  npt2=npt2+1
27591  xpt2(npt2)=0d0
27592  inx2(npt2)=1
27593  GOTO 130
27594  ELSEIF(npt2.LE.8) THEN
27595  npt2=npt2+1
27596  IF(npt2.LE.4.OR.npt2.EQ.6) ish2=1
27597  ish2=ish2+1
27598  xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
27599  inx2(npt2)=inx2(ish2)
27600  inx2(ish2)=npt2
27601  GOTO 130
27602  ELSEIF(npt2.LT.100) THEN
27603  isn2=ish2
27604  190 ish2=ish2+1
27605  IF(ish2.GT.npt2) ish2=2
27606  IF(ish2.EQ.isn2) GOTO 200
27607  dfpt2=abs(fpt2(ish2)-fpt2(inx2(ish2)))
27608  IF(dfpt2.LT.parp(43)*fmax2) GOTO 190
27609  npt2=npt2+1
27610  xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
27611  inx2(npt2)=inx2(ish2)
27612  inx2(ish2)=npt2
27613  GOTO 130
27614  ENDIF
27615 
27616 C...Calculate integral over outer loop.
27617  200 fsum2=0d0
27618  DO 210 ipt2=2,npt2
27619  fsum2=fsum2+0.5d0*(fpt2(ipt2)+fpt2(inx2(ipt2)))*
27620  & (xpt2(inx2(ipt2))-xpt2(ipt2))
27621  210 CONTINUE
27622  fsum2=fsum2*(atu2-atl2)/paru(1)
27623  IF(meql.EQ.1) fsum2=2d0*fsum2
27624  ELSE
27625  fsum2=func2
27626  ENDIF
27627 
27628 C...Save result; second integration for user-selected mass range.
27629  IF(loop.EQ.1) widw=fsum2
27630  wid2=fsum2
27631  IF(loop.EQ.1.AND.(ckin(46).GE.ckin(45).OR.ckin(48).GE.ckin(47)
27632  & .OR.max(ckin(45),ckin(47)).GE.1.01d0*parp(42))) THEN
27633  loop=2
27634  GOTO 100
27635  ENDIF
27636  ret1=widw
27637  ret2=wid2/widw
27638 
27639 C...Select two decay product masses of a resonance.
27640  ELSEIF(mofsh.EQ.2.OR.mofsh.EQ.5) THEN
27641  220 DO 230 i=1,2
27642  IF(mbw(i).EQ.0) GOTO 230
27643  pmbw=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*
27644  & (atu(i)-atl(i)))
27645  pmg(i)=min(pmu(i),max(pml(i),sqrt(max(0d0,pmbw))))
27646  rmg(i)=(pmg(i)/pmmx)**2
27647  230 CONTINUE
27648  IF((meql.EQ.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
27649  & pmg(1)+pmg(2)+parj(64).GT.pmmx) GOTO 220
27650 
27651 C...Weight with matrix element (if none known, use beta factor).
27652  flam=sqrt(max(0d0,(1d0-rmg(1)-rmg(2))**2-4d0*rmg(1)*rmg(2)))
27653  IF(mmed.EQ.1) THEN
27654  wtbe=flam*((1d0-rmg(1)-rmg(2))**2+8d0*rmg(1)*rmg(2))
27655  ELSEIF(mmed.EQ.2) THEN
27656  wtbe=flam**3*(1d0+10d0*rmg(1)+10d0*rmg(2)+rmg(1)**2+
27657  & rmg(2)**2+10d0*rmg(1)*rmg(2))
27658  ELSEIF(mmed.EQ.3) THEN
27659  wtbe=flam*(rmg(1)+flam**2/12d0)
27660  ELSE
27661  wtbe=flam
27662  ENDIF
27663  IF(wtbe.LT.pyr(0)) GOTO 220
27664  ret1=pmg(1)
27665  ret2=pmg(2)
27666 
27667 C...Find suitable set of masses for initialization of 2 -> 2 processes.
27668  ELSEIF(mofsh.EQ.3) THEN
27669  IF(mbw(1).NE.0.AND.mbw(2).EQ.0) THEN
27670  pmg(1)=min(pmd(1),0.5d0*(pml(1)+pmu(1)))
27671  pmg(2)=pmd(2)
27672  ELSEIF(mbw(2).NE.0.AND.mbw(1).EQ.0) THEN
27673  pmg(1)=pmd(1)
27674  pmg(2)=min(pmd(2),0.5d0*(pml(2)+pmu(2)))
27675  ELSE
27676  idiv=-1
27677  240 idiv=idiv+1
27678  pmg(1)=min(pmd(1),0.1d0*(idiv*pml(1)+(10-idiv)*pmu(1)))
27679  pmg(2)=min(pmd(2),0.1d0*(idiv*pml(2)+(10-idiv)*pmu(2)))
27680  IF(idiv.LE.9.AND.pmg(1)+pmg(2).GT.0.9d0*pmmx) GOTO 240
27681  ENDIF
27682  ret1=pmg(1)
27683  ret2=pmg(2)
27684 
27685 C...Evaluate importance of excluded tails of Breit-Wigners.
27686  IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
27687  & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
27688  IF(meql.LE.1) THEN
27689  vint(80)=1d0
27690  DO 250 i=1,2
27691  IF(mbw(i).NE.0) vint(80)=vint(80)*1.25d0*(atu(i)-atl(i))/
27692  & paru(1)
27693  250 CONTINUE
27694  ELSE
27695  vint(80)=(1.25d0/paru(1))**2*max((atu(1)-atl(1))*
27696  & (ath(2)-atl(2)),(ath(1)-atl(1))*(atu(2)-atl(2)))
27697  ENDIF
27698  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.30.OR.isub.EQ.35).AND.
27699  & mstp(43).NE.2) vint(80)=2d0*vint(80)
27700  IF(isub.EQ.22.AND.mstp(43).NE.2) vint(80)=4d0*vint(80)
27701  IF(meql.GE.1) vint(80)=2d0*vint(80)
27702 
27703 C...Pick one particle to be the lighter (if improves efficiency).
27704  ELSEIF(mofsh.EQ.4) THEN
27705  IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
27706  & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
27707  260 IF(meql.EQ.2) mlm=int(1.5d0+pyr(0))
27708 
27709 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27710  DO 270 i=1,2
27711  IF(mbw(i).EQ.0) GOTO 270
27712  pmv=pmu(i)
27713  IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
27714  atv=atu(i)
27715  IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
27716  rbr=pyr(0)
27717  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
27718  & isub.EQ.35).AND.mstp(43).NE.2) rbr=2d0*rbr
27719  IF(rbr.LT.0.8d0) THEN
27720  pmsr=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*(atv-atl(i)))
27721  pmg(i)=min(pmv,max(pml(i),sqrt(max(0d0,pmsr))))
27722  ELSEIF(rbr.LT.0.9d0) THEN
27723  pmg(i)=sqrt(max(0d0,pml(i)**2+pyr(0)*(pmv**2-pml(i)**2)))
27724  ELSEIF(rbr.LT.1.5d0) THEN
27725  pmg(i)=pml(i)*(pmv/pml(i))**pyr(0)
27726  ELSE
27727  pmg(i)=sqrt(max(0d0,pml(i)**2*pmv**2/(pml(i)**2+pyr(0)*
27728  & (pmv**2-pml(i)**2))))
27729  ENDIF
27730  270 CONTINUE
27731  IF((meql.GE.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
27732  & pmg(1)+pmg(2)+parj(64).GT.pmmx) THEN
27733  IF(mint(48).EQ.1.AND.mstp(171).EQ.0) THEN
27734  ngen(0,1)=ngen(0,1)+1
27735  ngen(mint(1),1)=ngen(mint(1),1)+1
27736  GOTO 260
27737  ELSE
27738  mint(51)=1
27739  RETURN
27740  ENDIF
27741  ENDIF
27742  ret1=pmg(1)
27743  ret2=pmg(2)
27744 
27745 C...Give weight for selected mass distribution.
27746  vint(80)=1d0
27747  DO 280 i=1,2
27748  IF(mbw(i).EQ.0) GOTO 280
27749  pmv=pmu(i)
27750  IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
27751  atv=atu(i)
27752  IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
27753  f0=pmd(i)*pgd(i)/((pmg(i)**2-pmd(i)**2)**2+
27754  & (pmd(i)*pgd(i))**2)/paru(1)
27755  f1=1d0
27756  f2=1d0/pmg(i)**2
27757  f3=1d0/pmg(i)**4
27758  fi0=(atv-atl(i))/paru(1)
27759  fi1=pmv**2-pml(i)**2
27760  fi2=2d0*log(pmv/pml(i))
27761  fi3=1d0/pml(i)**2-1d0/pmv**2
27762  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
27763  & isub.EQ.35).AND.mstp(43).NE.2) THEN
27764  vint(80)=vint(80)*20d0/(8d0+(fi0/f0)*(f1/fi1+6d0*f2/fi2+
27765  & 5d0*f3/fi3))
27766  ELSE
27767  vint(80)=vint(80)*10d0/(8d0+(fi0/f0)*(f1/fi1+f2/fi2))
27768  ENDIF
27769  vint(80)=vint(80)*fi0
27770  280 CONTINUE
27771  IF(meql.GE.1) vint(80)=2d0*vint(80)
27772  ENDIF
27773 
27774  RETURN
27775  END
27776 
27777 C***********************************************************************
27778 
27779 C...PYRECO
27780 C...Handles the possibility of colour reconnection in W+W- events,
27781 C...Based on the main scenarios of the Sjostrand and Khoze study:
27782 C...I, II, II', intermediate and instantaneous; plus one model
27783 C...along the lines of the Gustafson and Hakkinen: GH.
27784 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27785 C...is as if first resonance is W+ and second W-.
27786 
27787  SUBROUTINE pyreco(IW1,IW2,NSD1,NAFT1)
27788 
27789 C...Double precision and integer declarations.
27790  IMPLICIT DOUBLE PRECISION(a-h, o-z)
27791  IMPLICIT INTEGER(I-N)
27792  INTEGER PYK,PYCHGE,PYCOMP
27793 C...Parameter value; number of points in MC integration.
27794  parameter(npt=100)
27795 C...Commonblocks.
27796  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
27797  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27798  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27799  common/pypars/mstp(200),parp(200),msti(200),pari(200)
27800  common/pyint1/mint(400),vint(400)
27801  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
27802 C...Local arrays.
27803  dimension nbeg(2),nend(2),inp(50),inm(50),beww(3),xp(3),xm(3),
27804  &v1(3),v2(3),betp(50,4),dirp(50,3),betm(50,4),dirm(50,3),
27805  &xd(4),xb(4),iap(npt),iam(npt),wta(npt),v1p(3),v2p(3),v1m(3),
27806  &v2m(3),q(4,3),xpp(3),xmm(3),ipc(20),imc(20),tc(0:20),tpc(20),
27807  &tmc(20),ijoin(100)
27808 
27809 C...Functions to give four-product and to do determinants.
27810  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)
27811  deter(i,j,l)=q(i,1)*q(j,2)*q(l,3)-q(i,1)*q(l,2)*q(j,3)+
27812  &q(j,1)*q(l,2)*q(i,3)-q(j,1)*q(i,2)*q(l,3)+
27813  &q(l,1)*q(i,2)*q(j,3)-q(l,1)*q(j,2)*q(i,3)
27814 
27815 C...Only allow fraction of recoupling for GH, intermediate and
27816 C...instantaneous.
27817  IF(mstp(115).EQ.5.OR.mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
27818  IF(pyr(0).GT.parp(120)) RETURN
27819  ENDIF
27820  isub=mint(1)
27821 
27822 C...Common part for scenarios I, II, II', and GH.
27823  IF(mstp(115).EQ.1.OR.mstp(115).EQ.2.OR.mstp(115).EQ.3.OR.
27824  &mstp(115).EQ.5) THEN
27825 
27826 C...Read out frequently-used parameters.
27827  pi=paru(1)
27828  hbar=paru(3)
27829  pmw=pmas(24,1)
27830  IF(isub.EQ.22) pmw=pmas(23,1)
27831  pgw=pmas(24,2)
27832  IF(isub.EQ.22) pgw=pmas(23,2)
27833  tfrag=parp(115)
27834  rhad=parp(116)
27835  fact=parp(117)
27836  blowr=parp(118)
27837  blowt=parp(119)
27838 
27839 C...Find range of decay products of the W's.
27840 C...Background: the W's are stored in IW1 and IW2.
27841 C...Their direct decay products in NSD1+1 through NSD1+4.
27842 C...Products after shower (if any) in NSD1+5 through NAFT1
27843 C...for first W and in NAFT1+1 through N for the second.
27844  IF(naft1.GT.nsd1+4) THEN
27845  nbeg(1)=nsd1+5
27846  nend(1)=naft1
27847  ELSE
27848  nbeg(1)=nsd1+1
27849  nend(1)=nsd1+2
27850  ENDIF
27851  IF(n.GT.naft1) THEN
27852  nbeg(2)=naft1+1
27853  nend(2)=n
27854  ELSE
27855  nbeg(2)=nsd1+3
27856  nend(2)=nsd1+4
27857  ENDIF
27858 
27859 C...Rearrange parton shower products along strings.
27860  nold=n
27861  CALL pyprep(nsd1+1)
27862  IF(mint(51).NE.0) RETURN
27863 
27864 C...Find partons pointing back to W+ and W-; store them with quark
27865 C...end of string first.
27866  nnp=0
27867  nnm=0
27868  isgp=0
27869  isgm=0
27870  DO 120 i=nold+1,n
27871  IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 120
27872  IF(iabs(k(i,2)).GE.22) GOTO 120
27873  IF(k(i,3).GE.nbeg(1).AND.k(i,3).LE.nend(1)) THEN
27874  IF(isgp.EQ.0) isgp=isign(1,k(i,2))
27875  nnp=nnp+1
27876  IF(isgp.EQ.1) THEN
27877  inp(nnp)=i
27878  ELSE
27879  DO 100 i1=nnp,2,-1
27880  inp(i1)=inp(i1-1)
27881  100 CONTINUE
27882  inp(1)=i
27883  ENDIF
27884  IF(k(i,1).EQ.1) isgp=0
27885  ELSEIF(k(i,3).GE.nbeg(2).AND.k(i,3).LE.nend(2)) THEN
27886  IF(isgm.EQ.0) isgm=isign(1,k(i,2))
27887  nnm=nnm+1
27888  IF(isgm.EQ.1) THEN
27889  inm(nnm)=i
27890  ELSE
27891  DO 110 i1=nnm,2,-1
27892  inm(i1)=inm(i1-1)
27893  110 CONTINUE
27894  inm(1)=i
27895  ENDIF
27896  IF(k(i,1).EQ.1) isgm=0
27897  ENDIF
27898  120 CONTINUE
27899 
27900 C...Boost to W+W- rest frame (not strictly needed).
27901  DO 130 j=1,3
27902  beww(j)=(p(iw1,j)+p(iw2,j))/(p(iw1,4)+p(iw2,4))
27903  130 CONTINUE
27904  CALL pyrobo(iw1,iw1,0d0,0d0,-beww(1),-beww(2),-beww(3))
27905  CALL pyrobo(iw2,iw2,0d0,0d0,-beww(1),-beww(2),-beww(3))
27906  CALL pyrobo(nold+1,n,0d0,0d0,-beww(1),-beww(2),-beww(3))
27907 
27908 C...Select decay vertices of W+ and W-.
27909  tp=hbar*(-log(pyr(0)))*p(iw1,4)/
27910  & sqrt((p(iw1,5)**2-pmw**2)**2+(p(iw1,5)**2*pgw/pmw)**2)
27911  tm=hbar*(-log(pyr(0)))*p(iw2,4)/
27912  & sqrt((p(iw2,5)**2-pmw**2)**2+(p(iw2,5)**2*pgw/pmw)**2)
27913  gtmax=max(tp,tm)
27914  DO 140 j=1,3
27915  xp(j)=tp*p(iw1,j)/p(iw1,4)
27916  xm(j)=tm*p(iw2,j)/p(iw2,4)
27917  140 CONTINUE
27918 
27919 C...Begin scenario I specifics.
27920  IF(mstp(115).EQ.1) THEN
27921 
27922 C...Reconstruct velocity and direction of W+ string pieces.
27923  DO 170 iip=1,nnp-1
27924  IF(k(inp(iip),2).LT.0) GOTO 170
27925  i1=inp(iip)
27926  i2=inp(iip+1)
27927  p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
27928  p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
27929  DO 150 j=1,3
27930  v1(j)=p(i1,j)/p1a
27931  v2(j)=p(i2,j)/p2a
27932  betp(iip,j)=0.5d0*(v1(j)+v2(j))
27933  dirp(iip,j)=v1(j)-v2(j)
27934  150 CONTINUE
27935  betp(iip,4)=1d0/sqrt(1d0-betp(iip,1)**2-betp(iip,2)**2-
27936  & betp(iip,3)**2)
27937  dirl=sqrt(dirp(iip,1)**2+dirp(iip,2)**2+dirp(iip,3)**2)
27938  DO 160 j=1,3
27939  dirp(iip,j)=dirp(iip,j)/dirl
27940  160 CONTINUE
27941  170 CONTINUE
27942 
27943 C...Reconstruct velocity and direction of W- string pieces.
27944  DO 200 iim=1,nnm-1
27945  IF(k(inm(iim),2).LT.0) GOTO 200
27946  i1=inm(iim)
27947  i2=inm(iim+1)
27948  p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
27949  p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
27950  DO 180 j=1,3
27951  v1(j)=p(i1,j)/p1a
27952  v2(j)=p(i2,j)/p2a
27953  betm(iim,j)=0.5d0*(v1(j)+v2(j))
27954  dirm(iim,j)=v1(j)-v2(j)
27955  180 CONTINUE
27956  betm(iim,4)=1d0/sqrt(1d0-betm(iim,1)**2-betm(iim,2)**2-
27957  & betm(iim,3)**2)
27958  dirl=sqrt(dirm(iim,1)**2+dirm(iim,2)**2+dirm(iim,3)**2)
27959  DO 190 j=1,3
27960  dirm(iim,j)=dirm(iim,j)/dirl
27961  190 CONTINUE
27962  200 CONTINUE
27963 
27964 C...Loop over number of space-time points.
27965  nacc=0
27966  sum=0d0
27967  DO 250 ipt=1,npt
27968 
27969 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
27970  r=sqrt(-log(pyr(0)))
27971  phi=2d0*pi*pyr(0)
27972  x=blowr*rhad*r*cos(phi)
27973  y=blowr*rhad*r*sin(phi)
27974  r=sqrt(-log(pyr(0)))
27975  phi=2d0*pi*pyr(0)
27976  z=blowr*rhad*r*cos(phi)
27977  t=gtmax+blowt*sqrt(0.5d0)*tfrag*r*abs(sin(phi))
27978 
27979 C...Reject impossible points. Weight for sample distribution.
27980  IF(t**2-x**2-y**2-z**2.LT.0d0) GOTO 250
27981  wtsmp=exp(-(x**2+y**2+z**2)/(blowr*rhad)**2)*
27982  & exp(-2d0*(t-gtmax)**2/(blowt*tfrag)**2)
27983 
27984 C...Loop over W+ string pieces and find one with largest weight.
27985  imaxp=0
27986  wtmaxp=1d-10
27987  xd(1)=x-xp(1)
27988  xd(2)=y-xp(2)
27989  xd(3)=z-xp(3)
27990  xd(4)=t-tp
27991  DO 220 iip=1,nnp-1
27992  IF(k(inp(iip),2).LT.0) GOTO 220
27993  bed=betp(iip,1)*xd(1)+betp(iip,2)*xd(2)+betp(iip,3)*xd(3)
27994  bedg=betp(iip,4)*(betp(iip,4)*bed/(1d0+betp(iip,4))-xd(4))
27995  DO 210 j=1,3
27996  xb(j)=xd(j)+bedg*betp(iip,j)
27997  210 CONTINUE
27998  xb(4)=betp(iip,4)*(xd(4)-bed)
27999  sr2=xb(1)**2+xb(2)**2+xb(3)**2
28000  sz2=(dirp(iip,1)*xb(1)+dirp(iip,2)*xb(2)+
28001  & dirp(iip,3)*xb(3))**2
28002  wtp=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
28003  & tfrag**2)
28004  IF(xb(4)-sqrt(sr2).LT.0d0) wtp=0d0
28005  IF(wtp.GT.wtmaxp) THEN
28006  imaxp=iip
28007  wtmaxp=wtp
28008  ENDIF
28009  220 CONTINUE
28010 
28011 C...Loop over W- string pieces and find one with largest weight.
28012  imaxm=0
28013  wtmaxm=1d-10
28014  xd(1)=x-xm(1)
28015  xd(2)=y-xm(2)
28016  xd(3)=z-xm(3)
28017  xd(4)=t-tm
28018  DO 240 iim=1,nnm-1
28019  IF(k(inm(iim),2).LT.0) GOTO 240
28020  bed=betm(iim,1)*xd(1)+betm(iim,2)*xd(2)+betm(iim,3)*xd(3)
28021  bedg=betm(iim,4)*(betm(iim,4)*bed/(1d0+betm(iim,4))-xd(4))
28022  DO 230 j=1,3
28023  xb(j)=xd(j)+bedg*betm(iim,j)
28024  230 CONTINUE
28025  xb(4)=betm(iim,4)*(xd(4)-bed)
28026  sr2=xb(1)**2+xb(2)**2+xb(3)**2
28027  sz2=(dirm(iim,1)*xb(1)+dirm(iim,2)*xb(2)+
28028  & dirm(iim,3)*xb(3))**2
28029  wtm=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
28030  & tfrag**2)
28031  IF(xb(4)-sqrt(sr2).LT.0d0) wtm=0d0
28032  IF(wtm.GT.wtmaxm) THEN
28033  imaxm=iim
28034  wtmaxm=wtm
28035  ENDIF
28036  240 CONTINUE
28037 
28038 C...Result of integration.
28039  wt=0d0
28040  IF(imaxp.NE.0.AND.imaxm.NE.0) THEN
28041  wt=wtmaxp*wtmaxm/wtsmp
28042  sum=sum+wt
28043  nacc=nacc+1
28044  iap(nacc)=imaxp
28045  iam(nacc)=imaxm
28046  wta(nacc)=wt
28047  ENDIF
28048  250 CONTINUE
28049  res=blowr**3*blowt*sum/npt
28050 
28051 C...Decide whether to reconnect and, if so, where.
28052  iacc=0
28053  prec=1d0-exp(-fact*res)
28054  IF(prec.GT.pyr(0)) THEN
28055  rsum=pyr(0)*sum
28056  DO 260 ia=1,nacc
28057  iacc=ia
28058  rsum=rsum-wta(ia)
28059  IF(rsum.LE.0d0) GOTO 270
28060  260 CONTINUE
28061  270 iip=iap(iacc)
28062  iim=iam(iacc)
28063  ENDIF
28064 
28065 C...Begin scenario II and II' specifics.
28066  ELSEIF(mstp(115).EQ.2.OR.mstp(115).EQ.3) THEN
28067 
28068 C...Loop through all string pieces, one from W+ and one from W-.
28069  ncross=0
28070  tc(0)=0d0
28071  DO 340 iip=1,nnp-1
28072  IF(k(inp(iip),2).LT.0) GOTO 340
28073  i1p=inp(iip)
28074  i2p=inp(iip+1)
28075  DO 330 iim=1,nnm-1
28076  IF(k(inm(iim),2).LT.0) GOTO 330
28077  i1m=inm(iim)
28078  i2m=inm(iim+1)
28079 
28080 C...Find endpoint velocity vectors.
28081  DO 280 j=1,3
28082  v1p(j)=p(i1p,j)/p(i1p,4)
28083  v2p(j)=p(i2p,j)/p(i2p,4)
28084  v1m(j)=p(i1m,j)/p(i1m,4)
28085  v2m(j)=p(i2m,j)/p(i2m,4)
28086  280 CONTINUE
28087 
28088 C...Define q matrix and find t.
28089  DO 290 j=1,3
28090  q(1,j)=v2p(j)-v1p(j)
28091  q(2,j)=-(v2m(j)-v1m(j))
28092  q(3,j)=xp(j)-xm(j)-tp*v1p(j)+tm*v1m(j)
28093  q(4,j)=v1p(j)-v1m(j)
28094  290 CONTINUE
28095  t=-deter(1,2,3)/deter(1,2,4)
28096 
28097 C...Find alpha and beta; i.e. coordinates of crossing point.
28098  s11=q(1,1)*(t-tp)
28099  s12=q(2,1)*(t-tm)
28100  s13=q(3,1)+q(4,1)*t
28101  s21=q(1,2)*(t-tp)
28102  s22=q(2,2)*(t-tm)
28103  s23=q(3,2)+q(4,2)*t
28104  den=s11*s22-s12*s21
28105  alp=(s12*s23-s22*s13)/den
28106  bet=(s21*s13-s11*s23)/den
28107 
28108 C...Check if solution acceptable.
28109  iansw=1
28110  IF(t.LT.gtmax) iansw=0
28111  IF(alp.LT.0d0.OR.alp.GT.1d0) iansw=0
28112  IF(bet.LT.0d0.OR.bet.GT.1d0) iansw=0
28113 
28114 C...Find point of crossing and check that not inconsistent.
28115  DO 300 j=1,3
28116  xpp(j)=xp(j)+(v1p(j)+alp*(v2p(j)-v1p(j)))*(t-tp)
28117  xmm(j)=xm(j)+(v1m(j)+bet*(v2m(j)-v1m(j)))*(t-tm)
28118  300 CONTINUE
28119  d2pm=(xpp(1)-xmm(1))**2+(xpp(2)-xmm(2))**2+
28120  & (xpp(3)-xmm(3))**2
28121  d2p=xpp(1)**2+xpp(2)**2+xpp(3)**2
28122  d2m=xmm(1)**2+xmm(2)**2+xmm(3)**2
28123  IF(d2pm.GT.1d-4*(d2p+d2m)) iansw=-1
28124 
28125 C...Find string eigentimes at crossing.
28126  IF(iansw.EQ.1) THEN
28127  taup=sqrt(max(0d0,(t-tp)**2-(xpp(1)-xp(1))**2-
28128  & (xpp(2)-xp(2))**2-(xpp(3)-xp(3))**2))
28129  taum=sqrt(max(0d0,(t-tm)**2-(xmm(1)-xm(1))**2-
28130  & (xmm(2)-xm(2))**2-(xmm(3)-xm(3))**2))
28131  ELSE
28132  taup=0d0
28133  taum=0d0
28134  ENDIF
28135 
28136 C...Order crossings by time. End loop over crossings.
28137  IF(iansw.EQ.1.AND.ncross.LT.20) THEN
28138  ncross=ncross+1
28139  DO 310 i1=ncross,1,-1
28140  IF(t.GT.tc(i1-1).OR.i1.EQ.1) THEN
28141  ipc(i1)=iip
28142  imc(i1)=iim
28143  tc(i1)=t
28144  tpc(i1)=taup
28145  tmc(i1)=taum
28146  GOTO 320
28147  ELSE
28148  ipc(i1)=ipc(i1-1)
28149  imc(i1)=imc(i1-1)
28150  tc(i1)=tc(i1-1)
28151  tpc(i1)=tpc(i1-1)
28152  tmc(i1)=tmc(i1-1)
28153  ENDIF
28154  310 CONTINUE
28155  320 CONTINUE
28156  ENDIF
28157  330 CONTINUE
28158  340 CONTINUE
28159 
28160 C...Loop over crossings; find first (if any) acceptable one.
28161  iacc=0
28162  IF(ncross.GE.1) THEN
28163  DO 350 ic=1,ncross
28164  pnfrag=exp(-(tpc(ic)**2+tmc(ic)**2)/tfrag**2)
28165  IF(pnfrag.GT.pyr(0)) THEN
28166 C...Scenario II: only compare with fragmentation time.
28167  IF(mstp(115).EQ.2) THEN
28168  iacc=ic
28169  iip=ipc(iacc)
28170  iim=imc(iacc)
28171  GOTO 360
28172 C...Scenario II': also require that string length decreases.
28173  ELSE
28174  iip=ipc(ic)
28175  iim=imc(ic)
28176  i1p=inp(iip)
28177  i2p=inp(iip+1)
28178  i1m=inm(iim)
28179  i2m=inm(iim+1)
28180  elold=four(i1p,i2p)*four(i1m,i2m)
28181  elnew=four(i1p,i2m)*four(i1m,i2p)
28182  IF(elnew.LT.elold) THEN
28183  iacc=ic
28184  iip=ipc(iacc)
28185  iim=imc(iacc)
28186  GOTO 360
28187  ENDIF
28188  ENDIF
28189  ENDIF
28190  350 CONTINUE
28191  360 CONTINUE
28192  ENDIF
28193 
28194 C...Begin scenario GH specifics.
28195  ELSEIF(mstp(115).EQ.5) THEN
28196 
28197 C...Loop through all string pieces, one from W+ and one from W-.
28198  iacc=0
28199  elmin=1d0
28200  DO 380 iip=1,nnp-1
28201  IF(k(inp(iip),2).LT.0) GOTO 380
28202  i1p=inp(iip)
28203  i2p=inp(iip+1)
28204  DO 370 iim=1,nnm-1
28205  IF(k(inm(iim),2).LT.0) GOTO 370
28206  i1m=inm(iim)
28207  i2m=inm(iim+1)
28208 
28209 C...Look for largest decrease of (exponent of) Lambda measure.
28210  elold=four(i1p,i2p)*four(i1m,i2m)
28211  elnew=four(i1p,i2m)*four(i1m,i2p)
28212  eldif=elnew/max(1d-10,elold)
28213  IF(eldif.LT.elmin) THEN
28214  iacc=iip+iim
28215  elmin=eldif
28216  ipc(1)=iip
28217  imc(1)=iim
28218  ENDIF
28219  370 CONTINUE
28220  380 CONTINUE
28221  iip=ipc(1)
28222  iim=imc(1)
28223  ENDIF
28224 
28225 C...Common for scenarios I, II, II' and GH: reconnect strings.
28226  IF(iacc.NE.0) THEN
28227  mint(32)=1
28228  njoin=0
28229  DO 390 is=1,nnp+nnm
28230  njoin=njoin+1
28231  IF(is.LE.iip) THEN
28232  i=inp(is)
28233  ELSEIF(is.LE.iip+nnm-iim) THEN
28234  i=inm(is-iip+iim)
28235  ELSEIF(is.LE.iip+nnm) THEN
28236  i=inm(is-iip-nnm+iim)
28237  ELSE
28238  i=inp(is-nnm)
28239  ENDIF
28240  ijoin(njoin)=i
28241  IF(k(i,2).LT.0) THEN
28242  CALL pyjoin(njoin,ijoin)
28243  njoin=0
28244  ENDIF
28245  390 CONTINUE
28246 
28247 C...Restore original event record if no reconnection.
28248  ELSE
28249  DO 400 i=nsd1+1,nold
28250  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
28251  k(i,4)=mod(k(i,4),mstu(5)**2)
28252  k(i,5)=mod(k(i,5),mstu(5)**2)
28253  ENDIF
28254  400 CONTINUE
28255  DO 410 i=nold+1,n
28256  k(k(i,3),1)=3
28257  410 CONTINUE
28258  n=nold
28259  ENDIF
28260 
28261 C...Boost back system.
28262  CALL pyrobo(iw1,iw1,0d0,0d0,beww(1),beww(2),beww(3))
28263  CALL pyrobo(iw2,iw2,0d0,0d0,beww(1),beww(2),beww(3))
28264  IF(n.GT.nold) CALL pyrobo(nold+1,n,0d0,0d0,
28265  & beww(1),beww(2),beww(3))
28266 
28267 C...Common part for intermediate and instantaneous scenarios.
28268  ELSEIF(mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
28269  mint(32)=1
28270 
28271 C...Remove old shower products and reset showering ones.
28272  n=nsd1+4
28273  DO 420 i=nsd1+1,nsd1+4
28274  k(i,1)=3
28275  k(i,4)=mod(k(i,4),mstu(5)**2)
28276  k(i,5)=mod(k(i,5),mstu(5)**2)
28277  420 CONTINUE
28278 
28279 C...Identify quark-antiquark pairs.
28280  iq1=nsd1+1
28281  iq2=nsd1+2
28282  iq3=nsd1+3
28283  IF(k(iq1,2)*k(iq3,2).LT.0) iq3=nsd1+4
28284  iq4=2*nsd1+7-iq3
28285 
28286 C...Reconnect strings.
28287  ijoin(1)=iq1
28288  ijoin(2)=iq4
28289  CALL pyjoin(2,ijoin)
28290  ijoin(1)=iq3
28291  ijoin(2)=iq2
28292  CALL pyjoin(2,ijoin)
28293 
28294 C...Do new parton showers in intermediate scenario.
28295  IF(mstp(71).GE.1.AND.mstp(115).EQ.11) THEN
28296  mstj50=mstj(50)
28297  mstj(50)=0
28298  CALL pyshow(iq1,iq2,p(iw1,5))
28299  CALL pyshow(iq3,iq4,p(iw2,5))
28300  mstj(50)=mstj50
28301 
28302 C...Do new parton showers in instantaneous scenario.
28303  ELSEIF(mstp(71).GE.1.AND.mstp(115).EQ.12) THEN
28304  ppm2=(p(iq1,4)+p(iq4,4))**2-(p(iq1,1)+p(iq4,1))**2-
28305  & (p(iq1,2)+p(iq4,2))**2-(p(iq1,3)+p(iq4,3))**2
28306  ppm=sqrt(max(0d0,ppm2))
28307  CALL pyshow(iq1,iq4,ppm)
28308  ppm2=(p(iq3,4)+p(iq2,4))**2-(p(iq3,1)+p(iq2,1))**2-
28309  & (p(iq3,2)+p(iq2,2))**2-(p(iq3,3)+p(iq2,3))**2
28310  ppm=sqrt(max(0d0,ppm2))
28311  CALL pyshow(iq3,iq2,ppm)
28312  ENDIF
28313  ENDIF
28314 
28315  RETURN
28316  END
28317 
28318 C***********************************************************************
28319 
28320 C...PYKLIM
28321 C...Checks generated variables against pre-set kinematical limits;
28322 C...also calculates limits on variables used in generation.
28323 
28324  SUBROUTINE pyklim(ILIM)
28325 
28326 C...Double precision and integer declarations.
28327  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28328  IMPLICIT INTEGER(I-N)
28329  INTEGER PYK,PYCHGE,PYCOMP
28330 C...Commonblocks.
28331  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
28332  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28333  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28334  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
28335  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
28336  common/pypars/mstp(200),parp(200),msti(200),pari(200)
28337  common/pyint1/mint(400),vint(400)
28338  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
28339  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
28340  &/pyint1/,/pyint2/
28341 
28342 C...Common kinematical expressions.
28343  mint(51)=0
28344  isub=mint(1)
28345  istsb=iset(isub)
28346  IF(isub.EQ.96) GOTO 100
28347  sqm3=vint(63)
28348  sqm4=vint(64)
28349  IF(ilim.NE.0) THEN
28350  IF(abs(sqm3).LT.1d-4.AND.abs(sqm4).LT.1d-4) THEN
28351  ckin09=max(ckin(9),ckin(13))
28352  ckin10=min(ckin(10),ckin(14))
28353  ckin11=max(ckin(11),ckin(15))
28354  ckin12=min(ckin(12),ckin(16))
28355  ELSE
28356  ckin09=max(ckin(9),min(0d0,ckin(13)))
28357  ckin10=min(ckin(10),max(0d0,ckin(14)))
28358  ckin11=max(ckin(11),min(0d0,ckin(15)))
28359  ckin12=min(ckin(12),max(0d0,ckin(16)))
28360  ENDIF
28361  ENDIF
28362  IF(ilim.NE.1) THEN
28363  tau=vint(21)
28364  rm3=sqm3/(tau*vint(2))
28365  rm4=sqm4/(tau*vint(2))
28366  be34=sqrt(max(1d-20,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
28367  ENDIF
28368  pthmin=ckin(3)
28369  IF(min(sqm3,sqm4).LT.ckin(6)**2.AND.istsb.NE.1.AND.istsb.NE.3)
28370  &pthmin=max(ckin(3),ckin(5))
28371 
28372  IF(ilim.EQ.0) THEN
28373 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28374 C...pre-set kinematical limits.
28375  yst=vint(22)
28376  cth=vint(23)
28377  taup=vint(26)
28378  taue=tau
28379  IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
28380  x1=sqrt(taue)*exp(yst)
28381  x2=sqrt(taue)*exp(-yst)
28382  xf=x1-x2
28383  IF(mint(47).NE.1) THEN
28384  IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1
28385  IF(ckin(2).GE.0d0.AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1
28386  IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1
28387  IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1
28388  ENDIF
28389  IF(mint(45).NE.1) THEN
28390  IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1
28391  ENDIF
28392  IF(mint(46).NE.1) THEN
28393  IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1
28394  ENDIF
28395  IF(mint(45).EQ.2) THEN
28396  IF(x1.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
28397  ENDIF
28398  IF(mint(46).EQ.2) THEN
28399  IF(x2.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
28400  ENDIF
28401  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
28402  pth=0.5d0*be34*sqrt(tau*vint(2)*max(0d0,1d0-cth**2))
28403  expy3=max(1d-20,(1d0+rm3-rm4+be34*cth)/
28404  & max(1d-20,(1d0+rm3-rm4-be34*cth)))
28405  expy4=max(1d-20,(1d0-rm3+rm4-be34*cth)/
28406  & max(1d-20,(1d0-rm3+rm4+be34*cth)))
28407  y3=yst+0.5d0*log(expy3)
28408  y4=yst+0.5d0*log(expy4)
28409  ylarge=max(y3,y4)
28410  ysmall=min(y3,y4)
28411  etalar=20d0
28412  etasma=-20d0
28413  sth=sqrt(max(0d0,1d0-cth**2))
28414  exsq3=sqrt(max(1d-20,((1d0+rm3-rm4)*cosh(yst)+be34*sinh(yst)*
28415  & cth)**2-4d0*rm3))
28416  exsq4=sqrt(max(1d-20,((1d0-rm3+rm4)*cosh(yst)-be34*sinh(yst)*
28417  & cth)**2-4d0*rm4))
28418  IF(sth.GE.1d-10) THEN
28419  expet3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+exsq3)/
28420  & (be34*sth)
28421  expet4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+exsq4)/
28422  & (be34*sth)
28423  eta3=log(min(1d10,max(1d-10,expet3)))
28424  eta4=log(min(1d10,max(1d-10,expet4)))
28425  etalar=max(eta3,eta4)
28426  etasma=min(eta3,eta4)
28427  ENDIF
28428  cts3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/exsq3
28429  cts4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/exsq4
28430  ctslar=min(1d0,max(-1d0,cts3,cts4))
28431  ctssma=max(-1d0,min(1d0,cts3,cts4))
28432  sh=tau*vint(2)
28433  rpts=4d0*vint(71)**2/sh
28434  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
28435  rm34=max(1d-20,2d0*rm3*rm4)
28436  IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
28437  & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
28438  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
28439  tha=0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)
28440  uha=0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
28441  IF(pth.LT.pthmin) mint(51)=1
28442  IF(ckin(4).GE.0d0.AND.pth.GT.ckin(4)) mint(51)=1
28443  IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1
28444  IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1
28445  IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1
28446  IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1
28447  IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1
28448  IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1
28449  IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1
28450  IF(tha.LT.ckin(35)) mint(51)=1
28451  IF(ckin(36).GE.0d0.AND.tha.GT.ckin(36)) mint(51)=1
28452  IF(uha.LT.ckin(37)) mint(51)=1
28453  IF(ckin(38).GE.0d0.AND.uha.GT.ckin(38)) mint(51)=1
28454  ENDIF
28455  IF(istsb.GE.3.AND.istsb.LE.5) THEN
28456  IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1
28457  IF(ckin(32).GE.0d0.AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1
28458  ENDIF
28459 
28460 C...Additional cuts on W2 (approximately) in DIS.
28461  IF(isub.EQ.10.AND.mint(43).GE.2) THEN
28462  xbj=x2
28463  IF(iabs(mint(12)).LT.20) xbj=x1
28464  q2bj=tha
28465  w2bj=q2bj*(1d0-xbj)/xbj
28466  IF(w2bj.LT.ckin(39)) mint(51)=1
28467  IF(ckin(40).GT.0d0.AND.w2bj.GT.ckin(40)) mint(51)=1
28468  ENDIF
28469 
28470  ELSEIF(ilim.EQ.1) THEN
28471 C...Calculate limits on tau
28472 C...0) due to definition
28473  taumn0=0d0
28474  taumx0=1d0
28475 C...1) due to limits on subsystem mass
28476  taumn1=ckin(1)**2/vint(2)
28477  taumx1=1d0
28478  IF(ckin(2).GE.0d0) taumx1=ckin(2)**2/vint(2)
28479 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28480  tm3=sqrt(sqm3+pthmin**2)
28481  tm4=sqrt(sqm4+pthmin**2)
28482  ydcosh=1d0
28483  IF(ckin09.GT.ckin12) ydcosh=cosh(ckin09-ckin12)
28484  taumn2=(tm3**2+2d0*tm3*tm4*ydcosh+tm4**2)/vint(2)
28485  taumx2=1d0
28486 C...3) due to limits on pT-hat and cos(theta-hat)
28487  cth2mn=min(ckin(27)**2,ckin(28)**2)
28488  cth2mx=max(ckin(27)**2,ckin(28)**2)
28489  taumn3=0d0
28490  IF(ckin(27)*ckin(28).GT.0d0) taumn3=
28491  & (sqrt(sqm3+pthmin**2/(1d0-cth2mn))+
28492  & sqrt(sqm4+pthmin**2/(1d0-cth2mn)))**2/vint(2)
28493  taumx3=1d0
28494  IF(ckin(4).GE.0d0.AND.cth2mx.LT.1d0) taumx3=
28495  & (sqrt(sqm3+ckin(4)**2/(1d0-cth2mx))+
28496  & sqrt(sqm4+ckin(4)**2/(1d0-cth2mx)))**2/vint(2)
28497 C...4) due to limits on x1 and x2
28498  taumn4=ckin(21)*ckin(23)
28499  taumx4=ckin(22)*ckin(24)
28500 C...5) due to limits on xF
28501  taumn5=0d0
28502  taumx5=max(1d0-ckin(25),1d0+ckin(26))
28503 C...6) due to limits on that and uhat
28504  taumn6=(sqm3+sqm4+ckin(35)+ckin(37))/vint(2)
28505  taumx6=1d0
28506  IF(ckin(36).GT.0d0.AND.ckin(38).GT.0d0) taumx6=
28507  & (sqm3+sqm4+ckin(36)+ckin(38))/vint(2)
28508 
28509 C...Net effect of all separate limits.
28510  vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5,taumn6)
28511  vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5,taumx6)
28512  IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
28513  vint(11)=1d0-1d-9
28514  vint(31)=1d0+1d-9
28515  ELSEIF(mint(47).EQ.5) THEN
28516  vint(31)=min(vint(31),1d0-2d-10)
28517  ELSEIF(mint(47).GE.6) THEN
28518  vint(31)=min(vint(31),1d0-1d-10)
28519  ENDIF
28520  IF(vint(31).LE.vint(11)) mint(51)=1
28521 
28522  ELSEIF(ilim.EQ.2) THEN
28523 C...Calculate limits on y*
28524  taue=tau
28525  IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
28526  taurt=sqrt(taue)
28527 C...0) due to kinematics
28528  ystmn0=log(taurt)
28529  ystmx0=-ystmn0
28530 C...1) due to explicit limits
28531  ystmn1=ckin(7)
28532  ystmx1=ckin(8)
28533 C...2) due to limits on x1
28534  ystmn2=log(max(taue,ckin(21))/taurt)
28535  ystmx2=log(max(taue,ckin(22))/taurt)
28536 C...3) due to limits on x2
28537  ystmn3=-log(max(taue,ckin(24))/taurt)
28538  ystmx3=-log(max(taue,ckin(23))/taurt)
28539 C...4) due to limits on xF
28540  yepmn4=0.5d0*abs(ckin(25))/taurt
28541  ystmn4=sign(log(max(1d-20,sqrt(1d0+yepmn4**2)+yepmn4)),ckin(25))
28542  yepmx4=0.5d0*abs(ckin(26))/taurt
28543  ystmx4=sign(log(max(1d-20,sqrt(1d0+yepmx4**2)+yepmx4)),ckin(26))
28544 C...5) due to simultaneous limits on y-large and y-small
28545  yepsmn=(rm3-rm4)*sinh(ckin09-ckin11)
28546  yepsmx=(rm3-rm4)*sinh(ckin10-ckin12)
28547  ydifmn=abs(log(max(1d-20,sqrt(1d0+yepsmn**2)-yepsmn)))
28548  ydifmx=abs(log(max(1d-20,sqrt(1d0+yepsmx**2)-yepsmx)))
28549  ystmn5=0.5d0*(ckin09+ckin11-ydifmn)
28550  ystmx5=0.5d0*(ckin10+ckin12+ydifmx)
28551 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28552 C... y-small
28553  cthlim=sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*taue*vint(2))))
28554  rzmn=be34*max(ckin(27),-cthlim)
28555  rzmx=be34*min(ckin(28),cthlim)
28556  yex3mx=(1d0+rm3-rm4+rzmx)/max(1d-10,1d0+rm3-rm4-rzmx)
28557  yex4mx=(1d0+rm4-rm3-rzmn)/max(1d-10,1d0+rm4-rm3+rzmn)
28558  yex3mn=max(1d-10,1d0+rm3-rm4+rzmn)/(1d0+rm3-rm4-rzmn)
28559  yex4mn=max(1d-10,1d0+rm4-rm3-rzmx)/(1d0+rm4-rm3+rzmx)
28560  ystmn6=ckin09-0.5d0*log(max(yex3mx,yex4mx))
28561  ystmx6=ckin12-0.5d0*log(min(yex3mn,yex4mn))
28562 
28563 C...Net effect of all separate limits.
28564  vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)
28565  vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)
28566  IF(mint(47).EQ.1) THEN
28567  vint(12)=-1d-9
28568  vint(32)=1d-9
28569  ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
28570  vint(12)=(1d0-1d-9)*ystmx0
28571  vint(32)=(1d0+1d-9)*ystmx0
28572  ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
28573  vint(12)=-(1d0+1d-9)*ystmx0
28574  vint(32)=-(1d0-1d-9)*ystmx0
28575  ELSEIF(mint(47).EQ.5) THEN
28576  ystee=log((1d0-1d-10)/taurt)
28577  vint(12)=max(vint(12),-ystee)
28578  vint(32)=min(vint(32),ystee)
28579  ENDIF
28580  IF(vint(32).LE.vint(12)) mint(51)=1
28581 
28582  ELSEIF(ilim.EQ.3) THEN
28583 C...Calculate limits on cos(theta-hat)
28584  yst=vint(22)
28585 C...0) due to definition
28586  ctnmn0=-1d0
28587  ctnmx0=0d0
28588  ctpmn0=0d0
28589  ctpmx0=1d0
28590 C...1) due to explicit limits
28591  ctnmn1=min(0d0,ckin(27))
28592  ctnmx1=min(0d0,ckin(28))
28593  ctpmn1=max(0d0,ckin(27))
28594  ctpmx1=max(0d0,ckin(28))
28595 C...2) due to limits on pT-hat
28596  ctnmn2=-sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*tau*vint(2))))
28597  ctpmx2=-ctnmn2
28598  ctnmx2=0d0
28599  ctpmn2=0d0
28600  IF(ckin(4).GE.0d0) THEN
28601  ctnmx2=-sqrt(max(0d0,1d0-4d0*ckin(4)**2/
28602  & (be34**2*tau*vint(2))))
28603  ctpmn2=-ctnmx2
28604  ENDIF
28605 C...3) due to limits on y-large and y-small
28606  ctnmn3=min(0d0,max((1d0+rm3-rm4)/be34*tanh(ckin11-yst),
28607  & -(1d0-rm3+rm4)/be34*tanh(ckin10-yst)))
28608  ctnmx3=min(0d0,(1d0+rm3-rm4)/be34*tanh(ckin12-yst),
28609  & -(1d0-rm3+rm4)/be34*tanh(ckin09-yst))
28610  ctpmn3=max(0d0,(1d0+rm3-rm4)/be34*tanh(ckin09-yst),
28611  & -(1d0-rm3+rm4)/be34*tanh(ckin12-yst))
28612  ctpmx3=max(0d0,min((1d0+rm3-rm4)/be34*tanh(ckin10-yst),
28613  & -(1d0-rm3+rm4)/be34*tanh(ckin11-yst)))
28614 C...4) due to limits on that
28615  ctnmn4=-1d0
28616  ctnmx4=0d0
28617  ctpmn4=0d0
28618  ctpmx4=1d0
28619  sh=tau*vint(2)
28620  IF(ckin(35).GT.0d0) THEN
28621  ctlim=(1d0-rm3-rm4-2d0*ckin(35)/sh)/be34
28622  IF(ctlim.GT.0d0) THEN
28623  ctpmx4=ctlim
28624  ELSE
28625  ctpmx4=0d0
28626  ctnmx4=ctlim
28627  ENDIF
28628  ENDIF
28629  IF(ckin(36).GT.0d0) THEN
28630  ctlim=(1d0-rm3-rm4-2d0*ckin(36)/sh)/be34
28631  IF(ctlim.LT.0d0) THEN
28632  ctnmn4=ctlim
28633  ELSE
28634  ctnmn4=0d0
28635  ctpmn4=ctlim
28636  ENDIF
28637  ENDIF
28638 C...5) due to limits on uhat
28639  ctnmn5=-1d0
28640  ctnmx5=0d0
28641  ctpmn5=0d0
28642  ctpmx5=1d0
28643  IF(ckin(37).GT.0d0) THEN
28644  ctlim=(2d0*ckin(37)/sh-(1d0-rm3-rm4))/be34
28645  IF(ctlim.LT.0d0) THEN
28646  ctnmn5=ctlim
28647  ELSE
28648  ctnmn5=0d0
28649  ctpmn5=ctlim
28650  ENDIF
28651  ENDIF
28652  IF(ckin(38).GT.0d0) THEN
28653  ctlim=(2d0*ckin(38)/sh-(1d0-rm3-rm4))/be34
28654  IF(ctlim.GT.0d0) THEN
28655  ctpmx5=ctlim
28656  ELSE
28657  ctpmx5=0d0
28658  ctnmx5=ctlim
28659  ENDIF
28660  ENDIF
28661 
28662 C...Net effect of all separate limits.
28663  vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3,ctnmn4,ctnmn5)
28664  vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3,ctnmx4,ctnmx5)
28665  vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3,ctpmn4,ctpmn5)
28666  vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3,ctpmx4,ctpmx5)
28667  IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1
28668 
28669  IF(vint(14).GT.vint(34)) vint(34)=vint(14)
28670  IF(vint(13).GT.vint(33)) vint(33)=vint(13)
28671 
28672  ELSEIF(ilim.EQ.4) THEN
28673 C...Calculate limits on tau'
28674 C...0) due to kinematics
28675  tapmn0=tau
28676  IF(istsb.EQ.5.AND.vint(201).GT.0d0) THEN
28677  pqrat=(vint(201)+vint(206))/vint(1)
28678  tapmn0=(sqrt(tau)+pqrat)**2
28679  ENDIF
28680  tapmx0=1d0
28681 C...1) due to explicit limits
28682  tapmn1=ckin(31)**2/vint(2)
28683  tapmx1=1d0
28684  IF(ckin(32).GE.0d0) tapmx1=ckin(32)**2/vint(2)
28685 
28686 C...Net effect of all separate limits.
28687  vint(16)=max(tapmn0,tapmn1)
28688  vint(36)=min(tapmx0,tapmx1)
28689  IF(mint(47).EQ.1) THEN
28690  vint(16)=1d0-1d-9
28691  vint(36)=1d0+1d-9
28692  ELSEIF(mint(47).EQ.5) THEN
28693  vint(36)=min(vint(36),1d0-2d-10)
28694  ELSEIF(mint(47).EQ.6.OR.mint(47).EQ.7) THEN
28695  vint(36)=min(vint(36),1d0-1d-10)
28696  ENDIF
28697  IF(vint(36).LE.vint(16)) mint(51)=1
28698 
28699  ENDIF
28700  RETURN
28701 
28702 C...Special case for low-pT and multiple interactions:
28703 C...effective kinematical limits for tau, y*, cos(theta-hat).
28704  100 IF(ilim.EQ.0) THEN
28705  ELSEIF(ilim.EQ.1) THEN
28706  IF(mstp(82).LE.1) THEN
28707  vint(11)=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
28708  & vint(2)
28709  ELSE
28710  vint(11)=(parp(82)*(vint(1)/parp(89))**parp(90))**2/vint(2)
28711  ENDIF
28712  vint(31)=1d0
28713  ELSEIF(ilim.EQ.2) THEN
28714  vint(12)=0.5d0*log(vint(21))
28715  vint(32)=-vint(12)
28716  ELSEIF(ilim.EQ.3) THEN
28717  IF(mstp(82).LE.1) THEN
28718  st2eff=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
28719  & (vint(21)*vint(2))
28720  ELSE
28721  st2eff=0.01d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
28722  & (vint(21)*vint(2))
28723  ENDIF
28724  vint(13)=-sqrt(max(0d0,1d0-st2eff))
28725  vint(33)=0d0
28726  vint(14)=0d0
28727  vint(34)=-vint(13)
28728  ENDIF
28729 
28730  RETURN
28731  END
28732 
28733 C*********************************************************************
28734 
28735 C...PYKMAP
28736 C...Maps a uniform distribution into a distribution of a kinematical
28737 C...variable according to one of the possibilities allowed. It is
28738 C...assumed that kinematical limits have been set by a PYKLIM call.
28739 
28740  SUBROUTINE pykmap(IVAR,MVAR,VVAR)
28741 
28742 C...Double precision and integer declarations.
28743  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28744  IMPLICIT INTEGER(I-N)
28745  INTEGER PYK,PYCHGE,PYCOMP
28746 C...Commonblocks.
28747  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28748  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28749  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
28750  common/pypars/mstp(200),parp(200),msti(200),pari(200)
28751  common/pyint1/mint(400),vint(400)
28752  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
28753  SAVE /pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,/pyint2/
28754 
28755 C...Convert VVAR to tau variable.
28756  isub=mint(1)
28757  istsb=iset(isub)
28758  IF(ivar.EQ.1) THEN
28759  taumin=vint(11)
28760  taumax=vint(31)
28761  IF(mvar.EQ.3.OR.mvar.EQ.4) THEN
28762  taure=vint(73)
28763  gamre=vint(74)
28764  ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN
28765  taure=vint(75)
28766  gamre=vint(76)
28767  ELSEIF(mvar.EQ.8.OR.mvar.EQ.9) THEN
28768  taure=vint(77)
28769  gamre=vint(78)
28770  ENDIF
28771  IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
28772  tau=1d0
28773  ELSEIF(mvar.EQ.1) THEN
28774  tau=taumin*(taumax/taumin)**vvar
28775  ELSEIF(mvar.EQ.2) THEN
28776  tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)
28777  ELSEIF(mvar.EQ.3.OR.mvar.EQ.5.OR.mvar.EQ.8) THEN
28778  ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax
28779  tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin)
28780  ELSEIF(mvar.EQ.4.OR.mvar.EQ.6.OR.mvar.EQ.9) THEN
28781  aupp=atan((taumax-taure)/gamre)
28782  alow=atan((taumin-taure)/gamre)
28783  tau=taure+gamre*tan(alow+(aupp-alow)*vvar)
28784  ELSEIF(mint(47).EQ.5) THEN
28785  aupp=log(max(2d-10,1d0-taumax))
28786  alow=log(max(2d-10,1d0-taumin))
28787  tau=1d0-exp(aupp+vvar*(alow-aupp))
28788  ELSE
28789  aupp=log(max(1d-10,1d0-taumax))
28790  alow=log(max(1d-10,1d0-taumin))
28791  tau=1d0-exp(aupp+vvar*(alow-aupp))
28792  ENDIF
28793  vint(21)=min(taumax,max(taumin,tau))
28794 
28795 C...Convert VVAR to y* variable.
28796  ELSEIF(ivar.EQ.2) THEN
28797  ystmin=vint(12)
28798  ystmax=vint(32)
28799  taue=vint(21)
28800  IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
28801  IF(mint(47).EQ.1) THEN
28802  yst=0d0
28803  ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
28804  yst=-0.5d0*log(taue)
28805  ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
28806  yst=0.5d0*log(taue)
28807  ELSEIF(mvar.EQ.1) THEN
28808  yst=ystmin+(ystmax-ystmin)*sqrt(vvar)
28809  ELSEIF(mvar.EQ.2) THEN
28810  yst=ystmax-(ystmax-ystmin)*sqrt(1d0-vvar)
28811  ELSEIF(mvar.EQ.3) THEN
28812  aupp=atan(exp(ystmax))
28813  alow=atan(exp(ystmin))
28814  yst=log(tan(alow+(aupp-alow)*vvar))
28815  ELSEIF(mvar.EQ.4) THEN
28816  yst0=-0.5d0*log(taue)
28817  aupp=log(max(1d-10,exp(yst0-ystmin)-1d0))
28818  alow=log(max(1d-10,exp(yst0-ystmax)-1d0))
28819  yst=yst0-log(1d0+exp(alow+vvar*(aupp-alow)))
28820  ELSE
28821  yst0=-0.5d0*log(taue)
28822  aupp=log(max(1d-10,exp(yst0+ystmin)-1d0))
28823  alow=log(max(1d-10,exp(yst0+ystmax)-1d0))
28824  yst=log(1d0+exp(aupp+vvar*(alow-aupp)))-yst0
28825  ENDIF
28826  vint(22)=min(ystmax,max(ystmin,yst))
28827 
28828 C...Convert VVAR to cos(theta-hat) variable.
28829  ELSEIF(ivar.EQ.3) THEN
28830  rm34=max(1d-20,2d0*vint(63)*vint(64)/(vint(21)*vint(2))**2)
28831  rsqm=1d0+rm34
28832  IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
28833  & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
28834  ctnmin=vint(13)
28835  ctnmax=vint(33)
28836  ctpmin=vint(14)
28837  ctpmax=vint(34)
28838  IF(mvar.EQ.1) THEN
28839  aneg=ctnmax-ctnmin
28840  apos=ctpmax-ctpmin
28841  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28842  vctn=vvar*(aneg+apos)/aneg
28843  cth=ctnmin+(ctnmax-ctnmin)*vctn
28844  ELSE
28845  vctp=(vvar*(aneg+apos)-aneg)/apos
28846  cth=ctpmin+(ctpmax-ctpmin)*vctp
28847  ENDIF
28848  ELSEIF(mvar.EQ.2) THEN
28849  rmnmin=max(rm34,rsqm-ctnmin)
28850  rmnmax=max(rm34,rsqm-ctnmax)
28851  rmpmin=max(rm34,rsqm-ctpmin)
28852  rmpmax=max(rm34,rsqm-ctpmax)
28853  aneg=log(rmnmin/rmnmax)
28854  apos=log(rmpmin/rmpmax)
28855  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28856  vctn=vvar*(aneg+apos)/aneg
28857  cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn
28858  ELSE
28859  vctp=(vvar*(aneg+apos)-aneg)/apos
28860  cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp
28861  ENDIF
28862  ELSEIF(mvar.EQ.3) THEN
28863  rmnmin=max(rm34,rsqm+ctnmin)
28864  rmnmax=max(rm34,rsqm+ctnmax)
28865  rmpmin=max(rm34,rsqm+ctpmin)
28866  rmpmax=max(rm34,rsqm+ctpmax)
28867  aneg=log(rmnmax/rmnmin)
28868  apos=log(rmpmax/rmpmin)
28869  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28870  vctn=vvar*(aneg+apos)/aneg
28871  cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm
28872  ELSE
28873  vctp=(vvar*(aneg+apos)-aneg)/apos
28874  cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm
28875  ENDIF
28876  ELSEIF(mvar.EQ.4) THEN
28877  rmnmin=max(rm34,rsqm-ctnmin)
28878  rmnmax=max(rm34,rsqm-ctnmax)
28879  rmpmin=max(rm34,rsqm-ctpmin)
28880  rmpmax=max(rm34,rsqm-ctpmax)
28881  aneg=1d0/rmnmax-1d0/rmnmin
28882  apos=1d0/rmpmax-1d0/rmpmin
28883  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28884  vctn=vvar*(aneg+apos)/aneg
28885  cth=rsqm-1d0/(1d0/rmnmin+aneg*vctn)
28886  ELSE
28887  vctp=(vvar*(aneg+apos)-aneg)/apos
28888  cth=rsqm-1d0/(1d0/rmpmin+apos*vctp)
28889  ENDIF
28890  ELSEIF(mvar.EQ.5) THEN
28891  rmnmin=max(rm34,rsqm+ctnmin)
28892  rmnmax=max(rm34,rsqm+ctnmax)
28893  rmpmin=max(rm34,rsqm+ctpmin)
28894  rmpmax=max(rm34,rsqm+ctpmax)
28895  aneg=1d0/rmnmin-1d0/rmnmax
28896  apos=1d0/rmpmin-1d0/rmpmax
28897  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28898  vctn=vvar*(aneg+apos)/aneg
28899  cth=1d0/(1d0/rmnmin-aneg*vctn)-rsqm
28900  ELSE
28901  vctp=(vvar*(aneg+apos)-aneg)/apos
28902  cth=1d0/(1d0/rmpmin-apos*vctp)-rsqm
28903  ENDIF
28904  ENDIF
28905  IF(cth.LT.0d0) cth=min(ctnmax,max(ctnmin,cth))
28906  IF(cth.GT.0d0) cth=min(ctpmax,max(ctpmin,cth))
28907  vint(23)=cth
28908 
28909 C...Convert VVAR to tau' variable.
28910  ELSEIF(ivar.EQ.4) THEN
28911  tau=vint(21)
28912  taupmn=vint(16)
28913  taupmx=vint(36)
28914  IF(mint(47).EQ.1) THEN
28915  taup=1d0
28916  ELSEIF(mvar.EQ.1) THEN
28917  taup=taupmn*(taupmx/taupmn)**vvar
28918  ELSEIF(mvar.EQ.2) THEN
28919  aupp=(1d0-tau/taupmx)**4
28920  alow=(1d0-tau/taupmn)**4
28921  taup=tau/max(1d-10,1d0-(alow+(aupp-alow)*vvar)**0.25d0)
28922  ELSEIF(mint(47).EQ.5) THEN
28923  aupp=log(max(2d-10,1d0-taupmx))
28924  alow=log(max(2d-10,1d0-taupmn))
28925  taup=1d0-exp(aupp+vvar*(alow-aupp))
28926  ELSE
28927  aupp=log(max(1d-10,1d0-taupmx))
28928  alow=log(max(1d-10,1d0-taupmn))
28929  taup=1d0-exp(aupp+vvar*(alow-aupp))
28930  ENDIF
28931  vint(26)=min(taupmx,max(taupmn,taup))
28932 
28933 C...Selection of extra variables needed in 2 -> 3 process:
28934 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
28935 C...Since no options are available, the functions of PYKLIM
28936 C...and PYKMAP are joint for these choices.
28937  ELSEIF(ivar.EQ.5) THEN
28938 
28939 C...Read out total energy and particle masses.
28940  mint(51)=0
28941  mptpk=1
28942  IF(isub.EQ.123.OR.isub.EQ.124.OR.isub.EQ.173.OR.isub.EQ.174
28943  & .OR.isub.EQ.178.OR.isub.EQ.179.OR.isub.EQ.351.OR.isub.EQ.352)
28944  & mptpk=2
28945  shp=vint(26)*vint(2)
28946  shpr=sqrt(shp)
28947  pm1=vint(201)
28948  pm2=vint(206)
28949  pm3=sqrt(vint(21))*vint(1)
28950  IF(pm1+pm2+pm3.GT.0.9999d0*shpr) THEN
28951  mint(51)=1
28952  RETURN
28953  ENDIF
28954  pmrs1=vint(204)**2
28955  pmrs2=vint(209)**2
28956 
28957 C...Specify coefficients of pT choice; upper and lower limits.
28958  IF(mptpk.EQ.1) THEN
28959  hwt1=0.4d0
28960  hwt2=0.4d0
28961  ELSE
28962  hwt1=0.05d0
28963  hwt2=0.05d0
28964  ENDIF
28965  hwt3=1d0-hwt1-hwt2
28966  ptsmx1=((shp-pm1**2-(pm2+pm3)**2)**2-(2d0*pm1*(pm2+pm3))**2)/
28967  & (4d0*shp)
28968  IF(ckin(52).GT.0d0) ptsmx1=min(ptsmx1,ckin(52)**2)
28969  ptsmn1=ckin(51)**2
28970  ptsmx2=((shp-pm2**2-(pm1+pm3)**2)**2-(2d0*pm2*(pm1+pm3))**2)/
28971  & (4d0*shp)
28972  IF(ckin(54).GT.0d0) ptsmx2=min(ptsmx2,ckin(54)**2)
28973  ptsmn2=ckin(53)**2
28974 
28975 C...Select transverse momenta according to
28976 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
28977  hmx=pmrs1+ptsmx1
28978  hmn=pmrs1+ptsmn1
28979  IF(hmx.LT.1.0001d0*hmn) THEN
28980  mint(51)=1
28981  RETURN
28982  ENDIF
28983  hde=ptsmx1-ptsmn1
28984  rpt=pyr(0)
28985  IF(rpt.LT.hwt1) THEN
28986  pts1=ptsmn1+pyr(0)*hde
28987  ELSEIF(rpt.LT.hwt1+hwt2) THEN
28988  pts1=max(ptsmn1,hmn*(hmx/hmn)**pyr(0)-pmrs1)
28989  ELSE
28990  pts1=max(ptsmn1,hmn*hmx/(hmn+pyr(0)*hde)-pmrs1)
28991  ENDIF
28992  wtpts1=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs1+pts1))+
28993  & hwt3*hmn*hmx/(pmrs1+pts1)**2)
28994  hmx=pmrs2+ptsmx2
28995  hmn=pmrs2+ptsmn2
28996  IF(hmx.LT.1.0001d0*hmn) THEN
28997  mint(51)=1
28998  RETURN
28999  ENDIF
29000  hde=ptsmx2-ptsmn2
29001  rpt=pyr(0)
29002  IF(rpt.LT.hwt1) THEN
29003  pts2=ptsmn2+pyr(0)*hde
29004  ELSEIF(rpt.LT.hwt1+hwt2) THEN
29005  pts2=max(ptsmn2,hmn*(hmx/hmn)**pyr(0)-pmrs2)
29006  ELSE
29007  pts2=max(ptsmn2,hmn*hmx/(hmn+pyr(0)*hde)-pmrs2)
29008  ENDIF
29009  wtpts2=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs2+pts2))+
29010  & hwt3*hmn*hmx/(pmrs2+pts2)**2)
29011 
29012 C...Select azimuthal angles and check pT choice.
29013  phi1=paru(2)*pyr(0)
29014  phi2=paru(2)*pyr(0)
29015  phir=phi2-phi1
29016  pts3=max(0d0,pts1+pts2+2d0*sqrt(pts1*pts2)*cos(phir))
29017  IF(pts3.LT.ckin(55)**2.OR.(ckin(56).GT.0d0.AND.pts3.GT.
29018  & ckin(56)**2)) THEN
29019  mint(51)=1
29020  RETURN
29021  ENDIF
29022 
29023 C...Calculate transverse masses and check phase space not closed.
29024  pms1=pm1**2+pts1
29025  pms2=pm2**2+pts2
29026  pms3=pm3**2+pts3
29027  pmt1=sqrt(pms1)
29028  pmt2=sqrt(pms2)
29029  pmt3=sqrt(pms3)
29030  pm12=(pmt1+pmt2)**2
29031  IF(pmt1+pmt2+pmt3.GT.0.9999d0*shpr) THEN
29032  mint(51)=1
29033  RETURN
29034  ENDIF
29035 
29036 C...Select rapidity for particle 3 and check phase space not closed.
29037  y3max=log((shp+pms3-pm12+sqrt(max(0d0,(shp-pms3-pm12)**2-
29038  & 4d0*pms3*pm12)))/(2d0*shpr*pmt3))
29039  IF(y3max.LT.1d-6) THEN
29040  mint(51)=1
29041  RETURN
29042  ENDIF
29043  y3=(2d0*pyr(0)-1d0)*0.999999d0*y3max
29044  pz3=pmt3*sinh(y3)
29045  pe3=pmt3*cosh(y3)
29046 
29047 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29048  pz12=-pz3
29049  pe12=shpr-pe3
29050  pms12=pe12**2-pz12**2
29051  sql12=sqrt(max(0d0,(pms12-pms1-pms2)**2-4d0*pms1*pms2))
29052  IF(sql12.LT.1d-6*shp) THEN
29053  mint(51)=1
29054  RETURN
29055  ENDIF
29056  pmm1=pms12+pms1-pms2
29057  pmm2=pms12+pms2-pms1
29058  tfac=-shpr/(2d0*pms12)
29059  t1p=tfac*(pe12-pz12)*(pmm1-sql12)
29060  t1n=tfac*(pe12-pz12)*(pmm1+sql12)
29061  t2p=tfac*(pe12+pz12)*(pmm2-sql12)
29062  t2n=tfac*(pe12+pz12)*(pmm2+sql12)
29063 
29064 C...Construct relative mirror weights and make choice.
29065  IF(mptpk.EQ.1.OR.isub.EQ.351.OR.isub.EQ.352) THEN
29066  wtpu=1d0
29067  wtnu=1d0
29068  ELSE
29069  wtpu=1d0/((t1p-pmrs1)*(t2p-pmrs2))**2
29070  wtnu=1d0/((t1n-pmrs1)*(t2n-pmrs2))**2
29071  ENDIF
29072  wtp=wtpu/(wtpu+wtnu)
29073  wtn=wtnu/(wtpu+wtnu)
29074  eps=1d0
29075  IF(wtn.GT.pyr(0)) eps=-1d0
29076 
29077 C...Store result of variable choice and associated weights.
29078  vint(202)=pts1
29079  vint(207)=pts2
29080  vint(203)=phi1
29081  vint(208)=phi2
29082  vint(205)=wtpts1
29083  vint(210)=wtpts2
29084  vint(211)=y3
29085  vint(212)=y3max
29086  vint(213)=eps
29087  IF(eps.GT.0d0) THEN
29088  vint(214)=1d0/wtp
29089  vint(215)=t1p
29090  vint(216)=t2p
29091  ELSE
29092  vint(214)=1d0/wtn
29093  vint(215)=t1n
29094  vint(216)=t2n
29095  ENDIF
29096  vint(217)=-0.5d0*tfac*(pe12-pz12)*(pmm2+eps*sql12)
29097  vint(218)=-0.5d0*tfac*(pe12+pz12)*(pmm1+eps*sql12)
29098  vint(219)=0.5d0*(pms12-pts3)
29099  vint(220)=sql12
29100  ENDIF
29101 
29102  RETURN
29103  END
29104 
29105 C***********************************************************************
29106 
29107 C...PYSIGH
29108 C...Differential matrix elements for all included subprocesses
29109 C...Note that what is coded is (disregarding the COMFAC factor)
29110 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29111 C...when d(sigma-hat) is given in the zero-width limit, the delta
29112 C...function in tau is replaced by a (modified) Breit-Wigner:
29113 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29114 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29115 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29116 C...i.e., dimensionless quantities
29117 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29118 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29119 C...(2pi)^4 delta^4(P - sum p_i)
29120 C...COMFAC contains the factor pi/s (or equivalent) and
29121 C...the conversion factor from GeV^-2 to mb
29122 
29123  SUBROUTINE pysigh(NCHN,SIGS)
29124 
29125 C...Double precision and integer declarations
29126  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29127  IMPLICIT INTEGER(I-N)
29128  INTEGER PYK,PYCHGE,PYCOMP
29129 C...Parameter statement to help give large particle numbers.
29130  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
29131  &kexcit=4000000,kdimen=5000000)
29132 C...Commonblocks
29133  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
29134  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29135  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29136  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
29137  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
29138  common/pypars/mstp(200),parp(200),msti(200),pari(200)
29139  common/pyint1/mint(400),vint(400)
29140  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
29141  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
29142  common/pyint4/mwid(500),wids(500,5)
29143  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
29144  common/pyint7/sigt(0:6,0:6,0:5)
29145  common/pymssm/imss(0:99),rmss(0:99)
29146  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
29147  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
29148  common/pytcsm/itcm(0:99),rtcm(0:99)
29149  common/pypued/iued(0:99),rued(0:99)
29150  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
29151  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
29152  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
29153  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
29154  common/pytcco/coefx(194:380,2)
29155  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
29156  &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,
29157  &/pymssm/,/pyssmt/,/pytcsm/,/pypued/,/pysgcm/,/pytcco/
29158 C...Local arrays and complex variables
29159  dimension xpq(-25:25)
29160 
29161 C...Map of processes onto which routine to call
29162 C...in order to evaluate cross section:
29163 C...0 = not implemented;
29164 C...1 = standard QCD (including photons);
29165 C...2 = heavy flavours;
29166 C...3 = W/Z;
29167 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29168 C...5 = SUSY;
29169 C...6 = Technicolor;
29170 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29171 C...8 = Universal Extra Dimensions
29172  dimension mappr(500)
29173  DATA (mappr(i),i=1,180)/
29174  & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29175  1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29176  2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29177  3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29178  4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29179  5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29180  6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29181  7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29182  8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29183  9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29184  & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29185  1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29186  2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29187  3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29188  4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29189  5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29190  6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29191  7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29192  DATA (mappr(i),i=181,500)/
29193  8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29194  9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29195  & 100*5,
29196  & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29197  & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29198  1 20*0,
29199  4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29200  5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29201  6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29202  7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29203  8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29204  9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29205  & 4, 4, 18*0,
29206  2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29207  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29208  4 20*0,
29209  6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29210  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29211  8 20*0/
29212 
29213 C...Reset number of channels and cross-section
29214  nchn=0
29215  sigs=0d0
29216 
29217 C...Read process to consider.
29218  isub=mint(1)
29219  isubsv=isub
29220  map=mappr(isub)
29221 
29222 C...Read kinematical variables and limits
29223  istsb=iset(isubsv)
29224  taumin=vint(11)
29225  ystmin=vint(12)
29226  ctnmin=vint(13)
29227  ctpmin=vint(14)
29228  taupmn=vint(16)
29229  tau=vint(21)
29230  yst=vint(22)
29231  cth=vint(23)
29232  xt2=vint(25)
29233  taup=vint(26)
29234  taumax=vint(31)
29235  ystmax=vint(32)
29236  ctnmax=vint(33)
29237  ctpmax=vint(34)
29238  taupmx=vint(36)
29239 
29240 C...Derive kinematical quantities
29241  taue=tau
29242  IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
29243  x(1)=sqrt(taue)*exp(yst)
29244  x(2)=sqrt(taue)*exp(-yst)
29245  IF(mint(45).EQ.2.AND.istsb.GE.1) THEN
29246  IF(x(1).GT.1d0-1d-7) RETURN
29247  ELSEIF(mint(45).EQ.3) THEN
29248  x(1)=min(1d0-1.1d-10,x(1))
29249  ENDIF
29250  IF(mint(46).EQ.2.AND.istsb.GE.1) THEN
29251  IF(x(2).GT.1d0-1d-7) RETURN
29252  ELSEIF(mint(46).EQ.3) THEN
29253  x(2)=min(1d0-1.1d-10,x(2))
29254  ENDIF
29255  sh=max(1d0,tau*vint(2))
29256  sqm3=vint(63)
29257  sqm4=vint(64)
29258  rm3=sqm3/sh
29259  rm4=sqm4/sh
29260  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
29261  rpts=4d0*vint(71)**2/sh
29262  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
29263  rm34=max(1d-20,2d0*rm3*rm4)
29264  rsqm=1d0+rm34
29265  IF(2d0*vint(71)**2/max(1d0,vint(21)*vint(2)).LT.0.0001d0)
29266  &rm34=max(rm34,2d0*vint(71)**2/max(1d0,vint(21)*vint(2)))
29267  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
29268  IF(istsb.EQ.0) THEN
29269  th=vint(45)
29270  uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
29271  sqpth=max(vint(71)**2,0.25d0*sh*be34**2*vint(59)**2)
29272  ELSE
29273 C...Kinematics with incoming masses tricky: now depends on how
29274 C...subprocess has been set up w.r.t. order of incoming partons.
29275  rm1=0d0
29276  IF(mint(15).EQ.22.AND.vint(3).LT.0d0) rm1=-vint(3)**2/sh
29277  rm2=0d0
29278  IF(mint(16).EQ.22.AND.vint(4).LT.0d0) rm2=-vint(4)**2/sh
29279  IF(isub.EQ.35) THEN
29280  rm2=min(rm1,rm2)
29281  rm1=0d0
29282  ENDIF
29283  be12=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
29284  tucom=(1d0-rm1-rm2)*(1d0-rm3-rm4)
29285  th=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm4-2d0*rm2*rm3-
29286  & be12*be34*cth)
29287  uh=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm3-2d0*rm2*rm4+
29288  & be12*be34*cth)
29289  sqpth=max(vint(71)**2,0.25d0*sh*be34**2*(1d0-cth**2))
29290  ENDIF
29291  shr=sqrt(sh)
29292  sh2=sh**2
29293  th2=th**2
29294  uh2=uh**2
29295 
29296 C...Choice of Q2 scale for hard process (e.g. alpha_s).
29297  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
29298  q2=sh
29299  ELSEIF(istsb.EQ.8) THEN
29300  IF(mint(107).EQ.4) q2=vint(307)
29301  IF(mint(108).EQ.4) q2=vint(308)
29302  ELSEIF(mod(istsb,2).EQ.0.OR.istsb.EQ.9) THEN
29303  q2in1=0d0
29304  IF(mint(11).EQ.22.AND.vint(3).LT.0d0) q2in1=vint(3)**2
29305  q2in2=0d0
29306  IF(mint(12).EQ.22.AND.vint(4).LT.0d0) q2in2=vint(4)**2
29307  IF(mstp(32).EQ.1) THEN
29308  q2=2d0*sh*th*uh/(sh**2+th**2+uh**2)
29309  ELSEIF(mstp(32).EQ.2) THEN
29310  q2=sqpth+0.5d0*(sqm3+sqm4)
29311  ELSEIF(mstp(32).EQ.3) THEN
29312  q2=min(-th,-uh)
29313  ELSEIF(mstp(32).EQ.4) THEN
29314  q2=sh
29315  ELSEIF(mstp(32).EQ.5) THEN
29316  q2=-th
29317  ELSEIF(mstp(32).EQ.6) THEN
29318  xsf1=x(1)
29319  IF(istsb.EQ.9) xsf1=x(1)/vint(143)
29320  xsf2=x(2)
29321  IF(istsb.EQ.9) xsf2=x(2)/vint(144)
29322  q2=(1d0+xsf1*q2in1/sh+xsf2*q2in2/sh)*
29323  & (sqpth+0.5d0*(sqm3+sqm4))
29324  ELSEIF(mstp(32).EQ.7) THEN
29325  q2=(1d0+q2in1/sh+q2in2/sh)*(sqpth+0.5d0*(sqm3+sqm4))
29326  ELSEIF(mstp(32).EQ.8) THEN
29327  q2=sqpth+0.5d0*(q2in1+q2in2+sqm3+sqm4)
29328  ELSEIF(mstp(32).EQ.9) THEN
29329  q2=sqpth+q2in1+q2in2+sqm3+sqm4
29330  ELSEIF(mstp(32).EQ.10) THEN
29331  q2=vint(2)
29332 C..Begin JA 040914
29333  ELSEIF(mstp(32).EQ.11) THEN
29334  q2=0.25*(sqm3+sqm4+2*sqrt(sqm3*sqm4))
29335  ELSEIF(mstp(32).EQ.12) THEN
29336  q2=parp(193)
29337 C..End JA
29338  ELSEIF(mstp(32).EQ.13) THEN
29339  q2=sqpth
29340  ENDIF
29341  IF(mint(35).LE.2.AND.istsb.EQ.9) q2=sqpth
29342  IF(istsb.EQ.9.AND.mstp(82).GE.2) q2=q2+
29343  & (parp(82)*(vint(1)/parp(89))**parp(90))**2
29344  ENDIF
29345 
29346 C...Choice of Q2 scale for parton densities.
29347  q2sf=q2
29348 C..Begin JA 040914
29349  IF(mstp(32).EQ.12.AND.(mod(istsb,2).EQ.0.OR.istsb.EQ.9)
29350  & .OR.mstp(39).EQ.8.AND.(istsb.GE.3.AND.istsb.LE.5))
29351  & q2=parp(194)
29352 C..End JA
29353  IF(istsb.GE.3.AND.istsb.LE.5) THEN
29354  q2sf=pmas(23,1)**2
29355  IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77.OR.isub.EQ.124.OR.
29356  & isub.EQ.174.OR.isub.EQ.179.OR.isub.EQ.351) q2sf=pmas(24,1)**2
29357  IF(isub.EQ.352) q2sf=pmas(pycomp(9900024),1)**2
29358  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
29359  & isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402) THEN
29360  q2sf=pmas(pycomp(kfpr(isubsv,2)),1)**2
29361  IF(mstp(39).EQ.2) q2sf=
29362  & max(vint(201)**2+vint(202),vint(206)**2+vint(207))
29363  IF(mstp(39).EQ.3) q2sf=sh
29364  IF(mstp(39).EQ.4) q2sf=vint(26)*vint(2)
29365  IF(mstp(39).EQ.5) q2sf=pmas(pycomp(kfpr(isubsv,1)),1)**2
29366 C..Begin JA 040914
29367  IF(mstp(39).EQ.6) q2sf=0.25*(vint(201)+sqrt(sh))**2
29368  IF(mstp(39).EQ.7) q2sf=
29369  & (vint(201)**2+vint(202)+vint(206)**2+vint(207))/2d0
29370  IF(mstp(39).EQ.8) q2sf=parp(193)
29371 C..End JA
29372  ENDIF
29373  ENDIF
29374  IF(mint(35).GE.3.AND.istsb.EQ.9) q2sf=sqpth
29375 
29376  q2ps=q2sf
29377  q2sf=q2sf*parp(34)
29378  IF(mstp(69).GE.1.AND.mint(47).EQ.5) q2sf=vint(2)
29379  IF(mstp(69).GE.2) q2sf=vint(2)
29380 
29381 C...Identify to which class(es) subprocess belongs
29382  ismecr=0
29383  isqcd=0
29384  isjets=0
29385  IF (isubsv.EQ.1.OR.isubsv.EQ.2.OR.isubsv.EQ.3.OR.
29386  & isubsv.EQ.102.OR.isubsv.EQ.141.OR.isubsv.EQ.142.OR.
29387  & isubsv.EQ.144.OR.isubsv.EQ.151.OR.isubsv.EQ.152.OR.
29388  & isubsv.EQ.156.OR.isubsv.EQ.157) ismecr=1
29389  IF (isubsv.EQ.11.OR.isubsv.EQ.12.OR.isubsv.EQ.13.OR.
29390  & isubsv.EQ.28.OR.isubsv.EQ.53.OR.isubsv.EQ.68) isqcd=1
29391  IF ((isubsv.EQ.81.OR.isubsv.EQ.82).AND.mint(55).LE.5) isqcd=1
29392  IF (isubsv.GE.381.AND.isubsv.LE.386) isqcd=1
29393  IF ((isubsv.EQ.387.OR.isubsv.EQ.388).AND.mint(55).LE.5) isqcd=1
29394  IF (istsb.EQ.9) isqcd=1
29395  IF ((isubsv.GE.86.AND.isubsv.LE.89).OR.isubsv.EQ.107.OR.
29396  & (isubsv.GE.14.AND.isubsv.LE.16).OR.(isubsv.GE.29.AND.
29397  & isubsv.LE.32).OR.(isubsv.GE.111.AND.isubsv.LE.113).OR.
29398  & isubsv.EQ.115.OR.(isubsv.GE.183.AND.isubsv.LE.185).OR.
29399  & (isubsv.GE.188.AND.isubsv.LE.190).OR.isubsv.EQ.161.OR.
29400  & isubsv.EQ.167.OR.isubsv.EQ.168.OR.(isubsv.GE.393.AND.
29401  & isubsv.LE.395).OR.(isubsv.GE.421.AND.isubsv.LE.439).OR.
29402  & (isubsv.GE.461.AND.isubsv.LE.479)) isjets=1
29403 C...WBF is special case of ISJETS
29404  IF (isubsv.EQ.5.OR.isubsv.EQ.8.OR.
29405  & (isubsv.GE.71.AND.isubsv.LE.73).OR.
29406  & isubsv.EQ.76.OR.isubsv.EQ.77.OR.
29407  & (isubsv.GE.121.AND.isubsv.LE.124).OR.
29408  & isubsv.EQ.173.OR.isubsv.EQ.174.OR.
29409  & isubsv.EQ.178.OR.isubsv.EQ.179.OR.
29410  & isubsv.EQ.181.OR.isubsv.EQ.182.OR.
29411  & isubsv.EQ.186.OR.isubsv.EQ.187.OR.
29412  & isubsv.EQ.351.OR.isubsv.EQ.352) isjets=2
29413 C...Some processes with photons also belong here.
29414  IF (isubsv.EQ.10.OR.(isubsv.GE.18.AND.isubsv.LE.20).OR.
29415  & (isubsv.GE.33.AND.isubsv.LE.36).OR.isubsv.EQ.54.OR.
29416  & isubsv.EQ.58.OR.isubsv.EQ.69.OR.isubsv.EQ.70.OR.
29417  & isubsv.EQ.80.OR.(isubsv.GE.83.AND.isubsv.LE.85).OR.
29418  & (isubsv.GE.106.AND.isubsv.LE.110).OR.isubsv.EQ.114.OR.
29419  & (isubsv.GE.131.AND.isubsv.LE.140)) isjets=3
29420 
29421 C...Choice of Q2 scale for parton-shower activity.
29422  IF(mstp(22).GE.1.AND.(isub.EQ.10.OR.isub.EQ.83).AND.
29423  &(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
29424  xbj=x(2)
29425  IF(mint(43).EQ.3) xbj=x(1)
29426  IF(mstp(22).EQ.1) THEN
29427  q2ps=-th
29428  ELSEIF(mstp(22).EQ.2) THEN
29429  q2ps=((1d0-xbj)/xbj)*(-th)
29430  ELSEIF(mstp(22).EQ.3) THEN
29431  q2ps=sqrt((1d0-xbj)/xbj)*(-th)
29432  ELSE
29433  q2ps=(1d0-xbj)*max(1d0,-log(xbj))*(-th)
29434  ENDIF
29435  ENDIF
29436 C...For multiple interactions, start from scale defined above
29437 C...For all other QCD or "+jets"-type events, start shower from pThard.
29438  IF (isjets.EQ.1.OR.isqcd.EQ.1.AND.istsb.NE.9) q2ps=sqpth
29439  IF((mstp(68).EQ.1.OR.mstp(68).EQ.3).AND.ismecr.EQ.1) THEN
29440 C...Max shower scale = s for ME corrected processes.
29441 C...(pT-ordering: max pT2 is s/4)
29442  q2ps=vint(2)
29443  IF (mint(35).GE.3) q2ps=q2ps*0.25d0
29444  ELSEIF(mstp(68).GE.2.AND.isqcd.EQ.0.AND.isjets.EQ.0) THEN
29445 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29446 C...(pT-ordering: max pT2 is s/4)
29447  q2ps=vint(2)
29448  IF (mint(35).GE.3) q2ps=q2ps*0.25d0
29449  ENDIF
29450  IF(mint(35).EQ.2.AND.istsb.EQ.9) q2ps=sqpth
29451 
29452 C...Elastic and diffractive events not associated with scales so set 0.
29453  IF(isubsv.GE.91.AND.isubsv.LE.94) THEN
29454  q2sf=0d0
29455  q2ps=0d0
29456  ENDIF
29457 
29458 C...Store derived kinematical quantities
29459  vint(41)=x(1)
29460  vint(42)=x(2)
29461  vint(44)=sh
29462  vint(43)=sqrt(sh)
29463  vint(45)=th
29464  vint(46)=uh
29465  IF(istsb.NE.8) vint(48)=sqpth
29466  IF(istsb.NE.8) vint(47)=sqrt(sqpth)
29467  vint(50)=taup*vint(2)
29468  vint(49)=sqrt(max(0d0,vint(50)))
29469  vint(52)=q2
29470  vint(51)=sqrt(q2)
29471  vint(54)=q2sf
29472  vint(53)=sqrt(q2sf)
29473  vint(56)=q2ps
29474  vint(55)=sqrt(q2ps)
29475 
29476 C...Set starting scale for multiple interactions
29477  IF (isubsv.EQ.95) THEN
29478  xt2gmx=0d0
29479  ELSEIF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isubsv.NE.11.AND.
29480  & isubsv.NE.12.AND.isubsv.NE.13.AND.isubsv.NE.28.AND.
29481  & isubsv.NE.53.AND.isubsv.NE.68.AND.isubsv.NE.95.AND.
29482  & isubsv.NE.96)) THEN
29483 C...All accessible phase space allowed.
29484  xt2gmx=(1d0-vint(41))*(1d0-vint(42))
29485  ELSE
29486 C...Scale of hard process sets limit.
29487 C...2 -> 1. Limit is tau = x1*x2.
29488 C...2 -> 2. Limit is XT2 for hard process + FS masses.
29489 C...2 -> n > 2. Limit is tau' = tau of outer process.
29490  xt2gmx=vint(25)
29491  IF(istsb.EQ.1) xt2gmx=vint(21)
29492  IF(istsb.EQ.2)
29493  & xt2gmx=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
29494  IF(istsb.GE.3.AND.istsb.LE.5) xt2gmx=vint(26)
29495  ENDIF
29496  vint(62)=0.25d0*xt2gmx*vint(2)
29497  vint(61)=sqrt(max(0d0,vint(62)))
29498 
29499 C...Calculate parton distributions
29500  IF(istsb.LE.0) GOTO 160
29501  IF(mint(47).GE.2) THEN
29502  DO 110 i=3-min(2,mint(45)),min(2,mint(46))
29503  xsf=x(i)
29504  IF(istsb.EQ.9) xsf=x(i)/vint(142+i)
29505  IF(isub.EQ.99) THEN
29506  IF(mint(140+i).EQ.0) THEN
29507  xsf=vint(309-i)/(vint(2)+vint(309-i)-vint(i+2)**2)
29508  ELSE
29509  xsf=vint(309-i)/(vint(2)+vint(307)+vint(308))
29510  ENDIF
29511  vint(40+i)=xsf
29512  q2sf=vint(309-i)
29513  ENDIF
29514  mint(105)=mint(102+i)
29515  mint(109)=mint(106+i)
29516  vint(120)=vint(2+i)
29517  IF(mstp(57).LE.1) THEN
29518  CALL pypdfu(mint(10+i),xsf,q2sf,xpq)
29519  ELSE
29520  CALL pypdfl(mint(10+i),xsf,q2sf,xpq)
29521  ENDIF
29522 C...Safety margin against heavy flavour very close to threshold,
29523 C...e.g. caused by mismatch in c and b masses.
29524  IF(q2sf.LT.1.1*pmas(4,1)**2) THEN
29525  xpq(4)=0d0
29526  xpq(-4)=0d0
29527  ENDIF
29528  IF(q2sf.LT.1.1*pmas(5,1)**2) THEN
29529  xpq(5)=0d0
29530  xpq(-5)=0d0
29531  ENDIF
29532  DO 100 kfl=-25,25
29533  xsfx(i,kfl)=xpq(kfl)
29534  100 CONTINUE
29535  110 CONTINUE
29536  ENDIF
29537 
29538 C...Calculate alpha_em, alpha_strong and K-factor
29539  xw=paru(102)
29540  xwv=xw
29541  IF(mstp(8).GE.2.OR.(isub.GE.71.AND.isub.LE.77)) xw=
29542  &1d0-(pmas(24,1)/pmas(23,1))**2
29543  xw1=1d0-xw
29544  xwc=1d0/(16d0*xw*xw1)
29545  aem=pyalem(q2)
29546  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
29547  IF(mstp(33).NE.3) as=pyalps(parp(34)*q2)
29548  fack=1d0
29549  faca=1d0
29550  IF(mstp(33).EQ.1) THEN
29551  fack=parp(31)
29552  ELSEIF(mstp(33).EQ.2) THEN
29553  fack=parp(31)
29554  faca=parp(32)/parp(31)
29555  ELSEIF(mstp(33).EQ.3) THEN
29556  q2as=parp(33)*q2
29557  IF(istsb.EQ.9.AND.mstp(82).GE.2) q2as=q2as+
29558  & paru(112)*parp(82)*(vint(1)/parp(89))**parp(90)
29559  as=pyalps(q2as)
29560  ENDIF
29561  vint(138)=1d0
29562  vint(57)=aem
29563  vint(58)=as
29564 
29565 C...Set flags for allowed reacting partons/leptons
29566  DO 140 i=1,2
29567  DO 120 j=-25,25
29568  kfac(i,j)=0
29569  120 CONTINUE
29570  IF(mint(44+i).EQ.1) THEN
29571  kfac(i,mint(10+i))=1
29572  ELSEIF(mint(40+i).EQ.1.AND.mstp(12).EQ.0) THEN
29573  kfac(i,mint(10+i))=1
29574  kfac(i,22)=1
29575  kfac(i,24)=1
29576  kfac(i,-24)=1
29577  ELSE
29578  DO 130 j=-25,25
29579  kfac(i,j)=kfin(i,j)
29580  IF(iabs(j).GT.mstp(58).AND.iabs(j).LE.10) kfac(i,j)=0
29581  IF(xsfx(i,j).LT.1d-10) kfac(i,j)=0
29582  130 CONTINUE
29583  ENDIF
29584  140 CONTINUE
29585 
29586 C...Lower and upper limit for fermion flavour loops
29587  mmin1=0
29588  mmax1=0
29589  mmin2=0
29590  mmax2=0
29591  DO 150 j=-20,20
29592  IF(kfac(1,-j).EQ.1) mmin1=-j
29593  IF(kfac(1,j).EQ.1) mmax1=j
29594  IF(kfac(2,-j).EQ.1) mmin2=-j
29595  IF(kfac(2,j).EQ.1) mmax2=j
29596  150 CONTINUE
29597  mmina=min(mmin1,mmin2)
29598  mmaxa=max(mmax1,mmax2)
29599 
29600 C...Common resonance mass and width combinations
29601  sqmz=pmas(23,1)**2
29602  sqmw=pmas(24,1)**2
29603  gmmz=pmas(23,1)*pmas(23,2)
29604  gmmw=pmas(24,1)*pmas(24,2)
29605 
29606 C...Polarization factors...implemented so far for W+W-(25)
29607  polr=(1d0+parj(132))*(1d0-parj(131))
29608  poll=(1d0-parj(132))*(1d0+parj(131))
29609  polrr=(1d0+parj(132))*(1d0+parj(131))
29610  polll=(1d0-parj(132))*(1d0-parj(131))
29611 
29612 C...Phase space integral in tau
29613  comfac=paru(1)*paru(5)/vint(2)
29614  IF(mint(41).EQ.2.AND.mint(42).EQ.2) comfac=comfac*fack
29615  IF((mint(47).GE.2.OR.(istsb.GE.3.AND.istsb.LE.5)).AND.
29616  &istsb.NE.8.AND.istsb.NE.9) THEN
29617  atau1=log(taumax/taumin)
29618  atau2=(taumax-taumin)/(taumax*taumin)
29619  h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/tau
29620  IF(mint(72).GE.1) THEN
29621  taur1=vint(73)
29622  gamr1=vint(74)
29623  ataud=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))
29624  atau3=ataud/taur1
29625  IF(ataud.GT.1d-10) h1=h1+
29626  & (atau1/atau3)*coef(isubsv,3)/(tau+taur1)
29627  ataud=atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1)
29628  atau4=ataud/gamr1
29629  IF(ataud.GT.1d-10) h1=h1+
29630  & (atau1/atau4)*coef(isubsv,4)*tau/((tau-taur1)**2+gamr1**2)
29631  ENDIF
29632  IF(mint(72).GE.2) THEN
29633  taur2=vint(75)
29634  gamr2=vint(76)
29635  ataud=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))
29636  atau5=ataud/taur2
29637  IF(ataud.GT.1d-10) h1=h1+
29638  & (atau1/atau5)*coef(isubsv,5)/(tau+taur2)
29639  ataud=atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2)
29640  atau6=ataud/gamr2
29641  IF(ataud.GT.1d-10) h1=h1+
29642  & (atau1/atau6)*coef(isubsv,6)*tau/((tau-taur2)**2+gamr2**2)
29643  ENDIF
29644  IF(mint(72).EQ.3) THEN
29645  taur3=vint(77)
29646  gamr3=vint(78)
29647  ataud=log(taumax/taumin*(taumin+taur3)/(taumax+taur3))
29648  atau50=ataud/taur3
29649  IF(ataud.GT.1d-10) h1=h1+
29650  & (atau1/atau50)*coefx(isubsv,1)/(tau+taur3)
29651  ataud=atan((taumax-taur3)/gamr3)-atan((taumin-taur3)/gamr3)
29652  atau60=ataud/gamr3
29653  IF(ataud.GT.1d-10) h1=h1+
29654  & (atau1/atau60)*coefx(isubsv,2)*tau/((tau-taur3)**2+gamr3**2)
29655  ENDIF
29656  IF(mint(47).EQ.5.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
29657  atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
29658  IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
29659  & max(2d-10,1d0-tau)
29660  ELSEIF(mint(47).GE.6.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
29661  atau7=log(max(1d-10,1d0-taumin)/max(1d-10,1d0-taumax))
29662  IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
29663  & max(1d-10,1d0-tau)
29664  ENDIF
29665  comfac=comfac*atau1/(tau*h1)
29666  ENDIF
29667 
29668 C...Phase space integral in y*
29669  IF((mint(47).EQ.4.OR.mint(47).EQ.5).AND.istsb.NE.8.AND.istsb.NE.9)
29670  &THEN
29671  ayst0=ystmax-ystmin
29672  IF(ayst0.LT.1d-10) THEN
29673  comfac=0d0
29674  ELSE
29675  ayst1=0.5d0*(ystmax-ystmin)**2
29676  ayst2=ayst1
29677  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
29678  h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
29679  & (ayst0/ayst2)*coef(isubsv,9)*(ystmax-yst)+
29680  & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
29681  IF(mint(45).EQ.3) THEN
29682  yst0=-0.5d0*log(taue)
29683  ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
29684  & max(1d-10,exp(yst0-ystmax)-1d0))
29685  IF(ayst4.GT.1d-10) h2=h2+(ayst0/ayst4)*coef(isubsv,11)/
29686  & max(1d-10,1d0-exp(yst-yst0))
29687  ENDIF
29688  IF(mint(46).EQ.3) THEN
29689  yst0=-0.5d0*log(taue)
29690  ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
29691  & max(1d-10,exp(yst0+ystmin)-1d0))
29692  IF(ayst5.GT.1d-10) h2=h2+(ayst0/ayst5)*coef(isubsv,12)/
29693  & max(1d-10,1d0-exp(-yst-yst0))
29694  ENDIF
29695  comfac=comfac*ayst0/h2
29696  ENDIF
29697  ENDIF
29698 
29699 C...2 -> 1 processes: reduction in angular part of phase space integral
29700 C...for case of decaying resonance
29701  acth0=ctnmax-ctnmin+ctpmax-ctpmin
29702  IF((istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5)) THEN
29703  IF(mdcy(pycomp(kfpr(isubsv,1)),1).EQ.1) THEN
29704  IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37.OR.
29705  & kfpr(isub,1).EQ.39) THEN
29706  comfac=comfac*0.5d0*acth0
29707  ELSE
29708  comfac=comfac*0.125d0*(3d0*acth0+ctnmax**3-ctnmin**3+
29709  & ctpmax**3-ctpmin**3)
29710  ENDIF
29711  ENDIF
29712 
29713 C...2 -> 2 processes: angular part of phase space integral
29714  ELSEIF(istsb.EQ.2.OR.istsb.EQ.4) THEN
29715  acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/
29716  & (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))
29717  acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/
29718  & (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))
29719  acth3=1d0/max(rm34,rsqm-ctnmax)-1d0/max(rm34,rsqm-ctnmin)+
29720  & 1d0/max(rm34,rsqm-ctpmax)-1d0/max(rm34,rsqm-ctpmin)
29721  acth4=1d0/max(rm34,rsqm+ctnmin)-1d0/max(rm34,rsqm+ctnmax)+
29722  & 1d0/max(rm34,rsqm+ctpmin)-1d0/max(rm34,rsqm+ctpmax)
29723  h3=coef(isubsv,13)+
29724  & (acth0/acth1)*coef(isubsv,14)/max(rm34,rsqm-cth)+
29725  & (acth0/acth2)*coef(isubsv,15)/max(rm34,rsqm+cth)+
29726  & (acth0/acth3)*coef(isubsv,16)/max(rm34,rsqm-cth)**2+
29727  & (acth0/acth4)*coef(isubsv,17)/max(rm34,rsqm+cth)**2
29728  comfac=comfac*acth0*0.5d0*be34/h3
29729 
29730 C...2 -> 2 processes: take into account final state Breit-Wigners
29731  comfac=comfac*vint(80)
29732  ENDIF
29733 
29734 C...2 -> 3, 4 processes: phace space integral in tau'
29735  IF(mint(47).GE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN
29736  ataup1=log(taupmx/taupmn)
29737  ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
29738  h4=coef(isubsv,18)+
29739  & (ataup1/ataup2)*coef(isubsv,19)*(1d0-tau/taup)**3/taup
29740  IF(mint(47).EQ.5) THEN
29741  ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
29742  h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(2d-10,1d0-taup)
29743  ELSEIF(mint(47).GE.6) THEN
29744  ataup3=log(max(1d-10,1d0-taupmn)/max(1d-10,1d0-taupmx))
29745  h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(1d-10,1d0-taup)
29746  ENDIF
29747  comfac=comfac*ataup1/h4
29748  ENDIF
29749 
29750 C...2 -> 3, 4 processes: effective W/Z parton distributions
29751  IF(istsb.EQ.3.OR.istsb.EQ.4) THEN
29752  IF(1d0-tau/taup.GT.1d-4) THEN
29753  fzw=(1d0+tau/taup)*log(taup/tau)-2d0*(1d0-tau/taup)
29754  ELSE
29755  fzw=1d0/6d0*(1d0-tau/taup)**3*tau/taup
29756  ENDIF
29757  comfac=comfac*fzw
29758  ENDIF
29759 
29760 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29761  IF(istsb.EQ.5) THEN
29762  comfac=comfac*vint(205)*vint(210)*vint(212)*vint(214)/
29763  & (128d0*paru(1)**4*vint(220))*(tau**2/taup)
29764  ENDIF
29765 
29766 C...Phase space integral for low-pT and multiple interactions
29767  IF(istsb.EQ.9) THEN
29768  comfac=paru(1)*paru(5)*fack*0.5d0*vint(2)/sh2
29769  atau1=log(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)
29770  atau2=2d0*atan(1d0/xt2-1d0)/sqrt(xt2)
29771  h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/sqrt(tau)
29772  comfac=comfac*atau1/h1
29773  ayst0=ystmax-ystmin
29774  ayst1=0.5d0*(ystmax-ystmin)**2
29775  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
29776  h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
29777  & (ayst0/ayst1)*coef(isubsv,9)*(ystmax-yst)+
29778  & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
29779  comfac=comfac*ayst0/h2
29780  IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1d0/vint(149)-1d0)
29781 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29782 C...introduced to make cross-section finite for xT2 -> 0
29783  IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*
29784  & (1d0+vint(149)))
29785  ENDIF
29786 
29787 C...Real gamma + gamma: include factor 2 when different nature
29788  160 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
29789  &mstp(14).LE.10) comfac=2d0*comfac
29790 
29791 C...Extra factors to include the effects of
29792 C...longitudinal resolved photons (but not direct or DIS ones).
29793  DO 170 isde=1,2
29794  IF(mint(10+isde).EQ.22.AND.mint(106+isde).GE.1.AND.
29795  & mint(106+isde).LE.3) THEN
29796  vint(314+isde)=1d0
29797  xy=parp(166+isde)
29798  IF(mstp(16).EQ.0) THEN
29799  IF(vint(304+isde).GT.0d0.AND.vint(304+isde).LT.1d0)
29800  & xy=vint(304+isde)
29801  ELSE
29802  IF(vint(308+isde).GT.0d0.AND.vint(308+isde).LT.1d0)
29803  & xy=vint(308+isde)
29804  ENDIF
29805  q2ga=vint(306+isde)
29806  IF(mstp(17).GT.0.AND.xy.GT.0d0.AND.xy.LT.1d0.AND.
29807  & q2ga.GT.0d0) THEN
29808  reduce=0d0
29809  IF(mstp(17).EQ.1) THEN
29810  reduce=4d0*q2*q2ga/(q2+q2ga)**2
29811  ELSEIF(mstp(17).EQ.2) THEN
29812  reduce=4d0*q2ga/(q2+q2ga)
29813  ELSEIF(mstp(17).EQ.3) THEN
29814  pmvirt=pmas(pycomp(113),1)
29815  reduce=4d0*q2ga/(pmvirt**2+q2ga)
29816  ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.1) THEN
29817  pmvirt=pmas(pycomp(113),1)
29818  reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
29819  ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.2) THEN
29820  pmvirt=pmas(pycomp(113),1)
29821  reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
29822  ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.3) THEN
29823  pmvsmn=4d0*parp(15)**2
29824  pmvsmx=4d0*vint(154)**2
29825  redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
29826  redlon=(3d0*pmvsmn+q2ga)/(pmvsmn+q2ga)**3-
29827  & (3d0*pmvsmx+q2ga)/(pmvsmx+q2ga)**3
29828  reduce=4d0*(q2ga/6d0)*redlon/redtra
29829  ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.1) THEN
29830  pmvirt=pmas(pycomp(113),1)
29831  reduce=4d0*q2ga/(pmvirt**2+q2ga)
29832  ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.2) THEN
29833  pmvirt=pmas(pycomp(113),1)
29834  reduce=4d0*q2ga/(pmvirt**2+q2ga)
29835  ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.3) THEN
29836  pmvsmn=4d0*parp(15)**2
29837  pmvsmx=4d0*vint(154)**2
29838  redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
29839  redlon=1d0/(pmvsmn+q2ga)**2-1d0/(pmvsmx+q2ga)**2
29840  reduce=4d0*(q2ga/2d0)*redlon/redtra
29841  ENDIF
29842  beamas=pymass(11)
29843  IF(vint(302+isde).GT.0d0) beamas=vint(302+isde)
29844  fraclt=1d0/(1d0+xy**2/2d0/(1d0-xy)*
29845  & (1d0-2d0*beamas**2/q2ga))
29846  vint(314+isde)=1d0+parp(165)*reduce*fraclt
29847  ENDIF
29848  ELSE
29849  vint(314+isde)=1d0
29850  ENDIF
29851  comfac=comfac*vint(314+isde)
29852  170 CONTINUE
29853 
29854 C...Evaluate cross sections - done in separate routines by kind
29855 C...of physics, to keep PYSIGH of sensible size.
29856  IF(map.EQ.1) THEN
29857 C...Standard QCD (including photons).
29858  CALL pysgqc(nchn,sigs)
29859  ELSEIF(map.EQ.2) THEN
29860 C...Heavy flavours.
29861  CALL pysghf(nchn,sigs)
29862  ELSEIF(map.EQ.3) THEN
29863 C...W/Z.
29864  CALL pysgwz(nchn,sigs)
29865  ELSEIF(map.EQ.4) THEN
29866 C...Higgs (2 doublets; including longitudinal W/Z scattering).
29867  CALL pysghg(nchn,sigs)
29868  ELSEIF(map.EQ.5) THEN
29869 C...SUSY.
29870  CALL pysgsu(nchn,sigs)
29871  ELSEIF(map.EQ.6) THEN
29872 C...Technicolor.
29873  CALL pysgtc(nchn,sigs)
29874  ELSEIF(map.EQ.7) THEN
29875 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29876  CALL pysgex(nchn,sigs)
29877  ELSEIF(map.EQ.8) THEN
29878 C... Universal Extra Dimensions
29879  CALL pyxued(nchn,sigs)
29880  ENDIF
29881 
29882 C...Multiply with parton distributions
29883  IF(isub.LE.90.OR.isub.GE.96) THEN
29884  DO 180 ichn=1,nchn
29885  IF(mint(45).GE.2) THEN
29886  kfl1=isig(ichn,1)
29887  sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)
29888  ENDIF
29889  IF(mint(46).GE.2) THEN
29890  kfl2=isig(ichn,2)
29891  sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)
29892  ENDIF
29893  sigs=sigs+sigh(ichn)
29894  180 CONTINUE
29895  ENDIF
29896 
29897  RETURN
29898  END
29899 
29900 C*********************************************************************
29901 
29902 C...PYSGQC
29903 C...Subprocess cross sections for QCD processes,
29904 C...including photons.
29905 C...Auxiliary to PYSIGH.
29906 
29907  SUBROUTINE pysgqc(NCHN,SIGS)
29908 
29909 C...Double precision and integer declarations
29910  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29911  IMPLICIT INTEGER(I-N)
29912  INTEGER PYK,PYCHGE,PYCOMP
29913 C...Parameter statement to help give large particle numbers.
29914  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
29915  &kexcit=4000000,kdimen=5000000)
29916 C...Commonblocks
29917  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29918  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29919  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
29920  common/pypars/mstp(200),parp(200),msti(200),pari(200)
29921  common/pyint1/mint(400),vint(400)
29922  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
29923  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
29924  common/pyint4/mwid(500),wids(500,5)
29925  common/pyint7/sigt(0:6,0:6,0:5)
29926  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
29927  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
29928  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
29929  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
29930  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
29931  &/pyint3/,/pyint4/,/pyint7/,/pysgcm/
29932 C...Local arrays
29933  dimension wdtp(0:400),wdte(0:400,0:5)
29934 
29935 C...Differential cross section expressions.
29936 
29937  IF(isub.LE.20) THEN
29938  IF(isub.EQ.10) THEN
29939 C...f + f' -> f + f' (gamma/Z/W exchange)
29940  facggf=comfac*aem**2*2d0*(sh2+uh2)/th2
29941  facgzf=comfac*aem**2*xwc*4d0*sh2/(th*(th-sqmz))
29942  faczzf=comfac*(aem*xwc)**2*2d0*sh2/(th-sqmz)**2
29943  facwwf=comfac*(0.5d0*aem/xw)**2*sh2/(th-sqmw)**2
29944  DO 110 i=mmin1,mmax1
29945  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 110
29946  ia=iabs(i)
29947  DO 100 j=mmin2,mmax2
29948  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 100
29949  ja=iabs(j)
29950 C...Electroweak couplings
29951  ei=kchg(ia,1)*isign(1,i)/3d0
29952  ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
29953  vi=ai-4d0*ei*xwv
29954  ej=kchg(ja,1)*isign(1,j)/3d0
29955  aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
29956  vj=aj-4d0*ej*xwv
29957  epsij=isign(1,i*j)
29958 C...gamma/Z exchange, only gamma exchange, or only Z exchange
29959  IF(mstp(21).GE.1.AND.mstp(21).LE.4) THEN
29960  IF(mstp(21).EQ.1.OR.mstp(21).EQ.4) THEN
29961  facncf=facggf*ei**2*ej**2+facgzf*ei*ej*
29962  & (vi*vj*(1d0+uh2/sh2)+ai*aj*epsij*(1d0-uh2/sh2))+
29963  & faczzf*((vi**2+ai**2)*(vj**2+aj**2)*(1d0+uh2/sh2)+
29964  & 4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
29965  ELSEIF(mstp(21).EQ.2) THEN
29966  facncf=facggf*ei**2*ej**2
29967  ELSE
29968  facncf=faczzf*((vi**2+ai**2)*(vj**2+aj**2)*
29969  & (1d0+uh2/sh2)+4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
29970  ENDIF
29971 C...Extrafactor 2 for only one incoming neutrino spin state.
29972  IF(ia.GT.10.AND.mod(ia,2).EQ.0) facncf=2d0*facncf
29973  IF(ja.GT.10.AND.mod(ja,2).EQ.0) facncf=2d0*facncf
29974  nchn=nchn+1
29975  isig(nchn,1)=i
29976  isig(nchn,2)=j
29977  isig(nchn,3)=1
29978  sigh(nchn)=facncf
29979  ENDIF
29980 C...W exchange
29981  IF((mstp(21).EQ.1.OR.mstp(21).EQ.5).AND.ai*aj.LT.0d0) THEN
29982  facccf=facwwf*vint(180+i)*vint(180+j)
29983  IF(epsij.LT.0d0) facccf=facccf*uh2/sh2
29984  IF(ia.GT.10.AND.mod(ia,2).EQ.0) facccf=2d0*facccf
29985  IF(ja.GT.10.AND.mod(ja,2).EQ.0) facccf=2d0*facccf
29986  nchn=nchn+1
29987  isig(nchn,1)=i
29988  isig(nchn,2)=j
29989  isig(nchn,3)=2
29990  sigh(nchn)=facccf
29991  ENDIF
29992  100 CONTINUE
29993  110 CONTINUE
29994 
29995  ELSEIF(isub.EQ.11) THEN
29996 C...f + f' -> f + f' (g exchange)
29997  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
29998  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
29999  & mstp(34)*2d0/3d0*uh2/(sh*th))
30000  facqq2=comfac*as**2*4d0/9d0*((sh2+th2)/uh2-
30001  & mstp(34)*2d0/3d0*sh2/(th*uh))
30002  DO 130 i=mmin1,mmax1
30003  ia=iabs(i)
30004  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 130
30005  DO 120 j=mmin2,mmax2
30006  ja=iabs(j)
30007  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 120
30008  nchn=nchn+1
30009  isig(nchn,1)=i
30010  isig(nchn,2)=j
30011  isig(nchn,3)=1
30012  sigh(nchn)=facqq1
30013  IF(i.EQ.-j) sigh(nchn)=facqqb
30014  IF(i.EQ.j) THEN
30015  sigh(nchn)=0.5d0*sigh(nchn)
30016  nchn=nchn+1
30017  isig(nchn,1)=i
30018  isig(nchn,2)=j
30019  isig(nchn,3)=2
30020  sigh(nchn)=0.5d0*facqq2
30021  ENDIF
30022  120 CONTINUE
30023  130 CONTINUE
30024 
30025  ELSEIF(isub.EQ.12) THEN
30026 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30027  CALL pywidt(21,sh,wdtp,wdte)
30028  facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
30029  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
30030  DO 140 i=mmina,mmaxa
30031  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30032  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 140
30033  nchn=nchn+1
30034  isig(nchn,1)=i
30035  isig(nchn,2)=-i
30036  isig(nchn,3)=1
30037  sigh(nchn)=facqqb
30038  140 CONTINUE
30039 
30040  ELSEIF(isub.EQ.13) THEN
30041 C...f + fbar -> g + g (q + qbar -> g + g only)
30042  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30043  & uh2/sh2)
30044  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30045  & th2/sh2)
30046  DO 150 i=mmina,mmaxa
30047  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30048  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 150
30049  nchn=nchn+1
30050  isig(nchn,1)=i
30051  isig(nchn,2)=-i
30052  isig(nchn,3)=1
30053  sigh(nchn)=0.5d0*facgg1
30054  nchn=nchn+1
30055  isig(nchn,1)=i
30056  isig(nchn,2)=-i
30057  isig(nchn,3)=2
30058  sigh(nchn)=0.5d0*facgg2
30059  150 CONTINUE
30060 
30061  ELSEIF(isub.EQ.14) THEN
30062 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30063  facgg=comfac*as*aem*8d0/9d0*(th2+uh2)/(th*uh)
30064  DO 160 i=mmina,mmaxa
30065  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30066  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 160
30067  ei=kchg(iabs(i),1)/3d0
30068  nchn=nchn+1
30069  isig(nchn,1)=i
30070  isig(nchn,2)=-i
30071  isig(nchn,3)=1
30072  sigh(nchn)=facgg*ei**2
30073  160 CONTINUE
30074 
30075  ELSEIF(isub.EQ.18) THEN
30076 C...f + fbar -> gamma + gamma
30077  facgg=comfac*aem**2*2d0*(th2+uh2)/(th*uh)
30078  DO 170 i=mmina,mmaxa
30079  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 170
30080  ei=kchg(iabs(i),1)/3d0
30081  fcoi=1d0
30082  IF(iabs(i).LE.10) fcoi=faca/3d0
30083  nchn=nchn+1
30084  isig(nchn,1)=i
30085  isig(nchn,2)=-i
30086  isig(nchn,3)=1
30087  sigh(nchn)=0.5d0*facgg*fcoi*ei**4
30088  170 CONTINUE
30089  ENDIF
30090 
30091  ELSEIF(isub.LE.40) THEN
30092  IF(isub.EQ.28) THEN
30093 C...f + g -> f + g (q + g -> q + g only)
30094  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
30095  & uh/sh)*faca
30096  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
30097  & sh/uh)
30098  DO 190 i=mmina,mmaxa
30099  IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 190
30100  DO 180 isde=1,2
30101  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 180
30102  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 180
30103  nchn=nchn+1
30104  isig(nchn,isde)=i
30105  isig(nchn,3-isde)=21
30106  isig(nchn,3)=1
30107  sigh(nchn)=facqg1
30108  nchn=nchn+1
30109  isig(nchn,isde)=i
30110  isig(nchn,3-isde)=21
30111  isig(nchn,3)=2
30112  sigh(nchn)=facqg2
30113  180 CONTINUE
30114  190 CONTINUE
30115 
30116  ELSEIF(isub.EQ.29) THEN
30117 C...f + g -> f + gamma (q + g -> q + gamma only)
30118  fgq=comfac*faca*as*aem*1d0/3d0*(sh2+uh2)/(-sh*uh)
30119  DO 210 i=mmina,mmaxa
30120  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 210
30121  ei=kchg(iabs(i),1)/3d0
30122  facgq=fgq*ei**2
30123  DO 200 isde=1,2
30124  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 200
30125  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 200
30126  nchn=nchn+1
30127  isig(nchn,isde)=i
30128  isig(nchn,3-isde)=21
30129  isig(nchn,3)=1
30130  sigh(nchn)=facgq
30131  200 CONTINUE
30132  210 CONTINUE
30133 
30134  ELSEIF(isub.EQ.33) THEN
30135 C...f + gamma -> f + g (q + gamma -> q + g only)
30136  fgq=comfac*as*aem*8d0/3d0*(sh2+uh2)/(-sh*uh)
30137  DO 230 i=mmina,mmaxa
30138  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 230
30139  ei=kchg(iabs(i),1)/3d0
30140  facgq=fgq*ei**2
30141  DO 220 isde=1,2
30142  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 220
30143  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 220
30144  nchn=nchn+1
30145  isig(nchn,isde)=i
30146  isig(nchn,3-isde)=22
30147  isig(nchn,3)=1
30148  sigh(nchn)=facgq
30149  220 CONTINUE
30150  230 CONTINUE
30151 
30152  ELSEIF(isub.EQ.34) THEN
30153 C...f + gamma -> f + gamma
30154  fgq=comfac*aem**2*2d0*(sh2+uh2)/(-sh*uh)
30155  DO 250 i=mmina,mmaxa
30156  IF(i.EQ.0) GOTO 250
30157  ei=kchg(iabs(i),1)/3d0
30158  facgq=fgq*ei**4
30159  DO 240 isde=1,2
30160  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 240
30161  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 240
30162  nchn=nchn+1
30163  isig(nchn,isde)=i
30164  isig(nchn,3-isde)=22
30165  isig(nchn,3)=1
30166  sigh(nchn)=facgq
30167  240 CONTINUE
30168  250 CONTINUE
30169  ENDIF
30170 
30171  ELSEIF(isub.LE.80) THEN
30172  IF(isub.EQ.53) THEN
30173 C...g + g -> f + fbar (g + g -> q + qbar only)
30174  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 270
30175  idc0=mdcy(21,2)-1
30176 C...Begin by d, u, s flavours.
30177  flavwt=0d0
30178  IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
30179  & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
30180  IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
30181  & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
30182  IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
30183  & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
30184  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30185  & uh2/sh2)*flavwt*faca
30186  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30187  & th2/sh2)*flavwt*faca
30188  nchn=nchn+1
30189  isig(nchn,1)=21
30190  isig(nchn,2)=21
30191  isig(nchn,3)=1
30192  sigh(nchn)=facqq1
30193  nchn=nchn+1
30194  isig(nchn,1)=21
30195  isig(nchn,2)=21
30196  isig(nchn,3)=2
30197  sigh(nchn)=facqq2
30198 C...Next c and b flavours: modified that and uhat for fixed
30199 C...cos(theta-hat).
30200  DO 260 ifl=4,5
30201  sqmavg=pmas(ifl,1)**2
30202  IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
30203  be34=sqrt(1d0-4d0*sqmavg/sh)
30204  thq=-0.5d0*sh*(1d0-be34*cth)
30205  uhq=-0.5d0*sh*(1d0+be34*cth)
30206  thuhq=thq*uhq-sqmavg*sh
30207  IF(mstp(34).EQ.0) THEN
30208  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
30209  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
30210  ELSE
30211  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30212  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
30213  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30214  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
30215  ENDIF
30216  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
30217  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
30218  nchn=nchn+1
30219  isig(nchn,1)=21
30220  isig(nchn,2)=21
30221  isig(nchn,3)=1+2*(ifl-3)
30222  sigh(nchn)=facqq1
30223  nchn=nchn+1
30224  isig(nchn,1)=21
30225  isig(nchn,2)=21
30226  isig(nchn,3)=2+2*(ifl-3)
30227  sigh(nchn)=facqq2
30228  ENDIF
30229  260 CONTINUE
30230  270 CONTINUE
30231 
30232  ELSEIF(isub.EQ.54) THEN
30233 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30234  CALL pywidt(21,sh,wdtp,wdte)
30235  wdtesu=0d0
30236  DO 280 i=1,min(8,mdcy(21,3))
30237  ef=kchg(i,1)/3d0
30238  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30239  & wdte(i,4))
30240  280 CONTINUE
30241  facqq=comfac*aem*as*wdtesu*(th2+uh2)/(th*uh)
30242  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
30243  nchn=nchn+1
30244  isig(nchn,1)=21
30245  isig(nchn,2)=22
30246  isig(nchn,3)=1
30247  sigh(nchn)=facqq
30248  ENDIF
30249  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
30250  nchn=nchn+1
30251  isig(nchn,1)=22
30252  isig(nchn,2)=21
30253  isig(nchn,3)=1
30254  sigh(nchn)=facqq
30255  ENDIF
30256 
30257  ELSEIF(isub.EQ.58) THEN
30258 C...gamma + gamma -> f + fbar
30259  CALL pywidt(22,sh,wdtp,wdte)
30260  wdtesu=0d0
30261  DO 290 i=1,min(12,mdcy(22,3))
30262  IF(i.LE.8) ef= kchg(i,1)/3d0
30263  IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
30264  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30265  & wdte(i,4))
30266  290 CONTINUE
30267  facff=comfac*aem**2*wdtesu*2d0*(th2+uh2)/(th*uh)
30268  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
30269  nchn=nchn+1
30270  isig(nchn,1)=22
30271  isig(nchn,2)=22
30272  isig(nchn,3)=1
30273  sigh(nchn)=facff
30274  ENDIF
30275 
30276  ELSEIF(isub.EQ.68) THEN
30277 C...g + g -> g + g
30278  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 300
30279  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+2d0*th/sh+
30280  & th2/sh2)*faca
30281  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+2d0*sh/uh+
30282  & sh2/uh2)*faca
30283  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+2d0*uh/th+
30284  & uh2/th2)
30285  nchn=nchn+1
30286  isig(nchn,1)=21
30287  isig(nchn,2)=21
30288  isig(nchn,3)=1
30289  sigh(nchn)=0.5d0*facgg1
30290  nchn=nchn+1
30291  isig(nchn,1)=21
30292  isig(nchn,2)=21
30293  isig(nchn,3)=2
30294  sigh(nchn)=0.5d0*facgg2
30295  nchn=nchn+1
30296  isig(nchn,1)=21
30297  isig(nchn,2)=21
30298  isig(nchn,3)=3
30299  sigh(nchn)=0.5d0*facgg3
30300  300 CONTINUE
30301 
30302  ELSEIF(isub.EQ.80) THEN
30303 C...q + gamma -> q' + pi+/-
30304  fqpi=comfac*(2d0*aem/9d0)*(-sh/th)*(1d0/sh2+1d0/th2)
30305  assh=pyalps(max(0.5d0,0.5d0*sh))
30306  q2fpsh=0.55d0/log(max(2d0,2d0*sh))
30307  delsh=uh*sqrt(assh*q2fpsh)
30308  asuh=pyalps(max(0.5d0,-0.5d0*uh))
30309  q2fpuh=0.55d0/log(max(2d0,-2d0*uh))
30310  deluh=sh*sqrt(asuh*q2fpuh)
30311  DO 320 i=max(-2,mmina),min(2,mmaxa)
30312  IF(i.EQ.0) GOTO 320
30313  ei=kchg(iabs(i),1)/3d0
30314  ej=sign(1d0-abs(ei),ei)
30315  DO 310 isde=1,2
30316  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 310
30317  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 310
30318  nchn=nchn+1
30319  isig(nchn,isde)=i
30320  isig(nchn,3-isde)=22
30321  isig(nchn,3)=1
30322  sigh(nchn)=fqpi*(ei*delsh+ej*deluh)**2
30323  310 CONTINUE
30324  320 CONTINUE
30325  ENDIF
30326 
30327  ELSEIF(isub.LE.100) THEN
30328  IF(isub.EQ.91) THEN
30329 C...Elastic scattering
30330  sigs=vint(315)*vint(316)*sigt(0,0,1)
30331 
30332  ELSEIF(isub.EQ.92) THEN
30333 C...Single diffractive scattering (first side, i.e. XB)
30334  sigs=vint(315)*vint(316)*sigt(0,0,2)
30335 
30336  ELSEIF(isub.EQ.93) THEN
30337 C...Single diffractive scattering (second side, i.e. AX)
30338  sigs=vint(315)*vint(316)*sigt(0,0,3)
30339 
30340  ELSEIF(isub.EQ.94) THEN
30341 C...Double diffractive scattering
30342  sigs=vint(315)*vint(316)*sigt(0,0,4)
30343 
30344  ELSEIF(isub.EQ.95) THEN
30345 C...Low-pT scattering
30346  sigs=vint(315)*vint(316)*sigt(0,0,5)
30347 
30348  ELSEIF(isub.EQ.96) THEN
30349 C...Multiple interactions: sum of QCD processes
30350  CALL pywidt(21,sh,wdtp,wdte)
30351 
30352 C...q + q' -> q + q'
30353  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
30354  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
30355  & mstp(34)*2d0/3d0*uh2/(sh*th))
30356  facqq2=comfac*as**2*4d0/9d0*(sh2+th2)/uh2
30357  facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
30358  ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
30359  DO 340 i=-5,5
30360  IF(i.EQ.0) GOTO 340
30361  DO 330 j=-5,5
30362  IF(j.EQ.0) GOTO 330
30363  nchn=nchn+1
30364  isig(nchn,1)=i
30365  isig(nchn,2)=j
30366  isig(nchn,3)=111
30367  sigh(nchn)=facqq1
30368  IF(i.EQ.-j) sigh(nchn)=facqqb
30369  IF(i.EQ.j) THEN
30370  sigh(nchn)=0.5d0*facqq1*ratqqi
30371  nchn=nchn+1
30372  isig(nchn,1)=i
30373  isig(nchn,2)=j
30374  isig(nchn,3)=112
30375  sigh(nchn)=0.5d0*facqq2*ratqqi
30376  ENDIF
30377  330 CONTINUE
30378  340 CONTINUE
30379 
30380 C...q + qbar -> q' + qbar' or g + g
30381  facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
30382  & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))
30383  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30384  & uh2/sh2)
30385  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30386  & th2/sh2)
30387  DO 350 i=-5,5
30388  IF(i.EQ.0) GOTO 350
30389  nchn=nchn+1
30390  isig(nchn,1)=i
30391  isig(nchn,2)=-i
30392  isig(nchn,3)=121
30393  sigh(nchn)=facqqb
30394  nchn=nchn+1
30395  isig(nchn,1)=i
30396  isig(nchn,2)=-i
30397  isig(nchn,3)=131
30398  sigh(nchn)=0.5d0*facgg1
30399  nchn=nchn+1
30400  isig(nchn,1)=i
30401  isig(nchn,2)=-i
30402  isig(nchn,3)=132
30403  sigh(nchn)=0.5d0*facgg2
30404  350 CONTINUE
30405 
30406 C...q + g -> q + g
30407  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
30408  & uh/sh)*faca
30409  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
30410  & sh/uh)
30411  DO 370 i=-5,5
30412  IF(i.EQ.0) GOTO 370
30413  DO 360 isde=1,2
30414  nchn=nchn+1
30415  isig(nchn,isde)=i
30416  isig(nchn,3-isde)=21
30417  isig(nchn,3)=281
30418  sigh(nchn)=facqg1
30419  nchn=nchn+1
30420  isig(nchn,isde)=i
30421  isig(nchn,3-isde)=21
30422  isig(nchn,3)=282
30423  sigh(nchn)=facqg2
30424  360 CONTINUE
30425  370 CONTINUE
30426 
30427 C...g + g -> q + qbar (only d, u, s)
30428  idc0=mdcy(21,2)-1
30429  flavwt=0d0
30430  IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
30431  & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
30432  IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
30433  & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
30434  IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
30435  & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
30436  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30437  & uh2/sh2)*flavwt*faca
30438  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30439  & th2/sh2)*flavwt*faca
30440  nchn=nchn+1
30441  isig(nchn,1)=21
30442  isig(nchn,2)=21
30443  isig(nchn,3)=531
30444  sigh(nchn)=facqq1
30445  nchn=nchn+1
30446  isig(nchn,1)=21
30447  isig(nchn,2)=21
30448  isig(nchn,3)=532
30449  sigh(nchn)=facqq2
30450 
30451 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30452 C...cos(theta-hat)
30453  DO 380 ifl=4,5
30454  sqmavg=pmas(ifl,1)**2
30455  IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
30456  be34=sqrt(1d0-4d0*sqmavg/sh)
30457  thq=-0.5d0*sh*(1d0-be34*cth)
30458  uhq=-0.5d0*sh*(1d0+be34*cth)
30459  thuhq=thq*uhq-sqmavg*sh
30460  IF(mstp(34).EQ.0) THEN
30461  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
30462  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
30463  ELSE
30464  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30465  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
30466  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30467  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
30468  ENDIF
30469  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
30470  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
30471  nchn=nchn+1
30472  isig(nchn,1)=21
30473  isig(nchn,2)=21
30474  isig(nchn,3)=531+2*(ifl-3)
30475  sigh(nchn)=facqq1
30476  nchn=nchn+1
30477  isig(nchn,1)=21
30478  isig(nchn,2)=21
30479  isig(nchn,3)=532+2*(ifl-3)
30480  sigh(nchn)=facqq2
30481  ENDIF
30482  380 CONTINUE
30483 
30484 C...g + g -> g + g
30485  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
30486  & 2d0*th/sh+th2/sh2)*faca
30487  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
30488  & 2d0*sh/uh+sh2/uh2)*faca
30489  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3+
30490  & 2d0*uh/th+uh2/th2)
30491  nchn=nchn+1
30492  isig(nchn,1)=21
30493  isig(nchn,2)=21
30494  isig(nchn,3)=681
30495  sigh(nchn)=0.5d0*facgg1
30496  nchn=nchn+1
30497  isig(nchn,1)=21
30498  isig(nchn,2)=21
30499  isig(nchn,3)=682
30500  sigh(nchn)=0.5d0*facgg2
30501  nchn=nchn+1
30502  isig(nchn,1)=21
30503  isig(nchn,2)=21
30504  isig(nchn,3)=683
30505  sigh(nchn)=0.5d0*facgg3
30506 
30507  ELSEIF(isub.EQ.99) THEN
30508 C...f + gamma* -> f.
30509  IF(mint(107).EQ.4) THEN
30510  q2ga=vint(307)
30511  p2ga=vint(308)
30512  isde=2
30513  ELSE
30514  q2ga=vint(308)
30515  p2ga=vint(307)
30516  isde=1
30517  ENDIF
30518  comfac=paru(5)*4d0*paru(1)**2*paru(101)*vint(315)*vint(316)
30519  pm2rho=pmas(pycomp(113),1)**2
30520  IF(mstp(19).EQ.0) THEN
30521  comfac=comfac/q2ga
30522  ELSEIF(mstp(19).EQ.1) THEN
30523  comfac=comfac/(q2ga+pm2rho)
30524  ELSEIF(mstp(19).EQ.2) THEN
30525  comfac=comfac*q2ga/(q2ga+pm2rho)**2
30526  ELSE
30527  comfac=comfac*q2ga/(q2ga+pm2rho)**2
30528  w2ga=vint(2)
30529  IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
30530  rdrds=4.1d-3*w2ga**2.167d0/((q2ga+0.15d0*w2ga)**2*
30531  & q2ga**0.75d0)*(1d0+0.11d0*q2ga*p2ga/(1d0+0.02d0*p2ga**2))
30532  xga=q2ga/(w2ga+vint(307)+vint(308))
30533  ELSE
30534  rdrds=1.5d-4*w2ga**2.167d0/((q2ga+0.041d0*w2ga)**2*
30535  & q2ga**0.57d0)
30536  xga=q2ga/(w2ga+q2ga-pmas(pycomp(mint(10+isde)),1)**2)
30537  ENDIF
30538  comfac=comfac*exp(-max(1d-10,rdrds))
30539  IF(mstp(19).EQ.4) comfac=comfac/max(1d-2,1d0-xga)
30540  ENDIF
30541  DO 390 i=mmina,mmaxa
30542  IF(i.EQ.0.OR.kfac(isde,i).EQ.0) GOTO 390
30543  IF(iabs(i).LT.10.AND.iabs(i).GT.mstp(58)) GOTO 390
30544  ei=kchg(iabs(i),1)/3d0
30545  nchn=nchn+1
30546  isig(nchn,isde)=i
30547  isig(nchn,3-isde)=22
30548  isig(nchn,3)=1
30549  sigh(nchn)=comfac*ei**2
30550  390 CONTINUE
30551  ENDIF
30552 
30553  ELSE
30554  IF(isub.EQ.114.OR.isub.EQ.115) THEN
30555 C...g + g -> gamma + gamma or g + g -> g + gamma
30556  a0stur=0d0
30557  a0stui=0d0
30558  a0tsur=0d0
30559  a0tsui=0d0
30560  a0utsr=0d0
30561  a0utsi=0d0
30562  a1stur=0d0
30563  a1stui=0d0
30564  a2stur=0d0
30565  a2stui=0d0
30566  alst=log(-sh/th)
30567  alsu=log(-sh/uh)
30568  altu=log(th/uh)
30569  imax=2*mstp(1)
30570  IF(mstp(38).GE.1.AND.mstp(38).LE.8) imax=mstp(38)
30571  DO 400 i=1,imax
30572  ei=kchg(iabs(i),1)/3d0
30573  eiwt=ei**2
30574  IF(isub.EQ.115) eiwt=ei
30575  sqmq=pmas(i,1)**2
30576  epss=4d0*sqmq/sh
30577  epst=4d0*sqmq/th
30578  epsu=4d0*sqmq/uh
30579  IF((mstp(38).GE.1.AND.mstp(38).LE.8).OR.epss.LT.1d-4) THEN
30580  b0stur=1d0+(th-uh)/sh*altu+0.5d0*(th2+uh2)/sh2*(altu**2+
30581  & paru(1)**2)
30582  b0stui=0d0
30583  b0tsur=1d0+(sh-uh)/th*alsu+0.5d0*(sh2+uh2)/th2*alsu**2
30584  b0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*alsu)
30585  b0utsr=1d0+(sh-th)/uh*alst+0.5d0*(sh2+th2)/uh2*alst**2
30586  b0utsi=-paru(1)*((sh-th)/uh+(sh2+th2)/uh2*alst)
30587  b1stur=-1d0
30588  b1stui=0d0
30589  b2stur=-1d0
30590  b2stui=0d0
30591  ELSE
30592  CALL pywaux(1,epss,w1sr,w1si)
30593  CALL pywaux(1,epst,w1tr,w1ti)
30594  CALL pywaux(1,epsu,w1ur,w1ui)
30595  CALL pywaux(2,epss,w2sr,w2si)
30596  CALL pywaux(2,epst,w2tr,w2ti)
30597  CALL pywaux(2,epsu,w2ur,w2ui)
30598  CALL pyi3au(epss,th/uh,y3stur,y3stui)
30599  CALL pyi3au(epss,uh/th,y3sutr,y3suti)
30600  CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
30601  CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
30602  CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
30603  CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
30604  b0stur=1d0+(1d0+2d0*th/sh)*w1tr+(1d0+2d0*uh/sh)*w1ur+
30605  & 0.5d0*((th2+uh2)/sh2-epss)*(w2tr+w2ur)-
30606  & 0.25d0*epst*(1d0-0.5d0*epss)*(y3sutr+y3tusr)-
30607  & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stur+y3utsr)+
30608  & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
30609  & 0.5d0*epst*epsu)*(y3tsur+y3ustr)
30610  b0stui=(1d0+2d0*th/sh)*w1ti+(1d0+2d0*uh/sh)*w1ui+
30611  & 0.5d0*((th2+uh2)/sh2-epss)*(w2ti+w2ui)-
30612  & 0.25d0*epst*(1d0-0.5d0*epss)*(y3suti+y3tusi)-
30613  & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stui+y3utsi)+
30614  & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
30615  & 0.5d0*epst*epsu)*(y3tsui+y3usti)
30616  b0tsur=1d0+(1d0+2d0*sh/th)*w1sr+(1d0+2d0*uh/th)*w1ur+
30617  & 0.5d0*((sh2+uh2)/th2-epst)*(w2sr+w2ur)-
30618  & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusr+y3sutr)-
30619  & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsur+y3ustr)+
30620  & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
30621  & 0.5d0*epss*epsu)*(y3stur+y3utsr)
30622  b0tsui=(1d0+2d0*sh/th)*w1si+(1d0+2d0*uh/th)*w1ui+
30623  & 0.5d0*((sh2+uh2)/th2-epst)*(w2si+w2ui)-
30624  & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusi+y3suti)-
30625  & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsui+y3usti)+
30626  & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
30627  & 0.5d0*epss*epsu)*(y3stui+y3utsi)
30628  b0utsr=1d0+(1d0+2d0*th/uh)*w1tr+(1d0+2d0*sh/uh)*w1sr+
30629  & 0.5d0*((th2+sh2)/uh2-epsu)*(w2tr+w2sr)-
30630  & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3ustr+y3tsur)-
30631  & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsr+y3stur)+
30632  & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
30633  & 0.5d0*epst*epss)*(y3tusr+y3sutr)
30634  b0utsi=(1d0+2d0*th/uh)*w1ti+(1d0+2d0*sh/uh)*w1si+
30635  & 0.5d0*((th2+sh2)/uh2-epsu)*(w2ti+w2si)-
30636  & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3usti+y3tsui)-
30637  & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsi+y3stui)+
30638  & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
30639  & 0.5d0*epst*epss)*(y3tusi+y3suti)
30640  b1stur=-1d0-0.25d0*(epss+epst+epsu)*(w2sr+w2tr+w2ur)+
30641  & 0.25d0*(epsu+0.5d0*epss*epst)*(y3sutr+y3tusr)+
30642  & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stur+y3utsr)+
30643  & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsur+y3ustr)
30644  b1stui=-0.25d0*(epss+epst+epsu)*(w2si+w2ti+w2ui)+
30645  & 0.25d0*(epsu+0.5d0*epss*epst)*(y3suti+y3tusi)+
30646  & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stui+y3utsi)+
30647  & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsui+y3usti)
30648  b2stur=-1d0+0.125d0*epss*epst*(y3sutr+y3tusr)+
30649  & 0.125d0*epss*epsu*(y3stur+y3utsr)+
30650  & 0.125d0*epst*epsu*(y3tsur+y3ustr)
30651  b2stui=0.125d0*epss*epst*(y3suti+y3tusi)+
30652  & 0.125d0*epss*epsu*(y3stui+y3utsi)+
30653  & 0.125d0*epst*epsu*(y3tsui+y3usti)
30654  ENDIF
30655  a0stur=a0stur+eiwt*b0stur
30656  a0stui=a0stui+eiwt*b0stui
30657  a0tsur=a0tsur+eiwt*b0tsur
30658  a0tsui=a0tsui+eiwt*b0tsui
30659  a0utsr=a0utsr+eiwt*b0utsr
30660  a0utsi=a0utsi+eiwt*b0utsi
30661  a1stur=a1stur+eiwt*b1stur
30662  a1stui=a1stui+eiwt*b1stui
30663  a2stur=a2stur+eiwt*b2stur
30664  a2stui=a2stui+eiwt*b2stui
30665  400 CONTINUE
30666  asqsum=a0stur**2+a0stui**2+a0tsur**2+a0tsui**2+a0utsr**2+
30667  & a0utsi**2+4d0*a1stur**2+4d0*a1stui**2+a2stur**2+a2stui**2
30668  facgg=comfac*faca/(16d0*paru(1)**2)*as**2*aem**2*asqsum
30669  facgp=comfac*faca*5d0/(192d0*paru(1)**2)*as**3*aem*asqsum
30670  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 410
30671  nchn=nchn+1
30672  isig(nchn,1)=21
30673  isig(nchn,2)=21
30674  isig(nchn,3)=1
30675  IF(isub.EQ.114) sigh(nchn)=0.5d0*facgg
30676  IF(isub.EQ.115) sigh(nchn)=facgp
30677  410 CONTINUE
30678 
30679  ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
30680 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30681  ph=0d0
30682  IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
30683  & ph=vint(3)**2
30684  IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
30685  & ph=vint(4)**2
30686  IF(isub.EQ.131) THEN
30687  fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**2*
30688  & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
30689  ELSE
30690  fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
30691  ENDIF
30692  DO 430 i=mmina,mmaxa
30693  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 430
30694  ei=kchg(iabs(i),1)/3d0
30695  facgq=fgq*ei**2
30696  DO 420 isde=1,2
30697  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 420
30698  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 420
30699  nchn=nchn+1
30700  isig(nchn,isde)=i
30701  isig(nchn,3-isde)=22
30702  isig(nchn,3)=1
30703  sigh(nchn)=facgq
30704  420 CONTINUE
30705  430 CONTINUE
30706 
30707  ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
30708 C...f + gamma*_(T,L) -> f + gamma
30709  ph=0d0
30710  IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
30711  & ph=vint(3)**2
30712  IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
30713  & ph=vint(4)**2
30714  IF(isub.EQ.133) THEN
30715  fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**2*
30716  & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
30717  ELSE
30718  fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
30719  ENDIF
30720  DO 450 i=mmina,mmaxa
30721  IF(i.EQ.0) GOTO 450
30722  ei=kchg(iabs(i),1)/3d0
30723  facgq=fgq*ei**4
30724  DO 440 isde=1,2
30725  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 440
30726  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 440
30727  nchn=nchn+1
30728  isig(nchn,isde)=i
30729  isig(nchn,3-isde)=22
30730  isig(nchn,3)=1
30731  sigh(nchn)=facgq
30732  440 CONTINUE
30733  450 CONTINUE
30734 
30735  ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
30736 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30737  ph=0d0
30738  IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
30739  & ph=vint(3)**2
30740  IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
30741  & ph=vint(4)**2
30742  CALL pywidt(21,sh,wdtp,wdte)
30743  wdtesu=0d0
30744  DO 460 i=1,min(8,mdcy(21,3))
30745  ef=kchg(i,1)/3d0
30746  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30747  & wdte(i,4))
30748  460 CONTINUE
30749  IF(isub.EQ.135) THEN
30750  facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**2*
30751  & ((th2+uh2-2d0*ph*sh)/(th*uh)+4d0*ph*sh/(sh+ph)**2)
30752  ELSE
30753  facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**4*8d0*ph*sh
30754  ENDIF
30755  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
30756  nchn=nchn+1
30757  isig(nchn,1)=21
30758  isig(nchn,2)=22
30759  isig(nchn,3)=1
30760  sigh(nchn)=facqq
30761  ENDIF
30762  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
30763  nchn=nchn+1
30764  isig(nchn,1)=22
30765  isig(nchn,2)=21
30766  isig(nchn,3)=1
30767  sigh(nchn)=facqq
30768  ENDIF
30769 
30770  ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
30771 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30772  ph1=0d0
30773  IF(vint(3).LT.0d0) ph1=vint(3)**2
30774  ph2=0d0
30775  IF(vint(4).LT.0d0) ph2=vint(4)**2
30776  CALL pywidt(22,sh,wdtp,wdte)
30777  wdtesu=0d0
30778  DO 470 i=1,min(12,mdcy(22,3))
30779  IF(i.LE.8) ef= kchg(i,1)/3d0
30780  IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
30781  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30782  & wdte(i,4))
30783  470 CONTINUE
30784  dlamb2=(th+uh)**2-4d0*ph1*ph2
30785  IF(isub.EQ.137) THEN
30786  fparam=-sh*(th+uh)/dlamb2
30787  facff=comfac*aem**2*wdtesu*2d0*sh2/(dlamb2*th2*uh2)*
30788  & (th*uh-ph1*ph2)*((th2+uh2)*(1d0-2d0*fparam*(1d0-fparam))-
30789  & 2d0*ph1*ph2*fparam**2)
30790  ELSEIF(isub.EQ.138) THEN
30791  facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
30792  & ph2*(4d0*(th*uh-ph1*ph2)*(th*uh+ph1*sh*(th-uh)**2/dlamb2)+
30793  & 2d0*ph1**2*(th-uh)**2)
30794  ELSEIF(isub.EQ.139) THEN
30795  facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
30796  & ph1*(4d0*(th*uh-ph1*ph2)*(th*uh+ph2*sh*(th-uh)**2/dlamb2)+
30797  & 2d0*ph2**2*(th-uh)**2)
30798  ELSE
30799  facff=comfac*aem**2*wdtesu*32d0*sh2**2/(dlamb2**3*th2*uh2)*
30800  & ph1*ph2*(th*uh-ph1*ph2)*(th-uh)**2
30801  ENDIF
30802  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
30803  nchn=nchn+1
30804  isig(nchn,1)=22
30805  isig(nchn,2)=22
30806  isig(nchn,3)=1
30807  sigh(nchn)=facff
30808  ENDIF
30809 
30810  ENDIF
30811  ENDIF
30812 
30813  RETURN
30814  END
30815 
30816 C*********************************************************************
30817 
30818 C...PYSGHF
30819 C...Subprocess cross sections for heavy flavour production,
30820 C...open and closed.
30821 C...Auxiliary to PYSIGH.
30822 
30823  SUBROUTINE pysghf(NCHN,SIGS)
30824 
30825 C...Double precision and integer declarations
30826  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30827  IMPLICIT INTEGER(I-N)
30828  INTEGER PYK,PYCHGE,PYCOMP
30829 C...Parameter statement to help give large particle numbers.
30830  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
30831  &kexcit=4000000,kdimen=5000000)
30832 C...Commonblocks
30833  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30834  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30835  common/pypars/mstp(200),parp(200),msti(200),pari(200)
30836  common/pyint1/mint(400),vint(400)
30837  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
30838  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
30839  common/pyint4/mwid(500),wids(500,5)
30840  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
30841  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
30842  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
30843  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
30844  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
30845  &/pyint4/,/pysgcm/
30846 C...Local arrays
30847  dimension wdtp(0:400),wdte(0:400,0:5)
30848 
30849 C...Determine where are charmonium/bottomonium wave function parameters.
30850  ionium=140
30851  IF(isub.GE.461.AND.isub.LE.479) ionium=145
30852 
30853 C...Convert bottomonium process into equivalent charmonium ones.
30854  IF(isub.GE.461.AND.isub.LE.479) isub=isub-40
30855 
30856 C...Differential cross section expressions.
30857 
30858  IF(isub.LE.100) THEN
30859  IF(isub.EQ.81) THEN
30860 C...q + qbar -> Q + Qbar
30861  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
30862  thq=-0.5d0*sh*(1d0-be34*cth)
30863  uhq=-0.5d0*sh*(1d0+be34*cth)
30864  facqqb=comfac*as**2*4d0/9d0*((thq**2+uhq**2)/sh2+
30865  & 2d0*sqmavg/sh)
30866  IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqmavg,0d0)
30867  wid2=1d0
30868  IF(mint(55).EQ.6) wid2=wids(6,1)
30869  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
30870  facqqb=facqqb*wid2
30871  DO 100 i=mmina,mmaxa
30872  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30873  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
30874  nchn=nchn+1
30875  isig(nchn,1)=i
30876  isig(nchn,2)=-i
30877  isig(nchn,3)=1
30878  sigh(nchn)=facqqb
30879  100 CONTINUE
30880 
30881  ELSEIF(isub.EQ.82) THEN
30882 C...g + g -> Q + Qbar
30883  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
30884  thq=-0.5d0*sh*(1d0-be34*cth)
30885  uhq=-0.5d0*sh*(1d0+be34*cth)
30886  thuhq=thq*uhq-sqmavg*sh
30887  IF(mstp(34).EQ.0) THEN
30888  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
30889  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
30890  ELSE
30891  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30892  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
30893  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30894  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
30895  ENDIF
30896  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1
30897  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2
30898  IF(mstp(35).GE.1) THEN
30899  fatre=pyhfth(sh,sqmavg,2d0/7d0)
30900  facqq1=facqq1*fatre
30901  facqq2=facqq2*fatre
30902  ENDIF
30903  wid2=1d0
30904  IF(mint(55).EQ.6) wid2=wids(6,1)
30905  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
30906  facqq1=facqq1*wid2
30907  facqq2=facqq2*wid2
30908  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 110
30909  nchn=nchn+1
30910  isig(nchn,1)=21
30911  isig(nchn,2)=21
30912  isig(nchn,3)=1
30913  sigh(nchn)=facqq1
30914  nchn=nchn+1
30915  isig(nchn,1)=21
30916  isig(nchn,2)=21
30917  isig(nchn,3)=2
30918  sigh(nchn)=facqq2
30919  110 CONTINUE
30920 
30921  ELSEIF(isub.EQ.83) THEN
30922 C...f + q -> f' + Q
30923  facqqs=comfac*(0.5d0*aem/xw)**2*sh*(sh-sqm3)/(sqmw-th)**2
30924  facqqu=comfac*(0.5d0*aem/xw)**2*uh*(uh-sqm3)/(sqmw-th)**2
30925  DO 130 i=mmin1,mmax1
30926  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 130
30927  DO 120 j=mmin2,mmax2
30928  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 120
30929  IF(i*j.GT.0.AND.mod(iabs(i+j),2).EQ.0) GOTO 120
30930  IF(i*j.LT.0.AND.mod(iabs(i+j),2).EQ.1) GOTO 120
30931  IF(iabs(i).LT.mint(55).AND.mod(iabs(i+mint(55)),2).EQ.1)
30932  & THEN
30933  nchn=nchn+1
30934  isig(nchn,1)=i
30935  isig(nchn,2)=j
30936  isig(nchn,3)=1
30937  IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
30938  & (iabs(i)+1)/2)*vint(180+j)
30939  IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(i)/2,
30940  & (mint(55)+1)/2)*vint(180+j)
30941  wid2=1d0
30942  IF(i.GT.0) THEN
30943  IF(mint(55).EQ.6) wid2=wids(6,2)
30944  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30945  & wids(mint(55),2)
30946  ELSE
30947  IF(mint(55).EQ.6) wid2=wids(6,3)
30948  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30949  & wids(mint(55),3)
30950  ENDIF
30951  IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
30952  IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
30953  ENDIF
30954  IF(iabs(j).LT.mint(55).AND.mod(iabs(j+mint(55)),2).EQ.1)
30955  & THEN
30956  nchn=nchn+1
30957  isig(nchn,1)=i
30958  isig(nchn,2)=j
30959  isig(nchn,3)=2
30960  IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
30961  & (iabs(j)+1)/2)*vint(180+i)
30962  IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(j)/2,
30963  & (mint(55)+1)/2)*vint(180+i)
30964  wid2=1d0
30965  IF(j.GT.0) THEN
30966  IF(mint(55).EQ.6) wid2=wids(6,2)
30967  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30968  & wids(mint(55),2)
30969  ELSE
30970  IF(mint(55).EQ.6) wid2=wids(6,3)
30971  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30972  & wids(mint(55),3)
30973  ENDIF
30974  IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
30975  IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
30976  ENDIF
30977  120 CONTINUE
30978  130 CONTINUE
30979 
30980  ELSEIF(isub.EQ.84) THEN
30981 C...g + gamma -> Q + Qbar
30982  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
30983  thq=-0.5d0*sh*(1d0-be34*cth)
30984  uhq=-0.5d0*sh*(1d0+be34*cth)
30985  facqq=comfac*as*aem*(kchg(iabs(mint(55)),1)/3d0)**2*
30986  & (thq**2+uhq**2+4d0*sqmavg*sh*(1d0-sqmavg*sh/(thq*uhq)))/
30987  & (thq*uhq)
30988  IF(mstp(35).GE.1) facqq=facqq*pyhfth(sh,sqmavg,0d0)
30989  wid2=1d0
30990  IF(mint(55).EQ.6) wid2=wids(6,1)
30991  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
30992  facqq=facqq*wid2
30993  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
30994  nchn=nchn+1
30995  isig(nchn,1)=21
30996  isig(nchn,2)=22
30997  isig(nchn,3)=1
30998  sigh(nchn)=facqq
30999  ENDIF
31000  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31001  nchn=nchn+1
31002  isig(nchn,1)=22
31003  isig(nchn,2)=21
31004  isig(nchn,3)=1
31005  sigh(nchn)=facqq
31006  ENDIF
31007 
31008  ELSEIF(isub.EQ.85) THEN
31009 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31010  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
31011  thq=-0.5d0*sh*(1d0-be34*cth)
31012  uhq=-0.5d0*sh*(1d0+be34*cth)
31013  facff=comfac*aem**2*(kchg(iabs(mint(56)),1)/3d0)**4*2d0*
31014  & ((1d0-parj(131)*parj(132))*(thq*uhq-sqmavg*sh)*
31015  & (uhq**2+thq**2+2d0*sqmavg*sh)+(1d0+parj(131)*parj(132))*
31016  & sqmavg*sh**2*(sh-2d0*sqmavg))/(thq*uhq)**2
31017  IF(iabs(mint(56)).LT.10) facff=3d0*facff
31018  IF(iabs(mint(56)).LT.10.AND.mstp(35).GE.1)
31019  & facff=facff*pyhfth(sh,sqmavg,1d0)
31020  wid2=1d0
31021  IF(mint(56).EQ.6) wid2=wids(6,1)
31022  IF(mint(56).EQ.7.OR.mint(56).EQ.8) wid2=wids(mint(56),1)
31023  IF(mint(56).EQ.17) wid2=wids(17,1)
31024  facff=facff*wid2
31025  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31026  nchn=nchn+1
31027  isig(nchn,1)=22
31028  isig(nchn,2)=22
31029  isig(nchn,3)=1
31030  sigh(nchn)=facff
31031  ENDIF
31032 
31033  ELSEIF(isub.EQ.86) THEN
31034 C...g + g -> J/Psi + g
31035  facqqg=comfac*as**3*(5d0/9d0)*parp(38)*sqrt(sqm3)*
31036  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31037  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31038  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31039  nchn=nchn+1
31040  isig(nchn,1)=21
31041  isig(nchn,2)=21
31042  isig(nchn,3)=1
31043  sigh(nchn)=facqqg
31044  ENDIF
31045 
31046  ELSEIF(isub.EQ.87) THEN
31047 C...g + g -> chi_0c + g
31048  pgtw=(sh*th+th*uh+uh*sh)/sh2
31049  qgtw=(sh*th*uh)/sh**3
31050  rgtw=sqm3/sh
31051  facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31052  & (9d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
31053  & 6d0*rgtw*pgtw**3*qgtw*(2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)-
31054  & pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)+
31055  & 2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)+6d0*rgtw**2*qgtw**4)/
31056  & (qgtw*(qgtw-rgtw*pgtw)**4)
31057  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31058  nchn=nchn+1
31059  isig(nchn,1)=21
31060  isig(nchn,2)=21
31061  isig(nchn,3)=1
31062  sigh(nchn)=facqqg
31063  ENDIF
31064 
31065  ELSEIF(isub.EQ.88) THEN
31066 C...g + g -> chi_1c + g
31067  pgtw=(sh*th+th*uh+uh*sh)/sh2
31068  qgtw=(sh*th*uh)/sh**3
31069  rgtw=sqm3/sh
31070  facqqg=comfac*as**3*12d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31071  & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)+2d0*qgtw*(-rgtw**4+
31072  & 5d0*rgtw**2*pgtw+pgtw**2)-15d0*rgtw*qgtw**2)/
31073  & (qgtw-rgtw*pgtw)**4
31074  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31075  nchn=nchn+1
31076  isig(nchn,1)=21
31077  isig(nchn,2)=21
31078  isig(nchn,3)=1
31079  sigh(nchn)=facqqg
31080  ENDIF
31081 
31082  ELSEIF(isub.EQ.89) THEN
31083 C...g + g -> chi_2c + g
31084  pgtw=(sh*th+th*uh+uh*sh)/sh2
31085  qgtw=(sh*th*uh)/sh**3
31086  rgtw=sqm3/sh
31087  facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31088  & (12d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
31089  & 3d0*rgtw*pgtw**3*qgtw*(8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)+
31090  & 2d0*pgtw**2*qgtw**2*(-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)+
31091  & rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)+12d0*rgtw**2*
31092  & qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
31093  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31094  nchn=nchn+1
31095  isig(nchn,1)=21
31096  isig(nchn,2)=21
31097  isig(nchn,3)=1
31098  sigh(nchn)=facqqg
31099  ENDIF
31100  ENDIF
31101 
31102  ELSEIF(isub.LE.200) THEN
31103  IF(isub.EQ.104) THEN
31104 C...g + g -> chi_c0.
31105  kc=pycomp(10441)
31106  facbw=comfac*12d0*as**2*parp(39)*pmas(kc,2)/
31107  & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
31108  IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
31109  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31110  nchn=nchn+1
31111  isig(nchn,1)=21
31112  isig(nchn,2)=21
31113  isig(nchn,3)=1
31114  sigh(nchn)=facbw
31115  ENDIF
31116 
31117  ELSEIF(isub.EQ.105) THEN
31118 C...g + g -> chi_c2.
31119  kc=pycomp(445)
31120  facbw=comfac*16d0*as**2*parp(39)*pmas(kc,2)/
31121  & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
31122  IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
31123  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31124  nchn=nchn+1
31125  isig(nchn,1)=21
31126  isig(nchn,2)=21
31127  isig(nchn,3)=1
31128  sigh(nchn)=facbw
31129  ENDIF
31130 
31131  ELSEIF(isub.EQ.106) THEN
31132 C...g + g -> J/Psi + gamma.
31133  eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31134  facqqg=comfac*aem*eq**2*as**2*(4d0/3d0)*parp(38)*sqrt(sqm3)*
31135  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31136  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31137  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31138  nchn=nchn+1
31139  isig(nchn,1)=21
31140  isig(nchn,2)=21
31141  isig(nchn,3)=1
31142  sigh(nchn)=facqqg
31143  ENDIF
31144 
31145  ELSEIF(isub.EQ.107) THEN
31146 C...g + gamma -> J/Psi + g.
31147  eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31148  facqqg=comfac*aem*eq**2*as**2*(32d0/3d0)*parp(38)*sqrt(sqm3)*
31149  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31150  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31151  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
31152  nchn=nchn+1
31153  isig(nchn,1)=21
31154  isig(nchn,2)=22
31155  isig(nchn,3)=1
31156  sigh(nchn)=facqqg
31157  ENDIF
31158  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31159  nchn=nchn+1
31160  isig(nchn,1)=22
31161  isig(nchn,2)=21
31162  isig(nchn,3)=1
31163  sigh(nchn)=facqqg
31164  ENDIF
31165 
31166  ELSEIF(isub.EQ.108) THEN
31167 C...gamma + gamma -> J/Psi + gamma.
31168  eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31169  facqqg=comfac*aem**3*eq**6*384d0*parp(38)*sqrt(sqm3)*
31170  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31171  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31172  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31173  nchn=nchn+1
31174  isig(nchn,1)=22
31175  isig(nchn,2)=22
31176  isig(nchn,3)=1
31177  sigh(nchn)=facqqg
31178  ENDIF
31179  ENDIF
31180 
31181 C...QUARKONIA+++
31182 C...Additional code by Stefan Wolf
31183  ELSE
31184 
31185 C...Common code for quarkonium production.
31186  shth=sh+th
31187  thuh=th+uh
31188  uhsh=uh+sh
31189  shth2=shth**2
31190  thuh2=thuh**2
31191  uhsh2=uhsh**2
31192  IF ( (isub.GE.421.AND.isub.LE.424).OR.
31193  & (isub.GE.431.AND.isub.LE.433)) THEN
31194  sqmqq=sqm3
31195  ELSEIF((isub.GE.425.AND.isub.LE.430).OR.
31196  & (isub.GE.434.AND.isub.LE.439)) THEN
31197  sqmqq=sqm4
31198  ENDIF
31199  sqmqqr=sqrt(sqmqq)
31200  IF(mstp(145).EQ.1) THEN
31201  IF ( (isub.GE.421.AND.isub.LE.427).OR.
31202  & (isub.GE.431.AND.isub.LE.436)) THEN
31203  aq=uhsh/(2d0*x(1)) + shth/(2d0*x(2))
31204  bq=uhsh/(2d0*x(1)) - shth/(2d0*x(2))
31205  atilk1=x(1)*vint(2)/2d0-uhsh/(2d0*sqmqq)*aq
31206  atilk2=x(2)*vint(2)/2d0-shth/(2d0*sqmqq)*aq
31207  btilk1=-x(1)*vint(2)/2d0-uhsh/(2d0*sqmqq)*bq
31208  btilk2=x(2)*vint(2)/2d0-shth/(2d0*sqmqq)*bq
31209  ELSEIF( (isub.GE.428.AND.isub.LE.430).OR.
31210  & isub.GE.437) THEN
31211  aq=shth/(2d0*x(1)) + uhsh/(2d0*x(2))
31212  bq=shth/(2d0*x(1)) - uhsh/(2d0*x(2))
31213  atilk1=x(1)*vint(2)/2d0-shth/(2d0*sqmqq)*aq
31214  atilk2=x(2)*vint(2)/2d0-uhsh/(2d0*sqmqq)*aq
31215  btilk1=-x(1)*vint(2)/2d0-shth/(2d0*sqmqq)*bq
31216  btilk2=x(2)*vint(2)/2d0-uhsh/(2d0*sqmqq)*bq
31217  ENDIF
31218  aq2=aq**2
31219  bq2=bq**2
31220  smqq2=sqmqq*vint(2)
31221 C...Polarisation frames
31222  IF(mstp(146).EQ.1) THEN
31223 C...Recoil frame
31224  polh1=sqrt(aq2-smqq2)
31225  polh2=sqrt(vint(2)*(aq2-bq2-smqq2))
31226  az=-sqmqqr/polh1
31227  bz=0d0
31228  ax=aq*bq/(polh1*polh2)
31229  bx=-polh1/polh2
31230  ELSEIF(mstp(146).EQ.2) THEN
31231 C...Gottfried Jackson frame
31232  polh1=aq+bq
31233  polh2=polh1*sqrt(vint(2)*(aq2-bq2-smqq2))
31234  az=sqmqqr/polh1
31235  bz=az
31236  ax=-(bq2+aq*bq+smqq2)/polh2
31237  bx=(aq2+aq*bq-smqq2)/polh2
31238  ELSEIF(mstp(146).EQ.3) THEN
31239 C...Target frame
31240  polh1=aq-bq
31241  polh2=polh1*sqrt(vint(2)*(aq2-bq2-smqq2))
31242  az=-sqmqqr/polh1
31243  bz=-az
31244  ax=-(bq2-aq*bq+smqq2)/polh2
31245  bx=-(aq2-aq*bq-smqq2)/polh2
31246  ELSEIF(mstp(146).EQ.4) THEN
31247 C...Collins Soper frame
31248  polh1=aq2-bq2
31249  polh2=sqrt(vint(2)*polh1)
31250  az=-bq/polh2
31251  bz=aq/polh2
31252  ax=-sqmqqr*aq/sqrt(polh1*(polh1-smqq2))
31253  bx=sqmqqr*bq/sqrt(polh1*(polh1-smqq2))
31254  ENDIF
31255 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31256  el1k10=az*atilk1+bz*btilk1
31257  el1k20=az*atilk2+bz*btilk2
31258  el2k10=el1k10
31259  el2k20=el1k20
31260  el1k11=1d0/sqrt(2d0)*(ax*atilk1+bx*btilk1)
31261  el1k21=1d0/sqrt(2d0)*(ax*atilk2+bx*btilk2)
31262  el2k11=el1k11
31263  el2k21=el1k21
31264  ENDIF
31265 
31266  IF(isub.EQ.421) THEN
31267 C...g + g -> QQ~[3S11] + g
31268  IF(mstp(145).EQ.0) THEN
31269 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31270 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31271  facqqg=comfac*paru(1)*as**3*(10d0/81d0)*sqmqqr*
31272  & (sh2*thuh2+th2*uhsh2+uh2*shth2)/shth2/thuh2/uhsh2
31273 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31274 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31275  ELSE
31276  ff=-paru(1)*as**3*(10d0/81d0)*sqmqqr/thuh2/shth2/uhsh2
31277  aa=(shth2*uh2+uhsh2*th2+thuh2*sh2)/2d0
31278  bb=2d0*(sh2+th2)
31279  cc=2d0*(sh2+uh2)
31280  dd=2d0*sh2
31281  IF(mstp(147).EQ.0) THEN
31282  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31283  & +dd*(el1k10*el2k20+el1k20*el2k10))
31284  ELSEIF(mstp(147).EQ.1) THEN
31285  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31286  & +dd*(el1k11*el2k21+el1k21*el2k11)))
31287  ELSEIF(mstp(147).EQ.3) THEN
31288  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31289  & +dd*(el1k10*el2k20+el1k20*el2k10))
31290  ELSEIF(mstp(147).EQ.4) THEN
31291  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31292  & +dd*(el1k11*el2k21+el1k21*el2k11))
31293  ELSEIF(mstp(147).EQ.5) THEN
31294  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31295  & +dd*(el1k11*el2k20+el1k21*el2k10))
31296  ELSEIF(mstp(147).EQ.6) THEN
31297  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31298  & +dd*(el1k11*el2k21+el1k21*el2k11))
31299  ENDIF
31300  facqqg=comfac*ff*facqqg
31301  ENDIF
31302  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31303  nchn=nchn+1
31304  isig(nchn,1)=21
31305  isig(nchn,2)=21
31306  isig(nchn,3)=1
31307  sigh(nchn)=facqqg*parp(ionium+1)
31308  ENDIF
31309 
31310  ELSEIF(isub.EQ.422) THEN
31311 C...g + g -> QQ~[3S18] + g
31312  IF(mstp(145).EQ.0) THEN
31313  facqqg=-comfac*paru(1)*as**3*(1d0/72d0)*
31314  & (16d0*sqmqq**2-27d0*(shth2+thuh2+uhsh2))/
31315  & (sqmqq*sqmqqr)*
31316  & ((sh2*thuh2+th2*uhsh2+uh2*shth2)/shth2/thuh2/uhsh2)
31317  ELSE
31318  ff=paru(1)*as**3*(16d0*sqmqq**2-27d0*(shth2+thuh2+uhsh2))/
31319  & (72d0*sqmqq*sqmqqr*shth2*thuh2*uhsh2)
31320  aa=(shth2*uh2+uhsh2*th2+thuh2*sh2)/2d0
31321  bb=2d0*(sh2+th2)
31322  cc=2d0*(sh2+uh2)
31323  dd=2d0*sh2
31324  IF(mstp(147).EQ.0) THEN
31325  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31326  & +dd*(el1k10*el2k20+el1k20*el2k10))
31327  ELSEIF(mstp(147).EQ.1) THEN
31328  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31329  & +dd*(el1k11*el2k21+el1k21*el2k11)))
31330  ELSEIF(mstp(147).EQ.3) THEN
31331  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31332  & +dd*(el1k10*el2k20+el1k20*el2k10))
31333  ELSEIF(mstp(147).EQ.4) THEN
31334  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31335  & +dd*(el1k11*el2k21+el1k21*el2k11))
31336  ELSEIF(mstp(147).EQ.5) THEN
31337  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31338  & +dd*(el1k11*el2k20+el1k21*el2k10))
31339  ELSEIF(mstp(147).EQ.6) THEN
31340  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31341  & +dd*(el1k11*el2k21+el1k21*el2k11))
31342  ENDIF
31343  facqqg=comfac*ff*facqqg
31344  ENDIF
31345 C...Split total contribution into different colour flows just like
31346 C...in g g -> g g (recalculate kinematics for massless partons).
31347  thp=-0.5d0*sh*(1d0-cth)
31348  uhp=-0.5d0*sh*(1d0+cth)
31349  facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
31350  facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
31351  facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
31352  facggs=facgg1+facgg2+facgg3
31353  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31354  nchn=nchn+1
31355  isig(nchn,1)=21
31356  isig(nchn,2)=21
31357  isig(nchn,3)=1
31358  sigh(nchn)=facqqg*parp(ionium+2)*facgg1/facggs
31359  nchn=nchn+1
31360  isig(nchn,1)=21
31361  isig(nchn,2)=21
31362  isig(nchn,3)=2
31363  sigh(nchn)=facqqg*parp(ionium+2)*facgg2/facggs
31364  nchn=nchn+1
31365  isig(nchn,1)=21
31366  isig(nchn,2)=21
31367  isig(nchn,3)=3
31368  sigh(nchn)=facqqg*parp(ionium+2)*facgg3/facggs
31369  ENDIF
31370 
31371  ELSEIF(isub.EQ.423) THEN
31372 C...g + g -> QQ~[1S08] + g
31373  IF(mstp(145).EQ.0) THEN
31374 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31375 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31376 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31377 * & (SHTH2*THUH2*UHSH2)
31378  facqqg=comfac*paru(1)*as**3*(5d0/16d0)*sqmqqr*
31379  & (uh2/(thuh2*uhsh2)+sh2/(shth2*uhsh2)+
31380  & th2/(shth2*thuh2))*
31381  & (12d0+(shth2**2+thuh2**2+uhsh2**2)/(sqmqq*sh*th*uh))
31382  ELSE
31383  fa=paru(1)*as**3*(5d0/48d0)*sqmqqr*
31384  & (uh2/(thuh2*uhsh2)+sh2/(shth2*uhsh2)+
31385  & th2/(shth2*thuh2))*
31386  & (12d0+(shth2**2+thuh2**2+uhsh2**2)/(sqmqq*sh*th*uh))
31387  IF(mstp(147).EQ.0) THEN
31388  facqqg=comfac*fa
31389  ELSEIF(mstp(147).EQ.1) THEN
31390  facqqg=comfac*2d0*fa
31391  ELSEIF(mstp(147).EQ.3) THEN
31392  facqqg=comfac*fa
31393  ELSEIF(mstp(147).EQ.4) THEN
31394  facqqg=comfac*fa
31395  ELSEIF(mstp(147).EQ.5) THEN
31396  facqqg=0d0
31397  ELSEIF(mstp(147).EQ.6) THEN
31398  facqqg=0d0
31399  ENDIF
31400  ENDIF
31401 C...Split total contribution into different colour flows just like
31402 C...in g g -> g g (recalculate kinematics for massless partons).
31403  thp=-0.5d0*sh*(1d0-cth)
31404  uhp=-0.5d0*sh*(1d0+cth)
31405  facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
31406  facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
31407  facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
31408  facggs=facgg1+facgg2+facgg3
31409  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31410  nchn=nchn+1
31411  isig(nchn,1)=21
31412  isig(nchn,2)=21
31413  isig(nchn,3)=1
31414  sigh(nchn)=facqqg*parp(ionium+3)*facgg1/facggs
31415  nchn=nchn+1
31416  isig(nchn,1)=21
31417  isig(nchn,2)=21
31418  isig(nchn,3)=2
31419  sigh(nchn)=facqqg*parp(ionium+3)*facgg2/facggs
31420  nchn=nchn+1
31421  isig(nchn,1)=21
31422  isig(nchn,2)=21
31423  isig(nchn,3)=3
31424  sigh(nchn)=facqqg*parp(ionium+3)*facgg3/facggs
31425  ENDIF
31426 
31427  ELSEIF(isub.EQ.424) THEN
31428 C...g + g -> QQ~[3PJ8] + g
31429  poly=sh2+sh*th+th2
31430  IF(mstp(145).EQ.0) THEN
31431  facqqg=comfac*5d0*paru(1)*as**3*(3d0*sh*th*shth*poly**4
31432  & -sqmqq*poly**2*(7d0*sh**6+36d0*sh**5*th+45d0*sh**4*th2
31433  & +28d0*sh**3*th**3+45d0*sh2*th**4+36d0*sh*th**5
31434  & +7d0*th**6)
31435  & +sqmqq**2*shth*(35d0*sh**8+169d0*sh**7*th
31436  & +299d0*sh**6*th2+401d0*sh**5*th**3+418d0*sh**4*th**4
31437  & +401d0*sh**3*th**5+299d0*sh2*th**6+169d0*sh*th**7
31438  & +35d0*th**8)
31439  & -sqmqq**3*(84d0*sh**8+432d0*sh**7*th+905d0*sh**6*th2
31440  & +1287d0*sh**5*th**3+1436d0*sh**4*th**4
31441  & +1287d0*sh**3*th**5+905d0*sh2*th**6+432d0*sh*th**7
31442  & +84d0*th**8)
31443  & +sqmqq**4*shth*(126d0*sh**6+451d0*sh**5*th
31444  & +677d0*sh**4*th2+836d0*sh**3*th**3+677d0*sh2*th**4
31445  & +451d0*sh*th**5+126d0*th**6)
31446  & -3d0*sqmqq**5*(42d0*sh**6+171d0*sh**5*th
31447  & +304d0*sh**4*th2+362d0*sh**3*th**3+304d0*sh2*th**4
31448  & +171d0*sh*th**5+42d0*th**6)
31449  & +2d0*sqmqq**6*shth*(42d0*sh**4+106d0*sh**3*th
31450  & +119d0*sh2*th2+106d0*sh*th**3+42d0*th**4)
31451  & -sqmqq**7*(35d0*sh**4+99d0*sh**3*th+120d0*sh2*th2
31452  & +99d0*sh*th**3+35d0*th**4)
31453  & +7d0*sqmqq**8*shth*poly)/
31454  & (sh*th*uh*sqmqqr*sqmqq*
31455  & shth*shth2*thuh*thuh2*uhsh*uhsh2)
31456  ELSE
31457  ff=-5d0*paru(1)*as**3/(sh2*th2*uh2
31458  & *sqmqqr*sqmqq*shth*shth2*thuh*thuh2*uhsh*uhsh2)
31459  aa=sh*th*uh*(sh*th*shth*poly**4
31460  & -sqmqq*shth2*poly**2*
31461  & (sh**4+6d0*sh**3*th-6d0*sh2*th2+6d0*sh*th**3+th**4)
31462  & +sqmqq**2*shth*(5d0*sh**8+35d0*sh**7*th+49d0*sh**6*th2
31463  & +57d0*sh**5*th**3+46d0*sh**4*th**4+57d0*sh**3*th**5
31464  & +49d0*sh2*th**6+35d0*sh*th**7+5d0*th**8)
31465  & -sqmqq**3*(16d0*sh**8+104d0*sh**7*th+215d0*sh**6*th2
31466  & +291d0*sh**5*th**3+316d0*sh**4*th**4+291d0*sh**3*th**5
31467  & +215d0*sh2*th**6+104d0*sh*th**7+16d0*th**8)
31468  & +sqmqq**4*shth*(34d0*sh**6+145d0*sh**5*th
31469  & +211d0*sh**4*th2+262d0*sh**3*th**3+211d0*sh2*th**4
31470  & +145d0*sh*th**5+34d0*th**6)
31471  & -sqmqq**5*(44d0*sh**6+193d0*sh**5*th+346d0*sh**4*th2
31472  & +410d0*sh**3*th**3+346d0*sh2*th**4+193d0*sh*th**5
31473  & +44d0*th**6)
31474  & +2d0*sqmqq**6*shth*(17d0*sh**4+45d0*sh**3*th
31475  & +49d0*sh2*th2+45d0*sh*th**3+17d0*th**4)
31476  & -sqmqq**7*(3d0*sh2+2d0*sh*th+3d0*th2)
31477  & *(5d0*sh2+11d0*sh*th+5d0*th2)
31478  & +3d0*sqmqq**8*shth*poly)
31479  bb=4d0*shth2*poly**3
31480  & *(sh**4+sh**3*th-sh2*th2+sh*th**3+th**4)
31481  & -sqmqq*shth*(20d0*sh**10+84d0*sh**9*th+166d0*sh**8*th2
31482  & +231d0*sh**7*th**3+250d0*sh**6*th**4+250d0*sh**5*th**5
31483  & +250d0*sh**4*th**6+231d0*sh**3*th**7+166d0*sh2*th**8
31484  & +84d0*sh*th**9+20d0*th**10)
31485  & +sqmqq**2*shth2*(40d0*sh**8+86d0*sh**7*th
31486  & +66d0*sh**6*th2+67d0*sh**5*th**3+6d0*sh**4*th**4
31487  & +67d0*sh**3*th**5+66d0*sh2*th**6+86d0*sh*th**7
31488  & +40d0*th**8)
31489  & -sqmqq**3*shth*(40d0*sh**8+57d0*sh**7*th
31490  & -110d0*sh**6*th2-263d0*sh**5*th**3-384d0*sh**4*th**4
31491  & -263d0*sh**3*th**5-110d0*sh2*th**6+57d0*sh*th**7
31492  & +40d0*th**8)
31493  & +sqmqq**4*(20d0*sh**8-33d0*sh**7*th-368d0*sh**6*th2
31494  & -751d0*sh**5*th**3-920d0*sh**4*th**4-751d0*sh**3*th**5
31495  & -368d0*sh2*th**6-33d0*sh*th**7+20d0*th**8)
31496  & -sqmqq**5*shth*(4d0*sh**6-81d0*sh**5*th-242d0*sh**4*th2
31497  & -250d0*sh**3*th**3-242d0*sh2*th**4-81d0*sh*th**5
31498  & +4d0*th**6)
31499  & -sqmqq**6*sh*th*(41d0*sh**4+120d0*sh**3*th
31500  & +142d0*sh2*th2+120d0*sh*th**3+41d0*th**4)
31501  & +8d0*sqmqq**7*sh*th*shth*poly
31502  cc=4d0*th2*poly**3
31503  & *(-sh**4-2d0*sh**3*th+2d0*sh2*th2+3d0*sh*th**3+th**4)
31504  & -sqmqq*th2*(-20d0*sh**9-56d0*sh**8*th-24d0*sh**7*th2
31505  & +147d0*sh**6*th**3+409d0*sh**5*th**4+599d0*sh**4*th**5
31506  & +571d0*sh**3*th**6+370d0*sh2*th**7+148d0*sh*th**8
31507  & +28d0*th**9)
31508  & +sqmqq**2*(4d0*sh**10+20d0*sh**9*th-16d0*sh**8*th2
31509  & -48d0*sh**7*th**3+150d0*sh**6*th**4+611d0*sh**5*th**5
31510  & +1060d0*sh**4*th**6+1155d0*sh**3*th**7+854d0*sh2*th**8
31511  & +394d0*sh*th**9+84d0*th**10)
31512  & -sqmqq**3*shth*(20d0*sh**8+68d0*sh**7*th-20d0*sh**6*th2
31513  & +32d0*sh**5*th**3+286d0*sh**4*th**4+577d0*sh**3*th**5
31514  & +618d0*sh2*th**6+443d0*sh*th**7+140d0*th**8)
31515  & +sqmqq**4*(40d0*sh**8+152d0*sh**7*th+94d0*sh**6*th2
31516  & +38d0*sh**5*th**3+290d0*sh**4*th**4+631d0*sh**3*th**5
31517  & +738d0*sh2*th**6+513d0*sh*th**7+140d0*th**8)
31518  & -sqmqq**5*(40d0*sh**7+129d0*sh**6*th+53d0*sh**5*th2
31519  & +7d0*sh**4*th**3+129d0*sh**3*th**4+264d0*sh2*th**5
31520  & +266d0*sh*th**6+84d0*th**7)
31521  & +sqmqq**6*(20d0*sh**6+55d0*sh**5*th+2d0*sh**4*th2
31522  & -15d0*sh**3*th**3+30d0*sh2*th**4+76d0*sh*th**5
31523  & +28d0*th**6)
31524  & -sqmqq**7*shth*(4d0*sh**4+7d0*sh**3*th-14d0*sh2*th2
31525  & +7d0*sh*th**3+4*th**4)
31526  & +sqmqq**8*sh*(sh-th)**2*th
31527  dd=2d0*th2*shth2*poly**3
31528  & *(-sh2+2*sh*th+2*th2)
31529  & +sqmqq*(4d0*sh**11+22d0*sh**10*th+70d0*sh**9*th2
31530  & +115d0*sh**8*th**3+71d0*sh**7*th**4-119d0*sh**6*th**5
31531  & -381d0*sh**5*th**6-552d0*sh**4*th**7-512d0*sh**3*th**8
31532  & -320d0*sh2*th**9-126d0*sh*th**10-24d0*th**11)
31533  & -sqmqq**2*shth*(20d0*sh**9+84d0*sh**8*th
31534  & +212d0*sh**7*th2+247d0*sh**6*th**3+105d0*sh**5*th**4
31535  & -178d0*sh**4*th**5-380d0*sh**3*th**6-364d0*sh2*th**7
31536  & -210d0*sh*th**8-60d0*th**9)
31537  & +sqmqq**3*shth*(40d0*sh**8+159d0*sh**7*th
31538  & +374d0*sh**6*th2+404d0*sh**5*th**3+192d0*sh**4*th**4
31539  & -141d0*sh**3*th**5-264d0*sh2*th**6-216d0*sh*th**7
31540  & -80d0*th**8)
31541  & -sqmqq**4*(40d0*sh**8+197d0*sh**7*th+506d0*sh**6*th2
31542  & +672d0*sh**5*th**3+460d0*sh**4*th**4+79d0*sh**3*th**5
31543  & -138d0*sh2*th**6-164d0*sh*th**7-60d0*th**8)
31544  & +sqmqq**5*(20d0*sh**7+107d0*sh**6*th+267d0*sh**5*th2
31545  & +307d0*sh**4*th**3+185d0*sh**3*th**4+56d0*sh2*th**5
31546  & -30d0*sh*th**6-24d0*th**7)
31547  & -sqmqq**6*(4d0*sh**6+31d0*sh**5*th+74d0*sh**4*th2
31548  & +71d0*sh**3*th**3+46d0*sh2*th**4+10d0*sh*th**5
31549  & -4d0*th**6)
31550  & +4d0*sqmqq**7*sh*th*shth*poly
31551  IF(mstp(147).EQ.0) THEN
31552  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31553  & +dd*(el1k10*el2k20+el1k20*el2k10))
31554  ELSEIF(mstp(147).EQ.1) THEN
31555  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31556  & +dd*(el1k11*el2k21+el1k21*el2k11)))
31557  ELSEIF(mstp(147).EQ.3) THEN
31558  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31559  & +dd*(el1k10*el2k20+el1k20*el2k10))
31560  ELSEIF(mstp(147).EQ.4) THEN
31561  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31562  & +dd*(el1k11*el2k21+el1k21*el2k11))
31563  ELSEIF(mstp(147).EQ.5) THEN
31564  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31565  & +dd*(el1k11*el2k20+el1k21*el2k10))
31566  ELSEIF(mstp(147).EQ.6) THEN
31567  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31568  & +dd*(el1k11*el2k21+el1k21*el2k11))
31569  ENDIF
31570  facqqg=comfac*ff*facqqg
31571  ENDIF
31572 C...Split total contribution into different colour flows just like
31573 C...in g g -> g g (recalculate kinematics for massless partons).
31574  thp=-0.5d0*sh*(1d0-cth)
31575  uhp=-0.5d0*sh*(1d0+cth)
31576  facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
31577  facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
31578  facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
31579  facggs=facgg1+facgg2+facgg3
31580  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31581  nchn=nchn+1
31582  isig(nchn,1)=21
31583  isig(nchn,2)=21
31584  isig(nchn,3)=1
31585  sigh(nchn)=facqqg*parp(ionium+4)*facgg1/facggs
31586  nchn=nchn+1
31587  isig(nchn,1)=21
31588  isig(nchn,2)=21
31589  isig(nchn,3)=2
31590  sigh(nchn)=facqqg*parp(ionium+4)*facgg2/facggs
31591  nchn=nchn+1
31592  isig(nchn,1)=21
31593  isig(nchn,2)=21
31594  isig(nchn,3)=3
31595  sigh(nchn)=facqqg*parp(ionium+4)*facgg3/facggs
31596  ENDIF
31597 
31598  ELSEIF(isub.EQ.425) THEN
31599 C...q + g -> q + QQ~[3S18]
31600  IF(mstp(145).EQ.0) THEN
31601  facqqg=-comfac*paru(1)*as**3*(1d0/27d0)*
31602  & (4d0*(sh2+uh2)-sh*uh)*(shth2+thuh2)/
31603  & (sqmqq*sqmqqr*sh*uh*uhsh2)
31604  ELSE
31605  ff=paru(1)*as**3*(4d0*(sh2+uh2)-sh*uh)/
31606  & (54d0*sqmqq*sqmqqr*sh*uh*uhsh2)
31607  aa=shth2+thuh2
31608  bb=4d0
31609  cc=8d0
31610  dd=4d0
31611  IF(mstp(147).EQ.0) THEN
31612  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31613  & +dd*(el1k10*el2k20+el1k20*el2k10))
31614  ELSEIF(mstp(147).EQ.1) THEN
31615  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31616  & +dd*(el1k11*el2k21+el1k21*el2k11)))
31617  ELSEIF(mstp(147).EQ.3) THEN
31618  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31619  & +dd*(el1k10*el2k20+el1k20*el2k10))
31620  ELSEIF(mstp(147).EQ.4) THEN
31621  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31622  & +dd*(el1k11*el2k21+el1k21*el2k11))
31623  ELSEIF(mstp(147).EQ.5) THEN
31624  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31625  & +dd*(el1k11*el2k20+el1k21*el2k10))
31626  ELSEIF(mstp(147).EQ.6) THEN
31627  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31628  & +dd*(el1k11*el2k21+el1k21*el2k11))
31629  ENDIF
31630  facqqg=comfac*ff*facqqg
31631  ENDIF
31632 C...Split total contribution into different colour flows just like
31633 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31634 C...(recalculate kinematics for massless partons).
31635  thp=-0.5d0*sh*(1d0-cth)
31636  uhp=-0.5d0*sh*(1d0+cth)
31637  facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
31638  facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
31639  facqgs=facqg1+facqg2
31640  DO 2442 i=mmina,mmaxa
31641  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2442
31642  DO 2441 isde=1,2
31643  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2441
31644  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2441
31645  nchn=nchn+1
31646  isig(nchn,isde)=i
31647  isig(nchn,3-isde)=21
31648  isig(nchn,3)=1
31649  sigh(nchn)=facqqg*parp(ionium+2)*facqg1/facqgs
31650  nchn=nchn+1
31651  isig(nchn,isde)=i
31652  isig(nchn,3-isde)=21
31653  isig(nchn,3)=2
31654  sigh(nchn)=facqqg*parp(ionium+2)*facqg2/facqgs
31655  2441 CONTINUE
31656  2442 CONTINUE
31657 
31658  ELSEIF(isub.EQ.426) THEN
31659 C...q + g -> q + QQ~[1S08]
31660  IF(mstp(145).EQ.0) THEN
31661  facqqg=-comfac*paru(1)*as**3*(5d0/18d0)*
31662  & (sh2+uh2)/(sqmqqr*th*uhsh2)
31663  ELSE
31664  fa=-paru(1)*as**3*(5d0/54d0)*(sh2+uh2)/(sqmqqr*th*uhsh2)
31665  IF(mstp(147).EQ.0) THEN
31666  facqqg=comfac*fa
31667  ELSEIF(mstp(147).EQ.1) THEN
31668  facqqg=comfac*2d0*fa
31669  ELSEIF(mstp(147).EQ.3) THEN
31670  facqqg=comfac*fa
31671  ELSEIF(mstp(147).EQ.4) THEN
31672  facqqg=comfac*fa
31673  ELSEIF(mstp(147).EQ.5) THEN
31674  facqqg=0d0
31675  ELSEIF(mstp(147).EQ.6) THEN
31676  facqqg=0d0
31677  ENDIF
31678  ENDIF
31679 C...Split total contribution into different colour flows just like
31680 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31681 C...(recalculate kinematics for massless partons).
31682  thp=-0.5d0*sh*(1d0-cth)
31683  uhp=-0.5d0*sh*(1d0+cth)
31684  facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
31685  facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
31686  facqgs=facqg1+facqg2
31687  DO 2444 i=mmina,mmaxa
31688  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2444
31689  DO 2443 isde=1,2
31690  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2443
31691  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2443
31692  nchn=nchn+1
31693  isig(nchn,isde)=i
31694  isig(nchn,3-isde)=21
31695  isig(nchn,3)=1
31696  sigh(nchn)=facqqg*parp(ionium+3)*facqg1/facqgs
31697  nchn=nchn+1
31698  isig(nchn,isde)=i
31699  isig(nchn,3-isde)=21
31700  isig(nchn,3)=2
31701  sigh(nchn)=facqqg*parp(ionium+3)*facqg2/facqgs
31702  2443 CONTINUE
31703  2444 CONTINUE
31704 
31705  ELSEIF(isub.EQ.427) THEN
31706 C...q + g -> q + QQ~[3PJ8]
31707  IF(mstp(145).EQ.0) THEN
31708  facqqg=-comfac*paru(1)*as**3*(10d0/9d0)*
31709  & ((7d0*uhsh+8d0*th)*(sh2+uh2)
31710  & +4d0*th*(2d0*sqmqq**2-shth2-thuh2))/
31711  & (sqmqq*sqmqqr*th*uhsh2*uhsh)
31712  ELSE
31713  ff=10d0*paru(1)*as**3/
31714  & (9d0*sqmqq*sqmqqr*th2*uhsh2*uhsh)
31715  aa=th*uhsh*(2d0*sqmqq**2+shth2+thuh2)
31716  bb=8d0*(shth2+th*uh)
31717  cc=8d0*uhsh*(shth+thuh)
31718  dd=4d0*(2d0*sqmqq*sh+th*uhsh)
31719  IF(mstp(147).EQ.0) THEN
31720  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31721  & +dd*(el1k10*el2k20+el1k20*el2k10))
31722  ELSEIF(mstp(147).EQ.1) THEN
31723  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31724  & +dd*(el1k11*el2k21+el1k21*el2k11)))
31725  ELSEIF(mstp(147).EQ.3) THEN
31726  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31727  & +dd*(el1k10*el2k20+el1k20*el2k10))
31728  ELSEIF(mstp(147).EQ.4) THEN
31729  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31730  & +dd*(el1k11*el2k21+el1k21*el2k11))
31731  ELSEIF(mstp(147).EQ.5) THEN
31732  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31733  & +dd*(el1k11*el2k20+el1k21*el2k10))
31734  ELSEIF(mstp(147).EQ.6) THEN
31735  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31736  & +dd*(el1k11*el2k21+el1k21*el2k11))
31737  ENDIF
31738  facqqg=comfac*ff*facqqg
31739  ENDIF
31740 C...Split total contribution into different colour flows just like
31741 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31742 C...(recalculate kinematics for massless partons).
31743  thp=-0.5d0*sh*(1d0-cth)
31744  uhp=-0.5d0*sh*(1d0+cth)
31745  facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
31746  facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
31747  facqgs=facqg1+facqg2
31748  DO 2446 i=mmina,mmaxa
31749  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2446
31750  DO 2445 isde=1,2
31751  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2445
31752  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2445
31753  nchn=nchn+1
31754  isig(nchn,isde)=i
31755  isig(nchn,3-isde)=21
31756  isig(nchn,3)=1
31757  sigh(nchn)=facqqg*parp(ionium+4)*facqg1/facqgs
31758  nchn=nchn+1
31759  isig(nchn,isde)=i
31760  isig(nchn,3-isde)=21
31761  isig(nchn,3)=2
31762  sigh(nchn)=facqqg*parp(ionium+4)*facqg2/facqgs
31763  2445 CONTINUE
31764  2446 CONTINUE
31765 
31766  ELSEIF(isub.EQ.428) THEN
31767 C...q + q~ -> g + QQ~[3S18]
31768  IF(mstp(145).EQ.0) THEN
31769  facqqg=comfac*paru(1)*as**3*(8d0/81d0)*
31770  & (4d0*(th2+uh2)-th*uh)*(shth2+uhsh2)/
31771  & (sqmqq*sqmqqr*th*uh*thuh2)
31772  ELSE
31773  ff=-4d0*paru(1)*as**3*(4d0*(th2+uh2)-th*uh)/
31774  & (81d0*sqmqq*sqmqqr*th*uh*thuh2)
31775  aa=shth2+uhsh2
31776  bb=4d0
31777  cc=4d0
31778  dd=0d0
31779  IF(mstp(147).EQ.0) THEN
31780  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31781  & +dd*(el1k10*el2k20+el1k20*el2k10))
31782  ELSEIF(mstp(147).EQ.1) THEN
31783  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31784  & +dd*(el1k11*el2k21+el1k21*el2k11)))
31785  ELSEIF(mstp(147).EQ.3) THEN
31786  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31787  & +dd*(el1k10*el2k20+el1k20*el2k10))
31788  ELSEIF(mstp(147).EQ.4) THEN
31789  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31790  & +dd*(el1k11*el2k21+el1k21*el2k11))
31791  ELSEIF(mstp(147).EQ.5) THEN
31792  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31793  & +dd*(el1k11*el2k20+el1k21*el2k10))
31794  ELSEIF(mstp(147).EQ.6) THEN
31795  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31796  & +dd*(el1k11*el2k21+el1k21*el2k11))
31797  ENDIF
31798  facqqg=comfac*ff*facqqg
31799  ENDIF
31800 C...Split total contribution into different colour flows just like
31801 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31802 C...(recalculate kinematics for massless partons).
31803  thp=-0.5d0*sh*(1d0-cth)
31804  uhp=-0.5d0*sh*(1d0+cth)
31805  facgg1=uh/th-9d0/4d0*uh2/sh2
31806  facgg2=th/uh-9d0/4d0*th2/sh2
31807  facggs=facgg1+facgg2
31808  DO 2447 i=mmina,mmaxa
31809  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
31810  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2447
31811  nchn=nchn+1
31812  isig(nchn,1)=i
31813  isig(nchn,2)=-i
31814  isig(nchn,3)=1
31815  sigh(nchn)=facqqg*parp(ionium+2)*facgg1/facggs
31816  nchn=nchn+1
31817  isig(nchn,1)=i
31818  isig(nchn,2)=-i
31819  isig(nchn,3)=2
31820  sigh(nchn)=facqqg*parp(ionium+2)*facgg2/facggs
31821  2447 CONTINUE
31822 
31823  ELSEIF(isub.EQ.429) THEN
31824 C...q + q~ -> g + QQ~[1S08]
31825  IF(mstp(145).EQ.0) THEN
31826  facqqg=comfac*paru(1)*as**3*(20d0/27d0)*
31827  & (th2+uh2)/(sqmqqr*sh*thuh2)
31828  ELSE
31829  fa=paru(1)*as**3*(20d0/81d0)*(th2+uh2)/(sqmqqr*sh*thuh2)
31830  IF(mstp(147).EQ.0) THEN
31831  facqqg=comfac*fa
31832  ELSEIF(mstp(147).EQ.1) THEN
31833  facqqg=comfac*2d0*fa
31834  ELSEIF(mstp(147).EQ.3) THEN
31835  facqqg=comfac*fa
31836  ELSEIF(mstp(147).EQ.4) THEN
31837  facqqg=comfac*fa
31838  ELSEIF(mstp(147).EQ.5) THEN
31839  facqqg=0d0
31840  ELSEIF(mstp(147).EQ.6) THEN
31841  facqqg=0d0
31842  ENDIF
31843  ENDIF
31844 C...Split total contribution into different colour flows just like
31845 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31846 C...(recalculate kinematics for massless partons).
31847  thp=-0.5d0*sh*(1d0-cth)
31848  uhp=-0.5d0*sh*(1d0+cth)
31849  facgg1=uh/th-9d0/4d0*uh2/sh2
31850  facgg2=th/uh-9d0/4d0*th2/sh2
31851  facggs=facgg1+facgg2
31852  DO 2448 i=mmina,mmaxa
31853  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
31854  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2448
31855  nchn=nchn+1
31856  isig(nchn,1)=i
31857  isig(nchn,2)=-i
31858  isig(nchn,3)=1
31859  sigh(nchn)=facqqg*parp(ionium+3)*facgg1/facggs
31860  nchn=nchn+1
31861  isig(nchn,1)=i
31862  isig(nchn,2)=-i
31863  isig(nchn,3)=2
31864  sigh(nchn)=facqqg*parp(ionium+3)*facgg2/facggs
31865  2448 CONTINUE
31866 
31867  ELSEIF(isub.EQ.430) THEN
31868 C...q + q~ -> g + QQ~[3PJ8]
31869  IF(mstp(145).EQ.0) THEN
31870  facqqg=comfac*paru(1)*as**3*(80d0/27d0)*
31871  & ((7d0*thuh+8d0*sh)*(th2+uh2)
31872  & +4d0*sh*(2d0*sqmqq**2-shth2-uhsh2))/
31873  & (sqmqq*sqmqqr*sh*thuh2*thuh)
31874  ELSE
31875  ff=-80d0*paru(1)*as**3/(27d0*sqmqq*sqmqqr*sh2*thuh2*thuh)
31876  aa=sh*thuh*(2d0*sqmqq**2+shth2+uhsh2)
31877  bb=8d0*(uhsh2+sh*th)
31878  cc=8d0*(shth2+sh*uh)
31879  dd=4d0*(shth2+uhsh2+sh*sqmqq-sqmqq**2)
31880  IF(mstp(147).EQ.0) THEN
31881  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31882  & +dd*(el1k10*el2k20+el1k20*el2k10))
31883  ELSEIF(mstp(147).EQ.1) THEN
31884  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31885  & +dd*(el1k11*el2k21+el1k21*el2k11)))
31886  ELSEIF(mstp(147).EQ.3) THEN
31887  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31888  & +dd*(el1k10*el2k20+el1k20*el2k10))
31889  ELSEIF(mstp(147).EQ.4) THEN
31890  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31891  & +dd*(el1k11*el2k21+el1k21*el2k11))
31892  ELSEIF(mstp(147).EQ.5) THEN
31893  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31894  & +dd*(el1k11*el2k20+el1k21*el2k10))
31895  ELSEIF(mstp(147).EQ.6) THEN
31896  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31897  & +dd*(el1k11*el2k21+el1k21*el2k11))
31898  ENDIF
31899  facqqg=comfac*ff*facqqg
31900  ENDIF
31901 C...Split total contribution into different colour flows just like
31902 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31903 C...(recalculate kinematics for massless partons).
31904  thp=-0.5d0*sh*(1d0-cth)
31905  uhp=-0.5d0*sh*(1d0+cth)
31906  facgg1=uh/th-9d0/4d0*uh2/sh2
31907  facgg2=th/uh-9d0/4d0*th2/sh2
31908  facggs=facgg1+facgg2
31909  DO 2449 i=mmina,mmaxa
31910  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
31911  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2449
31912  nchn=nchn+1
31913  isig(nchn,1)=i
31914  isig(nchn,2)=-i
31915  isig(nchn,3)=1
31916  sigh(nchn)=facqqg*parp(ionium+4)*facgg1/facggs
31917  nchn=nchn+1
31918  isig(nchn,1)=i
31919  isig(nchn,2)=-i
31920  isig(nchn,3)=2
31921  sigh(nchn)=facqqg*parp(ionium+4)*facgg2/facggs
31922  2449 CONTINUE
31923 
31924  ELSEIF(isub.EQ.431) THEN
31925 C...g + g -> QQ~[3P01] + g
31926  pgtw=(sh*th+th*uh+uh*sh)/sh2
31927  qgtw=(sh*th*uh)/sh**3
31928  rgtw=sqmqq/sh
31929  IF(mstp(145).EQ.0) THEN
31930  facqqg=comfac*paru(1)*as**3*8d0/(9d0*sqmqqr*sh)*
31931  & (9d0*rgtw**2*pgtw**4*
31932  & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
31933  & -6d0*rgtw*pgtw**3*qgtw*
31934  & (2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)
31935  & -pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)
31936  & +2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)
31937  & +6d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
31938  ELSE
31939  fc1=paru(1)*as**3*8d0/(27d0*sqmqqr*sh)*
31940  & (9d0*rgtw**2*pgtw**4*
31941  & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
31942  & -6d0*rgtw*pgtw**3*qgtw*
31943  & (2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)
31944  & -pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)
31945  & +2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)
31946  & +6d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
31947  IF(mstp(147).EQ.0) THEN
31948  facqqg=comfac*fc1
31949  ELSEIF(mstp(147).EQ.1) THEN
31950  facqqg=comfac*2d0*fc1
31951  ELSEIF(mstp(147).EQ.3) THEN
31952  facqqg=comfac*fc1
31953  ELSEIF(mstp(147).EQ.4) THEN
31954  facqqg=comfac*fc1
31955  ELSEIF(mstp(147).EQ.5) THEN
31956  facqqg=0d0
31957  ELSEIF(mstp(147).EQ.6) THEN
31958  facqqg=0d0
31959  ENDIF
31960  ENDIF
31961  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31962  nchn=nchn+1
31963  isig(nchn,1)=21
31964  isig(nchn,2)=21
31965  isig(nchn,3)=1
31966  sigh(nchn)=facqqg*parp(ionium+5)
31967  ENDIF
31968 
31969  ELSEIF(isub.EQ.432) THEN
31970 C...g + g -> QQ~[3P11] + g
31971  pgtw=(sh*th+th*uh+uh*sh)/sh2
31972  qgtw=(sh*th*uh)/sh**3
31973  rgtw=sqmqq/sh
31974  IF(mstp(145).EQ.0) THEN
31975  facqqg=comfac*paru(1)*as**3*8d0/(3d0*sqmqqr*sh)*
31976  & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)
31977  & +2d0*qgtw*(-rgtw**4+5d0*rgtw**2*pgtw+pgtw**2)
31978  & -15d0*rgtw*qgtw**2)/(qgtw-rgtw*pgtw)**4
31979  ELSE
31980  ff=4d0/3d0*paru(1)*as**3*sqmqqr/shth2**2/thuh2**2/uhsh2**2
31981  c1=(4d0*pgtw**5+23d0*pgtw**2*qgtw**2
31982  & +(-14d0*pgtw**3*qgtw+3d0*qgtw**3)*rgtw
31983  & -(pgtw**4+2d0*pgtw*qgtw**2)*rgtw**2
31984  & +3d0*pgtw**2*qgtw*rgtw**3)*sh2**5
31985  c2=2d0*shth2*(sh2*thuh*(sh*thuh*(sh-th)*(sh-uh)
31986  & -th*uh*(th-uh)**2)+sh2**2*(th-uh)*(th2+uh2-sh*thuh)
31987  & *(pgtw**2-qgtw*(sh+2d0*uh)/sh))
31988  c3=2d0*uhsh2*(sh2*thuh*(sh*thuh*(sh-th)*(sh-uh)
31989  & -th*uh*(th-uh)**2)-sh2**2*(th-uh)*(th2+uh2-sh*thuh)
31990  & *(pgtw**2-qgtw*(sh+2d0*th)/sh))
31991  c4=-4d0*thuh*(th-uh)**2*
31992  & (th**3*uh**3+sh2**2*(2d0*th+uh)*(th+2d0*uh)
31993  & -sh2*th*uh*(th2+uh2))
31994  & +4d0*thuh2*(sh**3*(sh2**2+th2**2+uh2**2)
31995  & -sh*th*uh*(sh2**2+th*uh*(th2-3d0*th*uh+uh2)
31996  & +sh2*(5d0*thuh2-17d0*th*uh)))
31997  IF(mstp(147).EQ.0) THEN
31998  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
31999  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32000  ELSEIF(mstp(147).EQ.1) THEN
32001  facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32002  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32003  ELSEIF(mstp(147).EQ.3) THEN
32004  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32005  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32006  ELSEIF(mstp(147).EQ.4) THEN
32007  facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32008  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32009  ELSEIF(mstp(147).EQ.5) THEN
32010  facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32011  & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32012  ELSEIF(mstp(147).EQ.6) THEN
32013  facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32014  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32015  ENDIF
32016  facqqg=comfac*ff*facqqg
32017  ENDIF
32018  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32019  nchn=nchn+1
32020  isig(nchn,1)=21
32021  isig(nchn,2)=21
32022  isig(nchn,3)=1
32023  sigh(nchn)=facqqg*parp(ionium+5)
32024  ENDIF
32025 
32026  ELSEIF(isub.EQ.433) THEN
32027 C...g + g -> QQ~[3P21] + g
32028  pgtw=(sh*th+th*uh+uh*sh)/sh2
32029  qgtw=(sh*th*uh)/sh**3
32030  rgtw=sqmqq/sh
32031  IF(mstp(145).EQ.0) THEN
32032  facqqg=comfac*paru(1)*as**3*8d0/(9d0*sqmqqr*sh)*
32033  & (12d0*rgtw**2*pgtw**4*
32034  & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
32035  & -3d0*rgtw*pgtw**3*qgtw*
32036  & (8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)
32037  & +2d0*pgtw**2*qgtw**2*
32038  & (-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)
32039  & +rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)
32040  & +12d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
32041  ELSE
32042  ff=(16d0*paru(1)*as**3*sqmqq*sqmqqr)/
32043  & (3d0*sh2*th2*uh2*shth2**2*thuh2**2*uhsh2**2)
32044  c1=pgtw**2*qgtw*(pgtw*rgtw-qgtw)**2*(rgtw**2-2d0*pgtw)
32045  & *sh*sh2**7
32046  c2=2d0*shth2*(-sh2**3*th2**3-sh**5*th**5*uh*shth
32047  & +sh2**2*th2**2*uh2*(8d0*shth2-5d0*sh*th)
32048  & +sh**3*th**3*uh**3*shth*(17d0*shth2-2d0*sh*th)
32049  & +sh2*th2*uh2**2*(105d0*sh2*th2+64d0*sh*th*(sh2+th2)
32050  & +10d0*(sh2**2+th2**2))
32051  & +sh2*th2*uh**5*shth*(32d0*shth2+7d0*sh*th)
32052  & -uh2**3*(sh2**3-87d0*sh**3*th**3+th2**3
32053  & -45d0*sh2*th2*(sh2+th2)-5d0*sh*th*(sh2**2+th2**2))
32054  & +sh*th*uh**7*shth*(7d0*shth2+12d0*sh*th)
32055  & +4d0*sh*th*uh2**4*shth2)
32056  c3=2d0*uhsh2*(-sh2**3*uh2**3-sh**5*uh**5*th*uhsh
32057  & +sh2**2*uh2**2*th2*(8d0*uhsh2-5d0*sh*uh)
32058  & +sh**3*uh**3*th**3*uhsh*(17d0*uhsh2-2d0*sh*uh)
32059  & +sh2*uh2*th2**2*(105d0*sh2*uh2+64d0*sh*uh*(sh2+uh2)
32060  & +10d0*(sh2**2+uh2**2))
32061  & +sh2*uh2*th**5*uhsh*(32d0*uhsh2+7d0*sh*uh)
32062  & -th2**3*(sh2**3-87d0*sh**3*uh**3+uh2**3
32063  & -45d0*sh2*uh2*(sh2+uh2)-5d0*sh*uh*(sh2**2+uh2**2))
32064  & +sh*uh*th**7*uhsh*(7d0*uhsh2+12d0*sh*uh)
32065  & +4d0*sh*uh*th2**4*uhsh2)
32066  c4=-2d0*shth*uhsh*(-2d0*th2**3*uh2**3
32067  & -sh**5*th2*uh2*thuh*(5d0*th+3d0*uh)*(3d0*th+5d0*uh)
32068  & +sh2**3*(2d0*th+uh)*(th+2d0*uh)*(th2-uh2)**2
32069  & -sh*th2**2*uh2**2*thuh*(5d0*thuh2-4d0*th*uh)
32070  & -sh2*th**3*uh**3*thuh2*(13d0*thuh2-16d0*th*uh)
32071  & -sh**3*th2*uh2*(92d0*th2*uh2*thuh
32072  & +53d0*th*uh*(th**3+uh**3)+11d0*(th**5+uh**5))
32073  & -sh2**2*th*uh*(114d0*th**3*uh**3
32074  & +83d0*th2*uh2*(th2+uh2)+28d0*th*uh*(th2**2+uh2**2)
32075  & +3d0*(th2**3+uh2**3)))
32076  c5=4d0*sh*th*uh2*shth2*(2d0*sh*th+sh*uh+th*uh)**2
32077  & *(2d0*uh*sqmqq**2+shth*(sh*th-uh2))
32078  c6=4d0*sh*uh*th2*uhsh2*(2d0*sh*uh+sh*th+th*uh)**2
32079  & *(2d0*th*sqmqq**2+uhsh*(sh*uh-th2))
32080  c7=4d0*sh*th*uh2*shth*(sh2**2*th**3*(11d0*sh+16d0*th)
32081  & +sh**3*th2*uh*(31d0*sh2+83d0*sh*th+61d0*th2)
32082  & +sh2*th*uh2*(19d0*sh**3+110d0*sh2*th+156d0*sh*th2+
32083  & 82d0*th**3)
32084  & +sh*th*uh**3*(43d0*sh**3+132d0*sh2*th+124d0*sh*th2
32085  & +45d0*th**3)
32086  & +th*uh2**2*(37d0*sh**3+68d0*sh2*th+43d0*sh*th2+
32087  & 8d0*th**3)
32088  & +th*uh**5*(11d0*sh2+13d0*sh*th+5d0*th2)
32089  & +sh**3*uh**3*(3d0*uhsh2-2d0*sh*uh)
32090  & +th**5*uhsh*(5d0*uhsh2+2d0*sh*uh))
32091  c8=4d0*sh*uh*th2*uhsh*(sh2**2*uh**3*(11d0*sh+16d0*uh)
32092  & +sh**3*uh2*th*(31d0*sh2+83d0*sh*uh+61d0*uh2)
32093  & +sh2*uh*th2*(19d0*sh**3+110d0*sh2*uh+156d0*sh*uh2+
32094  & 82d0*uh**3)
32095  & +sh*uh*th**3*(43d0*sh**3+132d0*sh2*uh+124d0*sh*uh2
32096  & +45d0*uh**3)
32097  & +uh*th2**2*(37d0*sh**3+68d0*sh2*uh+43d0*sh*uh2+
32098  & 8d0*uh**3)
32099  & +uh*th**5*(11d0*sh2+13d0*sh*uh+5d0*uh2)
32100  & +sh**3*th**3*(3d0*shth2-2d0*sh*th)
32101  & +uh**5*shth*(5d0*shth2+2d0*sh*th))
32102  c9=4d0*shth*uhsh*(2d0*th**5*uh**5*thuh
32103  & +4d0*sh*th2**2*uh2**2*thuh2
32104  & -sh2*th**3*uh**3*thuh*(th2+uh2)
32105  & -2d0*sh**3*th2*uh2*(thuh2**2+2d0*th*uh*thuh2-th2*uh2)
32106  & +sh2**2*th*uh*thuh*(-th*uh*thuh2+3d0*(th2**2+uh2**2))
32107  & +sh**5*(4d0*th2*uh2*(thuh2-th*uh)
32108  & +5d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3)))
32109  c0=-4d0*(2d0*th2**3*uh2**3*sqmqq
32110  & -sh2*th2**2*uh2**2*thuh*(19d0*thuh2-4d0*th*uh)
32111  & -sh**3*th**3*uh**3*thuh2*(32d0*thuh2+29d0*th*uh)
32112  & -sh2**2*th2*uh2*thuh*(264d0*th2*uh2
32113  & +136d0*th*uh*(th2+uh2)+15d0*(th2**2+uh2**2))
32114  & +sh**5*th*uh*(-428d0*th**3*uh**3
32115  & -256d0*th2*uh2*(th2+uh2)-43d0*th*uh*(th2**2+uh2**2)
32116  & +2d0*(th2**3+uh2**3))
32117  & +sh**7*(-46d0*th**3*uh**3-21d0*th2*uh2*(th2+uh2)
32118  & +2d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3))
32119  & +sh2**3*thuh*(-134*th**3*uh**3-53d0*th2*uh2*(th2+uh2)
32120  & +4d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3)))
32121  IF(mstp(147).EQ.0) THEN
32122  facqqg=1d0/3d0*(c1*3d0
32123  & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
32124  & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
32125  & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
32126  & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
32127  & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
32128  & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
32129  & *(el1k10*el2k20-el1k11*el2k21)
32130  & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
32131  & *(el1k10*el2k20-el1k11*el2k21)
32132  & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
32133  & *(el1k20*el2k20-el1k21*el2k21)
32134  & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
32135  ELSEIF(mstp(147).EQ.1) THEN
32136  facqqg=c1*2d0
32137  & -c2*(el1k10*el2k10+el1k11*el2k11)
32138  & -c3*(el1k20*el2k20+el1k21*el2k21)
32139  & -c4*(el1k10*el2k20+el1k11*el2k21)
32140  & +c5*4d0*el1k10*el2k10*el1k11*el2k11
32141  & +c6*4d0*el1k20*el2k20*el1k21*el2k21
32142  & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
32143  & +el1k10*el2k20*el1k11*el2k11)
32144  & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
32145  & +el1k10*el2k20*el1k21*el2k21)
32146  & +c9*4d0*el1k10*el2k20*el1k11*el2k21
32147  & +c0*(el1k10*el2k10*el1k21*el2k21
32148  & +2d0*el1k10*el2k20*el1k11*el2k21
32149  & +el1k20*el2k20*el1k11*el2k11)
32150  ELSEIF(mstp(147).EQ.2) THEN
32151  facqqg=2d0*(c1
32152  & -c2*el1k11*el2k11
32153  & -c3*el1k21*el2k21
32154  & -c4*el1k11*el2k21
32155  & +c5*(el1k11*el2k11)**2
32156  & +c6*(el1k21*el2k21)**2
32157  & +c7*el1k11*el2k11*el1k11*el2k21
32158  & +c8*el1k21*el2k21*el1k11*el2k21
32159  & +(c9+c0)*(el1k11*el2k21)**2)
32160  ENDIF
32161  facqqg=comfac*ff*facqqg
32162  ENDIF
32163  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32164  nchn=nchn+1
32165  isig(nchn,1)=21
32166  isig(nchn,2)=21
32167  isig(nchn,3)=1
32168  sigh(nchn)=facqqg*parp(ionium+5)
32169  ENDIF
32170 
32171  ELSEIF(isub.EQ.434) THEN
32172 C...q + g -> q + QQ~[3P01]
32173  IF(mstp(145).EQ.0) THEN
32174  facqqg=-comfac*paru(1)*as**3*(16d0/81d0)*
32175  & (th-3d0*sqmqq)**2*(sh2+uh2)/(sqmqqr*th*uhsh2**2)
32176  ELSE
32177  fa=-paru(1)*as**3*(16d0/243d0)*
32178  & (th-3d0*sqmqq)**2*(sh2+uh2)/(sqmqqr*th*uhsh2**2)
32179  IF(mstp(147).EQ.0) THEN
32180  facqqg=comfac*fa
32181  ELSEIF(mstp(147).EQ.1) THEN
32182  facqqg=comfac*2d0*fa
32183  ELSEIF(mstp(147).EQ.3) THEN
32184  facqqg=comfac*fa
32185  ELSEIF(mstp(147).EQ.4) THEN
32186  facqqg=comfac*fa
32187  ELSEIF(mstp(147).EQ.5) THEN
32188  facqqg=0d0
32189  ELSEIF(mstp(147).EQ.6) THEN
32190  facqqg=0d0
32191  ENDIF
32192  ENDIF
32193  DO 2452 i=mmina,mmaxa
32194  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2452
32195  DO 2451 isde=1,2
32196  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2451
32197  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2451
32198  nchn=nchn+1
32199  isig(nchn,isde)=i
32200  isig(nchn,3-isde)=21
32201  isig(nchn,3)=1
32202  sigh(nchn)=facqqg*parp(ionium+5)
32203  2451 CONTINUE
32204  2452 CONTINUE
32205 
32206  ELSEIF(isub.EQ.435) THEN
32207 C...q + g -> q + QQ~[3P11]
32208  IF(mstp(145).EQ.0) THEN
32209  facqqg=-comfac*paru(1)*as**3*(32d0/27d0)*
32210  & (4d0*sqmqq*sh*uh+th*(sh2+uh2))/(sqmqqr*uhsh2**2)
32211  ELSE
32212  ff=(64d0*paru(1)*as**3*sqmqqr)/(27d0*uhsh2**2)
32213  c1=sh*uh
32214  c2=2d0*sh
32215  c3=0d0
32216  c4=2d0*(sh-uh)
32217  IF(mstp(147).EQ.0) THEN
32218  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32219  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32220  ELSEIF(mstp(147).EQ.1) THEN
32221  facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32222  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32223  ELSEIF(mstp(147).EQ.3) THEN
32224  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32225  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32226  ELSEIF(mstp(147).EQ.4) THEN
32227  facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32228  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32229  ELSEIF(mstp(147).EQ.5) THEN
32230  facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32231  & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32232  ELSEIF(mstp(147).EQ.6) THEN
32233  facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32234  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32235  ENDIF
32236  facqqg=comfac*ff*facqqg
32237  ENDIF
32238  DO 2454 i=mmina,mmaxa
32239  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2454
32240  DO 2453 isde=1,2
32241  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2453
32242  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2453
32243  nchn=nchn+1
32244  isig(nchn,isde)=i
32245  isig(nchn,3-isde)=21
32246  isig(nchn,3)=1
32247  sigh(nchn)=facqqg*parp(ionium+5)
32248  2453 CONTINUE
32249  2454 CONTINUE
32250 
32251  ELSEIF(isub.EQ.436) THEN
32252 C...q + g -> q + QQ~[3P21]
32253  IF(mstp(145).EQ.0) THEN
32254  facqqg=-comfac*paru(1)*as**3*(32d0/81d0)*
32255  & ((6d0*sqmqq**2+th2)*uhsh2
32256  & -2d0*sh*uh*(th2+6d0*sqmqq*uhsh))/
32257  & (sqmqqr*th*uhsh2**2)
32258  ELSE
32259  ff=-(32d0*paru(1)*as**3*sqmqq*sqmqqr)/(27d0*th2*uhsh2**2)
32260  c1=th*uhsh2
32261  c2=4d0*(sh2+th2+2d0*th*uhsh)
32262  c3=4d0*uhsh2
32263  c4=8d0*sh*uhsh
32264  c5=8d0*th
32265  c6=0d0
32266  c7=16d0*th
32267  c8=0d0
32268  c9=-16d0*uhsh
32269  c0=16d0*sqmqq
32270  IF(mstp(147).EQ.0) THEN
32271  facqqg=1d0/3d0*(c1*3d0
32272  & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
32273  & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
32274  & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
32275  & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
32276  & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
32277  & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
32278  & *(el1k10*el2k20-el1k11*el2k21)
32279  & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
32280  & *(el1k10*el2k20-el1k11*el2k21)
32281  & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
32282  & *(el1k20*el2k20-el1k21*el2k21)
32283  & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
32284  ELSEIF(mstp(147).EQ.1) THEN
32285  facqqg=c1*2d0
32286  & -c2*(el1k10*el2k10+el1k11*el2k11)
32287  & -c3*(el1k20*el2k20+el1k21*el2k21)
32288  & -c4*(el1k10*el2k20+el1k11*el2k21)
32289  & +c5*4d0*el1k10*el2k10*el1k11*el2k11
32290  & +c6*4d0*el1k20*el2k20*el1k21*el2k21
32291  & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
32292  & +el1k10*el2k20*el1k11*el2k11)
32293  & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
32294  & +el1k10*el2k20*el1k21*el2k21)
32295  & +c9*4d0*el1k10*el2k20*el1k11*el2k21
32296  & +c0*(el1k10*el2k10*el1k21*el2k21
32297  & +2d0*el1k10*el2k20*el1k11*el2k21
32298  & +el1k20*el2k20*el1k11*el2k11)
32299  ELSEIF(mstp(147).EQ.2) THEN
32300  facqqg=2d0*(c1
32301  & -c2*el1k11*el2k11
32302  & -c3*el1k21*el2k21
32303  & -c4*el1k11*el2k21
32304  & +c5*(el1k11*el2k11)**2
32305  & +c6*(el1k21*el2k21)**2
32306  & +c7*el1k11*el2k11*el1k11*el2k21
32307  & +c8*el1k21*el2k21*el1k11*el2k21
32308  & +(c9+c0)*(el1k11*el2k21)**2)
32309  ENDIF
32310  facqqg=comfac*ff*facqqg
32311  ENDIF
32312  DO 2456 i=mmina,mmaxa
32313  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2456
32314  DO 2455 isde=1,2
32315  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2455
32316  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2455
32317  nchn=nchn+1
32318  isig(nchn,isde)=i
32319  isig(nchn,3-isde)=21
32320  isig(nchn,3)=1
32321  sigh(nchn)=facqqg*parp(ionium+5)
32322  2455 CONTINUE
32323  2456 CONTINUE
32324 
32325  ELSEIF(isub.EQ.437) THEN
32326 C...q + q~ -> g + QQ~[3P01]
32327  IF(mstp(145).EQ.0) THEN
32328  facqqg=comfac*paru(1)*as**3*(128d0/243d0)*
32329  & (sh-3d0*sqmqq)**2*(th2+uh2)/(sqmqqr*sh*thuh2**2)
32330  ELSE
32331  fa=paru(1)*as**3*(128d0/729d0)*
32332  & (sh-3d0*sqmqq)**2*(th2+uh2)/(sqmqqr*sh*thuh2**2)
32333  IF(mstp(147).EQ.0) THEN
32334  facqqg=comfac*fa
32335  ELSEIF(mstp(147).EQ.1) THEN
32336  facqqg=comfac*2d0*fa
32337  ELSEIF(mstp(147).EQ.3) THEN
32338  facqqg=comfac*fa
32339  ELSEIF(mstp(147).EQ.4) THEN
32340  facqqg=comfac*fa
32341  ELSEIF(mstp(147).EQ.5) THEN
32342  facqqg=0d0
32343  ELSEIF(mstp(147).EQ.6) THEN
32344  facqqg=0d0
32345  ENDIF
32346  ENDIF
32347  DO 2457 i=mmina,mmaxa
32348  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32349  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2457
32350  nchn=nchn+1
32351  isig(nchn,1)=i
32352  isig(nchn,2)=-i
32353  isig(nchn,3)=1
32354  sigh(nchn)=facqqg*parp(ionium+5)
32355  2457 CONTINUE
32356 
32357  ELSEIF(isub.EQ.438) THEN
32358 C...q + q~ -> g + QQ~[3P11]
32359  IF(mstp(145).EQ.0) THEN
32360  facqqg=comfac*paru(1)*as**3*256d0/81d0*
32361  & (4d0*sqmqq*th*uh+sh*(th2+uh2))/(sqmqqr*thuh2**2)
32362  ELSE
32363  ff=-(512d0*paru(1)*as**3*sqmqqr)/(81d0*thuh2**2)
32364  c1=th*uh
32365  c2=2d0*uh
32366  c3=2d0*th
32367  c4=2d0*thuh
32368  IF(mstp(147).EQ.0) THEN
32369  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32370  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32371  ELSEIF(mstp(147).EQ.1) THEN
32372  facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32373  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32374  ELSEIF(mstp(147).EQ.3) THEN
32375  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32376  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32377  ELSEIF(mstp(147).EQ.4) THEN
32378  facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32379  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32380  ELSEIF(mstp(147).EQ.5) THEN
32381  facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32382  & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32383  ELSEIF(mstp(147).EQ.6) THEN
32384  facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32385  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32386  ENDIF
32387  facqqg=comfac*ff*facqqg
32388  ENDIF
32389  DO 2458 i=mmina,mmaxa
32390  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32391  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2458
32392  nchn=nchn+1
32393  isig(nchn,1)=i
32394  isig(nchn,2)=-i
32395  isig(nchn,3)=1
32396  sigh(nchn)=facqqg*parp(ionium+5)
32397  2458 CONTINUE
32398 
32399  ELSEIF(isub.EQ.439) THEN
32400 C...q + q~ -> g + QQ~[3P21]
32401  IF(mstp(145).EQ.0) THEN
32402  facqqg=comfac*paru(1)*as**3*(256d0/243d0)*
32403  & ((6d0*sqmqq**2+sh2)*thuh2
32404  & -2d0*th*uh*(sh2+6d0*sqmqq*thuh))/
32405  & (sqmqqr*sh*thuh2**2)
32406  ELSE
32407  ff=(256d0*paru(1)*as**3*sqmqq*sqmqqr)/(81d0*sh2*thuh2**2)
32408  c1=sh*thuh2
32409  c2=4d0*(sh2+uh2+2d0*sh*thuh)
32410  c3=4d0*(sh2+th2+2d0*sh*thuh)
32411  c4=8d0*(sh2-th*uh+2d0*sh*thuh)
32412  c5=8d0*sh
32413  c6=c5
32414  c7=16d0*sh
32415  c8=c7
32416  c9=-16d0*thuh
32417  c0=16d0*sqmqq
32418  IF(mstp(147).EQ.0) THEN
32419  facqqg=1d0/3d0*(c1*3d0
32420  & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
32421  & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
32422  & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
32423  & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
32424  & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
32425  & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
32426  & *(el1k10*el2k20-el1k11*el2k21)
32427  & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
32428  & *(el1k10*el2k20-el1k11*el2k21)
32429  & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
32430  & *(el1k20*el2k20-el1k21*el2k21)
32431  & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
32432  ELSEIF(mstp(147).EQ.1) THEN
32433  facqqg=c1*2d0
32434  & -c2*(el1k10*el2k10+el1k11*el2k11)
32435  & -c3*(el1k20*el2k20+el1k21*el2k21)
32436  & -c4*(el1k10*el2k20+el1k11*el2k21)
32437  & +c5*4d0*el1k10*el2k10*el1k11*el2k11
32438  & +c6*4d0*el1k20*el2k20*el1k21*el2k21
32439  & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
32440  & +el1k10*el2k20*el1k11*el2k11)
32441  & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
32442  & +el1k10*el2k20*el1k21*el2k21)
32443  & +c9*4d0*el1k10*el2k20*el1k11*el2k21
32444  & +c0*(el1k10*el2k10*el1k21*el2k21
32445  & +2d0*el1k10*el2k20*el1k11*el2k21
32446  & +el1k20*el2k20*el1k11*el2k11)
32447  ELSEIF(mstp(147).EQ.2) THEN
32448  facqqg=2d0*(c1
32449  & -c2*el1k11*el2k11
32450  & -c3*el1k21*el2k21
32451  & -c4*el1k11*el2k21
32452  & +c5*(el1k11*el2k11)**2
32453  & +c6*(el1k21*el2k21)**2
32454  & +c7*el1k11*el2k11*el1k11*el2k21
32455  & +c8*el1k21*el2k21*el1k11*el2k21
32456  & +(c9+c0)*(el1k11*el2k21)**2)
32457  ENDIF
32458  facqqg=comfac*ff*facqqg
32459  ENDIF
32460  DO 2459 i=mmina,mmaxa
32461  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32462  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2459
32463  nchn=nchn+1
32464  isig(nchn,1)=i
32465  isig(nchn,2)=-i
32466  isig(nchn,3)=1
32467  sigh(nchn)=facqqg*parp(ionium+5)
32468  2459 CONTINUE
32469  ENDIF
32470 C...QUARKONIA---
32471 
32472  ENDIF
32473 
32474  RETURN
32475  END
32476 
32477 C*********************************************************************
32478 
32479 C...PYSGWZ
32480 C...Subprocess cross sections for W/Z processes,
32481 C...except that longitudinal WW scattering is in Higgs sector.
32482 C...Auxiliary to PYSIGH.
32483 
32484  SUBROUTINE pysgwz(NCHN,SIGS)
32485 
32486 C...Double precision and integer declarations
32487  IMPLICIT DOUBLE PRECISION(a-h, o-z)
32488  IMPLICIT INTEGER(I-N)
32489  INTEGER PYK,PYCHGE,PYCOMP
32490 C...Parameter statement to help give large particle numbers.
32491  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
32492  &kexcit=4000000,kdimen=5000000)
32493 C...Commonblocks
32494  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
32495  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
32496  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
32497  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
32498  common/pypars/mstp(200),parp(200),msti(200),pari(200)
32499  common/pyint1/mint(400),vint(400)
32500  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
32501  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
32502  common/pyint4/mwid(500),wids(500,5)
32503  common/pytcsm/itcm(0:99),rtcm(0:99)
32504  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
32505  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
32506  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
32507  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
32508  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
32509  &/pyint2/,/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
32510 C...Local arrays and complex numbers
32511  dimension wdtp(0:400),wdte(0:400,0:5),hgz(6,3),hl3(3),hr3(3),
32512  &hl4(3),hr4(3)
32513  COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32514 
32515 C...Differential cross section expressions.
32516 
32517  IF(isub.LE.20) THEN
32518  IF(isub.EQ.1) THEN
32519 C...f + fbar -> gamma*/Z0
32520  mint(61)=2
32521  CALL pywidt(23,sh,wdtp,wdte)
32522  hs=shr*wdtp(0)
32523  facz=4d0*comfac*3d0
32524  hp0=aem/3d0*sh
32525  hp1=aem/3d0*xwc*sh
32526  DO 100 i=mmina,mmaxa
32527  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
32528  ei=kchg(iabs(i),1)/3d0
32529  ai=sign(1d0,ei)
32530  vi=ai-4d0*ei*xwv
32531  hi0=hp0
32532  IF(iabs(i).LE.10) hi0=hi0*faca/3d0
32533  hi1=hp1
32534  IF(iabs(i).LE.10) hi1=hi1*faca/3d0
32535  nchn=nchn+1
32536  isig(nchn,1)=i
32537  isig(nchn,2)=-i
32538  isig(nchn,3)=1
32539  sigh(nchn)=facz*(ei**2/sh2*hi0*hp0*vint(111)+
32540  & ei*vi*(1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*
32541  & (hi0*hp1+hi1*hp0)*vint(112)+(vi**2+ai**2)/
32542  & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114))
32543  100 CONTINUE
32544 
32545  ELSEIF(isub.EQ.2) THEN
32546 C...f + fbar' -> W+/-
32547  CALL pywidt(24,sh,wdtp,wdte)
32548  hs=shr*wdtp(0)
32549  facbw=4d0*comfac/((sh-sqmw)**2+hs**2)*3d0
32550  hp=aem/(24d0*xw)*sh
32551  DO 120 i=mmin1,mmax1
32552  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 120
32553  ia=iabs(i)
32554  DO 110 j=mmin2,mmax2
32555  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 110
32556  ja=iabs(j)
32557  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 110
32558  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
32559  & GOTO 110
32560  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32561  hi=hp*2d0
32562  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
32563  nchn=nchn+1
32564  isig(nchn,1)=i
32565  isig(nchn,2)=j
32566  isig(nchn,3)=1
32567  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
32568  sigh(nchn)=hi*facbw*hf
32569  110 CONTINUE
32570  120 CONTINUE
32571 
32572  ELSEIF(isub.EQ.15) THEN
32573 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32574  faczg=comfac*as*aem*(8d0/9d0)*(th2+uh2+2d0*sqm4*sh)/(th*uh)
32575 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32576  hfgg=0d0
32577  hfgz=0d0
32578  hfzz=0d0
32579  radc4=1d0+pyalps(sqm4)/paru(1)
32580  DO 130 i=1,min(16,mdcy(23,3))
32581  idc=i+mdcy(23,2)-1
32582  IF(mdme(idc,1).LT.0) GOTO 130
32583  imdm=0
32584  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
32585  & imdm=1
32586  IF(i.LE.8) THEN
32587  ef=kchg(i,1)/3d0
32588  af=sign(1d0,ef+0.1d0)
32589  vf=af-4d0*ef*xwv
32590  ELSEIF(i.LE.16) THEN
32591  ef=kchg(i+2,1)/3d0
32592  af=sign(1d0,ef+0.1d0)
32593  vf=af-4d0*ef*xwv
32594  ENDIF
32595  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
32596  IF(4d0*rm1.LT.1d0) THEN
32597  fcof=1d0
32598  IF(i.LE.8) fcof=3d0*radc4
32599  be34=sqrt(max(0d0,1d0-4d0*rm1))
32600  IF(imdm.EQ.1) THEN
32601  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
32602  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
32603  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
32604  & af**2*(1d0-4d0*rm1))*be34
32605  ENDIF
32606  ENDIF
32607  130 CONTINUE
32608 C...Propagators: as simulated in PYOFSH and as desired
32609  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
32610  mint15=mint(15)
32611  mint(15)=1
32612  mint(61)=1
32613  CALL pywidt(23,sqm4,wdtp,wdte)
32614  mint(15)=mint15
32615  hfaem=(paru(108)/paru(2))*(2d0/3d0)
32616  hfgg=hfgg*hfaem*vint(111)/sqm4
32617  hfgz=hfgz*hfaem*vint(112)/sqm4
32618  hfzz=hfzz*hfaem*vint(114)/sqm4
32619 C...Loop over flavours; consider full gamma/Z structure
32620  DO 140 i=mmina,mmaxa
32621  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32622  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 140
32623  ei=kchg(iabs(i),1)/3d0
32624  ai=sign(1d0,ei)
32625  vi=ai-4d0*ei*xwv
32626  nchn=nchn+1
32627  isig(nchn,1)=i
32628  isig(nchn,2)=-i
32629  isig(nchn,3)=1
32630  sigh(nchn)=faczg*(ei**2*hfgg+ei*vi*hfgz+
32631  & (vi**2+ai**2)*hfzz)/hbw4
32632  140 CONTINUE
32633 
32634  ELSEIF(isub.EQ.16) THEN
32635 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32636  facwg=comfac*as*aem/xw*2d0/9d0*(th2+uh2+2d0*sqm4*sh)/(th*uh)
32637 C...Propagators: as simulated in PYOFSH and as desired
32638  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
32639  CALL pywidt(24,sqm4,wdtp,wdte)
32640  gmmwc=sqrt(sqm4)*wdtp(0)
32641  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
32642  facwg=facwg*hbw4c/hbw4
32643  DO 160 i=mmin1,mmax1
32644  ia=iabs(i)
32645  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 160
32646  DO 150 j=mmin2,mmax2
32647  ja=iabs(j)
32648  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 150
32649  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 150
32650  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32651  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
32652  fckm=vckm((ia+1)/2,(ja+1)/2)
32653  nchn=nchn+1
32654  isig(nchn,1)=i
32655  isig(nchn,2)=j
32656  isig(nchn,3)=1
32657  sigh(nchn)=facwg*fckm*widsc
32658  150 CONTINUE
32659  160 CONTINUE
32660 
32661  ELSEIF(isub.EQ.19) THEN
32662 C...f + fbar -> gamma + (gamma*/Z0)
32663  facgz=comfac*2d0*aem**2*(th2+uh2+2d0*sqm4*sh)/(th*uh)
32664 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32665  hfgg=0d0
32666  hfgz=0d0
32667  hfzz=0d0
32668  radc4=1d0+pyalps(sqm4)/paru(1)
32669  DO 170 i=1,min(16,mdcy(23,3))
32670  idc=i+mdcy(23,2)-1
32671  IF(mdme(idc,1).LT.0) GOTO 170
32672  imdm=0
32673  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
32674  & imdm=1
32675  IF(i.LE.8) THEN
32676  ef=kchg(i,1)/3d0
32677  af=sign(1d0,ef+0.1d0)
32678  vf=af-4d0*ef*xwv
32679  ELSEIF(i.LE.16) THEN
32680  ef=kchg(i+2,1)/3d0
32681  af=sign(1d0,ef+0.1d0)
32682  vf=af-4d0*ef*xwv
32683  ENDIF
32684  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
32685  IF(4d0*rm1.LT.1d0) THEN
32686  fcof=1d0
32687  IF(i.LE.8) fcof=3d0*radc4
32688  be34=sqrt(max(0d0,1d0-4d0*rm1))
32689  IF(imdm.EQ.1) THEN
32690  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
32691  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
32692  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
32693  & af**2*(1d0-4d0*rm1))*be34
32694  ENDIF
32695  ENDIF
32696  170 CONTINUE
32697 C...Propagators: as simulated in PYOFSH and as desired
32698  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
32699  mint15=mint(15)
32700  mint(15)=1
32701  mint(61)=1
32702  CALL pywidt(23,sqm4,wdtp,wdte)
32703  mint(15)=mint15
32704  hfaem=(paru(108)/paru(2))*(2d0/3d0)
32705  hfgg=hfgg*hfaem*vint(111)/sqm4
32706  hfgz=hfgz*hfaem*vint(112)/sqm4
32707  hfzz=hfzz*hfaem*vint(114)/sqm4
32708 C...Loop over flavours; consider full gamma/Z structure
32709  DO 180 i=mmina,mmaxa
32710  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 180
32711  ei=kchg(iabs(i),1)/3d0
32712  ai=sign(1d0,ei)
32713  vi=ai-4d0*ei*xwv
32714  fcoi=1d0
32715  IF(iabs(i).LE.10) fcoi=faca/3d0
32716  nchn=nchn+1
32717  isig(nchn,1)=i
32718  isig(nchn,2)=-i
32719  isig(nchn,3)=1
32720  sigh(nchn)=facgz*fcoi*ei**2*(ei**2*hfgg+ei*vi*hfgz+
32721  & (vi**2+ai**2)*hfzz)/hbw4
32722  180 CONTINUE
32723 
32724  ELSEIF(isub.EQ.20) THEN
32725 C...f + fbar' -> gamma + W+/-
32726  facgw=comfac*0.5d0*aem**2/xw
32727 C...Propagators: as simulated in PYOFSH and as desired
32728  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
32729  CALL pywidt(24,sqm4,wdtp,wdte)
32730  gmmwc=sqrt(sqm4)*wdtp(0)
32731  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
32732  facgw=facgw*hbw4c/hbw4
32733 C...Anomalous couplings
32734  term1=(th2+uh2+2d0*sqm4*sh)/(th*uh)
32735  term2=0d0
32736  term3=0d0
32737  IF(itcm(5).GE.1.AND.itcm(5).LE.4) THEN
32738  term2=rtcm(46)*(th-uh)/(th+uh)
32739  term3=0.5d0*rtcm(46)**2*(th*uh+(th2+uh2)*sh/
32740  & (4d0*sqmw))/(th+uh)**2
32741  ENDIF
32742  DO 200 i=mmin1,mmax1
32743  ia=iabs(i)
32744  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 200
32745  DO 190 j=mmin2,mmax2
32746  ja=iabs(j)
32747  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 190
32748  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 190
32749  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
32750  & GOTO 190
32751  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32752  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
32753  IF(ia.LE.10) THEN
32754  facwr=uh/(th+uh)-1d0/3d0
32755  fckm=vckm((ia+1)/2,(ja+1)/2)
32756  fcoi=faca/3d0
32757  ELSE
32758  facwr=-th/(th+uh)
32759  fckm=1d0
32760  fcoi=1d0
32761  ENDIF
32762  facwk=term1*facwr**2+term2*facwr+term3
32763  nchn=nchn+1
32764  isig(nchn,1)=i
32765  isig(nchn,2)=j
32766  isig(nchn,3)=1
32767  sigh(nchn)=facgw*facwk*fcoi*fckm*widsc
32768  190 CONTINUE
32769  200 CONTINUE
32770  ENDIF
32771 
32772  ELSEIF(isub.LE.40) THEN
32773  IF(isub.EQ.22) THEN
32774 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32775 C...Kinematics dependence
32776  faczz=comfac*aem**2*((th2+uh2+2d0*(sqm3+sqm4)*sh)/(th*uh)-
32777  & sqm3*sqm4*(1d0/th2+1d0/uh2))
32778 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32779  DO 220 i=1,6
32780  DO 210 j=1,3
32781  hgz(i,j)=0d0
32782  210 CONTINUE
32783  220 CONTINUE
32784  radc3=1d0+pyalps(sqm3)/paru(1)
32785  radc4=1d0+pyalps(sqm4)/paru(1)
32786  DO 230 i=1,min(16,mdcy(23,3))
32787  idc=i+mdcy(23,2)-1
32788  IF(mdme(idc,1).LT.0) GOTO 230
32789  imdm=0
32790  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2) imdm=1
32791  IF(mdme(idc,1).EQ.4.OR.mdme(idc,1).EQ.5) imdm=mdme(idc,1)-2
32792  IF(i.LE.8) THEN
32793  ef=kchg(i,1)/3d0
32794  af=sign(1d0,ef+0.1d0)
32795  vf=af-4d0*ef*xwv
32796  ELSEIF(i.LE.16) THEN
32797  ef=kchg(i+2,1)/3d0
32798  af=sign(1d0,ef+0.1d0)
32799  vf=af-4d0*ef*xwv
32800  ENDIF
32801  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm3
32802  IF(4d0*rm1.LT.1d0) THEN
32803  fcof=1d0
32804  IF(i.LE.8) fcof=3d0*radc3
32805  be34=sqrt(max(0d0,1d0-4d0*rm1))
32806  IF(imdm.GE.1) THEN
32807  hgz(1,imdm)=hgz(1,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
32808  hgz(2,imdm)=hgz(2,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
32809  hgz(3,imdm)=hgz(3,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
32810  & af**2*(1d0-4d0*rm1))*be34
32811  ENDIF
32812  ENDIF
32813  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
32814  IF(4d0*rm1.LT.1d0) THEN
32815  fcof=1d0
32816  IF(i.LE.8) fcof=3d0*radc4
32817  be34=sqrt(max(0d0,1d0-4d0*rm1))
32818  IF(imdm.GE.1) THEN
32819  hgz(4,imdm)=hgz(4,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
32820  hgz(5,imdm)=hgz(5,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
32821  hgz(6,imdm)=hgz(6,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
32822  & af**2*(1d0-4d0*rm1))*be34
32823  ENDIF
32824  ENDIF
32825  230 CONTINUE
32826 C...Propagators: as simulated in PYOFSH and as desired
32827  hbw3=(1d0/paru(1))*gmmz/((sqm3-sqmz)**2+gmmz**2)
32828  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
32829  mint15=mint(15)
32830  mint(15)=1
32831  mint(61)=1
32832  CALL pywidt(23,sqm3,wdtp,wdte)
32833  mint(15)=mint15
32834  hfaem=(paru(108)/paru(2))*(2d0/3d0)
32835  DO 240 j=1,3
32836  hgz(1,j)=hgz(1,j)*hfaem*vint(111)/sqm3
32837  hgz(2,j)=hgz(2,j)*hfaem*vint(112)/sqm3
32838  hgz(3,j)=hgz(3,j)*hfaem*vint(114)/sqm3
32839  240 CONTINUE
32840  mint15=mint(15)
32841  mint(15)=1
32842  mint(61)=1
32843  CALL pywidt(23,sqm4,wdtp,wdte)
32844  mint(15)=mint15
32845  hfaem=(paru(108)/paru(2))*(2d0/3d0)
32846  DO 250 j=1,3
32847  hgz(4,j)=hgz(4,j)*hfaem*vint(111)/sqm4
32848  hgz(5,j)=hgz(5,j)*hfaem*vint(112)/sqm4
32849  hgz(6,j)=hgz(6,j)*hfaem*vint(114)/sqm4
32850  250 CONTINUE
32851 C...Loop over flavours; separate left- and right-handed couplings
32852  DO 270 i=mmina,mmaxa
32853  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 270
32854  ei=kchg(iabs(i),1)/3d0
32855  ai=sign(1d0,ei)
32856  vi=ai-4d0*ei*xwv
32857  vali=vi-ai
32858  vari=vi+ai
32859  fcoi=1d0
32860  IF(iabs(i).LE.10) fcoi=faca/3d0
32861  DO 260 j=1,3
32862  hl3(j)=ei**2*hgz(1,j)+ei*vali*hgz(2,j)+vali**2*hgz(3,j)
32863  hr3(j)=ei**2*hgz(1,j)+ei*vari*hgz(2,j)+vari**2*hgz(3,j)
32864  hl4(j)=ei**2*hgz(4,j)+ei*vali*hgz(5,j)+vali**2*hgz(6,j)
32865  hr4(j)=ei**2*hgz(4,j)+ei*vari*hgz(5,j)+vari**2*hgz(6,j)
32866  260 CONTINUE
32867  faclr=hl3(1)*hl4(1)+hl3(1)*(hl4(2)+hl4(3))+
32868  & hl4(1)*(hl3(2)+hl3(3))+hl3(2)*hl4(3)+hl4(2)*hl3(3)+
32869  & hr3(1)*hr4(1)+hr3(1)*(hr4(2)+hr4(3))+
32870  & hr4(1)*(hr3(2)+hr3(3))+hr3(2)*hr4(3)+hr4(2)*hr3(3)
32871  nchn=nchn+1
32872  isig(nchn,1)=i
32873  isig(nchn,2)=-i
32874  isig(nchn,3)=1
32875  sigh(nchn)=0.5d0*faczz*fcoi*faclr/(hbw3*hbw4)
32876  270 CONTINUE
32877 
32878  ELSEIF(isub.EQ.23) THEN
32879 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32880  faczw=comfac*0.5d0*(aem/xw)**2
32881  faczw=faczw*wids(23,2)
32882  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
32883  facbw=1d0/((sh-sqmw)**2+gmmw**2)
32884  DO 290 i=mmin1,mmax1
32885  ia=iabs(i)
32886  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 290
32887  DO 280 j=mmin2,mmax2
32888  ja=iabs(j)
32889  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 280
32890  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 280
32891  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
32892  & GOTO 280
32893  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32894  ei=kchg(ia,1)/3d0
32895  ai=sign(1d0,ei+0.1d0)
32896  vi=ai-4d0*ei*xwv
32897  ej=kchg(ja,1)/3d0
32898  aj=sign(1d0,ej+0.1d0)
32899  vj=aj-4d0*ej*xwv
32900  IF(vi+ai.GT.0) THEN
32901  visav=vi
32902  aisav=ai
32903  vi=vj
32904  ai=aj
32905  vj=visav
32906  aj=aisav
32907  ENDIF
32908  fckm=1d0
32909  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
32910  fcoi=1d0
32911  IF(ia.LE.10) fcoi=faca/3d0
32912  nchn=nchn+1
32913  isig(nchn,1)=i
32914  isig(nchn,2)=j
32915  isig(nchn,3)=1
32916  sigh(nchn)=faczw*fcoi*fckm*(facbw*((9d0-8d0*xw)/4d0*thuh+
32917  & (8d0*xw-6d0)/4d0*sh*(sqm3+sqm4))+(thuh-sh*(sqm3+sqm4))*
32918  & (sh-sqmw)*facbw*0.5d0*((vj+aj)/th-(vi+ai)/uh)+
32919  & thuh/(16d0*xw1)*((vj+aj)**2/th2+(vi+ai)**2/uh2)+
32920  & sh*(sqm3+sqm4)/(8d0*xw1)*(vi+ai)*(vj+aj)/(th*uh))*
32921  & wids(24,(5-kchw)/2)
32922 C***Protect against slightly negative cross sections. (Reason yet to be
32923 C***sorted out. One possibility: addition of width to the W propagator.)
32924  sigh(nchn)=max(0d0,sigh(nchn))
32925  280 CONTINUE
32926  290 CONTINUE
32927 
32928  ELSEIF(isub.EQ.25) THEN
32929 C...f + fbar -> W+ + W-
32930 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
32931  gmmzc=gmmz
32932  hbwzc=sh**2/((sh-sqmz)**2+gmmzc**2)
32933  hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
32934  CALL pywidt(24,sqm3,wdtp,wdte)
32935  gmmw3=sqrt(sqm3)*wdtp(0)
32936  hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
32937  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
32938  CALL pywidt(24,sqm4,wdtp,wdte)
32939  gmmw4=sqrt(sqm4)*wdtp(0)
32940  hbw4c=gmmw4/((sqm4-sqmw)**2+gmmw4**2)
32941 C...Kinematical functions
32942  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
32943  thuh34=(2d0*sh*(sqm3+sqm4)+thuh)/(sqm3*sqm4)
32944  gs=(((sh-sqm3-sqm4)**2-4d0*sqm3*sqm4)*thuh34+12d0*thuh)/sh2
32945  gt=thuh34+4d0*thuh/th2
32946  gst=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/th)/sh
32947  gu=thuh34+4d0*thuh/uh2
32948  gsu=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/uh)/sh
32949 C...Common factors and couplings
32950  facww=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)
32951  facww=facww*wids(24,1)
32952  cgg=aem**2/2d0
32953  cgz=aem**2/(4d0*xw)*hbwzc*(1d0-sqmz/sh)
32954  czz=aem**2/(32d0*xw**2)*hbwzc
32955  cng=aem**2/(4d0*xw)
32956  cnz=aem**2/(16d0*xw**2)*hbwzc*(1d0-sqmz/sh)
32957  cnn=aem**2/(16d0*xw**2)
32958 C...Coulomb factor for W+W- pair
32959  IF(mstp(40).GE.1.AND.mstp(40).LE.3) THEN
32960  coule=(sh-4d0*sqmw)/(4d0*pmas(24,1))
32961  coulp=max(1d-10,0.5d0*be34*sqrt(sh))
32962  IF(coule.LT.100d0*pmas(24,2)) THEN
32963  coulp1=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
32964  & pmas(24,2)**2)-coule))
32965  ELSE
32966  coulp1=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/coule))
32967  ENDIF
32968  IF(coule.GT.-100d0*pmas(24,2)) THEN
32969  coulp2=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
32970  & pmas(24,2)**2)+coule))
32971  ELSE
32972  coulp2=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/
32973  & abs(coule)))
32974  ENDIF
32975  IF(mstp(40).EQ.1) THEN
32976  couldc=paru(1)-2d0*atan((coulp1**2+coulp2**2-coulp**2)/
32977  & max(1d-10,2d0*coulp*coulp1))
32978  faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
32979  ELSEIF(mstp(40).EQ.2) THEN
32980  coulck=dcmplx(dble(coulp1),dble(coulp2))
32981  coulcp=dcmplx(0d0,dble(coulp))
32982  coulcd=(coulck+coulcp)/(coulck-coulcp)
32983  coulcr=1d0+dble(paru(101)*sqrt(sh))/
32984  & (4d0*coulcp)*log(coulcd)
32985  coulcs=dcmplx(0d0,0d0)
32986  nstp=100
32987  DO 300 istp=1,nstp
32988  coulxx=(istp-0.5)/nstp
32989  coulcs=coulcs+(1d0/coulxx)*log((1d0+coulxx*coulcd)/
32990  & (1d0+coulxx/coulcd))
32991  300 CONTINUE
32992  coulcr=coulcr+dble(paru(101)**2*sh)/(16d0*coulcp*coulck)*
32993  & (coulcs/nstp)
32994  faccou=abs(coulcr)**2
32995  ELSEIF(mstp(40).EQ.3) THEN
32996  couldc=paru(1)-2d0*(1d0-be34)**2*atan((coulp1**2+
32997  & coulp2**2-coulp**2)/max(1d-10,2d0*coulp*coulp1))
32998  faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
32999  ENDIF
33000  ELSEIF(mstp(40).EQ.4) THEN
33001  faccou=1d0+0.5d0*paru(101)*paru(1)/max(1d-5,be34)
33002  ELSE
33003  faccou=1d0
33004  ENDIF
33005  vint(95)=faccou
33006  facww=facww*faccou
33007 C...Loop over allowed flavours
33008  DO 310 i=mmina,mmaxa
33009  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 310
33010  ei=kchg(iabs(i),1)/3d0
33011  ai=sign(1d0,ei+0.1d0)
33012  vi=ai-4d0*ei*xwv
33013  fcoi=1d0
33014  IF(iabs(i).LE.10) fcoi=faca/3d0
33015  IF(mstp(50).LE.0.OR.iabs(i).LE.10) THEN
33016  IF(ai.LT.0d0) THEN
33017  dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs+
33018  & (cng*ei+cnz*(vi+ai))*gst+cnn*gt
33019  ELSE
33020  dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs-
33021  & (cng*ei+cnz*(vi+ai))*gsu+cnn*gu
33022  ENDIF
33023  ELSE
33024  xmw02=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
33025  bet=sqrt(1d0-4d0*xmw02/sh)
33026  gat=1d0/sqrt(1d0-bet**2)
33027  sthe2=1d0-cth**2
33028  ampzg=bet**3*(16d0+(4d0*bet**2*gat**2+3d0/gat**2)*sthe2)
33029  ampnu=bet*(2d0+bet**2*gat**2*sthe2/2d0+
33030  & 2d0*bet**2*(1d0-bet**2)*sthe2/(1d0-2d0*bet*cth+bet**2)**2)
33031  ampng=bet*((1d0+bet**2)*(4d0+bet**2*gat**2*sthe2)+
33032  & 2d0*(1d0-bet**2)*(bet**2*sthe2-2d0*(1d0-bet**2))/
33033  & (1d0-2d0*bet*cth+bet**2))
33034  propi1=(0.25d0*sqmz/xmw02)*hbwzc*(1d0-sqmz/sh)
33035  propi2=(0.25d0*sqmz/xmw02)**2*hbwzc
33036  a0=(2d0*(xmw02/sqmz)-(1d0-bet**2)*xw)*poll
33037  a1=(2d0*(xmw02/sqmz)**2-2*xmw02/sqmz*(1d0-bet**2)*xw)*poll
33038  a2=(1d0-bet**2)**2*xw**2*(polr+poll)/2d0
33039  atot=ampnu*poll+(a1+a2)*propi2*ampzg-a0*propi1*ampng
33040  atot=atot*cnn/sqmw*sh/bet*2d0
33041  dsigww=atot
33042  ENDIF
33043  nchn=nchn+1
33044  isig(nchn,1)=i
33045  isig(nchn,2)=-i
33046  isig(nchn,3)=1
33047  sigh(nchn)=facww*fcoi*dsigww
33048  310 CONTINUE
33049 
33050  ELSEIF(isub.EQ.30) THEN
33051 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33052  fzq=comfac*faca*as*aem*(1d0/3d0)*(sh2+uh2+2d0*sqm4*th)/
33053  & (-sh*uh)
33054 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33055  hfgg=0d0
33056  hfgz=0d0
33057  hfzz=0d0
33058  radc4=1d0+pyalps(sqm4)/paru(1)
33059  DO 320 i=1,min(16,mdcy(23,3))
33060  idc=i+mdcy(23,2)-1
33061  IF(mdme(idc,1).LT.0) GOTO 320
33062  imdm=0
33063  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33064  & imdm=1
33065  IF(i.LE.8) THEN
33066  ef=kchg(i,1)/3d0
33067  af=sign(1d0,ef+0.1d0)
33068  vf=af-4d0*ef*xwv
33069  ELSEIF(i.LE.16) THEN
33070  ef=kchg(i+2,1)/3d0
33071  af=sign(1d0,ef+0.1d0)
33072  vf=af-4d0*ef*xwv
33073  ENDIF
33074  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33075  IF(4d0*rm1.LT.1d0) THEN
33076  fcof=1d0
33077  IF(i.LE.8) fcof=3d0*radc4
33078  be34=sqrt(max(0d0,1d0-4d0*rm1))
33079  IF(imdm.EQ.1) THEN
33080  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33081  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33082  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33083  & af**2*(1d0-4d0*rm1))*be34
33084  ENDIF
33085  ENDIF
33086  320 CONTINUE
33087 C...Propagators: as simulated in PYOFSH and as desired
33088  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33089  mint15=mint(15)
33090  mint(15)=1
33091  mint(61)=1
33092  CALL pywidt(23,sqm4,wdtp,wdte)
33093  mint(15)=mint15
33094  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33095  hfgg=hfgg*hfaem*vint(111)/sqm4
33096  hfgz=hfgz*hfaem*vint(112)/sqm4
33097  hfzz=hfzz*hfaem*vint(114)/sqm4
33098 C...Loop over flavours; consider full gamma/Z structure
33099  DO 340 i=mmina,mmaxa
33100  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 340
33101  ei=kchg(iabs(i),1)/3d0
33102  ai=sign(1d0,ei)
33103  vi=ai-4d0*ei*xwv
33104  faczq=fzq*(ei**2*hfgg+ei*vi*hfgz+
33105  & (vi**2+ai**2)*hfzz)/hbw4
33106  DO 330 isde=1,2
33107  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 330
33108  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 330
33109  nchn=nchn+1
33110  isig(nchn,isde)=i
33111  isig(nchn,3-isde)=21
33112  isig(nchn,3)=1
33113  sigh(nchn)=faczq
33114  330 CONTINUE
33115  340 CONTINUE
33116 
33117  ELSEIF(isub.EQ.31) THEN
33118 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33119  facwq=comfac*faca*as*aem/xw*1d0/12d0*
33120  & (sh2+uh2+2d0*sqm4*th)/(-sh*uh)
33121 C...Propagators: as simulated in PYOFSH and as desired
33122  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33123  CALL pywidt(24,sqm4,wdtp,wdte)
33124  gmmwc=sqrt(sqm4)*wdtp(0)
33125  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33126  facwq=facwq*hbw4c/hbw4
33127  DO 360 i=mmina,mmaxa
33128  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 360
33129  ia=iabs(i)
33130  kchw=isign(1,kchg(ia,1)*isign(1,i))
33131  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33132  DO 350 isde=1,2
33133  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 350
33134  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 350
33135  nchn=nchn+1
33136  isig(nchn,isde)=i
33137  isig(nchn,3-isde)=21
33138  isig(nchn,3)=1
33139  sigh(nchn)=facwq*vint(180+i)*widsc
33140  350 CONTINUE
33141  360 CONTINUE
33142 
33143  ELSEIF(isub.EQ.35) THEN
33144 C...f + gamma -> f + (gamma*/Z0)
33145  IF(mint(15).EQ.22.AND.vint(3).LT.0d0) THEN
33146  fzqn=sh2+uh2+2d0*(sqm4-vint(3)**2)*th
33147  fzqdtm=vint(3)**2*sqm4-sh*(uh-vint(4)**2)
33148  ELSEIF(mint(16).EQ.22.AND.vint(4).LT.0d0) THEN
33149  fzqn=sh2+uh2+2d0*(sqm4-vint(4)**2)*th
33150  fzqdtm=vint(4)**2*sqm4-sh*(uh-vint(3)**2)
33151  ELSE
33152  fzqn=sh2+uh2+2d0*sqm4*th
33153  fzqdtm=-sh*uh
33154  ENDIF
33155  fzqn=comfac*2d0*aem**2*max(0d0,fzqn)
33156 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33157  hfgg=0d0
33158  hfgz=0d0
33159  hfzz=0d0
33160  radc4=1d0+pyalps(sqm4)/paru(1)
33161  DO 370 i=1,min(16,mdcy(23,3))
33162  idc=i+mdcy(23,2)-1
33163  IF(mdme(idc,1).LT.0) GOTO 370
33164  imdm=0
33165  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33166  & imdm=1
33167  IF(i.LE.8) THEN
33168  ef=kchg(i,1)/3d0
33169  af=sign(1d0,ef+0.1d0)
33170  vf=af-4d0*ef*xwv
33171  ELSEIF(i.LE.16) THEN
33172  ef=kchg(i+2,1)/3d0
33173  af=sign(1d0,ef+0.1d0)
33174  vf=af-4d0*ef*xwv
33175  ENDIF
33176  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33177  IF(4d0*rm1.LT.1d0) THEN
33178  fcof=1d0
33179  IF(i.LE.8) fcof=3d0*radc4
33180  be34=sqrt(max(0d0,1d0-4d0*rm1))
33181  IF(imdm.EQ.1) THEN
33182  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33183  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33184  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33185  & af**2*(1d0-4d0*rm1))*be34
33186  ENDIF
33187  ENDIF
33188  370 CONTINUE
33189 C...Propagators: as simulated in PYOFSH and as desired
33190  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33191  mint15=mint(15)
33192  mint(15)=1
33193  mint(61)=1
33194  CALL pywidt(23,sqm4,wdtp,wdte)
33195  mint(15)=mint15
33196  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33197  hfgg=hfgg*hfaem*vint(111)/sqm4
33198  hfgz=hfgz*hfaem*vint(112)/sqm4
33199  hfzz=hfzz*hfaem*vint(114)/sqm4
33200 C...Loop over flavours; consider full gamma/Z structure
33201  DO 390 i=mmina,mmaxa
33202  IF(i.EQ.0) GOTO 390
33203  ei=kchg(iabs(i),1)/3d0
33204  ai=sign(1d0,ei)
33205  vi=ai-4d0*ei*xwv
33206  faczq=ei**2*(ei**2*hfgg+ei*vi*hfgz+
33207  & (vi**2+ai**2)*hfzz)/hbw4
33208  fzqd=max(pmas(iabs(i),1)**2*sqm4,fzqdtm)
33209  DO 380 isde=1,2
33210  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 380
33211  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 380
33212  nchn=nchn+1
33213  isig(nchn,isde)=i
33214  isig(nchn,3-isde)=22
33215  isig(nchn,3)=1
33216  sigh(nchn)=faczq*fzqn/fzqd
33217  380 CONTINUE
33218  390 CONTINUE
33219 
33220  ELSEIF(isub.EQ.36) THEN
33221 C...f + gamma -> f' + W+/-
33222  fwq=comfac*aem**2/(2d0*xw)*
33223  & (sh2+uh2+2d0*sqm4*th)/(sqpth*sqm4-sh*uh)
33224 C...Propagators: as simulated in PYOFSH and as desired
33225  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33226  CALL pywidt(24,sqm4,wdtp,wdte)
33227  gmmwc=sqrt(sqm4)*wdtp(0)
33228  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33229  fwq=fwq*hbw4c/hbw4
33230  DO 410 i=mmina,mmaxa
33231  IF(i.EQ.0) GOTO 410
33232  ia=iabs(i)
33233  eia=abs(kchg(iabs(i),1)/3d0)
33234  facwq=fwq*(eia-sh/(sh+uh))**2
33235  kchw=isign(1,kchg(ia,1)*isign(1,i))
33236  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33237  DO 400 isde=1,2
33238  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 400
33239  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 400
33240  nchn=nchn+1
33241  isig(nchn,isde)=i
33242  isig(nchn,3-isde)=22
33243  isig(nchn,3)=1
33244  sigh(nchn)=facwq*vint(180+i)*widsc
33245  400 CONTINUE
33246  410 CONTINUE
33247  ENDIF
33248 
33249  ELSEIF(isub.LE.100) THEN
33250  IF(isub.EQ.69) THEN
33251 C...gamma + gamma -> W+ + W-
33252  sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
33253  fprop=sh2/((sqmwe-th)*(sqmwe-uh))
33254  facww=comfac*6d0*aem**2*(1d0-fprop*(4d0/3d0+2d0*sqmwe/sh)+
33255  & fprop**2*(2d0/3d0+2d0*(sqmwe/sh)**2))*wids(24,1)
33256  IF(kfac(1,22)*kfac(2,22).EQ.0) GOTO 420
33257  nchn=nchn+1
33258  isig(nchn,1)=22
33259  isig(nchn,2)=22
33260  isig(nchn,3)=1
33261  sigh(nchn)=facww
33262  420 CONTINUE
33263 
33264  ELSEIF(isub.EQ.70) THEN
33265 C...gamma + W+/- -> Z0 + W+/-
33266  sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
33267  fprop=(th-sqmwe)**2/(-sh*(sqmwe-uh))
33268  faczw=comfac*6d0*aem**2*(xw1/xw)*
33269  & (1d0-fprop*(4d0/3d0+2d0*sqmwe/(th-sqmwe))+
33270  & fprop**2*(2d0/3d0+2d0*(sqmwe/(th-sqmwe))**2))*wids(23,2)
33271  DO 440 kchw=1,-1,-2
33272  DO 430 isde=1,2
33273  IF(kfac(isde,22)*kfac(3-isde,24*kchw).EQ.0) GOTO 430
33274  nchn=nchn+1
33275  isig(nchn,isde)=22
33276  isig(nchn,3-isde)=24*kchw
33277  isig(nchn,3)=1
33278  sigh(nchn)=faczw*wids(24,(5-kchw)/2)
33279  430 CONTINUE
33280  440 CONTINUE
33281  ENDIF
33282  ENDIF
33283 
33284  RETURN
33285  END
33286 
33287 C*********************************************************************
33288 
33289 C...PYSGHG
33290 C...Subprocess cross sections for Higgs processes,
33291 C...except Higgs pairs in PYSGSU, but including WW scattering.
33292 C...Auxiliary to PYSIGH.
33293 
33294  SUBROUTINE pysghg(NCHN,SIGS)
33295 
33296 C...Double precision and integer declarations
33297  IMPLICIT DOUBLE PRECISION(a-h, o-z)
33298  IMPLICIT INTEGER(I-N)
33299  INTEGER PYK,PYCHGE,PYCOMP
33300 C...Parameter statement to help give large particle numbers.
33301  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
33302  &kexcit=4000000,kdimen=5000000)
33303 C...Commonblocks
33304  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
33305  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
33306  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
33307  common/pypars/mstp(200),parp(200),msti(200),pari(200)
33308  common/pyint1/mint(400),vint(400)
33309  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
33310  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
33311  common/pyint4/mwid(500),wids(500,5)
33312  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
33313  common/pymssm/imss(0:99),rmss(0:99)
33314  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
33315  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
33316  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
33317  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
33318  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
33319  &/pyint3/,/pyint4/,/pysubs/,/pymssm/,/pysgcm/
33320 C...Local arrays and complex variables
33321  dimension wdtp(0:400),wdte(0:400,0:5)
33322  COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33323  COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33324 
33325 C...Convert H or A process into equivalent h one
33326  ihigg=1
33327  kfhigg=25
33328  IF(isub.EQ.401.OR.isub.EQ.402) THEN
33329  kfhigg=kfpr(isub,1)
33330  END IF
33331  IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
33332  &isub.LE.190)) THEN
33333  ihigg=2
33334  IF(mod(isub-1,10).GE.5) ihigg=3
33335  kfhigg=33+ihigg
33336  IF(isub.EQ.151.OR.isub.EQ.156) isub=3
33337  IF(isub.EQ.152.OR.isub.EQ.157) isub=102
33338  IF(isub.EQ.153.OR.isub.EQ.158) isub=103
33339  IF(isub.EQ.171.OR.isub.EQ.176) isub=24
33340  IF(isub.EQ.172.OR.isub.EQ.177) isub=26
33341  IF(isub.EQ.173.OR.isub.EQ.178) isub=123
33342  IF(isub.EQ.174.OR.isub.EQ.179) isub=124
33343  IF(isub.EQ.181.OR.isub.EQ.186) isub=121
33344  IF(isub.EQ.182.OR.isub.EQ.187) isub=122
33345  IF(isub.EQ.183.OR.isub.EQ.188) isub=111
33346  IF(isub.EQ.184.OR.isub.EQ.189) isub=112
33347  IF(isub.EQ.185.OR.isub.EQ.190) isub=113
33348  ENDIF
33349  sqmh=pmas(kfhigg,1)**2
33350  gmmh=pmas(kfhigg,1)*pmas(kfhigg,2)
33351 
33352 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33353  IF((mstp(46).GE.3.AND.mstp(46).LE.6).AND.(isub.EQ.71.OR.isub.EQ.
33354  &72.OR.isub.EQ.73.OR.isub.EQ.76.OR.isub.EQ.77)) THEN
33355 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33356  IF(mstp(46).LE.4) THEN
33357  hdtlh=log(pmas(25,1)/parp(44))
33358  hdtmr=(4.5d0*paru(1)/sqrt(3d0)-74d0/9d0)/8d0+hdtlh/12d0
33359  hdtnr=-1d0/18d0+hdtlh/6d0
33360  ELSE
33361  hdtnm=0.125d0*(1d0/(288d0*paru(1)**2)+(parp(47)/parp(45))**2)
33362  hdtlq=log(parp(45)/parp(44))
33363  hdtmr=-(4d0*paru(1))**2*0.5d0*hdtnm+hdtlq/12d0
33364  hdtnr=(4d0*paru(1))**2*hdtnm+hdtlq/6d0
33365  ENDIF
33366 
33367 C...Calculate lowest and next-to-lowest order partial wave amplitudes
33368  hdtv=1d0/(16d0*paru(1)*parp(47)**2)
33369  a00l=dble(hdtv*sh)
33370  a20l=-0.5d0*a00l
33371  a11l=a00l/6d0
33372  hdtls=log(sh/parp(44)**2)
33373  a004=dble((hdtv*sh)**2/(4d0*paru(1)))*
33374  & cmplx(dble((176d0*hdtmr+112d0*hdtnr)/3d0+11d0/27d0-
33375  & (50d0/9d0)*hdtls),dble(4d0*paru(1)))
33376  a204=dble((hdtv*sh)**2/(4d0*paru(1)))*
33377  & cmplx(dble(32d0*(hdtmr+2d0*hdtnr)/3d0+25d0/54d0-
33378  & (20d0/9d0)*hdtls),dble(paru(1)))
33379  a114=dble((hdtv*sh)**2/(6d0*paru(1)))*
33380  & cmplx(dble(4d0*(-2d0*hdtmr+hdtnr)-1d0/18d0),dble(paru(1)/6d0))
33381 
33382 C...Unitarize partial wave amplitudes with Pade or K-matrix method
33383  IF(mstp(46).EQ.3.OR.mstp(46).EQ.5) THEN
33384  a00u=a00l/(1d0-a004/a00l)
33385  a20u=a20l/(1d0-a204/a20l)
33386  a11u=a11l/(1d0-a114/a11l)
33387  ELSE
33388  a00u=(a00l+dble(a004))/(1d0-dcmplx(0.d0,a00l+dble(a004)))
33389  a20u=(a20l+dble(a204))/(1d0-dcmplx(0.d0,a20l+dble(a204)))
33390  a11u=(a11l+dble(a114))/(1d0-dcmplx(0.d0,a11l+dble(a114)))
33391  ENDIF
33392  ENDIF
33393 
33394 C...Differential cross section expressions.
33395 
33396  IF(isub.LE.60) THEN
33397  IF(isub.EQ.3) THEN
33398 C...f + fbar -> h0 (or H0, or A0)
33399  CALL pywidt(kfhigg,sh,wdtp,wdte)
33400  hs=shr*wdtp(0)
33401  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33402  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
33403  & facbw=0d0
33404  hp=aem/(8d0*xw)*sh/sqmw*sh
33405  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33406  DO 100 i=mmina,mmaxa
33407  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
33408  ia=iabs(i)
33409  rmq=pymrun(ia,sh)**2/sh
33410  hi=hp*rmq
33411  IF(ia.LE.10) hi=hp*rmq*faca/3d0
33412  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
33413  ikfi=1
33414  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
33415  IF(ia.GT.10) ikfi=3
33416  hi=hi*paru(150+10*ihigg+ikfi)**2
33417  IF(imss(1).NE.0.AND.ia.EQ.5) THEN
33418  hi=hi/(1d0+rmss(41))**2
33419  IF(ihigg.NE.3) THEN
33420  hi=hi*(1d0+rmss(41)*paru(152+10*ihigg)/
33421  & paru(151+10*ihigg))**2
33422  ENDIF
33423  ENDIF
33424  ENDIF
33425  nchn=nchn+1
33426  isig(nchn,1)=i
33427  isig(nchn,2)=-i
33428  isig(nchn,3)=1
33429  sigh(nchn)=hi*facbw*hf
33430  100 CONTINUE
33431 
33432  ELSEIF(isub.EQ.5) THEN
33433 C...Z0 + Z0 -> h0
33434  CALL pywidt(25,sh,wdtp,wdte)
33435  hs=shr*wdtp(0)
33436  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33437  IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
33438  hp=aem/(8d0*xw)*sh/sqmw*sh
33439  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33440  hi=hp/4d0
33441  faci=8d0/(paru(1)**2*xw1)*(aem*xwc)**2
33442  DO 120 i=mmin1,mmax1
33443  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 120
33444  DO 110 j=mmin2,mmax2
33445  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 110
33446  ei=kchg(iabs(i),1)/3d0
33447  ai=sign(1d0,ei)
33448  vi=ai-4d0*ei*xwv
33449  ej=kchg(iabs(j),1)/3d0
33450  aj=sign(1d0,ej)
33451  vj=aj-4d0*ej*xwv
33452  nchn=nchn+1
33453  isig(nchn,1)=i
33454  isig(nchn,2)=j
33455  isig(nchn,3)=1
33456  sigh(nchn)=faci*(vi**2+ai**2)*(vj**2+aj**2)*hi*facbw*hf
33457  110 CONTINUE
33458  120 CONTINUE
33459 
33460  ELSEIF(isub.EQ.8) THEN
33461 C...W+ + W- -> h0
33462  CALL pywidt(25,sh,wdtp,wdte)
33463  hs=shr*wdtp(0)
33464  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33465  IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
33466  hp=aem/(8d0*xw)*sh/sqmw*sh
33467  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33468  hi=hp/2d0
33469  faci=1d0/(4d0*paru(1)**2)*(aem/xw)**2
33470  DO 140 i=mmin1,mmax1
33471  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 140
33472  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
33473  DO 130 j=mmin2,mmax2
33474  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 130
33475  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
33476  IF(ei*ej.GT.0d0) GOTO 130
33477  nchn=nchn+1
33478  isig(nchn,1)=i
33479  isig(nchn,2)=j
33480  isig(nchn,3)=1
33481  sigh(nchn)=faci*vint(180+i)*vint(180+j)*hi*facbw*hf
33482  130 CONTINUE
33483  140 CONTINUE
33484 
33485  ELSEIF(isub.EQ.24) THEN
33486 C...f + fbar -> Z0 + h0 (or H0, or A0)
33487 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33488  hbw3=gmmz/((sqm3-sqmz)**2+gmmz**2)
33489  CALL pywidt(23,sqm3,wdtp,wdte)
33490  gmmz3=sqrt(sqm3)*wdtp(0)
33491  hbw3c=gmmz3/((sqm3-sqmz)**2+gmmz3**2)
33492  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
33493  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
33494  gmmh4=sqrt(sqm4)*wdtp(0)
33495  hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
33496  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
33497  fachz=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*8d0*(aem*xwc)**2*
33498  & (thuh+2d0*sh*sqm3)/((sh-sqmz)**2+gmmz**2)
33499  fachz=fachz*wids(23,2)*wids(kfhigg,2)
33500  IF(mstp(4).GE.1.OR.ihigg.GE.2) fachz=fachz*
33501  & paru(154+10*ihigg)**2
33502  DO 150 i=mmina,mmaxa
33503  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 150
33504  ei=kchg(iabs(i),1)/3d0
33505  ai=sign(1d0,ei)
33506  vi=ai-4d0*ei*xwv
33507  fcoi=1d0
33508  IF(iabs(i).LE.10) fcoi=faca/3d0
33509  nchn=nchn+1
33510  isig(nchn,1)=i
33511  isig(nchn,2)=-i
33512  isig(nchn,3)=1
33513  sigh(nchn)=fachz*fcoi*(vi**2+ai**2)
33514  150 CONTINUE
33515 
33516  ELSEIF(isub.EQ.26) THEN
33517 C...f + fbar' -> W+/- + h0 (or H0, or A0)
33518 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33519  hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
33520  CALL pywidt(24,sqm3,wdtp,wdte)
33521  gmmw3=sqrt(sqm3)*wdtp(0)
33522  hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
33523  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
33524  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
33525  gmmh4=sqrt(sqm4)*wdtp(0)
33526  hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
33527  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
33528  fachw=comfac*0.125d0*(aem/xw)**2*(thuh+2d0*sh*sqm3)/
33529  & ((sh-sqmw)**2+gmmw**2)*(hbw3c/hbw3)*(hbw4c/hbw4)
33530  fachw=fachw*wids(kfhigg,2)
33531  IF(mstp(4).GE.1.OR.ihigg.GE.2) fachw=fachw*
33532  & paru(155+10*ihigg)**2
33533  DO 170 i=mmin1,mmax1
33534  ia=iabs(i)
33535  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 170
33536  DO 160 j=mmin2,mmax2
33537  ja=iabs(j)
33538  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(1,j).EQ.0) GOTO 160
33539  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 160
33540  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
33541  & GOTO 160
33542  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
33543  fckm=1d0
33544  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
33545  fcoi=1d0
33546  IF(ia.LE.10) fcoi=faca/3d0
33547  nchn=nchn+1
33548  isig(nchn,1)=i
33549  isig(nchn,2)=j
33550  isig(nchn,3)=1
33551  sigh(nchn)=fachw*fcoi*fckm*wids(24,(5-kchw)/2)
33552  160 CONTINUE
33553  170 CONTINUE
33554 
33555  ELSEIF(isub.EQ.32) THEN
33556 C...f + g -> f + h0 (q + g -> q + h0 only)
33557  fhcq=comfac*faca*as*aem/xw*1d0/24d0
33558 C...H propagator: as simulated in PYOFSH and as desired
33559  sqmhc=pmas(25,1)**2
33560  gmmhc=pmas(25,1)*pmas(25,2)
33561  hbw4=gmmhc/((sqm4-sqmhc)**2+gmmhc**2)
33562  CALL pywidt(25,sqm4,wdtp,wdte)
33563  gmmhcc=sqrt(sqm4)*wdtp(0)
33564  hbw4c=gmmhcc/((sqm4-sqmhc)**2+gmmhcc**2)
33565  fhcq=fhcq*hbw4c/hbw4
33566  DO 190 i=mmina,mmaxa
33567  ia=iabs(i)
33568  IF(ia.NE.5) GOTO 190
33569  sqml=pymrun(ia,sh)**2
33570  sqmq=pmas(ia,1)**2
33571  fachcq=fhcq*sqml/sqmw*
33572  & (sh/(sqmq-uh)+2d0*sqmq*(sqm4-uh)/(sqmq-uh)**2+(sqmq-uh)/sh-
33573  & 2d0*sqmq/(sqmq-uh)+2d0*(sqm4-uh)/(sqmq-uh)*
33574  & (sqm4-sqmq-sh)/sh)
33575  DO 180 isde=1,2
33576  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 180
33577  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 180
33578  nchn=nchn+1
33579  isig(nchn,isde)=i
33580  isig(nchn,3-isde)=21
33581  isig(nchn,3)=1
33582  sigh(nchn)=fachcq*wids(25,2)
33583  180 CONTINUE
33584  190 CONTINUE
33585  ENDIF
33586 
33587  ELSEIF(isub.LE.80) THEN
33588  IF(isub.EQ.71) THEN
33589 C...Z0 + Z0 -> Z0 + Z0
33590  IF(sh.LE.4.01d0*sqmz) GOTO 220
33591 
33592  IF(mstp(46).LE.2) THEN
33593 C...Exact scattering ME:s for on-mass-shell gauge bosons
33594  be2=1d0-4d0*sqmz/sh
33595  th=-0.5d0*sh*be2*(1d0-cth)
33596  uh=-0.5d0*sh*be2*(1d0+cth)
33597  IF(max(th,uh).GT.-1d0) GOTO 220
33598  shang=1d0/xw1*sqmw/sqmz*(1d0+be2)**2
33599  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33600  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33601  thang=1d0/xw1*sqmw/sqmz*(be2-cth)**2
33602  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
33603  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
33604  uhang=1d0/xw1*sqmw/sqmz*(be2+cth)**2
33605  auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
33606  auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
33607  faczz=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
33608  & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
33609  IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
33610  IF(mstp(46).EQ.1) faczz=faczz*((ashre+athre+auhre)**2+
33611  & (ashim+athim+auhim)**2)
33612  IF(mstp(46).EQ.2) faczz=0d0
33613 
33614  ELSE
33615 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33616  faczz=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
33617  & abs(a00u+2d0*a20u)**2
33618  ENDIF
33619  faczz=faczz*wids(23,1)
33620 
33621  DO 210 i=mmin1,mmax1
33622  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 210
33623  ei=kchg(iabs(i),1)/3d0
33624  ai=sign(1d0,ei)
33625  vi=ai-4d0*ei*xwv
33626  avi=ai**2+vi**2
33627  DO 200 j=mmin2,mmax2
33628  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 200
33629  ej=kchg(iabs(j),1)/3d0
33630  aj=sign(1d0,ej)
33631  vj=aj-4d0*ej*xwv
33632  avj=aj**2+vj**2
33633  nchn=nchn+1
33634  isig(nchn,1)=i
33635  isig(nchn,2)=j
33636  isig(nchn,3)=1
33637  sigh(nchn)=0.5d0*faczz*avi*avj
33638  200 CONTINUE
33639  210 CONTINUE
33640  220 CONTINUE
33641 
33642  ELSEIF(isub.EQ.72) THEN
33643 C...Z0 + Z0 -> W+ + W-
33644  IF(sh.LE.4.01d0*sqmz) GOTO 250
33645 
33646  IF(mstp(46).LE.2) THEN
33647 C...Exact scattering ME:s for on-mass-shell gauge bosons
33648  be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
33649  cth2=cth**2
33650  th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
33651  uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
33652  IF(max(th,uh).GT.-1d0) GOTO 250
33653  shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
33654  & (1d0-2d0*sqmz/sh)
33655  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33656  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33657  atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
33658  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33659  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33660  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
33661  & 2d0*(sqmw+sqmz)/sh*be2*cth))
33662  atwim=0d0
33663  auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
33664  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33665  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33666  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
33667  & 2d0*(sqmw+sqmz)/sh*be2*cth))
33668  auwim=0d0
33669  a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
33670  a4im=0d0
33671  facww=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
33672  & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
33673  IF(mstp(46).LE.0) facww=facww*(ashre**2+ashim**2)
33674  IF(mstp(46).EQ.1) facww=facww*((ashre+atwre+auwre+a4re)**2+
33675  & (ashim+atwim+auwim+a4im)**2)
33676  IF(mstp(46).EQ.2) facww=facww*((atwre+auwre+a4re)**2+
33677  & (atwim+auwim+a4im)**2)
33678 
33679  ELSE
33680 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33681  facww=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
33682  & abs(a00u-a20u)**2
33683  ENDIF
33684  facww=facww*wids(24,1)
33685 
33686  DO 240 i=mmin1,mmax1
33687  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 240
33688  ei=kchg(iabs(i),1)/3d0
33689  ai=sign(1d0,ei)
33690  vi=ai-4d0*ei*xwv
33691  avi=ai**2+vi**2
33692  DO 230 j=mmin2,mmax2
33693  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 230
33694  ej=kchg(iabs(j),1)/3d0
33695  aj=sign(1d0,ej)
33696  vj=aj-4d0*ej*xwv
33697  avj=aj**2+vj**2
33698  nchn=nchn+1
33699  isig(nchn,1)=i
33700  isig(nchn,2)=j
33701  isig(nchn,3)=1
33702  sigh(nchn)=facww*avi*avj
33703  230 CONTINUE
33704  240 CONTINUE
33705  250 CONTINUE
33706 
33707  ELSEIF(isub.EQ.73) THEN
33708 C...Z0 + W+/- -> Z0 + W+/-
33709  IF(sh.LE.2d0*sqmz+2d0*sqmw) GOTO 280
33710 
33711  IF(mstp(46).LE.2) THEN
33712 C...Exact scattering ME:s for on-mass-shell gauge bosons
33713  be2=1d0-2d0*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2
33714  ep1=1d0-(sqmz-sqmw)/sh
33715  ep2=1d0+(sqmz-sqmw)/sh
33716  th=-0.5d0*sh*be2*(1d0-cth)
33717  uh=(sqmz-sqmw)**2/sh-0.5d0*sh*be2*(1d0+cth)
33718  IF(max(th,uh).GT.-1d0) GOTO 280
33719  thang=(be2-ep1*cth)*(be2-ep2*cth)
33720  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
33721  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
33722  aswre=-xw1/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+
33723  & 1d0/4d0*(be2+ep1*ep2)**2*((ep1-ep2)**2-4d0*be2*cth)+
33724  & 2d0*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-
33725  & 1d0/16d0*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2)
33726  aswim=0d0
33727  auwre=xw1/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*
33728  & (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*
33729  & (be2+ep1*ep2*cth)*(2d0*ep2-ep2*cth+ep1)-
33730  & be2*(ep2+ep1*cth)**2*(be2-ep2**2*cth)-1d0/8d0*
33731  & (be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2d0*be2*(1d0-cth))+
33732  & 1d0/32d0*sh/sqmw*(be2+ep1*ep2*cth)**2*
33733  & (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)*
33734  & (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*
33735  & (2d0*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*
33736  & (be2-ep1**2*cth)-1d0/8d0*(be2+ep1*ep2*cth)**2*
33737  & ((ep1+ep2)**2+2d0*be2*(1d0-cth))+1d0/32d0*sh/sqmw*
33738  & (be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2)
33739  auwim=0d0
33740  a4re=xw1/sqmz*(ep1**2*ep2**2*(cth**2-1d0)-
33741  & 2d0*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2d0*be2*ep1*ep2)
33742  a4im=0d0
33743  faczw=comfac*1d0/(4096d0*paru(1)**2*4d0*xw1)*(aem/xw)**4*
33744  & (sh/sqmw)**2*sqrt(sqmz/sqmw)*sh2
33745  IF(mstp(46).LE.0) faczw=0d0
33746  IF(mstp(46).EQ.1) faczw=faczw*((athre+aswre+auwre+a4re)**2+
33747  & (athim+aswim+auwim+a4im)**2)
33748  IF(mstp(46).EQ.2) faczw=faczw*((aswre+auwre+a4re)**2+
33749  & (aswim+auwim+a4im)**2)
33750 
33751  ELSE
33752 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33753  faczw=comfac*aem**2/(64d0*paru(1)**2*xw**2*xw1)*16d0*
33754  & abs(a20u+3d0*a11u*dble(cth))**2
33755  ENDIF
33756  faczw=faczw*wids(23,2)
33757 
33758  DO 270 i=mmin1,mmax1
33759  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 270
33760  ei=kchg(iabs(i),1)/3d0
33761  ai=sign(1d0,ei)
33762  vi=ai-4d0*ei*xwv
33763  avi=ai**2+vi**2
33764  kchwi=isign(1,kchg(iabs(i),1)*isign(1,i))
33765  DO 260 j=mmin2,mmax2
33766  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 260
33767  ej=kchg(iabs(j),1)/3d0
33768  aj=sign(1d0,ej)
33769  vj=ai-4d0*ej*xwv
33770  avj=aj**2+vj**2
33771  kchwj=isign(1,kchg(iabs(j),1)*isign(1,j))
33772  nchn=nchn+1
33773  isig(nchn,1)=i
33774  isig(nchn,2)=j
33775  isig(nchn,3)=1
33776  sigh(nchn)=faczw*avi*vint(180+j)*wids(24,(5-kchwj)/2)
33777  nchn=nchn+1
33778  isig(nchn,1)=i
33779  isig(nchn,2)=j
33780  isig(nchn,3)=2
33781  sigh(nchn)=faczw*vint(180+i)*wids(24,(5-kchwi)/2)*avj
33782  260 CONTINUE
33783  270 CONTINUE
33784  280 CONTINUE
33785 
33786  ELSEIF(isub.EQ.75) THEN
33787 C...W+ + W- -> gamma + gamma
33788 
33789  ELSEIF(isub.EQ.76) THEN
33790 C...W+ + W- -> Z0 + Z0
33791  IF(sh.LE.4.01d0*sqmz) GOTO 310
33792 
33793  IF(mstp(46).LE.2) THEN
33794 C...Exact scattering ME:s for on-mass-shell gauge bosons
33795  be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
33796  cth2=cth**2
33797  th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
33798  uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
33799  IF(max(th,uh).GT.-1d0) GOTO 310
33800  shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
33801  & (1d0-2d0*sqmz/sh)
33802  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33803  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33804  atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
33805  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33806  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33807  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
33808  & 2d0*(sqmw+sqmz)/sh*be2*cth))
33809  atwim=0d0
33810  auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
33811  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33812  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33813  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
33814  & 2d0*(sqmw+sqmz)/sh*be2*cth))
33815  auwim=0d0
33816  a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
33817  a4im=0d0
33818  faczz=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
33819  & (sh/sqmw)**2*sh2
33820  IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
33821  IF(mstp(46).EQ.1) faczz=faczz*((ashre+atwre+auwre+a4re)**2+
33822  & (ashim+atwim+auwim+a4im)**2)
33823  IF(mstp(46).EQ.2) faczz=faczz*((atwre+auwre+a4re)**2+
33824  & (atwim+auwim+a4im)**2)
33825 
33826  ELSE
33827 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33828  faczz=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
33829  & abs(a00u-a20u)**2
33830  ENDIF
33831  faczz=faczz*wids(23,1)
33832 
33833  DO 300 i=mmin1,mmax1
33834  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 300
33835  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
33836  DO 290 j=mmin2,mmax2
33837  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 290
33838  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
33839  IF(ei*ej.GT.0d0) GOTO 290
33840  nchn=nchn+1
33841  isig(nchn,1)=i
33842  isig(nchn,2)=j
33843  isig(nchn,3)=1
33844  sigh(nchn)=0.5d0*faczz*vint(180+i)*vint(180+j)
33845  290 CONTINUE
33846  300 CONTINUE
33847  310 CONTINUE
33848 
33849  ELSEIF(isub.EQ.77) THEN
33850 C...W+/- + W+/- -> W+/- + W+/-
33851  IF(sh.LE.4.01d0*sqmw) GOTO 340
33852 
33853  IF(mstp(46).LE.2) THEN
33854 C...Exact scattering ME:s for on-mass-shell gauge bosons
33855  be2=1d0-4d0*sqmw/sh
33856  be4=be2**2
33857  cth2=cth**2
33858  cth3=cth**3
33859  th=-0.5d0*sh*be2*(1d0-cth)
33860  uh=-0.5d0*sh*be2*(1d0+cth)
33861  IF(max(th,uh).GT.-1d0) GOTO 340
33862  shang=(1d0+be2)**2
33863  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33864  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33865  thang=(be2-cth)**2
33866  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
33867  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
33868  uhang=(be2+cth)**2
33869  auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
33870  auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
33871  sgzang=1d0/sqmw*be2*(3d0-be2)**2*cth
33872  asgre=xw*sgzang
33873  asgim=0d0
33874  aszre=xw1*sh/(sh-sqmz)*sgzang
33875  aszim=0d0
33876  tgzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)+be2*(4d0-10d0*be2+
33877  & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2+be2*cth3)
33878  atgre=0.5d0*xw*sh/th*tgzang
33879  atgim=0d0
33880  atzre=0.5d0*xw1*sh/(th-sqmz)*tgzang
33881  atzim=0d0
33882  ugzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)-be2*(4d0-10d0*be2+
33883  & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2-be2*cth3)
33884  augre=0.5d0*xw*sh/uh*ugzang
33885  augim=0d0
33886  auzre=0.5d0*xw1*sh/(uh-sqmz)*ugzang
33887  auzim=0d0
33888  a4are=1d0/sqmw*(1d0+2d0*be2-6d0*be2*cth-cth2)
33889  a4aim=0d0
33890  a4sre=2d0/sqmw*(1d0+2d0*be2-cth2)
33891  a4sim=0d0
33892  fww=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
33893  & (sh/sqmw)**2*sh2
33894  IF(mstp(46).LE.0) THEN
33895  awware=ashre
33896  awwaim=ashim
33897  awwsre=0d0
33898  awwsim=0d0
33899  ELSEIF(mstp(46).EQ.1) THEN
33900  awware=ashre+athre+asgre+aszre+atgre+atzre+a4are
33901  awwaim=ashim+athim+asgim+aszim+atgim+atzim+a4aim
33902  awwsre=-athre-auhre+atgre+atzre+augre+auzre+a4sre
33903  awwsim=-athim-auhim+atgim+atzim+augim+auzim+a4sim
33904  ELSE
33905  awware=asgre+aszre+atgre+atzre+a4are
33906  awwaim=asgim+aszim+atgim+atzim+a4aim
33907  awwsre=atgre+atzre+augre+auzre+a4sre
33908  awwsim=atgim+atzim+augim+auzim+a4sim
33909  ENDIF
33910  awwa2=awware**2+awwaim**2
33911  awws2=awwsre**2+awwsim**2
33912 
33913  ELSE
33914 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33915  fwwa=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
33916  & abs(a00u+0.5d0*a20u+4.5d0*a11u*dble(cth))**2
33917  fwws=comfac*(aem/(4d0*paru(1)*xw))**2*64d0*abs(a20u)**2
33918  ENDIF
33919 
33920  DO 330 i=mmin1,mmax1
33921  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 330
33922  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
33923  DO 320 j=mmin2,mmax2
33924  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 320
33925  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
33926  IF(ei*ej.LT.0d0) THEN
33927 C...W+W-
33928  IF(mstp(45).EQ.1) GOTO 320
33929  IF(mstp(46).LE.2) facww=fww*awwa2*wids(24,1)
33930  IF(mstp(46).GE.3) facww=fwwa*wids(24,1)
33931  ELSE
33932 C...W+W+/W-W-
33933  IF(mstp(45).EQ.2) GOTO 320
33934  IF(mstp(46).LE.2) facww=fww*awws2
33935  IF(mstp(46).GE.3) facww=fwws
33936  IF(ei.GT.0d0) facww=facww*wids(24,4)
33937  IF(ei.LT.0d0) facww=facww*wids(24,5)
33938  ENDIF
33939  nchn=nchn+1
33940  isig(nchn,1)=i
33941  isig(nchn,2)=j
33942  isig(nchn,3)=1
33943  sigh(nchn)=facww*vint(180+i)*vint(180+j)
33944  IF(ei*ej.GT.0d0) sigh(nchn)=0.5d0*sigh(nchn)
33945  320 CONTINUE
33946  330 CONTINUE
33947  340 CONTINUE
33948  ENDIF
33949 
33950  ELSEIF(isub.LE.120) THEN
33951  IF(isub.EQ.102) THEN
33952 C...g + g -> h0 (or H0, or A0)
33953  CALL pywidt(kfhigg,sh,wdtp,wdte)
33954  hs=shr*wdtp(0)
33955  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33956  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33957  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
33958  & facbw=0d0
33959 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
33960  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
33961  wdtp13=0d0
33962  DO 345 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
33963  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
33964  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
33965  345 CONTINUE
33966  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
33967  & '(PYSGHG:) did not find Higgs -> g g channel')
33968  hi=shr*wdtp13/32d0
33969  ELSE
33970  hi=shr*wdtp(13)/32d0
33971  ENDIF
33972  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 350
33973  nchn=nchn+1
33974  isig(nchn,1)=21
33975  isig(nchn,2)=21
33976  isig(nchn,3)=1
33977  sigh(nchn)=hi*facbw*hf
33978  350 CONTINUE
33979 
33980  ELSEIF(isub.EQ.103) THEN
33981 C...gamma + gamma -> h0 (or H0, or A0)
33982  CALL pywidt(kfhigg,sh,wdtp,wdte)
33983  hs=shr*wdtp(0)
33984  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33985  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33986  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
33987  & facbw=0d0
33988 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
33989  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
33990  wdtp14=0d0
33991  DO 355 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
33992  IF(kfdp(idc,1).EQ.22.AND.kfdp(idc,2).EQ.22.AND.
33993  & kfdp(idc,3).EQ.0) wdtp14=pmas(kfhigg,2)*brat(idc)
33994  355 CONTINUE
33995  IF(wdtp14.EQ.0d0) CALL pyerrm(26,
33996  & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
33997  hi=shr*wdtp14*2d0
33998  ELSE
33999  hi=shr*wdtp(14)*2d0
34000  ENDIF
34001  IF(kfac(1,22)*kfac(2,22).EQ.0) GOTO 360
34002  nchn=nchn+1
34003  isig(nchn,1)=22
34004  isig(nchn,2)=22
34005  isig(nchn,3)=1
34006  sigh(nchn)=hi*facbw*hf
34007  360 CONTINUE
34008 
34009  ELSEIF(isub.EQ.110) THEN
34010 C...f + fbar -> gamma + h0
34011  thuh=max(th*uh,sh*ckin(3)**2)
34012  fachg=comfac*(3d0*aem**4)/(2d0*paru(1)**2*xw*sqmw)*sh*thuh
34013  fachg=fachg*wids(kfhigg,2)
34014 C...Calculate loop contributions for intermediate gamma* and Z0
34015  cigtot=dcmplx(0d0,0d0)
34016  ciztot=dcmplx(0d0,0d0)
34017  jmax=3*mstp(1)+1
34018  DO 370 j=1,jmax
34019  IF(j.LE.2*mstp(1)) THEN
34020  fnc=1d0
34021  ej=kchg(j,1)/3d0
34022  aj=sign(1d0,ej+0.1d0)
34023  vj=aj-4d0*ej*xwv
34024  balp=sqm4/(2d0*pmas(j,1))**2
34025  bbet=sh/(2d0*pmas(j,1))**2
34026  ELSEIF(j.LE.3*mstp(1)) THEN
34027  fnc=3d0
34028  jl=2*(j-2*mstp(1))-1
34029  ej=kchg(10+jl,1)/3d0
34030  aj=sign(1d0,ej+0.1d0)
34031  vj=aj-4d0*ej*xwv
34032  balp=sqm4/(2d0*pmas(10+jl,1))**2
34033  bbet=sh/(2d0*pmas(10+jl,1))**2
34034  ELSE
34035  balp=sqm4/(2d0*pmas(24,1))**2
34036  bbet=sh/(2d0*pmas(24,1))**2
34037  ENDIF
34038  babi=1d0/(balp-bbet)
34039  IF(balp.LT.1d0) THEN
34040  f0alp=dcmplx(dble(asin(sqrt(balp))),0d0)
34041  f1alp=f0alp**2
34042  ELSE
34043  f0alp=dcmplx(dble(log(sqrt(balp)+sqrt(balp-1d0))),
34044  & -dble(0.5d0*paru(1)))
34045  f1alp=-f0alp**2
34046  ENDIF
34047  f2alp=dble(sqrt(abs(balp-1d0)/balp))*f0alp
34048  IF(bbet.LT.1d0) THEN
34049  f0bet=dcmplx(dble(asin(sqrt(bbet))),0d0)
34050  f1bet=f0bet**2
34051  ELSE
34052  f0bet=dcmplx(dble(log(sqrt(bbet)+sqrt(bbet-1d0))),
34053  & -dble(0.5d0*paru(1)))
34054  f1bet=-f0bet**2
34055  ENDIF
34056  f2bet=dble(sqrt(abs(bbet-1d0)/bbet))*f0bet
34057  IF(j.LE.3*mstp(1)) THEN
34058  fif=dble(0.5d0*babi)+dble(babi**2)*(dble(0.5d0*(1d0-balp+
34059  & bbet))*(f1bet-f1alp)+dble(bbet)*(f2bet-f2alp))
34060  cigtot=cigtot+dble(fnc*ej**2)*fif
34061  ciztot=ciztot+dble(fnc*ej*vj)*fif
34062  ELSE
34063  txw=xw/xw1
34064  cigtot=cigtot-0.5*(dble(babi*(1.5d0+balp))+dble(babi**2)*
34065  & (dble(1.5d0-3d0*balp+4d0*bbet)*(f1bet-f1alp)+
34066  & dble(bbet*(2d0*balp+3d0))*(f2bet-f2alp)))
34067  ciztot=ciztot-dble(0.5d0*babi*xw1)*(dble(5d0-txw+2d0*balp*
34068  & (1d0-txw))*(1d0+dble(2d0*babi*bbet)*(f2bet-f2alp))+
34069  & dble(babi*(4d0*bbet*(3d0-txw)-(2d0*balp-1d0)*(5d0-txw)))*
34070  & (f1bet-f1alp))
34071  ENDIF
34072  370 CONTINUE
34073  cigtot=cigtot/dble(sh)
34074  ciztot=ciztot*dble(xwc)/dcmplx(dble(sh-sqmz),dble(gmmz))
34075 C...Loop over initial flavours
34076  DO 380 i=mmina,mmaxa
34077  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 380
34078  ei=kchg(iabs(i),1)/3d0
34079  ai=sign(1d0,ei)
34080  vi=ai-4d0*ei*xwv
34081  fcoi=1d0
34082  IF(iabs(i).LE.10) fcoi=faca/3d0
34083  nchn=nchn+1
34084  isig(nchn,1)=i
34085  isig(nchn,2)=-i
34086  isig(nchn,3)=1
34087  sigh(nchn)=fachg*fcoi*(abs(dble(ei)*cigtot+dble(vi)*
34088  & ciztot)**2+ai**2*abs(ciztot)**2)
34089  380 CONTINUE
34090 
34091  ELSEIF(isub.EQ.111) THEN
34092 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34093  IF(mstp(38).NE.0) THEN
34094 C...Simple case: only do gg <-> h exactly.
34095  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34096 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34097  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34098  wdtp13=0d0
34099  DO 385 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34100  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34101  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34102  385 CONTINUE
34103  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34104  & '(PYSGHG:) did not find Higgs -> g g channel')
34105  facgh=comfac*faca*(2d0/9d0)*as*(wdtp13/sqrt(sqm4))*
34106  & (th**2+uh**2)/(sh*sqm4)
34107  ELSE
34108  facgh=comfac*faca*(2d0/9d0)*as*(wdtp(13)/sqrt(sqm4))*
34109  & (th**2+uh**2)/(sh*sqm4)
34110  ENDIF
34111 C...Propagators: as simulated in PYOFSH and as desired
34112  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34113  gmmhc=sqrt(sqm4)*wdtp(0)
34114  hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34115  & ((sqm4-sqmh)**2+gmmhc**2)
34116  facgh=facgh*hbw4c/hbw4
34117  ELSE
34118 C...Messy case: do full loop integrals
34119  a5stur=0d0
34120  a5stui=0d0
34121  DO 390 i=1,2*mstp(1)
34122  sqmq=pmas(i,1)**2
34123  epss=4d0*sqmq/sh
34124  epsh=4d0*sqmq/sqmh
34125  CALL pywaux(1,epss,w1sr,w1si)
34126  CALL pywaux(1,epsh,w1hr,w1hi)
34127  CALL pywaux(2,epss,w2sr,w2si)
34128  CALL pywaux(2,epsh,w2hr,w2hi)
34129  a5stur=a5stur+epsh*(1d0+sh/(th+uh)*(w1sr-w1hr)+
34130  & (0.25d0-sqmq/(th+uh))*(w2sr-w2hr))
34131  a5stui=a5stui+epsh*(sh/(th+uh)*(w1si-w1hi)+
34132  & (0.25d0-sqmq/(th+uh))*(w2si-w2hi))
34133  390 CONTINUE
34134  facgh=comfac*faca/(144d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
34135  & sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)
34136  facgh=facgh*wids(25,2)
34137  ENDIF
34138  DO 400 i=mmina,mmaxa
34139  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
34140  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 400
34141  nchn=nchn+1
34142  isig(nchn,1)=i
34143  isig(nchn,2)=-i
34144  isig(nchn,3)=1
34145  sigh(nchn)=facgh
34146  400 CONTINUE
34147 
34148  ELSEIF(isub.EQ.112) THEN
34149 C...f + g -> f + h0 (q + g -> q + h0 only)
34150  IF(mstp(38).NE.0) THEN
34151 C...Simple case: only do gg <-> h exactly.
34152  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34153 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34154  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34155  wdtp13=0d0
34156  DO 405 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34157  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34158  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34159  405 CONTINUE
34160  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34161  & '(PYSGHG:) did not find Higgs -> g g channel')
34162  facqh=comfac*faca*(1d0/12d0)*as*(wdtp13/sqrt(sqm4))*
34163  & (sh**2+uh**2)/(-th*sqm4)
34164  ELSE
34165  facqh=comfac*faca*(1d0/12d0)*as*(wdtp(13)/sqrt(sqm4))*
34166  & (sh**2+uh**2)/(-th*sqm4)
34167  ENDIF
34168 C...Propagators: as simulated in PYOFSH and as desired
34169  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34170  gmmhc=sqrt(sqm4)*wdtp(0)
34171  hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34172  & ((sqm4-sqmh)**2+gmmhc**2)
34173  facqh=facqh*hbw4c/hbw4
34174  ELSE
34175 C...Messy case: do full loop integrals
34176  a5tsur=0d0
34177  a5tsui=0d0
34178  DO 410 i=1,2*mstp(1)
34179  sqmq=pmas(i,1)**2
34180  epst=4d0*sqmq/th
34181  epsh=4d0*sqmq/sqmh
34182  CALL pywaux(1,epst,w1tr,w1ti)
34183  CALL pywaux(1,epsh,w1hr,w1hi)
34184  CALL pywaux(2,epst,w2tr,w2ti)
34185  CALL pywaux(2,epsh,w2hr,w2hi)
34186  a5tsur=a5tsur+epsh*(1d0+th/(sh+uh)*(w1tr-w1hr)+
34187  & (0.25d0-sqmq/(sh+uh))*(w2tr-w2hr))
34188  a5tsui=a5tsui+epsh*(th/(sh+uh)*(w1ti-w1hi)+
34189  & (0.25d0-sqmq/(sh+uh))*(w2ti-w2hi))
34190  410 CONTINUE
34191  facqh=comfac*faca/(384d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
34192  & sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)
34193  facqh=facqh*wids(25,2)
34194  ENDIF
34195  DO 430 i=mmina,mmaxa
34196  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 430
34197  DO 420 isde=1,2
34198  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 420
34199  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 420
34200  nchn=nchn+1
34201  isig(nchn,isde)=i
34202  isig(nchn,3-isde)=21
34203  isig(nchn,3)=1
34204  sigh(nchn)=facqh
34205  420 CONTINUE
34206  430 CONTINUE
34207 
34208  ELSEIF(isub.EQ.113) THEN
34209 C...g + g -> g + h0
34210  IF(mstp(38).NE.0) THEN
34211 C...Simple case: only do gg <-> h exactly.
34212  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34213 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34214  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34215  wdtp13=0d0
34216  DO 435 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34217  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34218  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34219  435 CONTINUE
34220  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34221  & '(PYSGHG:) did not find Higgs -> g g channel')
34222  facgh=comfac*faca*(3d0/16d0)*as*(wdtp13/sqrt(sqm4))*
34223  & (sh**4+th**4+uh**4+sqm4**4)/(sh*th*uh*sqm4)
34224  ELSE
34225  facgh=comfac*faca*(3d0/16d0)*as*(wdtp(13)/sqrt(sqm4))*
34226  & (sh**4+th**4+uh**4+sqm4**4)/(sh*th*uh*sqm4)
34227  ENDIF
34228 C...Propagators: as simulated in PYOFSH and as desired
34229  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34230  gmmhc=sqrt(sqm4)*wdtp(0)
34231  hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34232  & ((sqm4-sqmh)**2+gmmhc**2)
34233  facgh=facgh*hbw4c/hbw4
34234  ELSE
34235 C...Messy case: do full loop integrals
34236  a2stur=0d0
34237  a2stui=0d0
34238  a2ustr=0d0
34239  a2usti=0d0
34240  a2tusr=0d0
34241  a2tusi=0d0
34242  a4stur=0d0
34243  a4stui=0d0
34244  DO 440 i=1,2*mstp(1)
34245  sqmq=pmas(i,1)**2
34246  epss=4d0*sqmq/sh
34247  epst=4d0*sqmq/th
34248  epsu=4d0*sqmq/uh
34249  epsh=4d0*sqmq/sqmh
34250  IF(epsh.LT.1d-6) GOTO 440
34251  CALL pywaux(1,epss,w1sr,w1si)
34252  CALL pywaux(1,epst,w1tr,w1ti)
34253  CALL pywaux(1,epsu,w1ur,w1ui)
34254  CALL pywaux(1,epsh,w1hr,w1hi)
34255  CALL pywaux(2,epss,w2sr,w2si)
34256  CALL pywaux(2,epst,w2tr,w2ti)
34257  CALL pywaux(2,epsu,w2ur,w2ui)
34258  CALL pywaux(2,epsh,w2hr,w2hi)
34259  CALL pyi3au(epss,th/uh,y3stur,y3stui)
34260  CALL pyi3au(epss,uh/th,y3sutr,y3suti)
34261  CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
34262  CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
34263  CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
34264  CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
34265  CALL pyi3au(epsh,sqmh/sh*th/uh,yhstur,yhstui)
34266  CALL pyi3au(epsh,sqmh/sh*uh/th,yhsutr,yhsuti)
34267  CALL pyi3au(epsh,sqmh/th*sh/uh,yhtsur,yhtsui)
34268  CALL pyi3au(epsh,sqmh/th*uh/sh,yhtusr,yhtusi)
34269  CALL pyi3au(epsh,sqmh/uh*sh/th,yhustr,yhusti)
34270  CALL pyi3au(epsh,sqmh/uh*th/sh,yhutsr,yhutsi)
34271  w3stur=yhstur-y3stur-y3utsr
34272  w3stui=yhstui-y3stui-y3utsi
34273  w3sutr=yhsutr-y3sutr-y3tusr
34274  w3suti=yhsuti-y3suti-y3tusi
34275  w3tsur=yhtsur-y3tsur-y3ustr
34276  w3tsui=yhtsui-y3tsui-y3usti
34277  w3tusr=yhtusr-y3tusr-y3sutr
34278  w3tusi=yhtusi-y3tusi-y3suti
34279  w3ustr=yhustr-y3ustr-y3tsur
34280  w3usti=yhusti-y3usti-y3tsui
34281  w3utsr=yhutsr-y3utsr-y3stur
34282  w3utsi=yhutsi-y3utsi-y3stui
34283  b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2d0*th*uh*
34284  & (uh+2d0*sh)/(sh+uh)**2*(w1tr-w1hr)+(sqmq-sh/4d0)*
34285  & (0.5d0*w2sr+0.5d0*w2hr-w2tr+w3stur)+sh2*(2d0*sqmq/
34286  & (sh+uh)**2-0.5d0/(sh+uh))*(w2tr-w2hr)+0.5d0*th*uh/sh*
34287  & (w2hr-2d0*w2tr)+0.125d0*(sh-12d0*sqmq-4d0*th*uh/sh)*w3tsur)
34288  b2stui=sqmq/sqmh**2*(2d0*th*uh*(uh+2d0*sh)/(sh+uh)**2*
34289  & (w1ti-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ti+
34290  & w3stui)+sh2*(2d0*sqmq/(sh+uh)**2-0.5d0/(sh+uh))*
34291  & (w2ti-w2hi)+0.5d0*th*uh/sh*(w2hi-2d0*w2ti)+0.125d0*
34292  & (sh-12d0*sqmq-4d0*th*uh/sh)*w3tsui)
34293  b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2d0*uh*th*
34294  & (th+2d0*sh)/(sh+th)**2*(w1ur-w1hr)+(sqmq-sh/4d0)*
34295  & (0.5d0*w2sr+0.5d0*w2hr-w2ur+w3sutr)+sh2*(2d0*sqmq/
34296  & (sh+th)**2-0.5d0/(sh+th))*(w2ur-w2hr)+0.5d0*uh*th/sh*
34297  & (w2hr-2d0*w2ur)+0.125d0*(sh-12d0*sqmq-4d0*uh*th/sh)*w3ustr)
34298  b2suti=sqmq/sqmh**2*(2d0*uh*th*(th+2d0*sh)/(sh+th)**2*
34299  & (w1ui-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ui+
34300  & w3suti)+sh2*(2d0*sqmq/(sh+th)**2-0.5d0/(sh+th))*
34301  & (w2ui-w2hi)+0.5d0*uh*th/sh*(w2hi-2d0*w2ui)+0.125d0*
34302  & (sh-12d0*sqmq-4d0*uh*th/sh)*w3usti)
34303  b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2d0*sh*uh*
34304  & (uh+2d0*th)/(th+uh)**2*(w1sr-w1hr)+(sqmq-th/4d0)*
34305  & (0.5d0*w2tr+0.5d0*w2hr-w2sr+w3tsur)+th2*(2d0*sqmq/
34306  & (th+uh)**2-0.5d0/(th+uh))*(w2sr-w2hr)+0.5d0*sh*uh/th*
34307  & (w2hr-2d0*w2sr)+0.125d0*(th-12d0*sqmq-4d0*sh*uh/th)*w3stur)
34308  b2tsui=sqmq/sqmh**2*(2d0*sh*uh*(uh+2d0*th)/(th+uh)**2*
34309  & (w1si-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2si+
34310  & w3tsui)+th2*(2d0*sqmq/(th+uh)**2-0.5d0/(th+uh))*
34311  & (w2si-w2hi)+0.5d0*sh*uh/th*(w2hi-2d0*w2si)+0.125d0*
34312  & (th-12d0*sqmq-4d0*sh*uh/th)*w3stui)
34313  b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2d0*uh*sh*
34314  & (sh+2d0*th)/(th+sh)**2*(w1ur-w1hr)+(sqmq-th/4d0)*
34315  & (0.5d0*w2tr+0.5d0*w2hr-w2ur+w3tusr)+th2*(2d0*sqmq/
34316  & (th+sh)**2-0.5d0/(th+sh))*(w2ur-w2hr)+0.5d0*uh*sh/th*
34317  & (w2hr-2d0*w2ur)+0.125d0*(th-12d0*sqmq-4d0*uh*sh/th)*w3utsr)
34318  b2tusi=sqmq/sqmh**2*(2d0*uh*sh*(sh+2d0*th)/(th+sh)**2*
34319  & (w1ui-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2ui+
34320  & w3tusi)+th2*(2d0*sqmq/(th+sh)**2-0.5d0/(th+sh))*
34321  & (w2ui-w2hi)+0.5d0*uh*sh/th*(w2hi-2d0*w2ui)+0.125d0*
34322  & (th-12d0*sqmq-4d0*uh*sh/th)*w3utsi)
34323  b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2d0*sh*th*
34324  & (th+2d0*uh)/(uh+th)**2*(w1sr-w1hr)+(sqmq-uh/4d0)*
34325  & (0.5d0*w2ur+0.5d0*w2hr-w2sr+w3ustr)+uh2*(2d0*sqmq/
34326  & (uh+th)**2-0.5d0/(uh+th))*(w2sr-w2hr)+0.5d0*sh*th/uh*
34327  & (w2hr-2d0*w2sr)+0.125d0*(uh-12d0*sqmq-4d0*sh*th/uh)*w3sutr)
34328  b2usti=sqmq/sqmh**2*(2d0*sh*th*(th+2d0*uh)/(uh+th)**2*
34329  & (w1si-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2si+
34330  & w3usti)+uh2*(2d0*sqmq/(uh+th)**2-0.5d0/(uh+th))*
34331  & (w2si-w2hi)+0.5d0*sh*th/uh*(w2hi-2d0*w2si)+0.125d0*
34332  & (uh-12d0*sqmq-4d0*sh*th/uh)*w3suti)
34333  b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2d0*th*sh*
34334  & (sh+2d0*uh)/(uh+sh)**2*(w1tr-w1hr)+(sqmq-uh/4d0)*
34335  & (0.5d0*w2ur+0.5d0*w2hr-w2tr+w3utsr)+uh2*(2d0*sqmq/
34336  & (uh+sh)**2-0.5d0/(uh+sh))*(w2tr-w2hr)+0.5d0*th*sh/uh*
34337  & (w2hr-2d0*w2tr)+0.125d0*(uh-12d0*sqmq-4d0*th*sh/uh)*w3tusr)
34338  b2utsi=sqmq/sqmh**2*(2d0*th*sh*(sh+2d0*uh)/(uh+sh)**2*
34339  & (w1ti-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2ti+
34340  & w3utsi)+uh2*(2d0*sqmq/(uh+sh)**2-0.5d0/(uh+sh))*
34341  & (w2ti-w2hi)+0.5d0*th*sh/uh*(w2hi-2d0*w2ti)+0.125d0*
34342  & (uh-12d0*sqmq-4d0*th*sh/uh)*w3tusi)
34343  b4stur=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
34344  & (w2sr-w2hr+w3stur))
34345  b4stui=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2si-w2hi+w3stui)
34346  b4tusr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
34347  & (w2tr-w2hr+w3tusr))
34348  b4tusi=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ti-w2hi+w3tusi)
34349  b4ustr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
34350  & (w2ur-w2hr+w3ustr))
34351  b4usti=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ui-w2hi+w3usti)
34352  a2stur=a2stur+b2stur+b2sutr
34353  a2stui=a2stui+b2stui+b2suti
34354  a2ustr=a2ustr+b2ustr+b2utsr
34355  a2usti=a2usti+b2usti+b2utsi
34356  a2tusr=a2tusr+b2tusr+b2tsur
34357  a2tusi=a2tusi+b2tusi+b2tsui
34358  a4stur=a4stur+b4stur+b4ustr+b4tusr
34359  a4stui=a4stui+b4stui+b4usti+b4tusi
34360  440 CONTINUE
34361  facgh=comfac*faca*3d0/(128d0*paru(1)**2)*aem/xw*as**3*
34362  & sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+
34363  & a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)
34364  facgh=facgh*wids(25,2)
34365  ENDIF
34366  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 450
34367  nchn=nchn+1
34368  isig(nchn,1)=21
34369  isig(nchn,2)=21
34370  isig(nchn,3)=1
34371  sigh(nchn)=facgh
34372  450 CONTINUE
34373  ENDIF
34374 
34375  ELSEIF(isub.LE.170) THEN
34376  IF(isub.EQ.121) THEN
34377 C...g + g -> Q + Qbar + h0
34378  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 460
34379  ia=kfpr(isubsv,2)
34380  pmf=pymrun(ia,sh)
34381  facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
34382  & (0.5d0*pmf/pmas(24,1))**2
34383  wid2=1d0
34384  IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
34385  facqqh=facqqh*wid2
34386  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
34387  ikfi=1
34388  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
34389  IF(ia.GT.10) ikfi=3
34390  facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
34391  IF(imss(1).NE.0.AND.ia.EQ.5) THEN
34392  facqqh=facqqh/(1d0+rmss(41))**2
34393  IF(ihigg.NE.3) THEN
34394  facqqh=facqqh*(1d0+rmss(41)*paru(152+10*ihigg)/
34395  & paru(151+10*ihigg))**2
34396  ENDIF
34397  ENDIF
34398  ENDIF
34399  CALL pyqqbh(wtqqbh)
34400  CALL pywidt(kfhigg,sh,wdtp,wdte)
34401  hs=shr*wdtp(0)
34402  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34403  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34404  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34405  & facbw=0d0
34406  nchn=nchn+1
34407  isig(nchn,1)=21
34408  isig(nchn,2)=21
34409  isig(nchn,3)=1
34410  sigh(nchn)=facqqh*wtqqbh*facbw
34411  460 CONTINUE
34412 
34413  ELSEIF(isub.EQ.122) THEN
34414 C...q + qbar -> Q + Qbar + h0
34415  ia=kfpr(isubsv,2)
34416  pmf=pymrun(ia,sh)
34417  facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
34418  & (0.5d0*pmf/pmas(24,1))**2
34419  wid2=1d0
34420  IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
34421  facqqh=facqqh*wid2
34422  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
34423  ikfi=1
34424  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
34425  IF(ia.GT.10) ikfi=3
34426  facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
34427  IF(imss(1).NE.0.AND.ia.EQ.5) THEN
34428  facqqh=facqqh/(1d0+rmss(41))**2
34429  IF(ihigg.NE.3) THEN
34430  facqqh=facqqh*(1d0+rmss(41)*paru(152+10*ihigg)/
34431  & paru(151+10*ihigg))**2
34432  ENDIF
34433  ENDIF
34434  ENDIF
34435  CALL pyqqbh(wtqqbh)
34436  CALL pywidt(kfhigg,sh,wdtp,wdte)
34437  hs=shr*wdtp(0)
34438  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34439  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34440  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34441  & facbw=0d0
34442  DO 470 i=mmina,mmaxa
34443  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
34444  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 470
34445  nchn=nchn+1
34446  isig(nchn,1)=i
34447  isig(nchn,2)=-i
34448  isig(nchn,3)=1
34449  sigh(nchn)=facqqh*wtqqbh*facbw
34450  470 CONTINUE
34451 
34452  ELSEIF(isub.EQ.123) THEN
34453 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34454 C...inner process)
34455  facnor=comfac*(4d0*paru(1)*aem/(xw*xw1))**3*sqmz/32d0
34456  IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
34457  & paru(154+10*ihigg)**2
34458  facprp=1d0/((vint(215)-vint(204)**2)*
34459  & (vint(216)-vint(209)**2))**2
34460  faczz1=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
34461  faczz2=facnor*facprp*vint(217)*vint(218)
34462  CALL pywidt(kfhigg,sh,wdtp,wdte)
34463  hs=shr*wdtp(0)
34464  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34465  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34466  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34467  & facbw=0d0
34468  DO 490 i=mmin1,mmax1
34469  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 490
34470  ia=iabs(i)
34471  DO 480 j=mmin2,mmax2
34472  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 480
34473  ja=iabs(j)
34474  ei=kchg(ia,1)*isign(1,i)/3d0
34475  ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
34476  vi=ai-4d0*ei*xwv
34477  ej=kchg(ja,1)*isign(1,j)/3d0
34478  aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
34479  vj=aj-4d0*ej*xwv
34480  faclr1=(vi**2+ai**2)*(vj**2+aj**2)+4d0*vi*ai*vj*aj
34481  faclr2=(vi**2+ai**2)*(vj**2+aj**2)-4d0*vi*ai*vj*aj
34482  nchn=nchn+1
34483  isig(nchn,1)=i
34484  isig(nchn,2)=j
34485  isig(nchn,3)=1
34486  sigh(nchn)=(faclr1*faczz1+faclr2*faczz2)*facbw
34487  480 CONTINUE
34488  490 CONTINUE
34489 
34490  ELSEIF(isub.EQ.124) THEN
34491 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34492 C...inner process)
34493  facnor=comfac*(4d0*paru(1)*aem/xw)**3*sqmw
34494  IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
34495  & paru(155+10*ihigg)**2
34496  facprp=1d0/((vint(215)-vint(204)**2)*
34497  & (vint(216)-vint(209)**2))**2
34498  facww=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
34499  CALL pywidt(kfhigg,sh,wdtp,wdte)
34500  hs=shr*wdtp(0)
34501  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34502  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34503  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34504  & facbw=0d0
34505  DO 510 i=mmin1,mmax1
34506  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 510
34507  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
34508  DO 500 j=mmin2,mmax2
34509  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 500
34510  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
34511  IF(ei*ej.GT.0d0) GOTO 500
34512  faclr=vint(180+i)*vint(180+j)
34513  nchn=nchn+1
34514  isig(nchn,1)=i
34515  isig(nchn,2)=j
34516  isig(nchn,3)=1
34517  sigh(nchn)=faclr*facww*facbw
34518  500 CONTINUE
34519  510 CONTINUE
34520 
34521  ELSEIF(isub.EQ.143) THEN
34522 C...f + fbar' -> H+/-
34523  sqmhc=pmas(37,1)**2
34524  CALL pywidt(37,sh,wdtp,wdte)
34525  hs=shr*wdtp(0)
34526  facbw=4d0*comfac/((sh-sqmhc)**2+hs**2)
34527  hp=aem/(8d0*xw)*sh/sqmw*sh
34528  DO 530 i=mmin1,mmax1
34529  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 530
34530  ia=iabs(i)
34531  im=(mod(ia,10)+1)/2
34532  DO 520 j=mmin2,mmax2
34533  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 520
34534  ja=iabs(j)
34535  jm=(mod(ja,10)+1)/2
34536  IF(i*j.GT.0.OR.ia.EQ.ja.OR.im.NE.jm) GOTO 520
34537  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
34538  & GOTO 520
34539  IF(mod(ia,2).EQ.0) THEN
34540  iu=ia
34541  il=ja
34542  ELSE
34543  iu=ja
34544  il=ia
34545  ENDIF
34546  rml=pymrun(il,sh)**2/sh
34547  rmu=pymrun(iu,sh)**2/sh
34548  hi=hp*(rml*paru(141)**2+rmu/paru(141)**2)
34549  IF(ia.LE.10) hi=hi*faca/3d0
34550  kchhc=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
34551  hf=shr*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
34552  nchn=nchn+1
34553  isig(nchn,1)=i
34554  isig(nchn,2)=j
34555  isig(nchn,3)=1
34556  sigh(nchn)=hi*facbw*hf
34557  520 CONTINUE
34558  530 CONTINUE
34559 
34560  ELSEIF(isub.EQ.161) THEN
34561 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34562 C...(choice of only b and t to avoid kinematics problems)
34563  fhcq=comfac*faca*as*aem/xw*1d0/24
34564 C...H propagator: as simulated in PYOFSH and as desired
34565  sqmhc=pmas(37,1)**2
34566  gmmhc=pmas(37,1)*pmas(37,2)
34567  hbw4=gmmhc/((sqm4-sqmhc)**2+gmmhc**2)
34568  CALL pywidt(37,sqm4,wdtp,wdte)
34569  gmmhcc=sqrt(sqm4)*wdtp(0)
34570  hbw4c=gmmhcc/((sqm4-sqmhc)**2+gmmhcc**2)
34571  fhcq=fhcq*hbw4c/hbw4
34572  q2rm=sh
34573  IF(mstp(32).EQ.12) q2rm=parp(194)
34574  DO 550 i=mmina,mmaxa
34575  ia=iabs(i)
34576  IF(ia.NE.5) GOTO 550
34577  sqml=pymrun(ia,q2rm)**2
34578  iua=ia+mod(ia,2)
34579  sqmq=pymrun(iua,q2rm)**2
34580  fachcq=fhcq*(sqml*paru(141)**2+sqmq/paru(141)**2)/sqmw*
34581  & (sh/(sqmq-uh)+2d0*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh-
34582  & 2d0*sqmq/(sqmq-uh)+2d0*(sqmhc-uh)/(sqmq-uh)*
34583  & (sqmhc-sqmq-sh)/sh)
34584  kchhc=isign(1,kchg(ia,1)*isign(1,i))
34585  DO 540 isde=1,2
34586  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 540
34587  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 540
34588  nchn=nchn+1
34589  isig(nchn,isde)=i
34590  isig(nchn,3-isde)=21
34591  isig(nchn,3)=1
34592  sigh(nchn)=fachcq*wids(37,(5-kchhc)/2)
34593  IF(iua.EQ.6) sigh(nchn)=sigh(nchn)*wids(6,(5+kchhc)/2)
34594  540 CONTINUE
34595  550 CONTINUE
34596  ENDIF
34597 
34598  ELSEIF(isub.LE.402) THEN
34599  IF(isub.EQ.401) THEN
34600 C... g + g -> t + bbar + H-
34601  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 560
34602  ia=kfpr(isubsv,2)
34603  CALL pystbh(wttbh)
34604  CALL pywidt(kfhigg,sh,wdtp,wdte)
34605  hs=shr*wdtp(0)
34606  facbw=(1d0/paru(1))*vint(2)*hs/((sh-sqmh)**2+hs**2)
34607  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34608  & facbw=0d0
34609  nchn=nchn+1
34610  isig(nchn,1)=21
34611  isig(nchn,2)=21
34612  isig(nchn,3)=1
34613  sigh(nchn)=2d0*comfac*wttbh*facbw
34614 c Since we don't know yet if H+ or H-, assume H+
34615 c when calculating suppression due to closed channels.
34616  sigh(nchn)=sigh(nchn)*wids(37,2)*wids(6,3)
34617  IF(abs(wids(37,2)-wids(37,3))
34618  & .GE.1d-6*(wids(37,2)+wids(37,3)).OR.
34619  & abs(wids(6,2)-wids(6,3))
34620  & .GE.1d-6*(wids(6,2)+wids(6,3))) THEN
34621  WRITE(*,*)'Error: Process 401 cannot handle different'
34622  WRITE(*,*)'decays for H+ and H- or t and tbar.'
34623  WRITE(*,*)'Execution stopped.'
34624  CALL pystop(108)
34625  END IF
34626  560 CONTINUE
34627 
34628  ELSEIF(isub.EQ.402) THEN
34629 C... q + qbar -> t + bbar + H-
34630  ia=kfpr(isubsv,2)
34631  CALL pystbh(wttbh)
34632  CALL pywidt(kfhigg,sh,wdtp,wdte)
34633  hs=shr*wdtp(0)
34634  facbw=(1d0/paru(1))*vint(2)*hs/((sh-sqmh)**2+hs**2)
34635  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34636  & facbw=0d0
34637  DO 570 i=mmina,mmaxa
34638  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
34639  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 570
34640  nchn=nchn+1
34641  isig(nchn,1)=i
34642  isig(nchn,2)=-i
34643  isig(nchn,3)=1
34644  sigh(nchn)=2d0*comfac*wttbh*facbw
34645 c Since we don't know yet if H+ or H-, assume H+
34646 c when calculating suppression due to closed channels.
34647  sigh(nchn)=sigh(nchn)*wids(37,2)*wids(6,3)
34648  IF(abs(wids(37,2)-wids(37,3))/(wids(37,2)+wids(37,3))
34649  & .GE.1d-6.OR.
34650  & abs(wids(6,2)-wids(6,3))/(wids(6,2)+wids(6,3))
34651  & .GE.1d-6) THEN
34652  WRITE(*,*)'Error: Process 402 cannot handle different'
34653  WRITE(*,*)'decays for H+ and H- or t and tbar.'
34654  WRITE(*,*)'Execution stopped.'
34655  CALL pystop(108)
34656  END IF
34657  570 CONTINUE
34658  ENDIF
34659  ENDIF
34660 
34661  RETURN
34662  END
34663 
34664 C*********************************************************************
34665 
34666 C...PYSGSU
34667 C...Subprocess cross sections for SUSY processes,
34668 C...including Higgs pair production.
34669 C...Auxiliary to PYSIGH.
34670 
34671  SUBROUTINE pysgsu(NCHN,SIGS)
34672 
34673 C...Double precision and integer declarations
34674  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34675  IMPLICIT INTEGER(I-N)
34676  INTEGER PYK,PYCHGE,PYCOMP
34677 C...Parameter statement to help give large particle numbers.
34678  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
34679  &kexcit=4000000,kdimen=5000000)
34680 C...Commonblocks
34681  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34682  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34683  common/pypars/mstp(200),parp(200),msti(200),pari(200)
34684  common/pyint1/mint(400),vint(400)
34685  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
34686  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
34687  common/pyint4/mwid(500),wids(500,5)
34688  common/pymssm/imss(0:99),rmss(0:99)
34689  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
34690  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
34691  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
34692  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
34693  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
34694  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
34695  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
34696  &/pyint4/,/pymssm/,/pyssmt/,/pysgcm/
34697 C...Local arrays and complex variables
34698  dimension wdtp(0:400),wdte(0:400,0:5)
34699  COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34700  COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34701  COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34702 
34703 CMRENNA++
34704 C...Z and W width, combinations of weak mixing angle
34705  zwid=pmas(23,2)
34706  wwid=pmas(24,2)
34707  tanw=sqrt(xw/xw1)
34708  ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
34709 
34710 C...Convert almost equivalent SUSY processes into each other
34711 C...Extract differences in flavours and couplings
34712 
34713 C...Sleptons and sneutrinos
34714  IF(isub.EQ.201.OR.isub.EQ.204.OR.isub.EQ.207) THEN
34715  kfid=mod(kfpr(isub,1),ksusy1)
34716  isub=201
34717  ilr=0
34718  ELSEIF(isub.EQ.202.OR.isub.EQ.205.OR.isub.EQ.208) THEN
34719  kfid=mod(kfpr(isub,1),ksusy1)
34720  isub=201
34721  ilr=1
34722  ELSEIF(isub.EQ.203.OR.isub.EQ.206.OR.isub.EQ.209) THEN
34723  kfid=mod(kfpr(isub,1),ksusy1)
34724  isub=203
34725  ELSEIF(isub.GE.210.AND.isub.LE.212) THEN
34726  IF(isub.EQ.210) THEN
34727  rkf=2.0d0
34728  ELSEIF(isub.EQ.211) THEN
34729  rkf=sfmix(15,1)**2
34730  ELSEIF(isub.EQ.212) THEN
34731  rkf=sfmix(15,2)**2
34732  ENDIF
34733  isub=210
34734  ELSEIF(isub.EQ.213.OR.isub.EQ.214) THEN
34735  IF(isub.EQ.213) THEN
34736  kfid=mod(kfpr(isub,1),ksusy1)
34737  rkf=2.0d0
34738  ELSEIF(isub.EQ.214) THEN
34739  kfid=16
34740  rkf=1.0d0
34741  ENDIF
34742  isub=213
34743 
34744 C...Neutralinos
34745  ELSEIF(isub.GE.216.AND.isub.LE.225) THEN
34746  IF(isub.EQ.216) THEN
34747  izid1=1
34748  izid2=1
34749  ELSEIF(isub.EQ.217) THEN
34750  izid1=2
34751  izid2=2
34752  ELSEIF(isub.EQ.218) THEN
34753  izid1=3
34754  izid2=3
34755  ELSEIF(isub.EQ.219) THEN
34756  izid1=4
34757  izid2=4
34758  ELSEIF(isub.EQ.220) THEN
34759  izid1=1
34760  izid2=2
34761  ELSEIF(isub.EQ.221) THEN
34762  izid1=1
34763  izid2=3
34764  ELSEIF(isub.EQ.222) THEN
34765  izid1=1
34766  izid2=4
34767  ELSEIF(isub.EQ.223) THEN
34768  izid1=2
34769  izid2=3
34770  ELSEIF(isub.EQ.224) THEN
34771  izid1=2
34772  izid2=4
34773  ELSEIF(isub.EQ.225) THEN
34774  izid1=3
34775  izid2=4
34776  ENDIF
34777  isub=216
34778 
34779 C...Charginos
34780  ELSEIF(isub.GE.226.AND.isub.LE.228) THEN
34781  IF(isub.EQ.226) THEN
34782  izid1=1
34783  izid2=1
34784  ELSEIF(isub.EQ.227) THEN
34785  izid1=2
34786  izid2=2
34787  ELSEIF(isub.EQ.228) THEN
34788  izid1=1
34789  izid2=2
34790  ENDIF
34791  isub=226
34792 
34793 C...Neutralino + chargino
34794  ELSEIF(isub.GE.229.AND.isub.LE.236) THEN
34795  IF(isub.EQ.229) THEN
34796  izid1=1
34797  izid2=1
34798  ELSEIF(isub.EQ.230) THEN
34799  izid1=1
34800  izid2=2
34801  ELSEIF(isub.EQ.231) THEN
34802  izid1=1
34803  izid2=3
34804  ELSEIF(isub.EQ.232) THEN
34805  izid1=1
34806  izid2=4
34807  ELSEIF(isub.EQ.233) THEN
34808  izid1=2
34809  izid2=1
34810  ELSEIF(isub.EQ.234) THEN
34811  izid1=2
34812  izid2=2
34813  ELSEIF(isub.EQ.235) THEN
34814  izid1=2
34815  izid2=3
34816  ELSEIF(isub.EQ.236) THEN
34817  izid1=2
34818  izid2=4
34819  ENDIF
34820  isub=229
34821 
34822 C...Gluino + neutralino
34823  ELSEIF(isub.GE.237.AND.isub.LE.240) THEN
34824  IF(isub.EQ.237) THEN
34825  izid=1
34826  ELSEIF(isub.EQ.238) THEN
34827  izid=2
34828  ELSEIF(isub.EQ.239) THEN
34829  izid=3
34830  ELSEIF(isub.EQ.240) THEN
34831  izid=4
34832  ENDIF
34833  isub=237
34834 
34835 C...Gluino + chargino
34836  ELSEIF(isub.GE.241.AND.isub.LE.242) THEN
34837  IF(isub.EQ.241) THEN
34838  izid=1
34839  ELSEIF(isub.EQ.242) THEN
34840  izid=2
34841  ENDIF
34842  isub=241
34843 
34844 C...Squark + neutralino
34845  ELSEIF(isub.GE.246.AND.isub.LE.253) THEN
34846  ilr=0
34847  IF(mod(isub,2).NE.0) ilr=1
34848  IF(isub.LE.247) THEN
34849  izid=1
34850  ELSEIF(isub.LE.249) THEN
34851  izid=2
34852  ELSEIF(isub.LE.251) THEN
34853  izid=3
34854  ELSEIF(isub.LE.253) THEN
34855  izid=4
34856  ENDIF
34857  isub=246
34858  rkf=5d0
34859 
34860 C...Squark + chargino
34861  ELSEIF(isub.GE.254.AND.isub.LE.257) THEN
34862  IF(isub.LE.255) THEN
34863  izid=1
34864  ELSEIF(isub.LE.257) THEN
34865  izid=2
34866  ENDIF
34867  IF(mod(isub,2).EQ.0) THEN
34868  ilr=0
34869  ELSE
34870  ilr=1
34871  ENDIF
34872  isub=254
34873  rkf=5d0
34874 
34875 C...Squark + gluino
34876  ELSEIF(isub.EQ.258.OR.isub.EQ.259) THEN
34877  isub=258
34878  rkf=4d0
34879 
34880 C...Stops
34881  ELSEIF(isub.EQ.261.OR.isub.EQ.262) THEN
34882  ilr=0
34883  IF(isub.EQ.262) ilr=1
34884  isub=261
34885  ELSEIF(isub.EQ.265) THEN
34886  isub=264
34887 
34888 C...Squarks
34889  ELSEIF(isub.GE.271.AND.isub.LE.280) THEN
34890  ilr=0
34891  IF(isub.LE.273) THEN
34892  IF(isub.EQ.273) ilr=1
34893  isub=271
34894  rkf=16d0
34895  ELSEIF(isub.LE.276) THEN
34896  IF(isub.EQ.276) ilr=1
34897  isub=274
34898  rkf=16d0
34899  ELSEIF(isub.LE.278) THEN
34900  IF(isub.EQ.278) ilr=1
34901  isub=277
34902  rkf=4d0
34903  ELSE
34904  IF(isub.EQ.280) ilr=1
34905  isub=279
34906  rkf=4d0
34907  ENDIF
34908 C...Sbottoms
34909  ELSEIF(isub.GE.281.AND.isub.LE.296) THEN
34910  ilr=0
34911  IF(isub.LE.283) THEN
34912  IF(isub.EQ.283) ilr=1
34913  isub=271
34914  rkf=4d0
34915  ELSEIF(isub.LE.286) THEN
34916  IF(isub.EQ.286) ilr=1
34917  isub=274
34918  rkf=4d0
34919  ELSEIF(isub.LE.288) THEN
34920  IF(isub.EQ.288) ilr=1
34921  isub=277
34922  rkf=1d0
34923  ELSEIF(isub.LE.290) THEN
34924  IF(isub.EQ.290) ilr=1
34925  isub=279
34926  rkf=1d0
34927  ELSEIF(isub.LE.293) THEN
34928  IF(isub.EQ.293) ilr=1
34929  isub=271
34930  rkf=1d0
34931  ELSEIF(isub.EQ.296) THEN
34932  ilr=1
34933  isub=274
34934  rkf=1d0
34935 C...Squark + gluino
34936  ELSEIF(isub.EQ.294.OR.isub.EQ.295) THEN
34937  isub=258
34938  rkf=1d0
34939  ENDIF
34940 C...H+/- + H0
34941  ELSEIF(isub.EQ.297.OR.isub.EQ.298) THEN
34942  IF(isub.EQ.297) THEN
34943  rkf=.5d0*paru(195)**2
34944  ELSEIF(isub.EQ.298) THEN
34945  rkf=.5d0*(1d0-paru(195)**2)
34946  ENDIF
34947  isub=210
34948 C...A0 + H0
34949  ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
34950  IF(isub.EQ.299) THEN
34951  rkf=paru(186)**2
34952  kfid=25
34953  ELSEIF(isub.EQ.300) THEN
34954  rkf=paru(187)**2
34955  kfid=35
34956  ENDIF
34957  isub=213
34958 C...H+ + H-
34959  ELSEIF(isub.EQ.301) THEN
34960  kfid=37
34961  rkf=1d0
34962  isub=201
34963  ENDIF
34964 
34965 C...Supersymmetric processes - all of type 2 -> 2 :
34966 C...correct final-state Breit-Wigners from fixed to running width.
34967  IF(mstp(42).GT.0) THEN
34968  DO 100 i=1,2
34969  kflw=kfpr(isubsv,i)
34970  kcw=pycomp(kflw)
34971  IF(pmas(kcw,2).LT.parp(41)) GOTO 100
34972  IF(i.EQ.1) sqmi=sqm3
34973  IF(i.EQ.2) sqmi=sqm4
34974  sqms=pmas(kcw,1)**2
34975  gmms=pmas(kcw,1)*pmas(kcw,2)
34976  hbws=gmms/((sqmi-sqms)**2+gmms**2)
34977  CALL pywidt(kflw,sqmi,wdtp,wdte)
34978  gmmi=sqrt(sqmi)*wdtp(0)
34979  hbwi=gmmi/((sqmi-sqms)**2+gmmi**2)
34980  comfac=comfac*(hbwi/hbws)
34981  100 CONTINUE
34982  ENDIF
34983 
34984 C...Differential cross section expressions.
34985 
34986  IF(isub.LE.210) THEN
34987  IF(isub.EQ.201) THEN
34988 C...f + fbar -> e_L + e_Lbar
34989  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
34990  DO 130 i=mmin1,mmax1
34991  ia=iabs(i)
34992  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 130
34993  ei=kchg(ia,1)/3d0
34994  tt3i=sign(1d0,ei+1d-6)/2d0
34995  ej=-1d0
34996  tt3j=-1d0/2d0
34997  fcol=1d0
34998 C...Color factor for e+ e-
34999  IF(ia.GE.11) fcol=3d0
35000  IF(isubsv.EQ.301) THEN
35001  a1=1d0
35002  a2=0d0
35003  ELSEIF(ilr.EQ.1) THEN
35004  a1=sfmix(kfid,3)**2
35005  a2=sfmix(kfid,4)**2
35006  ELSEIF(ilr.EQ.0) THEN
35007  a1=sfmix(kfid,1)**2
35008  a2=sfmix(kfid,2)**2
35009  ENDIF
35010  xlq=(tt3j-ej*xw)*a1
35011  xrq=(-ej*xw)*a2
35012  xlf=(tt3i-ei*xw)
35013  xrf=(-ei*xw)
35014  taa=(ei*ej)**2*(poll+polr)
35015  tzz=(xlf**2*poll+xrf**2*polr)*(xlq+xrq)**2/xw**2/xw1**2
35016  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*zwid/sh**2)
35017  taz=2d0*ei*ej*(xlq+xrq)*(xlf*poll+xrf*polr)/xw/xw1
35018  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
35019  tnn=0.0d0
35020  tan=0.0d0
35021  tzn=0.0d0
35022  IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
35023  fac2=sqrt(2d0)
35024  tnn1=0d0
35025  tnn2=0d0
35026  tnn3=0d0
35027  DO 120 ii=1,4
35028  dk=1d0/(th-smz(ii)**2)
35029  flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
35030  & zmix(ii,1))
35031  frek=fac2*tanw*ei*zmix(ii,1)
35032  tnn1=tnn1+flek**2*dk
35033  tnn2=tnn2+frek**2*dk
35034  DO 110 jj=1,4
35035  dl=1d0/(th-smz(jj)**2)
35036  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
35037  & zmix(jj,1))
35038  frel=fac2*tanw*ej*zmix(jj,1)
35039  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
35040  110 CONTINUE
35041  120 CONTINUE
35042  tnn=(uh*th-sqm3*sqm4)*(a1**2*tnn1**2*poll+
35043  & a2**2*tnn2**2*polr)
35044  tnn=(tnn+sh*a1*a2*tnn3*((1d0-parj(131))*(1d0-parj(132))+
35045  & (1d0+parj(131))*(1d0+parj(132))))/4d0/xw**2
35046  tzn=(uh*th-sqm3*sqm4)*(xlq+xrq)*
35047  & (tnn1*xlf*a1*poll+tnn2*xrf*a2*polr)
35048  tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
35049  & (1d0-sqmz/sh)/sh
35050  tzn=tzn/xw**2/xw1
35051  tan=ei*ej*(uh*th-sqm3*sqm4)/sh*(a1*tnn1*poll+
35052  & a2*tnn2*polr)/xw
35053  ENDIF
35054  facqq1=comfac*aem**2*(taa+tzz+taz)*fcol/3d0
35055  facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh**2
35056  facqq2=comfac*aem**2*(tnn+tzn+tan)*fcol/3d0
35057  nchn=nchn+1
35058  isig(nchn,1)=i
35059  isig(nchn,2)=-i
35060  isig(nchn,3)=1
35061  sigh(nchn)=facqq1+facqq2
35062  130 CONTINUE
35063 
35064  ELSEIF(isub.EQ.203) THEN
35065 C...f + fbar -> e_L + e_Rbar
35066  DO 160 i=mmin1,mmax1
35067  ia=iabs(i)
35068  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 160
35069  ei=kchg(iabs(i),1)/3d0
35070  tt3i=sign(1d0,ei)/2d0
35071  ej=-1
35072  tt3j=-1d0/2d0
35073  fcol=1d0
35074 C...Color factor for e+ e-
35075  IF(ia.GE.11) fcol=3d0
35076  a1=sfmix(kfid,1)**2
35077  a2=sfmix(kfid,2)**2
35078  xlq=(tt3j-ej*xw)
35079  xrq=(-ej*xw)
35080  xlf=(tt3i-ei*xw)
35081  xrf=(-ei*xw)
35082  tzz=(xlf**2*poll+xrf**2*polr)*(xlq-xrq)**2
35083  & /xw**2/xw1**2*a1*a2
35084  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35085  tnn=0.0d0
35086  tzn=0.0d0
35087  tnna=0d0
35088  tnnb=0d0
35089  IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
35090  fac2=sqrt(2d0)
35091  tnn1=0d0
35092  tnn2=0d0
35093  tnn3=0d0
35094  DO 150 ii=1,4
35095  dk=1d0/(th-smz(ii)**2)
35096  flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
35097  & zmix(ii,1))
35098  frek=fac2*tanw*ei*zmix(ii,1)
35099  tnn1=tnn1+flek**2*dk
35100  tnn2=tnn2+frek**2*dk
35101  DO 140 jj=1,4
35102  dl=1d0/(th-smz(jj)**2)
35103  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
35104  & zmix(jj,1))
35105  frel=fac2*tanw*ej*zmix(jj,1)
35106  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
35107  140 CONTINUE
35108  150 CONTINUE
35109  tnn=(uh*th-sqm3*sqm4)*a1*a2*(tnn2**2*polr+tnn1**2*poll)
35110  tnna=(tnn+sh*(a1**2*polll+a2**2*polrr)*tnn3)/4d0
35111  tnnb=(tnn+sh*(a1**2*polrr+a2**2*polll)*tnn3)/4d0
35112  tzn=(uh*th-sqm3*sqm4)*a1*a2
35113  tzn=tzn*(xlq-xrq)*(xlf*tnn1*poll-xrf*tnn2*polr)/xw1
35114  tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
35115  & (1d0-sqmz/sh)/sh
35116  ENDIF
35117  facqq0=comfac*aem**2*tzz*fcol/3d0*(uh*th-sqm3*sqm4)/sh2
35118  facqq2=comfac*aem**2/xw**2*(tnna+tzn)*fcol/3d0
35119  facqq1=comfac*aem**2/xw**2*(tnnb+tzn)*fcol/3d0
35120 C%%%%%%%%%%%
35121  nchn=nchn+1
35122  isig(nchn,1)=i
35123  isig(nchn,2)=-i
35124  isig(nchn,3)=1
35125  sigh(nchn)=(facqq0+facqq1)*wids(pycomp(kfpr(isubsv,1)),2)*
35126  & wids(pycomp(kfpr(isubsv,2)),3)
35127  nchn=nchn+1
35128  isig(nchn,1)=i
35129  isig(nchn,2)=-i
35130  isig(nchn,3)=2
35131  sigh(nchn)=(facqq0+facqq2)*wids(pycomp(kfpr(isubsv,1)),3)*
35132  & wids(pycomp(kfpr(isubsv,2)),2)
35133  160 CONTINUE
35134 
35135  ELSEIF(isub.EQ.210) THEN
35136 C...q + qbar' -> W*- > ~l_L + ~nu_L
35137  fac0=rkf*comfac*aem**2/xw**2/12d0
35138  fac1=(th*uh-sqm3*sqm4)/((sh-sqmw)**2+wwid**2*sqmw)
35139  DO 180 i=mmin1,mmax1
35140  ia=iabs(i)
35141  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 180
35142  DO 170 j=mmin2,mmax2
35143  ja=iabs(j)
35144  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 170
35145  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 170
35146  fckm=3d0
35147  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
35148  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
35149  kchw=2
35150  IF(kchsum.LT.0) kchw=3
35151  nchn=nchn+1
35152  isig(nchn,1)=i
35153  isig(nchn,2)=j
35154  isig(nchn,3)=1
35155  IF(isubsv.EQ.297.OR.isubsv.EQ.298) THEN
35156  facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
35157  & wids(pycomp(kfpr(isubsv,2)),2)
35158  ELSE
35159  facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
35160  & wids(pycomp(kfpr(isubsv,2)),kchw)
35161  ENDIF
35162  sigh(nchn)=fac0*fac1*fckm*facr
35163  170 CONTINUE
35164  180 CONTINUE
35165  ENDIF
35166 
35167  ELSEIF(isub.LE.220) THEN
35168  IF(isub.EQ.213) THEN
35169 C...f + fbar -> ~nu_L + ~nu_Lbar
35170  IF(isubsv.EQ.299.OR.isubsv.EQ.300) THEN
35171  facr=wids(pycomp(kfpr(isubsv,1)),2)*
35172  & wids(pycomp(kfpr(isubsv,2)),2)
35173  ELSE
35174  facr=wids(pycomp(kfpr(isubsv,1)),1)
35175  ENDIF
35176  comfac=comfac*facr
35177  propz2=(sh-sqmz)**2+zwid**2*sqmz
35178  xll=0.5d0
35179  xlr=0.0d0
35180  DO 190 i=mmin1,mmax1
35181  ia=iabs(i)
35182  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 190
35183  ei=kchg(ia,1)/3d0
35184  fcol=1d0
35185 C...Color factor for e+ e-
35186  IF(ia.GE.11) fcol=3d0
35187  xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
35188  xrq=-ei*xw
35189  tzc=0.0d0
35190  tcc=0.0d0
35191  IF(ia.GE.11.AND.kfid.EQ.ia+1) THEN
35192  tzc=vmix(1,1)**2/(th-smw(1)**2)+vmix(2,1)**2/
35193  & (th-smw(2)**2)
35194  tcc=tzc**2
35195  tzc=tzc/xw1*(sh-sqmz)/propz2*xlq*xll
35196  ENDIF
35197  facqq1=(xlq**2+xrq**2)*(xll+xlr)**2/xw1**2/propz2
35198  facqq2=tzc+tcc/4d0
35199  nchn=nchn+1
35200  isig(nchn,1)=i
35201  isig(nchn,2)=-i
35202  isig(nchn,3)=1
35203  sigh(nchn)=(facqq1+facqq2)*rkf*(uh*th-sqm3*sqm4)*comfac
35204  & *aem**2*fcol/3d0/xw**2
35205  190 CONTINUE
35206 
35207  ELSEIF(isub.EQ.216) THEN
35208 C...q + qbar -> ~chi0_1 + ~chi0_1
35209  IF(izid1.EQ.izid2) THEN
35210  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35211  ELSE
35212  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
35213  & wids(pycomp(kfpr(isubsv,2)),2)
35214  ENDIF
35215  facxx=comfac*aem**2/3d0/xw**2
35216  IF(izid1.EQ.izid2) facxx=facxx/2d0
35217  zm12=sqm3
35218  zm22=sqm4
35219  wu2 = (uh-zm12)*(uh-zm22)
35220  wt2 = (th-zm12)*(th-zm22)
35221  ws2 = smz(izid1)*smz(izid2)*sh
35222  propz2 = (sh-sqmz)**2 + sqmz*zwid**2
35223  propz=dcmplx(sh-sqmz,-zwid*pmas(23,1))/dcmplx(propz2)
35224  DO 200 i=1,4
35225  zmixc(izid1,i)=dcmplx(zmix(izid1,i),zmixi(izid1,i))
35226  IF(izid2.NE.izid1) THEN
35227  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
35228  ENDIF
35229  200 CONTINUE
35230  olpp=(zmixc(izid1,3)*dconjg(zmixc(izid2,3))-
35231  & zmixc(izid1,4)*dconjg(zmixc(izid2,4)))/2d0
35232  orpp=dconjg(olpp)
35233  DO 210 i=mmina,mmaxa
35234  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 210
35235  ei=kchg(iabs(i),1)/3d0
35236  t3i=sign(1d0,ei+1d-6)/2d0
35237  xml2=pmas(pycomp(ksusy1+iabs(i)),1)**2
35238  xmr2=pmas(pycomp(ksusy2+iabs(i)),1)**2
35239  glij=(t3i*zmixc(izid1,2)-tanw*(t3i-ei)*zmixc(izid1,1))*
35240  & dconjg(t3i*zmixc(izid2,2)-tanw*(t3i-ei)*zmixc(izid2,1))
35241  grij=zmixc(izid1,1)*dconjg(zmixc(izid2,1))*(ei*tanw)**2
35242  qll=dcmplx((t3i-ei*xw)/xw1)*olpp*propz-glij/dcmplx(uh-xml2)
35243  qlr=-dcmplx((t3i-ei*xw)/xw1)*orpp*propz+dconjg(glij)
35244  & /dcmplx(th-xml2)
35245  qrl=-dcmplx((ei*xw)/xw1)*olpp*propz+grij/dcmplx(th-xmr2)
35246  qrr=dcmplx((ei*xw)/xw1)*orpp*propz
35247  & -dconjg(grij)/dcmplx(uh-xmr2)
35248  fcol=1d0
35249  IF(iabs(i).GE.11) fcol=3d0
35250  facgg1=(abs(qll)**2*poll+abs(qrr)**2*polr)*wu2+
35251  & (abs(qrl)**2*polr+abs(qlr)**2*poll)*wt2+
35252  & 2d0*dble(qlr*dconjg(qll)*poll+
35253  & qrl*dconjg(qrr)*polr)*ws2
35254  nchn=nchn+1
35255  isig(nchn,1)=i
35256  isig(nchn,2)=-i
35257  isig(nchn,3)=1
35258  sigh(nchn)=facxx*facgg1*fcol
35259  210 CONTINUE
35260  ENDIF
35261 
35262  ELSEIF(isub.LE.230) THEN
35263  IF(isub.EQ.226) THEN
35264 C...f + fbar -> ~chi+_1 + ~chi-_1
35265  facxx=comfac*aem**2/3d0
35266  zm12=sqm3
35267  zm22=sqm4
35268  wu2 = (uh-zm12)*(uh-zm22)
35269  wt2 = (th-zm12)*(th-zm22)
35270  ws2 = smw(izid1)*smw(izid2)*sh
35271  propz2 = (sh-sqmz)**2 + sqmz*zwid**2
35272  propz=dcmplx(sh-sqmz,-zwid*pmas(23,1))/dcmplx(propz2)
35273  diff=0d0
35274  IF(izid1.EQ.izid2) diff=1d0
35275  DO 220 i=1,2
35276  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
35277  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
35278  IF(izid2.NE.izid1) THEN
35279  vmixc(izid2,i)=dcmplx(vmix(izid2,i),vmixi(izid2,i))
35280  umixc(izid2,i)=dcmplx(umix(izid2,i),umixi(izid2,i))
35281  ENDIF
35282  220 CONTINUE
35283  olp=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))-
35284  & vmixc(izid2,2)*dconjg(vmixc(izid1,2))/2d0+dcmplx(xw*diff)
35285  orp=-umixc(izid1,1)*dconjg(umixc(izid2,1))-
35286  & umixc(izid1,2)*dconjg(umixc(izid2,2))/2d0+dcmplx(xw*diff)
35287  DO 230 i=mmina,mmaxa
35288  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 230
35289  ei=kchg(iabs(i),1)/3d0
35290  t3i=sign(1d0,ei+1d-6)/2d0
35291  qrl=dcmplx(-ei/sh*diff)-dcmplx(ei/xw1)*propz*orp
35292  qll=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*propz*orp
35293  qrr=dcmplx(-ei/sh*diff)-dcmplx(ei/xw1)*propz*olp
35294  IF(mod(i,2).EQ.0) THEN
35295  xml2=pmas(pycomp(ksusy1+iabs(i)-1),1)**2
35296  qlr=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*
35297  & propz*olp-umixc(izid2,1)*dconjg(umixc(izid1,1))*
35298  & dcmplx(t3i/xw/(th-xml2))
35299  ELSE
35300  xml2=pmas(pycomp(ksusy1+iabs(i)+1),1)**2
35301  qlr=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*
35302  & propz*olp-vmixc(izid2,1)*dconjg(vmixc(izid1,1))*
35303  & dcmplx(t3i/xw/(th-xml2))
35304  ENDIF
35305  fcol=1d0
35306  IF(iabs(i).GE.11) fcol=3d0
35307  facsum=((abs(qll)**2*poll+abs(qrr)**2*polr)*wu2+
35308  & (abs(qrl)**2*polr+abs(qlr)**2*poll)*wt2+
35309  & 2d0*dble(qlr*dconjg(qll)*poll+
35310  & qrl*dconjg(qrr)*polr)*ws2)*facxx*fcol
35311  nchn=nchn+1
35312  isig(nchn,1)=i
35313  isig(nchn,2)=-i
35314  isig(nchn,3)=1
35315  IF(izid1.EQ.izid2) THEN
35316  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),1)
35317  ELSE
35318  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),3)*
35319  & wids(pycomp(kfpr(isubsv,2)),2)
35320  nchn=nchn+1
35321  isig(nchn,1)=i
35322  isig(nchn,2)=-i
35323  isig(nchn,3)=2
35324  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),2)*
35325  & wids(pycomp(kfpr(isubsv,2)),3)
35326  ENDIF
35327  230 CONTINUE
35328 
35329  ELSEIF(isub.EQ.229) THEN
35330 C...q + qbar' -> ~chi0_1 + ~chi+-_1
35331  facxx=comfac*aem**2/6d0/xw**2
35332  zm12=sqm3
35333  zm22=sqm4
35334  wu2 = (uh-zm12)*(uh-zm22)
35335  wt2 = (th-zm12)*(th-zm22)
35336  ws2 = smw(izid1)*smz(izid2)*sh
35337  rt2i = 1d0/sqrt(2d0)
35338  propw = dcmplx(sh-sqmw,-wwid*pmas(24,1))/
35339  & dcmplx((sh-sqmw)**2+wwid**2*sqmw,0d0)
35340  DO 240 i=1,2
35341  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
35342  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
35343  240 CONTINUE
35344  DO 250 i=1,4
35345  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
35346  250 CONTINUE
35347  ol=(dconjg(zmixc(izid2,2))*vmixc(izid1,1)-
35348  & dconjg(zmixc(izid2,4))*vmixc(izid1,2)*rt2i)*propw
35349  or=(zmixc(izid2,2)*dconjg(umixc(izid1,1))+
35350  & zmixc(izid2,3)*dconjg(umixc(izid1,2))*rt2i)*propw
35351 
35352  DO 270 i=mmin1,mmax1
35353  ia=iabs(i)
35354  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 270
35355  ei=kchg(ia,1)/3d0
35356  t3i=sign(1d0,ei+1d-6)/2d0
35357  DO 260 j=mmin2,mmax2
35358  ja=iabs(j)
35359  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 260
35360  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 260
35361  ej=kchg(ja,1)/3d0
35362  t3j=sign(1d0,ej+1d-6)/2d0
35363  fckm=3d0
35364  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
35365  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
35366  kchw=2
35367  IF(kchsum.LT.0) kchw=3
35368  IF(mod(ia,2).EQ.0) THEN
35369  zmi2 = pmas(pycomp(ksusy1+ia),1)**2
35370  zmj2 = pmas(pycomp(ksusy1+ja),1)**2
35371  qll=ol+vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ei-t3i)*
35372  & tanw+zmixc(izid2,2)*t3i)/dcmplx(uh-zmi2)
35373  qlr=or-dconjg(umixc(izid1,1))*(
35374  & zmixc(izid2,1)*(ej-t3j)*tanw+zmixc(izid2,2)*t3j)
35375  & /dcmplx(th-zmj2)
35376  ELSE
35377  zmi2 = pmas(pycomp(ksusy1+ja),1)**2
35378  zmj2 = pmas(pycomp(ksusy1+ia),1)**2
35379  qll=ol+vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ej-t3j)*
35380  & tanw+zmixc(izid2,2)*t3j)/dcmplx(uh-zmj2)
35381  qlr=or-dconjg(umixc(izid1,1))*(
35382  & zmixc(izid2,1)*(ei-t3i)*tanw+zmixc(izid2,2)*t3i)
35383  & /dcmplx(th-zmi2)
35384  ENDIF
35385  zintr=dble(qlr*dconjg(qll))
35386  facgg1=facxx*(abs(qll)**2*wu2+abs(qlr)**2*wt2+
35387  & 2d0*zintr*ws2)
35388  nchn=nchn+1
35389  isig(nchn,1)=i
35390  isig(nchn,2)=j
35391  isig(nchn,3)=1
35392  sigh(nchn)=facgg1*fckm*wids(pycomp(kfpr(isubsv,1)),2)*
35393  & wids(pycomp(kfpr(isubsv,2)),kchw)
35394  260 CONTINUE
35395  270 CONTINUE
35396  ENDIF
35397 
35398  ELSEIF(isub.LE.240) THEN
35399  IF(isub.EQ.237) THEN
35400 C...q + qbar -> gluino + ~chi0_1
35401  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
35402  & wids(pycomp(kfpr(isubsv,2)),2)
35403  asyuk=rmss(42)*as
35404  fac0=comfac*asyuk*aem*4d0/9d0/xw
35405  gm2=sqm3
35406  zm2=sqm4
35407  DO 280 i=mmina,mmaxa
35408  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 280
35409  ei=kchg(iabs(i),1)/3d0
35410  ia=iabs(i)
35411  xlqc = -tanw*ei*zmix(izid,1)
35412  xrqc =(sign(1d0,ei)*zmix(izid,2)-tanw*
35413  & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
35414  xlq2=xlqc**2
35415  xrq2=xrqc**2
35416  xml2=pmas(pycomp(ksusy1+ia),1)**2
35417  xmr2=pmas(pycomp(ksusy2+ia),1)**2
35418  atkin=(th-gm2)*(th-zm2)/(th-xml2)**2
35419  aukin=(uh-gm2)*(uh-zm2)/(uh-xml2)**2
35420  atukin=smz(izid)*sqrt(gm2)*sh/(th-xml2)/(uh-xml2)
35421  sgchil=xlq2*(atkin+aukin-2d0*atukin)
35422  atkin=(th-gm2)*(th-zm2)/(th-xmr2)**2
35423  aukin=(uh-gm2)*(uh-zm2)/(uh-xmr2)**2
35424  atukin=smz(izid)*sqrt(gm2)*sh/(th-xmr2)/(uh-xmr2)
35425  sgchir=xrq2*(atkin+aukin-2d0*atukin)
35426  nchn=nchn+1
35427  isig(nchn,1)=i
35428  isig(nchn,2)=-i
35429  isig(nchn,3)=1
35430  sigh(nchn)=fac0*(sgchil+sgchir)
35431  280 CONTINUE
35432  ENDIF
35433 
35434  ELSEIF(isub.LE.250) THEN
35435  IF(isub.EQ.241) THEN
35436 C...q + qbar' -> ~chi+-_1 + gluino
35437  facwg=comfac*as*aem/xw*2d0/9d0
35438  gm2=sqm3
35439  zm2=sqm4
35440  fac01=2d0*umix(izid,1)*vmix(izid,1)
35441  fac0=umix(izid,1)**2
35442  fac1=vmix(izid,1)**2
35443  DO 300 i=mmin1,mmax1
35444  ia=iabs(i)
35445  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 300
35446  DO 290 j=mmin2,mmax2
35447  ja=iabs(j)
35448  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 290
35449  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 290
35450  fckm=1d0
35451  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
35452  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
35453  kchw=2
35454  IF(kchsum.LT.0) kchw=3
35455  xmu2=pmas(pycomp(ksusy1+2),1)**2
35456  xmd2=pmas(pycomp(ksusy1+1),1)**2
35457  atkin=(th-gm2)*(th-zm2)/(th-xmu2)**2
35458  aukin=(uh-gm2)*(uh-zm2)/(uh-xmd2)**2
35459  atukin=smw(izid)*sqrt(gm2)*sh/(th-xmu2)/(uh-xmd2)
35460  xmu2=pmas(pycomp(ksusy2+2),1)**2
35461  xmd2=pmas(pycomp(ksusy2+1),1)**2
35462  atkin=(atkin+(th-gm2)*(th-zm2)/(th-xmu2)**2)/2d0
35463  aukin=(aukin+(uh-gm2)*(uh-zm2)/(uh-xmd2)**2)/2d0
35464  atukin=(atukin+smw(izid)*sqrt(gm2)*
35465  & sh/(th-xmu2)/(uh-xmd2))/2d0
35466  nchn=nchn+1
35467  isig(nchn,1)=i
35468  isig(nchn,2)=j
35469  isig(nchn,3)=1
35470  sigh(nchn)=facwg*fckm*(fac0*atkin+fac1*aukin-
35471  & fac01*atukin)*wids(pycomp(kfpr(isubsv,1)),2)*
35472  & wids(pycomp(kfpr(isubsv,2)),kchw)
35473  290 CONTINUE
35474  300 CONTINUE
35475 
35476  ELSEIF(isub.EQ.243) THEN
35477 C...q + qbar -> gluino + gluino
35478  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35479  xmt=sqm3-th
35480  xmu=sqm3-uh
35481  DO 310 i=mmina,mmaxa
35482  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
35483  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 310
35484  nchn=nchn+1
35485  xsu=pmas(pycomp(ksusy1+iabs(i)),1)**2-uh
35486  xst=pmas(pycomp(ksusy1+iabs(i)),1)**2-th
35487  facgg1=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
35488  & 2d0*sqm3*sh)/sh2 + rmss(42)**2*(4d0/9d0*(xmt**2/xst**2+
35489  & xmu**2/xsu**2) + sqm3*sh/xst/xsu/9d0) - rmss(42)*(
35490  & (xmt**2+sh*sqm3)/sh/xst + (xmu**2+sh*sqm3)/sh/xsu ))
35491  xsu=pmas(pycomp(ksusy2+iabs(i)),1)**2-uh
35492  xst=pmas(pycomp(ksusy2+iabs(i)),1)**2-th
35493  facgg2=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
35494  & 2d0*sqm3*sh)/sh2 + rmss(42)**2*(4d0/9d0*(xmt**2/xst**2+
35495  & xmu**2/xsu**2) + sqm3*sh/xst/xsu/9d0) - rmss(42)*(
35496  & (xmt**2+sh*sqm3)/sh/xst + (xmu**2+sh*sqm3)/sh/xsu ))
35497  isig(nchn,1)=i
35498  isig(nchn,2)=-i
35499  isig(nchn,3)=1
35500 C...1/2 for identical particles
35501  sigh(nchn)=0.25d0*(facgg1+facgg2)
35502  310 CONTINUE
35503 
35504  ELSEIF(isub.EQ.244) THEN
35505 C...g + g -> gluino + gluino
35506  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35507  xmt=sqm3-th
35508  xmu=sqm3-uh
35509  facqq1=comfac*as**2*9d0/4d0*(
35510  & (xmt*xmu-2d0*sqm3*(th+sqm3))/xmt**2 -
35511  & (xmt*xmu+sqm3*(uh-th))/sh/xmt )
35512  facqq2=comfac*as**2*9d0/4d0*(
35513  & (xmu*xmt-2d0*sqm3*(uh+sqm3))/xmu**2 -
35514  & (xmu*xmt+sqm3*(th-uh))/sh/xmu )
35515  facqq3=comfac*as**2*9d0/4d0*(2d0*xmt*xmu/sh2 +
35516  & sqm3*(sh-4d0*sqm3)/xmt/xmu)
35517  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 320
35518  nchn=nchn+1
35519  isig(nchn,1)=21
35520  isig(nchn,2)=21
35521  isig(nchn,3)=1
35522  sigh(nchn)=facqq1/2d0
35523  nchn=nchn+1
35524  isig(nchn,1)=21
35525  isig(nchn,2)=21
35526  isig(nchn,3)=2
35527  sigh(nchn)=facqq2/2d0
35528  nchn=nchn+1
35529  isig(nchn,1)=21
35530  isig(nchn,2)=21
35531  isig(nchn,3)=3
35532  sigh(nchn)=facqq3/2d0
35533  320 CONTINUE
35534 
35535  ELSEIF(isub.EQ.246) THEN
35536 C...g + q_j -> ~chi0_1 + ~q_j
35537  fac0=comfac*as*aem/6d0/xw
35538  zm2=sqm4
35539  qm2=sqm3
35540  faczq0=fac0*( (zm2-th)/sh +
35541  & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
35542  & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
35543  kfnsq=mod(kfpr(isubsv,1),ksusy1)
35544  DO 340 i=-kfnsq,kfnsq,2*kfnsq
35545  IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 340
35546  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 340
35547  ei=kchg(iabs(i),1)/3d0
35548  ia=iabs(i)
35549  xrqz = -tanw*ei*zmix(izid,1)
35550  xlqz =(sign(1d0,ei)*zmix(izid,2)-tanw*
35551  & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
35552  IF(ilr.EQ.0) THEN
35553  bs=xlqz**2*sfmix(ia,1)**2+xrqz**2*sfmix(ia,2)**2
35554  ELSE
35555  bs=xlqz**2*sfmix(ia,3)**2+xrqz**2*sfmix(ia,4)**2
35556  ENDIF
35557  faczq=faczq0*bs
35558  kchq=2
35559  IF(i.LT.0) kchq=3
35560  DO 330 isde=1,2
35561  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 330
35562  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 330
35563  nchn=nchn+1
35564  isig(nchn,isde)=i
35565  isig(nchn,3-isde)=21
35566  isig(nchn,3)=1
35567  sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35568  & wids(pycomp(kfpr(isubsv,2)),2)
35569  330 CONTINUE
35570  340 CONTINUE
35571  ENDIF
35572 
35573  ELSEIF(isub.LE.260) THEN
35574  IF(isub.EQ.254) THEN
35575 C...g + q_j -> ~chi1_1 + ~q_i
35576  fac0=comfac*as*aem/12d0/xw
35577  zm2=sqm4
35578  qm2=sqm3
35579  au=umix(izid,1)**2
35580  ad=vmix(izid,1)**2
35581  faczq0=fac0*( (zm2-th)/sh +
35582  & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
35583  & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
35584  kfnsq1=mod(kfpr(isubsv,1),ksusy1)
35585  IF(mod(kfnsq1,2).EQ.0) THEN
35586  kfnsq=kfnsq1-1
35587  kchw=2
35588  ELSE
35589  kfnsq=kfnsq1+1
35590  kchw=3
35591  ENDIF
35592  DO 360 i=-kfnsq,kfnsq,2*kfnsq
35593  IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 360
35594  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 360
35595  ia=iabs(i)
35596  IF(mod(ia,2).EQ.0) THEN
35597  faczq=faczq0*au
35598  ELSE
35599  faczq=faczq0*ad
35600  ENDIF
35601  faczq=faczq*sfmix(kfnsq1,1+2*ilr)**2
35602  kchq=2
35603  IF(i.LT.0) kchq=3
35604  kchwq=kchw
35605  IF(i.LT.0) kchwq=5-kchw
35606  DO 350 isde=1,2
35607  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 350
35608  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 350
35609  nchn=nchn+1
35610  isig(nchn,isde)=i
35611  isig(nchn,3-isde)=21
35612  isig(nchn,3)=1
35613  sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35614  & wids(pycomp(kfpr(isubsv,2)),kchwq)
35615  350 CONTINUE
35616  360 CONTINUE
35617 
35618  ELSEIF(isub.EQ.258) THEN
35619 C...g + q_j -> gluino + ~q_i
35620  xg2=sqm4
35621  xq2=sqm3
35622  xmt=xg2-th
35623  xmu=xg2-uh
35624  xst=xq2-th
35625  xsu=xq2-uh
35626  facqg1=0.5d0*4d0/9d0*xmt/sh + (xmt*sh+2d0*xg2*xst)/xmt**2 -
35627  & ( (sh-xq2+xg2)*(-xst)-sh*xg2 )/sh/(-xmt) +
35628  & 0.5d0*1d0/2d0*( xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst) +
35629  & (-xmu)*(th+xg2+2d0*xq2) )/2d0/xmt/xsu
35630  facqg2= 4d0/9d0*(-xmu)*(uh+xq2)/xsu**2 + 1d0/18d0*
35631  & (sh*(uh+xg2)
35632  & +2d0*(xq2-xg2)*xmu)/sh/(-xsu) + 0.5d0*4d0/9d0*xmt/sh +
35633  & 0.5d0*1d0/2d0*(xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst)+
35634  & (-xmu)*(th+xg2+2d0*xq2))/2d0/xmt/xsu
35635  asyuk=rmss(42)*as
35636  facqg1=comfac*as*asyuk*facqg1/2d0
35637  facqg2=comfac*as*asyuk*facqg2/2d0
35638  kfnsq=mod(kfpr(isubsv,1),ksusy1)
35639  DO 380 i=-kfnsq,kfnsq,2*kfnsq
35640  IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 380
35641  IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 380
35642  kchq=2
35643  IF(i.LT.0) kchq=3
35644  facsel=rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35645  & wids(pycomp(kfpr(isubsv,2)),2)
35646  DO 370 isde=1,2
35647  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 370
35648  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 370
35649  nchn=nchn+1
35650  isig(nchn,isde)=i
35651  isig(nchn,3-isde)=21
35652  isig(nchn,3)=1
35653  sigh(nchn)=facqg1*facsel
35654  nchn=nchn+1
35655  isig(nchn,isde)=i
35656  isig(nchn,3-isde)=21
35657  isig(nchn,3)=2
35658  sigh(nchn)=facqg2*facsel
35659  370 CONTINUE
35660  380 CONTINUE
35661  ENDIF
35662 
35663  ELSEIF(isub.LE.270) THEN
35664  IF(isub.EQ.261) THEN
35665 C...q_i + q_ibar -> ~t_1 + ~t_1bar
35666  facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )*
35667  & wids(pycomp(kfpr(isubsv,1)),1)
35668  kfnsq=mod(kfpr(isubsv,1),ksusy1)
35669  fac0=as**2*4d0/9d0
35670  DO 390 i=mmin1,mmax1
35671  ia=iabs(i)
35672  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 390
35673  IF(ia.GE.11.AND.ia.LE.18) THEN
35674  ei=kchg(ia,1)/3d0
35675  ej=kchg(kfnsq,1)/3d0
35676  t3i=sign(1d0,ei)/2d0
35677  t3j=sign(1d0,ej)/2d0
35678  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,2*ilr+1)**2
35679  xrq=2d0*(-ej*xw)*sfmix(kfnsq,2*ilr+2)**2
35680  xlf=2d0*(t3i-ei*xw)
35681  xrf=2d0*(-ei*xw)
35682  taa=0.5d0*(ei*ej)**2
35683  tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
35684  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35685  taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
35686  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
35687  fac0=aem**2*12d0*(taa+tzz+taz)
35688  ENDIF
35689  nchn=nchn+1
35690  isig(nchn,1)=i
35691  isig(nchn,2)=-i
35692  isig(nchn,3)=1
35693  sigh(nchn)=facqq1*fac0
35694  390 CONTINUE
35695 
35696  ELSEIF(isub.EQ.263) THEN
35697 C...f + fbar -> ~t1 + ~t2bar
35698  DO 400 i=mmin1,mmax1
35699  ia=iabs(i)
35700  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 400
35701  ei=kchg(iabs(i),1)/3d0
35702  tt3i=sign(1d0,ei)/2d0
35703  ej=2d0/3d0
35704  tt3j=1d0/2d0
35705  fcol=1d0
35706 C...Color factor for e+ e-
35707  IF(ia.GE.11) fcol=3d0
35708  xlq=2d0*(tt3j-ej*xw)
35709  xrq=2d0*(-ej*xw)
35710  xlf=2d0*(tt3i-ei*xw)
35711  xrf=2d0*(-ei*xw)
35712  tzz=(xlf**2+xrf**2)*(xlq-xrq)**2/64d0/xw**2/xw1**2
35713  tzz=tzz*(sfmix(6,1)*sfmix(6,2))**2
35714  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35715 C...Factor of 2 for t1 t2bar + t2 t1bar
35716  facqq1=2d0*comfac*aem**2*tzz*fcol*4d0
35717  facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh2
35718  nchn=nchn+1
35719  isig(nchn,1)=i
35720  isig(nchn,2)=-i
35721  isig(nchn,3)=1
35722  sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),2)*
35723  & wids(pycomp(kfpr(isubsv,2)),3)
35724  nchn=nchn+1
35725  isig(nchn,1)=i
35726  isig(nchn,2)=-i
35727  isig(nchn,3)=2
35728  sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),3)*
35729  & wids(pycomp(kfpr(isubsv,2)),2)
35730  400 CONTINUE
35731 
35732  ELSEIF(isub.EQ.264) THEN
35733 C...g + g -> ~t_1 + ~t_1bar
35734  xsu=sqm3-uh
35735  xst=sqm3-th
35736  fac0=comfac*as**2*(7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )*0.5d0*
35737  & wids(pycomp(kfpr(isubsv,1)),1)
35738  facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
35739  facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
35740  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 410
35741  nchn=nchn+1
35742  isig(nchn,1)=21
35743  isig(nchn,2)=21
35744  isig(nchn,3)=1
35745  sigh(nchn)=facqq1
35746  nchn=nchn+1
35747  isig(nchn,1)=21
35748  isig(nchn,2)=21
35749  isig(nchn,3)=2
35750  sigh(nchn)=facqq2
35751  410 CONTINUE
35752  ENDIF
35753 
35754  ELSEIF(isub.LE.280) THEN
35755  IF(isub.EQ.271) THEN
35756 C...q + q' -> ~q + ~q' (~g exchange)
35757  xmg2=pmas(pycomp(ksusy1+21),1)**2
35758  xmt=xmg2-th
35759  xmu=xmg2-uh
35760  xsu1=sqm3-uh
35761  xsu2=sqm4-uh
35762  xst1=sqm3-th
35763  xst2=sqm4-th
35764  asyuk=rmss(42)*as
35765  IF(ilr.EQ.1) THEN
35766  facqq1=comfac*asyuk**2*4d0/9d0*( -(xst1*xst2+sh*th)/xmt**2 )
35767  facqq2=comfac*asyuk**2*4d0/9d0*( -(xsu1*xsu2+sh*uh)/xmu**2 )
35768  facqqb=0.0d0
35769  ELSE
35770  facqq1=0.5d0*comfac*asyuk**2*4d0/9d0*( sh*xmg2/xmt**2 )
35771  facqq2=0.5d0*comfac*asyuk**2*4d0/9d0*( sh*xmg2/xmu**2 )
35772  facqqb=0.5d0*comfac*asyuk**2*4d0/9d0*( -2d0*sh*xmg2/3d0/
35773  & xmt/xmu )
35774  ENDIF
35775  kfnsqi=mod(kfpr(isubsv,1),ksusy1)
35776  kfnsqj=mod(kfpr(isubsv,2),ksusy1)
35777  DO 430 i=-kfnsqi,kfnsqi,2*kfnsqi
35778  IF(i.LT.mmin1.OR.i.GT.mmax1) GOTO 430
35779  ia=iabs(i)
35780  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 430
35781  kchq=2
35782  IF(i.LT.0) kchq=3
35783  DO 420 j=-kfnsqj,kfnsqj,2*kfnsqj
35784  IF(j.LT.mmin2.OR.j.GT.mmax2) GOTO 420
35785  ja=iabs(j)
35786  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 420
35787  IF(i*j.LT.0) GOTO 420
35788  nchn=nchn+1
35789  isig(nchn,1)=i
35790  isig(nchn,2)=j
35791  isig(nchn,3)=1
35792  sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35793  & wids(pycomp(kfpr(isubsv,2)),kchq)
35794  IF(i.EQ.j) THEN
35795  IF(ilr.EQ.0) THEN
35796  sigh(nchn)=0.5d0*(facqq1+0.5d0*facqqb)*rkf*
35797  & wids(pycomp(kfpr(isubsv,1)),kchq+2)
35798  ELSE
35799  sigh(nchn)=0.5d0*facqq1*rkf*
35800  & wids(pycomp(kfpr(isubsv,1)),kchq)*
35801  & wids(pycomp(kfpr(isubsv,2)),kchq)
35802  ENDIF
35803  nchn=nchn+1
35804  isig(nchn,1)=i
35805  isig(nchn,2)=j
35806  isig(nchn,3)=2
35807  IF(ilr.EQ.0) THEN
35808  sigh(nchn)=0.5d0*(facqq2+0.5d0*facqqb)*rkf*
35809  & wids(pycomp(kfpr(isubsv,1)),kchq+2)
35810  ELSE
35811  sigh(nchn)=0.5d0*facqq2*rkf*
35812  & wids(pycomp(kfpr(isubsv,1)),kchq)*
35813  & wids(pycomp(kfpr(isubsv,2)),kchq)
35814  ENDIF
35815  ENDIF
35816  420 CONTINUE
35817  430 CONTINUE
35818 
35819  ELSEIF(isub.EQ.274) THEN
35820 C...q + qbar' -> ~q + ~qbar'
35821  xmg2=pmas(pycomp(ksusy1+21),1)**2
35822  xmt=xmg2-th
35823  xmu=xmg2-uh
35824  IF(ilr.EQ.0) THEN
35825 C...Mrenna...Normalization.and.1/XMT
35826  facqq1=comfac*as**2*2d0/9d0*(
35827  & (uh*th-sqm3*sqm4)/xmt**2 )*rmss(42)**2
35828  facqqb=comfac*as**2*4d0/9d0*(
35829  & (uh*th-sqm3*sqm4)/sh2 )
35830  facqqi=-comfac*as**2*4d0/27d0*(
35831  & (uh*th-sqm3*sqm4)/sh/xmt )*rmss(42)
35832  facqqb=facqqb+facqq1+facqqi
35833  ELSE
35834  facqq1=comfac*as**2*4d0/9d0*( xmg2*sh/xmt**2 )*rmss(42)**2
35835  facqqb=facqq1
35836  ENDIF
35837  kfnsqi=mod(kfpr(isubsv,1),ksusy1)
35838  kfnsqj=mod(kfpr(isubsv,2),ksusy1)
35839  DO 450 i=-kfnsqi,kfnsqi,2*kfnsqi
35840  IF(i.LT.mmin1.OR.i.GT.mmax1) GOTO 450
35841  ia=iabs(i)
35842  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 450
35843  kchq=2
35844  IF(i.LT.0) kchq=3
35845  DO 440 j=-kfnsqj,kfnsqj,2*kfnsqj
35846  IF(j.LT.mmin2.OR.j.GT.mmax2) GOTO 440
35847  ja=iabs(j)
35848  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 440
35849  IF(i*j.GT.0) GOTO 440
35850  nchn=nchn+1
35851  isig(nchn,1)=i
35852  isig(nchn,2)=j
35853  isig(nchn,3)=1
35854  sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35855  & wids(pycomp(kfpr(isubsv,2)),5-kchq)
35856  IF(ilr.EQ.0.AND.i.EQ.-j) sigh(nchn)=facqqb*rkf*
35857  & wids(pycomp(kfpr(isubsv,1)),1)
35858  440 CONTINUE
35859  450 CONTINUE
35860 
35861  ELSEIF(isub.EQ.277) THEN
35862 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35863 C...if i .eq. j covered in 274
35864  facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )
35865  kfnsq=mod(kfpr(isubsv,1),ksusy1)
35866  fac0=0d0
35867  DO 460 i=mmin1,mmax1
35868  ia=iabs(i)
35869  IF(i.EQ.0.OR.(ia.GT.mstp(58).AND.ia.LE.10).OR.
35870  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 460
35871  IF(ia.EQ.kfnsq) GOTO 460
35872  IF(ia.EQ.11.OR.ia.EQ.13.OR.ia.EQ.15) THEN
35873  ei=kchg(ia,1)/3d0
35874  ej=kchg(kfnsq,1)/3d0
35875  t3j=sign(0.5d0,ej)
35876  t3i=sign(1d0,ei)/2d0
35877  IF(ilr.EQ.0) THEN
35878  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,1)
35879  xrq=2d0*(-ej*xw)*sfmix(kfnsq,2)
35880  ELSE
35881  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,3)
35882  xrq=2d0*(-ej*xw)*sfmix(kfnsq,4)
35883  ENDIF
35884  xlf=2d0*(t3i-ei*xw)
35885  xrf=2d0*(-ei*xw)
35886  IF(ilr.EQ.0) THEN
35887  xrq=0d0
35888  ELSE
35889  xlq=0d0
35890  ENDIF
35891  taa=0.5d0*(ei*ej)**2
35892  tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
35893  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35894  taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
35895  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
35896  fac0=aem**2*12d0*(taa+tzz+taz)
35897  ELSEIF(ia.LE.6) THEN
35898  fac0=as**2*8d0/9d0/2d0
35899  ENDIF
35900  nchn=nchn+1
35901  isig(nchn,1)=i
35902  isig(nchn,2)=-i
35903  isig(nchn,3)=1
35904  sigh(nchn)=facqq1*fac0*rkf*wids(pycomp(kfpr(isubsv,1)),1)
35905  460 CONTINUE
35906 
35907  ELSEIF(isub.EQ.279) THEN
35908 C...g + g -> ~q_j + ~q_jbar
35909  xsu=sqm3-uh
35910  xst=sqm3-th
35911 C...5=RKF because ~t ~tbar treated separately
35912  fac0=rkf*comfac*as**2*( 7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )
35913  facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
35914  facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
35915  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 470
35916  nchn=nchn+1
35917  isig(nchn,1)=21
35918  isig(nchn,2)=21
35919  isig(nchn,3)=1
35920  sigh(nchn)=facqq1/2d0*wids(pycomp(kfpr(isubsv,1)),1)
35921  nchn=nchn+1
35922  isig(nchn,1)=21
35923  isig(nchn,2)=21
35924  isig(nchn,3)=2
35925  sigh(nchn)=facqq2/2d0*wids(pycomp(kfpr(isubsv,1)),1)
35926  470 CONTINUE
35927 
35928  ENDIF
35929  ENDIF
35930 CMRENNA--
35931 
35932  RETURN
35933  END
35934 
35935 C*********************************************************************
35936 
35937 C...PYSGTC
35938 C...Subprocess cross sections for Technicolor processes.
35939 C...Auxiliary to PYSIGH.
35940 
35941  SUBROUTINE pysgtc(NCHN,SIGS)
35942 
35943 C...Double precision and integer declarations
35944  IMPLICIT DOUBLE PRECISION(a-h, o-z)
35945  IMPLICIT INTEGER(I-N)
35946  INTEGER PYK,PYCHGE,PYCOMP
35947 C...Parameter statement to help give large particle numbers.
35948  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
35949  &kexcit=4000000,kdimen=5000000)
35950 C...Commonblocks
35951  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
35952  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
35953  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
35954  common/pypars/mstp(200),parp(200),msti(200),pari(200)
35955  common/pyint1/mint(400),vint(400)
35956  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
35957  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
35958  common/pyint4/mwid(500),wids(500,5)
35959  common/pytcsm/itcm(0:99),rtcm(0:99)
35960  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
35961  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
35962  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
35963  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
35964  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
35965  &/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
35966 C...Local arrays and complex variables
35967  dimension wdtp(0:400),wdte(0:400,0:5)
35968  COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
35969  COMPLEX*16 SSMX,DAAST,DZAST,DWAST
35970  COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
35971  COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
35972  COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
35973  COMPLEX*16 DVVS,DVVT,DVVU
35974  INTEGER INDX(6)
35975 
35976 C...Combinations of weak mixing angle.
35977  tanw=sqrt(xw/xw1)
35978  ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
35979 
35980 C...Convert almost equivalent technicolor processes into
35981 C...a few basic processes, and set distinguishing parameters.
35982  IF(isub.GE.361.AND.isub.LE.380) THEN
35983  sqtv=rtcm(12)**2
35984  sqta=rtcm(13)**2
35985  sn2w=2d0*sqrt(xw*xw1)
35986  cs2w=1d0-2d0*xw
35987  ct2w=cs2w/sn2w
35988  csxi=cos(asin(rtcm(3)))
35989  csxip=cos(asin(rtcm(4)))
35990  qupd=2d0*rtcm(2)-1d0
35991  q2ud=rtcm(2)**2+(rtcm(2)-1d0)**2
35992  cab2=0d0
35993  vogp=0d0
35994  vrgp=0d0
35995  aogp=0d0
35996  argp=0d0
35997  vxgp=0d0
35998  axgp=0d0
35999  vagp=0d0
36000  vzgp=0d0
36001  vwgp=0d0
36002 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36003  IF(isub.EQ.361) THEN
36004  kfa=24
36005  kfb=24
36006  cab2=rtcm(3)**4
36007  axgp=-rtcm(3)/(2d0*sqrt(xw))/rtcm(49)
36008  argp=rtcm(3)/(2d0*sqrt(xw))/rtcm(13)
36009  vogp=rtcm(3)/(2d0*sqrt(xw))/rtcm(12)
36010 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36011  axgp = sqrt(2d0)*axgp
36012  argp = sqrt(2d0)*argp
36013  vogp = sqrt(2d0)*vogp
36014 C... rho_tc0 -> W_L pi_tc-
36015  ELSEIF(isub.EQ.362) THEN
36016  kfa=24
36017  kfb=ktechn+211
36018  isub=361
36019  cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36020 C... pi_tc pi_tc
36021  ELSEIF(isub.EQ.363) THEN
36022  kfa=ktechn+211
36023  kfb=ktechn+211
36024  isub=361
36025  cab2=(1d0-rtcm(3)**2)**2
36026 C... rho_tc0/omega_tc -> gamma pi_tc
36027  ELSEIF(isub.EQ.364) THEN
36028  kfa=22
36029  kfb=ktechn+111
36030  isub=361
36031  vogp=csxi/rtcm(12)
36032  vrgp=vogp*qupd
36033  vagp=2d0*qupd*csxi
36034  vzgp=qupd*csxi*(1d0-4d0*xw)/sn2w
36035 C... gamma pi_tc'
36036  ELSEIF(isub.EQ.365) THEN
36037  kfa=22
36038  kfb=ktechn+221
36039  isub=361
36040  vrgp=csxip/rtcm(12)
36041  vogp=vrgp*qupd
36042  vagp=2d0*q2ud*csxip
36043  vzgp=csxip/sn2w*(1d0-4d0*xw*q2ud)
36044 C... Z pi_tc
36045  ELSEIF(isub.EQ.366) THEN
36046  kfa=23
36047  kfb=ktechn+111
36048  isub=361
36049  vogp=csxi*ct2w/rtcm(12)
36050  vrgp=-qupd*csxi*tanw/rtcm(12)
36051  vagp=qupd*csxi*(1d0-4d0*xw)/sn2w
36052  vzgp=-qupd*csxi*cs2w/xw1
36053 C... Z pi_tc'
36054  ELSEIF(isub.EQ.367) THEN
36055  kfa=23
36056  kfb=ktechn+221
36057  isub=361
36058 C...RTCM(48) is the M_V for the techni-a
36059  vxgp=-csxip/sn2w/rtcm(48)
36060  vrgp=csxip*ct2w/rtcm(12)
36061  vogp=-qupd*csxip*tanw/rtcm(12)
36062  vagp=csxip*(1d0-4d0*q2ud*xw)/sn2w
36063  vzgp=2d0*csxip*(cs2w+4d0*q2ud*xw**2)/sn2w**2
36064 C... W_T pi_tc
36065  ELSEIF(isub.EQ.368) THEN
36066  kfa=24
36067  kfb=ktechn+211
36068  isub=361
36069 C...RTCM(49) is the M_A for the techni-a
36070  axgp=-csxi/(2d0*sqrt(xw))/rtcm(49)
36071  vogp=csxi/(2d0*sqrt(xw))/rtcm(12)
36072  argp=csxi/(2d0*sqrt(xw))/rtcm(13)
36073  vagp=qupd*csxi/(2d0*sqrt(xw))
36074  vzgp=-qupd*csxi/(2d0*sqrt(xw1))
36075 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36076  ELSEIF(isub.EQ.370) THEN
36077  kfa=24
36078  kfb=23
36079  cab2=rtcm(3)**4
36080  argp=-rtcm(3)/(2d0*sqrt(xw))/rtcm(13)
36081  axgp=rtcm(3)/(2d0*sqrt(xw))/rtcm(49)
36082 C... W_L pi_tc0
36083  ELSEIF(isub.EQ.371) THEN
36084  kfa=24
36085  kfb=ktechn+111
36086  isub=370
36087  cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36088 C... Z_L pi_tc+
36089  ELSEIF(isub.EQ.372) THEN
36090  kfa=ktechn+211
36091  kfb=23
36092  isub=370
36093  cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36094 C... pi_tc+ pi_tc0
36095  ELSEIF(isub.EQ.373) THEN
36096  kfa=ktechn+211
36097  kfb=ktechn+111
36098  isub=370
36099  cab2=(1d0-rtcm(3)**2)**2
36100 C... gamma pi_tc+
36101  ELSEIF(isub.EQ.374) THEN
36102  kfa=ktechn+211
36103  kfb=22
36104  isub=370
36105  vrgp=qupd*csxi/rtcm(12)
36106  vwgp=qupd*csxi/(2d0*sqrt(xw))
36107  axgp=-csxi/rtcm(49)
36108 C... Z_T pi_tc+
36109  ELSEIF(isub.EQ.375) THEN
36110  kfa=ktechn+211
36111  kfb=23
36112  isub=370
36113  vrgp=-qupd*csxi*tanw/rtcm(12)
36114  argp=csxi/(2d0*sqrt(xw*xw1))/rtcm(13)
36115  vwgp=-qupd*csxi/(2d0*sqrt(xw1))
36116  axgp=-csxi*ct2w/rtcm(49)
36117 C... W_T pi_tc0
36118  ELSEIF(isub.EQ.376) THEN
36119  kfa=24
36120  kfb=ktechn+111
36121  isub=370
36122  vrgp=0d0
36123  argp=-csxi/(2d0*sqrt(xw))/rtcm(13)
36124  axgp=csxi/(2d0*sqrt(xw))/rtcm(49)
36125 C... W_T pi_tc0'
36126  ELSEIF(isub.EQ.377) THEN
36127  kfa=24
36128  kfb=ktechn+221
36129  isub=370
36130  vrgp=csxip/(2d0*sqrt(xw))/rtcm(12)
36131  vwgp=csxip/(2d0*xw)
36132  vxgp=-csxip/(2d0*sqrt(xw))/rtcm(48)
36133 C... gamma W+
36134  ELSEIF(isub.EQ.378) THEN
36135  kfa=24
36136  kfb=22
36137  isub=370
36138  vrgp=qupd*rtcm(3)/rtcm(12)
36139  axgp=-rtcm(3)/rtcm(49)
36140 C... gamma Z
36141  ELSEIF(isub.EQ.379) THEN
36142  kfa=23
36143  kfb=22
36144  isub=361
36145  vogp=rtcm(3)/rtcm(12)
36146  vrgp=qupd*rtcm(3)/rtcm(12)
36147  ELSEIF(isub.EQ.380) THEN
36148  kfa=23
36149  kfb=23
36150  isub=361
36151  vogp=rtcm(3)*ct2w/rtcm(12)
36152  vrgp=-qupd*rtcm(3)*tanw/rtcm(12)
36153  ENDIF
36154  ENDIF
36155 
36156 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36157  IF(isub.GE.381.AND.isub.LE.388) THEN
36158  IF(itcm(5).LE.4) THEN
36159  sqdqqs=1d0/sh2
36160  sqdqqt=1d0/th2
36161  sqdqqu=1d0/uh2
36162  sqdggs=sqdqqs
36163  sqdggt=sqdqqt
36164  sqdggu=sqdqqu
36165  redggs=1d0/sh
36166  redggt=1d0/th
36167  redggu=1d0/uh
36168  redgtu=1d0/uh/th
36169  redgsu=1d0/sh/uh
36170  redgst=1d0/sh/th
36171  redqst=1d0/sh/th
36172  redqtu=1d0/uh/th
36173  sqdlgs=0d0
36174  sqdlgt=0d0
36175  sqdqts=sqdqqs
36176  ELSEIF(itcm(5).EQ.5) THEN
36177  tant3=rtcm(21)
36178  IF(itcm(2).EQ.0) THEN
36179  imdl=1
36180  ELSE
36181  imdl=2
36182  ENDIF
36183  alprht=2.16d0*(3d0/itcm(1))
36184  sin2t=2d0*tant3/(tant3**2+1d0)
36185  sint3=tant3/sqrt(tant3**2+1d0)
36186  xig=sqrt(pyalps(sh)/alprht)
36187  x12=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*cos(rtcm(30))+
36188  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*cos(rtcm(32)))/sqrt(2d0)/sin2t
36189  x21=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*sin(rtcm(30))+
36190  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*sin(rtcm(32)))/sqrt(2d0)/sin2t
36191  x11=(.25d0*(rtcm(29)**2+rtcm(31)**2+2d0)-
36192  & sint3**2)*2d0/sin2t
36193  x22=(.25d0*(2d0-rtcm(29)**2-rtcm(31)**2)-
36194  & sint3**2)*2d0/sin2t
36195 
36196  sm1122=.5d0*(2d0-rtcm(29)**2-rtcm(31)**2)*rtcm(28)**2
36197  sm1112=x12*rtcm(28)**2*sin2t
36198  sm1121=-x21*rtcm(28)**2*sin2t
36199  sm2212=-sm1112
36200  sm2221=-sm1121
36201  sm1221=-.5d0*((1d0-rtcm(29)**2)*sin(2d0*rtcm(30))+
36202  & (1d0-rtcm(31)**2)*sin(2d0*rtcm(32)))*rtcm(28)**2
36203 
36204 C.........SH LOOP
36205  ztc(1,1)=dcmplx(sh,0d0)
36206  CALL pywidt(3100021,sh,wdtp,wdte)
36207  IF(wdtp(0).GT.rtcm(33)*shr) wdtp(0)=rtcm(33)*shr
36208  ztc(2,2)=dcmplx(sh-pmas(pycomp(3100021),1)**2,-shr*wdtp(0))
36209  CALL pywidt(3100113,sh,wdtp,wdte)
36210  ztc(3,3)=dcmplx(sh-pmas(pycomp(3100113),1)**2,-shr*wdtp(0))
36211  CALL pywidt(3400113,sh,wdtp,wdte)
36212  ztc(4,4)=dcmplx(sh-pmas(pycomp(3400113),1)**2,-shr*wdtp(0))
36213  CALL pywidt(3200113,sh,wdtp,wdte)
36214  ztc(5,5)=dcmplx(sh-pmas(pycomp(3200113),1)**2,-shr*wdtp(0))
36215  CALL pywidt(3300113,sh,wdtp,wdte)
36216  ztc(6,6)=dcmplx(sh-pmas(pycomp(3300113),1)**2,-shr*wdtp(0))
36217  ztc(1,2)=(0d0,0d0)
36218  ztc(1,3)=dcmplx(sh*xig,0d0)
36219  ztc(1,4)=ztc(1,3)
36220  ztc(1,5)=ztc(1,2)
36221  ztc(1,6)=ztc(1,2)
36222  ztc(2,3)=dcmplx(sh*xig*x11,0d0)
36223  ztc(2,4)=dcmplx(sh*xig*x22,0d0)
36224  ztc(2,5)=dcmplx(sh*xig*x12,0d0)
36225  ztc(2,6)=dcmplx(sh*xig*x21,0d0)
36226  ztc(3,4)=-sm1122
36227  ztc(3,5)=-sm1112
36228  ztc(3,6)=-sm1121
36229  ztc(4,5)=-sm2212
36230  ztc(4,6)=-sm2221
36231  ztc(5,6)=-sm1221
36232 
36233  DO 110 i=1,5
36234  DO 100 j=i+1,6
36235  ztc(j,i)=ztc(i,j)
36236  100 CONTINUE
36237  110 CONTINUE
36238  CALL pyldcm(ztc,6,6,indx,d)
36239  DO 130 i=1,6
36240  DO 120 j=1,6
36241  ytc(i,j)=(0d0,0d0)
36242  IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
36243  120 CONTINUE
36244  130 CONTINUE
36245 
36246  DO 140 i=1,6
36247  CALL pybksb(ztc,6,6,indx,ytc(1,i))
36248  140 CONTINUE
36249  dggs=ytc(1,1)
36250  dvvs=ytc(2,2)
36251  dgvs=ytc(1,2)
36252 
36253  xig=sqrt(pyalps(-th)/alprht)
36254 C.........TH LOOP
36255  ztc(1,1)=dcmplx(th)
36256  ztc(2,2)=dcmplx(th-pmas(pycomp(3100021),1)**2)
36257  ztc(3,3)=dcmplx(th-pmas(pycomp(3100113),1)**2)
36258  ztc(4,4)=dcmplx(th-pmas(pycomp(3400113),1)**2)
36259  ztc(5,5)=dcmplx(th-pmas(pycomp(3200113),1)**2)
36260  ztc(6,6)=dcmplx(th-pmas(pycomp(3300113),1)**2)
36261  ztc(1,2)=(0d0,0d0)
36262  ztc(1,3)=dcmplx(th*xig,0d0)
36263  ztc(1,4)=ztc(1,3)
36264  ztc(1,5)=ztc(1,2)
36265  ztc(1,6)=ztc(1,2)
36266  ztc(2,3)=dcmplx(th*xig*x11,0d0)
36267  ztc(2,4)=dcmplx(th*xig*x22,0d0)
36268  ztc(2,5)=dcmplx(th*xig*x12,0d0)
36269  ztc(2,6)=dcmplx(th*xig*x21,0d0)
36270  ztc(3,4)=-sm1122
36271  ztc(3,5)=-sm1112
36272  ztc(3,6)=-sm1121
36273  ztc(4,5)=-sm2212
36274  ztc(4,6)=-sm2221
36275  ztc(5,6)=-sm1221
36276  DO 160 i=1,5
36277  DO 150 j=i+1,6
36278  ztc(j,i)=ztc(i,j)
36279  150 CONTINUE
36280  160 CONTINUE
36281  CALL pyldcm(ztc,6,6,indx,d)
36282  DO 180 i=1,6
36283  DO 170 j=1,6
36284  ytc(i,j)=(0d0,0d0)
36285  IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
36286  170 CONTINUE
36287  180 CONTINUE
36288  DO 190 i=1,6
36289  CALL pybksb(ztc,6,6,indx,ytc(1,i))
36290  190 CONTINUE
36291  dggt=ytc(1,1)
36292  dvvt=ytc(2,2)
36293  dgvt=ytc(1,2)
36294 
36295  xig=sqrt(pyalps(-uh)/alprht)
36296 C.........UH LOOP
36297  ztc(1,1)=dcmplx(uh,0d0)
36298  ztc(2,2)=dcmplx(uh-pmas(pycomp(3100021),1)**2)
36299  ztc(3,3)=dcmplx(uh-pmas(pycomp(3100113),1)**2)
36300  ztc(4,4)=dcmplx(uh-pmas(pycomp(3400113),1)**2)
36301  ztc(5,5)=dcmplx(uh-pmas(pycomp(3200113),1)**2)
36302  ztc(6,6)=dcmplx(uh-pmas(pycomp(3300113),1)**2)
36303  ztc(1,2)=(0d0,0d0)
36304  ztc(1,3)=dcmplx(uh*xig,0d0)
36305  ztc(1,4)=ztc(1,3)
36306  ztc(1,5)=ztc(1,2)
36307  ztc(1,6)=ztc(1,2)
36308  ztc(2,3)=dcmplx(uh*xig*x11,0d0)
36309  ztc(2,4)=dcmplx(uh*xig*x22,0d0)
36310  ztc(2,5)=dcmplx(uh*xig*x12,0d0)
36311  ztc(2,6)=dcmplx(uh*xig*x21,0d0)
36312  ztc(3,4)=-sm1122
36313  ztc(3,5)=-sm1112
36314  ztc(3,6)=-sm1121
36315  ztc(4,5)=-sm2212
36316  ztc(4,6)=-sm2221
36317  ztc(5,6)=-sm1221
36318  DO 210 i=1,5
36319  DO 200 j=i+1,6
36320  ztc(j,i)=ztc(i,j)
36321  200 CONTINUE
36322  210 CONTINUE
36323  CALL pyldcm(ztc,6,6,indx,d)
36324  DO 230 i=1,6
36325  DO 220 j=1,6
36326  ytc(i,j)=(0d0,0d0)
36327  IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
36328  220 CONTINUE
36329  230 CONTINUE
36330  DO 240 i=1,6
36331  CALL pybksb(ztc,6,6,indx,ytc(1,i))
36332  240 CONTINUE
36333  dggu=ytc(1,1)
36334  dvvu=ytc(2,2)
36335  dgvu=ytc(1,2)
36336 
36337  IF(imdl.EQ.1) THEN
36338  dqqs=dggs+dvvs*dcmplx(tant3**2)-dgvs*dcmplx(2d0*tant3)
36339  dqqt=dggt+dvvt*dcmplx(tant3**2)-dgvt*dcmplx(2d0*tant3)
36340  dqqu=dggu+dvvu*dcmplx(tant3**2)-dgvu*dcmplx(2d0*tant3)
36341  dqts=dggs-dvvs-dgvs*dcmplx(tant3-1d0/tant3)
36342  dqgs=dggs-dgvs*dcmplx(tant3)
36343  dtgs=dggs+dgvs*dcmplx(1d0/tant3)
36344  ELSE
36345  dqqs=dggs+dvvs*dcmplx(1d0/tant3**2)+dgvs*dcmplx(2d0/tant3)
36346  dqqt=dggt+dvvt*dcmplx(1d0/tant3**2)+dgvt*dcmplx(2d0/tant3)
36347  dqqu=dggu+dvvu*dcmplx(1d0/tant3**2)+dgvu*dcmplx(2d0/tant3)
36348  dqts=dggs+dvvs*dcmplx(1d0/tant3**2)+dgvs*dcmplx(2d0/tant3)
36349  dqgs=dggs+dgvs*dcmplx(1d0/tant3)
36350  dtgs=dggs+dgvs*dcmplx(1d0/tant3)
36351  ENDIF
36352 
36353  sqdqts=abs(dqts)**2
36354  sqdqqs=abs(dqqs)**2
36355  sqdqqt=abs(dqqt)**2
36356  sqdqqu=abs(dqqu)**2
36357  sqdlgs=abs(dcmplx(sh)*dqgs-dcmplx(1d0))**2
36358  redlgs=dble(dqgs)
36359  sqdhgs=abs(dcmplx(sh)*dtgs-dcmplx(1d0))**2
36360  redhgs=dble(dtgs)
36361  sqdlgt=abs(dcmplx(th)*dggt-dcmplx(1d0))**2
36362 
36363  sqdggs=abs(dggs)**2
36364  sqdggt=abs(dggt)**2
36365  sqdggu=abs(dggu)**2
36366  redggs=dble(dggs)
36367  redggt=dble(dggt)
36368  redggu=dble(dggu)
36369  redgtu=dble(dggu*dconjg(dggt))
36370  redgsu=dble(dggu*dconjg(dggs))
36371  redgst=dble(dggs*dconjg(dggt))
36372  redqst=dble(dqqs*dconjg(dqqt))
36373  redqtu=dble(dqqt*dconjg(dqqu))
36374  ENDIF
36375  ENDIF
36376 
36377 
36378 C...Differential cross section expressions.
36379 
36380  IF(isub.LE.190) THEN
36381  IF(isub.EQ.149) THEN
36382 C...g + g -> eta_tc
36383  kctc=pycomp(ktechn+331)
36384  CALL pywidt(ktechn+331,sh,wdtp,wdte)
36385  hs=shr*wdtp(0)
36386  facbw=comfac*0.5d0/((sh-pmas(kctc,1)**2)**2+hs**2)
36387  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36388  hp=sh
36389  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 250
36390  hi=hp*wdtp(3)
36391  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36392  nchn=nchn+1
36393  isig(nchn,1)=21
36394  isig(nchn,2)=21
36395  isig(nchn,3)=1
36396  sigh(nchn)=hi*facbw*hf
36397  250 CONTINUE
36398 
36399  ELSEIF(isub.EQ.165) THEN
36400 C...q + qbar -> l+ + l- (including contact term for compositeness)
36401  zratr=xwc*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
36402  zrati=xwc*sh*gmmz/((sh-sqmz)**2+gmmz**2)
36403  kff=iabs(kfpr(isub,1))
36404  ef=kchg(kff,1)/3d0
36405  af=sign(1d0,ef+0.1d0)
36406  vf=af-4d0*ef*xwv
36407  valf=vf+af
36408  varf=vf-af
36409  fcof=1d0
36410  IF(kff.LE.10) fcof=3d0
36411  wid2=1d0
36412  IF(kff.EQ.6) wid2=wids(6,1)
36413  IF(kff.EQ.7.OR.kff.EQ.8) wid2=wids(kff,1)
36414  IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
36415  DO 260 i=mmina,mmaxa
36416  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 260
36417  ei=kchg(iabs(i),1)/3d0
36418  ai=sign(1d0,ei+0.1d0)
36419  vi=ai-4d0*ei*xwv
36420  vali=vi+ai
36421  vari=vi-ai
36422  fcoi=1d0
36423  IF(iabs(i).LE.10) fcoi=faca/3d0
36424  IF((itcm(5).EQ.1.AND.iabs(i).LE.2).OR.itcm(5).EQ.2) THEN
36425  fgza=(ei*ef+vali*valf*zratr+rtcm(42)*sh/
36426  & (aem*rtcm(41)**2))**2+(vali*valf*zrati)**2+
36427  & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
36428  ELSE
36429  fgza=(ei*ef+vali*valf*zratr)**2+(vali*valf*zrati)**2+
36430  & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
36431  ENDIF
36432  fgzb=(ei*ef+vali*varf*zratr)**2+(vali*varf*zrati)**2+
36433  & (ei*ef+vari*valf*zratr)**2+(vari*valf*zrati)**2
36434  fgzab=aem**2*(fgza*uh2/sh2+fgzb*th2/sh2)
36435  IF((itcm(5).EQ.3.AND.iabs(i).EQ.2).OR.(itcm(5).EQ.4.AND.
36436  & mod(iabs(i),2).EQ.0)) fgzab=fgzab+sh2/(2d0*rtcm(41)**4)
36437  nchn=nchn+1
36438  isig(nchn,1)=i
36439  isig(nchn,2)=-i
36440  isig(nchn,3)=1
36441  sigh(nchn)=comfac*fcoi*fcof*fgzab*wid2
36442  260 CONTINUE
36443 
36444  ELSEIF(isub.EQ.166) THEN
36445 C...q + q'bar -> l + nu_l (including contact term for compositeness)
36446  wfac=(1d0/4d0)*(aem/xw)**2*uh2/((sh-sqmw)**2+gmmw**2)
36447  wcifac=wfac+sh2/(4d0*rtcm(41)**4)
36448  kff=iabs(kfpr(isub,1))
36449  fcof=1d0
36450  IF(kff.LE.10) fcof=3d0
36451  DO 280 i=mmin1,mmax1
36452  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 280
36453  ia=iabs(i)
36454  DO 270 j=mmin2,mmax2
36455  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 270
36456  ja=iabs(j)
36457  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 270
36458  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36459  & GOTO 270
36460  fcoi=1d0
36461  IF(ia.LE.10) fcoi=vckm((ia+1)/2,(ja+1)/2)*faca/3d0
36462  wid2=1d0
36463  IF((i.GT.0.AND.mod(i,2).EQ.0).OR.(j.GT.0.AND.
36464  & mod(j,2).EQ.0)) THEN
36465  IF(kff.EQ.5) wid2=wids(6,2)
36466  IF(kff.EQ.7) wid2=wids(8,2)*wids(7,3)
36467  IF(kff.EQ.17) wid2=wids(18,2)*wids(17,3)
36468  ELSE
36469  IF(kff.EQ.5) wid2=wids(6,3)
36470  IF(kff.EQ.7) wid2=wids(8,3)*wids(7,2)
36471  IF(kff.EQ.17) wid2=wids(18,3)*wids(17,2)
36472  ENDIF
36473  nchn=nchn+1
36474  isig(nchn,1)=i
36475  isig(nchn,2)=j
36476  isig(nchn,3)=1
36477  sigh(nchn)=comfac*fcoi*fcof*wfac*wid2
36478  IF((itcm(5).EQ.3.AND.ia.LE.2.AND.ja.LE.2).OR.itcm(5).EQ.4)
36479  & sigh(nchn)=comfac*fcoi*fcof*wcifac*wid2
36480  270 CONTINUE
36481  280 CONTINUE
36482  ENDIF
36483 
36484  ELSEIF(isub.LE.200) THEN
36485  IF(isub.EQ.191) THEN
36486 C...q + qbar -> rho_tc0.
36487  kctc=pycomp(ktechn+113)
36488  sqmrht=pmas(kctc,1)**2
36489  CALL pywidt(ktechn+113,sh,wdtp,wdte)
36490  hs=shr*wdtp(0)
36491  facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
36492  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36493  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36494  alprht=2.16d0*(3d0/itcm(1))
36495  hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)
36496  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
36497  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
36498  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
36499  DO 290 i=mmina,mmaxa
36500  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 290
36501  ia=iabs(i)
36502  ei=kchg(iabs(i),1)/3d0
36503  ai=sign(1d0,ei+0.1d0)
36504  vi=ai-4d0*ei*xwv
36505  vali=0.5d0*(vi+ai)
36506  vari=0.5d0*(vi-ai)
36507  hi=hp*((ei+vali*bwzr)**2+(vali*bwzi)**2+
36508  & (ei+vari*bwzr)**2+(vari*bwzi)**2)
36509  IF(ia.LE.10) hi=hi*faca/3d0
36510  nchn=nchn+1
36511  isig(nchn,1)=i
36512  isig(nchn,2)=-i
36513  isig(nchn,3)=1
36514  sigh(nchn)=hi*facbw*hf
36515  290 CONTINUE
36516 
36517  ELSEIF(isub.EQ.192) THEN
36518 C...q + qbar' -> rho_tc+/-.
36519  kctc=pycomp(ktechn+213)
36520  sqmrht=pmas(kctc,1)**2
36521  CALL pywidt(ktechn+213,sh,wdtp,wdte)
36522  hs=shr*wdtp(0)
36523  facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
36524  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36525  alprht=2.16d0*(3d0/itcm(1))
36526  hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)*
36527  & (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
36528  DO 310 i=mmin1,mmax1
36529  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 310
36530  ia=iabs(i)
36531  DO 300 j=mmin2,mmax2
36532  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 300
36533  ja=iabs(j)
36534  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 300
36535  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36536  & GOTO 300
36537  kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
36538  hf=shr*(wdte(0,1)+wdte(0,(5-kchr)/2)+wdte(0,4))
36539  hi=hp
36540  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
36541  nchn=nchn+1
36542  isig(nchn,1)=i
36543  isig(nchn,2)=j
36544  isig(nchn,3)=1
36545  sigh(nchn)=hi*facbw*hf
36546  300 CONTINUE
36547  310 CONTINUE
36548 
36549  ELSEIF(isub.EQ.193) THEN
36550 C...q + qbar -> omega_tc0.
36551  kctc=pycomp(ktechn+223)
36552  sqmomt=pmas(kctc,1)**2
36553  CALL pywidt(ktechn+223,sh,wdtp,wdte)
36554  hs=shr*wdtp(0)
36555  facbw=12d0*comfac/((sh-sqmomt)**2+hs**2)
36556  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36557  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36558  alprht=2.16d0*(3d0/itcm(1))
36559  hp=(1d0/6d0)*(aem**2/alprht)*(sqmomt**2/sh)*
36560  & (2d0*rtcm(2)-1d0)**2
36561  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
36562  bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
36563  DO 320 i=mmina,mmaxa
36564  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 320
36565  ia=iabs(i)
36566  ei=kchg(iabs(i),1)/3d0
36567  ai=sign(1d0,ei+0.1d0)
36568  vi=ai-4d0*ei*xwv
36569  vali=0.5d0*(vi+ai)
36570  vari=0.5d0*(vi-ai)
36571  hi=hp*((ei-vali*bwzr)**2+(vali*bwzi)**2+
36572  & (ei-vari*bwzr)**2+(vari*bwzi)**2)
36573  IF(ia.LE.10) hi=hi*faca/3d0
36574  nchn=nchn+1
36575  isig(nchn,1)=i
36576  isig(nchn,2)=-i
36577  isig(nchn,3)=1
36578  sigh(nchn)=hi*facbw*hf
36579  320 CONTINUE
36580 
36581  ELSEIF(isub.EQ.194) THEN
36582 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36583 C...Default final state is e+e-
36584  kfa=kfpr(isubsv,1)
36585  alprht=2.16d0*(3d0/itcm(1))
36586  hp=aem**2*comfac
36587 
36588  sn2w=2d0*sqrt(xw*xw1)
36589 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36590 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36591 
36592  qupd=2d0*rtcm(2)-1d0
36593  far=sqrt(aem/alprht)
36594  fao=far*qupd
36595  fzr=far*ct2w
36596  fzo=-fao*tanw
36597 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36598  fzx=-far/sn2w*rtcm(47)
36599  sfar=far**2
36600  sfao=fao**2
36601  sfzr=fzr**2
36602  sfzo=fzo**2
36603  sfzx=fzx**2
36604  CALL pywidt(23,sh,wdtp,wdte)
36605  ssmz=dcmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
36606  CALL pywidt(ktechn+113,sh,wdtp,wdte)
36607  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+113),1)**2/sh,wdtp(0)/shr)
36608  CALL pywidt(ktechn+223,sh,wdtp,wdte)
36609  ssmo=dcmplx(1d0-pmas(pycomp(ktechn+223),1)**2/sh,wdtp(0)/shr)
36610  CALL pywidt(ktechn+115,sh,wdtp,wdte)
36611  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+115),1)**2/sh,wdtp(0)/shr)
36612 C...Propagator including a_T^0
36613  detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
36614  $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
36615 C...Add in techni-a contribution
36616  detd=ssmx*detd-sfzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)
36617  daa=(-ssmx*(sfzo*ssmr+sfzr*ssmo-ssmo*ssmr*ssmz)-
36618  $ sfzx*ssmr*ssmo)/detd/sh
36619  dzz=-(sfao*ssmr+sfar*ssmo-ssmo*ssmr)/detd/sh*ssmx
36620  daz=(far*fzr*ssmo+fao*fzo*ssmr)/detd/sh*ssmx
36621 
36622  xwrht=1d0/(4d0*xw*(1d0-xw))
36623  kff=iabs(kfpr(isub,1))
36624  ef=kchg(kff,1)/3d0
36625  af=sign(1d0,ef+0.1d0)
36626  vf=af-4d0*ef*xwv
36627  valf=0.5d0*(vf+af)
36628  varf=0.5d0*(vf-af)
36629  fcof=1d0
36630  IF(kff.LE.10) fcof=3d0
36631 
36632  wid2=1d0
36633  IF(kff.GE.6.AND.kff.LE.8) wid2=wids(kff,1)
36634  IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
36635  dzz=dzz*dcmplx(xwrht,0d0)
36636  daz=daz*dcmplx(sqrt(xwrht),0d0)
36637 
36638  DO 330 i=mmina,mmaxa
36639  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 330
36640  ei=kchg(iabs(i),1)/3d0
36641  ai=sign(1d0,ei+0.1d0)
36642  vi=ai-4d0*ei*xwv
36643  vali=0.5d0*(vi+ai)
36644  vari=0.5d0*(vi-ai)
36645  fcoi=fcof
36646  IF(iabs(i).LE.10) fcoi=fcoi/3d0
36647  difll=abs(ei*ef*daa+vali*valf*dzz+daz*(ei*valf+ef*vali))**2
36648  difrr=abs(ei*ef*daa+vari*varf*dzz+daz*(ei*varf+ef*vari))**2
36649  diflr=abs(ei*ef*daa+vali*varf*dzz+daz*(ei*varf+ef*vali))**2
36650  difrl=abs(ei*ef*daa+vari*valf*dzz+daz*(ei*valf+ef*vari))**2
36651  facsig=(difll+difrr)*((uh-sqm4)**2+sh*sqm4)+
36652  & (diflr+difrl)*((th-sqm3)**2+sh*sqm3)
36653  nchn=nchn+1
36654  isig(nchn,1)=i
36655  isig(nchn,2)=-i
36656  isig(nchn,3)=1
36657  sigh(nchn)=hp*fcoi*facsig*wid2
36658  330 CONTINUE
36659 
36660  ELSEIF(isub.EQ.195) THEN
36661 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36662  kfa=kfpr(isubsv,1)
36663  kfb=kfa+1
36664  alprht=2.16d0*(3d0/itcm(1))
36665  factc=comfac*(aem**2/12d0/xw**2)*(uh-sqm3)*(uh-sqm4)*3d0
36666 
36667  fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
36668 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36669 C
36670 C...Propagator including a_T^+
36671  fwx=-fwr*rtcm(47)
36672  CALL pywidt(24,sh,wdtp,wdte)
36673  ssmz=dcmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
36674  CALL pywidt(ktechn+213,sh,wdtp,wdte)
36675  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+213),1)**2/sh,wdtp(0)/shr)
36676  CALL pywidt(ktechn+215,sh,wdtp,wdte)
36677  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+215),1)**2/sh,wdtp(0)/shr)
36678  detd=ssmx*(ssmz*ssmr-dcmplx(fwr**2,0d0))-
36679  & dcmplx(fwx**2,0d0)*ssmr
36680  dww=ssmr*ssmx/detd/sh
36681  fcof=1d0
36682  IF(kfa.LE.8) fcof=3d0
36683  hp=factc*abs(dww)**2*fcof
36684 
36685  DO 350 i=mmin1,mmax1
36686  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 350
36687  ia=iabs(i)
36688  DO 340 j=mmin2,mmax2
36689  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 340
36690  ja=iabs(j)
36691  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 340
36692  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36693  & GOTO 340
36694  kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
36695  hi=hp
36696  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
36697  nchn=nchn+1
36698  isig(nchn,1)=i
36699  isig(nchn,2)=j
36700  isig(nchn,3)=1
36701  sigh(nchn)=hi*wids(kfa,(5-kchr)/2)*wids(kfb,(5+kchr)/2)
36702  340 CONTINUE
36703  350 CONTINUE
36704  ENDIF
36705 
36706  ELSEIF(isub.LE.380) THEN
36707  alprht=2.16d0*(3d0/itcm(1))
36708  IF(isub.EQ.361) THEN
36709  far=sqrt(aem/alprht)
36710  fao=far*qupd
36711  fzr=far*ct2w
36712  fzo=-fao*tanw
36713 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36714  fzx=-far/sn2w*rtcm(47)
36715  sfar=far**2
36716  sfao=fao**2
36717  sfzr=fzr**2
36718  sfzo=fzo**2
36719  sfzx=fzx**2
36720  CALL pywidt(23,sh,wdtp,wdte)
36721  ssmz=dcmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
36722  CALL pywidt(ktechn+113,sh,wdtp,wdte)
36723  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+113),1)**2/sh,wdtp(0)/shr)
36724  CALL pywidt(ktechn+223,sh,wdtp,wdte)
36725  ssmo=dcmplx(1d0-pmas(pycomp(ktechn+223),1)**2/sh,wdtp(0)/shr)
36726  CALL pywidt(ktechn+115,sh,wdtp,wdte)
36727  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+115),1)**2/sh,wdtp(0)/shr)
36728  detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
36729  $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
36730 C...Add in techni-a contribution
36731  detd=ssmx*detd-sfzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)
36732  darho=-(ssmx*(-far*sfzo+fao*fzo*fzr+far*ssmo*ssmz)-
36733  $ sfzx*far*ssmo)/detd/sh
36734  dzrho=-(-fzr*sfao+fao*fzo*far+fzr*ssmo)/detd/sh*ssmx
36735  daome=-(ssmx*(-fao*sfzr+far*fzo*fzr+fao*ssmr*ssmz)-
36736  $ sfzx*fao*ssmr)/detd/sh
36737  dzome=-(-fzo*sfar+far*fao*fzr+fzo*ssmr)/detd/sh*ssmx
36738  daast=-fzx*(fao*fzo*ssmr+far*fzr*ssmo)/detd/sh
36739  dzast=-fzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)/detd/sh
36740  daa=(-ssmx*(sfzo*ssmr+sfzr*ssmo-ssmo*ssmr*ssmz)-
36741  $ sfzx*ssmr*ssmo)/detd/sh
36742  dzz=-(sfao*ssmr+sfar*ssmo-ssmo*ssmr)/detd/sh*ssmx
36743  daz=(far*fzr*ssmo+fao*fzo*ssmr)/detd/sh*ssmx
36744 
36745 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36746 C...W+W-, W pi_tc, pi_T pi_T, etc.
36747  faca=(sh**2*be34**2-(th-uh)**2)
36748  vfac=(th**2+uh**2-2d0*sqm3*sqm4)
36749  afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)
36750  fanom=sqrt(paru(1)*aem)*itcm(1)/paru(2)**2/rtcm(1)
36751  hp=(1d0/24d0)*aem**2*comfac*3d0*sh
36752  DO 370 i=mmina,mmaxa
36753  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 370
36754  ia=iabs(i)
36755  ei=kchg(iabs(i),1)/3d0
36756  ai=sign(1d0,ei+0.1d0)
36757  vi=ai-4d0*ei*xwv
36758  vali=0.25d0*(vi+ai) ! = \zeta_{iL} in PRD67-115011
36759  vari=0.25d0*(vi-ai) ! = \zeta_{iR} in PRD67-115011
36760 C...........Eqs. (5) and (6) in LSTC-rates.pdf
36761  f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*vrgp
36762  f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*vogp
36763  f2l=f2l+(ei*daast+vali*dzast/sqrt(xw*xw1))*vxgp
36764  f2l=f2l+fanom*(vagp*(ei*daa+vali*daz/sqrt(xw*xw1))+
36765  $ vzgp*(ei*daz+vali*dzz/sqrt(xw*xw1)))
36766  f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*vrgp
36767  f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*vogp
36768  f2r=f2r+(ei*daast+vari*dzast/sqrt(xw*xw1))*vxgp
36769  f2r=f2r+fanom*(vagp*(ei*daa+vari*daz/sqrt(xw*xw1))+
36770  $ vzgp*(ei*daz+vari*dzz/sqrt(xw*xw1)))
36771  hi=(abs(f2l)**2+abs(f2r)**2)*vfac
36772 C...........Eqs. (5) and (7) in LSTC-rates.pdf
36773  f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*argp
36774  f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*aogp
36775  f2l=f2l+(ei*daast+vali*dzast/sqrt(xw*xw1))*axgp
36776  f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*argp
36777  f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*aogp
36778  f2r=f2r+(ei*daast+vari*dzast/sqrt(xw*xw1))*axgp
36779  hj=(abs(f2l)**2+abs(f2r)**2)*afac
36780 C
36781 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36782 C
36783 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36784 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36785 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36786 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36787  f2l=ei*darho/far + vali*ct2w*dzrho/fzr/sqrt(xw*xw1)
36788  f2r=ei*darho/far + vari*ct2w*dzrho/fzr/sqrt(xw*xw1)
36789  hk=(abs(f2l)**2+abs(f2r)**2)*2d0*faca*cab2/sh
36790  hi=hi+hj+hk
36791  IF(ia.LE.10) hi=hi/3d0
36792  nchn=nchn+1
36793  isig(nchn,1)=i
36794  isig(nchn,2)=-i
36795  isig(nchn,3)=1
36796  IF(kfa.EQ.kfb) THEN
36797  sigh(nchn)=hi*hp*wids(pycomp(kfa),1)
36798  ELSEIF(isubsv.EQ.362.OR.isubsv.EQ.368) THEN
36799  sigh(nchn)=hi*hp*wids(pycomp(kfa),2)*wids(pycomp(kfb),3)
36800  nchn=nchn+1
36801  isig(nchn,1)=i
36802  isig(nchn,2)=-i
36803  isig(nchn,3)=2
36804  sigh(nchn)=hi*hp*wids(pycomp(kfa),3)*wids(pycomp(kfb),2)
36805  ELSE
36806  sigh(nchn)=hi*hp*wids(pycomp(kfa),2)*wids(pycomp(kfb),2)
36807  ENDIF
36808  370 CONTINUE
36809 
36810  ELSEIF(isub.EQ.370) THEN
36811 C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
36812 C...f + fbar' -> gamma pi_tc, etc.
36813  faca=(sh**2*be34**2-(th-uh)**2)
36814  fanom=sqrt(paru(1)*aem)*itcm(1)/paru(2)**2/rtcm(1)
36815  vfac=(th**2+uh**2-2d0*sqm3*sqm4)
36816  afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)
36817  alprht=2.16d0*(3d0/itcm(1))
36818  fachp=(1d0/48d0)*aem**2/xw*comfac*3d0*sh
36819  fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
36820 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36821  fwx=-fwr*rtcm(47)
36822  CALL pywidt(24,sh,wdtp,wdte)
36823  ssmz=dcmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
36824  CALL pywidt(ktechn+213,sh,wdtp,wdte)
36825  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+213),1)**2/sh,wdtp(0)/shr)
36826  CALL pywidt(ktechn+215,sh,wdtp,wdte)
36827  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+215),1)**2/sh,wdtp(0)/shr)
36828  detd=ssmx*(ssmz*ssmr-dcmplx(fwr**2,0d0))-
36829  & dcmplx(fwx**2,0d0)*ssmr
36830  dww=ssmr*ssmx/detd/sh
36831  dwrho=-dcmplx(fwr,0d0)*ssmx/detd/sh
36832  dwast=-dcmplx(fwx,0d0)*ssmr/detd/sh
36833  hp=fachp*(afac*abs(dwrho*argp+dwast*axgp)**2+
36834  $ vfac*abs(fanom*dww*vwgp+dwrho*vrgp+dwast*vxgp)**2)
36835 C
36836 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36837 C
36838 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36839  hp=hp+.5d0*fachp*cab2*faca/xw/sh*abs(dwrho/fwr)**2
36840 C...Add in W_L Z_T axial and vector contributions.
36841  IF(isubsv.EQ.370) hp=hp+fachp*rtcm(3)**2*(
36842  $ (th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm4)* !AFAC w/ switched masses.
36843  $ abs(dwrho/rtcm(13)-dwast/rtcm(49)*cs2w)**2/sn2w**2+
36844  $ vfac*qupd**2*xw/xw1*abs(dwrho)**2/rtcm(12)**2)
36845  DO 410 i=mmin1,mmax1
36846  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 410
36847  ia=iabs(i)
36848  DO 400 j=mmin2,mmax2
36849  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 400
36850  ja=iabs(j)
36851  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 400
36852  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36853  & GOTO 400
36854  kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
36855  hi=hp
36856  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
36857  nchn=nchn+1
36858  isig(nchn,1)=i
36859  isig(nchn,2)=j
36860  isig(nchn,3)=1
36861  IF(isubsv.EQ.374.OR.isubsv.EQ.378) THEN
36862  sigh(nchn)=hi*wids(pycomp(kfa),(5-kchr)/2)
36863  ELSE
36864  sigh(nchn)=hi*wids(pycomp(kfa),(5-kchr)/2)*
36865  & wids(pycomp(kfb),2)
36866  ENDIF
36867  400 CONTINUE
36868  410 CONTINUE
36869  ENDIF
36870 
36871  ELSEIF(isub.LE.390) THEN
36872  IF(isub.EQ.381) THEN
36873 C...f + f' -> f + f' (g exchange)
36874  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)*sqdqqt
36875  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)*sqdqqt*faca-
36876  & mstp(34)*2d0/3d0*uh2*redqst)
36877  facqq2=comfac*as**2*4d0/9d0*(sh2+th2)*sqdqqu
36878  facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
36879  ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
36880  IF(itcm(5).GE.1.AND.itcm(5).LE.4) THEN
36881 C...Modifications from contact interactions (compositeness)
36882  facci1=facqq1+comfac*(sh2/rtcm(41)**4)
36883  faccib=facqqb+comfac*(8d0/9d0)*(as*rtcm(42)/rtcm(41)**2)*
36884  & (uh2/th+uh2/sh)+comfac*(5d0/3d0)*(uh2/rtcm(41)**4)
36885  facci2=facqq2+comfac*(8d0/9d0)*(as*rtcm(42)/rtcm(41)**2)*
36886  & (sh2/th+sh2/uh)+comfac*(5d0/3d0)*(sh2/rtcm(41)**4)
36887  facci3=facqq1+comfac*(uh2/rtcm(41)**4)
36888  ratcii=(facci1+facci2+facqqi)/(facci1+facci2)
36889  ELSEIF(itcm(5).EQ.5) THEN
36890  facci1=facqq1
36891  faccib=facqqb
36892  facci2=facqq2
36893  facci3=facqq1
36894 CSM.......Check this change from
36895 CSM RATCII=1D0
36896  ratcii=ratqqi
36897  ENDIF
36898  DO 430 i=mmin1,mmax1
36899  ia=iabs(i)
36900  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 430
36901  DO 420 j=mmin2,mmax2
36902  ja=iabs(j)
36903  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 420
36904  nchn=nchn+1
36905  isig(nchn,1)=i
36906  isig(nchn,2)=j
36907  isig(nchn,3)=1
36908  IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.(ia.GE.3.OR.
36909  & ja.GE.3))) THEN
36910  sigh(nchn)=facqq1
36911  IF(i.EQ.-j) sigh(nchn)=facqqb
36912  ELSE
36913  sigh(nchn)=facci1
36914  IF(i*j.LT.0) sigh(nchn)=facci3
36915  IF(i.EQ.-j) sigh(nchn)=faccib
36916  ENDIF
36917  IF(i.EQ.j) THEN
36918  nchn=nchn+1
36919  isig(nchn,1)=i
36920  isig(nchn,2)=j
36921  isig(nchn,3)=2
36922  IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.ia.GE.3)) THEN
36923  sigh(nchn-1)=0.5d0*facqq1*ratqqi
36924  sigh(nchn)=0.5d0*facqq2*ratqqi
36925  ELSE
36926  sigh(nchn-1)=0.5d0*facci1*ratcii
36927  sigh(nchn)=0.5d0*facci2*ratcii
36928  ENDIF
36929  ENDIF
36930  420 CONTINUE
36931  430 CONTINUE
36932 
36933  ELSEIF(isub.EQ.382) THEN
36934 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
36935  CALL pywidt(21,sh,wdtp,wdte)
36936  facqqf=comfac*as**2*4d0/9d0*(th2+uh2)
36937  facqqb=facqqf*sqdqqs*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36938  IF(itcm(5).EQ.1) THEN
36939 C...Modifications from contact interactions (compositeness)
36940  faccib=facqqb
36941  DO 440 i=1,2
36942  faccib=faccib+comfac*(uh2/rtcm(41)**4)*(wdte(i,1)+
36943  & wdte(i,2)+wdte(i,4))
36944  440 CONTINUE
36945  ELSEIF(itcm(5).GE.2.AND.itcm(5).LE.4) THEN
36946  faccib=facqqb+comfac*(uh2/rtcm(41)**4)*
36947  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
36948  ELSEIF(itcm(5).EQ.5) THEN
36949  facqqb=facqqf*sqdqqs*(wdte(0,1)+wdte(0,2)+wdte(0,4)-
36950  & wdte(5,1)-wdte(5,2)-wdte(5,4))
36951  faccib=facqqf*sqdqts*(wdte(5,1)+wdte(5,2)+wdte(5,4))
36952  ENDIF
36953  DO 450 i=mmina,mmaxa
36954  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
36955  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 450
36956  nchn=nchn+1
36957  isig(nchn,1)=i
36958  isig(nchn,2)=-i
36959  isig(nchn,3)=1
36960  IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.iabs(i).GE.3)) THEN
36961  sigh(nchn)=facqqb
36962  ELSEIF(itcm(5).EQ.5) THEN
36963  sigh(nchn)=facqqb
36964  nchn=nchn+1
36965  isig(nchn,1)=i
36966  isig(nchn,2)=-i
36967  isig(nchn,3)=2
36968  sigh(nchn)=faccib
36969  ELSE
36970  sigh(nchn)=faccib
36971  ENDIF
36972  450 CONTINUE
36973 
36974  ELSEIF(isub.EQ.383) THEN
36975 C...f + fbar -> g + g (q + qbar -> g + g only)
36976  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
36977  & uh2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)
36978  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
36979  & th2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)
36980  IF(itcm(5).EQ.5) THEN
36981  facgg3=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
36982  & uh2/sh2+9d0/4d0*th*uh/sh2*sqdhgs)
36983  facgg4=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
36984  & th2/sh2+9d0/4d0*th*uh/sh2*sqdhgs)
36985  ENDIF
36986  DO 460 i=mmina,mmaxa
36987  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
36988  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 460
36989  nchn=nchn+1
36990  isig(nchn,1)=i
36991  isig(nchn,2)=-i
36992  isig(nchn,3)=1
36993  sigh(nchn)=0.5d0*facgg1
36994  IF(itcm(5).EQ.5.AND.iabs(i).EQ.5) sigh(nchn)=0.5d0*facgg3
36995  nchn=nchn+1
36996  isig(nchn,1)=i
36997  isig(nchn,2)=-i
36998  isig(nchn,3)=2
36999  sigh(nchn)=0.5d0*facgg2
37000  IF(itcm(5).EQ.5.AND.iabs(i).EQ.5) sigh(nchn)=0.5d0*facgg4
37001  460 CONTINUE
37002 
37003  ELSEIF(isub.EQ.384) THEN
37004 C...f + g -> f + g (q + g -> q + g only)
37005  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
37006  & uh/sh-9d0/4d0*sh*uh/th2*sqdlgt)*faca
37007  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
37008  & sh/uh-9d0/4d0*sh*uh/th2*sqdlgt)
37009  DO 480 i=mmina,mmaxa
37010  IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 480
37011  DO 470 isde=1,2
37012  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 470
37013  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 470
37014  nchn=nchn+1
37015  isig(nchn,isde)=i
37016  isig(nchn,3-isde)=21
37017  isig(nchn,3)=1
37018  sigh(nchn)=facqg1
37019  nchn=nchn+1
37020  isig(nchn,isde)=i
37021  isig(nchn,3-isde)=21
37022  isig(nchn,3)=2
37023  sigh(nchn)=facqg2
37024  470 CONTINUE
37025  480 CONTINUE
37026 
37027  ELSEIF(isub.EQ.385) THEN
37028 C...g + g -> f + fbar (g + g -> q + qbar only)
37029  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 500
37030  idc0=mdcy(21,2)-1
37031 C...Begin by d, u, s flavours.
37032  flavwt=0d0
37033  IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
37034  & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
37035  IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
37036  & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
37037  IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
37038  & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
37039  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
37040  & uh2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)*flavwt*faca
37041  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
37042  & th2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)*flavwt*faca
37043  nchn=nchn+1
37044  isig(nchn,1)=21
37045  isig(nchn,2)=21
37046  isig(nchn,3)=1
37047  sigh(nchn)=facqq1
37048  nchn=nchn+1
37049  isig(nchn,1)=21
37050  isig(nchn,2)=21
37051  isig(nchn,3)=2
37052  sigh(nchn)=facqq2
37053 C...Next c and b flavours: modified that and uhat for fixed
37054 C...cos(theta-hat).
37055  DO 490 ifl=4,5
37056  sqmavg=pmas(ifl,1)**2
37057  IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
37058  be34=sqrt(1d0-4d0*sqmavg/sh)
37059  thq=-0.5d0*sh*(1d0-be34*cth)
37060  uhq=-0.5d0*sh*(1d0+be34*cth)
37061  thuhq=thq*uhq-sqmavg*sh
37062  IF(mstp(34).EQ.0) THEN
37063  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
37064  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
37065  ELSE
37066  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37067  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
37068  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37069  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
37070  ENDIF
37071  IF(itcm(5).GE.5) THEN
37072  IF(ifl.EQ.4) THEN
37073  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redlgs+
37074  & 2.25d0*thq*uhq/sh2*sqdlgs
37075  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redlgs+
37076  & 2.25d0*thq*uhq/sh2*sqdlgs
37077  ELSE
37078  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redhgs+
37079  & 2.25d0*thq*uhq/sh2*sqdhgs
37080  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redhgs+
37081  & 2.25d0*thq*uhq/sh2*sqdhgs
37082  ENDIF
37083  ENDIF
37084  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
37085  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
37086  nchn=nchn+1
37087  isig(nchn,1)=21
37088  isig(nchn,2)=21
37089  isig(nchn,3)=1+2*(ifl-3)
37090  sigh(nchn)=facqq1
37091  nchn=nchn+1
37092  isig(nchn,1)=21
37093  isig(nchn,2)=21
37094  isig(nchn,3)=2+2*(ifl-3)
37095  sigh(nchn)=facqq2
37096  ENDIF
37097  490 CONTINUE
37098  500 CONTINUE
37099 
37100  ELSEIF(isub.EQ.386) THEN
37101 C...g + g -> g + g
37102  IF(itcm(5).LE.4) THEN
37103  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
37104  & 2d0*th/sh+th2/sh2)*faca
37105  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
37106  & 2d0*sh/uh+sh2/uh2)*faca
37107  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+
37108  & 2d0*uh/th+uh2/th2)
37109  ELSE
37110  gst= (12d0 + 40d0*th/sh + 56d0*th2/sh2 + 32d0*th**3/sh**3 +
37111  & 16d0*th**4/sh**4 + sqdggs*(4d0*sh2 + 16d0*sh*th + 16d0*th2)+
37112  & 4d0*redgst*(sh + 2d0*th)*
37113  & (2d0*sh**3 - 3d0*sh2*th - 2d0*sh*th2 + 2d0*th**3)/sh2 +
37114  & 2d0*redggs*(2d0*sh - 12d0*th2/sh - 8d0*th**3/sh2) +
37115  & 2d0*redggt*(4d0*sh - 22d0*th - 68d0*th2/sh - 60d0*th**3/sh2-
37116  & 32d0*th**4/sh**3 - 16d0*th**5/sh**4) +
37117  & sqdggt*(16d0*sh2 + 16d0*sh*th + 68d0*th2 + 144d0*th**3/sh +
37118  & 96d0*th**4/sh2 + 32d0*th**5/sh**3 + 16d0*th**6/sh**4))/16d0
37119  gsu= (12d0 + 40d0*uh/sh + 56d0*uh2/sh2 + 32d0*uh**3/sh**3 +
37120  & 16d0*uh**4/sh**4 + sqdggs*(4d0*sh2 + 16d0*sh*uh + 16d0*uh2)+
37121  & 4d0*redgsu*(sh + 2d0*uh)*
37122  & (2d0*sh**3 - 3d0*sh2*uh - 2d0*sh*uh2 + 2d0*uh**3)/sh2 +
37123  & 2d0*redggs*(2d0*sh - 12d0*uh2/sh - 8d0*uh**3/sh2) +
37124  & 2d0*redggu*(4d0*sh - 22d0*uh - 68d0*uh2/sh - 60d0*uh**3/sh2-
37125  & 32d0*uh**4/sh**3 - 16d0*uh**5/sh**4) +
37126  & sqdggu*(16d0*sh2 + 16d0*sh*uh + 68d0*uh2 + 144d0*uh**3/sh +
37127  & 96d0*uh**4/sh2 + 32d0*uh**5/sh**3 + 16d0*uh**6/sh**4))/16d0
37128  gut= (12d0 - 16d0*th*(th - uh)**2*uh/sh**4 +
37129  & 4d0*redggu*(2d0*th**5 - 15d0*th**4*uh - 48d0*th**3*uh2 -
37130  & 58d0*th2*uh**3 - 10d0*th*uh**4 + uh**5)/sh**4 +
37131  & 4d0*redggt*(th**5 - 10d0*th**4*uh - 58d0*th**3*uh2 -
37132  & 48d0*th2*uh**3 - 15d0*th*uh**4 + 2d0*uh**5)/sh**4 +
37133  & 4d0*sqdggu*(4d0*th**6 + 20d0*th**5*uh + 57d0*th**4*uh2 +
37134  & 72d0*th**3*uh**3+ 38d0*th2*uh**4+4d0*th*uh**5 +uh**6)/sh**4+
37135  & 4d0*sqdggt*(4d0*uh**6 + 4d0*th**5*uh + 38d0*th**4*uh2 +
37136  & 72d0*th**3*uh**3 +57d0*th2*uh**4+20d0*th*uh**5+th**6)/sh**4+
37137  & 2d0*redgtu*((th - uh)**2* (th**4 + 20d0*th**3*uh +
37138  & 30d0*th2*uh2 + 20d0*th*uh**3 + uh**4) +
37139  & sh2*(7d0*th**4 + 52d0*th**3*uh + 274d0*th2*uh2 +
37140  & 52d0*th*uh**3 + 7d0*uh**4))/(2d0*sh**4))/16d0
37141  facgg1=comfac*as**2*9d0/4d0*gst*faca
37142  facgg2=comfac*as**2*9d0/4d0*gsu*faca
37143  facgg3=comfac*as**2*9d0/4d0*gut
37144  ENDIF
37145  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 510
37146  nchn=nchn+1
37147  isig(nchn,1)=21
37148  isig(nchn,2)=21
37149  isig(nchn,3)=1
37150  sigh(nchn)=0.5d0*facgg1
37151  nchn=nchn+1
37152  isig(nchn,1)=21
37153  isig(nchn,2)=21
37154  isig(nchn,3)=2
37155  sigh(nchn)=0.5d0*facgg2
37156  nchn=nchn+1
37157  isig(nchn,1)=21
37158  isig(nchn,2)=21
37159  isig(nchn,3)=3
37160  sigh(nchn)=0.5d0*facgg3
37161  510 CONTINUE
37162 
37163  ELSEIF(isub.EQ.387) THEN
37164 C...q + qbar -> Q + Qbar
37165  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
37166  thq=-0.5d0*sh*(1d0-be34*cth)
37167  uhq=-0.5d0*sh*(1d0+be34*cth)
37168  facqqb=comfac*as**2*4d0/9d0*((thq**2+uhq**2)/sh2+
37169  & 2d0*sqmavg/sh)
37170  IF(itcm(5).GE.5) THEN
37171  IF(mint(55).EQ.5.OR.mint(55).EQ.6) THEN
37172  facqqb=facqqb*sh2*sqdqts
37173  ELSE
37174  facqqb=facqqb*sh2*sqdqqs
37175  ENDIF
37176  ENDIF
37177  IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqmavg,0d0)
37178  wid2=1d0
37179  IF(mint(55).EQ.6) wid2=wids(6,1)
37180  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
37181  facqqb=facqqb*wid2
37182  DO 520 i=mmina,mmaxa
37183  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37184  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 520
37185  nchn=nchn+1
37186  isig(nchn,1)=i
37187  isig(nchn,2)=-i
37188  isig(nchn,3)=1
37189  sigh(nchn)=facqqb
37190  520 CONTINUE
37191 
37192  ELSEIF(isub.EQ.388) THEN
37193 C...g + g -> Q + Qbar
37194  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
37195  thq=-0.5d0*sh*(1d0-be34*cth)
37196  uhq=-0.5d0*sh*(1d0+be34*cth)
37197  thuhq=thq*uhq-sqmavg*sh
37198  IF(mstp(34).EQ.0) THEN
37199  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
37200  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
37201  ELSE
37202  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37203  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
37204  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37205  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
37206  ENDIF
37207  IF(itcm(5).GE.5) THEN
37208  IF(mint(55).EQ.5.OR.mint(55).EQ.6) THEN
37209  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redhgs+
37210  & 2.25d0*thq*uhq/sh2*sqdhgs
37211  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redhgs+
37212  & 2.25d0*thq*uhq/sh2*sqdhgs
37213  ELSE
37214  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redlgs+
37215  & 2.25d0*thq*uhq/sh2*sqdlgs
37216  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redlgs+
37217  & 2.25d0*thq*uhq/sh2*sqdlgs
37218  ENDIF
37219  ENDIF
37220  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1
37221  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2
37222  IF(mstp(35).GE.1) THEN
37223  fatre=pyhfth(sh,sqmavg,2d0/7d0)
37224  facqq1=facqq1*fatre
37225  facqq2=facqq2*fatre
37226  ENDIF
37227  wid2=1d0
37228  IF(mint(55).EQ.6) wid2=wids(6,1)
37229  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
37230  facqq1=facqq1*wid2
37231  facqq2=facqq2*wid2
37232  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 530
37233  nchn=nchn+1
37234  isig(nchn,1)=21
37235  isig(nchn,2)=21
37236  isig(nchn,3)=1
37237  sigh(nchn)=facqq1
37238  nchn=nchn+1
37239  isig(nchn,1)=21
37240  isig(nchn,2)=21
37241  isig(nchn,3)=2
37242  sigh(nchn)=facqq2
37243  530 CONTINUE
37244  ENDIF
37245  ENDIF
37246 
37247 CMRENNA--
37248 
37249  RETURN
37250  END
37251 
37252 C*********************************************************************
37253 
37254 C...PYSGEX
37255 C...Subprocess cross sections for assorted exotic processes,
37256 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37257 C...Auxiliary to PYSIGH.
37258 
37259  SUBROUTINE pysgex(NCHN,SIGS)
37260 
37261 C...Double precision and integer declarations
37262  IMPLICIT DOUBLE PRECISION(a-h, o-z)
37263  IMPLICIT INTEGER(I-N)
37264  INTEGER PYK,PYCHGE,PYCOMP
37265 C...Parameter statement to help give large particle numbers.
37266  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
37267  &kexcit=4000000,kdimen=5000000)
37268 C...Commonblocks
37269  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37270  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37271  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
37272  common/pypars/mstp(200),parp(200),msti(200),pari(200)
37273  common/pyint1/mint(400),vint(400)
37274  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
37275  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
37276  common/pyint4/mwid(500),wids(500,5)
37277  common/pytcsm/itcm(0:99),rtcm(0:99)
37278  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
37279  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
37280  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
37281  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
37282  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
37283  &/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
37284 C...Local arrays
37285  dimension wdtp(0:400),wdte(0:400,0:5)
37286 
37287 C...Differential cross section expressions.
37288 
37289  IF(isub.LE.160) THEN
37290  IF(isub.EQ.141) THEN
37291 C...f + fbar -> gamma*/Z0/Z'0
37292  sqmzp=pmas(32,1)**2
37293  mint(61)=2
37294  CALL pywidt(32,sh,wdtp,wdte)
37295  hp0=aem/3d0*sh
37296  hp1=aem/3d0*xwc*sh
37297  hp2=hp1
37298  hs=shr*vint(117)
37299  hsp=shr*wdtp(0)
37300  faczp=4d0*comfac*3d0
37301  DO 100 i=mmina,mmaxa
37302  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
37303  ei=kchg(iabs(i),1)/3d0
37304  ai=sign(1d0,ei)
37305  vi=ai-4d0*ei*xwv
37306  ia=iabs(i)
37307  IF(ia.LT.10) THEN
37308  IF(ia.LE.2) THEN
37309  vpi=paru(123-2*mod(iabs(i),2))
37310  api=paru(124-2*mod(iabs(i),2))
37311  ELSEIF(ia.LE.4) THEN
37312  vpi=parj(182-2*mod(iabs(i),2))
37313  api=parj(183-2*mod(iabs(i),2))
37314  ELSE
37315  vpi=parj(190-2*mod(iabs(i),2))
37316  api=parj(191-2*mod(iabs(i),2))
37317  ENDIF
37318  ELSE
37319  IF(ia.LE.12) THEN
37320  vpi=paru(127-2*mod(iabs(i),2))
37321  api=paru(128-2*mod(iabs(i),2))
37322  ELSEIF(ia.LE.14) THEN
37323  vpi=parj(186-2*mod(iabs(i),2))
37324  api=parj(187-2*mod(iabs(i),2))
37325  ELSE
37326  vpi=parj(194-2*mod(iabs(i),2))
37327  api=parj(195-2*mod(iabs(i),2))
37328  ENDIF
37329  ENDIF
37330  hi0=hp0
37331  IF(iabs(i).LE.10) hi0=hi0*faca/3d0
37332  hi1=hp1
37333  IF(iabs(i).LE.10) hi1=hi1*faca/3d0
37334  hi2=hp2
37335  IF(iabs(i).LE.10) hi2=hi2*faca/3d0
37336  nchn=nchn+1
37337  isig(nchn,1)=i
37338  isig(nchn,2)=-i
37339  isig(nchn,3)=1
37340 C...Special case: if only branching ratios known then use them.
37341  IF(mwid(32).EQ.2.AND.mstp(44).EQ.3) THEN
37342  hi=0d0
37343  IF(ia.LT.10) THEN
37344  hi=shr*wdtp(ia)*faca/9d0
37345  ELSEIF(ia.LT.20) THEN
37346  hi=shr*wdtp(ia-2)
37347  ENDIF
37348  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37349  sigh(nchn)=hi*faczp*hf/((sh-sqmzp)**2+hsp**2)
37350  ELSE
37351 C...Normal cross section.
37352  sigh(nchn)=faczp*(ei**2/sh2*hi0*hp0*vint(111)+ei*vi*
37353  & (1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*(hi0*hp1+hi1*hp0)*
37354  & vint(112)+ei*vpi*(1d0-sqmzp/sh)/((sh-sqmzp)**2+hsp**2)*
37355  & (hi0*hp2+hi2*hp0)*vint(113)+(vi**2+ai**2)/
37356  & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114)+(vi*vpi+ai*api)*
37357  & ((sh-sqmz)*(sh-sqmzp)+hs*hsp)/(((sh-sqmz)**2+hs**2)*
37358  & ((sh-sqmzp)**2+hsp**2))*(hi1*hp2+hi2*hp1)*vint(115)+
37359  & (vpi**2+api**2)/((sh-sqmzp)**2+hsp**2)*hi2*hp2*vint(116))
37360  ENDIF
37361  100 CONTINUE
37362 
37363  ELSEIF(isub.EQ.142) THEN
37364 C...f + fbar' -> W'+/-
37365  sqmwp=pmas(34,1)**2
37366  CALL pywidt(34,sh,wdtp,wdte)
37367  hs=shr*wdtp(0)
37368  facbw=4d0*comfac/((sh-sqmwp)**2+hs**2)*3d0
37369  hp=aem/(24d0*xw)*sh
37370  DO 120 i=mmin1,mmax1
37371  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 120
37372  ia=iabs(i)
37373  DO 110 j=mmin2,mmax2
37374  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 110
37375  ja=iabs(j)
37376  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 110
37377  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37378  & GOTO 110
37379  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37380 C...Special case: if only branching ratios known then use them.
37381  IF(mwid(34).EQ.2) THEN
37382  hi=0d0
37383  DO 105 idc=mdcy(34,2),mdcy(34,2)+mdcy(34,3)-1
37384  IF((ia.EQ.iabs(kfdp(idc,1)).AND.ja.EQ.
37385  & iabs(kfdp(idc,2))).OR.(ia.EQ.iabs(kfdp(idc,2))
37386  & .AND.ja.EQ.iabs(kfdp(idc,1))))
37387  & hi=shr*wdtp(idc+1-mdcy(34,2))
37388  105 CONTINUE
37389  IF(ia.LT.10) hi=hi*faca/9d0
37390  ELSE
37391 C...Normal cross section.
37392  hi=hp*(paru(133)**2+paru(134)**2)
37393  IF(ia.LE.10) hi=hp*(paru(131)**2+paru(132)**2)*
37394  & vckm((ia+1)/2,(ja+1)/2)*faca/3d0
37395  ENDIF
37396  nchn=nchn+1
37397  isig(nchn,1)=i
37398  isig(nchn,2)=j
37399  isig(nchn,3)=1
37400  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
37401  sigh(nchn)=hi*facbw*hf
37402  110 CONTINUE
37403  120 CONTINUE
37404 
37405  ELSEIF(isub.EQ.144) THEN
37406 C...f + fbar' -> R
37407  sqmr=pmas(41,1)**2
37408  CALL pywidt(41,sh,wdtp,wdte)
37409  hs=shr*wdtp(0)
37410  facbw=4d0*comfac/((sh-sqmr)**2+hs**2)*3d0
37411  hp=aem/(12d0*xw)*sh
37412  DO 140 i=mmin1,mmax1
37413  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 140
37414  ia=iabs(i)
37415  DO 130 j=mmin2,mmax2
37416  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 130
37417  ja=iabs(j)
37418  IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) GOTO 130
37419  hi=hp
37420  IF(ia.LE.10) hi=hi*faca/3d0
37421  hf=shr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))
37422  nchn=nchn+1
37423  isig(nchn,1)=i
37424  isig(nchn,2)=j
37425  isig(nchn,3)=1
37426  sigh(nchn)=hi*facbw*hf
37427  130 CONTINUE
37428  140 CONTINUE
37429 
37430  ELSEIF(isub.EQ.145) THEN
37431 C...q + l -> LQ (leptoquark)
37432  sqmlq=pmas(42,1)**2
37433  CALL pywidt(42,sh,wdtp,wdte)
37434  hs=shr*wdtp(0)
37435  facbw=4d0*comfac/((sh-sqmlq)**2+hs**2)
37436  IF(abs(shr-pmas(42,1)).GT.parp(48)*pmas(42,2)) facbw=0d0
37437  hp=aem/4d0*sh
37438  kflqq=kfdp(mdcy(42,2),1)
37439  kflql=kfdp(mdcy(42,2),2)
37440  DO 160 i=mmin1,mmax1
37441  IF(kfac(1,i).EQ.0) GOTO 160
37442  ia=iabs(i)
37443  IF(ia.NE.kflqq.AND.ia.NE.iabs(kflql)) GOTO 160
37444  DO 150 j=mmin2,mmax2
37445  IF(kfac(2,j).EQ.0) GOTO 150
37446  ja=iabs(j)
37447  IF(ja.NE.kflqq.AND.ja.NE.iabs(kflql)) GOTO 150
37448  IF(i*j.NE.kflqq*kflql) GOTO 150
37449  IF(ja.EQ.ia) GOTO 150
37450  IF(ia.EQ.kflqq) kchlq=isign(1,i)
37451  IF(ja.EQ.kflqq) kchlq=isign(1,j)
37452  hi=hp*paru(151)
37453  hf=shr*(wdte(0,1)+wdte(0,(5-kchlq)/2)+wdte(0,4))
37454  nchn=nchn+1
37455  isig(nchn,1)=i
37456  isig(nchn,2)=j
37457  isig(nchn,3)=1
37458  sigh(nchn)=hi*facbw*hf
37459  150 CONTINUE
37460  160 CONTINUE
37461 
37462  ELSEIF(isub.EQ.146) THEN
37463 C...e + gamma* -> e* (excited lepton)
37464  kfqstr=kfpr(isub,1)
37465  kcqstr=pycomp(kfqstr)
37466  kfqexc=mod(kfqstr,kexcit)
37467  CALL pywidt(kfqstr,sh,wdtp,wdte)
37468  hs=shr*wdtp(0)
37469  facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
37470  qf=-rtcm(43)/2d0-rtcm(44)/2d0
37471  facbw=facbw*aem*qf**2*sh/rtcm(41)**2
37472  IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
37473  & facbw=0d0
37474  hp=sh
37475  DO 180 i=-kfqexc,kfqexc,2*kfqexc
37476  DO 170 isde=1,2
37477  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 170
37478  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 170
37479  hi=hp
37480  IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37481  IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
37482  nchn=nchn+1
37483  isig(nchn,isde)=i
37484  isig(nchn,3-isde)=22
37485  isig(nchn,3)=1
37486  sigh(nchn)=hi*facbw*hf
37487  170 CONTINUE
37488  180 CONTINUE
37489 
37490  ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
37491 C...d + g -> d* and u + g -> u* (excited quarks)
37492  kfqstr=kfpr(isub,1)
37493  kcqstr=pycomp(kfqstr)
37494  kfqexc=mod(kfqstr,kexcit)
37495  CALL pywidt(kfqstr,sh,wdtp,wdte)
37496  hs=shr*wdtp(0)
37497  facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
37498  facbw=facbw*as*rtcm(45)**2*sh/(3d0*rtcm(41)**2)
37499  IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
37500  & facbw=0d0
37501  hp=sh
37502  DO 200 i=-kfqexc,kfqexc,2*kfqexc
37503  DO 190 isde=1,2
37504  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 190
37505  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 190
37506  hi=hp
37507  IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37508  IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
37509  nchn=nchn+1
37510  isig(nchn,isde)=i
37511  isig(nchn,3-isde)=21
37512  isig(nchn,3)=1
37513  sigh(nchn)=hi*facbw*hf
37514  190 CONTINUE
37515  200 CONTINUE
37516  ENDIF
37517 
37518  ELSEIF(isub.LE.190) THEN
37519  IF(isub.EQ.162) THEN
37520 C...q + g -> LQ + lbar; LQ=leptoquark
37521  sqmlq=pmas(42,1)**2
37522  faclq=comfac*faca*paru(151)*(as*aem/6d0)*(-th/sh)*
37523  & (uh2+sqmlq**2)/(uh-sqmlq)**2
37524  kflqq=kfdp(mdcy(42,2),1)
37525  DO 220 i=mmina,mmaxa
37526  IF(iabs(i).NE.kflqq) GOTO 220
37527  kchlq=isign(1,i)
37528  DO 210 isde=1,2
37529  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 210
37530  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 210
37531  nchn=nchn+1
37532  isig(nchn,isde)=i
37533  isig(nchn,3-isde)=21
37534  isig(nchn,3)=1
37535  sigh(nchn)=faclq*wids(42,(5-kchlq)/2)
37536  210 CONTINUE
37537  220 CONTINUE
37538 
37539  ELSEIF(isub.EQ.163) THEN
37540 C...g + g -> LQ + LQbar; LQ=leptoquark
37541  sqmlq=pmas(42,1)**2
37542  faclq=comfac*faca*wids(42,1)*(as**2/2d0)*
37543  & (7d0/48d0+3d0*(uh-th)**2/(16d0*sh2))*(1d0+2d0*sqmlq*th/
37544  & (th-sqmlq)**2+2d0*sqmlq*uh/(uh-sqmlq)**2+4d0*sqmlq**2/
37545  & ((th-sqmlq)*(uh-sqmlq)))
37546  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 230
37547  nchn=nchn+1
37548  isig(nchn,1)=21
37549  isig(nchn,2)=21
37550 C...Since don't know proper colour flow, randomize between alternatives
37551  isig(nchn,3)=int(1.5d0+pyr(0))
37552  sigh(nchn)=faclq
37553  230 CONTINUE
37554 
37555  ELSEIF(isub.EQ.164) THEN
37556 C...q + qbar -> LQ + LQbar; LQ=leptoquark
37557  delta=0.25d0*(sqm3-sqm4)**2/sh
37558  sqmlq=0.5d0*(sqm3+sqm4)-delta
37559  th=th-delta
37560  uh=uh-delta
37561 C SQMLQ=PMAS(42,1)**2
37562  faclqa=comfac*wids(42,1)*(as**2/9d0)*
37563  & (sh*(sh-4d0*sqmlq)-(uh-th)**2)/sh2
37564  faclqs=comfac*wids(42,1)*((paru(151)**2*aem**2/8d0)*
37565  & (-sh*th-(sqmlq-th)**2)/th2+(paru(151)*aem*as/18d0)*
37566  & ((sqmlq-th)*(uh-th)+sh*(sqmlq+th))/(sh*th))
37567  kflqq=kfdp(mdcy(42,2),1)
37568  DO 240 i=mmina,mmaxa
37569  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37570  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 240
37571  nchn=nchn+1
37572  isig(nchn,1)=i
37573  isig(nchn,2)=-i
37574  isig(nchn,3)=1
37575  sigh(nchn)=faclqa
37576  IF(iabs(i).EQ.kflqq) sigh(nchn)=faclqa+faclqs
37577  240 CONTINUE
37578 
37579  ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
37580 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37581  kfqstr=kfpr(isub,2)
37582  kcqstr=pycomp(kfqstr)
37583  kfqexc=mod(kfqstr,kexcit)
37584  facqsa=comfac*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)
37585  facqsb=comfac*0.25d0*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)*
37586  & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
37587 C...Propagators: as simulated in PYOFSH and as desired
37588  gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
37589  hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
37590  CALL pywidt(kfqstr,sqm4,wdtp,wdte)
37591  gmmqc=sqrt(sqm4)*wdtp(0)
37592  hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
37593  facqsa=facqsa*hbw4c/hbw4
37594  facqsb=facqsb*hbw4c/hbw4
37595 C...Branching ratios.
37596  brpos=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
37597  brneg=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
37598  DO 260 i=mmin1,mmax1
37599  ia=iabs(i)
37600  IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) GOTO 260
37601  DO 250 j=mmin2,mmax2
37602  ja=iabs(j)
37603  IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) GOTO 250
37604  IF(ia.EQ.kfqexc.AND.i.EQ.j) THEN
37605  nchn=nchn+1
37606  isig(nchn,1)=i
37607  isig(nchn,2)=j
37608  isig(nchn,3)=1
37609  IF(i.GT.0) sigh(nchn)=(4d0/3d0)*facqsa*brpos
37610  IF(i.LT.0) sigh(nchn)=(4d0/3d0)*facqsa*brneg
37611  nchn=nchn+1
37612  isig(nchn,1)=i
37613  isig(nchn,2)=j
37614  isig(nchn,3)=2
37615  IF(j.GT.0) sigh(nchn)=(4d0/3d0)*facqsa*brpos
37616  IF(j.LT.0) sigh(nchn)=(4d0/3d0)*facqsa*brneg
37617  ELSEIF((ia.EQ.kfqexc.OR.ja.EQ.kfqexc).AND.i*j.GT.0) THEN
37618  nchn=nchn+1
37619  isig(nchn,1)=i
37620  isig(nchn,2)=j
37621  isig(nchn,3)=1
37622  IF(ja.EQ.kfqexc) isig(nchn,3)=2
37623  IF(isig(nchn,isig(nchn,3)).GT.0) sigh(nchn)=facqsa*brpos
37624  IF(isig(nchn,isig(nchn,3)).LT.0) sigh(nchn)=facqsa*brneg
37625  ELSEIF(ia.EQ.kfqexc.AND.i.EQ.-j) THEN
37626  nchn=nchn+1
37627  isig(nchn,1)=i
37628  isig(nchn,2)=j
37629  isig(nchn,3)=1
37630  IF(i.GT.0) sigh(nchn)=(8d0/3d0)*facqsb*brpos
37631  IF(i.LT.0) sigh(nchn)=(8d0/3d0)*facqsb*brneg
37632  nchn=nchn+1
37633  isig(nchn,1)=i
37634  isig(nchn,2)=j
37635  isig(nchn,3)=2
37636  IF(j.GT.0) sigh(nchn)=(8d0/3d0)*facqsb*brpos
37637  IF(j.LT.0) sigh(nchn)=(8d0/3d0)*facqsb*brneg
37638  ELSEIF(i.EQ.-j) THEN
37639  nchn=nchn+1
37640  isig(nchn,1)=i
37641  isig(nchn,2)=j
37642  isig(nchn,3)=1
37643  IF(i.GT.0) sigh(nchn)=facqsb*brpos
37644  IF(i.LT.0) sigh(nchn)=facqsb*brneg
37645  nchn=nchn+1
37646  isig(nchn,1)=i
37647  isig(nchn,2)=j
37648  isig(nchn,3)=2
37649  IF(j.GT.0) sigh(nchn)=facqsb*brpos
37650  IF(j.LT.0) sigh(nchn)=facqsb*brneg
37651  ELSEIF(ia.EQ.kfqexc.OR.ja.EQ.kfqexc) THEN
37652  nchn=nchn+1
37653  isig(nchn,1)=i
37654  isig(nchn,2)=j
37655  isig(nchn,3)=1
37656  IF(ja.EQ.kfqexc) isig(nchn,3)=2
37657  IF(isig(nchn,isig(nchn,3)).GT.0) sigh(nchn)=facqsb*brpos
37658  IF(isig(nchn,isig(nchn,3)).LT.0) sigh(nchn)=facqsb*brneg
37659  ENDIF
37660  250 CONTINUE
37661  260 CONTINUE
37662 
37663  ELSEIF(isub.EQ.169) THEN
37664 C...q + qbar -> e + e* (excited lepton)
37665  kfqstr=kfpr(isub,2)
37666  kcqstr=pycomp(kfqstr)
37667  kfqexc=mod(kfqstr,kexcit)
37668  facqsb=(comfac/12d0)*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)*
37669  & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
37670 C...Propagators: as simulated in PYOFSH and as desired
37671  gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
37672  hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
37673  CALL pywidt(kfqstr,sqm4,wdtp,wdte)
37674  gmmqc=sqrt(sqm4)*wdtp(0)
37675  hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
37676  facqsb=facqsb*hbw4c/hbw4
37677 C...Branching ratios.
37678  brpos=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
37679  brneg=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
37680  DO 270 i=mmin1,mmax1
37681  ia=iabs(i)
37682  IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) GOTO 270
37683  j=-i
37684  ja=iabs(j)
37685  IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) GOTO 270
37686  nchn=nchn+1
37687  isig(nchn,1)=i
37688  isig(nchn,2)=j
37689  isig(nchn,3)=1
37690  IF(i.GT.0) sigh(nchn)=facqsb*brpos
37691  IF(i.LT.0) sigh(nchn)=facqsb*brneg
37692  nchn=nchn+1
37693  isig(nchn,1)=i
37694  isig(nchn,2)=j
37695  isig(nchn,3)=2
37696  IF(j.GT.0) sigh(nchn)=facqsb*brpos
37697  IF(j.LT.0) sigh(nchn)=facqsb*brneg
37698  270 CONTINUE
37699  ENDIF
37700 
37701  ELSEIF(isub.LE.360) THEN
37702  IF(isub.EQ.341.OR.isub.EQ.342) THEN
37703 C...l + l -> H_L++/-- or H_R++/--.
37704  kfres=kfpr(isub,1)
37705  kfrec=pycomp(kfres)
37706  CALL pywidt(kfres,sh,wdtp,wdte)
37707  hs=shr*wdtp(0)
37708  facbw=8d0*comfac/((sh-pmas(kfrec,1)**2)**2+hs**2)
37709  DO 290 i=mmin1,mmax1
37710  ia=iabs(i)
37711  IF((ia.NE.11.AND.ia.NE.13.AND.ia.NE.15).OR.kfac(1,i).EQ.0)
37712  & GOTO 290
37713  DO 280 j=mmin2,mmax2
37714  ja=iabs(j)
37715  IF((ja.NE.11.AND.ja.NE.13.AND.ja.NE.15).OR.kfac(2,j).EQ.0)
37716  & GOTO 280
37717  IF(i*j.LT.0) GOTO 280
37718  kchh=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37719  nchn=nchn+1
37720  isig(nchn,1)=i
37721  isig(nchn,2)=j
37722  isig(nchn,3)=1
37723  hi=sh*parp(181+3*((ia-11)/2)+(ja-11)/2)**2/(8d0*paru(1))
37724  hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
37725  sigh(nchn)=hi*facbw*hf
37726  280 CONTINUE
37727  290 CONTINUE
37728 
37729  ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
37730 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37731  kfres=kfpr(isub,1)
37732  kfrec=pycomp(kfres)
37733 C...Propagators: as simulated in PYOFSH and as desired
37734  hbw3=pmas(kfrec,1)*pmas(kfrec,2)/((sqm3-pmas(kfrec,1)**2)**2+
37735  & (pmas(kfrec,1)*pmas(kfrec,2))**2)
37736  CALL pywidt(kfres,sqm3,wdtp,wdte)
37737  gmmc=sqrt(sqm3)*wdtp(0)
37738  hbw3c=gmmc/((sqm3-pmas(kfrec,1)**2)**2+gmmc**2)
37739  fhcc=comfac*aem*hbw3c/hbw3
37740  DO 310 i=mmina,mmaxa
37741  ia=iabs(i)
37742  IF(ia.NE.11.AND.ia.NE.13.AND.ia.NE.15) GOTO 310
37743  sqml=pmas(ia,1)**2
37744  j=isign(kfpr(isub,2),-i)
37745  kchh=isign(2,kchg(ia,1)*isign(1,i))
37746  widsc=(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))/wdtp(0)
37747  smm1=8d0*(sh+th-sqm3)*(sh+th-2d0*sqm3-sqml-sqm4)/
37748  & (uh-sqm3)**2
37749  smm2=2d0*((2d0*sqm3-3d0*sqml)*sqm4+(sqml-2d0*sqm4)*th-
37750  & (th-sqm4)*sh)/(th-sqm4)**2
37751  smm3=2d0*((2d0*sqm3-3d0*sqm4+th)*sqml-(2d0*sqml-sqm4+th)*
37752  & sh)/(sh-sqml)**2
37753  smm12=4d0*((2d0*sqml-sqm4-2d0*sqm3+th)*sh+(th-3d0*sqm3-
37754  & 3d0*sqm4)*th+(2d0*sqm3-2d0*sqml+3d0*sqm4)*sqm3)/
37755  & ((uh-sqm3)*(th-sqm4))
37756  smm13=-4d0*((th+sqml-2d0*sqm4)*th-(sqm3+3d0*sqml-2d0*sqm4)*
37757  & sqm3+(sqm3+3d0*sqml+th)*sh-(th-sqm3+sh)**2)/
37758  & ((uh-sqm3)*(sh-sqml))
37759  smm23=-4d0*((sqml-sqm4+sqm3)*th-sqm3**2+sqm3*(sqml+sqm4)-
37760  & 3d0*sqml*sqm4-(sqml-sqm4-sqm3+th)*sh)/
37761  & ((sh-sqml)*(th-sqm4))
37762  smm=(sh/(sh-sqml))**2*(smm1+smm2+smm3+smm12+smm13+smm23)*
37763  & parp(181+3*((ia-11)/2)+(iabs(j)-11)/2)**2/(4d0*paru(1))
37764  DO 300 isde=1,2
37765  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 300
37766  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 300
37767  nchn=nchn+1
37768  isig(nchn,isde)=i
37769  isig(nchn,3-isde)=22
37770  isig(nchn,3)=0
37771  sigh(nchn)=fhcc*smm*widsc
37772  300 CONTINUE
37773  310 CONTINUE
37774 
37775  ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
37776 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37777  kfres=kfpr(isub,1)
37778  kfrec=pycomp(kfres)
37779  sqmh=pmas(kfrec,1)**2
37780  gmmh=pmas(kfrec,1)*pmas(kfrec,2)
37781 C...Propagators: H++/-- as simulated in PYOFSH and as desired
37782  hbw3=gmmh/((sqm3-sqmh)**2+gmmh**2)
37783  CALL pywidt(kfres,sqm3,wdtp,wdte)
37784  gmmh3=sqrt(sqm3)*wdtp(0)
37785  hbw3c=gmmh3/((sqm3-sqmh)**2+gmmh3**2)
37786  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
37787  CALL pywidt(kfres,sqm4,wdtp,wdte)
37788  gmmh4=sqrt(sqm4)*wdtp(0)
37789  hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
37790 C...Kinematical and coupling functions
37791  fachh=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*(th*uh-sqm3*sqm4)
37792  xwhh=(1d0-2d0*xwv)/(8d0*xwv*(1d0-xwv))
37793 C...Loop over allowed flavours
37794  DO 320 i=mmina,mmaxa
37795  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 320
37796  ei=kchg(iabs(i),1)/3d0
37797  ai=sign(1d0,ei+0.1d0)
37798  vi=ai-4d0*ei*xwv
37799  fcoi=1d0
37800  IF(iabs(i).LE.10) fcoi=faca/3d0
37801  IF(isub.EQ.349) THEN
37802  hbwz=1d0/((sh-sqmz)**2+gmmz**2)
37803  IF(iabs(i).LT.10) THEN
37804  dsighh=8d0*aem**2*(ei**2/sh2+
37805  & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
37806  & (vi**2+ai**2)*xwhh**2*hbwz)
37807  ELSE
37808  iaoff=181+3*((iabs(i)-11)/2)
37809  hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
37810  & (4d0*paru(1))
37811  dsighh=8d0*aem**2*(ei**2/sh2+
37812  & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
37813  & (vi**2+ai**2)*xwhh**2*hbwz)+
37814  & 8d0*aem*(ei*hsum/(sh*th)+
37815  & (vi+ai)*xwhh*hsum*(sh-sqmz)*hbwz/th)+
37816  & 4d0*hsum**2/th2
37817  ENDIF
37818  ELSE
37819  IF(iabs(i).LT.10) THEN
37820  dsighh=8d0*aem**2*ei**2/sh2
37821  ELSE
37822  iaoff=181+3*((iabs(i)-11)/2)
37823  hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
37824  & (4d0*paru(1))
37825  dsighh=8d0*aem**2*ei**2/sh2+8d0*aem*ei*hsum/(sh*th)+
37826  & 4d0*hsum**2/th2
37827  ENDIF
37828  ENDIF
37829  nchn=nchn+1
37830  isig(nchn,1)=i
37831  isig(nchn,2)=-i
37832  isig(nchn,3)=1
37833  sigh(nchn)=fachh*fcoi*dsighh
37834  320 CONTINUE
37835 
37836  ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
37837 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37838  kfres=kfpr(isub,1)
37839  kfrec=pycomp(kfres)
37840  sqmh=pmas(kfrec,1)**2
37841  IF(isub.EQ.351) facnor=parp(190)**8*parp(192)**2
37842  IF(isub.EQ.352) facnor=parp(191)**6*2d0*
37843  & pmas(pycomp(9900024),1)**2
37844  facww=comfac*facnor*taup*vint(2)*vint(219)
37845  facprt=1d0/((vint(204)**2-vint(215))*
37846  & (vint(209)**2-vint(216)))
37847  facpru=1d0/((vint(204)**2+2d0*vint(217))*
37848  & (vint(209)**2+2d0*vint(218)))
37849  CALL pywidt(kfres,sh,wdtp,wdte)
37850  hs=shr*wdtp(0)
37851  facbw=(1d0/paru(1))*vint(2)/((sh-sqmh)**2+hs**2)
37852  IF(abs(shr-pmas(kfrec,1)).GT.parp(48)*pmas(kfrec,2))
37853  & facbw=0d0
37854  DO 340 i=mmin1,mmax1
37855  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 340
37856  IF(isub.EQ.352.AND.iabs(i).GT.10) GOTO 340
37857  kchwi=(1-2*mod(iabs(i),2))*isign(1,i)
37858  DO 330 j=mmin2,mmax2
37859  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 330
37860  IF(isub.EQ.352.AND.iabs(j).GT.10) GOTO 330
37861  kchwj=(1-2*mod(iabs(j),2))*isign(1,j)
37862  kchh=kchwi+kchwj
37863  IF(iabs(kchh).NE.2) GOTO 330
37864  faclr=vint(180+i)*vint(180+j)
37865  hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
37866  IF(i.EQ.j.AND.iabs(i).GT.10) THEN
37867  facprp=0.5d0*(facprt+facpru)**2
37868  ELSE
37869  facprp=facprt**2
37870  ENDIF
37871  nchn=nchn+1
37872  isig(nchn,1)=i
37873  isig(nchn,2)=j
37874  isig(nchn,3)=1
37875  sigh(nchn)=faclr*facww*facprp*facbw*hf
37876  330 CONTINUE
37877  340 CONTINUE
37878 
37879  ELSEIF(isub.EQ.353) THEN
37880 C...f + fbar -> Z_R0
37881  sqmzr=pmas(pycomp(kfpr(isub,1)),1)**2
37882  CALL pywidt(kfpr(isub,1),sh,wdtp,wdte)
37883  hs=shr*wdtp(0)
37884  facbw=4d0*comfac/((sh-sqmzr)**2+hs**2)*3d0
37885  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37886  hp=(aem/(3d0*(1d0-2d0*xw)))*xwc*sh
37887  DO 350 i=mmina,mmaxa
37888  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 350
37889  IF(iabs(i).LE.8) THEN
37890  ei=kchg(iabs(i),1)/3d0
37891  ai=sign(1d0,ei+0.1d0)*(1d0-2d0*xw)
37892  vi=sign(1d0,ei+0.1d0)-4d0*ei*xw
37893  ELSE
37894  ai=-(1d0-2d0*xw)
37895  vi=-1d0+4d0*xw
37896  ENDIF
37897  hi=hp*(vi**2+ai**2)
37898  IF(iabs(i).LE.10) hi=hi*faca/3d0
37899  nchn=nchn+1
37900  isig(nchn,1)=i
37901  isig(nchn,2)=-i
37902  isig(nchn,3)=1
37903  sigh(nchn)=hi*facbw*hf
37904  350 CONTINUE
37905 
37906  ELSEIF(isub.EQ.354) THEN
37907 C...f + fbar' -> W_R+/-
37908  sqmwr=pmas(pycomp(kfpr(isub,1)),1)**2
37909  CALL pywidt(kfpr(isub,1),sh,wdtp,wdte)
37910  hs=shr*wdtp(0)
37911  facbw=4d0*comfac/((sh-sqmwr)**2+hs**2)*3d0
37912  hp=aem/(24d0*xw)*sh
37913  DO 370 i=mmin1,mmax1
37914  IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 370
37915  ia=iabs(i)
37916  DO 360 j=mmin2,mmax2
37917  IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 360
37918  ja=iabs(j)
37919  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 360
37920  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37921  & GOTO 360
37922  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37923  hi=hp*2d0
37924  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
37925  nchn=nchn+1
37926  isig(nchn,1)=i
37927  isig(nchn,2)=j
37928  isig(nchn,3)=1
37929  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
37930  sigh(nchn)=hi*facbw*hf
37931  360 CONTINUE
37932  370 CONTINUE
37933  ENDIF
37934 
37935  ELSEIF(isub.LE.400) THEN
37936  IF(isub.EQ.391) THEN
37937 C...f + fbar -> G*.
37938  kfgstr=kfpr(isub,1)
37939  kcgstr=pycomp(kfgstr)
37940  CALL pywidt(kfgstr,sh,wdtp,wdte)
37941  hs=shr*wdtp(0)
37942  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37943  facg=comfac*parp(50)**2/(16d0*paru(1))*sh*hf/
37944  & ((sh-pmas(kcgstr,1)**2)**2+hs**2)
37945 C...Modify cross section in wings of peak.
37946  facg = facg * sh**2 / pmas(kcgstr,1)**4
37947  DO 380 i=mmina,mmaxa
37948  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 380
37949  hi=1d0
37950  IF(iabs(i).LE.10) hi=hi*faca/3d0
37951  nchn=nchn+1
37952  isig(nchn,1)=i
37953  isig(nchn,2)=-i
37954  isig(nchn,3)=1
37955  sigh(nchn)=facg*hi
37956  380 CONTINUE
37957 
37958  ELSEIF(isub.EQ.392) THEN
37959 C...g + g -> G*.
37960  kfgstr=kfpr(isub,1)
37961  kcgstr=pycomp(kfgstr)
37962  CALL pywidt(kfgstr,sh,wdtp,wdte)
37963  hs=shr*wdtp(0)
37964  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37965  facg=comfac*parp(50)**2/(32d0*paru(1))*sh*hf/
37966  & ((sh-pmas(kcgstr,1)**2)**2+hs**2)
37967 C...Modify cross section in wings of peak.
37968  facg = facg * sh**2 / pmas(kcgstr,1)**4
37969  IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 390
37970  nchn=nchn+1
37971  isig(nchn,1)=21
37972  isig(nchn,2)=21
37973  isig(nchn,3)=1
37974  sigh(nchn)=facg
37975  390 CONTINUE
37976 
37977  ELSEIF(isub.EQ.393) THEN
37978 C...q + qbar -> g + G*.
37979  kfgstr=kfpr(isub,2)
37980  kcgstr=pycomp(kfgstr)
37981  facg=comfac*parp(50)**2*as*sh/(72d0*paru(1)*sqm4)*
37982  & (4d0*(th2+uh2)/sh2+9d0*(th+uh)/sh+(th2/uh+uh2/th)/sh+
37983  & 3d0*(4d0+th/uh+uh/th)+4d0*(sh/uh+sh/th)+
37984  & 2d0*sh2/(th*uh))
37985 C...Propagators: as simulated in PYOFSH and as desired
37986  gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
37987  hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
37988  CALL pywidt(kfgstr,sqm4,wdtp,wdte)
37989  hs=sqrt(sqm4)*wdtp(0)
37990  hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37991  hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
37992  facg=facg*hbw4c/hbw4
37993  DO 400 i=mmina,mmaxa
37994  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37995  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 400
37996  nchn=nchn+1
37997  isig(nchn,1)=i
37998  isig(nchn,2)=-i
37999  isig(nchn,3)=1
38000  sigh(nchn)=facg
38001  400 CONTINUE
38002 
38003  ELSEIF(isub.EQ.394) THEN
38004 C...q + g -> q + G*.
38005  kfgstr=kfpr(isub,2)
38006  kcgstr=pycomp(kfgstr)
38007  facg=-comfac*parp(50)**2*as*sh/(192d0*paru(1)*sqm4)*
38008  & (4d0*(sh2+uh2)/(th*sh)+9d0*(sh+uh)/sh+sh/uh+uh2/sh2+
38009  & 3d0*th*(4d0+sh/uh+uh/sh)/sh+4d0*th2*(1d0/uh+1d0/sh)/sh+
38010  & 2d0*th2*th/(uh*sh2))
38011 C...Propagators: as simulated in PYOFSH and as desired
38012  gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
38013  hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
38014  CALL pywidt(kfgstr,sqm4,wdtp,wdte)
38015  hs=sqrt(sqm4)*wdtp(0)
38016  hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38017  hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
38018  facg=facg*hbw4c/hbw4
38019  DO 420 i=mmina,mmaxa
38020  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 420
38021  DO 410 isde=1,2
38022  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 410
38023  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 410
38024  nchn=nchn+1
38025  isig(nchn,isde)=i
38026  isig(nchn,3-isde)=21
38027  isig(nchn,3)=1
38028  sigh(nchn)=facg
38029  410 CONTINUE
38030  420 CONTINUE
38031 
38032  ELSEIF(isub.EQ.395) THEN
38033 C...g + g -> g + G*.
38034  kfgstr=kfpr(isub,2)
38035  kcgstr=pycomp(kfgstr)
38036  facg=comfac*3d0*parp(50)**2*as*sh/(32d0*paru(1)*sqm4)*
38037  & ((th2+th*uh+uh2)**2/(sh2*th*uh)+2d0*(th2/uh+uh2/th)/sh+
38038  & 3d0*(th/uh+uh/th)+2d0*(sh/uh+sh/th)+sh2/(th*uh))
38039 C...Propagators: as simulated in PYOFSH and as desired
38040  gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
38041  hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
38042  CALL pywidt(kfgstr,sqm4,wdtp,wdte)
38043  hs=sqrt(sqm4)*wdtp(0)
38044  hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38045  hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
38046  facg=facg*hbw4c/hbw4
38047  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
38048  nchn=nchn+1
38049  isig(nchn,1)=21
38050  isig(nchn,2)=21
38051  isig(nchn,3)=1
38052  sigh(nchn)=facg
38053  ENDIF
38054  ENDIF
38055  ENDIF
38056 
38057  RETURN
38058  END
38059 
38060 C*********************************************************************
38061 
38062 C...PYPDFU
38063 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38064 C...parton distributions according to a few different parametrizations.
38065 C...Note that what is coded is x times the probability distribution,
38066 C...i.e. xq(x,Q2) etc.
38067 
38068  SUBROUTINE pypdfu(KF,X,Q2,XPQ)
38069 
38070 C...Double precision and integer declarations.
38071  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38072  IMPLICIT INTEGER(I-N)
38073  INTEGER PYK,PYCHGE,PYCOMP
38074 C...Commonblocks.
38075  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38076  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38077  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38078  common/pypars/mstp(200),parp(200),msti(200),pari(200)
38079  common/pyint1/mint(400),vint(400)
38080  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
38081  &xpdir(-6:6)
38082  common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
38083  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
38084  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
38085  & xmi(2,240),pt2mi(240),imisep(0:240)
38086  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint8/,
38087  &/pyint9/,/pyintm/
38088 C...Local arrays.
38089  dimension xpq(-25:25),xpel(-25:25),xpga(-6:6),vxpga(-6:6),
38090  &xppi(-6:6),xppr(-6:6),xpval(-6:6),ppar(6,2)
38091  SAVE ppar
38092 
38093 C...Interface to PDFLIB.
38094  common/w50513/xmin,xmax,q2min,q2max
38095  SAVE /w50513/
38096  DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38097  &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38098  CHARACTER*20 PARM(20)
38099  DATA VALUE/20*0d0/,parm/20*' '/
38100 
38101 C...Data related to Schuler-Sjostrand photon distributions.
38102  DATA alamga/0.2d0/, pmcga/1.3d0/, pmbga/4.6d0/
38103 
38104 C...Valence PDF momentum integral parametrizations PER PARTON!
38105  DATA (ppar(1,ipar),ipar=1,2) /0.385d0,1.60d0/
38106  DATA (ppar(2,ipar),ipar=1,2) /0.480d0,1.56d0/
38107  pavg(ifl,q2)=ppar(ifl,1)/(1d0+ppar(ifl,2)*
38108  &log(log(max(q2,1d0)/0.04d0)))
38109 
38110 C...Reset parton distributions.
38111  mint(92)=0
38112  DO 100 kfl=-25,25
38113  xpq(kfl)=0d0
38114  100 CONTINUE
38115  DO 110 kfl=-6,6
38116  xpval(kfl)=0d0
38117  110 CONTINUE
38118 
38119 C...Check x and particle species.
38120  IF(x.LE.0d0.OR.x.GE.1d0) THEN
38121  WRITE(mstu(11),5000) x
38122  GOTO 9999
38123  ENDIF
38124  kfa=iabs(kf)
38125  IF(kfa.NE.11.AND.kfa.NE.13.AND.kfa.NE.15.AND.kfa.NE.22.AND.
38126  &kfa.NE.211.AND.kfa.NE.2112.AND.kfa.NE.2212.AND.kfa.NE.3122.AND.
38127  &kfa.NE.3112.AND.kfa.NE.3212.AND.kfa.NE.3222.AND.kfa.NE.3312.AND.
38128  &kfa.NE.3322.AND.kfa.NE.3334.AND.kfa.NE.111.AND.kfa.NE.321.AND.
38129  &kfa.NE.310.AND.kfa.NE.130) THEN
38130  WRITE(mstu(11),5100) kf
38131  GOTO 9999
38132  ENDIF
38133 
38134 C...Electron (or muon or tau) parton distribution call.
38135  IF(kfa.EQ.11.OR.kfa.EQ.13.OR.kfa.EQ.15) THEN
38136  CALL pypdel(kfa,x,q2,xpel)
38137  DO 120 kfl=-25,25
38138  xpq(kfl)=xpel(kfl)
38139  120 CONTINUE
38140 
38141 C...Photon parton distribution call (VDM+anomalous).
38142  ELSEIF(kfa.EQ.22.AND.mint(109).LE.1) THEN
38143  IF(mstp(56).EQ.1.AND.mstp(55).EQ.1) THEN
38144  CALL pypdga(x,q2,xpga)
38145  DO 130 kfl=-6,6
38146  xpq(kfl)=xpga(kfl)
38147  130 CONTINUE
38148  xpvu=4d0*(xpq(2)-xpq(1))/3d0
38149  xpval(1)=xpvu/4d0
38150  xpval(2)=xpvu
38151  xpval(3)=min(xpq(3),xpvu/4d0)
38152  xpval(4)=min(xpq(4),xpvu)
38153  xpval(5)=min(xpq(5),xpvu/4d0)
38154  xpval(-1)=xpval(1)
38155  xpval(-2)=xpval(2)
38156  xpval(-3)=xpval(3)
38157  xpval(-4)=xpval(4)
38158  xpval(-5)=xpval(5)
38159  ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.5.AND.mstp(55).LE.8) THEN
38160  q2mx=q2
38161  p2mx=0.36d0
38162  IF(mstp(55).GE.7) p2mx=4.0d0
38163  IF(mstp(57).EQ.0) q2mx=p2mx
38164  p2=0d0
38165  IF(vint(120).LT.0d0) p2=vint(120)**2
38166  CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gam,xpga)
38167  DO 140 kfl=-6,6
38168  xpq(kfl)=xpga(kfl)
38169  xpval(kfl)=vxpdgm(kfl)
38170  140 CONTINUE
38171  vint(231)=p2mx
38172  ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.9.AND.mstp(55).LE.12) THEN
38173  q2mx=q2
38174  p2mx=0.36d0
38175  IF(mstp(55).GE.11) p2mx=4.0d0
38176  IF(mstp(57).EQ.0) q2mx=p2mx
38177  p2=0d0
38178  IF(vint(120).LT.0d0) p2=vint(120)**2
38179  CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gam,xpga)
38180  DO 150 kfl=-6,6
38181  xpq(kfl)=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
38182  xpval(kfl)=vxpvmd(kfl)+vxpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
38183  150 CONTINUE
38184  vint(231)=p2mx
38185  ELSEIF(mstp(56).EQ.2) THEN
38186 C...Call PDFLIB parton distributions.
38187  parm(1)='NPTYPE'
38188  value(1)=3
38189  parm(2)='NGROUP'
38190  value(2)=mstp(55)/1000
38191  parm(3)='NSET'
38192  value(3)=mod(mstp(55),1000)
38193  IF(mint(93).NE.3000000+mstp(55)) THEN
38194  CALL pdfset(parm,VALUE)
38195  mint(93)=3000000+mstp(55)
38196  ENDIF
38197  xx=x
38198  qq2=max(0d0,q2min,q2)
38199  IF(mstp(57).EQ.0) qq2=q2min
38200  p2=0d0
38201  IF(vint(120).LT.0d0) p2=vint(120)**2
38202  ip2=mstp(60)
38203  IF(mstp(55).EQ.5004) THEN
38204  IF(5d0*p2.LT.qq2.AND.
38205  & qq2.GT.0.6d0.AND.qq2.LT.5d4.AND.
38206  & p2.GE.0d0.AND.p2.LT.10d0.AND.
38207  & xx.GT.1d-4.AND.xx.LT.1d0) THEN
38208  CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
38209  & bot,top,glu)
38210  ELSE
38211  upv=0d0
38212  dnv=0d0
38213  usea=0d0
38214  dsea=0d0
38215  str=0d0
38216  chm=0d0
38217  bot=0d0
38218  top=0d0
38219  glu=0d0
38220  ENDIF
38221  ELSE
38222  IF(p2.LT.qq2) THEN
38223  CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
38224  & bot,top,glu)
38225  ELSE
38226  upv=0d0
38227  dnv=0d0
38228  usea=0d0
38229  dsea=0d0
38230  str=0d0
38231  chm=0d0
38232  bot=0d0
38233  top=0d0
38234  glu=0d0
38235  ENDIF
38236  ENDIF
38237  vint(231)=q2min
38238  xpq(0)=glu
38239  xpq(1)=dnv
38240  xpq(-1)=dnv
38241  xpq(2)=upv
38242  xpq(-2)=upv
38243  xpq(3)=str
38244  xpq(-3)=str
38245  xpq(4)=chm
38246  xpq(-4)=chm
38247  xpq(5)=bot
38248  xpq(-5)=bot
38249  xpq(6)=top
38250  xpq(-6)=top
38251  xpvu=4d0*(xpq(2)-xpq(1))/3d0
38252  xpval(1)=xpvu/4d0
38253  xpval(2)=xpvu
38254  xpval(3)=min(xpq(3),xpvu/4d0)
38255  xpval(4)=min(xpq(4),xpvu)
38256  xpval(5)=min(xpq(5),xpvu/4d0)
38257  xpval(-1)=xpval(1)
38258  xpval(-2)=xpval(2)
38259  xpval(-3)=xpval(3)
38260  xpval(-4)=xpval(4)
38261  xpval(-5)=xpval(5)
38262  ELSE
38263  WRITE(mstu(11),5200) kf,mstp(56),mstp(55)
38264  ENDIF
38265 
38266 C...Pion/gammaVDM parton distribution call.
38267  ELSEIF(kfa.EQ.211.OR.kfa.EQ.111.OR.kfa.EQ.321.OR.kfa.EQ.130.OR.
38268  &kfa.EQ.310.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
38269  IF(kfa.EQ.22.AND.mstp(56).EQ.1.AND.mstp(55).GE.5.AND.
38270  & mstp(55).LE.12) THEN
38271  iset=1+mod(mstp(55)-1,4)
38272  q2mx=q2
38273  p2mx=0.36d0
38274  IF(iset.GE.3) p2mx=4.0d0
38275  IF(mstp(57).EQ.0) q2mx=p2mx
38276  p2=0d0
38277  IF(vint(120).LT.0d0) p2=vint(120)**2
38278  CALL pyggam(iset,x,q2mx,p2,mstp(60),f2gam,xpga)
38279  DO 160 kfl=-6,6
38280  xpq(kfl)=xpvmd(kfl)
38281  xpval(kfl)=vxpvmd(kfl)
38282  160 CONTINUE
38283  vint(231)=p2mx
38284  ELSEIF(mstp(54).EQ.1.AND.mstp(53).GE.1.AND.mstp(53).LE.3) THEN
38285  CALL pypdpi(x,q2,xppi)
38286  DO 170 kfl=-6,6
38287  xpq(kfl)=xppi(kfl)
38288  170 CONTINUE
38289  xpval(2)=xpq(2)-xpq(-2)
38290  xpval(-1)=xpq(-1)-xpq(1)
38291  ELSEIF(mstp(54).EQ.2) THEN
38292 C...Call PDFLIB parton distributions.
38293  parm(1)='NPTYPE'
38294  value(1)=2
38295  parm(2)='NGROUP'
38296  value(2)=mstp(53)/1000
38297  parm(3)='NSET'
38298  value(3)=mod(mstp(53),1000)
38299  IF(mint(93).NE.2000000+mstp(53)) THEN
38300  CALL pdfset(parm,VALUE)
38301  mint(93)=2000000+mstp(53)
38302  ENDIF
38303  xx=x
38304  qq=sqrt(max(0d0,q2min,q2))
38305  IF(mstp(57).EQ.0) qq=sqrt(q2min)
38306  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
38307  vint(231)=q2min
38308  xpq(0)=glu
38309  xpq(1)=dsea
38310  xpq(-1)=upv+dsea
38311  xpq(2)=upv+usea
38312  xpq(-2)=usea
38313  xpq(3)=str
38314  xpq(-3)=str
38315  xpq(4)=chm
38316  xpq(-4)=chm
38317  xpq(5)=bot
38318  xpq(-5)=bot
38319  xpq(6)=top
38320  xpq(-6)=top
38321  xpval(2)=upv
38322  xpval(-1)=upv
38323  ELSE
38324  WRITE(mstu(11),5200) kf,mstp(54),mstp(53)
38325  ENDIF
38326 
38327 C...Anomalous photon parton distribution call.
38328  ELSEIF(kfa.EQ.22.AND.mint(109).EQ.3) THEN
38329  q2mx=q2
38330  p2mx=parp(15)**2
38331  IF(mstp(56).EQ.1.AND.mstp(55).LE.8) THEN
38332  IF(mstp(55).EQ.5.OR.mstp(55).EQ.6) p2mx=0.36d0
38333  IF(mstp(55).EQ.7.OR.mstp(55).EQ.8) p2mx=4.0d0
38334  IF(mstp(57).EQ.0) q2mx=p2mx
38335  p2=0d0
38336  IF(vint(120).LT.0d0) p2=vint(120)**2
38337  CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gm,xpga)
38338  DO 180 kfl=-6,6
38339  xpq(kfl)=xpanl(kfl)+xpanh(kfl)
38340  xpval(kfl)=vxpanl(kfl)+vxpanh(kfl)
38341  180 CONTINUE
38342  vint(231)=p2mx
38343  ELSEIF(mstp(56).EQ.1) THEN
38344  IF(mstp(55).EQ.9.OR.mstp(55).EQ.10) p2mx=0.36d0
38345  IF(mstp(55).EQ.11.OR.mstp(55).EQ.12) p2mx=4.0d0
38346  IF(mstp(57).EQ.0) q2mx=p2mx
38347  p2=0d0
38348  IF(vint(120).LT.0d0) p2=vint(120)**2
38349  CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gm,xpga)
38350  DO 190 kfl=-6,6
38351  xpq(kfl)=max(0d0,xpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
38352  xpval(kfl)=max(0d0,vxpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
38353  190 CONTINUE
38354  vint(231)=p2mx
38355  ELSEIF(mstp(56).EQ.2) THEN
38356  IF(mstp(57).EQ.0) q2mx=p2mx
38357  CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)
38358  DO 200 kfl=-6,6
38359  xpq(kfl)=xpga(kfl)
38360  xpval(kfl)=vxpga(kfl)
38361  200 CONTINUE
38362  vint(231)=p2mx
38363  ELSEIF(mstp(55).GE.1.AND.mstp(55).LE.5) THEN
38364  IF(mstp(57).EQ.0) q2mx=p2mx
38365  CALL pygvmd(0,mstp(55),x,q2mx,p2mx,parp(1),xpga,vxpga)
38366  DO 210 kfl=-6,6
38367  xpq(kfl)=xpga(kfl)
38368  xpval(kfl)=vxpga(kfl)
38369  210 CONTINUE
38370  vint(231)=p2mx
38371  ELSE
38372  220 rkf=11d0*pyr(0)
38373  kfr=1
38374  IF(rkf.GT.1d0) kfr=2
38375  IF(rkf.GT.5d0) kfr=3
38376  IF(rkf.GT.6d0) kfr=4
38377  IF(rkf.GT.10d0) kfr=5
38378  IF(kfr.EQ.4.AND.q2.LT.pmcga**2) GOTO 220
38379  IF(kfr.EQ.5.AND.q2.LT.pmbga**2) GOTO 220
38380  IF(mstp(57).EQ.0) q2mx=p2mx
38381  CALL pygvmd(0,kfr,x,q2mx,p2mx,parp(1),xpga,vxpga)
38382  DO 230 kfl=-6,6
38383  xpq(kfl)=xpga(kfl)
38384  xpval(kfl)=vxpga(kfl)
38385  230 CONTINUE
38386  vint(231)=p2mx
38387  ENDIF
38388 
38389 C...Proton parton distribution call.
38390  ELSE
38391  IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.20) THEN
38392  CALL pypdpr(x,q2,xppr)
38393  DO 240 kfl=-6,6
38394  xpq(kfl)=xppr(kfl)
38395  240 CONTINUE
38396 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38397  xpval(1)=max(0d0,xpq(1)-xpq(-1))
38398  xpval(2)=max(0d0,xpq(2)-xpq(-2))
38399  ELSEIF(mstp(52).EQ.2) THEN
38400 C...Call PDFLIB parton distributions.
38401  parm(1)='NPTYPE'
38402  value(1)=1
38403  parm(2)='NGROUP'
38404  value(2)=mstp(51)/1000
38405  parm(3)='NSET'
38406  value(3)=mod(mstp(51),1000)
38407  IF(mint(93).NE.1000000+mstp(51)) THEN
38408  CALL pdfset(parm,VALUE)
38409  mint(93)=1000000+mstp(51)
38410  ENDIF
38411  xx=x
38412  qq=sqrt(max(0d0,q2min,q2))
38413  IF(mstp(57).EQ.0) qq=sqrt(q2min)
38414  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
38415  vint(231)=q2min
38416  xpq(0)=glu
38417  xpq(1)=dnv+dsea
38418  xpq(-1)=dsea
38419  xpq(2)=upv+usea
38420  xpq(-2)=usea
38421  xpq(3)=str
38422  xpq(-3)=str
38423  xpq(4)=chm
38424  xpq(-4)=chm
38425  xpq(5)=bot
38426  xpq(-5)=bot
38427  xpq(6)=top
38428  xpq(-6)=top
38429  xpval(1)=dnv
38430  xpval(2)=upv
38431  ELSE
38432  WRITE(mstu(11),5200) kf,mstp(52),mstp(51)
38433  ENDIF
38434  ENDIF
38435 
38436 C...Isospin average for pi0/gammaVDM.
38437  IF(kfa.EQ.111.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
38438  IF(kfa.EQ.22.AND.mstp(55).GE.5.AND.mstp(55).LE.12) THEN
38439  xpv=xpq(2)-xpq(1)
38440  xpq(2)=xpq(1)
38441  xpq(-2)=xpq(-1)
38442  ELSE
38443  xps=0.5d0*(xpq(1)+xpq(-2))
38444  xpv=0.5d0*(xpq(2)+xpq(-1))-xps
38445  xpq(2)=xps
38446  xpq(-1)=xps
38447  ENDIF
38448  xpvl=0.5d0*(xpval(1)+xpval(2)+xpval(-1)+xpval(-2))+
38449  & xpval(3)+xpval(4)+xpval(5)
38450  DO 250 kfl=-6,6
38451  xpval(kfl)=0d0
38452  250 CONTINUE
38453  IF(kfa.EQ.22.AND.mint(105).LE.223) THEN
38454  xpq(1)=xpq(1)+0.2d0*xpv
38455  xpq(2)=xpq(2)+0.8d0*xpv
38456  xpval(1)=0.2d0*xpvl
38457  xpval(2)=0.8d0*xpvl
38458  ELSEIF(kfa.EQ.22.AND.mint(105).EQ.333) THEN
38459  xpq(3)=xpq(3)+xpv
38460  xpval(3)=xpvl
38461  ELSEIF(kfa.EQ.22.AND.mint(105).EQ.443) THEN
38462  xpq(4)=xpq(4)+xpv
38463  xpval(4)=xpvl
38464  IF(mstp(55).GE.9) THEN
38465  DO 260 kfl=-6,6
38466  xpq(kfl)=0d0
38467  260 CONTINUE
38468  ENDIF
38469  ELSE
38470  xpq(1)=xpq(1)+0.5d0*xpv
38471  xpq(2)=xpq(2)+0.5d0*xpv
38472  xpval(1)=0.5d0*xpvl
38473  xpval(2)=0.5d0*xpvl
38474  ENDIF
38475  DO 270 kfl=1,6
38476  xpq(-kfl)=xpq(kfl)
38477  xpval(-kfl)=xpval(kfl)
38478  270 CONTINUE
38479 
38480 C...Rescale for gammaVDM by effective gamma -> rho coupling.
38481 C+++Do not rescale?
38482  IF(kfa.EQ.22.AND.mint(109).EQ.2.AND..NOT.(mstp(56).EQ.1
38483  & .AND.mstp(55).GE.5.AND.mstp(55).LE.12)) THEN
38484  DO 280 kfl=-6,6
38485  xpq(kfl)=vint(281)*xpq(kfl)
38486  xpval(kfl)=vint(281)*xpval(kfl)
38487  280 CONTINUE
38488  vint(232)=vint(281)*xpv
38489  ENDIF
38490 
38491 C...Simple recipes for kaons.
38492  ELSEIF(kfa.EQ.321) THEN
38493  xpq(-3)=xpq(-3)+xpq(-1)-xpq(1)
38494  xpq(-1)=xpq(1)
38495  xpval(-3)=xpval(-1)
38496  xpval(-1)=0d0
38497  ELSEIF(kfa.EQ.130.OR.kfa.EQ.310) THEN
38498  xps=0.5d0*(xpq(1)+xpq(-2))
38499  xpv=0.5d0*(xpq(2)+xpq(-1))-xps
38500  xpq(2)=xps
38501  xpq(-1)=xps
38502  xpq(1)=xpq(1)+0.5d0*xpv
38503  xpq(-1)=xpq(-1)+0.5d0*xpv
38504  xpq(3)=xpq(3)+0.5d0*xpv
38505  xpq(-3)=xpq(-3)+0.5d0*xpv
38506  xpv=0.5d0*(xpval(2)+xpval(-1))
38507  xpval(2)=0d0
38508  xpval(-1)=0d0
38509  xpval(1)=0.5d0*xpv
38510  xpval(-1)=0.5d0*xpv
38511  xpval(3)=0.5d0*xpv
38512  xpval(-3)=0.5d0*xpv
38513 
38514 C...Isospin conjugation for neutron.
38515  ELSEIF(kfa.EQ.2112) THEN
38516  xpsv=xpq(1)
38517  xpq(1)=xpq(2)
38518  xpq(2)=xpsv
38519  xpsv=xpq(-1)
38520  xpq(-1)=xpq(-2)
38521  xpq(-2)=xpsv
38522  xpsv=xpval(1)
38523  xpval(1)=xpval(2)
38524  xpval(2)=xpsv
38525 
38526 C...Simple recipes for hyperon (average valence parton distribution).
38527  ELSEIF(kfa.EQ.3122.OR.kfa.EQ.3112.OR.kfa.EQ.3212.OR.kfa.EQ.3222
38528  & .OR.kfa.EQ.3312.OR.kfa.EQ.3322.OR.kfa.EQ.3334) THEN
38529  xpv=(xpq(1)+xpq(2)-xpq(-1)-xpq(-2))/3d0
38530  xps=0.5d0*(xpq(-1)+xpq(-2))
38531  xpq(1)=xps
38532  xpq(2)=xps
38533  xpq(-1)=xps
38534  xpq(-2)=xps
38535  xpq(kfa/1000)=xpq(kfa/1000)+xpv
38536  xpq(mod(kfa/100,10))=xpq(mod(kfa/100,10))+xpv
38537  xpq(mod(kfa/10,10))=xpq(mod(kfa/10,10))+xpv
38538  xpv=(xpval(1)+xpval(2))/3d0
38539  xpval(1)=0d0
38540  xpval(2)=0d0
38541  xpval(kfa/1000)=xpval(kfa/1000)+xpv
38542  xpval(mod(kfa/100,10))=xpval(mod(kfa/100,10))+xpv
38543  xpval(mod(kfa/10,10))=xpval(mod(kfa/10,10))+xpv
38544  ENDIF
38545 
38546 C...Charge conjugation for antiparticle.
38547  IF(kf.LT.0) THEN
38548  DO 290 kfl=1,25
38549  IF(kfl.EQ.21.OR.kfl.EQ.22.OR.kfl.EQ.23.OR.kfl.EQ.25) GOTO 290
38550  xpsv=xpq(kfl)
38551  xpq(kfl)=xpq(-kfl)
38552  xpq(-kfl)=xpsv
38553  290 CONTINUE
38554  DO 300 kfl=1,6
38555  xpsv=xpval(kfl)
38556  xpval(kfl)=xpval(-kfl)
38557  xpval(-kfl)=xpsv
38558  300 CONTINUE
38559  ENDIF
38560 
38561 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38562 C...Set side.
38563  js=mint(30)
38564 C...Only reshape PDFs for the non-first interactions;
38565 C...But need valence/sea separation already from first interaction.
38566  IF ((js.EQ.1.OR.js.EQ.2).AND.mint(35).GE.2) THEN
38567  kfvsel=kfival(js,1)
38568 C...If valence quark kicked out of pi0 or gamma then that decides
38569 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38570  IF(kfvsel.NE.0.AND.(kfa.EQ.111.OR.kfa.EQ.22)) THEN
38571  xpvl=0d0
38572  DO 310 kfl=1,6
38573  xpvl=xpvl+xpval(kfl)
38574  xpq(kfl)=max(0d0,xpq(kfl)-xpval(kfl))
38575  xpval(kfl)=0d0
38576  310 CONTINUE
38577  xpq(iabs(kfvsel))=xpq(iabs(kfvsel))+xpvl
38578  xpval(iabs(kfvsel))=xpvl
38579  DO 320 kfl=1,6
38580  xpq(-kfl)=xpq(kfl)
38581  xpval(-kfl)=xpval(kfl)
38582  320 CONTINUE
38583 
38584 C...If valence quark kicked out of K0S or K0S then that decides whether
38585 C...we should consider state as d sbar or s dbar.
38586  ELSEIF(kfvsel.NE.0.AND.(kfa.EQ.130.OR.kfa.EQ.310)) THEN
38587  kfs=1
38588  IF(kfvsel.EQ.-1.OR.kfvsel.EQ.3) kfs=-1
38589  xpq(kfs)=xpq(kfs)+xpval(-kfs)
38590  xpval(kfs)=xpval(kfs)+xpval(-kfs)
38591  xpq(-kfs)=max(0d0,xpq(-kfs)-xpval(-kfs))
38592  xpval(-kfs)=0d0
38593  kfs=-3*kfs
38594  xpq(kfs)=xpq(kfs)+xpval(-kfs)
38595  xpval(kfs)=xpval(kfs)+xpval(-kfs)
38596  xpq(-kfs)=max(0d0,xpq(-kfs)-xpval(-kfs))
38597  xpval(-kfs)=0d0
38598  ENDIF
38599 
38600 C...XPQ distributions are nominal for a (signed) beam particle
38601 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38602  cmpfac=1d0
38603  nresc=0
38604  345 nresc=nresc+1
38605  pvctot(js,-1)=0d0
38606  pvctot(js, 0)=0d0
38607  pvctot(js, 1)=0d0
38608  DO 350 ifl=-6,6
38609  IF(ifl.EQ.0) GOTO 350
38610 
38611 C...Count up number of original IFL valence quarks.
38612  ivorg=0
38613  IF(kfival(js,1).EQ.ifl) ivorg=ivorg+1
38614  IF(kfival(js,2).EQ.ifl) ivorg=ivorg+1
38615  IF(kfival(js,3).EQ.ifl) ivorg=ivorg+1
38616 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38617 C...bookkeep as if d dbar (for total momentum sum in valence sector).
38618  IF(kfival(js,1).EQ.0.AND.iabs(ifl).EQ.1) ivorg=1
38619 C...Count down number of remaining IFL valence quarks. Skip current
38620 C...interaction initiator.
38621  ivrem=ivorg
38622  DO 330 i1=1,nmi(js)
38623  IF (i1.EQ.mint(36)) GOTO 330
38624  IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
38625  & ivrem=ivrem-1
38626  330 CONTINUE
38627 
38628 C...Separate out original VALENCE and SEA content.
38629  val=xpval(ifl)
38630  sea=max(0d0,xpq(ifl)-val)
38631  xpsvc(ifl,0)=val
38632  xpsvc(ifl,-1)=sea
38633 
38634 C...Rescale valence content if changed.
38635  IF (ivorg.NE.0.AND.ivrem.NE.ivorg) xpsvc(ifl,0)=
38636  & (val*ivrem)/ivorg
38637 
38638 C...Momentum integrals of original and removed valence quarks.
38639  IF(ivorg.NE.0) THEN
38640 C...For p/n/pbar/nbar beams can split into d_val and u_val.
38641 C...Isospin conjugation for neutrons
38642  IF(kfa.EQ.2212.OR.kfa.EQ.2112) THEN
38643  iaflp=iabs(ifl)
38644  IF (kfa.EQ.2112) iaflp=3-iaflp
38645  vpavg=pavg(iaflp,q2)
38646 C...For other baryons average d_val and u_val, like for PDFs.
38647  ELSEIF(kfa.GT.1000) THEN
38648  vpavg=(pavg(1,q2)+2d0*pavg(2,q2))/3d0
38649 C...For mesons and photon average d_val and u_val and scale by 3/2.
38650 C...Very crude, especially for photon.
38651  ELSE
38652  vpavg=0.5d0*(pavg(1,q2)+2d0*pavg(2,q2))
38653  ENDIF
38654  pvctot(js,-1)=pvctot(js,-1)+ivorg*vpavg
38655  pvctot(js, 0)=pvctot(js, 0)+(ivorg-ivrem)*vpavg
38656  ENDIF
38657 
38658 C...Now add companions (at X with partner having been at Z=XASSOC).
38659 C...NOTE: due to the assumed simple x scaling, the partner was at what
38660 C...corresponds to a higher Z than XASSOC, if there were intermediate
38661 C...scatterings. Nothing done about that for the moment.
38662  DO 340 ivc=1,nvc(js,ifl)
38663 C...Skip companions that have been kicked out
38664  IF (xassoc(js,ifl,ivc).LE.0d0) THEN
38665  xpsvc(ifl,ivc)=0d0
38666  GOTO 340
38667  ELSE
38668 C...Momentum fraction of the partner quark.
38669 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38670  xs=xassoc(js,ifl,ivc)
38671  xrem=vint(142+js)
38672  ys=xs/(xrem+xs)
38673 C...Momentum fraction of the companion quark.
38674 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38675  y=x*(1d0-ys)
38676  xpsvc(ifl,ivc)=pyfcmp(y/cmpfac,ys/cmpfac,mstp(87))
38677 C...Add to momentum sum, with rescaling compensation factor.
38678  xcfac=(xrem+xs)/xrem*cmpfac
38679  pvctot(js,1)=pvctot(js,1)+xcfac*pypcmp(ys/cmpfac,mstp(87))
38680  ENDIF
38681  340 CONTINUE
38682  350 CONTINUE
38683 
38684 C...Wait until all flavours treated, then rescale seas and gluon.
38685  xpsvc(0,-1)=xpq(0)
38686  xpsvc(0,0)=0d0
38687  rsfac=1d0+(pvctot(js,0)-pvctot(js,1))/(1d0-pvctot(js,-1))
38688  IF (rsfac.LE.0d0) THEN
38689 C...First calculate factor needed to exactly restore pz cons.
38690  IF (nresc.EQ.1) cmpfac =
38691  & (1d0-(pvctot(js,-1)-pvctot(js,0)))/pvctot(js,1)
38692 C...Add a bit of headroom
38693  cmpfac=0.99*cmpfac
38694 C...Try a few times if more headroom is needed, then print error message.
38695  IF (nresc.LE.10) GOTO 345
38696  CALL pyerrm(15,
38697  & '(PYPDFU:) Negative reshaping factor persists!')
38698  WRITE(mstu(11),5300) (pvctot(js,itmp),itmp=-1,1), rsfac
38699  rsfac=0d0
38700  ENDIF
38701  DO 370 ifl=-6,6
38702  xpsvc(ifl,-1)=rsfac*xpsvc(ifl,-1)
38703 C...Also store resulting distributions in XPQ
38704  xpq(ifl)=0d0
38705  DO 360 isvc=-1,nvc(js,ifl)
38706  xpq(ifl)=xpq(ifl)+xpsvc(ifl,isvc)
38707  360 CONTINUE
38708  370 CONTINUE
38709 C...Save companion reweighting factor for PYPTIS.
38710  vint(140)=cmpfac
38711  ENDIF
38712 
38713 
38714 C...Allow gluon also in position 21.
38715  xpq(21)=xpq(0)
38716 
38717 C...Check positivity and reset above maximum allowed flavour.
38718  DO 380 kfl=-25,25
38719  xpq(kfl)=max(0d0,xpq(kfl))
38720  IF(iabs(kfl).GT.mstp(58).AND.iabs(kfl).LE.8) xpq(kfl)=0d0
38721  380 CONTINUE
38722 
38723 C...Formats for error printouts.
38724  5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
38725  5100 FORMAT(' Error: illegal particle code for parton distribution;',
38726  &' KF =',i5)
38727  5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38728  &3i5)
38729  5300 FORMAT(' Original valence momentum fraction : ',f6.3/
38730  & ' Removed valence momentum fraction : ',f6.3/
38731  & ' Added companion momentum fraction : ',f6.3/
38732  & ' Resulting rescale factor : ',f6.3)
38733 
38734 C...Reset side pointer and return
38735  9999 mint(30)=0
38736 
38737  RETURN
38738  END
38739 
38740 C*********************************************************************
38741 
38742 C...PYPDFL
38743 C...Gives proton parton distribution at small x and/or Q^2 according to
38744 C...correct limiting behaviour.
38745 
38746  SUBROUTINE pypdfl(KF,X,Q2,XPQ)
38747 
38748 C...Double precision and integer declarations.
38749  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38750  IMPLICIT INTEGER(I-N)
38751  INTEGER PYK,PYCHGE,PYCOMP
38752 C...Commonblocks.
38753  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38754  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38755  common/pypars/mstp(200),parp(200),msti(200),pari(200)
38756  common/pyint1/mint(400),vint(400)
38757  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
38758 C...Local arrays.
38759  dimension xpq(-25:25),xpa(-25:25),xpb(-25:25),wtsb(-3:3)
38760  DATA rmr/0.92d0/,rmp/0.38d0/,wtsb/0.5d0,1d0,1d0,5d0,1d0,1d0,0.5d0/
38761 
38762 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38763  mint(92)=0
38764  kfa=iabs(kf)
38765  iacc=0
38766  IF((kfa.EQ.2212.OR.kfa.EQ.2112).AND.mstp(57).GE.2) iacc=1
38767  IF(kfa.EQ.211.AND.mstp(57).GE.3) iacc=1
38768  IF(kfa.EQ.22.AND.mint(109).EQ.2.AND.mstp(57).GE.3) iacc=1
38769  IF(iacc.EQ.0) THEN
38770  CALL pypdfu(kf,x,q2,xpq)
38771  RETURN
38772  ENDIF
38773 
38774 C...Reset. Check x.
38775  DO 100 kfl=-25,25
38776  xpq(kfl)=0d0
38777  100 CONTINUE
38778  IF(x.LE.0d0.OR.x.GE.1d0) THEN
38779  WRITE(mstu(11),5000) x
38780  RETURN
38781  ENDIF
38782 
38783 C...Define valence content.
38784  kfc=kf
38785  nv1=2
38786  nv2=1
38787  IF(kf.EQ.2212) THEN
38788  kfv1=2
38789  kfv2=1
38790  ELSEIF(kf.EQ.-2212) THEN
38791  kfv1=-2
38792  kfv2=-1
38793  ELSEIF(kf.EQ.2112) THEN
38794  kfv1=1
38795  kfv2=2
38796  ELSEIF(kf.EQ.-2112) THEN
38797  kfv1=-1
38798  kfv2=-2
38799  ELSEIF(kf.EQ.211) THEN
38800  nv1=1
38801  kfv1=2
38802  kfv2=-1
38803  ELSEIF(kf.EQ.-211) THEN
38804  nv1=1
38805  kfv1=-2
38806  kfv2=1
38807  ELSEIF(mint(105).LE.223) THEN
38808  kfv1=1
38809  wtv1=0.2d0
38810  kfv2=2
38811  wtv2=0.8d0
38812  ELSEIF(mint(105).EQ.333) THEN
38813  kfv1=3
38814  wtv1=1.0d0
38815  kfv2=1
38816  wtv2=0.0d0
38817  ELSEIF(mint(105).EQ.443) THEN
38818  kfv1=4
38819  wtv1=1.0d0
38820  kfv2=1
38821  wtv2=0.0d0
38822  ENDIF
38823 
38824 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38825  mint30=mint(30)
38826  CALL pypdfu(kfc,x,q2,xpa)
38827  q2mn=max(3d0,vint(231))
38828  q2b=2d0+0.052d0**2*exp(3.56d0*sqrt(max(0d0,-log(3d0*x))))
38829  xmn=exp(-(log((q2mn-2d0)/0.052d0**2)/3.56d0)**2)/3d0
38830 
38831 C...Large Q2 and large x: naive call is enough.
38832  IF(q2.GT.q2mn.AND.q2.GT.q2b) THEN
38833  DO 110 kfl=-25,25
38834  xpq(kfl)=xpa(kfl)
38835  110 CONTINUE
38836  mint(92)=1
38837 
38838 C...Small Q2 and large x: dampen boundary value.
38839  ELSEIF(x.GT.xmn) THEN
38840 
38841 C...Evaluate at boundary and define dampening factors.
38842  mint(30)=mint30
38843  CALL pypdfu(kfc,x,q2mn,xpa)
38844  fv=(q2*(q2mn+rmr)/(q2mn*(q2+rmr)))**(0.55d0*(1d0-x)/(1d0-xmn))
38845  fs=(q2*(q2mn+rmp)/(q2mn*(q2+rmp)))**1.08d0
38846 
38847 C...Separate valence and sea parts of parton distribution.
38848  IF(kfa.NE.22) THEN
38849  xfv1=xpa(kfv1)-xpa(-kfv1)
38850  xpa(kfv1)=xpa(-kfv1)
38851  xfv2=xpa(kfv2)-xpa(-kfv2)
38852  xpa(kfv2)=xpa(-kfv2)
38853  ELSE
38854  xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
38855  xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
38856  xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
38857  xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
38858  ENDIF
38859 
38860 C...Dampen valence and sea separately. Put back together.
38861  DO 120 kfl=-25,25
38862  xpq(kfl)=fs*xpa(kfl)
38863  120 CONTINUE
38864  IF(kfa.NE.22) THEN
38865  xpq(kfv1)=xpq(kfv1)+fv*xfv1
38866  xpq(kfv2)=xpq(kfv2)+fv*xfv2
38867  ELSE
38868  xpq(kfv1)=xpq(kfv1)+fv*wtv1*vint(232)
38869  xpq(-kfv1)=xpq(-kfv1)+fv*wtv1*vint(232)
38870  xpq(kfv2)=xpq(kfv2)+fv*wtv2*vint(232)
38871  xpq(-kfv2)=xpq(-kfv2)+fv*wtv2*vint(232)
38872  ENDIF
38873  mint(92)=2
38874 
38875 C...Large Q2 and small x: interpolate behaviour.
38876  ELSEIF(q2.GT.q2mn) THEN
38877 
38878 C...Evaluate at extremes and define coefficients for interpolation.
38879  mint(30)=mint30
38880  CALL pypdfu(kfc,xmn,q2mn,xpa)
38881  vi232a=vint(232)
38882  mint(30)=mint30
38883  CALL pypdfu(kfc,x,q2b,xpb)
38884  vi232b=vint(232)
38885  fla=log(q2b/q2)/log(q2b/q2mn)
38886  fva=(x/xmn)**0.45d0*fla
38887  fsa=(x/xmn)**(-0.08d0)*fla
38888  fb=1d0-fla
38889 
38890 C...Separate valence and sea parts of parton distribution.
38891  IF(kfa.NE.22) THEN
38892  xfva1=xpa(kfv1)-xpa(-kfv1)
38893  xpa(kfv1)=xpa(-kfv1)
38894  xfva2=xpa(kfv2)-xpa(-kfv2)
38895  xpa(kfv2)=xpa(-kfv2)
38896  xfvb1=xpb(kfv1)-xpb(-kfv1)
38897  xpb(kfv1)=xpb(-kfv1)
38898  xfvb2=xpb(kfv2)-xpb(-kfv2)
38899  xpb(kfv2)=xpb(-kfv2)
38900  ELSE
38901  xpa(kfv1)=xpa(kfv1)-wtv1*vi232a
38902  xpa(-kfv1)=xpa(-kfv1)-wtv1*vi232a
38903  xpa(kfv2)=xpa(kfv2)-wtv2*vi232a
38904  xpa(-kfv2)=xpa(-kfv2)-wtv2*vi232a
38905  xpb(kfv1)=xpb(kfv1)-wtv1*vi232b
38906  xpb(-kfv1)=xpb(-kfv1)-wtv1*vi232b
38907  xpb(kfv2)=xpb(kfv2)-wtv2*vi232b
38908  xpb(-kfv2)=xpb(-kfv2)-wtv2*vi232b
38909  ENDIF
38910 
38911 C...Interpolate for valence and sea. Put back together.
38912  DO 130 kfl=-25,25
38913  xpq(kfl)=fsa*xpa(kfl)+fb*xpb(kfl)
38914  130 CONTINUE
38915  IF(kfa.NE.22) THEN
38916  xpq(kfv1)=xpq(kfv1)+(fva*xfva1+fb*xfvb1)
38917  xpq(kfv2)=xpq(kfv2)+(fva*xfva2+fb*xfvb2)
38918  ELSE
38919  xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vi232a+fb*vi232b)
38920  xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vi232a+fb*vi232b)
38921  xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vi232a+fb*vi232b)
38922  xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vi232a+fb*vi232b)
38923  ENDIF
38924  mint(92)=3
38925 
38926 C...Small Q2 and small x: dampen boundary value and add term.
38927  ELSE
38928 
38929 C...Evaluate at boundary and define dampening factors.
38930  mint(30)=mint30
38931  CALL pypdfu(kfc,xmn,q2mn,xpa)
38932  fb=(xmn-x)*(q2mn-q2)/(xmn*q2mn)
38933  fa=1d0-fb
38934  fvc=(x/xmn)**0.45d0*(q2/(q2+rmr))**0.55d0
38935  fva=fvc*fa*((q2mn+rmr)/q2mn)**0.55d0
38936  fvb=fvc*fb*1.10d0*xmn**0.45d0*0.11d0
38937  fsc=(x/xmn)**(-0.08d0)*(q2/(q2+rmp))**1.08d0
38938  fsa=fsc*fa*((q2mn+rmp)/q2mn)**1.08d0
38939  fsb=fsc*fb*0.21d0*xmn**(-0.08d0)*0.21d0
38940 
38941 C...Separate valence and sea parts of parton distribution.
38942  IF(kfa.NE.22) THEN
38943  xfv1=xpa(kfv1)-xpa(-kfv1)
38944  xpa(kfv1)=xpa(-kfv1)
38945  xfv2=xpa(kfv2)-xpa(-kfv2)
38946  xpa(kfv2)=xpa(-kfv2)
38947  ELSE
38948  xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
38949  xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
38950  xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
38951  xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
38952  ENDIF
38953 
38954 C...Dampen valence and sea separately. Add constant terms.
38955 C...Put back together.
38956  DO 140 kfl=-25,25
38957  xpq(kfl)=fsa*xpa(kfl)
38958  140 CONTINUE
38959  IF(kfa.NE.22) THEN
38960  DO 150 kfl=-3,3
38961  xpq(kfl)=xpq(kfl)+fsb*wtsb(kfl)
38962  150 CONTINUE
38963  xpq(kfv1)=xpq(kfv1)+(fva*xfv1+fvb*nv1)
38964  xpq(kfv2)=xpq(kfv2)+(fva*xfv2+fvb*nv2)
38965  ELSE
38966  DO 160 kfl=-3,3
38967  xpq(kfl)=xpq(kfl)+vint(281)*fsb*wtsb(kfl)
38968  160 CONTINUE
38969  xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
38970  xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
38971  xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
38972  xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
38973  ENDIF
38974  xpq(21)=xpq(0)
38975  mint(92)=4
38976  ENDIF
38977 
38978 C...Format for error printout.
38979  5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
38980 
38981  RETURN
38982  END
38983 
38984 C*********************************************************************
38985 
38986 C...PYPDEL
38987 C...Gives electron (or muon, or tau) parton distribution.
38988 
38989  SUBROUTINE pypdel(KFA,X,Q2,XPEL)
38990 
38991 C...Double precision and integer declarations.
38992  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38993  IMPLICIT INTEGER(I-N)
38994  INTEGER PYK,PYCHGE,PYCOMP
38995 C...Commonblocks.
38996  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38997  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38998  common/pypars/mstp(200),parp(200),msti(200),pari(200)
38999  common/pyint1/mint(400),vint(400)
39000  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
39001 C...Local arrays.
39002  dimension xpel(-25:25),xpga(-6:6),sxp(0:6)
39003 
39004 C...Interface to PDFLIB.
39005  common/w50513/xmin,xmax,q2min,q2max
39006  SAVE /w50513/
39007  DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39008  &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39009  CHARACTER*20 PARM(20)
39010  DATA VALUE/20*0d0/,parm/20*' '/
39011 
39012 C...Some common constants.
39013  DO 100 kfl=-25,25
39014  xpel(kfl)=0d0
39015  100 CONTINUE
39016  aem=paru(101)
39017  pme=pmas(11,1)
39018  IF(kfa.EQ.13) pme=pmas(13,1)
39019  IF(kfa.EQ.15) pme=pmas(15,1)
39020  xl=log(max(1d-10,x))
39021  x1l=log(max(1d-10,1d0-x))
39022  hle=log(max(3d0,q2/pme**2))
39023  hbe2=(aem/paru(1))*(hle-1d0)
39024 
39025 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39026 C...LEP 1, CERN 89-08, p. 34
39027  IF(mstp(59).LE.1) THEN
39028  hde=1d0+(aem/paru(1))*(1.5d0*hle+1.289868d0)+(aem/paru(1))**2*
39029  & (-2.164868d0*hle**2+9.840808d0*hle-10.130464d0)
39030  hee=hbe2*(1d0-x)**(hbe2-1d0)*sqrt(max(0d0,hde))-
39031  & 0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*(-4d0*x1l+3d0*xl)-
39032  & 4d0*xl/(1d0-x)-5d0-x)
39033  ELSE
39034  hee=hbe2*(1d0-x)**(hbe2-1d0)*exp(0.172784d0*hbe2)/
39035  & pygamm(1d0+hbe2)-0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*
39036  & (-4d0*x1l+3d0*xl)-4d0*xl/(1d0-x)-5d0-x)
39037  ENDIF
39038 C...Zero distribution for very large x and rescale it for intermediate.
39039  IF(x.GT.1d0-1d-10) THEN
39040  hee=0d0
39041  ELSEIF(x.GT.1d0-1d-7) THEN
39042  hee=hee*1000d0**hbe2/(1000d0**hbe2-1d0)
39043  ENDIF
39044  xpel(kfa)=x*hee
39045 
39046 C...Photon and (transverse) W- inside electron.
39047  aemp=pyalem(pme*sqrt(max(0d0,q2)))/paru(2)
39048  IF(mstp(13).LE.1) THEN
39049  hlg=hle
39050  ELSE
39051  hlg=log(max(1d0,(parp(13)/pme**2)*(1d0-x)/x**2))
39052  ENDIF
39053  xpel(22)=aemp*hlg*(1d0+(1d0-x)**2)
39054  hlw=log(1d0+q2/pmas(24,1)**2)/(4d0*paru(102))
39055  xpel(-24)=aemp*hlw*(1d0+(1d0-x)**2)
39056 
39057 C...Electron or positron inside photon inside electron.
39058  IF(kfa.EQ.11.AND.mstp(12).EQ.1) THEN
39059  xfsea=0.5d0*(aemp*(hle-1d0))**2*(4d0/3d0+x-x**2-4d0*x**3/3d0+
39060  & 2d0*x*(1d0+x)*xl)
39061  xpel(11)=xpel(11)+xfsea
39062  xpel(-11)=xfsea
39063 
39064 C...Initialize PDFLIB photon parton distributions.
39065  IF(mstp(56).EQ.2) THEN
39066  parm(1)='NPTYPE'
39067  value(1)=3
39068  parm(2)='NGROUP'
39069  value(2)=mstp(55)/1000
39070  parm(3)='NSET'
39071  value(3)=mod(mstp(55),1000)
39072  IF(mint(93).NE.3000000+mstp(55)) THEN
39073  CALL pdfset(parm,VALUE)
39074  mint(93)=3000000+mstp(55)
39075  ENDIF
39076  ENDIF
39077 
39078 C...Quarks and gluons inside photon inside electron:
39079 C...numerical convolution required.
39080  DO 110 kfl=0,6
39081  sxp(kfl)=0d0
39082  110 CONTINUE
39083  sumxpp=0d0
39084  iter=-1
39085  120 iter=iter+1
39086  sumxp=sumxpp
39087  nstp=2**(iter-1)
39088  IF(iter.EQ.0) nstp=2
39089  DO 130 kfl=0,6
39090  sxp(kfl)=0.5d0*sxp(kfl)
39091  130 CONTINUE
39092  wtstp=0.5d0/nstp
39093  IF(iter.EQ.0) wtstp=0.5d0
39094 C...Pick grid of x_{gamma} values logarithmically even.
39095  DO 150 istp=1,nstp
39096  IF(iter.EQ.0) THEN
39097  xle=xl*(istp-1)
39098  ELSE
39099  xle=xl*(istp-0.5d0)/nstp
39100  ENDIF
39101  xe=min(1d0-1d-10,exp(xle))
39102  xg=min(1d0-1d-10,x/xe)
39103 C...Evaluate photon inside electron parton distribution for convolution.
39104  xpgp=1d0+(1d0-xe)**2
39105  IF(mstp(13).LE.1) THEN
39106  xpgp=xpgp*hle
39107  ELSE
39108  xpgp=xpgp*log(max(1d0,(parp(13)/pme**2)*(1d0-xe)/xe**2))
39109  ENDIF
39110 C...Evaluate photon parton distributions for convolution.
39111  IF(mstp(56).EQ.1) THEN
39112  IF(mstp(55).EQ.1) THEN
39113  CALL pypdga(xg,q2,xpga)
39114  ELSEIF(mstp(55).GE.5.AND.mstp(55).LE.8) THEN
39115  q2mx=q2
39116  p2mx=0.36d0
39117  IF(mstp(55).GE.7) p2mx=4.0d0
39118  IF(mstp(57).EQ.0) q2mx=p2mx
39119  p2=0d0
39120  IF(vint(120).LT.0d0) p2=vint(120)**2
39121  CALL pyggam(mstp(55)-4,xg,q2mx,p2,mstp(60),f2gam,xpga)
39122  vint(231)=p2mx
39123  ELSEIF(mstp(55).GE.9.AND.mstp(55).LE.12) THEN
39124  q2mx=q2
39125  p2mx=0.36d0
39126  IF(mstp(55).GE.11) p2mx=4.0d0
39127  IF(mstp(57).EQ.0) q2mx=p2mx
39128  p2=0d0
39129  IF(vint(120).LT.0d0) p2=vint(120)**2
39130  CALL pyggam(mstp(55)-8,xg,q2mx,p2,mstp(60),f2gam,xpga)
39131  vint(231)=p2mx
39132  ENDIF
39133  DO 140 kfl=0,5
39134  sxp(kfl)=sxp(kfl)+wtstp*xpgp*xpga(kfl)
39135  140 CONTINUE
39136  ELSEIF(mstp(56).EQ.2) THEN
39137 C...Call PDFLIB parton distributions.
39138  xx=xg
39139  qq=sqrt(max(0d0,q2min,q2))
39140  IF(mstp(57).EQ.0) qq=sqrt(q2min)
39141  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
39142  sxp(0)=sxp(0)+wtstp*xpgp*glu
39143  sxp(1)=sxp(1)+wtstp*xpgp*dnv
39144  sxp(2)=sxp(2)+wtstp*xpgp*upv
39145  sxp(3)=sxp(3)+wtstp*xpgp*str
39146  sxp(4)=sxp(4)+wtstp*xpgp*chm
39147  sxp(5)=sxp(5)+wtstp*xpgp*bot
39148  sxp(6)=sxp(6)+wtstp*xpgp*top
39149  ENDIF
39150  150 CONTINUE
39151  sumxpp=sxp(0)+2d0*sxp(1)+2d0*sxp(2)
39152  IF(iter.LE.2.OR.(iter.LE.7.AND.abs(sumxpp-sumxp).GT.
39153  & parp(14)*(sumxpp+sumxp))) GOTO 120
39154 
39155 C...Put convolution into output arrays.
39156  fconv=aemp*(-xl)
39157  xpel(0)=fconv*sxp(0)
39158  DO 160 kfl=1,6
39159  xpel(kfl)=fconv*sxp(kfl)
39160  xpel(-kfl)=xpel(kfl)
39161  160 CONTINUE
39162  ENDIF
39163 
39164  RETURN
39165  END
39166 
39167 C*********************************************************************
39168 
39169 C...PYPDGA
39170 C...Gives photon parton distribution.
39171 
39172  SUBROUTINE pypdga(X,Q2,XPGA)
39173 
39174 C...Double precision and integer declarations.
39175  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39176  IMPLICIT INTEGER(I-N)
39177  INTEGER PYK,PYCHGE,PYCOMP
39178 C...Commonblocks.
39179  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39180  common/pypars/mstp(200),parp(200),msti(200),pari(200)
39181  common/pyint1/mint(400),vint(400)
39182  SAVE /pydat1/,/pypars/,/pyint1/
39183 C...Local arrays.
39184  dimension xpga(-6:6),dgag(4,3),dgbg(4,3),dgcg(4,3),dgan(4,3),
39185  &dgbn(4,3),dgcn(4,3),dgdn(4,3),dgen(4,3),dgas(4,3),dgbs(4,3),
39186  &dgcs(4,3),dgds(4,3),dges(4,3)
39187 
39188 C...The following data lines are coefficients needed in the
39189 C...Drees and Grassie photon parton distribution parametrization.
39190  DATA dgag/-.207d0,.6158d0,1.074d0,0.d0,.8926d-2,.6594d0,
39191  &.4766d0,.1975d-1,.03197d0,1.018d0,.2461d0,.2707d-1/
39192  DATA dgbg/-.1987d0,.6257d0,8.352d0,5.024d0,.5085d-1,.2774d0,
39193  &-.3906d0,-.3212d0,-.618d-2,.9476d0,-.6094d0,-.1067d-1/
39194  DATA dgcg/5.119d0,-.2752d0,-6.993d0,2.298d0,-.2313d0,.1382d0,
39195  &6.542d0,.5162d0,-.1216d0,.9047d0,2.653d0,.2003d-2/
39196  DATA dgan/2.285d0,-.1526d-1,1330.d0,4.219d0,-.3711d0,1.061d0,
39197  &4.758d0,-.1503d-1,15.8d0,-.9464d0,-.5d0,-.2118d0/
39198  DATA dgbn/6.073d0,-.8132d0,-41.31d0,3.165d0,-.1717d0,.7815d0,
39199  &1.535d0,.7067d-2,2.742d0,-.7332d0,.7148d0,3.287d0/
39200  DATA dgcn/-.4202d0,.1778d-1,.9216d0,.18d0,.8766d-1,.2197d-1,
39201  &.1096d0,.204d0,.2917d-1,.4657d-1,.1785d0,.4811d-1/
39202  DATA dgdn/-.8083d-1,.6346d0,1.208d0,.203d0,-.8915d0,.2857d0,
39203  &2.973d0,.1185d0,-.342d-1,.7196d0,.7338d0,.8139d-1/
39204  DATA dgen/.5526d-1,1.136d0,.9512d0,.1163d-1,-.1816d0,.5866d0,
39205  &2.421d0,.4059d0,-.2302d-1,.9229d0,.5873d0,-.79d-4/
39206  DATA dgas/16.69d0,-.7916d0,1099.d0,4.428d0,-.1207d0,1.071d0,
39207  &1.977d0,-.8625d-2,6.734d0,-1.008d0,-.8594d-1,.7625d-1/
39208  DATA dgbs/.176d0,.4794d-1,1.047d0,.25d-1,25.d0,-1.648d0,
39209  &-.1563d-1,6.438d0,59.88d0,-2.983d0,4.48d0,.9686d0/
39210  DATA dgcs/-.208d-1,.3386d-2,4.853d0,.8404d0,-.123d-1,1.162d0,
39211  &.4824d0,-.11d-1,-.3226d-2,.8432d0,.3616d0,.1383d-2/
39212  DATA dgds/-.1685d-1,1.353d0,1.426d0,1.239d0,-.9194d-1,.7912d0,
39213  &.6397d0,2.327d0,-.3321d-1,.9475d0,-.3198d0,.2132d-1/
39214  DATA dges/-.1986d0,1.1d0,1.136d0,-.2779d0,.2015d-1,.9869d0,
39215  &-.7036d-1,.1694d-1,.1059d0,.6954d0,-.6663d0,.3683d0/
39216 
39217 C...Photon parton distribution from Drees and Grassie.
39218 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39219  DO 100 kfl=-6,6
39220  xpga(kfl)=0d0
39221  100 CONTINUE
39222  vint(231)=1d0
39223  IF(mstp(57).LE.0) THEN
39224  t=log(1d0/0.16d0)
39225  ELSE
39226  t=log(min(1d4,max(1d0,q2))/0.16d0)
39227  ENDIF
39228  x1=1d0-x
39229  nf=3
39230  IF(q2.GT.25d0) nf=4
39231  IF(q2.GT.300d0) nf=5
39232  nfe=nf-2
39233  aem=paru(101)
39234 
39235 C...Evaluate gluon content.
39236  dga=dgag(1,nfe)*t**dgag(2,nfe)+dgag(3,nfe)*t**(-dgag(4,nfe))
39237  dgb=dgbg(1,nfe)*t**dgbg(2,nfe)+dgbg(3,nfe)*t**(-dgbg(4,nfe))
39238  dgc=dgcg(1,nfe)*t**dgcg(2,nfe)+dgcg(3,nfe)*t**(-dgcg(4,nfe))
39239  xpgl=dga*x**dgb*x1**dgc
39240 
39241 C...Evaluate up- and down-type quark content.
39242  dga=dgan(1,nfe)*t**dgan(2,nfe)+dgan(3,nfe)*t**(-dgan(4,nfe))
39243  dgb=dgbn(1,nfe)*t**dgbn(2,nfe)+dgbn(3,nfe)*t**(-dgbn(4,nfe))
39244  dgc=dgcn(1,nfe)*t**dgcn(2,nfe)+dgcn(3,nfe)*t**(-dgcn(4,nfe))
39245  dgd=dgdn(1,nfe)*t**dgdn(2,nfe)+dgdn(3,nfe)*t**(-dgdn(4,nfe))
39246  dge=dgen(1,nfe)*t**dgen(2,nfe)+dgen(3,nfe)*t**(-dgen(4,nfe))
39247  xpqn=x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
39248  dga=dgas(1,nfe)*t**dgas(2,nfe)+dgas(3,nfe)*t**(-dgas(4,nfe))
39249  dgb=dgbs(1,nfe)*t**dgbs(2,nfe)+dgbs(3,nfe)*t**(-dgbs(4,nfe))
39250  dgc=dgcs(1,nfe)*t**dgcs(2,nfe)+dgcs(3,nfe)*t**(-dgcs(4,nfe))
39251  dgd=dgds(1,nfe)*t**dgds(2,nfe)+dgds(3,nfe)*t**(-dgds(4,nfe))
39252  dge=dges(1,nfe)*t**dges(2,nfe)+dges(3,nfe)*t**(-dges(4,nfe))
39253  dgf=9d0
39254  IF(nf.EQ.4) dgf=10d0
39255  IF(nf.EQ.5) dgf=55d0/6d0
39256  xpqs=dgf*x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
39257  IF(nf.LE.3) THEN
39258  xpqu=(xpqs+9d0*xpqn)/6d0
39259  xpqd=(xpqs-4.5d0*xpqn)/6d0
39260  ELSEIF(nf.EQ.4) THEN
39261  xpqu=(xpqs+6d0*xpqn)/8d0
39262  xpqd=(xpqs-6d0*xpqn)/8d0
39263  ELSE
39264  xpqu=(xpqs+7.5d0*xpqn)/10d0
39265  xpqd=(xpqs-5d0*xpqn)/10d0
39266  ENDIF
39267 
39268 C...Put into output arrays.
39269  xpga(0)=aem*xpgl
39270  xpga(1)=aem*xpqd
39271  xpga(2)=aem*xpqu
39272  xpga(3)=aem*xpqd
39273  IF(nf.GE.4) xpga(4)=aem*xpqu
39274  IF(nf.GE.5) xpga(5)=aem*xpqd
39275  DO 110 kfl=1,6
39276  xpga(-kfl)=xpga(kfl)
39277  110 CONTINUE
39278 
39279  RETURN
39280  END
39281 
39282 C*********************************************************************
39283 
39284 C...PYGGAM
39285 C...Constructs the F2 and parton distributions of the photon
39286 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39287 C...For F2, c and b are included by the Bethe-Heitler formula;
39288 C...in the 'MSbar' scheme additionally a Cgamma term is added.
39289 C...Contains the SaS sets 1D, 1M, 2D and 2M.
39290 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39291 
39292  SUBROUTINE pyggam(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39293 
39294 C...Double precision and integer declarations.
39295  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39296  IMPLICIT INTEGER(I-N)
39297  INTEGER PYK,PYCHGE,PYCOMP
39298 C...Commonblocks.
39299  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
39300  &xpdir(-6:6)
39301  common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
39302  SAVE /pyint8/,/pyint9/
39303 C...Local arrays.
39304  dimension xpdfgm(-6:6),xpga(-6:6), vxpga(-6:6)
39305 C...Charm and bottom masses (low to compensate for J/psi etc.).
39306  DATA pmc/1.3d0/, pmb/4.6d0/
39307 C...alpha_em and alpha_em/(2*pi).
39308  DATA aem/0.007297d0/, aem2pi/0.0011614d0/
39309 C...Lambda value for 4 flavours.
39310  DATA alam/0.20d0/
39311 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39312  DATA fracu/0.8d0/
39313 C...VMD couplings f_V**2/(4*pi).
39314  DATA frho/2.20d0/, fomega/23.6d0/, fphi/18.4d0/
39315 C...Masses for rho (=omega) and phi.
39316  DATA pmrho/0.770d0/, pmphi/1.020d0/
39317 C...Number of points in integration for IP2=1.
39318  DATA nstep/100/
39319 
39320 C...Reset output.
39321  f2gm=0d0
39322  DO 100 kfl=-6,6
39323  xpdfgm(kfl)=0d0
39324  xpvmd(kfl)=0d0
39325  xpanl(kfl)=0d0
39326  xpanh(kfl)=0d0
39327  xpbeh(kfl)=0d0
39328  xpdir(kfl)=0d0
39329  vxpvmd(kfl)=0d0
39330  vxpanl(kfl)=0d0
39331  vxpanh(kfl)=0d0
39332  vxpdgm(kfl)=0d0
39333  100 CONTINUE
39334 
39335 C...Set Q0 cut-off parameter as function of set used.
39336  IF(iset.LE.2) THEN
39337  q0=0.6d0
39338  ELSE
39339  q0=2d0
39340  ENDIF
39341  q02=q0**2
39342 
39343 C...Scale choice for off-shell photon; common factors.
39344  q2a=q2
39345  facnor=1d0
39346  IF(ip2.EQ.1) THEN
39347  p2mx=p2+q02
39348  q2a=q2+p2*q02/max(q02,q2)
39349  facnor=log(q2/q02)/nstep
39350  ELSEIF(ip2.EQ.2) THEN
39351  p2mx=max(p2,q02)
39352  ELSEIF(ip2.EQ.3) THEN
39353  p2mx=p2+q02
39354  q2a=q2+p2*q02/max(q02,q2)
39355  ELSEIF(ip2.EQ.4) THEN
39356  p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39357  & ((q2+p2)*(q02+p2)))
39358  ELSEIF(ip2.EQ.5) THEN
39359  p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39360  & ((q2+p2)*(q02+p2)))
39361  p2mx=q0*sqrt(p2mxa)
39362  facnor=log(q2/p2mxa)/log(q2/p2mx)
39363  ELSEIF(ip2.EQ.6) THEN
39364  p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39365  & ((q2+p2)*(q02+p2)))
39366  p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
39367  ELSE
39368  p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39369  & ((q2+p2)*(q02+p2)))
39370  p2mx=q0*sqrt(p2mxa)
39371  p2mxb=p2mx
39372  p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
39373  p2mxb=max(0d0,1d0-p2/q2)*p2mxb+min(1d0,p2/q2)*p2mxa
39374  IF(abs(q2-q02).GT.1d-6) THEN
39375  facnor=log(q2/p2mxa)/log(q2/p2mxb)
39376  ELSEIF(p2.LT.q02) THEN
39377  facnor=q02**3/(q02+p2)/(q02**2-p2**2/2d0)
39378  ELSE
39379  facnor=1d0
39380  ENDIF
39381  ENDIF
39382 
39383 C...Call VMD parametrization for d quark and use to give rho, omega,
39384 C...phi. Note dipole dampening for off-shell photon.
39385  CALL pygvmd(iset,1,x,q2a,p2mx,alam,xpga,vxpga)
39386  xfval=vxpga(1)
39387  xpga(1)=xpga(2)
39388  xpga(-1)=xpga(-2)
39389  facud=aem*(1d0/frho+1d0/fomega)*(pmrho**2/(pmrho**2+p2))**2
39390  facs=aem*(1d0/fphi)*(pmphi**2/(pmphi**2+p2))**2
39391  DO 110 kfl=-5,5
39392  xpvmd(kfl)=(facud+facs)*xpga(kfl)
39393  110 CONTINUE
39394  xpvmd(1)=xpvmd(1)+(1d0-fracu)*facud*xfval
39395  xpvmd(2)=xpvmd(2)+fracu*facud*xfval
39396  xpvmd(3)=xpvmd(3)+facs*xfval
39397  xpvmd(-1)=xpvmd(-1)+(1d0-fracu)*facud*xfval
39398  xpvmd(-2)=xpvmd(-2)+fracu*facud*xfval
39399  xpvmd(-3)=xpvmd(-3)+facs*xfval
39400  vxpvmd(1)=(1d0-fracu)*facud*xfval
39401  vxpvmd(2)=fracu*facud*xfval
39402  vxpvmd(3)=facs*xfval
39403  vxpvmd(-1)=(1d0-fracu)*facud*xfval
39404  vxpvmd(-2)=fracu*facud*xfval
39405  vxpvmd(-3)=facs*xfval
39406 
39407  IF(ip2.NE.1) THEN
39408 C...Anomalous parametrizations for different strategies
39409 C...for off-shell photons; except full integration.
39410 
39411 C...Call anomalous parametrization for d + u + s.
39412  CALL pygano(-3,x,q2a,p2mx,alam,xpga,vxpga)
39413  DO 120 kfl=-5,5
39414  xpanl(kfl)=facnor*xpga(kfl)
39415  vxpanl(kfl)=facnor*vxpga(kfl)
39416  120 CONTINUE
39417 
39418 C...Call anomalous parametrization for c and b.
39419  CALL pygano(4,x,q2a,p2mx,alam,xpga,vxpga)
39420  DO 130 kfl=-5,5
39421  xpanh(kfl)=facnor*xpga(kfl)
39422  vxpanh(kfl)=facnor*vxpga(kfl)
39423  130 CONTINUE
39424  CALL pygano(5,x,q2a,p2mx,alam,xpga,vxpga)
39425  DO 140 kfl=-5,5
39426  xpanh(kfl)=xpanh(kfl)+facnor*xpga(kfl)
39427  vxpanh(kfl)=vxpanh(kfl)+facnor*vxpga(kfl)
39428  140 CONTINUE
39429 
39430  ELSE
39431 C...Special option: loop over flavours and integrate over k2.
39432  DO 170 kf=1,5
39433  DO 160 istep=1,nstep
39434  q2step=q02*(q2/q02)**((istep-0.5d0)/nstep)
39435  IF((kf.EQ.4.AND.q2step.LT.pmc**2).OR.
39436  & (kf.EQ.5.AND.q2step.LT.pmb**2)) GOTO 160
39437  CALL pygvmd(0,kf,x,q2,q2step,alam,xpga,vxpga)
39438  facq=aem2pi*(q2step/(q2step+p2))**2*facnor
39439  IF(mod(kf,2).EQ.0) facq=facq*(8d0/9d0)
39440  IF(mod(kf,2).EQ.1) facq=facq*(2d0/9d0)
39441  DO 150 kfl=-5,5
39442  IF(kf.LE.3) xpanl(kfl)=xpanl(kfl)+facq*xpga(kfl)
39443  IF(kf.GE.4) xpanh(kfl)=xpanh(kfl)+facq*xpga(kfl)
39444  IF(kf.LE.3) vxpanl(kfl)=vxpanl(kfl)+facq*vxpga(kfl)
39445  IF(kf.GE.4) vxpanh(kfl)=vxpanh(kfl)+facq*vxpga(kfl)
39446  150 CONTINUE
39447  160 CONTINUE
39448  170 CONTINUE
39449  ENDIF
39450 
39451 C...Call Bethe-Heitler term expression for charm and bottom.
39452  CALL pygbeh(4,x,q2,p2,pmc**2,xpbh)
39453  xpbeh(4)=xpbh
39454  xpbeh(-4)=xpbh
39455  CALL pygbeh(5,x,q2,p2,pmb**2,xpbh)
39456  xpbeh(5)=xpbh
39457  xpbeh(-5)=xpbh
39458 
39459 C...For MSbar subtraction call C^gamma term expression for d, u, s.
39460  IF(iset.EQ.2.OR.iset.EQ.4) THEN
39461  CALL pygdir(x,q2,p2,q02,xpga)
39462  DO 180 kfl=-5,5
39463  xpdir(kfl)=xpga(kfl)
39464  180 CONTINUE
39465  ENDIF
39466 
39467 C...Store result in output array.
39468  DO 190 kfl=-5,5
39469  chsq=1d0/9d0
39470  IF(iabs(kfl).EQ.2.OR.iabs(kfl).EQ.4) chsq=4d0/9d0
39471  xpf2=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
39472  IF(kfl.NE.0) f2gm=f2gm+chsq*xpf2
39473  xpdfgm(kfl)=xpvmd(kfl)+xpanl(kfl)+xpanh(kfl)
39474  vxpdgm(kfl)=vxpvmd(kfl)+vxpanl(kfl)+vxpanh(kfl)
39475  190 CONTINUE
39476 
39477  RETURN
39478  END
39479 
39480 C*********************************************************************
39481 
39482 C...PYGVMD
39483 C...Evaluates the VMD parton distributions of a photon,
39484 C...evolved homogeneously from an initial scale P2 to Q2.
39485 C...Does not include dipole suppression factor.
39486 C...ISET is parton distribution set, see above;
39487 C...additionally ISET=0 is used for the evolution of an anomalous photon
39488 C...which branched at a scale P2 and then evolved homogeneously to Q2.
39489 C...ALAM is the 4-flavour Lambda, which is automatically converted
39490 C...to 3- and 5-flavour equivalents as needed.
39491 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39492 
39493  SUBROUTINE pygvmd(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39494 
39495 C...Double precision and integer declarations.
39496  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39497  IMPLICIT INTEGER(I-N)
39498  INTEGER PYK,PYCHGE,PYCOMP
39499 C...Local arrays and data.
39500  dimension xpga(-6:6), vxpga(-6:6)
39501  DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
39502 
39503 C...Reset output.
39504  DO 100 kfl=-6,6
39505  xpga(kfl)=0d0
39506  vxpga(kfl)=0d0
39507  100 CONTINUE
39508  kfa=iabs(kf)
39509 
39510 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39511  alam3=alam*(pmc/alam)**(2d0/27d0)
39512  alam5=alam*(alam/pmb)**(2d0/23d0)
39513  p2eff=max(p2,1.2d0*alam3**2)
39514  IF(kfa.EQ.4) p2eff=max(p2eff,pmc**2)
39515  IF(kfa.EQ.5) p2eff=max(p2eff,pmb**2)
39516  q2eff=max(q2,p2eff)
39517 
39518 C...Find number of flavours at lower and upper scale.
39519  nfp=4
39520  IF(p2eff.LT.pmc**2) nfp=3
39521  IF(p2eff.GT.pmb**2) nfp=5
39522  nfq=4
39523  IF(q2eff.LT.pmc**2) nfq=3
39524  IF(q2eff.GT.pmb**2) nfq=5
39525 
39526 C...Find s as sum of 3-, 4- and 5-flavour parts.
39527  s=0d0
39528  IF(nfp.EQ.3) THEN
39529  q2div=pmc**2
39530  IF(nfq.EQ.3) q2div=q2eff
39531  s=s+(6d0/27d0)*log(log(q2div/alam3**2)/log(p2eff/alam3**2))
39532  ENDIF
39533  IF(nfp.LE.4.AND.nfq.GE.4) THEN
39534  p2div=p2eff
39535  IF(nfp.EQ.3) p2div=pmc**2
39536  q2div=q2eff
39537  IF(nfq.EQ.5) q2div=pmb**2
39538  s=s+(6d0/25d0)*log(log(q2div/alam**2)/log(p2div/alam**2))
39539  ENDIF
39540  IF(nfq.EQ.5) THEN
39541  p2div=pmb**2
39542  IF(nfp.EQ.5) p2div=p2eff
39543  s=s+(6d0/23d0)*log(log(q2eff/alam5**2)/log(p2div/alam5**2))
39544  ENDIF
39545 
39546 C...Calculate frequent combinations of x and s.
39547  x1=1d0-x
39548  xl=-log(x)
39549  s2=s**2
39550  s3=s**3
39551  s4=s**4
39552 
39553 C...Evaluate homogeneous anomalous parton distributions below or
39554 C...above threshold.
39555  IF(iset.EQ.0) THEN
39556  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39557  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39558  xval = x * 1.5d0 * (x**2+x1**2)
39559  xglu = 0d0
39560  xsea = 0d0
39561  ELSE
39562  xval = (1.5d0/(1d0-0.197d0*s+4.33d0*s2)*x**2 +
39563  & (1.5d0+2.10d0*s)/(1d0+3.29d0*s)*x1**2 +
39564  & 5.23d0*s/(1d0+1.17d0*s+19.9d0*s3)*x*x1) *
39565  & x**(1d0/(1d0+1.5d0*s)) * (1d0-x**2)**(2.667d0*s)
39566  xglu = 4d0*s/(1d0+4.76d0*s+15.2d0*s2+29.3d0*s4) *
39567  & x**(-2.03d0*s/(1d0+2.44d0*s)) * (x1*xl)**(1.333d0*s) *
39568  & ((4d0*x**2+7d0*x+4d0)*x1/3d0 - 2d0*x*(1d0+x)*xl)
39569  xsea = s2/(1d0+4.54d0*s+8.19d0*s2+8.05d0*s3) *
39570  & x**(-1.54d0*s/(1d0+1.29d0*s)) * x1**(2.667d0*s) *
39571  & ((8d0-73d0*x+62d0*x**2)*x1/9d0 + (3d0-8d0*x**2/3d0)*x*xl +
39572  & (2d0*x-1d0)*x*xl**2)
39573  ENDIF
39574 
39575 C...Evaluate set 1D parton distributions below or above threshold.
39576  ELSEIF(iset.EQ.1) THEN
39577  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39578  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39579  xval = 1.294d0 * x**0.80d0 * x1**0.76d0
39580  xglu = 1.273d0 * x**0.40d0 * x1**1.76d0
39581  xsea = 0.100d0 * x1**3.76d0
39582  ELSE
39583  xval = 1.294d0/(1d0+0.252d0*s+3.079d0*s2) *
39584  & x**(0.80d0-0.13d0*s) * x1**(0.76d0+0.667d0*s) * xl**(2d0*s)
39585  xglu = 7.90d0*s/(1d0+5.50d0*s) * exp(-5.16d0*s) *
39586  & x**(-1.90d0*s/(1d0+3.60d0*s)) * x1**1.30d0 *
39587  & xl**(0.50d0+3d0*s) + 1.273d0 * exp(-10d0*s) *
39588  & x**0.40d0 * x1**(1.76d0+3d0*s)
39589  xsea = (0.1d0-0.397d0*s2+1.121d0*s3)/
39590  & (1d0+5.61d0*s2+5.26d0*s3) * x**(-7.32d0*s2/(1d0+10.3d0*s2)) *
39591  & x1**((3.76d0+15d0*s+12d0*s2)/(1d0+4d0*s))
39592  xsea0 = 0.100d0 * x1**3.76d0
39593  ENDIF
39594 
39595 C...Evaluate set 1M parton distributions below or above threshold.
39596  ELSEIF(iset.EQ.2) THEN
39597  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39598  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39599  xval = 0.8477d0 * x**0.51d0 * x1**1.37d0
39600  xglu = 3.42d0 * x**0.255d0 * x1**2.37d0
39601  xsea = 0d0
39602  ELSE
39603  xval = 0.8477d0/(1d0+1.37d0*s+2.18d0*s2+3.73d0*s3) *
39604  & x**(0.51d0+0.21d0*s) * x1**1.37d0 * xl**(2.667d0*s)
39605  xglu = 24d0*s/(1d0+9.6d0*s+0.92d0*s2+14.34d0*s3) *
39606  & exp(-5.94d0*s) * x**((-0.013d0-1.80d0*s)/(1d0+3.14d0*s)) *
39607  & x1**(2.37d0+0.4d0*s) * xl**(0.32d0+3.6d0*s) + 3.42d0 *
39608  & exp(-12d0*s) * x**0.255d0 * x1**(2.37d0+3d0*s)
39609  xsea = 0.842d0*s/(1d0+21.3d0*s-33.2d0*s2+229d0*s3) *
39610  & x**((0.13d0-2.90d0*s)/(1d0+5.44d0*s)) * x1**(3.45d0+0.5d0*s) *
39611  & xl**(2.8d0*s)
39612  xsea0 = 0d0
39613  ENDIF
39614 
39615 C...Evaluate set 2D parton distributions below or above threshold.
39616  ELSEIF(iset.EQ.3) THEN
39617  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39618  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39619  xval = x**0.46d0 * x1**0.64d0 + 0.76d0 * x
39620  xglu = 1.925d0 * x1**2
39621  xsea = 0.242d0 * x1**4
39622  ELSE
39623  xval = (1d0+0.186d0*s)/(1d0-0.209d0*s+1.495d0*s2) *
39624  & x**(0.46d0+0.25d0*s) *
39625  & x1**((0.64d0+0.14d0*s+5d0*s2)/(1d0+s)) * xl**(1.9d0*s) +
39626  & (0.76d0+0.4d0*s) * x * x1**(2.667d0*s)
39627  xglu = (1.925d0+5.55d0*s+147d0*s2)/(1d0-3.59d0*s+3.32d0*s2) *
39628  & exp(-18.67d0*s) *
39629  & x**((-5.81d0*s-5.34d0*s2)/(1d0+29d0*s-4.26d0*s2))
39630  & * x1**((2d0-5.9d0*s)/(1d0+1.7d0*s)) *
39631  & xl**(9.3d0*s/(1d0+1.7d0*s))
39632  xsea = (0.242d0-0.252d0*s+1.19d0*s2)/
39633  & (1d0-0.607d0*s+21.95d0*s2) *
39634  & x**(-12.1d0*s2/(1d0+2.62d0*s+16.7d0*s2)) * x1**4 * xl**s
39635  xsea0 = 0.242d0 * x1**4
39636  ENDIF
39637 
39638 C...Evaluate set 2M parton distributions below or above threshold.
39639  ELSEIF(iset.EQ.4) THEN
39640  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39641  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39642  xval = 1.168d0 * x**0.50d0 * x1**2.60d0 + 0.965d0 * x
39643  xglu = 1.808d0 * x1**2
39644  xsea = 0.209d0 * x1**4
39645  ELSE
39646  xval = (1.168d0+1.771d0*s+29.35d0*s2) * exp(-5.776d0*s) *
39647  & x**((0.5d0+0.208d0*s)/(1d0-0.794d0*s+1.516d0*s2)) *
39648  & x1**((2.6d0+7.6d0*s)/(1d0+5d0*s)) *
39649  & xl**(5.15d0*s/(1d0+2d0*s)) +
39650  & (0.965d0+22.35d0*s)/(1d0+18.4d0*s) * x * x1**(2.667d0*s)
39651  xglu = (1.808d0+29.9d0*s)/(1d0+26.4d0*s) * exp(-5.28d0*s) *
39652  & x**((-5.35d0*s-10.11d0*s2)/(1d0+31.71d0*s)) *
39653  & x1**((2d0-7.3d0*s+4d0*s2)/(1d0+2.5d0*s)) *
39654  & xl**(10.9d0*s/(1d0+2.5d0*s))
39655  xsea = (0.209d0+0.644d0*s2)/(1d0+0.319d0*s+17.6d0*s2) *
39656  & x**((-0.373d0*s-7.71d0*s2)/(1d0+0.815d0*s+11.0d0*s2)) *
39657  & x1**(4d0+s) * xl**(0.45d0*s)
39658  xsea0 = 0.209d0 * x1**4
39659  ENDIF
39660  ENDIF
39661 
39662 C...Threshold factors for c and b sea.
39663  sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
39664  xchm=0d0
39665  IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
39666  sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
39667  IF(iset.EQ.0) THEN
39668  xchm=xsea*(1d0-(sch/sll)**2)
39669  ELSE
39670  xchm=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sch/sll)
39671  ENDIF
39672  ENDIF
39673  xbot=0d0
39674  IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
39675  sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
39676  IF(iset.EQ.0) THEN
39677  xbot=xsea*(1d0-(sbt/sll)**2)
39678  ELSE
39679  xbot=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sbt/sll)
39680  ENDIF
39681  ENDIF
39682 
39683 C...Fill parton distributions.
39684  xpga(0)=xglu
39685  xpga(1)=xsea
39686  xpga(2)=xsea
39687  xpga(3)=xsea
39688  xpga(4)=xchm
39689  xpga(5)=xbot
39690  xpga(kfa)=xpga(kfa)+xval
39691  DO 110 kfl=1,5
39692  xpga(-kfl)=xpga(kfl)
39693  110 CONTINUE
39694  vxpga(kfa)=xval
39695  vxpga(-kfa)=xval
39696 
39697  RETURN
39698  END
39699 
39700 C*********************************************************************
39701 
39702 C...PYGANO
39703 C...Evaluates the parton distributions of the anomalous photon,
39704 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39705 C...KF=0 gives the sum over (up to) 5 flavours,
39706 C...KF<0 limits to flavours up to abs(KF),
39707 C...KF>0 is for flavour KF only.
39708 C...ALAM is the 4-flavour Lambda, which is automatically converted
39709 C...to 3- and 5-flavour equivalents as needed.
39710 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39711 
39712  SUBROUTINE pygano(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39713 
39714 C...Double precision and integer declarations.
39715  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39716  IMPLICIT INTEGER(I-N)
39717  INTEGER PYK,PYCHGE,PYCOMP
39718 C...Local arrays and data.
39719  dimension xpga(-6:6), vxpga(-6:6), alamsq(3:5)
39720  DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
39721 
39722 C...Reset output.
39723  DO 100 kfl=-6,6
39724  xpga(kfl)=0d0
39725  vxpga(kfl)=0d0
39726  100 CONTINUE
39727  IF(q2.LE.p2) RETURN
39728  kfa=iabs(kf)
39729 
39730 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39731  alamsq(3)=(alam*(pmc/alam)**(2d0/27d0))**2
39732  alamsq(4)=alam**2
39733  alamsq(5)=(alam*(alam/pmb)**(2d0/23d0))**2
39734  p2eff=max(p2,1.2d0*alamsq(3))
39735  IF(kf.EQ.4) p2eff=max(p2eff,pmc**2)
39736  IF(kf.EQ.5) p2eff=max(p2eff,pmb**2)
39737  q2eff=max(q2,p2eff)
39738  xl=-log(x)
39739 
39740 C...Find number of flavours at lower and upper scale.
39741  nfp=4
39742  IF(p2eff.LT.pmc**2) nfp=3
39743  IF(p2eff.GT.pmb**2) nfp=5
39744  nfq=4
39745  IF(q2eff.LT.pmc**2) nfq=3
39746  IF(q2eff.GT.pmb**2) nfq=5
39747 
39748 C...Define range of flavour loop.
39749  IF(kf.EQ.0) THEN
39750  kflmn=1
39751  kflmx=5
39752  ELSEIF(kf.LT.0) THEN
39753  kflmn=1
39754  kflmx=kfa
39755  ELSE
39756  kflmn=kfa
39757  kflmx=kfa
39758  ENDIF
39759 
39760 C...Loop over flavours the photon can branch into.
39761  DO 110 kfl=kflmn,kflmx
39762 
39763 C...Light flavours: calculate t range and (approximate) s range.
39764  IF(kfl.LE.3.AND.(kfl.EQ.1.OR.kfl.EQ.kf)) THEN
39765  tdiff=log(q2eff/p2eff)
39766  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
39767  & log(p2eff/alamsq(nfq)))
39768  IF(nfq.GT.nfp) THEN
39769  q2div=pmb**2
39770  IF(nfq.EQ.4) q2div=pmc**2
39771  snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
39772  & log(p2eff/alamsq(nfq)))
39773  snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
39774  & log(p2eff/alamsq(nfq-1)))
39775  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
39776  ENDIF
39777  IF(nfq.EQ.5.AND.nfp.EQ.3) THEN
39778  q2div=pmc**2
39779  snf4=(6d0/(33d0-2d0*4))*log(log(q2div/alamsq(4))/
39780  & log(p2eff/alamsq(4)))
39781  snf3=(6d0/(33d0-2d0*3))*log(log(q2div/alamsq(3))/
39782  & log(p2eff/alamsq(3)))
39783  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snf3-snf4)
39784  ENDIF
39785 
39786 C...u and s quark do not need a separate treatment when d has been done.
39787  ELSEIF(kfl.EQ.2.OR.kfl.EQ.3) THEN
39788 
39789 C...Charm: as above, but only include range above c threshold.
39790  ELSEIF(kfl.EQ.4) THEN
39791  IF(q2.LE.pmc**2) GOTO 110
39792  p2eff=max(p2eff,pmc**2)
39793  q2eff=max(q2eff,p2eff)
39794  tdiff=log(q2eff/p2eff)
39795  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
39796  & log(p2eff/alamsq(nfq)))
39797  IF(nfq.EQ.5.AND.nfp.EQ.4) THEN
39798  q2div=pmb**2
39799  snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
39800  & log(p2eff/alamsq(nfq)))
39801  snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
39802  & log(p2eff/alamsq(nfq-1)))
39803  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
39804  ENDIF
39805 
39806 C...Bottom: as above, but only include range above b threshold.
39807  ELSEIF(kfl.EQ.5) THEN
39808  IF(q2.LE.pmb**2) GOTO 110
39809  p2eff=max(p2eff,pmb**2)
39810  q2eff=max(q2,p2eff)
39811  tdiff=log(q2eff/p2eff)
39812  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
39813  & log(p2eff/alamsq(nfq)))
39814  ENDIF
39815 
39816 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39817  chsq=1d0/9d0
39818  IF(kfl.EQ.2.OR.kfl.EQ.4) chsq=4d0/9d0
39819  fac=aem2pi*2d0*chsq*tdiff
39820 
39821 C...Evaluate parton distributions (normalized to unit momentum sum).
39822  IF(kfl.EQ.1.OR.kfl.EQ.4.OR.kfl.EQ.5.OR.kfl.EQ.kf) THEN
39823  xval= ((1.5d0+2.49d0*s+26.9d0*s**2)/(1d0+32.3d0*s**2)*x**2 +
39824  & (1.5d0-0.49d0*s+7.83d0*s**2)/(1d0+7.68d0*s**2)*(1d0-x)**2 +
39825  & 1.5d0*s/(1d0-3.2d0*s+7d0*s**2)*x*(1d0-x)) *
39826  & x**(1d0/(1d0+0.58d0*s)) * (1d0-x**2)**(2.5d0*s/(1d0+10d0*s))
39827  xglu= 2d0*s/(1d0+4d0*s+7d0*s**2) *
39828  & x**(-1.67d0*s/(1d0+2d0*s)) * (1d0-x**2)**(1.2d0*s) *
39829  & ((4d0*x**2+7d0*x+4d0)*(1d0-x)/3d0 - 2d0*x*(1d0+x)*xl)
39830  xsea= 0.333d0*s**2/(1d0+4.90d0*s+4.69d0*s**2+21.4d0*s**3) *
39831  & x**(-1.18d0*s/(1d0+1.22d0*s)) * (1d0-x)**(1.2d0*s) *
39832  & ((8d0-73d0*x+62d0*x**2)*(1d0-x)/9d0 +
39833  & (3d0-8d0*x**2/3d0)*x*xl + (2d0*x-1d0)*x*xl**2)
39834 
39835 C...Threshold factors for c and b sea.
39836  sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
39837  xchm=0d0
39838  IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
39839  sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
39840  xchm=xsea*(1d0-(sch/sll)**3)
39841  ENDIF
39842  xbot=0d0
39843  IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
39844  sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
39845  xbot=xsea*(1d0-(sbt/sll)**3)
39846  ENDIF
39847  ENDIF
39848 
39849 C...Add contribution of each valence flavour.
39850  xpga(0)=xpga(0)+fac*xglu
39851  xpga(1)=xpga(1)+fac*xsea
39852  xpga(2)=xpga(2)+fac*xsea
39853  xpga(3)=xpga(3)+fac*xsea
39854  xpga(4)=xpga(4)+fac*xchm
39855  xpga(5)=xpga(5)+fac*xbot
39856  xpga(kfl)=xpga(kfl)+fac*xval
39857  vxpga(kfl)=vxpga(kfl)+fac*xval
39858  110 CONTINUE
39859  DO 120 kfl=1,5
39860  xpga(-kfl)=xpga(kfl)
39861  vxpga(-kfl)=vxpga(kfl)
39862  120 CONTINUE
39863 
39864  RETURN
39865  END
39866 
39867 
39868 C*********************************************************************
39869 
39870 C...PYGBEH
39871 C...Evaluates the Bethe-Heitler cross section for heavy flavour
39872 C...production.
39873 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39874 
39875  SUBROUTINE pygbeh(KF,X,Q2,P2,PM2,XPBH)
39876 
39877 C...Double precision and integer declarations.
39878  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39879  IMPLICIT INTEGER(I-N)
39880  INTEGER PYK,PYCHGE,PYCOMP
39881 
39882 C...Local data.
39883  DATA aem2pi/0.0011614d0/
39884 
39885 C...Reset output.
39886  xpbh=0d0
39887  sigbh=0d0
39888 
39889 C...Check kinematics limits.
39890  IF(x.GE.q2/(4d0*pm2+q2+p2)) RETURN
39891  w2=q2*(1d0-x)/x-p2
39892  beta2=1d0-4d0*pm2/w2
39893  IF(beta2.LT.1d-10) RETURN
39894  beta=sqrt(beta2)
39895  rmq=4d0*pm2/q2
39896 
39897 C...Simple case: P2 = 0.
39898  IF(p2.LT.1d-4) THEN
39899  IF(beta.LT.0.99d0) THEN
39900  xbl=log((1d0+beta)/(1d0-beta))
39901  ELSE
39902  xbl=log((1d0+beta)**2*w2/(4d0*pm2))
39903  ENDIF
39904  sigbh=beta*(8d0*x*(1d0-x)-1d0-rmq*x*(1d0-x))+
39905  & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)
39906 
39907 C...Complicated case: P2 > 0, based on approximation of
39908 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
39909  ELSE
39910  rpq=1d0-4d0*x**2*p2/q2
39911  IF(rpq.GT.1d-10) THEN
39912  rpbe=sqrt(rpq*beta2)
39913  IF(rpbe.LT.0.99d0) THEN
39914  xbl=log((1d0+rpbe)/(1d0-rpbe))
39915  xbi=2d0*rpbe/(1d0-rpbe**2)
39916  ELSE
39917  rpbesn=4d0*pm2/w2+(4d0*x**2*p2/q2)*beta2
39918  xbl=log((1d0+rpbe)**2/rpbesn)
39919  xbi=2d0*rpbe/rpbesn
39920  ENDIF
39921  sigbh=beta*(6d0*x*(1d0-x)-1d0)+
39922  & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)+
39923  & xbi*(2d0*x/q2)*(pm2*x*(2d0-rmq)-p2*x)
39924  ENDIF
39925  ENDIF
39926 
39927 C...Multiply by charge-squared etc. to get parton distribution.
39928  chsq=1d0/9d0
39929  IF(iabs(kf).EQ.2.OR.iabs(kf).EQ.4) chsq=4d0/9d0
39930  xpbh=3d0*chsq*aem2pi*x*sigbh
39931 
39932  RETURN
39933  END
39934 
39935 C*********************************************************************
39936 
39937 C...PYGDIR
39938 C...Evaluates the direct contribution, i.e. the C^gamma term,
39939 C...as needed in MSbar parametrizations.
39940 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39941 
39942  SUBROUTINE pygdir(X,Q2,P2,Q02,XPGA)
39943 
39944 C...Double precision and integer declarations.
39945  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39946  IMPLICIT INTEGER(I-N)
39947  INTEGER PYK,PYCHGE,PYCOMP
39948 C...Local array and data.
39949  dimension xpga(-6:6)
39950  DATA pmc/1.3d0/, pmb/4.6d0/, aem2pi/0.0011614d0/
39951 
39952 C...Reset output.
39953  DO 100 kfl=-6,6
39954  xpga(kfl)=0d0
39955  100 CONTINUE
39956 
39957 C...Evaluate common x-dependent expression.
39958  xtmp = (x**2+(1d0-x)**2) * (-log(x)) - 1d0
39959  cgam = 3d0*aem2pi*x * (xtmp*(1d0+p2/(p2+q02)) + 6d0*x*(1d0-x))
39960 
39961 C...d, u, s part by simple charge factor.
39962  xpga(1)=(1d0/9d0)*cgam
39963  xpga(2)=(4d0/9d0)*cgam
39964  xpga(3)=(1d0/9d0)*cgam
39965 
39966 C...Also fill for antiquarks.
39967  DO 110 kf=1,5
39968  xpga(-kf)=xpga(kf)
39969  110 CONTINUE
39970 
39971  RETURN
39972  END
39973 
39974 C*********************************************************************
39975 
39976 C...PYPDPI
39977 C...Gives pi+ parton distribution according to two different
39978 C...parametrizations.
39979 
39980  SUBROUTINE pypdpi(X,Q2,XPPI)
39981 
39982 C...Double precision and integer declarations.
39983  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39984  IMPLICIT INTEGER(I-N)
39985  INTEGER PYK,PYCHGE,PYCOMP
39986 C...Commonblocks.
39987  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39988  common/pypars/mstp(200),parp(200),msti(200),pari(200)
39989  common/pyint1/mint(400),vint(400)
39990  SAVE /pydat1/,/pypars/,/pyint1/
39991 C...Local arrays.
39992  dimension xppi(-6:6),cow(3,5,4,2),xq(9),ts(6)
39993 
39994 C...The following data lines are coefficients needed in the
39995 C...Owens pion parton distribution parametrizations, see below.
39996 C...Expansion coefficients for up and down valence quark distributions.
39997  DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/
39998  &4.0000d-01, 7.0000d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
39999  &-6.2120d-02, 6.4780d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40000  &-7.1090d-03, 1.3350d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
40001  DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/
40002  &4.0000d-01, 6.2800d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40003  &-5.9090d-02, 6.4360d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40004  &-6.5240d-03, 1.4510d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
40005 C...Expansion coefficients for gluon distribution.
40006  DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/
40007  &8.8800d-01, 0.0000d+00, 3.1100d+00, 6.0000d+00, 0.0000d+00,
40008  &-1.8020d+00, -1.5760d+00, -1.3170d-01, 2.8010d+00, -1.7280d+01,
40009  &1.8120d+00, 1.2000d+00, 5.0680d-01, -1.2160d+01, 2.0490d+01/
40010  DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/
40011  &7.9400d-01, 0.0000d+00, 2.8900d+00, 6.0000d+00, 0.0000d+00,
40012  &-9.1440d-01, -1.2370d+00, 5.9660d-01, -3.6710d+00, -8.1910d+00,
40013  &5.9660d-01, 6.5820d-01, -2.5500d-01, -2.3040d+00, 7.7580d+00/
40014 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40015  DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/
40016  &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
40017  &-2.4280d-01, -2.1200d-01, 8.6730d-01, 1.2660d+00, 2.3820d+00,
40018  &1.3860d-01, 3.6710d-03, 4.7470d-02, -2.2150d+00, 3.4820d-01/
40019  DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/
40020  &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
40021  &-1.4170d-01, -1.6970d-01, -2.4740d+00, -2.5340d+00, 5.6210d-01,
40022  &-1.7400d-01, -9.6230d-02, 1.5750d+00, 1.3780d+00, -2.7010d-01/
40023 C...Expansion coefficients for charm quark sea distribution.
40024  DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/
40025  &0.0000d+00, -2.2120d-02, 2.8940d+00, 0.0000d+00, 0.0000d+00,
40026  &7.9280d-02, -3.7850d-01, 9.4330d+00, 5.2480d+00, 8.3880d+00,
40027  &-6.1340d-02, -1.0880d-01, -1.0852d+01, -7.1870d+00, -1.1610d+01/
40028  DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/
40029  &0.0000d+00, -8.8200d-02, 1.9240d+00, 0.0000d+00, 0.0000d+00,
40030  &6.2290d-02, -2.8920d-01, 2.4240d-01, -4.4630d+00, -8.3670d-01,
40031  &-4.0990d-02, -1.0820d-01, 2.0360d+00, 5.2090d+00, -4.8400d-02/
40032 
40033 C...Euler's beta function, requires ordinary Gamma function
40034  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
40035 
40036 C...Reset output array.
40037  DO 100 kfl=-6,6
40038  xppi(kfl)=0d0
40039  100 CONTINUE
40040 
40041  IF(mstp(53).LE.2) THEN
40042 C...Pion parton distributions from Owens.
40043 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40044 
40045 C...Determine set, Lambda and s expansion variable.
40046  nset=mstp(53)
40047  IF(nset.EQ.1) alam=0.2d0
40048  IF(nset.EQ.2) alam=0.4d0
40049  vint(231)=4d0
40050  IF(mstp(57).LE.0) THEN
40051  sd=0d0
40052  ELSE
40053  q2in=min(2d3,max(4d0,q2))
40054  sd=log(log(q2in/alam**2)/log(4d0/alam**2))
40055  ENDIF
40056 
40057 C...Calculate parton distributions.
40058  DO 120 kfl=1,4
40059  DO 110 is=1,5
40060  ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+
40061  & cow(3,is,kfl,nset)*sd**2
40062  110 CONTINUE
40063  IF(kfl.EQ.1) THEN
40064  xq(kfl)=x**ts(1)*(1d0-x)**ts(2)/eulbet(ts(1),ts(2)+1d0)
40065  ELSE
40066  xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
40067  & ts(5)*x**2)
40068  ENDIF
40069  120 CONTINUE
40070 
40071 C...Put into output array.
40072  xppi(0)=xq(2)
40073  xppi(1)=xq(3)/6d0
40074  xppi(2)=xq(1)+xq(3)/6d0
40075  xppi(3)=xq(3)/6d0
40076  xppi(4)=xq(4)
40077  xppi(-1)=xq(1)+xq(3)/6d0
40078  xppi(-2)=xq(3)/6d0
40079  xppi(-3)=xq(3)/6d0
40080  xppi(-4)=xq(4)
40081 
40082 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40083 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40084 C...10^-5 < x < 1.
40085  ELSE
40086 
40087 C...Determine s expansion variable and some x expressions.
40088  vint(231)=0.25d0
40089  IF(mstp(57).LE.0) THEN
40090  sd=0d0
40091  ELSE
40092  q2in=min(1d8,max(0.25d0,q2))
40093  sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
40094  ENDIF
40095  sd2=sd**2
40096  xl=-log(x)
40097  xs=sqrt(x)
40098 
40099 C...Evaluate valence, gluon and sea distributions.
40100  xfval=(0.519d0+0.180d0*sd-0.011d0*sd2)*x**(0.499d0-0.027d0*sd)*
40101  & (1d0+(0.381d0-0.419d0*sd)*xs)*(1d0-x)**(0.367d0+0.563d0*sd)
40102  xfglu=(x**(0.482d0+0.341d0*sqrt(sd))*((0.678d0+0.877d0*
40103  & sd-0.175d0*sd2)+
40104  & (0.338d0-1.597d0*sd)*xs+(-0.233d0*sd+0.406d0*sd2)*x)+
40105  & sd**0.599d0*exp(-(0.618d0+2.070d0*sd)+sqrt(3.676d0*sd**1.263d0*
40106  & xl)))*
40107  & (1d0-x)**(0.390d0+1.053d0*sd)
40108  xfsea=sd**0.55d0*(1d0-0.748d0*xs+(0.313d0+0.935d0*sd)*x)*(1d0-
40109  & x)**3.359d0*
40110  & exp(-(4.433d0+1.301d0*sd)+sqrt((9.30d0-0.887d0*sd)*sd**0.56d0*
40111  & xl))/
40112  & xl**(2.538d0-0.763d0*sd)
40113  IF(sd.LE.0.888d0) THEN
40114  xfchm=0d0
40115  ELSE
40116  xfchm=(sd-0.888d0)**1.02d0*(1d0+1.008d0*x)*(1d0-x)**(1.208d0+
40117  & 0.771d0*sd)*
40118  & exp(-(4.40d0+1.493d0*sd)+sqrt((2.032d0+1.901d0*sd)*sd**0.39d0*
40119  & xl))
40120  ENDIF
40121  IF(sd.LE.1.351d0) THEN
40122  xfbot=0d0
40123  ELSE
40124  xfbot=(sd-1.351d0)**1.03d0*(1d0-x)**(0.697d0+0.855d0*sd)*
40125  & exp(-(4.51d0+1.490d0*sd)+sqrt((3.056d0+1.694d0*sd)*sd**0.39d0*
40126  & xl))
40127  ENDIF
40128 
40129 C...Put into output array.
40130  xppi(0)=xfglu
40131  xppi(1)=xfsea
40132  xppi(2)=xfsea
40133  xppi(3)=xfsea
40134  xppi(4)=xfchm
40135  xppi(5)=xfbot
40136  DO 130 kfl=1,5
40137  xppi(-kfl)=xppi(kfl)
40138  130 CONTINUE
40139  xppi(2)=xppi(2)+xfval
40140  xppi(-1)=xppi(-1)+xfval
40141  ENDIF
40142 
40143  RETURN
40144  END
40145 
40146 C*********************************************************************
40147 
40148 C...PYPDPR
40149 C...Gives proton parton distributions according to a few different
40150 C...parametrizations.
40151 
40152  SUBROUTINE pypdpr(X,Q2,XPPR)
40153 
40154 C...Double precision and integer declarations.
40155  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40156  IMPLICIT INTEGER(I-N)
40157  INTEGER PYK,PYCHGE,PYCOMP
40158 C...Commonblocks.
40159  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40160  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
40161  common/pypars/mstp(200),parp(200),msti(200),pari(200)
40162  common/pyint1/mint(400),vint(400)
40163  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
40164 C...Arrays and data.
40165  dimension xppr(-6:6),q2min(16)
40166  DATA q2min/ 2.56d0, 2.56d0, 2.56d0, 0.4d0, 0.4d0, 0.4d0,
40167  &1.0d0, 1.0d0, 2*0d0, 0.25d0, 5d0, 5d0, 4d0, 4d0, 0d0/
40168 
40169 C...Reset output array.
40170  DO 100 kfl=-6,6
40171  xppr(kfl)=0d0
40172  100 CONTINUE
40173 
40174 C...Common preliminaries.
40175  nset=max(1,min(16,mstp(51)))
40176  IF(nset.EQ.9.OR.nset.EQ.10) nset=6
40177  vint(231)=q2min(nset)
40178  IF(mstp(57).EQ.0) THEN
40179  q2l=q2min(nset)
40180  ELSE
40181  q2l=max(q2min(nset),q2)
40182  ENDIF
40183 
40184  IF(nset.GE.1.AND.nset.LE.3) THEN
40185 C...Interface to the CTEQ 3 parton distributions.
40186  qrt=sqrt(max(1d0,q2l))
40187 
40188 C...Loop over flavours.
40189  DO 110 i=-6,6
40190  IF(i.LE.0) THEN
40191  xppr(i)=pycteq(nset,i,x,qrt)
40192  ELSEIF(i.LE.2) THEN
40193  xppr(i)=pycteq(nset,i,x,qrt)+xppr(-i)
40194  ELSE
40195  xppr(i)=xppr(-i)
40196  ENDIF
40197  110 CONTINUE
40198 
40199  ELSEIF(nset.GE.4.AND.nset.LE.6) THEN
40200 C...Interface to the GRV 94 distributions.
40201  IF(nset.EQ.4) THEN
40202  CALL pygrvl (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
40203  ELSEIF(nset.EQ.5) THEN
40204  CALL pygrvm (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
40205  ELSE
40206  CALL pygrvd (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
40207  ENDIF
40208 
40209 C...Put into output array.
40210  xppr(0)=gl
40211  xppr(-1)=0.5d0*(udb+del)
40212  xppr(-2)=0.5d0*(udb-del)
40213  xppr(-3)=sb
40214  xppr(-4)=chm
40215  xppr(-5)=bot
40216  xppr(1)=dv+xppr(-1)
40217  xppr(2)=uv+xppr(-2)
40218  xppr(3)=sb
40219  xppr(4)=chm
40220  xppr(5)=bot
40221 
40222  ELSEIF(nset.EQ.7) THEN
40223 C...Interface to the CTEQ 5L parton distributions.
40224 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40225 C...freezing x*f(x,Q2) at borders.
40226  qrt=sqrt(max(1d0,min(1d8,q2l)))
40227  xin=max(1d-6,min(1d0,x))
40228 
40229 C...Loop over flavours (with u <-> d notation mismatch).
40230  sumudb=pyct5l(-1,xin,qrt)
40231  ratudb=pyct5l(-2,xin,qrt)
40232  DO 120 i=-5,2
40233  IF(i.EQ.1) THEN
40234  xppr(i)=xin*pyct5l(2,xin,qrt)
40235  ELSEIF(i.EQ.2) THEN
40236  xppr(i)=xin*pyct5l(1,xin,qrt)
40237  ELSEIF(i.EQ.-1) THEN
40238  xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
40239  ELSEIF(i.EQ.-2) THEN
40240  xppr(i)=xin*sumudb/(1d0+ratudb)
40241  ELSE
40242  xppr(i)=xin*pyct5l(i,xin,qrt)
40243  IF(i.LT.0) xppr(-i)=xppr(i)
40244  ENDIF
40245  120 CONTINUE
40246 
40247  ELSEIF(nset.EQ.8) THEN
40248 C...Interface to the CTEQ 5M1 parton distributions.
40249  qrt=sqrt(max(1d0,min(1d8,q2l)))
40250  xin=max(1d-6,min(1d0,x))
40251 
40252 C...Loop over flavours (with u <-> d notation mismatch).
40253  sumudb=pyct5m(-1,xin,qrt)
40254  ratudb=pyct5m(-2,xin,qrt)
40255  DO 130 i=-5,2
40256  IF(i.EQ.1) THEN
40257  xppr(i)=xin*pyct5m(2,xin,qrt)
40258  ELSEIF(i.EQ.2) THEN
40259  xppr(i)=xin*pyct5m(1,xin,qrt)
40260  ELSEIF(i.EQ.-1) THEN
40261  xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
40262  ELSEIF(i.EQ.-2) THEN
40263  xppr(i)=xin*sumudb/(1d0+ratudb)
40264  ELSE
40265  xppr(i)=xin*pyct5m(i,xin,qrt)
40266  IF(i.LT.0) xppr(-i)=xppr(i)
40267  ENDIF
40268  130 CONTINUE
40269 
40270  ELSEIF(nset.GE.11.AND.nset.LE.15) THEN
40271 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40272 C...obsolete but offers backwards compatibility.
40273  CALL pypdpo(x,q2l,xppr)
40274 
40275 C...Symmetric choice for debugging only
40276  ELSEIF(nset.EQ.16) THEN
40277  xppr(0)=.5d0/x
40278  xppr(1)=.05d0/x
40279  xppr(2)=.05d0/x
40280  xppr(3)=.05d0/x
40281  xppr(4)=.05d0/x
40282  xppr(5)=.05d0/x
40283  xppr(-1)=.05d0/x
40284  xppr(-2)=.05d0/x
40285  xppr(-3)=.05d0/x
40286  xppr(-4)=.05d0/x
40287  xppr(-5)=.05d0/x
40288 
40289  ENDIF
40290 
40291  RETURN
40292  END
40293 
40294 C*********************************************************************
40295 
40296 C...PYCTEQ
40297 C...Gives the CTEQ 3 parton distribution function sets in
40298 C...parametrized form, of October 24, 1994.
40299 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40300 C...J. Qiu, W.K. Tung and H. Weerts.
40301 
40302  FUNCTION pycteq (ISET, IPRT, X, Q)
40303 
40304 C...Double precision declaration.
40305  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40306  IMPLICIT INTEGER(I-N)
40307 
40308 C...Data on Lambda values of fits, minimum Q and quark masses.
40309  dimension alm(3), qms(4:6)
40310  DATA alm / 0.177d0, 0.239d0, 0.247d0 /
40311  DATA qmn / 1.60d0 /, (qms(i), i=4,6) / 1.60d0, 5.00d0, 180.0d0 /
40312 
40313 C....Check flavour thresholds. Set up QI for SB.
40314  ip = iabs(iprt)
40315  IF(ip .GE. 4) THEN
40316  IF(q .LE. qms(ip)) THEN
40317  pycteq = 0d0
40318  RETURN
40319  ENDIF
40320  qi = qms(ip)
40321  ELSE
40322  qi = qmn
40323  ENDIF
40324 
40325 C...Use "standard lambda" of parametrization program for expansion.
40326  alam = alm(iset)
40327  sbl = log(q/alam) / log(qi/alam)
40328  sb = log(sbl)
40329  sb2 = sb*sb
40330  sb3 = sb2*sb
40331 
40332 C...Expansion for CTEQ3L.
40333  IF(iset .EQ. 1) THEN
40334  IF(iprt .EQ. 2) THEN
40335  a0=exp( 0.1907d+00+0.4205d-01*sb +0.2752d+00*sb2-
40336  & 0.3171d+00*sb3)
40337  a1= 0.4611d+00+0.2331d-01*sb -0.3403d-01*sb2+0.3174d-01*sb3
40338  a2= 0.3504d+01+0.5739d+00*sb +0.2676d+00*sb2-0.1553d+00*sb3
40339  a3= 0.7452d+01-0.6742d+01*sb +0.2849d+01*sb2-0.1964d+00*sb3
40340  a4= 0.1116d+01-0.3435d+00*sb +0.2865d+00*sb2-0.1288d+00*sb3
40341  a5= 0.6659d-01+0.2714d+00*sb -0.2688d+00*sb2+0.2763d+00*sb3
40342  ELSEIF(iprt .EQ. 1) THEN
40343  a0=exp( 0.1141d+00+0.4764d+00*sb -0.1745d+01*sb2+
40344  & 0.7728d+00*sb3)
40345  a1= 0.4275d+00-0.1290d+00*sb +0.3609d+00*sb2-0.1689d+00*sb3
40346  a2= 0.3000d+01+0.2946d+01*sb -0.4117d+01*sb2+0.1989d+01*sb3
40347  a3=-0.1302d+01+0.2322d+01*sb -0.4258d+01*sb2+0.2109d+01*sb3
40348  a4= 0.2586d+01-0.1920d+00*sb -0.3754d+00*sb2+0.2731d+00*sb3
40349  a5=-0.2251d+00-0.5374d+00*sb +0.2245d+01*sb2-0.1034d+01*sb3
40350  ELSEIF(iprt .EQ. 0) THEN
40351  a0=exp(-0.7631d+00-0.7241d+00*sb -0.1170d+01*sb2+
40352  & 0.5343d+00*sb3)
40353  a1=-0.3573d+00+0.3469d+00*sb -0.3396d+00*sb2+0.9188d-01*sb3
40354  a2= 0.5604d+01+0.7458d+00*sb -0.5082d+00*sb2+0.1844d+00*sb3
40355  a3= 0.1549d+02-0.1809d+02*sb +0.1162d+02*sb2-0.3483d+01*sb3
40356  a4= 0.9881d+00+0.1364d+00*sb -0.4421d+00*sb2+0.2051d+00*sb3
40357  a5=-0.9505d-01+0.3259d+01*sb -0.1547d+01*sb2+0.2918d+00*sb3
40358  ELSEIF(iprt .EQ. -1) THEN
40359  a0=exp(-0.2449d+01-0.3513d+01*sb +0.4529d+01*sb2-
40360  & 0.2031d+01*sb3)
40361  a1=-0.4050d+00+0.3411d+00*sb -0.3669d+00*sb2+0.1109d+00*sb3
40362  a2= 0.7470d+01-0.2982d+01*sb +0.5503d+01*sb2-0.2419d+01*sb3
40363  a3= 0.1503d+02+0.1638d+01*sb -0.8772d+01*sb2+0.3852d+01*sb3
40364  a4= 0.1137d+01-0.1006d+01*sb +0.1485d+01*sb2-0.6389d+00*sb3
40365  a5=-0.5299d+00+0.3160d+01*sb -0.3104d+01*sb2+0.1219d+01*sb3
40366  ELSEIF(iprt .EQ. -2) THEN
40367  a0=exp(-0.2740d+01-0.7987d-01*sb -0.9015d+00*sb2-
40368  & 0.9872d-01*sb3)
40369  a1=-0.3909d+00+0.1244d+00*sb -0.4487d-01*sb2+0.1277d-01*sb3
40370  a2= 0.9163d+01+0.2823d+00*sb -0.7720d+00*sb2-0.9360d-02*sb3
40371  a3= 0.1080d+02-0.3915d+01*sb -0.1153d+01*sb2+0.2649d+01*sb3
40372  a4= 0.9894d+00-0.1647d+00*sb -0.9426d-02*sb2+0.2945d-02*sb3
40373  a5=-0.3395d+00+0.6998d+00*sb +0.7000d+00*sb2-0.6730d-01*sb3
40374  ELSEIF(iprt .EQ. -3) THEN
40375  a0=exp(-0.3640d+01+0.1250d+01*sb -0.2914d+01*sb2+
40376  & 0.8390d+00*sb3)
40377  a1=-0.3595d+00-0.5259d-01*sb +0.3122d+00*sb2-0.1642d+00*sb3
40378  a2= 0.7305d+01+0.9727d+00*sb -0.9788d+00*sb2-0.5193d-01*sb3
40379  a3= 0.1198d+02-0.1799d+02*sb +0.2614d+02*sb2-0.1091d+02*sb3
40380  a4= 0.9882d+00-0.6101d+00*sb +0.9737d+00*sb2-0.4935d+00*sb3
40381  a5=-0.1186d+00-0.3231d+00*sb +0.3074d+01*sb2-0.1274d+01*sb3
40382  ELSEIF(iprt .EQ. -4) THEN
40383  a0=sb** 0.1122d+01*exp(-0.3718d+01-0.1335d+01*sb +
40384  & 0.1651d-01*sb2)
40385  a1=-0.4719d+00+0.7509d+00*sb -0.8420d+00*sb2+0.2901d+00*sb3
40386  a2= 0.6194d+01-0.1641d+01*sb +0.4907d+01*sb2-0.2523d+01*sb3
40387  a3= 0.4426d+01-0.4270d+01*sb +0.6581d+01*sb2-0.3474d+01*sb3
40388  a4= 0.2683d+00+0.9876d+00*sb -0.7612d+00*sb2+0.1780d+00*sb3
40389  a5=-0.4547d+00+0.4410d+01*sb -0.3712d+01*sb2+0.1245d+01*sb3
40390  ELSEIF(iprt .EQ. -5) THEN
40391  a0=sb** 0.9838d+00*exp(-0.2548d+01-0.7660d+01*sb +
40392  & 0.3702d+01*sb2)
40393  a1=-0.3122d+00-0.2120d+00*sb +0.5716d+00*sb2-0.3773d+00*sb3
40394  a2= 0.6257d+01-0.8214d-01*sb -0.2537d+01*sb2+0.2981d+01*sb3
40395  a3=-0.6723d+00+0.2131d+01*sb +0.9599d+01*sb2-0.7910d+01*sb3
40396  a4= 0.9169d-01+0.4295d-01*sb -0.5017d+00*sb2+0.3811d+00*sb3
40397  a5= 0.2402d+00+0.2656d+01*sb -0.1586d+01*sb2+0.2880d+00*sb3
40398  ELSEIF(iprt .EQ. -6) THEN
40399  a0=sb** 0.1001d+01*exp(-0.6934d+01+0.3050d+01*sb -
40400  & 0.6943d+00*sb2)
40401  a1=-0.1713d+00-0.5167d+00*sb +0.1241d+01*sb2-0.1703d+01*sb3
40402  a2= 0.6169d+01+0.3023d+01*sb -0.1972d+02*sb2+0.1069d+02*sb3
40403  a3= 0.4439d+01-0.1746d+02*sb +0.1225d+02*sb2+0.8350d+00*sb3
40404  a4= 0.5458d+00-0.4586d+00*sb +0.9089d+00*sb2-0.4049d+00*sb3
40405  a5= 0.3207d+01-0.3362d+01*sb +0.5877d+01*sb2-0.7659d+01*sb3
40406  ENDIF
40407 
40408 C...Expansion for CTEQ3M.
40409  ELSEIF(iset .EQ. 2) THEN
40410  IF(iprt .EQ. 2) THEN
40411  a0=exp( 0.2259d+00+0.1237d+00*sb +0.3035d+00*sb2-
40412  & 0.2935d+00*sb3)
40413  a1= 0.5085d+00+0.1651d-01*sb -0.3592d-01*sb2+0.2782d-01*sb3
40414  a2= 0.3732d+01+0.4901d+00*sb +0.2218d+00*sb2-0.1116d+00*sb3
40415  a3= 0.7011d+01-0.6620d+01*sb +0.2557d+01*sb2-0.1360d+00*sb3
40416  a4= 0.8969d+00-0.2429d+00*sb +0.1811d+00*sb2-0.6888d-01*sb3
40417  a5= 0.8636d-01+0.2558d+00*sb -0.3082d+00*sb2+0.2535d+00*sb3
40418  ELSEIF(iprt .EQ. 1) THEN
40419  a0=exp(-0.7266d+00-0.1584d+01*sb +0.1259d+01*sb2-
40420  & 0.4305d-01*sb3)
40421  a1= 0.5285d+00-0.3721d+00*sb +0.5150d+00*sb2-0.1697d+00*sb3
40422  a2= 0.4075d+01+0.8282d+00*sb -0.4496d+00*sb2+0.2107d+00*sb3
40423  a3= 0.3279d+01+0.5066d+01*sb -0.9134d+01*sb2+0.2897d+01*sb3
40424  a4= 0.4399d+00-0.5888d+00*sb +0.4802d+00*sb2-0.1664d+00*sb3
40425  a5= 0.3678d+00-0.8929d+00*sb +0.1592d+01*sb2-0.5713d+00*sb3
40426  ELSEIF(iprt .EQ. 0) THEN
40427  a0=exp(-0.2318d+00-0.9779d+00*sb -0.3783d+00*sb2+
40428  & 0.1037d-01*sb3)
40429  a1=-0.2916d+00+0.1754d+00*sb -0.1884d+00*sb2+0.6116d-01*sb3
40430  a2= 0.5349d+01+0.7460d+00*sb +0.2319d+00*sb2-0.2622d+00*sb3
40431  a3= 0.6920d+01-0.3454d+01*sb +0.2027d+01*sb2-0.7626d+00*sb3
40432  a4= 0.1013d+01+0.1423d+00*sb -0.1798d+00*sb2+0.1872d-01*sb3
40433  a5=-0.5465d-01+0.2303d+01*sb -0.9584d+00*sb2+0.3098d+00*sb3
40434  ELSEIF(iprt .EQ. -1) THEN
40435  a0=exp(-0.2328d+01-0.3061d+01*sb +0.3620d+01*sb2-
40436  & 0.1602d+01*sb3)
40437  a1=-0.3358d+00+0.3198d+00*sb -0.4210d+00*sb2+0.1571d+00*sb3
40438  a2= 0.8478d+01-0.3112d+01*sb +0.5243d+01*sb2-0.2255d+01*sb3
40439  a3= 0.1971d+02+0.3389d+00*sb -0.5268d+01*sb2+0.2099d+01*sb3
40440  a4= 0.1128d+01-0.4701d+00*sb +0.7779d+00*sb2-0.3506d+00*sb3
40441  a5=-0.4708d+00+0.3341d+01*sb -0.3375d+01*sb2+0.1353d+01*sb3
40442  ELSEIF(iprt .EQ. -2) THEN
40443  a0=exp(-0.2906d+01-0.1069d+00*sb -0.1055d+01*sb2+
40444  & 0.2496d+00*sb3)
40445  a1=-0.2875d+00+0.6571d-01*sb -0.1987d-01*sb2-0.1800d-02*sb3
40446  a2= 0.9854d+01-0.2715d+00*sb -0.7407d+00*sb2+0.2888d+00*sb3
40447  a3= 0.1583d+02-0.7687d+01*sb +0.3428d+01*sb2-0.3327d+00*sb3
40448  a4= 0.9763d+00+0.7599d-01*sb -0.2128d+00*sb2+0.6852d-01*sb3
40449  a5=-0.8444d-02+0.9434d+00*sb +0.4152d+00*sb2-0.1481d+00*sb3
40450  ELSEIF(iprt .EQ. -3) THEN
40451  a0=exp(-0.3780d+01+0.2499d+01*sb -0.4962d+01*sb2+
40452  & 0.1936d+01*sb3)
40453  a1=-0.2639d+00-0.1575d+00*sb +0.3584d+00*sb2-0.1646d+00*sb3
40454  a2= 0.8082d+01+0.2794d+01*sb -0.5438d+01*sb2+0.2321d+01*sb3
40455  a3= 0.1811d+02-0.2000d+02*sb +0.1951d+02*sb2-0.6904d+01*sb3
40456  a4= 0.9822d+00+0.4972d+00*sb -0.8690d+00*sb2+0.3415d+00*sb3
40457  a5= 0.1772d+00-0.6078d+00*sb +0.3341d+01*sb2-0.1473d+01*sb3
40458  ELSEIF(iprt .EQ. -4) THEN
40459  a0=sb** 0.1122d+01*exp(-0.4232d+01-0.1808d+01*sb +
40460  & 0.5348d+00*sb2)
40461  a1=-0.2824d+00+0.5846d+00*sb -0.7230d+00*sb2+0.2419d+00*sb3
40462  a2= 0.5683d+01-0.2948d+01*sb +0.5916d+01*sb2-0.2560d+01*sb3
40463  a3= 0.2051d+01+0.4795d+01*sb -0.4271d+01*sb2+0.4174d+00*sb3
40464  a4= 0.1737d+00+0.1717d+01*sb -0.1978d+01*sb2+0.6643d+00*sb3
40465  a5= 0.8689d+00+0.3500d+01*sb -0.3283d+01*sb2+0.1026d+01*sb3
40466  ELSEIF(iprt .EQ. -5) THEN
40467  a0=sb** 0.9906d+00*exp(-0.1496d+01-0.6576d+01*sb +
40468  & 0.1569d+01*sb2)
40469  a1=-0.2140d+00-0.6419d-01*sb -0.2741d-02*sb2+0.3185d-02*sb3
40470  a2= 0.5781d+01+0.1049d+00*sb -0.3930d+00*sb2+0.5174d+00*sb3
40471  a3=-0.9420d+00+0.5511d+00*sb +0.8817d+00*sb2+0.1903d+01*sb3
40472  a4= 0.2418d-01+0.4232d-01*sb -0.1244d-01*sb2-0.2365d-01*sb3
40473  a5= 0.7664d+00+0.1794d+01*sb -0.4917d+00*sb2-0.1284d+00*sb3
40474  ELSEIF(iprt .EQ. -6) THEN
40475  a0=sb** 0.1000d+01*exp(-0.8460d+01+0.1154d+01*sb +
40476  & 0.8838d+01*sb2)
40477  a1=-0.4316d-01-0.2976d+00*sb +0.3174d+00*sb2-0.1429d+01*sb3
40478  a2= 0.4910d+01+0.2273d+01*sb +0.5631d+01*sb2-0.1994d+02*sb3
40479  a3= 0.1190d+02-0.2000d+02*sb -0.2000d+02*sb2+0.1292d+02*sb3
40480  a4= 0.5771d+00-0.2552d+00*sb +0.7510d+00*sb2+0.6923d+00*sb3
40481  a5= 0.4402d+01-0.1627d+01*sb -0.2085d+01*sb2-0.6737d+01*sb3
40482  ENDIF
40483 
40484 C...Expansion for CTEQ3D.
40485  ELSEIF(iset .EQ. 3) THEN
40486  IF(iprt .EQ. 2) THEN
40487  a0=exp( 0.2148d+00+0.5814d-01*sb +0.2734d+00*sb2-
40488  & 0.2902d+00*sb3)
40489  a1= 0.4810d+00+0.1657d-01*sb -0.3800d-01*sb2+0.3125d-01*sb3
40490  a2= 0.3509d+01+0.3923d+00*sb +0.4010d+00*sb2-0.1932d+00*sb3
40491  a3= 0.7055d+01-0.6552d+01*sb +0.3466d+01*sb2-0.5657d+00*sb3
40492  a4= 0.1061d+01-0.3453d+00*sb +0.4089d+00*sb2-0.1817d+00*sb3
40493  a5= 0.8687d-01+0.2548d+00*sb -0.2967d+00*sb2+0.2647d+00*sb3
40494  ELSEIF(iprt .EQ. 1) THEN
40495  a0=exp( 0.3961d+00+0.4914d+00*sb -0.1728d+01*sb2+
40496  & 0.7257d+00*sb3)
40497  a1= 0.4162d+00-0.1419d+00*sb +0.3680d+00*sb2-0.1618d+00*sb3
40498  a2= 0.3248d+01+0.3028d+01*sb -0.4307d+01*sb2+0.1920d+01*sb3
40499  a3=-0.1100d+01+0.2184d+01*sb -0.3820d+01*sb2+0.1717d+01*sb3
40500  a4= 0.2082d+01-0.2756d+00*sb +0.3043d+00*sb2-0.1260d+00*sb3
40501  a5=-0.4822d+00-0.5706d+00*sb +0.2243d+01*sb2-0.9760d+00*sb3
40502  ELSEIF(iprt .EQ. 0) THEN
40503  a0=exp(-0.4665d+00-0.7554d+00*sb -0.3323d+00*sb2-
40504  & 0.2734d-04*sb3)
40505  a1=-0.3359d+00+0.2395d+00*sb -0.2377d+00*sb2+0.7059d-01*sb3
40506  a2= 0.5451d+01+0.6086d+00*sb +0.8606d-01*sb2-0.1425d+00*sb3
40507  a3= 0.1026d+02-0.9352d+01*sb +0.4879d+01*sb2-0.1150d+01*sb3
40508  a4= 0.9935d+00-0.5017d-01*sb -0.1707d-01*sb2-0.1464d-02*sb3
40509  a5=-0.4160d-01+0.2305d+01*sb -0.1063d+01*sb2+0.3211d+00*sb3
40510  ELSEIF(iprt .EQ. -1) THEN
40511  a0=exp(-0.2714d+01-0.2868d+01*sb +0.3700d+01*sb2-
40512  & 0.1671d+01*sb3)
40513  a1=-0.3893d+00+0.3341d+00*sb -0.3897d+00*sb2+0.1420d+00*sb3
40514  a2= 0.8359d+01-0.3267d+01*sb +0.5327d+01*sb2-0.2245d+01*sb3
40515  a3= 0.2359d+02-0.5669d+01*sb -0.4602d+01*sb2+0.3153d+01*sb3
40516  a4= 0.1106d+01-0.4745d+00*sb +0.7739d+00*sb2-0.3417d+00*sb3
40517  a5=-0.5557d+00+0.3433d+01*sb -0.3390d+01*sb2+0.1354d+01*sb3
40518  ELSEIF(iprt .EQ. -2) THEN
40519  a0=exp(-0.3323d+01+0.2296d+00*sb -0.1109d+01*sb2+
40520  & 0.2223d+00*sb3)
40521  a1=-0.3410d+00+0.8847d-01*sb -0.1111d-01*sb2-0.5927d-02*sb3
40522  a2= 0.9753d+01-0.5182d+00*sb -0.4670d+00*sb2+0.1921d+00*sb3
40523  a3= 0.1977d+02-0.1600d+02*sb +0.9481d+01*sb2-0.1864d+01*sb3
40524  a4= 0.9818d+00+0.2839d-02*sb -0.1188d+00*sb2+0.3584d-01*sb3
40525  a5=-0.7934d-01+0.1004d+01*sb +0.3704d+00*sb2-0.1220d+00*sb3
40526  ELSEIF(iprt .EQ. -3) THEN
40527  a0=exp(-0.3985d+01+0.2855d+01*sb -0.5208d+01*sb2+
40528  & 0.1937d+01*sb3)
40529  a1=-0.3337d+00-0.1150d+00*sb +0.3691d+00*sb2-0.1709d+00*sb3
40530  a2= 0.7968d+01+0.3641d+01*sb -0.6599d+01*sb2+0.2642d+01*sb3
40531  a3= 0.1873d+02-0.1999d+02*sb +0.1734d+02*sb2-0.5813d+01*sb3
40532  a4= 0.9731d+00+0.5082d+00*sb -0.8780d+00*sb2+0.3231d+00*sb3
40533  a5=-0.5542d-01-0.4189d+00*sb +0.3309d+01*sb2-0.1439d+01*sb3
40534  ELSEIF(iprt .EQ. -4) THEN
40535  a0=sb** 0.1105d+01*exp(-0.3952d+01-0.1901d+01*sb +
40536  & 0.5137d+00*sb2)
40537  a1=-0.3543d+00+0.6055d+00*sb -0.6941d+00*sb2+0.2278d+00*sb3
40538  a2= 0.5955d+01-0.2629d+01*sb +0.5337d+01*sb2-0.2300d+01*sb3
40539  a3= 0.1933d+01+0.4882d+01*sb -0.3810d+01*sb2+0.2290d+00*sb3
40540  a4= 0.1806d+00+0.1655d+01*sb -0.1893d+01*sb2+0.6395d+00*sb3
40541  a5= 0.4790d+00+0.3612d+01*sb -0.3152d+01*sb2+0.9684d+00*sb3
40542  ELSEIF(iprt .EQ. -5) THEN
40543  a0=sb** 0.9818d+00*exp(-0.1825d+01-0.7464d+01*sb +
40544  & 0.2143d+01*sb2)
40545  a1=-0.2604d+00-0.1400d+00*sb +0.1702d+00*sb2-0.8476d-01*sb3
40546  a2= 0.6005d+01+0.6275d+00*sb -0.2535d+01*sb2+0.2219d+01*sb3
40547  a3=-0.9067d+00+0.1149d+01*sb +0.1974d+01*sb2+0.4716d+01*sb3
40548  a4= 0.3915d-01+0.5945d-01*sb -0.9844d-01*sb2+0.2783d-01*sb3
40549  a5= 0.5500d+00+0.1994d+01*sb -0.6727d+00*sb2-0.1510d+00*sb3
40550  ELSEIF(iprt .EQ. -6) THEN
40551  a0=sb** 0.1002d+01*exp(-0.8553d+01+0.3793d+00*sb +
40552  & 0.9998d+01*sb2)
40553  a1=-0.5870d-01-0.2792d+00*sb +0.6526d+00*sb2-0.1984d+01*sb3
40554  a2= 0.4716d+01+0.4473d+00*sb +0.1128d+02*sb2-0.1937d+02*sb3
40555  a3= 0.1289d+02-0.1742d+02*sb -0.1983d+02*sb2-0.9274d+00*sb3
40556  a4= 0.5647d+00-0.2732d+00*sb +0.1074d+01*sb2+0.5981d+00*sb3
40557  a5= 0.4390d+01-0.1262d+01*sb -0.9026d+00*sb2-0.9394d+01*sb3
40558  ENDIF
40559  ENDIF
40560 
40561 C...Calculation of x * f(x, Q).
40562  pycteq = max(0d0, a0 *(x**a1) *((1d0-x)**a2) *(1d0+a3*(x**a4))
40563  & *(log(1d0+1d0/x))**a5 )
40564 
40565  RETURN
40566  END
40567 
40568 C*********************************************************************
40569 
40570 C...PYGRVL
40571 C...Gives the GRV 94 L (leading order) parton distribution function set
40572 C...in parametrized form.
40573 C...Authors: M. Glueck, E. Reya and A. Vogt.
40574 
40575  SUBROUTINE pygrvl (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40576 
40577 C...Double precision declaration.
40578  IMPLICIT DOUBLE PRECISION (a - z)
40579 
40580 C...Common expressions.
40581  mu2 = 0.23d0
40582  lam2 = 0.2322d0 * 0.2322d0
40583  s = log(log(q2/lam2) / log(mu2/lam2))
40584  ds = sqrt(s)
40585  s2 = s * s
40586  s3 = s2 * s
40587 
40588 C...uv :
40589  nu = 2.284d0 + 0.802d0 * s + 0.055d0 * s2
40590  aku = 0.590d0 - 0.024d0 * s
40591  bku = 0.131d0 + 0.063d0 * s
40592  au = -0.449d0 - 0.138d0 * s - 0.076d0 * s2
40593  bu = 0.213d0 + 2.669d0 * s - 0.728d0 * s2
40594  cu = 8.854d0 - 9.135d0 * s + 1.979d0 * s2
40595  du = 2.997d0 + 0.753d0 * s - 0.076d0 * s2
40596  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
40597 
40598 C...dv :
40599  nd = 0.371d0 + 0.083d0 * s + 0.039d0 * s2
40600  akd = 0.376d0
40601  bkd = 0.486d0 + 0.062d0 * s
40602  ad = -0.509d0 + 3.310d0 * s - 1.248d0 * s2
40603  bd = 12.41d0 - 10.52d0 * s + 2.267d0 * s2
40604  cd = 6.373d0 - 6.208d0 * s + 1.418d0 * s2
40605  dd = 3.691d0 + 0.799d0 * s - 0.071d0 * s2
40606  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
40607 
40608 C...del :
40609  ne = 0.082d0 + 0.014d0 * s + 0.008d0 * s2
40610  ake = 0.409d0 - 0.005d0 * s
40611  bke = 0.799d0 + 0.071d0 * s
40612  ae = -38.07d0 + 36.13d0 * s - 0.656d0 * s2
40613  be = 90.31d0 - 74.15d0 * s + 7.645d0 * s2
40614  ce = 0.0d0
40615  de = 7.486d0 + 1.217d0 * s - 0.159d0 * s2
40616  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
40617 
40618 C...udb :
40619  alx = 1.451d0
40620  bex = 0.271d0
40621  akx = 0.410d0 - 0.232d0 * s
40622  bkx = 0.534d0 - 0.457d0 * s
40623  agx = 0.890d0 - 0.140d0 * s
40624  bgx = -0.981d0
40625  cx = 0.320d0 + 0.683d0 * s
40626  dx = 4.752d0 + 1.164d0 * s + 0.286d0 * s2
40627  ex = 4.119d0 + 1.713d0 * s
40628  esx = 0.682d0 + 2.978d0 * s
40629  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
40630  & dx, ex, esx)
40631 
40632 C...sb :
40633  sts = 0d0
40634  als = 0.914d0
40635  bes = 0.577d0
40636  aks = 1.798d0 - 0.596d0 * s
40637  as = -5.548d0 + 3.669d0 * ds - 0.616d0 * s
40638  bs = 18.92d0 - 16.73d0 * ds + 5.168d0 * s
40639  dst = 6.379d0 - 0.350d0 * s + 0.142d0 * s2
40640  est = 3.981d0 + 1.638d0 * s
40641  ess = 6.402d0
40642  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
40643 
40644 C...cb :
40645  stc = 0.888d0
40646  alc = 1.01d0
40647  bec = 0.37d0
40648  akc = 0d0
40649  ac = 0d0
40650  bc = 4.24d0 - 0.804d0 * s
40651  dct = 3.46d0 - 1.076d0 * s
40652  ect = 4.61d0 + 1.49d0 * s
40653  esc = 2.555d0 + 1.961d0 * s
40654  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
40655 
40656 C...bb :
40657  stb = 1.351d0
40658  alb = 1.00d0
40659  beb = 0.51d0
40660  akb = 0d0
40661  ab = 0d0
40662  bb = 1.848d0
40663  dbt = 2.929d0 + 1.396d0 * s
40664  ebt = 4.71d0 + 1.514d0 * s
40665  esb = 4.02d0 + 1.239d0 * s
40666  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
40667 
40668 C...gl :
40669  alg = 0.524d0
40670  beg = 1.088d0
40671  akg = 1.742d0 - 0.930d0 * s
40672  bkg = - 0.399d0 * s2
40673  ag = 7.486d0 - 2.185d0 * s
40674  bg = 16.69d0 - 22.74d0 * s + 5.779d0 * s2
40675  cg = -25.59d0 + 29.71d0 * s - 7.296d0 * s2
40676  dg = 2.792d0 + 2.215d0 * s + 0.422d0 * s2 - 0.104d0 * s3
40677  eg = 0.807d0 + 2.005d0 * s
40678  esg = 3.841d0 + 0.316d0 * s
40679  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg,
40680  & dg, eg, esg)
40681 
40682  RETURN
40683  END
40684 
40685 C*********************************************************************
40686 
40687 C...PYGRVM
40688 C...Gives the GRV 94 M (MSbar) parton distribution function set
40689 C...in parametrized form.
40690 C...Authors: M. Glueck, E. Reya and A. Vogt.
40691 
40692  SUBROUTINE pygrvm (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40693 
40694 C...Double precision declaration.
40695  IMPLICIT DOUBLE PRECISION (a - z)
40696 
40697 C...Common expressions.
40698  mu2 = 0.34d0
40699  lam2 = 0.248d0 * 0.248d0
40700  s = log(log(q2/lam2) / log(mu2/lam2))
40701  ds = sqrt(s)
40702  s2 = s * s
40703  s3 = s2 * s
40704 
40705 C...uv :
40706  nu = 1.304d0 + 0.863d0 * s
40707  aku = 0.558d0 - 0.020d0 * s
40708  bku = 0.183d0 * s
40709  au = -0.113d0 + 0.283d0 * s - 0.321d0 * s2
40710  bu = 6.843d0 - 5.089d0 * s + 2.647d0 * s2 - 0.527d0 * s3
40711  cu = 7.771d0 - 10.09d0 * s + 2.630d0 * s2
40712  du = 3.315d0 + 1.145d0 * s - 0.583d0 * s2 + 0.154d0 * s3
40713  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
40714 
40715 C...dv :
40716  nd = 0.102d0 - 0.017d0 * s + 0.005d0 * s2
40717  akd = 0.270d0 - 0.019d0 * s
40718  bkd = 0.260d0
40719  ad = 2.393d0 + 6.228d0 * s - 0.881d0 * s2
40720  bd = 46.06d0 + 4.673d0 * s - 14.98d0 * s2 + 1.331d0 * s3
40721  cd = 17.83d0 - 53.47d0 * s + 21.24d0 * s2
40722  dd = 4.081d0 + 0.976d0 * s - 0.485d0 * s2 + 0.152d0 * s3
40723  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
40724 
40725 C...del :
40726  ne = 0.070d0 + 0.042d0 * s - 0.011d0 * s2 + 0.004d0 * s3
40727  ake = 0.409d0 - 0.007d0 * s
40728  bke = 0.782d0 + 0.082d0 * s
40729  ae = -29.65d0 + 26.49d0 * s + 5.429d0 * s2
40730  be = 90.20d0 - 74.97d0 * s + 4.526d0 * s2
40731  ce = 0.0d0
40732  de = 8.122d0 + 2.120d0 * s - 1.088d0 * s2 + 0.231d0 * s3
40733  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
40734 
40735 C...udb :
40736  alx = 0.877d0
40737  bex = 0.561d0
40738  akx = 0.275d0
40739  bkx = 0.0d0
40740  agx = 0.997d0
40741  bgx = 3.210d0 - 1.866d0 * s
40742  cx = 7.300d0
40743  dx = 9.010d0 + 0.896d0 * ds + 0.222d0 * s2
40744  ex = 3.077d0 + 1.446d0 * s
40745  esx = 3.173d0 - 2.445d0 * ds + 2.207d0 * s
40746  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
40747  & dx, ex, esx)
40748 
40749 C...sb :
40750  sts = 0d0
40751  als = 0.756d0
40752  bes = 0.216d0
40753  aks = 1.690d0 + 0.650d0 * ds - 0.922d0 * s
40754  as = -4.329d0 + 1.131d0 * s
40755  bs = 9.568d0 - 1.744d0 * s
40756  dst = 9.377d0 + 1.088d0 * ds - 1.320d0 * s + 0.130d0 * s2
40757  est = 3.031d0 + 1.639d0 * s
40758  ess = 5.837d0 + 0.815d0 * s
40759  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
40760 
40761 C...cb :
40762  stc = 0.820d0
40763  alc = 0.98d0
40764  bec = 0d0
40765  akc = -0.625d0 - 0.523d0 * s
40766  ac = 0d0
40767  bc = 1.896d0 + 1.616d0 * s
40768  dct = 4.12d0 + 0.683d0 * s
40769  ect = 4.36d0 + 1.328d0 * s
40770  esc = 0.677d0 + 0.679d0 * s
40771  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
40772 
40773 C...bb :
40774  stb = 1.297d0
40775  alb = 0.99d0
40776  beb = 0d0
40777  akb = - 0.193d0 * s
40778  ab = 0d0
40779  bb = 0d0
40780  dbt = 3.447d0 + 0.927d0 * s
40781  ebt = 4.68d0 + 1.259d0 * s
40782  esb = 1.892d0 + 2.199d0 * s
40783  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
40784 
40785 C...gl :
40786  alg = 1.014d0
40787  beg = 1.738d0
40788  akg = 1.724d0 + 0.157d0 * s
40789  bkg = 0.800d0 + 1.016d0 * s
40790  ag = 7.517d0 - 2.547d0 * s
40791  bg = 34.09d0 - 52.21d0 * ds + 17.47d0 * s
40792  cg = 4.039d0 + 1.491d0 * s
40793  dg = 3.404d0 + 0.830d0 * s
40794  eg = -1.112d0 + 3.438d0 * s - 0.302d0 * s2
40795  esg = 3.256d0 - 0.436d0 * s
40796  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
40797 
40798  RETURN
40799  END
40800 
40801 C*********************************************************************
40802 
40803 C...PYGRVD
40804 C...Gives the GRV 94 D (DIS) parton distribution function set
40805 C...in parametrized form.
40806 C...Authors: M. Glueck, E. Reya and A. Vogt.
40807 
40808  SUBROUTINE pygrvd (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40809 
40810 C...Double precision declaration.
40811  IMPLICIT DOUBLE PRECISION (a - z)
40812 
40813 C...Common expressions.
40814  mu2 = 0.34d0
40815  lam2 = 0.248d0 * 0.248d0
40816  s = log(log(q2/lam2) / log(mu2/lam2))
40817  ds = sqrt(s)
40818  s2 = s * s
40819  s3 = s2 * s
40820 
40821 C...uv :
40822  nu = 2.484d0 + 0.116d0 * s + 0.093d0 * s2
40823  aku = 0.563d0 - 0.025d0 * s
40824  bku = 0.054d0 + 0.154d0 * s
40825  au = -0.326d0 - 0.058d0 * s - 0.135d0 * s2
40826  bu = -3.322d0 + 8.259d0 * s - 3.119d0 * s2 + 0.291d0 * s3
40827  cu = 11.52d0 - 12.99d0 * s + 3.161d0 * s2
40828  du = 2.808d0 + 1.400d0 * s - 0.557d0 * s2 + 0.119d0 * s3
40829  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
40830 
40831 C...dv :
40832  nd = 0.156d0 - 0.017d0 * s
40833  akd = 0.299d0 - 0.022d0 * s
40834  bkd = 0.259d0 - 0.015d0 * s
40835  ad = 3.445d0 + 1.278d0 * s + 0.326d0 * s2
40836  bd = -6.934d0 + 37.45d0 * s - 18.95d0 * s2 + 1.463d0 * s3
40837  cd = 55.45d0 - 69.92d0 * s + 20.78d0 * s2
40838  dd = 3.577d0 + 1.441d0 * s - 0.683d0 * s2 + 0.179d0 * s3
40839  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
40840 
40841 C...del :
40842  ne = 0.099d0 + 0.019d0 * s + 0.002d0 * s2
40843  ake = 0.419d0 - 0.013d0 * s
40844  bke = 1.064d0 - 0.038d0 * s
40845  ae = -44.00d0 + 98.70d0 * s - 14.79d0 * s2
40846  be = 28.59d0 - 40.94d0 * s - 13.66d0 * s2 + 2.523d0 * s3
40847  ce = 84.57d0 - 108.8d0 * s + 31.52d0 * s2
40848  de = 7.469d0 + 2.480d0 * s - 0.866d0 * s2
40849  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
40850 
40851 C...udb :
40852  alx = 1.215d0
40853  bex = 0.466d0
40854  akx = 0.326d0 + 0.150d0 * s
40855  bkx = 0.956d0 + 0.405d0 * s
40856  agx = 0.272d0
40857  bgx = 3.794d0 - 2.359d0 * ds
40858  cx = 2.014d0
40859  dx = 7.941d0 + 0.534d0 * ds - 0.940d0 * s + 0.410d0 * s2
40860  ex = 3.049d0 + 1.597d0 * s
40861  esx = 4.396d0 - 4.594d0 * ds + 3.268d0 * s
40862  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
40863  & dx, ex, esx)
40864 
40865 C...sb :
40866  sts = 0d0
40867  als = 0.175d0
40868  bes = 0.344d0
40869  aks = 1.415d0 - 0.641d0 * ds
40870  as = 0.580d0 - 9.763d0 * ds + 6.795d0 * s - 0.558d0 * s2
40871  bs = 5.617d0 + 5.709d0 * ds - 3.972d0 * s
40872  dst = 13.78d0 - 9.581d0 * s + 5.370d0 * s2 - 0.996d0 * s3
40873  est = 4.546d0 + 0.372d0 * s2
40874  ess = 5.053d0 - 1.070d0 * s + 0.805d0 * s2
40875  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
40876 
40877 C...cb :
40878  stc = 0.820d0
40879  alc = 0.98d0
40880  bec = 0d0
40881  akc = -0.625d0 - 0.523d0 * s
40882  ac = 0d0
40883  bc = 1.896d0 + 1.616d0 * s
40884  dct = 4.12d0 + 0.683d0 * s
40885  ect = 4.36d0 + 1.328d0 * s
40886  esc = 0.677d0 + 0.679d0 * s
40887  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
40888 
40889 C...bb :
40890  stb = 1.297d0
40891  alb = 0.99d0
40892  beb = 0d0
40893  akb = - 0.193d0 * s
40894  ab = 0d0
40895  bb = 0d0
40896  dbt = 3.447d0 + 0.927d0 * s
40897  ebt = 4.68d0 + 1.259d0 * s
40898  esb = 1.892d0 + 2.199d0 * s
40899  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
40900 
40901 C...gl :
40902  alg = 1.258d0
40903  beg = 1.846d0
40904  akg = 2.423d0
40905  bkg = 2.427d0 + 1.311d0 * s - 0.153d0 * s2
40906  ag = 25.09d0 - 7.935d0 * s
40907  bg = -14.84d0 - 124.3d0 * ds + 72.18d0 * s
40908  cg = 590.3d0 - 173.8d0 * s
40909  dg = 5.196d0 + 1.857d0 * s
40910  eg = -1.648d0 + 3.988d0 * s - 0.432d0 * s2
40911  esg = 3.232d0 - 0.542d0 * s
40912  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
40913 
40914  RETURN
40915  END
40916 
40917 C*********************************************************************
40918 
40919 C...PYGRVV
40920 C...Auxiliary for the GRV 94 parton distribution functions
40921 C...for u and d valence and d-u sea.
40922 C...Authors: M. Glueck, E. Reya and A. Vogt.
40923 
40924  FUNCTION pygrvv (X, N, AK, BK, A, B, C, D)
40925 
40926 C...Double precision declaration.
40927  IMPLICIT DOUBLE PRECISION (a - z)
40928 
40929 C...Evaluation.
40930  dx = sqrt(x)
40931  pygrvv = n * x**ak * (1d0+ a*x**bk + x * (b + c*dx)) *
40932  & (1d0- x)**d
40933 
40934  RETURN
40935  END
40936 
40937 C*********************************************************************
40938 
40939 C...PYGRVW
40940 C...Auxiliary for the GRV 94 parton distribution functions
40941 C...for d+u sea and gluon.
40942 C...Authors: M. Glueck, E. Reya and A. Vogt.
40943 
40944  FUNCTION pygrvw (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
40945 
40946 C...Double precision declaration.
40947  IMPLICIT DOUBLE PRECISION (a - z)
40948 
40949 C...Evaluation.
40950  lx = log(1d0/x)
40951  pygrvw = (x**ak * (a + x * (b + x*c)) * lx**bk + s**al
40952  & * exp(-e + sqrt(es * s**be * lx))) * (1d0- x)**d
40953 
40954  RETURN
40955  END
40956 
40957 C*********************************************************************
40958 
40959 C...PYGRVS
40960 C...Auxiliary for the GRV 94 parton distribution functions
40961 C...for s, c and b sea.
40962 C...Authors: M. Glueck, E. Reya and A. Vogt.
40963 
40964  FUNCTION pygrvs (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
40965 
40966 C...Double precision declaration.
40967  IMPLICIT DOUBLE PRECISION (a - z)
40968 
40969 C...Evaluation.
40970  IF(s.LE.sth) THEN
40971  pygrvs = 0d0
40972  ELSE
40973  dx = sqrt(x)
40974  lx = log(1d0/x)
40975  pygrvs = (s - sth)**al / lx**ak * (1d0+ ag*dx + b*x) *
40976  & (1d0- x)**d * exp(-e + sqrt(es * s**be * lx))
40977  ENDIF
40978 
40979  RETURN
40980  END
40981 
40982 C*********************************************************************
40983 
40984 C...PYCT5L
40985 C...Auxiliary function for parametrization of CTEQ5L.
40986 C...Author: J. Pumplin 9/99.
40987 
40988 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
40989 C...in Parametrized Form
40990 C... September 15, 1999
40991 C
40992 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
40993 C... CTEQ5 PPARTON DISTRIBUTIONS"
40994 C...hep-ph/9903282
40995 
40996 C...The CTEQ5M1 set given here is an updated version of the original
40997 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
40998 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
40999 C...almost all applications.
41000 C...The improvement is in the QCD evolution which is now more
41001 C...accurate, and which agrees completely with the benchmark work
41002 C...of the HERA 96/97 Workshop.
41003 C...The differences between the parametrized and the corresponding
41004 C...table versions (on which it is based) are of similar order as
41005 C...between the two version.
41006 
41007 C...!! Because accurate parametrizations over a wide range of (x,Q)
41008 C...is hard to obtain, only the most widely used sets CTEQ5M and
41009 C...CTEQ5L are available in parametrized form for now.
41010 
41011 C...These parametrizations were obtained by Jon Pumplin.
41012 
41013 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41014 C -------------------------------------------------------------------
41015 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41016 C 3 CTEQ5L Leading Order 0.127 192 146
41017 C -------------------------------------------------------------------
41018 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41019 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41020 C...calibration.
41021 
41022 C...The two Iset value are adopted to agree with the standard table
41023 C...versions.
41024 
41025 C...Range of validity:
41026 C...The range of (x, Q) covered by this parametrization of the QCD
41027 C...evolved parton distributions is 1E-6 < x < 1 ;
41028 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41029 C...data only in a subset of that region; and the assumed DGLAP
41030 C...evolution is unlikely to be valid for all of it either.
41031 
41032 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41033 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41034 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41035 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41036 
41037  FUNCTION pyct5l(IFL,X,Q)
41038 
41039 C...Double precision declaration.
41040  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41041  IMPLICIT INTEGER(I-N)
41042 
41043  parameter(nex=8, nlf=2)
41044  dimension am(0:nex,0:nlf,-5:2)
41045  dimension alfvec(-5:2), qmavec(-5:2)
41046  dimension mexvec(-5:2), mlfvec(-5:2)
41047  dimension ut1vec(-5:2), ut2vec(-5:2)
41048  dimension af(0:nex)
41049 
41050  DATA mexvec( 2) / 8 /
41051  DATA mlfvec( 2) / 2 /
41052  DATA ut1vec( 2) / 0.4971265e+01 /
41053  DATA ut2vec( 2) / -0.1105128e+01 /
41054  DATA alfvec( 2) / 0.2987216e+00 /
41055  DATA qmavec( 2) / 0.0000000e+00 /
41056  DATA (am( 0,k, 2),k=0, 2)
41057  & / 0.5292616e+01, -0.2751910e+01, -0.2488990e+01 /
41058  DATA (am( 1,k, 2),k=0, 2)
41059  & / 0.9714424e+00, 0.1011827e-01, -0.1023660e-01 /
41060  DATA (am( 2,k, 2),k=0, 2)
41061  & / -0.1651006e+02, 0.7959721e+01, 0.8810563e+01 /
41062  DATA (am( 3,k, 2),k=0, 2)
41063  & / -0.1643394e+02, 0.5892854e+01, 0.9348874e+01 /
41064  DATA (am( 4,k, 2),k=0, 2)
41065  & / 0.3067422e+02, 0.4235796e+01, -0.5112136e+00 /
41066  DATA (am( 5,k, 2),k=0, 2)
41067  & / 0.2352526e+02, -0.5305168e+01, -0.1169174e+02 /
41068  DATA (am( 6,k, 2),k=0, 2)
41069  & / -0.1095451e+02, 0.3006577e+01, 0.5638136e+01 /
41070  DATA (am( 7,k, 2),k=0, 2)
41071  & / -0.1172251e+02, -0.2183624e+01, 0.4955794e+01 /
41072  DATA (am( 8,k, 2),k=0, 2)
41073  & / 0.1662533e-01, 0.7622870e-02, -0.4895887e-03 /
41074 
41075  DATA mexvec( 1) / 8 /
41076  DATA mlfvec( 1) / 2 /
41077  DATA ut1vec( 1) / 0.2612618e+01 /
41078  DATA ut2vec( 1) / -0.1258304e+06 /
41079  DATA alfvec( 1) / 0.3407552e+00 /
41080  DATA qmavec( 1) / 0.0000000e+00 /
41081  DATA (am( 0,k, 1),k=0, 2)
41082  & / 0.9905300e+00, -0.4502235e+00, 0.1624441e+00 /
41083  DATA (am( 1,k, 1),k=0, 2)
41084  & / 0.8867534e+00, 0.1630829e-01, -0.4049085e-01 /
41085  DATA (am( 2,k, 1),k=0, 2)
41086  & / 0.8547974e+00, 0.3336301e+00, 0.1371388e+00 /
41087  DATA (am( 3,k, 1),k=0, 2)
41088  & / 0.2941113e+00, -0.1527905e+01, 0.2331879e+00 /
41089  DATA (am( 4,k, 1),k=0, 2)
41090  & / 0.3384235e+02, 0.3715315e+01, 0.8276930e+00 /
41091  DATA (am( 5,k, 1),k=0, 2)
41092  & / 0.6230115e+01, 0.3134639e+01, -0.1729099e+01 /
41093  DATA (am( 6,k, 1),k=0, 2)
41094  & / -0.1186928e+01, -0.3282460e+00, 0.1052020e+00 /
41095  DATA (am( 7,k, 1),k=0, 2)
41096  & / -0.8545702e+01, -0.6247947e+01, 0.3692561e+01 /
41097  DATA (am( 8,k, 1),k=0, 2)
41098  & / 0.1724598e-01, 0.7120465e-02, 0.4003646e-04 /
41099 
41100  DATA mexvec( 0) / 8 /
41101  DATA mlfvec( 0) / 2 /
41102  DATA ut1vec( 0) / -0.4656819e+00 /
41103  DATA ut2vec( 0) / -0.2742390e+03 /
41104  DATA alfvec( 0) / 0.4491863e+00 /
41105  DATA qmavec( 0) / 0.0000000e+00 /
41106  DATA (am( 0,k, 0),k=0, 2)
41107  & / 0.1193572e+03, -0.3886845e+01, -0.1133965e+01 /
41108  DATA (am( 1,k, 0),k=0, 2)
41109  & / -0.9421449e+02, 0.3995885e+01, 0.1607363e+01 /
41110  DATA (am( 2,k, 0),k=0, 2)
41111  & / 0.4206383e+01, 0.2485954e+00, 0.2497468e+00 /
41112  DATA (am( 3,k, 0),k=0, 2)
41113  & / 0.1210557e+03, -0.3015765e+01, -0.1423651e+01 /
41114  DATA (am( 4,k, 0),k=0, 2)
41115  & / -0.1013897e+03, -0.7113478e+00, 0.2621865e+00 /
41116  DATA (am( 5,k, 0),k=0, 2)
41117  & / -0.1312404e+01, -0.9297691e+00, -0.1562531e+00 /
41118  DATA (am( 6,k, 0),k=0, 2)
41119  & / 0.1627137e+01, 0.4954111e+00, -0.6387009e+00 /
41120  DATA (am( 7,k, 0),k=0, 2)
41121  & / 0.1537698e+00, -0.2487878e+00, 0.8305947e+00 /
41122  DATA (am( 8,k, 0),k=0, 2)
41123  & / 0.2496448e-01, 0.2457823e-02, 0.8234276e-03 /
41124 
41125  DATA mexvec(-1) / 8 /
41126  DATA mlfvec(-1) / 2 /
41127  DATA ut1vec(-1) / 0.3862583e+01 /
41128  DATA ut2vec(-1) / -0.1265969e+01 /
41129  DATA alfvec(-1) / 0.2457668e+00 /
41130  DATA qmavec(-1) / 0.0000000e+00 /
41131  DATA (am( 0,k,-1),k=0, 2)
41132  & / 0.2647441e+02, 0.1059277e+02, -0.9176654e+00 /
41133  DATA (am( 1,k,-1),k=0, 2)
41134  & / 0.1990636e+01, 0.8558918e-01, 0.4248667e-01 /
41135  DATA (am( 2,k,-1),k=0, 2)
41136  & / -0.1476095e+02, -0.3276255e+02, 0.1558110e+01 /
41137  DATA (am( 3,k,-1),k=0, 2)
41138  & / -0.2966889e+01, -0.3649037e+02, 0.1195914e+01 /
41139  DATA (am( 4,k,-1),k=0, 2)
41140  & / -0.1000519e+03, -0.2464635e+01, 0.1964849e+00 /
41141  DATA (am( 5,k,-1),k=0, 2)
41142  & / 0.3718331e+02, 0.4700389e+02, -0.2772142e+01 /
41143  DATA (am( 6,k,-1),k=0, 2)
41144  & / -0.1872722e+02, -0.2291189e+02, 0.1089052e+01 /
41145  DATA (am( 7,k,-1),k=0, 2)
41146  & / -0.1628146e+02, -0.1823993e+02, 0.2537369e+01 /
41147  DATA (am( 8,k,-1),k=0, 2)
41148  & / -0.1156300e+01, -0.1280495e+00, 0.5153245e-01 /
41149 
41150  DATA mexvec(-2) / 7 /
41151  DATA mlfvec(-2) / 2 /
41152  DATA ut1vec(-2) / 0.1895615e+00 /
41153  DATA ut2vec(-2) / -0.3069097e+01 /
41154  DATA alfvec(-2) / 0.5293999e+00 /
41155  DATA qmavec(-2) / 0.0000000e+00 /
41156  DATA (am( 0,k,-2),k=0, 2)
41157  & / -0.6556775e+00, 0.2490190e+00, 0.3966485e-01 /
41158  DATA (am( 1,k,-2),k=0, 2)
41159  & / 0.1305102e+01, -0.1188925e+00, -0.4600870e-02 /
41160  DATA (am( 2,k,-2),k=0, 2)
41161  & / -0.2371436e+01, 0.3566814e+00, -0.2834683e+00 /
41162  DATA (am( 3,k,-2),k=0, 2)
41163  & / -0.6152826e+01, 0.8339877e+00, -0.7233230e+00 /
41164  DATA (am( 4,k,-2),k=0, 2)
41165  & / -0.8346558e+01, 0.2892168e+01, 0.2137099e+00 /
41166  DATA (am( 5,k,-2),k=0, 2)
41167  & / 0.1279530e+02, 0.1021114e+00, 0.5787439e+00 /
41168  DATA (am( 6,k,-2),k=0, 2)
41169  & / 0.5858816e+00, -0.1940375e+01, -0.4029269e+00 /
41170  DATA (am( 7,k,-2),k=0, 2)
41171  & / -0.2795725e+02, -0.5263392e+00, 0.1290229e+01 /
41172 
41173  DATA mexvec(-3) / 7 /
41174  DATA mlfvec(-3) / 2 /
41175  DATA ut1vec(-3) / 0.3753257e+01 /
41176  DATA ut2vec(-3) / -0.1113085e+01 /
41177  DATA alfvec(-3) / 0.3713141e+00 /
41178  DATA qmavec(-3) / 0.0000000e+00 /
41179  DATA (am( 0,k,-3),k=0, 2)
41180  & / 0.1580931e+01, -0.2273826e+01, -0.1822245e+01 /
41181  DATA (am( 1,k,-3),k=0, 2)
41182  & / 0.2702644e+01, 0.6763243e+00, 0.7231586e-02 /
41183  DATA (am( 2,k,-3),k=0, 2)
41184  & / -0.1857924e+02, 0.3907500e+01, 0.5850109e+01 /
41185  DATA (am( 3,k,-3),k=0, 2)
41186  & / -0.3044793e+02, 0.2639332e+01, 0.5566644e+01 /
41187  DATA (am( 4,k,-3),k=0, 2)
41188  & / -0.4258011e+01, -0.5429244e+01, 0.4418946e+00 /
41189  DATA (am( 5,k,-3),k=0, 2)
41190  & / 0.3465259e+02, -0.5532604e+01, -0.4904153e+01 /
41191  DATA (am( 6,k,-3),k=0, 2)
41192  & / -0.1658858e+02, 0.2923275e+01, 0.2266286e+01 /
41193  DATA (am( 7,k,-3),k=0, 2)
41194  & / -0.1149263e+02, 0.2877475e+01, -0.7999105e+00 /
41195 
41196  DATA mexvec(-4) / 7 /
41197  DATA mlfvec(-4) / 2 /
41198  DATA ut1vec(-4) / 0.4400772e+01 /
41199  DATA ut2vec(-4) / -0.1356116e+01 /
41200  DATA alfvec(-4) / 0.3712017e-01 /
41201  DATA qmavec(-4) / 0.1300000e+01 /
41202  DATA (am( 0,k,-4),k=0, 2)
41203  & / -0.8293661e+00, -0.3982375e+01, -0.6494283e-01 /
41204  DATA (am( 1,k,-4),k=0, 2)
41205  & / 0.2754618e+01, 0.8338636e+00, -0.6885160e-01 /
41206  DATA (am( 2,k,-4),k=0, 2)
41207  & / -0.1657987e+02, 0.1439143e+02, -0.6887240e+00 /
41208  DATA (am( 3,k,-4),k=0, 2)
41209  & / -0.2800703e+02, 0.1535966e+02, -0.7377693e+00 /
41210  DATA (am( 4,k,-4),k=0, 2)
41211  & / -0.6460216e+01, -0.4783019e+01, 0.4913297e+00 /
41212  DATA (am( 5,k,-4),k=0, 2)
41213  & / 0.3141830e+02, -0.3178031e+02, 0.7136013e+01 /
41214  DATA (am( 6,k,-4),k=0, 2)
41215  & / -0.1802509e+02, 0.1862163e+02, -0.4632843e+01 /
41216  DATA (am( 7,k,-4),k=0, 2)
41217  & / -0.1240412e+02, 0.2565386e+02, -0.1066570e+02 /
41218 
41219  DATA mexvec(-5) / 6 /
41220  DATA mlfvec(-5) / 2 /
41221  DATA ut1vec(-5) / 0.5562568e+01 /
41222  DATA ut2vec(-5) / -0.1801317e+01 /
41223  DATA alfvec(-5) / 0.4952010e-02 /
41224  DATA qmavec(-5) / 0.4500000e+01 /
41225  DATA (am( 0,k,-5),k=0, 2)
41226  & / -0.6031237e+01, 0.1992727e+01, -0.1076331e+01 /
41227  DATA (am( 1,k,-5),k=0, 2)
41228  & / 0.2933912e+01, 0.5839674e+00, 0.7509435e-01 /
41229  DATA (am( 2,k,-5),k=0, 2)
41230  & / -0.8284919e+01, 0.1488593e+01, -0.8251678e+00 /
41231  DATA (am( 3,k,-5),k=0, 2)
41232  & / -0.1925986e+02, 0.2805753e+01, -0.3015446e+01 /
41233  DATA (am( 4,k,-5),k=0, 2)
41234  & / -0.9480483e+01, -0.9767837e+00, -0.1165544e+01 /
41235  DATA (am( 5,k,-5),k=0, 2)
41236  & / 0.2193195e+02, -0.1788518e+02, 0.9460908e+01 /
41237  DATA (am( 6,k,-5),k=0, 2)
41238  & / -0.1327377e+02, 0.1201754e+02, -0.6277844e+01 /
41239 
41240  IF(q .LE. qmavec(ifl)) THEN
41241  pyct5l = 0.d0
41242  RETURN
41243  ENDIF
41244 
41245  IF(x .GE. 1.d0) THEN
41246  pyct5l = 0.d0
41247  RETURN
41248  ENDIF
41249 
41250  tmp = log(q/alfvec(ifl))
41251  IF(tmp .LE. 0.d0) THEN
41252  pyct5l = 0.d0
41253  RETURN
41254  ENDIF
41255 
41256  sb = log(tmp)
41257  sb1 = sb - 1.2d0
41258  sb2 = sb1*sb1
41259 
41260  DO 110 i = 0, nex
41261  af(i) = 0.d0
41262  sbx = 1.d0
41263  DO 100 k = 0, mlfvec(ifl)
41264  af(i) = af(i) + sbx*am(i,k,ifl)
41265  sbx = sb1*sbx
41266  100 CONTINUE
41267  110 CONTINUE
41268 
41269  y = -log(x)
41270  u = log(x/0.00001d0)
41271 
41272  part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
41273  part2 = af(0)*(1.d0 - x) + af(3)*x
41274  part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
41275  part4 = ut1vec(ifl)*log(1.d0-x) +
41276  & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
41277 
41278  pyct5l = exp(log(x) + part1 + part2 + part3 + part4)
41279 
41280 C...Include threshold factor.
41281  pyct5l = pyct5l * (1.d0 - qmavec(ifl)/q)
41282 
41283  RETURN
41284  END
41285 
41286 C*********************************************************************
41287 
41288 C...PYCT5M
41289 C...Auxiliary function for parametrization of CTEQ5M1.
41290 C...Author: J. Pumplin 9/99.
41291 
41292  FUNCTION pyct5m(IFL,X,Q)
41293 
41294 C...Double precision declaration.
41295  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41296  IMPLICIT INTEGER(I-N)
41297 
41298  parameter(nex=8, nlf=2)
41299  dimension am(0:nex,0:nlf,-5:2)
41300  dimension alfvec(-5:2), qmavec(-5:2)
41301  dimension mexvec(-5:2), mlfvec(-5:2)
41302  dimension ut1vec(-5:2), ut2vec(-5:2)
41303  dimension af(0:nex)
41304 
41305  DATA mexvec( 2) / 8 /
41306  DATA mlfvec( 2) / 2 /
41307  DATA ut1vec( 2) / 0.5141718e+01 /
41308  DATA ut2vec( 2) / -0.1346944e+01 /
41309  DATA alfvec( 2) / 0.5260555e+00 /
41310  DATA qmavec( 2) / 0.0000000e+00 /
41311  DATA (am( 0,k, 2),k=0, 2)
41312  & / 0.4289071e+01, -0.2536870e+01, -0.1259948e+01 /
41313  DATA (am( 1,k, 2),k=0, 2)
41314  & / 0.9839410e+00, 0.4168426e-01, -0.5018952e-01 /
41315  DATA (am( 2,k, 2),k=0, 2)
41316  & / -0.1651961e+02, 0.9246261e+01, 0.5996400e+01 /
41317  DATA (am( 3,k, 2),k=0, 2)
41318  & / -0.2077936e+02, 0.9786469e+01, 0.7656465e+01 /
41319  DATA (am( 4,k, 2),k=0, 2)
41320  & / 0.3054926e+02, 0.1889536e+01, 0.1380541e+01 /
41321  DATA (am( 5,k, 2),k=0, 2)
41322  & / 0.3084695e+02, -0.1212303e+02, -0.1053551e+02 /
41323  DATA (am( 6,k, 2),k=0, 2)
41324  & / -0.1426778e+02, 0.6239537e+01, 0.5254819e+01 /
41325  DATA (am( 7,k, 2),k=0, 2)
41326  & / -0.1909811e+02, 0.3695678e+01, 0.5495729e+01 /
41327  DATA (am( 8,k, 2),k=0, 2)
41328  & / 0.1889751e-01, 0.5027193e-02, 0.6624896e-03 /
41329 
41330  DATA mexvec( 1) / 8 /
41331  DATA mlfvec( 1) / 2 /
41332  DATA ut1vec( 1) / 0.4138426e+01 /
41333  DATA ut2vec( 1) / -0.3221374e+01 /
41334  DATA alfvec( 1) / 0.4960962e+00 /
41335  DATA qmavec( 1) / 0.0000000e+00 /
41336  DATA (am( 0,k, 1),k=0, 2)
41337  & / 0.1332497e+01, -0.3703718e+00, 0.1288638e+00 /
41338  DATA (am( 1,k, 1),k=0, 2)
41339  & / 0.7544687e+00, 0.3255075e-01, -0.4706680e-01 /
41340  DATA (am( 2,k, 1),k=0, 2)
41341  & / -0.7638814e+00, 0.5008313e+00, -0.9237374e-01 /
41342  DATA (am( 3,k, 1),k=0, 2)
41343  & / -0.3689889e+00, -0.1055098e+01, -0.4645065e+00 /
41344  DATA (am( 4,k, 1),k=0, 2)
41345  & / 0.3991610e+02, 0.1979881e+01, 0.1775814e+01 /
41346  DATA (am( 5,k, 1),k=0, 2)
41347  & / 0.6201080e+01, 0.2046288e+01, 0.3804571e+00 /
41348  DATA (am( 6,k, 1),k=0, 2)
41349  & / -0.8027900e+00, -0.7011688e+00, -0.8049612e+00 /
41350  DATA (am( 7,k, 1),k=0, 2)
41351  & / -0.8631305e+01, -0.3981200e+01, 0.6970153e+00 /
41352  DATA (am( 8,k, 1),k=0, 2)
41353  & / 0.2371230e-01, 0.5372683e-02, 0.1118701e-02 /
41354 
41355  DATA mexvec( 0) / 8 /
41356  DATA mlfvec( 0) / 2 /
41357  DATA ut1vec( 0) / -0.1026789e+01 /
41358  DATA ut2vec( 0) / -0.9051707e+01 /
41359  DATA alfvec( 0) / 0.9462977e+00 /
41360  DATA qmavec( 0) / 0.0000000e+00 /
41361  DATA (am( 0,k, 0),k=0, 2)
41362  & / 0.1191990e+03, -0.8548739e+00, -0.1963040e+01 /
41363  DATA (am( 1,k, 0),k=0, 2)
41364  & / -0.9449972e+02, 0.1074771e+01, 0.2056055e+01 /
41365  DATA (am( 2,k, 0),k=0, 2)
41366  & / 0.3701064e+01, -0.1167947e-02, 0.1933573e+00 /
41367  DATA (am( 3,k, 0),k=0, 2)
41368  & / 0.1171345e+03, -0.1064540e+01, -0.1875312e+01 /
41369  DATA (am( 4,k, 0),k=0, 2)
41370  & / -0.1014453e+03, -0.5707427e+00, 0.4511242e-01 /
41371  DATA (am( 5,k, 0),k=0, 2)
41372  & / 0.6365168e+01, 0.1275354e+01, -0.4964081e+00 /
41373  DATA (am( 6,k, 0),k=0, 2)
41374  & / -0.3370693e+01, -0.1122020e+01, 0.5947751e-01 /
41375  DATA (am( 7,k, 0),k=0, 2)
41376  & / -0.5327270e+01, -0.9293556e+00, 0.6629940e+00 /
41377  DATA (am( 8,k, 0),k=0, 2)
41378  & / 0.2437513e-01, 0.1600939e-02, 0.6855336e-03 /
41379 
41380  DATA mexvec(-1) / 8 /
41381  DATA mlfvec(-1) / 2 /
41382  DATA ut1vec(-1) / 0.5243571e+01 /
41383  DATA ut2vec(-1) / -0.2870513e+01 /
41384  DATA alfvec(-1) / 0.6701448e+00 /
41385  DATA qmavec(-1) / 0.0000000e+00 /
41386  DATA (am( 0,k,-1),k=0, 2)
41387  & / 0.2428863e+02, 0.1907035e+01, -0.4606457e+00 /
41388  DATA (am( 1,k,-1),k=0, 2)
41389  & / 0.2006810e+01, -0.1265915e+00, 0.7153556e-02 /
41390  DATA (am( 2,k,-1),k=0, 2)
41391  & / -0.1884546e+02, -0.2339471e+01, 0.5740679e+01 /
41392  DATA (am( 3,k,-1),k=0, 2)
41393  & / -0.2527892e+02, -0.2044124e+01, 0.1280470e+02 /
41394  DATA (am( 4,k,-1),k=0, 2)
41395  & / -0.1013824e+03, -0.1594199e+01, 0.2216401e+00 /
41396  DATA (am( 5,k,-1),k=0, 2)
41397  & / 0.8070930e+02, 0.1792072e+01, -0.2164364e+02 /
41398  DATA (am( 6,k,-1),k=0, 2)
41399  & / -0.4641050e+02, 0.1977338e+00, 0.1273014e+02 /
41400  DATA (am( 7,k,-1),k=0, 2)
41401  & / -0.3910568e+02, 0.1719632e+01, 0.1086525e+02 /
41402  DATA (am( 8,k,-1),k=0, 2)
41403  & / -0.1185496e+01, -0.1905847e+00, -0.8744118e-03 /
41404 
41405  DATA mexvec(-2) / 7 /
41406  DATA mlfvec(-2) / 2 /
41407  DATA ut1vec(-2) / 0.4782210e+01 /
41408  DATA ut2vec(-2) / -0.1976856e+02 /
41409  DATA alfvec(-2) / 0.7558374e+00 /
41410  DATA qmavec(-2) / 0.0000000e+00 /
41411  DATA (am( 0,k,-2),k=0, 2)
41412  & / -0.6216935e+00, 0.2369963e+00, -0.7909949e-02 /
41413  DATA (am( 1,k,-2),k=0, 2)
41414  & / 0.1245440e+01, -0.1031510e+00, 0.4916523e-02 /
41415  DATA (am( 2,k,-2),k=0, 2)
41416  & / -0.7060824e+01, -0.3875283e-01, 0.1784981e+00 /
41417  DATA (am( 3,k,-2),k=0, 2)
41418  & / -0.7430595e+01, 0.1964572e+00, -0.1284999e+00 /
41419  DATA (am( 4,k,-2),k=0, 2)
41420  & / -0.6897810e+01, 0.2620543e+01, 0.8012553e-02 /
41421  DATA (am( 5,k,-2),k=0, 2)
41422  & / 0.1507713e+02, 0.2340307e-01, 0.2482535e+01 /
41423  DATA (am( 6,k,-2),k=0, 2)
41424  & / -0.1815341e+01, -0.1538698e+01, -0.2014208e+01 /
41425  DATA (am( 7,k,-2),k=0, 2)
41426  & / -0.2571932e+02, 0.2903941e+00, -0.2848206e+01 /
41427 
41428  DATA mexvec(-3) / 7 /
41429  DATA mlfvec(-3) / 2 /
41430  DATA ut1vec(-3) / 0.4518239e+01 /
41431  DATA ut2vec(-3) / -0.2690590e+01 /
41432  DATA alfvec(-3) / 0.6124079e+00 /
41433  DATA qmavec(-3) / 0.0000000e+00 /
41434  DATA (am( 0,k,-3),k=0, 2)
41435  & / -0.2734458e+01, -0.7245673e+00, -0.6351374e+00 /
41436  DATA (am( 1,k,-3),k=0, 2)
41437  & / 0.2927174e+01, 0.4822709e+00, -0.1088787e-01 /
41438  DATA (am( 2,k,-3),k=0, 2)
41439  & / -0.1771017e+02, -0.1416635e+01, 0.8467622e+01 /
41440  DATA (am( 3,k,-3),k=0, 2)
41441  & / -0.4972782e+02, -0.3348547e+01, 0.1767061e+02 /
41442  DATA (am( 4,k,-3),k=0, 2)
41443  & / -0.7102770e+01, -0.3205337e+01, 0.4101704e+00 /
41444  DATA (am( 5,k,-3),k=0, 2)
41445  & / 0.7169698e+02, -0.2205985e+01, -0.2463931e+02 /
41446  DATA (am( 6,k,-3),k=0, 2)
41447  & / -0.4090347e+02, 0.2103486e+01, 0.1416507e+02 /
41448  DATA (am( 7,k,-3),k=0, 2)
41449  & / -0.2952639e+02, 0.5376136e+01, 0.7825585e+01 /
41450 
41451  DATA mexvec(-4) / 7 /
41452  DATA mlfvec(-4) / 2 /
41453  DATA ut1vec(-4) / 0.2783230e+01 /
41454  DATA ut2vec(-4) / -0.1746328e+01 /
41455  DATA alfvec(-4) / 0.1115653e+01 /
41456  DATA qmavec(-4) / 0.1300000e+01 /
41457  DATA (am( 0,k,-4),k=0, 2)
41458  & / -0.1743872e+01, -0.1128921e+01, -0.2841969e+00 /
41459  DATA (am( 1,k,-4),k=0, 2)
41460  & / 0.3345755e+01, 0.3187765e+00, 0.1378124e+00 /
41461  DATA (am( 2,k,-4),k=0, 2)
41462  & / -0.2037615e+02, 0.4121687e+01, 0.2236520e+00 /
41463  DATA (am( 3,k,-4),k=0, 2)
41464  & / -0.4703104e+02, 0.5353087e+01, -0.1455347e+01 /
41465  DATA (am( 4,k,-4),k=0, 2)
41466  & / -0.1060230e+02, -0.1551122e+01, -0.1078863e+01 /
41467  DATA (am( 5,k,-4),k=0, 2)
41468  & / 0.5088892e+02, -0.8197304e+01, 0.8083451e+01 /
41469  DATA (am( 6,k,-4),k=0, 2)
41470  & / -0.2819070e+02, 0.4554086e+01, -0.5890995e+01 /
41471  DATA (am( 7,k,-4),k=0, 2)
41472  & / -0.1098238e+02, 0.2590096e+01, -0.8062879e+01 /
41473 
41474  DATA mexvec(-5) / 6 /
41475  DATA mlfvec(-5) / 2 /
41476  DATA ut1vec(-5) / 0.1619654e+02 /
41477  DATA ut2vec(-5) / -0.3367346e+01 /
41478  DATA alfvec(-5) / 0.5109891e-02 /
41479  DATA qmavec(-5) / 0.4500000e+01 /
41480  DATA (am( 0,k,-5),k=0, 2)
41481  & / -0.6800138e+01, 0.2493627e+01, -0.1075724e+01 /
41482  DATA (am( 1,k,-5),k=0, 2)
41483  & / 0.3036555e+01, 0.3324733e+00, 0.2008298e+00 /
41484  DATA (am( 2,k,-5),k=0, 2)
41485  & / -0.5203879e+01, -0.8493476e+01, -0.4523208e+01 /
41486  DATA (am( 3,k,-5),k=0, 2)
41487  & / -0.1524239e+01, -0.3411912e+01, -0.1771867e+02 /
41488  DATA (am( 4,k,-5),k=0, 2)
41489  & / -0.1099444e+02, 0.1320930e+01, -0.2353831e+01 /
41490  DATA (am( 5,k,-5),k=0, 2)
41491  & / 0.1699299e+02, -0.3565802e+02, 0.3566872e+02 /
41492  DATA (am( 6,k,-5),k=0, 2)
41493  & / -0.1465793e+02, 0.2703365e+02, -0.2176372e+02 /
41494 
41495  IF(q .LE. qmavec(ifl)) THEN
41496  pyct5m = 0.d0
41497  RETURN
41498  ENDIF
41499 
41500  IF(x .GE. 1.d0) THEN
41501  pyct5m = 0.d0
41502  RETURN
41503  ENDIF
41504 
41505  tmp = log(q/alfvec(ifl))
41506  IF(tmp .LE. 0.d0) THEN
41507  pyct5m = 0.d0
41508  RETURN
41509  ENDIF
41510 
41511  sb = log(tmp)
41512  sb1 = sb - 1.2d0
41513  sb2 = sb1*sb1
41514 
41515  DO 110 i = 0, nex
41516  af(i) = 0.d0
41517  sbx = 1.d0
41518  DO 100 k = 0, mlfvec(ifl)
41519  af(i) = af(i) + sbx*am(i,k,ifl)
41520  sbx = sb1*sbx
41521  100 CONTINUE
41522  110 CONTINUE
41523 
41524  y = -log(x)
41525  u = log(x/0.00001d0)
41526 
41527  part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
41528  part2 = af(0)*(1.d0 - x) + af(3)*x
41529  part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
41530  part4 = ut1vec(ifl)*log(1.d0-x) +
41531  & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
41532 
41533  pyct5m = exp(log(x) + part1 + part2 + part3 + part4)
41534 
41535 C...Include threshold factor.
41536  pyct5m = pyct5m * (1.d0 - qmavec(ifl)/q)
41537 
41538  RETURN
41539  END
41540 
41541 C*********************************************************************
41542 
41543 C...PYPDPO
41544 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41545 C...a few older parametrizations, now obsolete but convenient for
41546 C...backwards checks.
41547 
41548  SUBROUTINE pypdpo(X,Q2,XPPR)
41549 
41550 C...Double precision and integer declarations.
41551  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41552  IMPLICIT INTEGER(I-N)
41553  INTEGER PYK,PYCHGE,PYCOMP
41554 C...Commonblocks.
41555  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41556  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
41557  common/pypars/mstp(200),parp(200),msti(200),pari(200)
41558  common/pyint1/mint(400),vint(400)
41559  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
41560  dimension xppr(-6:6),xq(9),tx(6),tt(6),ts(6),nehlq(8,2),
41561  &cehlq(6,6,2,8,2),cdo(3,6,5,2)
41562 
41563 
41564 C...The following data lines are coefficients needed in the
41565 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41566 C...parametrizations, see below.
41567 C...Powers of 1-x in different cases.
41568  DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41569 C...Expansion coefficients for up valence quark distribution.
41570  DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/
41571  1 7.677d-01,-2.087d-01,-3.303d-01,-2.517d-02,-1.570d-02,-1.000d-04,
41572  2-5.326d-01,-2.661d-01, 3.201d-01, 1.192d-01, 2.434d-02, 7.620d-03,
41573  3 2.162d-01, 1.881d-01,-8.375d-02,-6.515d-02,-1.743d-02,-5.040d-03,
41574  4-9.211d-02,-9.952d-02, 1.373d-02, 2.506d-02, 8.770d-03, 2.550d-03,
41575  5 3.670d-02, 4.409d-02, 9.600d-04,-7.960d-03,-3.420d-03,-1.050d-03,
41576  6-1.549d-02,-2.026d-02,-3.060d-03, 2.220d-03, 1.240d-03, 4.100d-04,
41577  1 2.395d-01, 2.905d-01, 9.778d-02, 2.149d-02, 3.440d-03, 5.000d-04,
41578  2 1.751d-02,-6.090d-03,-2.687d-02,-1.916d-02,-7.970d-03,-2.750d-03,
41579  3-5.760d-03,-5.040d-03, 1.080d-03, 2.490d-03, 1.530d-03, 7.500d-04,
41580  4 1.740d-03, 1.960d-03, 3.000d-04,-3.400d-04,-2.900d-04,-1.800d-04,
41581  5-5.300d-04,-6.400d-04,-1.700d-04, 4.000d-05, 6.000d-05, 4.000d-05,
41582  6 1.700d-04, 2.200d-04, 8.000d-05, 1.000d-05,-1.000d-05,-1.000d-05/
41583  DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/
41584  1 7.237d-01,-2.189d-01,-2.995d-01,-1.909d-02,-1.477d-02, 2.500d-04,
41585  2-5.314d-01,-2.425d-01, 3.283d-01, 1.119d-01, 2.223d-02, 7.070d-03,
41586  3 2.289d-01, 1.890d-01,-9.859d-02,-6.900d-02,-1.747d-02,-5.080d-03,
41587  4-1.041d-01,-1.084d-01, 2.108d-02, 2.975d-02, 9.830d-03, 2.830d-03,
41588  5 4.394d-02, 5.116d-02,-1.410d-03,-1.055d-02,-4.230d-03,-1.270d-03,
41589  6-1.991d-02,-2.539d-02,-2.780d-03, 3.430d-03, 1.720d-03, 5.500d-04,
41590  1 2.410d-01, 2.884d-01, 9.369d-02, 1.900d-02, 2.530d-03, 2.400d-04,
41591  2 1.765d-02,-9.220d-03,-3.037d-02,-2.085d-02,-8.440d-03,-2.810d-03,
41592  3-6.450d-03,-5.260d-03, 1.720d-03, 3.110d-03, 1.830d-03, 8.700d-04,
41593  4 2.120d-03, 2.320d-03, 2.600d-04,-4.900d-04,-3.900d-04,-2.300d-04,
41594  5-6.900d-04,-8.200d-04,-2.000d-04, 7.000d-05, 9.000d-05, 6.000d-05,
41595  6 2.400d-04, 3.100d-04, 1.100d-04, 0.000d+00,-2.000d-05,-2.000d-05/
41596 C...Expansion coefficients for down valence quark distribution.
41597  DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/
41598  1 3.813d-01,-8.090d-02,-1.634d-01,-2.185d-02,-8.430d-03,-6.200d-04,
41599  2-2.948d-01,-1.435d-01, 1.665d-01, 6.638d-02, 1.473d-02, 4.080d-03,
41600  3 1.252d-01, 1.042d-01,-4.722d-02,-3.683d-02,-1.038d-02,-2.860d-03,
41601  4-5.478d-02,-5.678d-02, 8.900d-03, 1.484d-02, 5.340d-03, 1.520d-03,
41602  5 2.220d-02, 2.567d-02,-3.000d-05,-4.970d-03,-2.160d-03,-6.500d-04,
41603  6-9.530d-03,-1.204d-02,-1.510d-03, 1.510d-03, 8.300d-04, 2.700d-04,
41604  1 1.261d-01, 1.354d-01, 3.958d-02, 8.240d-03, 1.660d-03, 4.500d-04,
41605  2 3.890d-03,-1.159d-02,-1.625d-02,-9.610d-03,-3.710d-03,-1.260d-03,
41606  3-1.910d-03,-5.600d-04, 1.590d-03, 1.590d-03, 8.400d-04, 3.900d-04,
41607  4 6.400d-04, 4.900d-04,-1.500d-04,-2.900d-04,-1.800d-04,-1.000d-04,
41608  5-2.000d-04,-1.900d-04, 0.000d+00, 6.000d-05, 4.000d-05, 3.000d-05,
41609  6 7.000d-05, 8.000d-05, 2.000d-05,-1.000d-05,-1.000d-05,-1.000d-05/
41610  DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/
41611  1 3.578d-01,-8.622d-02,-1.480d-01,-1.840d-02,-7.820d-03,-4.500d-04,
41612  2-2.925d-01,-1.304d-01, 1.696d-01, 6.243d-02, 1.353d-02, 3.750d-03,
41613  3 1.318d-01, 1.041d-01,-5.486d-02,-3.872d-02,-1.038d-02,-2.850d-03,
41614  4-6.162d-02,-6.143d-02, 1.303d-02, 1.740d-02, 5.940d-03, 1.670d-03,
41615  5 2.643d-02, 2.957d-02,-1.490d-03,-6.450d-03,-2.630d-03,-7.700d-04,
41616  6-1.218d-02,-1.497d-02,-1.260d-03, 2.240d-03, 1.120d-03, 3.500d-04,
41617  1 1.263d-01, 1.334d-01, 3.732d-02, 7.070d-03, 1.260d-03, 3.400d-04,
41618  2 3.660d-03,-1.357d-02,-1.795d-02,-1.031d-02,-3.880d-03,-1.280d-03,
41619  3-2.100d-03,-3.600d-04, 2.050d-03, 1.920d-03, 9.800d-04, 4.400d-04,
41620  4 7.700d-04, 5.400d-04,-2.400d-04,-3.900d-04,-2.400d-04,-1.300d-04,
41621  5-2.600d-04,-2.300d-04, 2.000d-05, 9.000d-05, 6.000d-05, 4.000d-05,
41622  6 9.000d-05, 1.000d-04, 2.000d-05,-2.000d-05,-2.000d-05,-1.000d-05/
41623 C...Expansion coefficients for up and down sea quark distributions.
41624  DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/
41625  1 6.870d-02,-6.861d-02, 2.973d-02,-5.400d-03, 3.780d-03,-9.700d-04,
41626  2-1.802d-02, 1.400d-04, 6.490d-03,-8.540d-03, 1.220d-03,-1.750d-03,
41627  3-4.650d-03, 1.480d-03,-5.930d-03, 6.000d-04,-1.030d-03,-8.000d-05,
41628  4 6.440d-03, 2.570d-03, 2.830d-03, 1.150d-03, 7.100d-04, 3.300d-04,
41629  5-3.930d-03,-2.540d-03,-1.160d-03,-7.700d-04,-3.600d-04,-1.900d-04,
41630  6 2.340d-03, 1.930d-03, 5.300d-04, 3.700d-04, 1.600d-04, 9.000d-05,
41631  1 1.014d+00,-1.106d+00, 3.374d-01,-7.444d-02, 8.850d-03,-8.700d-04,
41632  2 9.233d-01,-1.285d+00, 4.475d-01,-9.786d-02, 1.419d-02,-1.120d-03,
41633  3 4.888d-02,-1.271d-01, 8.606d-02,-2.608d-02, 4.780d-03,-6.000d-04,
41634  4-2.691d-02, 4.887d-02,-1.771d-02, 1.620d-03, 2.500d-04,-6.000d-05,
41635  5 7.040d-03,-1.113d-02, 1.590d-03, 7.000d-04,-2.000d-04, 0.000d+00,
41636  6-1.710d-03, 2.290d-03, 3.800d-04,-3.500d-04, 4.000d-05, 1.000d-05/
41637  DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/
41638  1 1.008d-01,-7.100d-02, 1.973d-02,-5.710d-03, 2.930d-03,-9.900d-04,
41639  2-5.271d-02,-1.823d-02, 1.792d-02,-6.580d-03, 1.750d-03,-1.550d-03,
41640  3 1.220d-02, 1.763d-02,-8.690d-03,-8.800d-04,-1.160d-03,-2.100d-04,
41641  4-1.190d-03,-7.180d-03, 2.360d-03, 1.890d-03, 7.700d-04, 4.100d-04,
41642  5-9.100d-04, 2.040d-03,-3.100d-04,-1.050d-03,-4.000d-04,-2.400d-04,
41643  6 1.190d-03,-1.700d-04,-2.000d-04, 4.200d-04, 1.700d-04, 1.000d-04,
41644  1 1.081d+00,-1.189d+00, 3.868d-01,-8.617d-02, 1.115d-02,-1.180d-03,
41645  2 9.917d-01,-1.396d+00, 4.998d-01,-1.159d-01, 1.674d-02,-1.720d-03,
41646  3 5.099d-02,-1.338d-01, 9.173d-02,-2.885d-02, 5.890d-03,-6.500d-04,
41647  4-3.178d-02, 5.703d-02,-2.070d-02, 2.440d-03, 1.100d-04,-9.000d-05,
41648  5 8.970d-03,-1.392d-02, 2.050d-03, 6.500d-04,-2.300d-04, 2.000d-05,
41649  6-2.340d-03, 3.010d-03, 5.000d-04,-3.900d-04, 6.000d-05, 1.000d-05/
41650 C...Expansion coefficients for gluon distribution.
41651  DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/
41652  1 9.482d-01,-9.578d-01, 1.009d-01,-1.051d-01, 3.456d-02,-3.054d-02,
41653  2-9.627d-01, 5.379d-01, 3.368d-01,-9.525d-02, 1.488d-02,-2.051d-02,
41654  3 4.300d-01,-8.306d-02,-3.372d-01, 4.902d-02,-9.160d-03, 1.041d-02,
41655  4-1.925d-01,-1.790d-02, 2.183d-01, 7.490d-03, 4.140d-03,-1.860d-03,
41656  5 8.183d-02, 1.926d-02,-1.072d-01,-1.944d-02,-2.770d-03,-5.200d-04,
41657  6-3.884d-02,-1.234d-02, 5.410d-02, 1.879d-02, 3.350d-03, 1.040d-03,
41658  1 2.948d+01,-3.902d+01, 1.464d+01,-3.335d+00, 5.054d-01,-5.915d-02,
41659  2 2.559d+01,-3.955d+01, 1.661d+01,-4.299d+00, 6.904d-01,-8.243d-02,
41660  3-1.663d+00, 1.176d+00, 1.118d+00,-7.099d-01, 1.948d-01,-2.404d-02,
41661  4-2.168d-01, 8.170d-01,-7.169d-01, 1.851d-01,-1.924d-02,-3.250d-03,
41662  5 2.088d-01,-4.355d-01, 2.239d-01,-2.446d-02,-3.620d-03, 1.910d-03,
41663  6-9.097d-02, 1.601d-01,-5.681d-02,-2.500d-03, 2.580d-03,-4.700d-04/
41664  DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/
41665  1 2.367d+00, 4.453d-01, 3.660d-01, 9.467d-02, 1.341d-01, 1.661d-02,
41666  2-3.170d+00,-1.795d+00, 3.313d-02,-2.874d-01,-9.827d-02,-7.119d-02,
41667  3 1.823d+00, 1.457d+00,-2.465d-01, 3.739d-02, 6.090d-03, 1.814d-02,
41668  4-1.033d+00,-9.827d-01, 2.136d-01, 1.169d-01, 5.001d-02, 1.684d-02,
41669  5 5.133d-01, 5.259d-01,-1.173d-01,-1.139d-01,-4.988d-02,-2.021d-02,
41670  6-2.881d-01,-3.145d-01, 5.667d-02, 9.161d-02, 4.568d-02, 1.951d-02,
41671  1 3.036d+01,-4.062d+01, 1.578d+01,-3.699d+00, 6.020d-01,-7.031d-02,
41672  2 2.700d+01,-4.167d+01, 1.770d+01,-4.804d+00, 7.862d-01,-1.060d-01,
41673  3-1.909d+00, 1.357d+00, 1.127d+00,-7.181d-01, 2.232d-01,-2.481d-02,
41674  4-2.488d-01, 9.781d-01,-8.127d-01, 2.094d-01,-2.997d-02,-4.710d-03,
41675  5 2.506d-01,-5.427d-01, 2.672d-01,-3.103d-02,-1.800d-03, 2.870d-03,
41676  6-1.128d-01, 2.087d-01,-6.972d-02,-2.480d-03, 2.630d-03,-8.400d-04/
41677 C...Expansion coefficients for strange sea quark distribution.
41678  DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/
41679  1 4.968d-02,-4.173d-02, 2.102d-02,-3.270d-03, 3.240d-03,-6.700d-04,
41680  2-6.150d-03,-1.294d-02, 6.740d-03,-6.890d-03, 9.000d-04,-1.510d-03,
41681  3-8.580d-03, 5.050d-03,-4.900d-03,-1.600d-04,-9.400d-04,-1.500d-04,
41682  4 7.840d-03, 1.510d-03, 2.220d-03, 1.400d-03, 7.000d-04, 3.500d-04,
41683  5-4.410d-03,-2.220d-03,-8.900d-04,-8.500d-04,-3.600d-04,-2.000d-04,
41684  6 2.520d-03, 1.840d-03, 4.100d-04, 3.900d-04, 1.600d-04, 9.000d-05,
41685  1 9.235d-01,-1.085d+00, 3.464d-01,-7.210d-02, 9.140d-03,-9.100d-04,
41686  2 9.315d-01,-1.274d+00, 4.512d-01,-9.775d-02, 1.380d-02,-1.310d-03,
41687  3 4.739d-02,-1.296d-01, 8.482d-02,-2.642d-02, 4.760d-03,-5.700d-04,
41688  4-2.653d-02, 4.953d-02,-1.735d-02, 1.750d-03, 2.800d-04,-6.000d-05,
41689  5 6.940d-03,-1.132d-02, 1.480d-03, 6.500d-04,-2.100d-04, 0.000d+00,
41690  6-1.680d-03, 2.340d-03, 4.200d-04,-3.400d-04, 5.000d-05, 1.000d-05/
41691  DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/
41692  1 6.478d-02,-4.537d-02, 1.643d-02,-3.490d-03, 2.710d-03,-6.700d-04,
41693  2-2.223d-02,-2.126d-02, 1.247d-02,-6.290d-03, 1.120d-03,-1.440d-03,
41694  3-1.340d-03, 1.362d-02,-6.130d-03,-7.900d-04,-9.000d-04,-2.000d-04,
41695  4 5.080d-03,-3.610d-03, 1.700d-03, 1.830d-03, 6.800d-04, 4.000d-04,
41696  5-3.580d-03, 6.000d-05,-2.600d-04,-1.050d-03,-3.800d-04,-2.300d-04,
41697  6 2.420d-03, 9.300d-04,-1.000d-04, 4.500d-04, 1.700d-04, 1.100d-04,
41698  1 9.868d-01,-1.171d+00, 3.940d-01,-8.459d-02, 1.124d-02,-1.250d-03,
41699  2 1.001d+00,-1.383d+00, 5.044d-01,-1.152d-01, 1.658d-02,-1.830d-03,
41700  3 4.928d-02,-1.368d-01, 9.021d-02,-2.935d-02, 5.800d-03,-6.600d-04,
41701  4-3.133d-02, 5.785d-02,-2.023d-02, 2.630d-03, 1.600d-04,-8.000d-05,
41702  5 8.840d-03,-1.416d-02, 1.900d-03, 5.800d-04,-2.500d-04, 1.000d-05,
41703  6-2.300d-03, 3.080d-03, 5.500d-04,-3.700d-04, 7.000d-05, 1.000d-05/
41704 C...Expansion coefficients for charm sea quark distribution.
41705  DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/
41706  1 9.270d-03,-1.817d-02, 9.590d-03,-6.390d-03, 1.690d-03,-1.540d-03,
41707  2 5.710d-03,-1.188d-02, 6.090d-03,-4.650d-03, 1.240d-03,-1.310d-03,
41708  3-3.960d-03, 7.100d-03,-3.590d-03, 1.840d-03,-3.900d-04, 3.400d-04,
41709  4 1.120d-03,-1.960d-03, 1.120d-03,-4.800d-04, 1.000d-04,-4.000d-05,
41710  5 4.000d-05,-3.000d-05,-1.800d-04, 9.000d-05,-5.000d-05,-2.000d-05,
41711  6-4.200d-04, 7.300d-04,-1.600d-04, 5.000d-05, 5.000d-05, 5.000d-05,
41712  1 8.098d-01,-1.042d+00, 3.398d-01,-6.824d-02, 8.760d-03,-9.000d-04,
41713  2 8.961d-01,-1.217d+00, 4.339d-01,-9.287d-02, 1.304d-02,-1.290d-03,
41714  3 3.058d-02,-1.040d-01, 7.604d-02,-2.415d-02, 4.600d-03,-5.000d-04,
41715  4-2.451d-02, 4.432d-02,-1.651d-02, 1.430d-03, 1.200d-04,-1.000d-04,
41716  5 1.122d-02,-1.457d-02, 2.680d-03, 5.800d-04,-1.200d-04, 3.000d-05,
41717  6-7.730d-03, 7.330d-03,-7.600d-04,-2.400d-04, 1.000d-05, 0.000d+00/
41718  DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/
41719  1 9.980d-03,-1.945d-02, 1.055d-02,-6.870d-03, 1.860d-03,-1.560d-03,
41720  2 5.700d-03,-1.203d-02, 6.250d-03,-4.860d-03, 1.310d-03,-1.370d-03,
41721  3-4.490d-03, 7.990d-03,-4.170d-03, 2.050d-03,-4.400d-04, 3.300d-04,
41722  4 1.470d-03,-2.480d-03, 1.460d-03,-5.700d-04, 1.200d-04,-1.000d-05,
41723  5-9.000d-05, 1.500d-04,-3.200d-04, 1.200d-04,-6.000d-05,-4.000d-05,
41724  6-4.200d-04, 7.600d-04,-1.400d-04, 4.000d-05, 7.000d-05, 5.000d-05,
41725  1 8.698d-01,-1.131d+00, 3.836d-01,-8.111d-02, 1.048d-02,-1.300d-03,
41726  2 9.626d-01,-1.321d+00, 4.854d-01,-1.091d-01, 1.583d-02,-1.700d-03,
41727  3 3.057d-02,-1.088d-01, 8.022d-02,-2.676d-02, 5.590d-03,-5.600d-04,
41728  4-2.845d-02, 5.164d-02,-1.918d-02, 2.210d-03,-4.000d-05,-1.500d-04,
41729  5 1.311d-02,-1.751d-02, 3.310d-03, 5.100d-04,-1.200d-04, 5.000d-05,
41730  6-8.590d-03, 8.380d-03,-9.200d-04,-2.600d-04, 1.000d-05,-1.000d-05/
41731 C...Expansion coefficients for bottom sea quark distribution.
41732  DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/
41733  1 9.010d-03,-1.401d-02, 7.150d-03,-4.130d-03, 1.260d-03,-1.040d-03,
41734  2 6.280d-03,-9.320d-03, 4.780d-03,-2.890d-03, 9.100d-04,-8.200d-04,
41735  3-2.930d-03, 4.090d-03,-1.890d-03, 7.600d-04,-2.300d-04, 1.400d-04,
41736  4 3.900d-04,-1.200d-03, 4.400d-04,-2.500d-04, 2.000d-05,-2.000d-05,
41737  5 2.600d-04, 1.400d-04,-8.000d-05, 1.000d-04, 1.000d-05, 1.000d-05,
41738  6-2.600d-04, 3.200d-04, 1.000d-05,-1.000d-05, 1.000d-05,-1.000d-05,
41739  1 8.029d-01,-1.075d+00, 3.792d-01,-7.843d-02, 1.007d-02,-1.090d-03,
41740  2 7.903d-01,-1.099d+00, 4.153d-01,-9.301d-02, 1.317d-02,-1.410d-03,
41741  3-1.704d-02,-1.130d-02, 2.882d-02,-1.341d-02, 3.040d-03,-3.600d-04,
41742  4-7.200d-04, 7.230d-03,-5.160d-03, 1.080d-03,-5.000d-05,-4.000d-05,
41743  5 3.050d-03,-4.610d-03, 1.660d-03,-1.300d-04,-1.000d-05, 1.000d-05,
41744  6-4.360d-03, 5.230d-03,-1.610d-03, 2.000d-04,-2.000d-05, 0.000d+00/
41745  DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/
41746  1 8.980d-03,-1.459d-02, 7.510d-03,-4.410d-03, 1.310d-03,-1.070d-03,
41747  2 5.970d-03,-9.440d-03, 4.800d-03,-3.020d-03, 9.100d-04,-8.500d-04,
41748  3-3.050d-03, 4.440d-03,-2.100d-03, 8.500d-04,-2.400d-04, 1.400d-04,
41749  4 5.300d-04,-1.300d-03, 5.600d-04,-2.700d-04, 3.000d-05,-2.000d-05,
41750  5 2.000d-04, 1.400d-04,-1.100d-04, 1.000d-04, 0.000d+00, 0.000d+00,
41751  6-2.600d-04, 3.200d-04, 0.000d+00,-3.000d-05, 1.000d-05,-1.000d-05,
41752  1 8.672d-01,-1.174d+00, 4.265d-01,-9.252d-02, 1.244d-02,-1.460d-03,
41753  2 8.500d-01,-1.194d+00, 4.630d-01,-1.083d-01, 1.614d-02,-1.830d-03,
41754  3-2.241d-02,-5.630d-03, 2.815d-02,-1.425d-02, 3.520d-03,-4.300d-04,
41755  4-7.300d-04, 8.030d-03,-5.780d-03, 1.380d-03,-1.300d-04,-4.000d-05,
41756  5 3.460d-03,-5.380d-03, 1.960d-03,-2.100d-04, 1.000d-05, 1.000d-05,
41757  6-4.850d-03, 5.950d-03,-1.890d-03, 2.600d-04,-3.000d-05, 0.000d+00/
41758 C...Expansion coefficients for top sea quark distribution.
41759  DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/
41760  1 4.410d-03,-7.480d-03, 3.770d-03,-2.580d-03, 7.300d-04,-7.100d-04,
41761  2 3.840d-03,-6.050d-03, 3.030d-03,-2.030d-03, 5.800d-04,-5.900d-04,
41762  3-8.800d-04, 1.660d-03,-7.500d-04, 4.700d-04,-1.000d-04, 1.000d-04,
41763  4-8.000d-05,-1.500d-04, 1.200d-04,-9.000d-05, 3.000d-05, 0.000d+00,
41764  5 1.300d-04,-2.200d-04,-2.000d-05,-2.000d-05,-2.000d-05,-2.000d-05,
41765  6-7.000d-05, 1.900d-04,-4.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
41766  1 6.623d-01,-9.248d-01, 3.519d-01,-7.930d-02, 1.110d-02,-1.180d-03,
41767  2 6.380d-01,-9.062d-01, 3.582d-01,-8.479d-02, 1.265d-02,-1.390d-03,
41768  3-2.581d-02, 2.125d-02, 4.190d-03,-4.980d-03, 1.490d-03,-2.100d-04,
41769  4 7.100d-04, 5.300d-04,-1.270d-03, 3.900d-04,-5.000d-05,-1.000d-05,
41770  5 3.850d-03,-5.060d-03, 1.860d-03,-3.500d-04, 4.000d-05, 0.000d+00,
41771  6-3.530d-03, 4.460d-03,-1.500d-03, 2.700d-04,-3.000d-05, 0.000d+00/
41772  DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/
41773  1 4.260d-03,-7.530d-03, 3.830d-03,-2.680d-03, 7.600d-04,-7.300d-04,
41774  2 3.640d-03,-6.050d-03, 3.030d-03,-2.090d-03, 5.900d-04,-6.000d-04,
41775  3-9.200d-04, 1.710d-03,-8.200d-04, 5.000d-04,-1.200d-04, 1.000d-04,
41776  4-5.000d-05,-1.600d-04, 1.300d-04,-9.000d-05, 3.000d-05, 0.000d+00,
41777  5 1.300d-04,-2.100d-04,-1.000d-05,-2.000d-05,-2.000d-05,-1.000d-05,
41778  6-8.000d-05, 1.800d-04,-5.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
41779  1 7.146d-01,-1.007d+00, 3.932d-01,-9.246d-02, 1.366d-02,-1.540d-03,
41780  2 6.856d-01,-9.828d-01, 3.977d-01,-9.795d-02, 1.540d-02,-1.790d-03,
41781  3-3.053d-02, 2.758d-02, 2.150d-03,-4.880d-03, 1.640d-03,-2.500d-04,
41782  4 9.200d-04, 4.200d-04,-1.340d-03, 4.600d-04,-8.000d-05,-1.000d-05,
41783  5 4.230d-03,-5.660d-03, 2.140d-03,-4.300d-04, 6.000d-05, 0.000d+00,
41784  6-3.890d-03, 5.000d-03,-1.740d-03, 3.300d-04,-4.000d-05, 0.000d+00/
41785 
41786 C...The following data lines are coefficients needed in the
41787 C...Duke, Owens proton structure function parametrizations, see below.
41788 C...Expansion coefficients for (up+down) valence quark distribution.
41789  DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/
41790  1 4.190d-01, 3.460d+00, 4.400d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41791  2 4.000d-03, 7.240d-01,-4.860d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41792  3-7.000d-03,-6.600d-02, 1.330d+00, 0.000d+00, 0.000d+00, 0.000d+00/
41793  DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/
41794  1 3.740d-01, 3.330d+00, 6.030d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41795  2 1.400d-02, 7.530d-01,-6.220d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41796  3 0.000d+00,-7.600d-02, 1.560d+00, 0.000d+00, 0.000d+00, 0.000d+00/
41797 C...Expansion coefficients for down valence quark distribution.
41798  DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/
41799  1 7.630d-01, 4.000d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41800  2-2.370d-01, 6.270d-01,-4.210d-01, 0.000d+00, 0.000d+00, 0.000d+00,
41801  3 2.600d-02,-1.900d-02, 3.300d-02, 0.000d+00, 0.000d+00, 0.000d+00/
41802  DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/
41803  1 7.610d-01, 3.830d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41804  2-2.320d-01, 6.270d-01,-4.180d-01, 0.000d+00, 0.000d+00, 0.000d+00,
41805  3 2.300d-02,-1.900d-02, 3.600d-02, 0.000d+00, 0.000d+00, 0.000d+00/
41806 C...Expansion coefficients for (up+down+strange) sea quark distribution.
41807  DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/
41808  1 1.265d+00, 0.000d+00, 8.050d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41809  2-1.132d+00,-3.720d-01, 1.590d+00, 6.310d+00,-1.050d+01, 1.470d+01,
41810  3 2.930d-01,-2.900d-02,-1.530d-01,-2.730d-01,-3.170d+00, 9.800d+00/
41811  DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/
41812  1 1.670d+00, 0.000d+00, 9.150d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41813  2-1.920d+00,-2.730d-01, 5.300d-01, 1.570d+01,-1.010d+02, 2.230d+02,
41814  3 5.820d-01,-1.640d-01,-7.630d-01,-2.830d+00, 4.470d+01,-1.170d+02/
41815 C...Expansion coefficients for charm sea quark distribution.
41816  DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/
41817  1 0.000d+00,-3.600d-02, 6.350d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41818  2 1.350d-01,-2.220d-01, 3.260d+00,-3.030d+00, 1.740d+01,-1.790d+01,
41819  3-7.500d-02,-5.800d-02,-9.090d-01, 1.500d+00,-1.130d+01, 1.560d+01/
41820  DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/
41821  1 0.000d+00,-1.200d-01, 3.510d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41822  2 6.700d-02,-2.330d-01, 3.660d+00,-4.740d-01, 9.500d+00,-1.660d+01,
41823  3-3.100d-02,-2.300d-02,-4.530d-01, 3.580d-01,-5.430d+00, 1.550d+01/
41824 C...Expansion coefficients for gluon distribution.
41825  DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/
41826  1 1.560d+00, 0.000d+00, 6.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
41827  2-1.710d+00,-9.490d-01, 1.440d+00,-7.190d+00,-1.650d+01, 1.530d+01,
41828  3 6.380d-01, 3.250d-01,-1.050d+00, 2.550d-01, 1.090d+01,-1.010d+01/
41829  DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/
41830  1 8.790d-01, 0.000d+00, 4.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
41831  2-9.710d-01,-1.160d+00, 1.230d+00,-5.640d+00,-7.540d+00,-5.960d-01,
41832  3 4.340d-01, 4.760d-01,-2.540d-01,-8.170d-01, 5.500d+00, 1.260d-01/
41833 
41834 C...Euler's beta function, requires ordinary Gamma function
41835  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
41836 
41837 C...Leading order proton parton distributions from Glueck, Reya and
41838 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41839 C...10^-5 < x < 1.
41840  IF(mstp(51).EQ.11) THEN
41841 
41842 C...Determine s expansion variable and some x expressions.
41843  q2in=min(1d8,max(0.25d0,q2))
41844  sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
41845  sd2=sd**2
41846  xl=-log(x)
41847  xs=sqrt(x)
41848 
41849 C...Evaluate valence, gluon and sea distributions.
41850  xfvud=(0.663d0+0.191d0*sd-0.041d0*sd2+0.031d0*sd**3)*
41851  & x**0.326d0*(1d0+(-1.97d0+6.74d0*sd-1.96d0*sd2)*xs+
41852  & (24.4d0-20.7d0*sd+4.08d0*sd2)*x)*
41853  & (1d0-x)**(2.86d0+0.70d0*sd-0.02d0*sd2)
41854  xfvdd=(0.579d0+0.283d0*sd+0.047d0*sd2)*x**(0.523d0-0.015d0*sd)*
41855  & (1d0+(2.22d0-0.59d0*sd-0.27d0*sd2)*xs+(5.95d0-6.19d0*sd+
41856  & 1.55d0*sd2)*x)*(1d0-x)**(3.57d0+0.94d0*sd-0.16d0*sd2)
41857  xfglu=(x**(1.00d0-0.17d0*sd)*((4.879d0*sd-1.383d0*sd2)+
41858  & (25.92d0-28.97d0*sd+5.596d0*sd2)*x+(-25.69d0+23.68d0*sd-
41859  & 1.975d0*sd2)*x**2)+sd**0.558d0*exp(-(0.595d0+2.138d0*sd)+
41860  & sqrt(4.066d0*sd**1.218d0*xl)))*
41861  & (1d0-x)**(2.537d0+1.718d0*sd+0.353d0*sd2)
41862  xfsea=(x**(0.412d0-0.171d0*sd)*(0.363d0-1.196d0*x+(1.029d0+
41863  & 1.785d0*sd-0.459d0*sd2)*x**2)*xl**(0.566d0-0.496d0*sd)+
41864  & sd**1.396d0*exp(-(3.838d0+1.944d0*sd)+sqrt(2.845d0*sd**1.331d0*
41865  & xl)))*(1d0-x)**(4.696d0+2.109d0*sd)
41866  xfstr=sd**0.803d0*(1d0+(-3.055d0+1.024d0*sd**0.67d0)*xs+
41867  & (27.4d0-20.0d0*sd**0.154d0)*x)*(1d0-x)**6.22d0*
41868  & exp(-(4.33d0+1.408d0*sd)+sqrt((8.27d0-0.437d0*sd)*
41869  & sd**0.563d0*xl))/xl**(2.082d0-0.577d0*sd)
41870  IF(sd.LE.0.888d0) THEN
41871  xfchm=0d0
41872  ELSE
41873  xfchm=(sd-0.888d0)**1.01d0*(1.+(4.24d0-0.804d0*sd)*x)*
41874  & (1d0-x)**(3.46d0+1.076d0*sd)*exp(-(4.61d0+1.49d0*sd)+
41875  & sqrt((2.555d0+1.961d0*sd)*sd**0.37d0*xl))
41876  ENDIF
41877  IF(sd.LE.1.351d0) THEN
41878  xfbot=0d0
41879  ELSE
41880  xfbot=(sd-1.351d0)*(1d0+1.848d0*x)*(1d0-x)**(2.929d0+
41881  & 1.396d0*sd)*exp(-(4.71d0+1.514d0*sd)+
41882  & sqrt((4.02d0+1.239d0*sd)*sd**0.51d0*xl))
41883  ENDIF
41884 
41885 C...Put into output array.
41886  xppr(0)=xfglu
41887  xppr(1)=xfvdd+xfsea
41888  xppr(2)=xfvud-xfvdd+xfsea
41889  xppr(3)=xfstr
41890  xppr(4)=xfchm
41891  xppr(5)=xfbot
41892  xppr(-1)=xfsea
41893  xppr(-2)=xfsea
41894  xppr(-3)=xfstr
41895  xppr(-4)=xfchm
41896  xppr(-5)=xfbot
41897 
41898 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41899 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41900  ELSEIF(mstp(51).EQ.12.OR.mstp(51).EQ.13) THEN
41901 
41902 C...Determine set, Lambda and x and t expansion variables.
41903  nset=mstp(51)-11
41904  IF(nset.EQ.1) alam=0.2d0
41905  IF(nset.EQ.2) alam=0.29d0
41906  tmin=log(5d0/alam**2)
41907  tmax=log(1d8/alam**2)
41908  t=log(max(1d0,q2/alam**2))
41909  vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
41910  nx=1
41911  IF(x.LE.0.1d0) nx=2
41912  IF(nx.EQ.1) vx=(2d0*x-1.1d0)/0.9d0
41913  IF(nx.EQ.2) vx=max(-1d0,(2d0*log(x)+11.51293d0)/6.90776d0)
41914 
41915 C...Chebyshev polynomials for x and t expansion.
41916  tx(1)=1d0
41917  tx(2)=vx
41918  tx(3)=2d0*vx**2-1d0
41919  tx(4)=4d0*vx**3-3d0*vx
41920  tx(5)=8d0*vx**4-8d0*vx**2+1d0
41921  tx(6)=16d0*vx**5-20d0*vx**3+5d0*vx
41922  tt(1)=1d0
41923  tt(2)=vt
41924  tt(3)=2d0*vt**2-1d0
41925  tt(4)=4d0*vt**3-3d0*vt
41926  tt(5)=8d0*vt**4-8d0*vt**2+1d0
41927  tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
41928 
41929 C...Calculate structure functions.
41930  DO 120 kfl=1,6
41931  xqsum=0d0
41932  DO 110 it=1,6
41933  DO 100 ix=1,6
41934  xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)
41935  100 CONTINUE
41936  110 CONTINUE
41937  xq(kfl)=xqsum*(1d0-x)**nehlq(kfl,nset)
41938  120 CONTINUE
41939 
41940 C...Put into output array.
41941  xppr(0)=xq(4)
41942  xppr(1)=xq(2)+xq(3)
41943  xppr(2)=xq(1)+xq(3)
41944  xppr(3)=xq(5)
41945  xppr(4)=xq(6)
41946  xppr(-1)=xq(3)
41947  xppr(-2)=xq(3)
41948  xppr(-3)=xq(5)
41949  xppr(-4)=xq(6)
41950 
41951 C...Special expansion for bottom (threshold effects).
41952  IF(mstp(58).GE.5) THEN
41953  IF(nset.EQ.1) tmin=8.1905d0
41954  IF(nset.EQ.2) tmin=7.4474d0
41955  IF(t.GT.tmin) THEN
41956  vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
41957  tt(1)=1d0
41958  tt(2)=vt
41959  tt(3)=2d0*vt**2-1d0
41960  tt(4)=4d0*vt**3-3d0*vt
41961  tt(5)=8d0*vt**4-8d0*vt**2+1d0
41962  tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
41963  xqsum=0d0
41964  DO 140 it=1,6
41965  DO 130 ix=1,6
41966  xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)
41967  130 CONTINUE
41968  140 CONTINUE
41969  xppr(5)=xqsum*(1d0-x)**nehlq(7,nset)
41970  xppr(-5)=xppr(5)
41971  ENDIF
41972  ENDIF
41973 
41974 C...Special expansion for top (threshold effects).
41975  IF(mstp(58).GE.6) THEN
41976  IF(nset.EQ.1) tmin=11.5528d0
41977  IF(nset.EQ.2) tmin=10.8097d0
41978  tmin=tmin+2d0*log(pmas(6,1)/30d0)
41979  tmax=tmax+2d0*log(pmas(6,1)/30d0)
41980  IF(t.GT.tmin) THEN
41981  vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
41982  tt(1)=1d0
41983  tt(2)=vt
41984  tt(3)=2d0*vt**2-1d0
41985  tt(4)=4d0*vt**3-3d0*vt
41986  tt(5)=8d0*vt**4-8d0*vt**2+1d0
41987  tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
41988  xqsum=0d0
41989  DO 160 it=1,6
41990  DO 150 ix=1,6
41991  xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)
41992  150 CONTINUE
41993  160 CONTINUE
41994  xppr(6)=xqsum*(1d0-x)**nehlq(8,nset)
41995  xppr(-6)=xppr(6)
41996  ENDIF
41997  ENDIF
41998 
41999 C...Proton parton distributions from Duke, Owens.
42000 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42001  ELSEIF(mstp(51).EQ.14.OR.mstp(51).EQ.15) THEN
42002 
42003 C...Determine set, Lambda and s expansion parameter.
42004  nset=mstp(51)-13
42005  IF(nset.EQ.1) alam=0.2d0
42006  IF(nset.EQ.2) alam=0.4d0
42007  q2in=min(1d6,max(4d0,q2))
42008  sd=log(log(q2in/alam**2)/log(4d0/alam**2))
42009 
42010 C...Calculate structure functions.
42011  DO 180 kfl=1,5
42012  DO 170 is=1,6
42013  ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+
42014  & cdo(3,is,kfl,nset)*sd**2
42015  170 CONTINUE
42016  IF(kfl.LE.2) THEN
42017  xq(kfl)=x**ts(1)*(1d0-x)**ts(2)*(1d0+ts(3)*x)/(eulbet(ts(1),
42018  & ts(2)+1d0)*(1d0+ts(3)*ts(1)/(ts(1)+ts(2)+1d0)))
42019  ELSE
42020  xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
42021  & ts(5)*x**2+ts(6)*x**3)
42022  ENDIF
42023  180 CONTINUE
42024 
42025 C...Put into output arrays.
42026  xppr(0)=xq(5)
42027  xppr(1)=xq(2)+xq(3)/6d0
42028  xppr(2)=3d0*xq(1)-xq(2)+xq(3)/6d0
42029  xppr(3)=xq(3)/6d0
42030  xppr(4)=xq(4)
42031  xppr(-1)=xq(3)/6d0
42032  xppr(-2)=xq(3)/6d0
42033  xppr(-3)=xq(3)/6d0
42034  xppr(-4)=xq(4)
42035 
42036  ENDIF
42037 
42038  RETURN
42039  END
42040 
42041 C*********************************************************************
42042 
42043 C...PYHFTH
42044 C...Gives threshold attractive/repulsive factor for heavy flavour
42045 C...production.
42046 
42047  FUNCTION pyhfth(SH,SQM,FRATT)
42048 
42049 C...Double precision and integer declarations.
42050  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42051  IMPLICIT INTEGER(I-N)
42052  INTEGER PYK,PYCHGE,PYCOMP
42053 C...Commonblocks.
42054  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42055  common/pypars/mstp(200),parp(200),msti(200),pari(200)
42056  common/pyint1/mint(400),vint(400)
42057  SAVE /pydat1/,/pypars/,/pyint1/
42058 
42059 C...Value for alpha_strong.
42060  IF(mstp(35).LE.1) THEN
42061  alssg=parp(35)
42062  ELSE
42063  mst115=mstu(115)
42064  mstu(115)=mstp(36)
42065  q2bn=sqrt(max(1d0,sqm*((sqrt(sh)-2d0*sqrt(sqm))**2+
42066  & parp(36)**2)))
42067  alssg=pyalps(q2bn)
42068  mstu(115)=mst115
42069  ENDIF
42070 
42071 C...Evaluate attractive and repulsive factors.
42072  xattr=4d0*paru(1)*alssg/(3d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
42073  fattr=xattr/(1d0-exp(-min(50d0,xattr)))
42074  xrepu=paru(1)*alssg/(6d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
42075  frepu=xrepu/(exp(min(50d0,xrepu))-1d0)
42076  pyhfth=fratt*fattr+(1d0-fratt)*frepu
42077  vint(138)=pyhfth
42078 
42079  RETURN
42080  END
42081 
42082 C*********************************************************************
42083 
42084 C...PYSPLI
42085 C...Splits a hadron remnant into two (partons or hadron + parton)
42086 C...in case it is more complicated than just a quark or a diquark.
42087 
42088  SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)
42089 
42090 C...Double precision and integer declarations.
42091  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42092  IMPLICIT INTEGER(I-N)
42093  INTEGER PYK,PYCHGE,PYCOMP
42094 C...Commonblocks. PYDAT1 temporary
42095  common/pypars/mstp(200),parp(200),msti(200),pari(200)
42096  common/pyint1/mint(400),vint(400)
42097  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42098  SAVE /pypars/,/pyint1/,/pydat1/
42099 C...Local array.
42100  dimension kfl(3)
42101 
42102 C...Preliminaries. Parton composition.
42103  kfa=iabs(kf)
42104  kfs=isign(1,kf)
42105  kfl(1)=mod(kfa/1000,10)
42106  kfl(2)=mod(kfa/100,10)
42107  kfl(3)=mod(kfa/10,10)
42108  IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN
42109  kfl(2)=int(1.5d0+pyr(0))
42110  IF(mint(105).EQ.333) kfl(2)=3
42111  IF(mint(105).EQ.443) kfl(2)=4
42112  kfl(3)=kfl(2)
42113  ELSEIF((kfa.EQ.111.OR.kfa.EQ.113).AND.pyr(0).GT.0.5d0) THEN
42114  kfl(2)=2
42115  kfl(3)=2
42116  ELSEIF(kfa.EQ.223.AND.pyr(0).GT.0.5d0) THEN
42117  kfl(2)=1
42118  kfl(3)=1
42119  ELSEIF((kfa.EQ.130.OR.kfa.EQ.310).AND.pyr(0).GT.0.5d0) THEN
42120  kfl(2)=mod(kfa/10,10)
42121  kfl(3)=mod(kfa/100,10)
42122  ENDIF
42123  IF(kflin.NE.21.AND.kflin.NE.22.AND.kflin.NE.23) THEN
42124  kflr=kflin*kfs
42125  ELSE
42126  kflr=kflin
42127  ENDIF
42128  kflch=0
42129 
42130 C...Subdivide lepton.
42131  IF(kfa.GE.11.AND.kfa.LE.18) THEN
42132  IF(kflr.EQ.kfa) THEN
42133  kflsp=kfs*22
42134  ELSEIF(kflr.EQ.22) THEN
42135  kflsp=kfa
42136  ELSEIF(kflr.EQ.-24.AND.mod(kfa,2).EQ.1) THEN
42137  kflsp=kfa+1
42138  ELSEIF(kflr.EQ.24.AND.mod(kfa,2).EQ.0) THEN
42139  kflsp=kfa-1
42140  ELSEIF(kflr.EQ.21) THEN
42141  kflsp=kfa
42142  kflch=kfs*21
42143  ELSE
42144  kflsp=kfa
42145  kflch=-kflr
42146  ENDIF
42147 
42148 C...Subdivide photon.
42149  ELSEIF(kfa.EQ.22.AND.mint(109).NE.2) THEN
42150  IF(kflr.NE.21) THEN
42151  kflsp=-kflr
42152  ELSE
42153  ragr=0.75d0*pyr(0)
42154  kflsp=1
42155  IF(ragr.GT.0.125d0) kflsp=2
42156  IF(ragr.GT.0.625d0) kflsp=3
42157  IF(pyr(0).GT.0.5d0) kflsp=-kflsp
42158  kflch=-kflsp
42159  ENDIF
42160 
42161 C...Subdivide Reggeon or Pomeron.
42162  ELSEIF(kfa.EQ.110.OR.kfa.EQ.990) THEN
42163  IF(kflin.EQ.21) THEN
42164  kflsp=kfs*21
42165  ELSE
42166  kflsp=-kflin
42167  ENDIF
42168 
42169 C...Subdivide meson.
42170  ELSEIF(kfl(1).EQ.0) THEN
42171  kfl(2)=kfl(2)*(-1)**kfl(2)
42172  kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))
42173  IF(kflr.EQ.kfl(2)) THEN
42174  kflsp=kfl(3)
42175  ELSEIF(kflr.EQ.kfl(3)) THEN
42176  kflsp=kfl(2)
42177  ELSEIF(kflr.EQ.21.AND.pyr(0).GT.0.5d0) THEN
42178  kflsp=kfl(2)
42179  kflch=kfl(3)
42180  ELSEIF(kflr.EQ.21) THEN
42181  kflsp=kfl(3)
42182  kflch=kfl(2)
42183  ELSEIF(kflr*kfl(2).GT.0) THEN
42184  ntry=0
42185  100 ntry=ntry+1
42186  CALL pykfdi(-kflr,kfl(2),kfdump,kflch)
42187  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42188  GOTO 100
42189  ELSEIF(kflch.EQ.0) THEN
42190  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42191  mint(51)=1
42192  RETURN
42193  ENDIF
42194  kflsp=kfl(3)
42195  ELSE
42196  ntry=0
42197  110 ntry=ntry+1
42198  CALL pykfdi(-kflr,kfl(3),kfdump,kflch)
42199  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42200  GOTO 110
42201  ELSEIF(kflch.EQ.0) THEN
42202  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42203  mint(51)=1
42204  RETURN
42205  ENDIF
42206  kflsp=kfl(2)
42207  ENDIF
42208 
42209 C...Special case for extracting photon from baryon without splitting
42210 C...the latter. (Currently only used by external programs.)
42211  ELSEIF(kflin.EQ.22.AND.mstp(98).EQ.1) then
42212  kflsp=kfa
42213  kflch=0
42214 
42215 C...Subdivide baryon.
42216  ELSE
42217  nagr=0
42218  DO 120 j=1,3
42219  IF(kflr.EQ.kfl(j)) nagr=nagr+1
42220  120 CONTINUE
42221  IF(nagr.GE.1) THEN
42222  ragr=0.00001d0+(nagr-0.00002d0)*pyr(0)
42223  iagr=0
42224  DO 130 j=1,3
42225  IF(kflr.EQ.kfl(j)) ragr=ragr-1d0
42226  IF(iagr.EQ.0.AND.ragr.LE.0d0) iagr=j
42227  130 CONTINUE
42228  ELSE
42229  iagr=1.00001d0+2.99998d0*pyr(0)
42230  ENDIF
42231  id1=1
42232  IF(iagr.EQ.1) id1=2
42233  IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3
42234  id2=6-iagr-id1
42235  ksp=3
42236  IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN
42237  IF(iagr.NE.3.AND.pyr(0).GT.0.25d0) ksp=1
42238  ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN
42239  IF(iagr.NE.1.AND.pyr(0).GT.0.25d0) ksp=1
42240  ELSEIF(mod(kfa,10).EQ.2) THEN
42241  IF(iagr.EQ.1) ksp=1
42242  IF(iagr.NE.1.AND.pyr(0).GT.0.75d0) ksp=1
42243  ENDIF
42244  kflsp=1000*kfl(id1)+100*kfl(id2)+ksp
42245  IF(kflr.EQ.21) THEN
42246  kflch=kfl(iagr)
42247  ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN
42248  ntry=0
42249  140 ntry=ntry+1
42250  CALL pykfdi(-kflr,kfl(iagr),kfdump,kflch)
42251  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42252  GOTO 140
42253  ELSEIF(kflch.EQ.0) THEN
42254  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42255  mint(51)=1
42256  RETURN
42257  ENDIF
42258  ELSEIF(nagr.EQ.0) THEN
42259  ntry=0
42260  150 ntry=ntry+1
42261  CALL pykfdi(10000*kfl(id1)+kflsp,-kflr,kfdump,kflch)
42262  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42263  GOTO 150
42264  ELSEIF(kflch.EQ.0) THEN
42265  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42266  mint(51)=1
42267  RETURN
42268  ENDIF
42269  kflsp=kfl(iagr)
42270  ENDIF
42271  ENDIF
42272 
42273 C...Add on correct sign for result.
42274  kflch=kflch*kfs
42275  kflsp=kflsp*kfs
42276 
42277  RETURN
42278  END
42279 
42280 C*********************************************************************
42281 
42282 C...PYGAMM
42283 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42284 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42285 C...(Dover, 1965) 6.1.36.
42286 
42287  FUNCTION pygamm(X)
42288 
42289 C...Double precision and integer declarations.
42290  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42291  IMPLICIT INTEGER(I-N)
42292  INTEGER PYK,PYCHGE,PYCOMP
42293 C...Local array and data.
42294  dimension b(8)
42295  DATA b/-0.577191652d0,0.988205891d0,-0.897056937d0,0.918206857d0,
42296  &-0.756704078d0,0.482199394d0,-0.193527818d0,0.035868343d0/
42297 
42298  nx=int(x)
42299  dx=x-nx
42300 
42301  pygamm=1d0
42302  dxp=1d0
42303  DO 100 i=1,8
42304  dxp=dxp*dx
42305  pygamm=pygamm+b(i)*dxp
42306  100 CONTINUE
42307  IF(x.LT.1d0) THEN
42308  pygamm=pygamm/x
42309  ELSE
42310  DO 110 ix=1,nx-1
42311  pygamm=(x-ix)*pygamm
42312  110 CONTINUE
42313  ENDIF
42314 
42315  RETURN
42316  END
42317 
42318 C***********************************************************************
42319 
42320 C...PYWAUX
42321 C...Calculates real and imaginary parts of the auxiliary functions W1
42322 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42323 C...der Bij, Nucl. Phys. B297 (1988) 221.
42324 
42325  SUBROUTINE pywaux(IAUX,EPS,WRE,WIM)
42326 
42327 C...Double precision and integer declarations.
42328  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42329  IMPLICIT INTEGER(I-N)
42330  INTEGER PYK,PYCHGE,PYCOMP
42331 C...Commonblocks.
42332  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42333  SAVE /pydat1/
42334 
42335  asinh(x)=log(x+sqrt(x**2+1d0))
42336  acosh(x)=log(x+sqrt(x**2-1d0))
42337 
42338  IF(eps.LT.0d0) THEN
42339  IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*asinh(sqrt(-1d0/eps))
42340  IF(iaux.EQ.2) wre=4d0*(asinh(sqrt(-1d0/eps)))**2
42341  wim=0d0
42342  ELSEIF(eps.LT.1d0) THEN
42343  IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*acosh(sqrt(1d0/eps))
42344  IF(iaux.EQ.2) wre=4d0*(acosh(sqrt(1d0/eps)))**2-paru(1)**2
42345  IF(iaux.EQ.1) wim=-paru(1)*sqrt(1d0-eps)
42346  IF(iaux.EQ.2) wim=-4d0*paru(1)*acosh(sqrt(1d0/eps))
42347  ELSE
42348  IF(iaux.EQ.1) wre=2d0*sqrt(eps-1d0)*asin(sqrt(1d0/eps))
42349  IF(iaux.EQ.2) wre=-4d0*(asin(sqrt(1d0/eps)))**2
42350  wim=0d0
42351  ENDIF
42352 
42353  RETURN
42354  END
42355 
42356 C***********************************************************************
42357 
42358 C...PYI3AU
42359 C...Calculates real and imaginary parts of the auxiliary function I3;
42360 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42361 C...Nucl. Phys. B297 (1988) 221.
42362 
42363  SUBROUTINE pyi3au(EPS,RAT,Y3RE,Y3IM)
42364 
42365 C...Double precision and integer declarations.
42366  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42367  IMPLICIT INTEGER(I-N)
42368  INTEGER PYK,PYCHGE,PYCOMP
42369 C...Commonblocks.
42370  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42371  SAVE /pydat1/
42372 
42373  be=0.5d0*(1d0+sqrt(1d0+rat*eps))
42374  IF(eps.LT.1d0) ga=0.5d0*(1d0+sqrt(1d0-eps))
42375 
42376  IF(eps.LT.0d0) THEN
42377  IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42378  f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
42379  & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
42380  & pyspen(0.25d0*(rat+1d0)*eps/(1d0+0.25d0*rat*eps),0d0,1)-
42381  & pyspen((rat+1d0)/rat,0d0,1)+0.5d0*(log(1d0+0.25d0*rat*eps)**2-
42382  & log(0.25d0*rat*eps)**2)+log(1d0-0.25d0*eps)*
42383  & log((1d0+0.25d0*(rat-1d0)*eps)/(1d0+0.25d0*rat*eps))+
42384  & log(-0.25d0*eps)*log(0.25d0*rat*eps/(1d0+0.25d0*(rat-1d0)*
42385  & eps))
42386  ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
42387  f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
42388  & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
42389  & pyspen((be-1d0+0.25d0*eps)/be,0d0,1)-
42390  & pyspen((be-1d0+0.25d0*eps)/(be-1d0),0d0,1)+
42391  & 0.5d0*(log(be)**2-log(be-1d0)**2)+
42392  & log(1d0-0.25d0*eps)*log((be-0.25d0*eps)/be)+
42393  & log(-0.25d0*eps)*log((be-1d0)/(be-0.25d0*eps))
42394  ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42395  f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
42396  & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
42397  & pyspen((1d0+0.25d0*rat*eps-ga)/(1d0+0.25d0*rat*eps),0d0,1)-
42398  & pyspen((1d0+0.25d0*rat*eps-ga)/(0.25d0*rat*eps),0d0,1)+
42399  & 0.5d0*(log(1d0+0.25d0*rat*eps)**2-log(0.25d0*rat*eps)**2)+
42400  & log(ga)*log((ga+0.25d0*rat*eps)/(1d0+0.25d0*rat*eps))+
42401  & log(ga-1d0)*log(0.25d0*rat*eps/(ga+0.25d0*rat*eps))
42402  ELSE
42403  f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
42404  & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen((be-ga)/be,0d0,1)-
42405  & pyspen((be-ga)/(be-1d0),0d0,1)+0.5d0*(log(be)**2-
42406  & log(be-1d0)**2)+log(ga)*log((ga+be-1d0)/be)+
42407  & log(ga-1d0)*log((be-1d0)/(ga+be-1d0))
42408  ENDIF
42409  f3im=0d0
42410  ELSEIF(eps.LT.1d0) THEN
42411  IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42412  f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
42413  & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
42414  & pyspen((1d0-0.25d0*eps)/(-0.25d0*(rat+1d0)*eps),0d0,1)-
42415  & pyspen(1d0/(rat+1d0),0d0,1)+log((1d0-0.25d0*eps)/
42416  & (0.25d0*eps))*log((1d0+0.25d0*(rat-1d0)*eps)/
42417  & (0.25d0*(rat+1d0)*eps))
42418  f3im=-paru(1)*log((1d0+0.25d0*(rat-1d0)*eps)/
42419  & (0.25d0*(rat+1d0)*eps))
42420  ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
42421  f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
42422  & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
42423  & pyspen((1d0-0.25d0*eps)/(1d0-0.25d0*eps-be),0d0,1)-
42424  & pyspen(-0.25d0*eps/(1d0-0.25d0*eps-be),0d0,1)+
42425  & log((1d0-0.25d0*eps)/(0.25d0*eps))*
42426  & log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
42427  f3im=-paru(1)*log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
42428  ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42429  f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
42430  & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
42431  & pyspen(ga/(ga-1d0-0.25d0*rat*eps),0d0,1)-
42432  & pyspen((ga-1d0)/(ga-1d0-0.25d0*rat*eps),0d0,1)+
42433  & log(ga/(1d0-ga))*log((ga+0.25d0*rat*eps)/
42434  & (1d0+0.25d0*rat*eps-ga))
42435  f3im=-paru(1)*log((ga+0.25d0*rat*eps)/
42436  & (1d0+0.25d0*rat*eps-ga))
42437  ELSE
42438  f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
42439  & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen(ga/(ga-be),0d0,1)-
42440  & pyspen((ga-1d0)/(ga-be),0d0,1)+log(ga/(1d0-ga))*
42441  & log((ga+be-1d0)/(be-ga))
42442  f3im=-paru(1)*log((ga+be-1d0)/(be-ga))
42443  ENDIF
42444  ELSE
42445  rsq=eps/(eps-1d0+(2d0*be-1d0)**2)
42446  rcthe=rsq*(1d0-2d0*be/eps)
42447  rsthe=sqrt(max(0d0,rsq-rcthe**2))
42448  rcphi=rsq*(1d0+2d0*(be-1d0)/eps)
42449  rsphi=sqrt(max(0d0,rsq-rcphi**2))
42450  r=sqrt(rsq)
42451  the=acos(max(-0.999999d0,min(0.999999d0,rcthe/r)))
42452  phi=acos(max(-0.999999d0,min(0.999999d0,rcphi/r)))
42453  f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-
42454  & pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+
42455  & (phi-the)*(phi+the-paru(1))
42456  f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-
42457  & pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)
42458  ENDIF
42459 
42460  y3re=2d0/(2d0*be-1d0)*f3re
42461  y3im=2d0/(2d0*be-1d0)*f3im
42462 
42463  RETURN
42464  END
42465 
42466 C***********************************************************************
42467 
42468 C...PYSPEN
42469 C...Calculates real and imaginary part of Spence function; see
42470 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42471 
42472  FUNCTION pyspen(XREIN,XIMIN,IREIM)
42473 
42474 C...Double precision and integer declarations.
42475  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42476  IMPLICIT INTEGER(I-N)
42477  INTEGER PYK,PYCHGE,PYCOMP
42478 C...Commonblocks.
42479  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42480  SAVE /pydat1/
42481 C...Local array and data.
42482  dimension b(0:14)
42483  DATA b/
42484  &1.000000d+00, -5.000000d-01, 1.666667d-01,
42485  &0.000000d+00, -3.333333d-02, 0.000000d+00,
42486  &2.380952d-02, 0.000000d+00, -3.333333d-02,
42487  &0.000000d+00, 7.575757d-02, 0.000000d+00,
42488  &-2.531135d-01, 0.000000d+00, 1.166667d+00/
42489 
42490  xre=xrein
42491  xim=ximin
42492  IF(abs(1d0-xre).LT.1d-6.AND.abs(xim).LT.1d-6) THEN
42493  IF(ireim.EQ.1) pyspen=paru(1)**2/6d0
42494  IF(ireim.EQ.2) pyspen=0d0
42495  RETURN
42496  ENDIF
42497 
42498  xmod=sqrt(xre**2+xim**2)
42499  IF(xmod.LT.1d-6) THEN
42500  IF(ireim.EQ.1) pyspen=0d0
42501  IF(ireim.EQ.2) pyspen=0d0
42502  RETURN
42503  ENDIF
42504 
42505  xarg=sign(acos(xre/xmod),xim)
42506  sp0re=0d0
42507  sp0im=0d0
42508  sgn=1d0
42509  IF(xmod.GT.1d0) THEN
42510  algxre=log(xmod)
42511  algxim=xarg-sign(paru(1),xarg)
42512  sp0re=-paru(1)**2/6d0-(algxre**2-algxim**2)/2d0
42513  sp0im=-algxre*algxim
42514  sgn=-1d0
42515  xmod=1d0/xmod
42516  xarg=-xarg
42517  xre=xmod*cos(xarg)
42518  xim=xmod*sin(xarg)
42519  ENDIF
42520  IF(xre.GT.0.5d0) THEN
42521  algxre=log(xmod)
42522  algxim=xarg
42523  xre=1d0-xre
42524  xim=-xim
42525  xmod=sqrt(xre**2+xim**2)
42526  xarg=sign(acos(xre/xmod),xim)
42527  algyre=log(xmod)
42528  algyim=xarg
42529  sp0re=sp0re+sgn*(paru(1)**2/6d0-(algxre*algyre-algxim*algyim))
42530  sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)
42531  sgn=-sgn
42532  ENDIF
42533 
42534  xre=1d0-xre
42535  xim=-xim
42536  xmod=sqrt(xre**2+xim**2)
42537  xarg=sign(acos(xre/xmod),xim)
42538  zre=-log(xmod)
42539  zim=-xarg
42540 
42541  spre=0d0
42542  spim=0d0
42543  savere=1d0
42544  saveim=0d0
42545  DO 100 i=0,14
42546  IF(max(abs(savere),abs(saveim)).LT.1d-30) GOTO 110
42547  termre=(savere*zre-saveim*zim)/dble(i+1)
42548  termim=(savere*zim+saveim*zre)/dble(i+1)
42549  savere=termre
42550  saveim=termim
42551  spre=spre+b(i)*termre
42552  spim=spim+b(i)*termim
42553  100 CONTINUE
42554 
42555  110 IF(ireim.EQ.1) pyspen=sp0re+sgn*spre
42556  IF(ireim.EQ.2) pyspen=sp0im+sgn*spim
42557 
42558  RETURN
42559  END
42560 
42561 C***********************************************************************
42562 
42563 C...PYQQBH
42564 C...Calculates the matrix element for the processes
42565 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42566 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42567 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42568 
42569  SUBROUTINE pyqqbh(WTQQBH)
42570 
42571 C...Double precision and integer declarations.
42572  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42573  IMPLICIT INTEGER(I-N)
42574  INTEGER PYK,PYCHGE,PYCOMP
42575 C...Commonblocks.
42576  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42577  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
42578  common/pypars/mstp(200),parp(200),msti(200),pari(200)
42579  common/pyint1/mint(400),vint(400)
42580  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
42581  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/
42582 C...Local arrays and function.
42583  dimension pp(15,4),clr(8,8),fm(10,10),rm(8,8),dx(8)
42584  dot(i,j)=pp(i,4)*pp(j,4)-pp(i,1)*pp(j,1)-pp(i,2)*pp(j,2)-
42585  &pp(i,3)*pp(j,3)
42586 
42587 C...Mass parameters.
42588  wtqqbh=0d0
42589  isub=mint(1)
42590  shpr=sqrt(vint(26))*vint(1)
42591  pq=pmas(pycomp(kfpr(isub,2)),1)
42592  ph=sqrt(vint(21))*vint(1)
42593  spq=pq**2
42594  sph=ph**2
42595 
42596 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42597  DO 100 i=1,2
42598  pt=sqrt(max(0d0,vint(197+5*i)))
42599  pp(i,1)=pt*cos(vint(198+5*i))
42600  pp(i,2)=pt*sin(vint(198+5*i))
42601  100 CONTINUE
42602  pp(3,1)=-pp(1,1)-pp(2,1)
42603  pp(3,2)=-pp(1,2)-pp(2,2)
42604  pms1=spq+pp(1,1)**2+pp(1,2)**2
42605  pms2=spq+pp(2,1)**2+pp(2,2)**2
42606  pms3=sph+pp(3,1)**2+pp(3,2)**2
42607  pmt3=sqrt(pms3)
42608  pp(3,3)=pmt3*sinh(vint(211))
42609  pp(3,4)=pmt3*cosh(vint(211))
42610  pms12=(shpr-pp(3,4))**2-pp(3,3)**2
42611  pp(1,3)=(-pp(3,3)*(pms12+pms1-pms2)+
42612  &vint(213)*(shpr-pp(3,4))*vint(220))/(2d0*pms12)
42613  pp(2,3)=-pp(1,3)-pp(3,3)
42614  pp(1,4)=sqrt(pms1+pp(1,3)**2)
42615  pp(2,4)=sqrt(pms2+pp(2,3)**2)
42616 
42617 C...Set up incoming kinematics and derived momentum combinations.
42618  DO 110 i=4,5
42619  pp(i,1)=0d0
42620  pp(i,2)=0d0
42621  pp(i,3)=-0.5d0*shpr*(-1)**i
42622  pp(i,4)=-0.5d0*shpr
42623  110 CONTINUE
42624  DO 120 j=1,4
42625  pp(6,j)=pp(1,j)+pp(2,j)
42626  pp(7,j)=pp(1,j)+pp(3,j)
42627  pp(8,j)=pp(1,j)+pp(4,j)
42628  pp(9,j)=pp(1,j)+pp(5,j)
42629  pp(10,j)=-pp(2,j)-pp(3,j)
42630  pp(11,j)=-pp(2,j)-pp(4,j)
42631  pp(12,j)=-pp(2,j)-pp(5,j)
42632  pp(13,j)=-pp(4,j)-pp(5,j)
42633  120 CONTINUE
42634 
42635 C...Derived kinematics invariants.
42636  x1=dot(1,2)
42637  x2=dot(1,3)
42638  x3=dot(1,4)
42639  x4=dot(1,5)
42640  x5=dot(2,3)
42641  x6=dot(2,4)
42642  x7=dot(2,5)
42643  x8=dot(3,4)
42644  x9=dot(3,5)
42645  x10=dot(4,5)
42646 
42647 C...Propagators.
42648  ss1=dot(7,7)-spq
42649  ss2=dot(8,8)-spq
42650  ss3=dot(9,9)-spq
42651  ss4=dot(10,10)-spq
42652  ss5=dot(11,11)-spq
42653  ss6=dot(12,12)-spq
42654  ss7=dot(13,13)
42655  dx(1)=ss1*ss6
42656  dx(2)=ss2*ss6
42657  dx(3)=ss2*ss4
42658  dx(4)=ss1*ss5
42659  dx(5)=ss3*ss5
42660  dx(6)=ss3*ss4
42661  dx(7)=ss7*ss1
42662  dx(8)=ss7*ss4
42663 
42664 C...Define colour coefficients for g + g -> Q + Qbar + H.
42665  IF(isub.EQ.121.OR.isub.EQ.181.OR.isub.EQ.186) THEN
42666  DO 140 i=1,3
42667  DO 130 j=1,3
42668  clr(i,j)=16d0/3d0
42669  clr(i+3,j+3)=16d0/3d0
42670  clr(i,j+3)=-2d0/3d0
42671  clr(i+3,j)=-2d0/3d0
42672  130 CONTINUE
42673  140 CONTINUE
42674  DO 160 l=1,2
42675  DO 150 i=1,3
42676  clr(i,6+l)=-6d0
42677  clr(i+3,6+l)=6d0
42678  clr(6+l,i)=-6d0
42679  clr(6+l,i+3)=6d0
42680  150 CONTINUE
42681  160 CONTINUE
42682  DO 180 k1=1,2
42683  DO 170 k2=1,2
42684  clr(6+k1,6+k2)=12d0
42685  170 CONTINUE
42686  180 CONTINUE
42687 
42688 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42689  fm(1,1)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x4+x9+2*
42690  & x7+x5)+8*pq**2*ph**2*(-x1-x4+2*x7)+16*pq**2*(x2*x9+4*x2*
42691  & x7+x2*x5-2*x4*x7-2*x9*x7)+8*ph**2*x4*x7-16*x2*x9*x7
42692  fm(1,2)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10+x9-x8+2
42693  & *x7-4*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x4-2*x2*x10+x2*x7-2*
42694  & x2*x6-2*x3*x7+2*x4*x7+4*x10*x7-x9*x7-x8*x7)+16*x2*x7*(x4+
42695  & x10)
42696  fm(1,3)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-2*x3-4*
42697  & x4-8*x10+x9+x8-2*x7-4*x6+2*x5)-(4*pq**2*ph**2)*(x1+x4+x10
42698  & +x6)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
42699  & -4*x2*x4-5*x2*x10+x2*x8-x2*x7-3*x2*x6+x2*x5+x3*x9+2*x3*x7
42700  & -x3*x5+x4*x8+2*x4*x6-3*x4*x5-5*x10*x5+x9*x8+x9*x6+x9*x5+
42701  & x8*x7-4*x6*x5+x5**2)-(16*x2*x5)*(x1+x4+x10+x6)
42702  fm(1,4)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1+x2-x3-x4+x10-
42703  & x9-x8+2*x7+2*x6-x5)+4*pq**2*ph**2*(x1+x3+x4+x10+2*x7+2*x6
42704  & )+8*pq**2*(4*x1*x10+4*x1*x7+4*x1*x6+2*x2*x10-x2*x9-x2*x8+
42705  & 4*x2*x7+4*x2*x6-x2*x5+4*x10*x5+4*x7*x5+4*x6*x5)-(8*ph**2*
42706  & x1)*(x10+x7+x6)+16*x2*x5*(x10+x7+x6)
42707  fm(1,5)=8*pq**4*(-2*x1-2*x4+x10-x9)+4*pq**2*(4*x1**2-2*x1*
42708  & x2+8*x1*x3+6*x1*x10-2*x1*x9+4*x1*x8+4*x1*x7+4*x1*x6+2*x1*
42709  & x5+x2*x10+4*x3*x4-x3*x9+2*x3*x7+3*x4*x8-2*x4*x6+2*x4*x5-4
42710  & *x10*x7+3*x10*x5-3*x9*x6+3*x8*x7-4*x7**2+4*x7*x5)+8*(x1**
42711  & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5-x1*x4*
42712  & x8-x1*x4*x5+x1*x10*x9+x1*x9*x7+x1*x9*x6-x1*x8*x7-x2*x3*x7
42713  & +x2*x4*x6-x2*x10*x7-x2*x7**2+x3*x7*x5-x4*x10*x5-x4*x7*x5-
42714  & x4*x6*x5)
42715  fm(1,6)=16*pq**4*(-4*x1-x4+x9-x7)+4*pq**2*ph**2*(-2*x1-x4-
42716  & x7)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x4-3*x1*x9-2*x1*x7-3*
42717  & x1*x5-2*x2*x4-2*x7*x5)-8*ph**2*x4*x7+8*(-x1*x2*x9-2*x1*x2
42718  & *x5-x1*x9**2-x1*x9*x5+x2**2*x7-x2*x4*x5+x2*x9*x7-x2*x7*x5
42719  & +x4*x9*x5+x4*x5**2)
42720  fm(1,7)=8*pq**4*(2*x3+x4+3*x10+x9+2*x8+3*x7+6*x6)+2*pq**2*
42721  & ph**2*(-2*x3-x4+3*x10+3*x7+6*x6)+4*pq**2*(4*x1*x10+4*x1*
42722  & x7+8*x1*x6+6*x2*x10+x2*x9+2*x2*x8+6*x2*x7+12*x2*x6-8*x3*
42723  & x7+4*x4*x7+4*x4*x6+4*x10*x5+4*x9*x7+4*x9*x6-8*x8*x7+4*x7*
42724  & x5+8*x6*x5)+4*ph**2*(-x1*x10-x1*x7-2*x1*x6+2*x3*x7-x4*x7-
42725  & x4*x6)+8*x2*(x10*x5+x9*x7+x9*x6-2*x8*x7+x7*x5+2*x6*x5)
42726  fm(1,8)=8*pq**4*(2*x3+x4+3*x10+2*x9+x8+3*x7+6*x6)+2*pq**2*
42727  & ph**2*(-2*x3-x4+2*x10+x7+2*x6)+4*pq**2*(4*x1*x10-2*x1*x9+
42728  & 2*x1*x8+4*x1*x7+8*x1*x6+5*x2*x10+2*x2*x9+x2*x8+4*x2*x7+8*
42729  & x2*x6-x3*x9-8*x3*x7+2*x3*x5+2*x4*x9-x4*x8+4*x4*x7+4*x4*x6
42730  & +4*x4*x5+5*x10*x5+x9**2-x9*x8+2*x9*x7+5*x9*x6+x9*x5-7*x8*
42731  & x7+2*x8*x5+2*x7*x5+10*x6*x5)+2*ph**2*(-x1*x10+x3*x7-2*x4*
42732  & x7+x4*x6)+4*(-x1*x9**2+x1*x9*x8-2*x1*x9*x5-x1*x8*x5+2*x2*
42733  & x10*x5+x2*x9*x7+x2*x9*x6-2*x2*x8*x7+3*x2*x6*x5+x3*x9*x5+
42734  & x3*x5**2+x4*x9*x5-2*x4*x8*x5+2*x4*x5**2)
42735  fm(2,2)=16*pq**6+16*pq**4*(-x1+x3-x4-x10+x7-x6)+16*pq**2*(
42736  & x3*x10+x3*x7+x3*x6+x4*x7+x10*x7)-16*x3*x10*x7
42737  fm(2,3)=16*pq**6+8*pq**4*(-2*x1+x2+2*x3-4*x4-4*x10-x9+x8-2
42738  & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5+4*x3*x10-x3*x9-x3*x8-2*x3*
42739  & x7+2*x3*x6+x3*x5-2*x4*x5-2*x10*x5-2*x6*x5)+16*x3*x5*(x10+
42740  & x6)
42741  fm(2,4)=8*pq**4*(-2*x1-2*x3+x10-x8)+4*pq**2*(4*x1**2-2*x1*
42742  & x2+8*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+4*x1*x7+4*x1*x6+2*x1*
42743  & x5+x2*x10+4*x3*x4+3*x3*x9-2*x3*x7+2*x3*x5-x4*x8+2*x4*x6-4
42744  & *x10*x6+3*x10*x5+3*x9*x6-3*x8*x7-4*x6**2+4*x6*x5)+8*(-x1
42745  & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9-x1*x3*x5+x1*x4
42746  & *x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x1*x8*x6+x2*x3*
42747  & x7-x2*x4*x6-x2*x10*x6-x2*x6**2-x3*x10*x5-x3*x7*x5-x3*x6*
42748  & x5+x4*x6*x5)
42749  fm(2,5)=16*pq**4*x10+8*pq**2*(2*x1**2+2*x1*x3+2*x1*x4+2*x1
42750  & *x10+2*x1*x7+2*x1*x6+x3*x7+x4*x6)+8*(-2*x1**3-2*x1**2*x3-
42751  & 2*x1**2*x4-2*x1**2*x10-2*x1**2*x7-2*x1**2*x6-2*x1*x3*x4-
42752  & x1*x3*x10-2*x1*x3*x6-x1*x4*x10-2*x1*x4*x7-x1*x10**2-x1*
42753  & x10*x7-x1*x10*x6-2*x1*x7*x6+x3**2*x7-x3*x4*x7-x3*x4*x6+x3
42754  & *x10*x7+x3*x7**2-x3*x7*x6+x4**2*x6+x4*x10*x6-x4*x7*x6+x4*
42755  & x6**2)
42756  fm(2,6)=8*pq**4*(-2*x1+x10-x9-2*x7)+4*pq**2*(4*x1**2+2*x1*
42757  & x2+4*x1*x3+4*x1*x4+6*x1*x10-2*x1*x9+4*x1*x8+8*x1*x6-2*x1*
42758  & x5+4*x2*x4+3*x2*x10+2*x2*x7-3*x3*x9-2*x3*x7-4*x4**2-4*x4*
42759  & x10+3*x4*x8+2*x4*x6+x10*x5-x9*x6+3*x8*x7+4*x7*x6)+8*(x1**
42760  & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5+x1*x4*
42761  & x9-x1*x4*x8-x1*x4*x5+x1*x10*x9+x1*x9*x6-x1*x8*x7-x2*x3*x7
42762  & -x2*x4*x7+x2*x4*x6-x2*x10*x7+x3*x7*x5-x4**2*x5-x4*x10*x5-
42763  & x4*x6*x5)
42764  fm(2,7)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
42765  & 2*x1*x4-2*x1*x10+x1*x9-x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
42766  & x4+3*x2*x10+x2*x7+2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9-2*x3*
42767  & x7-4*x3*x6-x3*x5-6*x4**2-6*x4*x10-3*x4*x9-x4*x8-4*x4*x7-2
42768  & *x4*x6-2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+x10*x5
42769  & +x9*x7-2*x8*x7-2*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
42770  & -x1**2*x9+x1**2*x8-2*x1*x2*x10-3*x1*x2*x7-3*x1*x2*x6+x1*
42771  & x3*x9-x1*x3*x5+x1*x4*x9+x1*x4*x8+x1*x4*x5+x1*x10*x9+x1*
42772  & x10*x8-x1*x9*x6+x1*x8*x6+x2*x3*x7-3*x2*x4*x7-x2*x4*x6-3*
42773  & x2*x10*x7-3*x2*x10*x6-3*x2*x7*x6-3*x2*x6**2-2*x3*x4*x5-x3
42774  & *x10*x5-x3*x6*x5-x4**2*x5-x4*x10*x5+x4*x6*x5)
42775  fm(2,8)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
42776  & 2*x1*x4-2*x1*x10-x1*x9+x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
42777  & x4+x2*x10-x2*x7-2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9+x3*x8-2*
42778  & x3*x7-4*x3*x6+x3*x5-6*x4**2-6*x4*x10-2*x4*x9-4*x4*x7-2*x4
42779  & *x6+2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+3*x10*x5-
42780  & x9*x6-2*x8*x7-3*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
42781  & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6-3*x1*x3*x5+x1*x4*x9-
42782  & x1*x4*x8-3*x1*x4*x5+x1*x10*x9+x1*x10*x8-2*x1*x10*x5+x1*x9
42783  & *x6+x1*x8*x7+x1*x8*x6-x2*x4*x7+x2*x4*x6-x2*x10*x7-x2*x10*
42784  & x6-2*x2*x7*x6-x2*x6**2-3*x3*x4*x5-3*x3*x10*x5+x3*x7*x5-3*
42785  & x3*x6*x5-3*x4**2*x5-3*x4*x10*x5-x4*x6*x5)
42786  fm(3,3)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x3+x8+x6
42787  & +2*x5)+8*pq**2*ph**2*(-x1+2*x3-x6)+16*pq**2*(x2*x5-2*x3*
42788  & x8-2*x3*x6+4*x3*x5+x8*x5)+8*ph**2*x3*x6-16*x3*x8*x5
42789  fm(3,4)=16*pq**4*(-4*x1-x3+x8-x6)+4*pq**2*ph**2*(-2*x1-x3-
42790  & x6)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x3-3*x1*x8-2*x1*x6-3*
42791  & x1*x5-2*x2*x3-2*x6*x5)-8*ph**2*x3*x6+8*(-x1*x2*x8-2*x1*x2
42792  & *x5-x1*x8**2-x1*x8*x5+x2**2*x6-x2*x3*x5+x2*x8*x6-x2*x6*x5
42793  & +x3*x8*x5+x3*x5**2)
42794  fm(3,5)=8*pq**4*(-2*x1+x10-x8-2*x6)+4*pq**2*(4*x1**2+2*x1*
42795  & x2+4*x1*x3+4*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+8*x1*x7-2*x1*
42796  & x5+4*x2*x3+3*x2*x10+2*x2*x6-4*x3**2-4*x3*x10+3*x3*x9+2*x3
42797  & *x7-3*x4*x8-2*x4*x6+x10*x5+3*x9*x6-x8*x7+4*x7*x6)+8*(-x1
42798  & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9+x1*x3*x8-x1*x3
42799  & *x5+x1*x4*x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x2*x3*
42800  & x7-x2*x3*x6-x2*x4*x6-x2*x10*x6-x3**2*x5-x3*x10*x5-x3*x7*
42801  & x5+x4*x6*x5)
42802  fm(3,6)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1-x2+2*x3+2*x4+
42803  & x10-x9-x8-x7-x6+x5)+4*pq**2*ph**2*(x1+2*x3+2*x4+x10+x7+x6
42804  & )+8*pq**2*(4*x1*x3+4*x1*x4+4*x1*x10+4*x2*x3+4*x2*x4+4*x2*
42805  & x10-x2*x5+4*x3*x5+4*x4*x5+2*x10*x5-x9*x5-x8*x5)-(8*ph**2*
42806  & x1)*(x3+x4+x10)+16*x2*x5*(x3+x4+x10)
42807  fm(3,7)=8*pq**4*(3*x3+6*x4+3*x10+x9+2*x8+2*x7+x6)+2*pq**2*
42808  & ph**2*(x3+2*x4+2*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+4*
42809  & x1*x10+2*x1*x9-2*x1*x8+2*x2*x3+10*x2*x4+5*x2*x10+2*x2*x9+
42810  & x2*x8+2*x2*x7+4*x2*x6-7*x3*x9+2*x3*x8-8*x3*x7+4*x3*x6+4*
42811  & x3*x5+5*x4*x8+4*x4*x6+8*x4*x5+5*x10*x5-x9*x8-x9*x6+x9*x5+
42812  & x8**2-x8*x7+2*x8*x6+2*x8*x5)+2*ph**2*(-x1*x10+x3*x7-2*x3*
42813  & x6+x4*x6)+4*(-x1*x2*x9-2*x1*x2*x8+x1*x9*x8-x1*x8**2+x2**2
42814  & *x7+2*x2**2*x6+3*x2*x4*x5+2*x2*x10*x5-2*x2*x9*x6+x2*x8*x7
42815  & +x2*x8*x6-2*x3*x9*x5+x3*x8*x5+x4*x8*x5)
42816  fm(3,8)=8*pq**4*(3*x3+6*x4+3*x10+2*x9+x8+2*x7+x6)+2*pq**2*
42817  & ph**2*(3*x3+6*x4+3*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+
42818  & 4*x1*x10+4*x2*x3+8*x2*x4+4*x2*x10-8*x3*x9+4*x3*x8-8*x3*x7
42819  & +4*x3*x6+6*x3*x5+4*x4*x8+4*x4*x6+12*x4*x5+6*x10*x5+2*x9*
42820  & x5+x8*x5)+4*ph**2*(-x1*x3-2*x1*x4-x1*x10+2*x3*x7-x3*x6-x4
42821  & *x6)+8*x5*(x2*x3+2*x2*x4+x2*x10-2*x3*x9+x3*x8+x4*x8)
42822  fm(4,4)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x3+x8+2*
42823  & x6+x5)+8*pq**2*ph**2*(-x1-x3+2*x6)+16*pq**2*(x2*x8+4*x2*
42824  & x6+x2*x5-2*x3*x6-2*x8*x6)+8*ph**2*x3*x6-16*x2*x8*x6
42825  fm(4,5)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10-x9+x8-4
42826  & *x7+2*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x3-2*x2*x10-2*x2*x7+
42827  & x2*x6+2*x3*x6-2*x4*x6+4*x10*x6-x9*x6-x8*x6)+16*x2*x6*(x3+
42828  & x10)
42829  fm(4,6)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-4*x3-2*
42830  & x4-8*x10+x9+x8-4*x7-2*x6+2*x5)-(4*pq**2*ph**2)*(x1+x3+x10
42831  & +x7)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
42832  & -4*x2*x3-5*x2*x10+x2*x9-3*x2*x7-x2*x6+x2*x5+x3*x9+2*x3*x7
42833  & -3*x3*x5+x4*x8+2*x4*x6-x4*x5-5*x10*x5+x9*x8+x9*x6+x8*x7+
42834  & x8*x5-4*x7*x5+x5**2)-(16*x2*x5)*(x1+x3+x10+x7)
42835  fm(4,7)=8*pq**4*(-x3-2*x4-3*x10-2*x9-x8-6*x7-3*x6)+2*pq**2
42836  & *ph**2*(x3+2*x4-3*x10-6*x7-3*x6)+4*pq**2*(-4*x1*x10-8*x1*
42837  & x7-4*x1*x6-6*x2*x10-2*x2*x9-x2*x8-12*x2*x7-6*x2*x6-4*x3*
42838  & x7-4*x3*x6+8*x4*x6-4*x10*x5+8*x9*x6-4*x8*x7-4*x8*x6-8*x7*
42839  & x5-4*x6*x5)+4*ph**2*(x1*x10+2*x1*x7+x1*x6+x3*x7+x3*x6-2*
42840  & x4*x6)+8*x2*(-x10*x5+2*x9*x6-x8*x7-x8*x6-2*x7*x5-x6*x5)
42841  fm(4,8)=8*pq**4*(-x3-2*x4-3*x10-x9-2*x8-6*x7-3*x6)+2*pq**2
42842  & *ph**2*(x3+2*x4-2*x10-2*x7-x6)+4*pq**2*(-4*x1*x10-2*x1*x9
42843  & +2*x1*x8-8*x1*x7-4*x1*x6-5*x2*x10-x2*x9-2*x2*x8-8*x2*x7-4
42844  & *x2*x6+x3*x9-2*x3*x8-4*x3*x7-4*x3*x6-4*x3*x5+x4*x8+8*x4*
42845  & x6-2*x4*x5-5*x10*x5+x9*x8+7*x9*x6-2*x9*x5-x8**2-5*x8*x7-2
42846  & *x8*x6-x8*x5-10*x7*x5-2*x6*x5)+2*ph**2*(x1*x10-x3*x7+2*x3
42847  & *x6-x4*x6)+4*(-x1*x9*x8+x1*x9*x5+x1*x8**2+2*x1*x8*x5-2*x2
42848  & *x10*x5+2*x2*x9*x6-x2*x8*x7-x2*x8*x6-3*x2*x7*x5+2*x3*x9*
42849  & x5-x3*x8*x5-2*x3*x5**2-x4*x8*x5-x4*x5**2)
42850  fm(5,5)=16*pq**6+16*pq**4*(-x1-x3+x4-x10-x7+x6)+16*pq**2*(
42851  & x3*x6+x4*x10+x4*x7+x4*x6+x10*x6)-16*x4*x10*x6
42852  fm(5,6)=16*pq**6+8*pq**4*(-2*x1+x2-4*x3+2*x4-4*x10+x9-x8-2
42853  & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5-2*x3*x5+4*x4*x10-x4*x9-x4*
42854  & x8+2*x4*x7-2*x4*x6+x4*x5-2*x10*x5-2*x7*x5)+16*x4*x5*(x10+
42855  & x7)
42856  fm(5,7)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
42857  & 4*x1*x4+2*x1*x10+x1*x9-x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
42858  & x4-3*x2*x10-2*x2*x7-x2*x6+6*x3**2+6*x3*x4+6*x3*x10+x3*x9+
42859  & 3*x3*x8+2*x3*x7+4*x3*x6+2*x3*x5+6*x4*x10+2*x4*x8+4*x4*x7+
42860  & 2*x4*x6+x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-x10*x5+
42861  & 2*x9*x7+2*x9*x6-x8*x6+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(-
42862  & x1**2*x9+x1**2*x8+2*x1*x2*x10+3*x1*x2*x7+3*x1*x2*x6-x1*x3
42863  & *x9-x1*x3*x8-x1*x3*x5-x1*x4*x8+x1*x4*x5-x1*x10*x9-x1*x10*
42864  & x8-x1*x9*x7+x1*x8*x7+x2*x3*x7+3*x2*x3*x6-x2*x4*x6+3*x2*
42865  & x10*x7+3*x2*x10*x6+3*x2*x7**2+3*x2*x7*x6+x3**2*x5+2*x3*x4
42866  & *x5+x3*x10*x5-x3*x7*x5+x4*x10*x5+x4*x7*x5)
42867  fm(5,8)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
42868  & 4*x1*x4+2*x1*x10-x1*x9+x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
42869  & x4-x2*x10+2*x2*x7+x2*x6+6*x3**2+6*x3*x4+6*x3*x10+2*x3*x8+
42870  & 2*x3*x7+4*x3*x6-2*x3*x5+6*x4*x10-x4*x9+2*x4*x8+4*x4*x7+2*
42871  & x4*x6-x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-3*x10*x5+
42872  & 3*x9*x7+2*x9*x6+x8*x7+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(
42873  & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9-x1*x3*x8+3*
42874  & x1*x3*x5+3*x1*x4*x5-x1*x10*x9-x1*x10*x8+2*x1*x10*x5-x1*x9
42875  & *x7-x1*x9*x6-x1*x8*x7-x2*x3*x7+x2*x3*x6+x2*x10*x7+x2*x10*
42876  & x6+x2*x7**2+2*x2*x7*x6+3*x3**2*x5+3*x3*x4*x5+3*x3*x10*x5+
42877  & x3*x7*x5+3*x4*x10*x5+3*x4*x7*x5-x4*x6*x5)
42878  fm(6,6)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x4+x9+x7
42879  & +2*x5)+8*pq**2*ph**2*(-x1+2*x4-x7)+16*pq**2*(x2*x5-2*x4*
42880  & x9-2*x4*x7+4*x4*x5+x9*x5)+8*ph**2*x4*x7-16*x4*x9*x5
42881  fm(6,7)=8*pq**4*(-6*x3-3*x4-3*x10-2*x9-x8-x7-2*x6)+2*pq**2
42882  & *ph**2*(-2*x3-x4-2*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*x4
42883  & -4*x1*x10+2*x1*x9-2*x1*x8-10*x2*x3-2*x2*x4-5*x2*x10-x2*x9
42884  & -2*x2*x8-4*x2*x7-2*x2*x6-5*x3*x9-4*x3*x7-8*x3*x5-2*x4*x9+
42885  & 7*x4*x8-4*x4*x7+8*x4*x6-4*x4*x5-5*x10*x5-x9**2+x9*x8-2*x9
42886  & *x7+x9*x6-2*x9*x5+x8*x7-x8*x5)+2*ph**2*(x1*x10-x3*x7+2*x4
42887  & *x7-x4*x6)+4*(2*x1*x2*x9+x1*x2*x8+x1*x9**2-x1*x9*x8-2*x2
42888  & **2*x7-x2**2*x6-3*x2*x3*x5-2*x2*x10*x5-x2*x9*x7-x2*x9*x6+
42889  & 2*x2*x8*x7-x3*x9*x5-x4*x9*x5+2*x4*x8*x5)
42890  fm(6,8)=8*pq**4*(-6*x3-3*x4-3*x10-x9-2*x8-x7-2*x6)+2*pq**2
42891  & *ph**2*(-6*x3-3*x4-3*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*
42892  & x4-4*x1*x10-8*x2*x3-4*x2*x4-4*x2*x10-4*x3*x9-4*x3*x7-12*
42893  & x3*x5-4*x4*x9+8*x4*x8-4*x4*x7+8*x4*x6-6*x4*x5-6*x10*x5-x9
42894  & *x5-2*x8*x5)+4*ph**2*(2*x1*x3+x1*x4+x1*x10+x3*x7+x4*x7-2*
42895  & x4*x6)+8*x5*(-2*x2*x3-x2*x4-x2*x10-x3*x9-x4*x9+2*x4*x8)
42896  fm(7,7)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+9*
42897  & x2*x10+7*x3*x7+2*x3*x6+2*x4*x7+7*x4*x6+x10*x5+2*x9*x7+7*
42898  & x9*x6+7*x8*x7+2*x8*x6)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2
42899  & *x4*x7-7*x4*x6)+4*x2*(x10*x5+2*x9*x7+7*x9*x6+7*x8*x7+2*x8
42900  & *x6)
42901  fm(7,8)=72*pq**4*x10+2*pq**2*ph**2*x10+4*pq**2*(2*x1*x10+
42902  & 10*x2*x10+7*x3*x9+2*x3*x8+14*x3*x7+4*x3*x6+2*x4*x9+7*x4*
42903  & x8+4*x4*x7+14*x4*x6+10*x10*x5+x9**2+7*x9*x8+2*x9*x7+7*x9*
42904  & x6+x8**2+7*x8*x7+2*x8*x6)+2*ph**2*(7*x1*x10-7*x3*x7-2*x3*
42905  & x6-2*x4*x7-7*x4*x6)+2*(-2*x1*x9**2-14*x1*x9*x8-2*x1*x8**2
42906  & +2*x2*x10*x5+2*x2*x9*x7+7*x2*x9*x6+7*x2*x8*x7+2*x2*x8*x6+
42907  & 7*x3*x9*x5+2*x3*x8*x5+2*x4*x9*x5+7*x4*x8*x5)
42908  fm(8,8)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+x2
42909  & *x10+7*x3*x9+2*x3*x8+7*x3*x7+2*x3*x6+2*x4*x9+7*x4*x8+2*x4
42910  & *x7+7*x4*x6+9*x10*x5)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2*
42911  & x4*x7-7*x4*x6)+4*x5*(x2*x10+7*x3*x9+2*x3*x8+2*x4*x9+7*x4*
42912  & x8)
42913  fm(9,9)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
42914  & x3*x7+x4*x6-x10*x5+x9*x6+x8*x7)+ph**2*(x1*x10-x3*x7-x4*x6
42915  & )+2*x2*(-x10*x5+x9*x6+x8*x7)
42916  fm(9,10)=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
42917  & x10+2*x3*x9+2*x3*x7+2*x4*x6-2*x10*x5+x9*x8+2*x8*x7)+ph**2
42918  & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x8*x7+x3*
42919  & x9*x5)
42920  fmxx=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
42921  & x10+2*x4*x8+2*x4*x6+2*x3*x7-2*x10*x5+x9*x8+2*x9*x6)+ph**2
42922  & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x9*x6+x4*
42923  & x8*x5)
42924  fm(9,10)=0.5d0*(fmxx+fm(9,10))
42925  fm(10,10)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
42926  & x3*x7+x4*x6-x10*x5+x9*x3+x8*x4)+ph**2*(x1*x10-x3*x7-x4*x6
42927  & )+2*x5*(-x10*x2+x9*x3+x8*x4)
42928 
42929 C...Repackage matrix elements.
42930  DO 200 i=1,8
42931  DO 190 j=i,8
42932  rm(i,j)=fm(i,j)
42933  190 CONTINUE
42934  200 CONTINUE
42935  rm(7,7)=fm(7,7)-2d0*fm(9,9)
42936  rm(7,8)=fm(7,8)-2d0*fm(9,10)
42937  rm(8,8)=fm(8,8)-2d0*fm(10,10)
42938 
42939 C...Produce final result: matrix elements * colours * propagators.
42940  DO 220 i=1,8
42941  DO 210 j=i,8
42942  fac=8d0
42943  IF(i.EQ.j)fac=4d0
42944  wtqqbh=wtqqbh+rm(i,j)*fac*clr(i,j)/(dx(i)*dx(j))
42945  210 CONTINUE
42946  220 CONTINUE
42947  wtqqbh=-wtqqbh/256d0
42948 
42949  ELSE
42950 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
42951  a11=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x2*x10+x3
42952  & *x7+x4*x6+x9*x6+x8*x7)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x2)*(x9
42953  & *x6+x8*x7)
42954  a12=-8d0*pq**4*x10+4d0*pq**2*(-x2*x10-x3*x9-2d0*x3*x7-x4*x8-
42955  & 2d0*x4*x6-x10*x5-x9*x8-x9*x6-x8*x7)+2d0*ph**2*(-x1*x10+x3*x7
42956  & +x4*x6)+2d0*(2d0*x1*x9*x8-x2*x9*x6-x2*x8*x7-x3*x9*x5-x4*x8*
42957  & x5)
42958  a22=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x3*x9+x3*
42959  & x7+x4*x8+x4*x6+x10*x5)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x5)*(x3
42960  & *x9+x4*x8)
42961 
42962 C...Produce final result: matrix elements * propagators.
42963  a11=a11/dx(7)**2
42964  a12=a12/(dx(7)*dx(8))
42965  a22=a22/dx(8)**2
42966  wtqqbh=-(a11+a22+2d0*a12)*8d0/9d0
42967  ENDIF
42968 
42969  RETURN
42970  END
42971 
42972 C*********************************************************************
42973 
42974 C...PYSTBH (and auxiliaries)
42975 C.. Evaluates the matrix elements for t + b + H production.
42976 
42977  SUBROUTINE pystbh(WTTBH)
42978 
42979 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
42980  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42981  IMPLICIT INTEGER(I-N)
42982  INTEGER PYK,PYCHGE,PYCOMP
42983 
42984 C...COMMONBLOCKS
42985  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42986  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
42987  common/pypars/mstp(200),parp(200),msti(200),pari(200)
42988  common/pyint1/mint(400),vint(400)
42989  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
42990  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
42991  common/pyint4/mwid(500),wids(500,5)
42992  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
42993  common/pymssm/imss(0:99),rmss(0:99)
42994  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
42995  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
42996  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
42997  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
42998  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
42999  DOUBLE PRECISION MW2
43000  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
43001  &/pyint4/,/pysubs/,/pymssm/,/pysgcm/,/pyctbh/
43002 
43003 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43004  dimension qq(4,2),pp(4,3)
43005  DATA qq/8*0d0/
43006 
43007  wttbh=0d0
43008 
43009 C...KINEMATIC PARAMETERS.
43010  shpr=sqrt(vint(26))*vint(1)
43011  ph=sqrt(vint(21))*vint(1)
43012  sph=ph**2
43013 
43014 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43015  DO 100 i=1,2
43016  pt=sqrt(max(0d0,vint(197+5*i)))
43017  pp(1,i)=pt*cos(vint(198+5*i))
43018  pp(2,i)=pt*sin(vint(198+5*i))
43019  100 CONTINUE
43020  pp(1,3)=-pp(1,1)-pp(1,2)
43021  pp(2,3)=-pp(2,1)-pp(2,2)
43022  pms1=vint(201)**2+pp(1,1)**2+pp(2,1)**2
43023  pms2=vint(206)**2+pp(1,2)**2+pp(2,2)**2
43024  pms3=sph+pp(1,3)**2+pp(2,3)**2
43025  pmt3=sqrt(pms3)
43026  pp(3,3)=pmt3*sinh(vint(211))
43027  pp(4,3)=pmt3*cosh(vint(211))
43028  pms12=(shpr-pp(4,3))**2-pp(3,3)**2
43029  pp(3,1)=(-pp(3,3)*(pms12+pms1-pms2)+
43030  &vint(213)*(shpr-pp(4,3))*vint(220))/(2d0*pms12)
43031  pp(3,2)=-pp(3,1)-pp(3,3)
43032  pp(4,1)=sqrt(pms1+pp(3,1)**2)
43033  pp(4,2)=sqrt(pms2+pp(3,2)**2)
43034 
43035 C...CM SYSTEM, INGOING QUARKS/GLUONS
43036  qq(3,1) = shpr/2.d0
43037  qq(4,1) = qq(3,1)
43038  qq(3,2) = -qq(3,1)
43039  qq(4,2) = qq(4,1)
43040 
43041 C...PARAMETERS FOR AMPLITUDE METHOD
43042  alpha = aem
43043  alphas = as
43044  sw2 = paru(102)
43045  mw2 = pmas(24,1)**2
43046  tanb = paru(141)
43047  vtb = vckm(3,3)
43048  rmb=pymrun(5,vint(52))
43049 
43050  isub=mint(1)
43051 
43052  IF (isub.EQ.401) THEN
43053  CALL pytbhg(qq(1,1),qq(1,2),pp(1,1),pp(1,2),pp(1,3),
43054  & vint(201),vint(206),rmb,vint(43),wttbh)
43055  ELSE IF (isub.EQ.402) THEN
43056  CALL pytbhq(qq(1,1),qq(1,2),pp(1,1),pp(1,2),pp(1,3),
43057  & vint(201),vint(206),rmb,vint(43),wttbh)
43058  END IF
43059 
43060  RETURN
43061  END
43062 C------------------------------------------------------------------
43063  SUBROUTINE pytbhb(MT,MB,MHP,BR,GAMT)
43064 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43065  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43066  IMPLICIT INTEGER(I-N)
43067  DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43068  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
43069  SAVE /pyctbh/
43070 
43071 C TOP WIDTH CALCULATION
43072 C VTB = 0.99
43073  mw=dsqrt(mw2)
43074  xb=(mb/mt)**2
43075  xw=(mw/mt)**2
43076  xh =(mhp/mt)**2
43077  gamtbh = 0d0
43078  IF (mt .LT. (mhp+mb)) THEN
43079 C T ->B W ONLY
43080  betw = dsqrt(1.d0-2*(xb+xw)+(xw-xb)**2)
43081  gamtbw = vtb**2*alpha/(16*sw2)*mt/xw*betw*
43082  & (2*(1.d0-xb-xw)-(1.d0+xb-xw)*(1.d0-xb -2*xw) )
43083  gamt = gamtbw
43084  ELSE
43085 C T ->BW +T ->B H^+
43086  betw = dsqrt(1.d0-2*(xb+xw)+(xw-xb)**2)
43087  gamtbw = vtb**2*alpha/(16*sw2)*mt/xw*betw*
43088  & (2*(1.d0-xb-xw)-(1.d0+xb-xw)*(1.d0-xb -2*xw) )
43089 C
43090  kfun = dsqrt( (1.d0-(mhp/mt)**2-(mb/mt)**2)**2
43091  & -4.d0*(mhp*mb/mt**2)**2 )
43092  gamtbh= alpha/sw2/8.d0*vtb**2*kfun/mt *
43093  & (v**2*((mt+mb)**2-mhp**2)+a**2*((mt-mb)**2-mhp**2))
43094  gamt = gamtbw+gamtbh
43095  ENDIF
43096 C THUS BR IS
43097  br=gamtbh/gamt
43098  RETURN
43099  END
43100 
43101 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43102 C GG->TBH^+, QQBAR->TBH^+
43103 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43104 C (FOR INSTANCE WITH PYTHIA)
43105 C------------------------------------------------------------
43106 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43107 C PHYS REV. D 60 (1999) 115011
43108 C (THESE FILES PREPARED BY J.-L. KNEUR)
43109 C------------------------------------------------------------
43110 C 1) GG->TBH^+
43111  SUBROUTINE pytbhg(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43112 C
43113 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43114 C
43115 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43116 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43117 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43118 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43119 C "PHYSICAL PARAMETERS" INPUT:
43120 C MT,MB TOP AND BOTTOM MASSES;
43121 C MHP CHARGED HIGGS MASS
43122 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43123 C
43124 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43125 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43126 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43127 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43128 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43129 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43130 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43131 C
43132  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43133  IMPLICIT INTEGER(I-N)
43134  DOUBLE PRECISION MW2,MT,MB,MHP,MW
43135  dimension q1(4),q2(4),p1(4),p2(4),p3(4)
43136  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43137  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43138  common/pymssm/imss(0:99),rmss(0:99)
43139 
43140  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
43141  SAVE /pydat1/,/pydat2/,/pymssm/,/pyctbh/
43142 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43143 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43144 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43145 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43146 C (TAN BETA) VALUES
43147 C
43148 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43149 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43150 
43151  pi = 4*datan(1.d0)
43152  mw = dsqrt(mw2)
43153 C
43154 C COLLECTING THE RELEVANT OVERALL FACTORS:
43155 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43156  ps=1.d0/(8.d0*8.d0 *2.d0*2.d0)
43157 C COUPLING CONSTANT (OVERALL NORMALIZATION)
43158  fact=(4.d0*pi*alpha)*(4.d0*pi*alphas)**2/sw2/2.d0
43159 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43160 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43161 C ALPHAS IS ALPHA_STRONG;
43162 C SW2 IS SIN(THETA_W)**2.
43163 C
43164 C VTB=.998D0
43165 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43166 C
43167  v = ( mt/mw/tanb +rmb/mw*tanb)/2.d0
43168  a = (-mt/mw/tanb +rmb/mw*tanb)/2.d0
43169 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43170 C
43171 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43172 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43173  DO 100 kk=1,4
43174  p2(kk)=p3(kk)-q1(kk)-q2(kk)+p1(kk)
43175  100 CONTINUE
43176 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43177  s = 2*pytbhs(q1,q2)
43178  p1q1=pytbhs(q1,p1)
43179  p1q2=pytbhs(p1,q2)
43180  p2q1=pytbhs(p2,q1)
43181  p2q2=pytbhs(p2,q2)
43182  p1p2=pytbhs(p1,p2)
43183 C
43184 C TOP WIDTH CALCULATION
43185  CALL pytbhb(mt,mb,mhp,br,gamt)
43186 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43187 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43188  a1inv= s -2*p1q1 -2*p1q2
43189  a1 =a1inv/(a1inv**2+ (gamt*mt)**2)
43190 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43191 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43192 C THE TOP WIDTH
43193  a12 = 1.d0/(a1inv**2+ (gamt*mt)**2)
43194  a2 =1.d0/(s +2*p2q1 +2*p2q2)
43195 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43196 C NOW COMES THE AMP**2:
43197 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43198 C THE EXPRESSIONS BELOW
43199  v18=0.d0
43200  a18=0.d0
43201  v18= 640*a1/3+640*a2/3+32*a1*a2*mb**2-368*a12*mb*mt-
43202  &512*a1*a2*mb*mt/3-
43203  &368*a2**2*mb*mt+32*a1*a2*mt**2+496*a12*p1p2/3+
43204  &320*a1*a2*p1p2+496*a2**2*p1p2/3+128*a1*mb*mt**3/(3*p1q1**2)+
43205  &128*a1*mt**4/(3*p1q1**2)-256*a12*mb*mt**5/(3*p1q1**2)+
43206  &256*a1*mt**2*p1p2/(3*p1q1**2)-256*a12*mt**4*p1p2/(3*p1q1**2)+
43207  &8/(3*p1q1)-32*a1*mb*mt/p1q1-56*a2*mb*mt/(3*p1q1)+
43208  &88*a1*mt**2/(3*p1q1)+72*a2*mt**2/p1q1+
43209  &704*a12*mb*mt**3/(3*p1q1)-224*a1*a2*mb*mt**3/(3*p1q1)+
43210  &104*a1*p1p2/(3*p1q1)+48*a2*p1p2/p1q1+
43211  &128*a1*a2*mb*mt*p1p2/(3*p1q1)+512*a12*mt**2*p1p2/(3*p1q1)-
43212  &448*a1*a2*mt**2*p1p2/(3*p1q1)-32*a1*a2*p1p2**2/p1q1-
43213  &656*a1*a2*p1q1/3-224*a2**2*p1q1+128*a1*mb*mt**3/(3*p1q2**2)+
43214  &128*a1*mt**4/(3*p1q2**2)-256*a12*mb*mt**5/(3*p1q2**2)+
43215  &256*a1*mt**2*p1p2/(3*p1q2**2)-256*a12*mt**4*p1p2/(3*p1q2**2)+
43216  &256*a1*mt**2*p1q1/(3*p1q2**2)+256*a12*mb*mt**3*p1q1/(3*p1q2**2)+
43217  &8/(3*p1q2)-32*a1*mb*mt/p1q2-56*a2*mb*mt/(3*p1q2)
43218  v18=v18+88*a1*mt**2/(3*p1q2)+72*a2*mt**2/p1q2+
43219  &704*a12*mb*mt**3/(3*p1q2)-224*a1*a2*mb*mt**3/(3*p1q2)+
43220  &104*a1*p1p2/(3*p1q2)+48*a2*p1p2/p1q2+
43221  &128*a1*a2*mb*mt*p1p2/(3*p1q2)+512*a12*mt**2*p1p2/(3*p1q2)-
43222  &448*a1*a2*mt**2*p1p2/(3*p1q2)-32*a1*a2*p1p2**2/p1q2-
43223  &32*a1*mb*mt**3/(3*p1q1*p1q2)-32*a1*mt**4/(3*p1q1*p1q2)+
43224  &64*a12*mb*mt**5/(3*p1q1*p1q2)+16*p1p2/(3*p1q1*p1q2)-
43225  &64*a1*mt**2*p1p2/(3*p1q1*p1q2)+64*a12*mt**4*p1p2/(3*p1q1*p1q2)+
43226  &112*a1*p1q1/p1q2+272*a2*p1q1/(3*p1q2)-
43227  &272*a1*a2*mb**2*p1q1/(3*p1q2)+208*a12*mb*mt*p1q1/(3*p1q2)-
43228  &400*a1*a2*mb*mt*p1q1/(3*p1q2)-80*a1*a2*mt**2*p1q1/p1q2+
43229  &96*a12*p1p2*p1q1/p1q2-320*a1*a2*p1p2*p1q1/p1q2-
43230  &544*a1*a2*p1q1**2/(3*p1q2)-656*a1*a2*p1q2/3-224*a2**2*p1q2+
43231  &256*a1*mt**2*p1q2/(3*p1q1**2)+256*a12*mb*mt**3*p1q2/(3*p1q1**2)+
43232  &112*a1*p1q2/p1q1+272*a2*p1q2/(3*p1q1)-
43233  &272*a1*a2*mb**2*p1q2/(3*p1q1)+208*a12*mb*mt*p1q2/(3*p1q1)-
43234  &400*a1*a2*mb*mt*p1q2/(3*p1q1)-80*a1*a2*mt**2*p1q2/p1q1
43235  v18=v18+96*a12*p1p2*p1q2/p1q1-320*a1*a2*p1p2*p1q2/p1q1-
43236  &544*a1*a2*p1q2**2/(3*p1q1)+128*a2*mb**4/(3*p2q1**2)+
43237  &128*a2*mb**3*mt/(3*p2q1**2)-256*a2**2*mb**5*mt/(3*p2q1**2)+
43238  &256*a2*mb**2*p1p2/(3*p2q1**2)-256*a2**2*mb**4*p1p2/(3*p2q1**2)+
43239  &256*a2*mb**2*p1q1/(3*p2q1**2)-256*a2**2*mb**4*p1q1/(3*p2q1**2)-
43240  &64*mb**3*mt**3/(3*p1q2**2*p2q1**2)-
43241  &64*mb**2*mt**2*p1p2/(3*p1q2**2*p2q1**2)-
43242  &64*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1**2)+
43243  &64*mb**3*mt/(3*p1q2*p2q1**2)+
43244  &256*a2*mb**3*mt*p1p2/(3*p1q2*p2q1**2)+
43245  &256*a2*mb**2*p1p2**2/(3*p1q2*p2q1**2)+
43246  &256*a2*mb**3*mt*p1q1/(3*p1q2*p2q1**2)+
43247  &512*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1**2)+
43248  &256*a2*mb**2*p1q1**2/(3*p1q2*p2q1**2)-
43249  &256*a2**2*mb**4*p1q2/(3*p2q1**2)-8/(3*p2q1)-72*a1*mb**2/p2q1-
43250  &88*a2*mb**2/(3*p2q1)+56*a1*mb*mt/(3*p2q1)+32*a2*mb*mt/p2q1+
43251  &224*a1*a2*mb**3*mt/(3*p2q1)-704*a2**2*mb**3*mt/(3*p2q1)
43252  v18=v18-48*a1*p1p2/p2q1-104*a2*p1p2/(3*p2q1)+
43253  &448*a1*a2*mb**2*p1p2/(3*p2q1)-512*a2**2*mb**2*p1p2/(3*p2q1)-
43254  &128*a1*a2*mb*mt*p1p2/(3*p2q1)+32*a1*a2*p1p2**2/p2q1-
43255  &16*p1p2/(3*p1q1*p2q1)-32*a1*mb*mt*p1p2/(3*p1q1*p2q1)-
43256  &32*a2*mb*mt*p1p2/(3*p1q1*p2q1)-
43257  &64*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q1)-
43258  &64*a1*a2*p1p2**3/(3*p1q1*p2q1)-256*a2*p1q1/(3*p2q1)+
43259  &448*a1*a2*mb**2*p1q1/(3*p2q1)-368*a2**2*mb**2*p1q1/(3*p2q1)+
43260  &224*a1*a2*mb*mt*p1q1/(3*p2q1)+304*a1*a2*p1p2*p1q1/(3*p2q1)-
43261  &64*mb*mt**3/(3*p1q2**2*p2q1)-
43262  &256*a1*mb*mt**3*p1p2/(3*p1q2**2*p2q1)-
43263  &256*a1*mt**2*p1p2**2/(3*p1q2**2*p2q1)+
43264  &64*mt**2*p1q1/(3*p1q2**2*p2q1)-
43265  &128*a1*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1)-
43266  &128*a1*mb*mt**3*p1q1/(3*p1q2**2*p2q1)-
43267  &256*a1*mt**2*p1p2*p1q1/(3*p1q2**2*p2q1)-4*mb**2/(3*p1q2*p2q1)+
43268  &64*mb*mt/(3*p1q2*p2q1)-128*a2*mb**3*mt/(3*p1q2*p2q1)
43269  v18=v18-4*mt**2/(3*p1q2*p2q1)-128*a1*mb**2*mt**2/(3*p1q2*p2q1)-
43270  &128*a2*mb**2*mt**2/(3*p1q2*p2q1)-128*a1*mb*mt**3/(3*p1q2*p2q1)-
43271  &112*a2*mb**2*p1p2/(3*p1q2*p2q1)-32*a1*mb*mt*p1p2/(3*p1q2*p2q1)-
43272  &32*a2*mb*mt*p1p2/(3*p1q2*p2q1)-112*a1*mt**2*p1p2/(3*p1q2*p2q1)-
43273  &48*a1*p1p2**2/(p1q2*p2q1)-48*a2*p1p2**2/(p1q2*p2q1)+
43274  &512*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q1)+
43275  &512*a1*a2*p1p2**3/(3*p1q2*p2q1)-8*mb*mt*p1p2/(3*p1q1*p1q2*p2q1)-
43276  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q1)+
43277  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q1)-
43278  &16*p1p2**2/(3*p1q1*p1q2*p2q1)+
43279  &32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q1)+8*p1q1/(3*p1q2*p2q1)-
43280  &160*a1*mb**2*p1q1/(3*p1q2*p2q1)-272*a2*mb**2*p1q1/(3*p1q2*p2q1)+
43281  &56*a1*mb*mt*p1q1/(3*p1q2*p2q1)+200*a2*mb*mt*p1q1/(3*p1q2*p2q1)-
43282  &48*a1*p1p2*p1q1/(p1q2*p2q1)-256*a2*p1p2*p1q1/(3*p1q2*p2q1)+
43283  &256*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1)+
43284  &256*a1*a2*mb*mt*p1p2*p1q1/(p1q2*p2q1)+
43285  &1024*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q1)
43286  v18=v18-272*a2*p1q1**2/(3*p1q2*p2q1)+
43287  &256*a1*a2*mb**2*p1q1**2/(3*p1q2*p2q1)+
43288  &256*a1*a2*mb*mt*p1q1**2/(3*p1q2*p2q1)+
43289  &512*a1*a2*p1p2*p1q1**2/(3*p1q2*p2q1)+16*a2*p1q2/(3*p2q1)+
43290  &64*a1*a2*mb**2*p1q2/p2q1+32*a2**2*mb**2*p1q2/(3*p2q1)+
43291  &112*a1*a2*mb*mt*p1q2/(3*p2q1)+368*a1*a2*p1p2*p1q2/(3*p2q1)+
43292  &32*a2*p1p2*p1q2/(3*p1q1*p2q1)-
43293  &32*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1)-
43294  &32*a1*a2*mb*mt*p1p2*p1q2/(3*p1q1*p2q1)-
43295  &64*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q1)+224*a12*p2q1+
43296  &656*a1*a2*p2q1/3-256*a1*mt**2*p2q1/(3*p1q1**2)+
43297  &256*a12*mt**4*p2q1/(3*p1q1**2)-256*a1*p2q1/(3*p1q1)+
43298  &224*a1*a2*mb*mt*p2q1/(3*p1q1)-368*a12*mt**2*p2q1/(3*p1q1)+
43299  &448*a1*a2*mt**2*p2q1/(3*p1q1)+304*a1*a2*p1p2*p2q1/(3*p1q1)+
43300  &256*a12*mt**4*p2q1/(3*p1q2**2)+
43301  &256*a12*mt**2*p1q1*p2q1/(3*p1q2**2)+16*a1*p2q1/(3*p1q2)+
43302  &112*a1*a2*mb*mt*p2q1/(3*p1q2)+32*a12*mt**2*p2q1/(3*p1q2)
43303  v18=v18+64*a1*a2*mt**2*p2q1/p1q2+368*a1*a2*p1p2*p2q1/(3*p1q2)+
43304  &16*a1*mt**2*p2q1/(3*p1q1*p1q2)-64*a12*mt**4*p2q1/(3*p1q1*p1q2)+
43305  &640*a12*p1q1*p2q1/(3*p1q2)+544*a1*a2*p1q1*p2q1/(3*p1q2)+
43306  &32*a12*p1q2*p2q1/p1q1+944*a1*a2*p1q2*p2q1/(3*p1q1)+
43307  &128*a2*mb**4/(3*p2q2**2)+128*a2*mb**3*mt/(3*p2q2**2)-
43308  &256*a2**2*mb**5*mt/(3*p2q2**2)+256*a2*mb**2*p1p2/(3*p2q2**2)-
43309  &256*a2**2*mb**4*p1p2/(3*p2q2**2)-
43310  &64*mb**3*mt**3/(3*p1q1**2*p2q2**2)-
43311  &64*mb**2*mt**2*p1p2/(3*p1q1**2*p2q2**2)+
43312  &64*mb**3*mt/(3*p1q1*p2q2**2)+
43313  &256*a2*mb**3*mt*p1p2/(3*p1q1*p2q2**2)+
43314  &256*a2*mb**2*p1p2**2/(3*p1q1*p2q2**2)-
43315  &256*a2**2*mb**4*p1q1/(3*p2q2**2)+256*a2*mb**2*p1q2/(3*p2q2**2)-
43316  &256*a2**2*mb**4*p1q2/(3*p2q2**2)-
43317  &64*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2**2)+
43318  &256*a2*mb**3*mt*p1q2/(3*p1q1*p2q2**2)+
43319  &512*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2**2)
43320  v18=v18+256*a2*mb**2*p1q2**2/(3*p1q1*p2q2**2)-
43321  &256*a2*mb**2*p2q1/(3*p2q2**2)-256*a2**2*mb**3*mt*p2q1/(3*p2q2**2)+
43322  &64*mb**2*mt**2*p2q1/(3*p1q1**2*p2q2**2)+
43323  &64*mb**2*p2q1/(3*p1q1*p2q2**2)-
43324  &128*a2*mb**3*mt*p2q1/(3*p1q1*p2q2**2)-
43325  &128*a2*mb**2*mt**2*p2q1/(3*p1q1*p2q2**2)-
43326  &256*a2*mb**2*p1p2*p2q1/(3*p1q1*p2q2**2)+
43327  &256*a2**2*mb**2*p1q1*p2q1/(3*p2q2**2)-
43328  &256*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2**2)-8/(3*p2q2)-
43329  &72*a1*mb**2/p2q2-88*a2*mb**2/(3*p2q2)+56*a1*mb*mt/(3*p2q2)+
43330  &32*a2*mb*mt/p2q2+224*a1*a2*mb**3*mt/(3*p2q2)-
43331  &704*a2**2*mb**3*mt/(3*p2q2)-48*a1*p1p2/p2q2-
43332  &104*a2*p1p2/(3*p2q2)+448*a1*a2*mb**2*p1p2/(3*p2q2)-
43333  &512*a2**2*mb**2*p1p2/(3*p2q2)-128*a1*a2*mb*mt*p1p2/(3*p2q2)+
43334  &32*a1*a2*p1p2**2/p2q2-64*mb*mt**3/(3*p1q1**2*p2q2)-
43335  &256*a1*mb*mt**3*p1p2/(3*p1q1**2*p2q2)-
43336  &256*a1*mt**2*p1p2**2/(3*p1q1**2*p2q2)-4*mb**2/(3*p1q1*p2q2)
43337  v18=v18+64*mb*mt/(3*p1q1*p2q2)-128*a2*mb**3*mt/(3*p1q1*p2q2)-
43338  &4*mt**2/(3*p1q1*p2q2)-128*a1*mb**2*mt**2/(3*p1q1*p2q2)-
43339  &128*a2*mb**2*mt**2/(3*p1q1*p2q2)-128*a1*mb*mt**3/(3*p1q1*p2q2)-
43340  &112*a2*mb**2*p1p2/(3*p1q1*p2q2)-32*a1*mb*mt*p1p2/(3*p1q1*p2q2)-
43341  &32*a2*mb*mt*p1p2/(3*p1q1*p2q2)-112*a1*mt**2*p1p2/(3*p1q1*p2q2)-
43342  &48*a1*p1p2**2/(p1q1*p2q2)-48*a2*p1p2**2/(p1q1*p2q2)+
43343  &512*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q2)+
43344  &512*a1*a2*p1p2**3/(3*p1q1*p2q2)+16*a2*p1q1/(3*p2q2)+
43345  &64*a1*a2*mb**2*p1q1/p2q2+32*a2**2*mb**2*p1q1/(3*p2q2)+
43346  &112*a1*a2*mb*mt*p1q1/(3*p2q2)+368*a1*a2*p1p2*p1q1/(3*p2q2)-
43347  &16*p1p2/(3*p1q2*p2q2)-32*a1*mb*mt*p1p2/(3*p1q2*p2q2)-
43348  &32*a2*mb*mt*p1p2/(3*p1q2*p2q2)-
43349  &64*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q2)-
43350  &64*a1*a2*p1p2**3/(3*p1q2*p2q2)-8*mb*mt*p1p2/(3*p1q1*p1q2*p2q2)-
43351  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q2)+
43352  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q2)-
43353  &16*p1p2**2/(3*p1q1*p1q2*p2q2)
43354  v18=v18+32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q2)+
43355  &32*a2*p1p2*p1q1/(3*p1q2*p2q2)-
43356  &32*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q2)-
43357  &32*a1*a2*mb*mt*p1p2*p1q1/(3*p1q2*p2q2)-
43358  &64*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q2)-256*a2*p1q2/(3*p2q2)+
43359  &448*a1*a2*mb**2*p1q2/(3*p2q2)-368*a2**2*mb**2*p1q2/(3*p2q2)+
43360  &224*a1*a2*mb*mt*p1q2/(3*p2q2)+304*a1*a2*p1p2*p1q2/(3*p2q2)+
43361  &64*mt**2*p1q2/(3*p1q1**2*p2q2)-
43362  &128*a1*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2)-
43363  &128*a1*mb*mt**3*p1q2/(3*p1q1**2*p2q2)-
43364  &256*a1*mt**2*p1p2*p1q2/(3*p1q1**2*p2q2)+8*p1q2/(3*p1q1*p2q2)-
43365  &160*a1*mb**2*p1q2/(3*p1q1*p2q2)-272*a2*mb**2*p1q2/(3*p1q1*p2q2)+
43366  &56*a1*mb*mt*p1q2/(3*p1q1*p2q2)+200*a2*mb*mt*p1q2/(3*p1q1*p2q2)-
43367  &48*a1*p1p2*p1q2/(p1q1*p2q2)-256*a2*p1p2*p1q2/(3*p1q1*p2q2)+
43368  &256*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2)+
43369  &256*a1*a2*mb*mt*p1p2*p1q2/(p1q1*p2q2)+
43370  &1024*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q2)
43371  v18=v18-272*a2*p1q2**2/(3*p1q1*p2q2)+
43372  &256*a1*a2*mb**2*p1q2**2/(3*p1q1*p2q2)+
43373  &256*a1*a2*mb*mt*p1q2**2/(3*p1q1*p2q2)+
43374  &512*a1*a2*p1p2*p1q2**2/(3*p1q1*p2q2)-32*a2*mb**4/(3*p2q1*p2q2)-
43375  &32*a2*mb**3*mt/(3*p2q1*p2q2)+64*a2**2*mb**5*mt/(3*p2q1*p2q2)+
43376  &16*p1p2/(3*p2q1*p2q2)-64*a2*mb**2*p1p2/(3*p2q1*p2q2)+
43377  &64*a2**2*mb**4*p1p2/(3*p2q1*p2q2)+8*mb**2*p1p2/(3*p1q1*p2q1*p2q2)+
43378  &8*mb*mt*p1p2/(3*p1q1*p2q1*p2q2)-
43379  &32*a2*mb**3*mt*p1p2/(3*p1q1*p2q1*p2q2)+
43380  &16*p1p2**2/(3*p1q1*p2q1*p2q2)-
43381  &32*a2*mb**2*p1p2**2/(3*p1q1*p2q1*p2q2)-
43382  &16*a2*mb**2*p1q1/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q1/(3*p2q1*p2q2)+
43383  &8*mb**2*p1p2/(3*p1q2*p2q1*p2q2)+8*mb*mt*p1p2/(3*p1q2*p2q1*p2q2)-
43384  &32*a2*mb**3*mt*p1p2/(3*p1q2*p2q1*p2q2)+
43385  &16*p1p2**2/(3*p1q2*p2q1*p2q2)-
43386  &32*a2*mb**2*p1p2**2/(3*p1q2*p2q1*p2q2)+
43387  &16*mb*mt*p1p2**2/(3*p1q1*p1q2*p2q1*p2q2)
43388  v18=v18+16*p1p2**3/(3*p1q1*p1q2*p2q1*p2q2)-
43389  &32*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1*p2q2)-
43390  &16*a2*mb**2*p1q2/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q2/(3*p2q1*p2q2)-
43391  &32*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1*p2q2)+272*a1*p2q1/(3*p2q2)+
43392  &112*a2*p2q1/p2q2-80*a1*a2*mb**2*p2q1/p2q2-
43393  &400*a1*a2*mb*mt*p2q1/(3*p2q2)+208*a2**2*mb*mt*p2q1/(3*p2q2)-
43394  &272*a1*a2*mt**2*p2q1/(3*p2q2)-320*a1*a2*p1p2*p2q1/p2q2+
43395  &96*a2**2*p1p2*p2q1/p2q2+256*a1*mb*mt**3*p2q1/(3*p1q1**2*p2q2)+
43396  &512*a1*mt**2*p1p2*p2q1/(3*p1q1**2*p2q2)-8*p2q1/(3*p1q1*p2q2)-
43397  &200*a1*mb*mt*p2q1/(3*p1q1*p2q2)-56*a2*mb*mt*p2q1/(3*p1q1*p2q2)+
43398  &272*a1*mt**2*p2q1/(3*p1q1*p2q2)+160*a2*mt**2*p2q1/(3*p1q1*p2q2)+
43399  &256*a1*p1p2*p2q1/(3*p1q1*p2q2)+48*a2*p1p2*p2q1/(p1q1*p2q2)-
43400  &256*a1*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2)-
43401  &256*a1*a2*mt**2*p1p2*p2q1/(3*p1q1*p2q2)-
43402  &1024*a1*a2*p1p2**2*p2q1/(3*p1q1*p2q2)-
43403  &544*a1*a2*p1q1*p2q1/(3*p2q2)-640*a2**2*p1q1*p2q1/(3*p2q2)-
43404  &32*a1*p1p2*p2q1/(3*p1q2*p2q2)
43405  v18=v18+32*a1*a2*mb*mt*p1p2*p2q1/(3*p1q2*p2q2)+
43406  &32*a1*a2*mt**2*p1p2*p2q1/(3*p1q2*p2q2)+
43407  &64*a1*a2*p1p2**2*p2q1/(3*p1q2*p2q2)-
43408  &32*a1*mt**2*p1p2*p2q1/(3*p1q1*p1q2*p2q2)+
43409  &64*a1*a2*p1p2*p1q1*p2q1/(3*p1q2*p2q2)-
43410  &944*a1*a2*p1q2*p2q1/(3*p2q2)-32*a2**2*p1q2*p2q1/p2q2+
43411  &256*a1*mt**2*p1q2*p2q1/(3*p1q1**2*p2q2)+
43412  &96*a1*p1q2*p2q1/(p1q1*p2q2)+96*a2*p1q2*p2q1/(p1q1*p2q2)-
43413  &128*a1*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2)-
43414  &256*a1*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2)-
43415  &128*a1*a2*mt**2*p1q2*p2q1/(3*p1q1*p2q2)-
43416  &512*a1*a2*p1p2*p1q2*p2q1/(p1q1*p2q2)-
43417  &512*a1*a2*p1q2**2*p2q1/(3*p1q1*p2q2)+544*a1*a2*p2q1**2/(3*p2q2)-
43418  &256*a1*mt**2*p2q1**2/(3*p1q1**2*p2q2)-
43419  &272*a1*p2q1**2/(3*p1q1*p2q2)+
43420  &256*a1*a2*mb*mt*p2q1**2/(3*p1q1*p2q2)+
43421  &256*a1*a2*mt**2*p2q1**2/(3*p1q1*p2q2)
43422  v18=v18+512*a1*a2*p1p2*p2q1**2/(3*p1q1*p2q2)+
43423  &512*a1*a2*p1q2*p2q1**2/(3*p1q1*p2q2)+224*a12*p2q2+
43424  &656*a1*a2*p2q2/3+256*a12*mt**4*p2q2/(3*p1q1**2)+
43425  &16*a1*p2q2/(3*p1q1)+112*a1*a2*mb*mt*p2q2/(3*p1q1)+
43426  &32*a12*mt**2*p2q2/(3*p1q1)+64*a1*a2*mt**2*p2q2/p1q1+
43427  &368*a1*a2*p1p2*p2q2/(3*p1q1)-256*a1*mt**2*p2q2/(3*p1q2**2)+
43428  &256*a12*mt**4*p2q2/(3*p1q2**2)-256*a1*p2q2/(3*p1q2)+
43429  &224*a1*a2*mb*mt*p2q2/(3*p1q2)-368*a12*mt**2*p2q2/(3*p1q2)+
43430  &448*a1*a2*mt**2*p2q2/(3*p1q2)+304*a1*a2*p1p2*p2q2/(3*p1q2)+
43431  &16*a1*mt**2*p2q2/(3*p1q1*p1q2)-64*a12*mt**4*p2q2/(3*p1q1*p1q2)+
43432  &32*a12*p1q1*p2q2/p1q2+944*a1*a2*p1q1*p2q2/(3*p1q2)+
43433  &256*a12*mt**2*p1q2*p2q2/(3*p1q1**2)+
43434  &640*a12*p1q2*p2q2/(3*p1q1)+544*a1*a2*p1q2*p2q2/(3*p1q1)-
43435  &256*a2*mb**2*p2q2/(3*p2q1**2)-256*a2**2*mb**3*mt*p2q2/(3*p2q1**2)+
43436  &64*mb**2*mt**2*p2q2/(3*p1q2**2*p2q1**2)+
43437  &64*mb**2*p2q2/(3*p1q2*p2q1**2)-
43438  &128*a2*mb**3*mt*p2q2/(3*p1q2*p2q1**2)
43439  v18=v18-128*a2*mb**2*mt**2*p2q2/(3*p1q2*p2q1**2)-
43440  &256*a2*mb**2*p1p2*p2q2/(3*p1q2*p2q1**2)-
43441  &256*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1**2)+
43442  &256*a2**2*mb**2*p1q2*p2q2/(3*p2q1**2)+272*a1*p2q2/(3*p2q1)+
43443  &112*a2*p2q2/p2q1-80*a1*a2*mb**2*p2q2/p2q1-
43444  &400*a1*a2*mb*mt*p2q2/(3*p2q1)+208*a2**2*mb*mt*p2q2/(3*p2q1)-
43445  &272*a1*a2*mt**2*p2q2/(3*p2q1)-320*a1*a2*p1p2*p2q2/p2q1+
43446  &96*a2**2*p1p2*p2q2/p2q1-32*a1*p1p2*p2q2/(3*p1q1*p2q1)+
43447  &32*a1*a2*mb*mt*p1p2*p2q2/(3*p1q1*p2q1)+
43448  &32*a1*a2*mt**2*p1p2*p2q2/(3*p1q1*p2q1)+
43449  &64*a1*a2*p1p2**2*p2q2/(3*p1q1*p2q1)-944*a1*a2*p1q1*p2q2/(3*p2q1)-
43450  &32*a2**2*p1q1*p2q2/p2q1+256*a1*mb*mt**3*p2q2/(3*p1q2**2*p2q1)+
43451  &512*a1*mt**2*p1p2*p2q2/(3*p1q2**2*p2q1)+
43452  &256*a1*mt**2*p1q1*p2q2/(3*p1q2**2*p2q1)-8*p2q2/(3*p1q2*p2q1)-
43453  &200*a1*mb*mt*p2q2/(3*p1q2*p2q1)-56*a2*mb*mt*p2q2/(3*p1q2*p2q1)+
43454  &272*a1*mt**2*p2q2/(3*p1q2*p2q1)+160*a2*mt**2*p2q2/(3*p1q2*p2q1)+
43455  &256*a1*p1p2*p2q2/(3*p1q2*p2q1)+48*a2*p1p2*p2q2/(p1q2*p2q1)
43456  v18=v18-256*a1*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1)-
43457  &256*a1*a2*mt**2*p1p2*p2q2/(3*p1q2*p2q1)-
43458  &1024*a1*a2*p1p2**2*p2q2/(3*p1q2*p2q1)-
43459  &32*a1*mt**2*p1p2*p2q2/(3*p1q1*p1q2*p2q1)+
43460  &96*a1*p1q1*p2q2/(p1q2*p2q1)+96*a2*p1q1*p2q2/(p1q2*p2q1)-
43461  &128*a1*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1)-
43462  &256*a1*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1)-
43463  &128*a1*a2*mt**2*p1q1*p2q2/(3*p1q2*p2q1)-
43464  &512*a1*a2*p1p2*p1q1*p2q2/(p1q2*p2q1)-
43465  &512*a1*a2*p1q1**2*p2q2/(3*p1q2*p2q1)-544*a1*a2*p1q2*p2q2/(3*p2q1)-
43466  &640*a2**2*p1q2*p2q2/(3*p2q1)+
43467  &64*a1*a2*p1p2*p1q2*p2q2/(3*p1q1*p2q1)+544*a1*a2*p2q2**2/(3*p2q1)-
43468  &256*a1*mt**2*p2q2**2/(3*p1q2**2*p2q1)-
43469  &272*a1*p2q2**2/(3*p1q2*p2q1)+
43470  &256*a1*a2*mb*mt*p2q2**2/(3*p1q2*p2q1)+
43471  &256*a1*a2*mt**2*p2q2**2/(3*p1q2*p2q1)+
43472  &512*a1*a2*p1p2*p2q2**2/(3*p1q2*p2q1)
43473  v18=v18+512*a1*a2*p1q1*p2q2**2/(3*p1q2*p2q1)+
43474  &384*a12*mb*mt*p1q1**2/s**2+
43475  &384*a12*p1p2*p1q1**2/s**2+2688*a12*mb*mt*p1q1*p1q2/s**2+
43476  &2688*a12*p1p2*p1q1*p1q2/s**2+384*a12*mb*mt*p1q2**2/s**2+
43477  &384*a12*p1p2*p1q2**2/s**2+768*a1*a2*mb*mt*p1q1*p2q1/s**2+
43478  &768*a1*a2*p1p2*p1q1*p2q1/s**2+2688*a1*a2*mb*mt*p1q2*p2q1/s**2+
43479  &2688*a1*a2*p1p2*p1q2*p2q1/s**2-960*a12*p1q1*p1q2*p2q1/s**2-
43480  &960*a1*a2*p1q1*p1q2*p2q1/s**2+960*a12*p1q2**2*p2q1/s**2+
43481  &960*a1*a2*p1q2**2*p2q1/s**2+384*a2**2*mb*mt*p2q1**2/s**2+
43482  &384*a2**2*p1p2*p2q1**2/s**2-960*a1*a2*p1q2*p2q1**2/s**2-
43483  &960*a2**2*p1q2*p2q1**2/s**2+2688*a1*a2*mb*mt*p1q1*p2q2/s**2+
43484  &2688*a1*a2*p1p2*p1q1*p2q2/s**2+960*a12*p1q1**2*p2q2/s**2+
43485  &960*a1*a2*p1q1**2*p2q2/s**2+768*a1*a2*mb*mt*p1q2*p2q2/s**2+
43486  &768*a1*a2*p1p2*p1q2*p2q2/s**2-960*a12*p1q1*p1q2*p2q2/s**2-
43487  &960*a1*a2*p1q1*p1q2*p2q2/s**2+2688*a2**2*mb*mt*p2q1*p2q2/s**2+
43488  &2688*a2**2*p1p2*p2q1*p2q2/s**2+960*a1*a2*p1q1*p2q1*p2q2/s**2+
43489  &960*a2**2*p1q1*p2q1*p2q2/s**2+960*a1*a2*p1q2*p2q1*p2q2/s**2+
43490  &960*a2**2*p1q2*p2q1*p2q2/s**2+384*a2**2*mb*mt*p2q2**2/s**2
43491  v18=v18+384*a2**2*p1p2*p2q2**2/s**2-960*a1*a2*p1q1*p2q2**2/s**2-
43492  &960*a2**2*p1q1*p2q2**2/s**2+96*a1*mb*mt/s+96*a2*mb*mt/s-
43493  &768*a2**2*mb**3*mt/s-768*a12*mb*mt**3/s-192*a1*p1p2/s-
43494  &192*a2*p1p2/s-768*a2**2*mb**2*p1p2/s-2304*a1*a2*mb*mt*p1p2/s-
43495  &768*a12*mt**2*p1p2/s-2304*a1*a2*p1p2**2/s-
43496  &96*a1*mb*mt**3/(p1q1*s)-192*a2*mb*mt*p1p2/(p1q1*s)-
43497  &96*a1*mt**2*p1p2/(p1q1*s)-192*a2*p1p2**2/(p1q1*s)-192*a1*p1q1/s-
43498  &144*a2*p1q1/s-384*a1*a2*mb**2*p1q1/s-480*a2**2*mb**2*p1q1/s-
43499  &480*a12*mb*mt*p1q1/s+96*a1*a2*mb*mt*p1q1/s-
43500  &864*a12*p1p2*p1q1/s-672*a1*a2*p1p2*p1q1/s-96*a1*a2*p1q1**2/s-
43501  &96*a1*mb*mt**3/(p1q2*s)-192*a2*mb*mt*p1p2/(p1q2*s)-
43502  &96*a1*mt**2*p1p2/(p1q2*s)-192*a2*p1p2**2/(p1q2*s)-
43503  &48*a1*mb*mt*p1q1/(p1q2*s)+96*a2*mb*mt*p1q1/(p1q2*s)-
43504  &48*a1*mt**2*p1q1/(p1q2*s)-192*a1*p1p2*p1q1/(p1q2*s)-
43505  &192*a2*p1p2*p1q1/(p1q2*s)+192*a1*a2*mb*mt*p1p2*p1q1/(p1q2*s)+
43506  &192*a1*a2*p1p2**2*p1q1/(p1q2*s)-192*a1*p1q1**2/(p1q2*s)-
43507  &192*a2*p1q1**2/(p1q2*s)+192*a1*a2*mb**2*p1q1**2/(p1q2*s)
43508  v18=v18-192*a12*mb*mt*p1q1**2/(p1q2*s)+
43509  &96*a1*a2*mb*mt*p1q1**2/(p1q2*s)+
43510  &192*a1*a2*p1p2*p1q1**2/(p1q2*s)-192*a1*p1q2/s-144*a2*p1q2/s-
43511  &384*a1*a2*mb**2*p1q2/s-480*a2**2*mb**2*p1q2/s-
43512  &480*a12*mb*mt*p1q2/s+96*a1*a2*mb*mt*p1q2/s-
43513  &864*a12*p1p2*p1q2/s-672*a1*a2*p1p2*p1q2/s-
43514  &48*a1*mb*mt*p1q2/(p1q1*s)+96*a2*mb*mt*p1q2/(p1q1*s)-
43515  &48*a1*mt**2*p1q2/(p1q1*s)-192*a1*p1p2*p1q2/(p1q1*s)-
43516  &192*a2*p1p2*p1q2/(p1q1*s)+192*a1*a2*mb*mt*p1p2*p1q2/(p1q1*s)+
43517  &192*a1*a2*p1p2**2*p1q2/(p1q1*s)-576*a1*a2*p1q1*p1q2/s-
43518  &96*a1*a2*p1q2**2/s-192*a1*p1q2**2/(p1q1*s)-
43519  &192*a2*p1q2**2/(p1q1*s)+192*a1*a2*mb**2*p1q2**2/(p1q1*s)-
43520  &192*a12*mb*mt*p1q2**2/(p1q1*s)+96*a1*a2*mb*mt*p1q2**2/(p1q1*s)+
43521  &192*a1*a2*p1p2*p1q2**2/(p1q1*s)+96*a2*mb**3*mt/(p2q1*s)+
43522  &96*a2*mb**2*p1p2/(p2q1*s)+192*a1*mb*mt*p1p2/(p2q1*s)+
43523  &192*a1*p1p2**2/(p2q1*s)+96*a1*mb**2*p1q1/(p2q1*s)+
43524  &192*a2*mb**2*p1q1/(p2q1*s)+96*a1*mb*mt*p1q1/(p2q1*s)+
43525  &192*a1*a2*mb**3*mt*p1q1/(p2q1*s)+192*a1*p1p2*p1q1/(p2q1*s)
43526  v18=v18+192*a1*a2*mb**2*p1p2*p1q1/(p2q1*s)+
43527  &96*a1*a2*mb**2*p1q1**2/(p2q1*s)+
43528  &192*a2*mb**3*mt*p1q1/(p1q2*p2q1*s)+
43529  &192*a2*mb**2*p1p2*p1q1/(p1q2*p2q1*s)+
43530  &96*a1*mb*mt*p1p2*p1q1/(p1q2*p2q1*s)+
43531  &96*a1*p1p2**2*p1q1/(p1q2*p2q1*s)+
43532  &96*a1*mb**2*p1q1**2/(p1q2*p2q1*s)+
43533  &192*a2*mb**2*p1q1**2/(p1q2*p2q1*s)+
43534  &48*a1*mb*mt*p1q1**2/(p1q2*p2q1*s)+
43535  &96*a1*p1p2*p1q1**2/(p1q2*p2q1*s)+96*a1*mb**2*p1q2/(p2q1*s)+
43536  &48*a2*mb**2*p1q2/(p2q1*s)-192*a1*a2*mb**3*mt*p1q2/(p2q1*s)-
43537  &192*a1*a2*mb**2*p1p2*p1q2/(p2q1*s)-
43538  &96*a1*a2*mb**2*p1q2**2/(p2q1*s)+144*a1*p2q1/s+192*a2*p2q1/s-
43539  &96*a1*a2*mb*mt*p2q1/s+480*a2**2*mb*mt*p2q1/s+
43540  &480*a12*mt**2*p2q1/s+384*a1*a2*mt**2*p2q1/s+
43541  &672*a1*a2*p1p2*p2q1/s+864*a2**2*p1p2*p2q1/s+
43542  &96*a2*mb*mt*p2q1/(p1q1*s)+192*a1*mt**2*p2q1/(p1q1*s)
43543  v18=v18+96*a2*mt**2*p2q1/(p1q1*s)+
43544  &192*a1*a2*mb*mt**3*p2q1/(p1q1*s)+
43545  &192*a2*p1p2*p2q1/(p1q1*s)+192*a1*a2*mt**2*p1p2*p2q1/(p1q1*s)-
43546  &192*a12*p1q1*p2q1/s-192*a2**2*p1q1*p2q1/s+
43547  &48*a1*mt**2*p2q1/(p1q2*s)+96*a2*mt**2*p2q1/(p1q2*s)-
43548  &192*a1*a2*mb*mt**3*p2q1/(p1q2*s)-
43549  &192*a1*a2*mt**2*p1p2*p2q1/(p1q2*s)-
43550  &96*a1*a2*mb*mt*p1q1*p2q1/(p1q2*s)-
43551  &192*a12*mt**2*p1q1*p2q1/(p1q2*s)-
43552  &96*a1*a2*mt**2*p1q1*p2q1/(p1q2*s)-
43553  &384*a1*a2*p1p2*p1q1*p2q1/(p1q2*s)-384*a12*p1q1**2*p2q1/(p1q2*s)-
43554  &384*a1*a2*p1q1**2*p2q1/(p1q2*s)-480*a12*p1q2*p2q1/s-
43555  &960*a1*a2*p1q2*p2q1/s-480*a2**2*p1q2*p2q1/s+
43556  &144*a1*p1q2*p2q1/(p1q1*s)+96*a2*p1q2*p2q1/(p1q1*s)-
43557  &384*a1*a2*mb*mt*p1q2*p2q1/(p1q1*s)-
43558  &96*a12*mt**2*p1q2*p2q1/(p1q1*s)+
43559  &96*a1*a2*mt**2*p1q2*p2q1/(p1q1*s)-
43560  &576*a1*a2*p1p2*p1q2*p2q1/(p1q1*s)-192*a12*p1q2**2*p2q1/(p1q1*s)
43561  v18=v18-384*a1*a2*p1q2**2*p2q1/(p1q1*s)-96*a1*a2*p2q1**2/s-
43562  &96*a1*a2*mt**2*p2q1**2/(p1q1*s)+96*a1*a2*mt**2*p2q1**2/(p1q2*s)+
43563  &288*a1*a2*p1q2*p2q1**2/(p1q1*s)+96*a2*mb**3*mt/(p2q2*s)+
43564  &96*a2*mb**2*p1p2/(p2q2*s)+192*a1*mb*mt*p1p2/(p2q2*s)+
43565  &192*a1*p1p2**2/(p2q2*s)+96*a1*mb**2*p1q1/(p2q2*s)+
43566  &48*a2*mb**2*p1q1/(p2q2*s)-192*a1*a2*mb**3*mt*p1q1/(p2q2*s)-
43567  &192*a1*a2*mb**2*p1p2*p1q1/(p2q2*s)-
43568  &96*a1*a2*mb**2*p1q1**2/(p2q2*s)+96*a1*mb**2*p1q2/(p2q2*s)+
43569  &192*a2*mb**2*p1q2/(p2q2*s)+96*a1*mb*mt*p1q2/(p2q2*s)+
43570  &192*a1*a2*mb**3*mt*p1q2/(p2q2*s)+192*a1*p1p2*p1q2/(p2q2*s)+
43571  &192*a1*a2*mb**2*p1p2*p1q2/(p2q2*s)+
43572  &192*a2*mb**3*mt*p1q2/(p1q1*p2q2*s)+
43573  &192*a2*mb**2*p1p2*p1q2/(p1q1*p2q2*s)+
43574  &96*a1*mb*mt*p1p2*p1q2/(p1q1*p2q2*s)+
43575  &96*a1*p1p2**2*p1q2/(p1q1*p2q2*s)+96*a1*a2*mb**2*p1q2**2/(p2q2*s)+
43576  &96*a1*mb**2*p1q2**2/(p1q1*p2q2*s)+
43577  &192*a2*mb**2*p1q2**2/(p1q1*p2q2*s)
43578  v18=v18+48*a1*mb*mt*p1q2**2/(p1q1*p2q2*s)+
43579  &96*a1*p1p2*p1q2**2/(p1q1*p2q2*s)-48*a2*mb**2*p2q1/(p2q2*s)+
43580  &96*a1*mb*mt*p2q1/(p2q2*s)-48*a2*mb*mt*p2q1/(p2q2*s)-
43581  &192*a1*p1p2*p2q1/(p2q2*s)-192*a2*p1p2*p2q1/(p2q2*s)+
43582  &192*a1*a2*mb*mt*p1p2*p2q1/(p2q2*s)+
43583  &192*a1*a2*p1p2**2*p2q1/(p2q2*s)-
43584  &192*a1*mb*mt**3*p2q1/(p1q1*p2q2*s)-
43585  &96*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2*s)-
43586  &192*a1*mt**2*p1p2*p2q1/(p1q1*p2q2*s)-
43587  &96*a2*p1p2**2*p2q1/(p1q1*p2q2*s)+
43588  &96*a1*a2*mb**2*p1q1*p2q1/(p2q2*s)+
43589  &192*a2**2*mb**2*p1q1*p2q1/(p2q2*s)+
43590  &96*a1*a2*mb*mt*p1q1*p2q1/(p2q2*s)+
43591  &384*a1*a2*p1p2*p1q1*p2q1/(p2q2*s)-96*a1*p1q2*p2q1/(p2q2*s)-
43592  &144*a2*p1q2*p2q1/(p2q2*s)-96*a1*a2*mb**2*p1q2*p2q1/(p2q2*s)+
43593  &96*a2**2*mb**2*p1q2*p2q1/(p2q2*s)+
43594  &384*a1*a2*mb*mt*p1q2*p2q1/(p2q2*s)
43595  v18=v18+576*a1*a2*p1p2*p1q2*p2q1/(p2q2*s)-
43596  &96*a2*mb**2*p1q2*p2q1/(p1q1*p2q2*s)+
43597  &48*a1*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)+
43598  &48*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
43599  &96*a1*mt**2*p1q2*p2q1/(p1q1*p2q2*s)-
43600  &96*a1*p1p2*p1q2*p2q1/(p1q1*p2q2*s)-
43601  &96*a2*p1p2*p1q2*p2q1/(p1q1*p2q2*s)+
43602  &96*a1*a2*p1q1*p1q2*p2q1/(p2q2*s)+288*a1*a2*p1q2**2*p2q1/(p2q2*s)-
43603  &96*a1*p1q2**2*p2q1/(p1q1*p2q2*s)-96*a2*p1q2**2*p2q1/(p1q1*p2q2*s)+
43604  &192*a1*p2q1**2/(p2q2*s)+192*a2*p2q1**2/(p2q2*s)-
43605  &96*a1*a2*mb*mt*p2q1**2/(p2q2*s)+192*a2**2*mb*mt*p2q1**2/(p2q2*s)-
43606  &192*a1*a2*mt**2*p2q1**2/(p2q2*s)-192*a1*a2*p1p2*p2q1**2/(p2q2*s)+
43607  &48*a2*mb*mt*p2q1**2/(p1q1*p2q2*s)+
43608  &192*a1*mt**2*p2q1**2/(p1q1*p2q2*s)+
43609  &96*a2*mt**2*p2q1**2/(p1q1*p2q2*s)+
43610  &96*a2*p1p2*p2q1**2/(p1q1*p2q2*s)-384*a1*a2*p1q1*p2q1**2/(p2q2*s)-
43611  &384*a2**2*p1q1*p2q1**2/(p2q2*s)-384*a1*a2*p1q2*p2q1**2/(p2q2*s)
43612  v18=v18-192*a2**2*p1q2*p2q1**2/(p2q2*s)+
43613  &96*a1*p1q2*p2q1**2/(p1q1*p2q2*s)+
43614  &96*a2*p1q2*p2q1**2/(p1q1*p2q2*s)+144*a1*p2q2/s+192*a2*p2q2/s-
43615  &96*a1*a2*mb*mt*p2q2/s+480*a2**2*mb*mt*p2q2/s+
43616  &480*a12*mt**2*p2q2/s+384*a1*a2*mt**2*p2q2/s+
43617  &672*a1*a2*p1p2*p2q2/s+864*a2**2*p1p2*p2q2/s+
43618  &48*a1*mt**2*p2q2/(p1q1*s)+96*a2*mt**2*p2q2/(p1q1*s)-
43619  &192*a1*a2*mb*mt**3*p2q2/(p1q1*s)-
43620  &192*a1*a2*mt**2*p1p2*p2q2/(p1q1*s)-480*a12*p1q1*p2q2/s-
43621  &960*a1*a2*p1q1*p2q2/s-480*a2**2*p1q1*p2q2/s+
43622  &96*a2*mb*mt*p2q2/(p1q2*s)+192*a1*mt**2*p2q2/(p1q2*s)+
43623  &96*a2*mt**2*p2q2/(p1q2*s)+192*a1*a2*mb*mt**3*p2q2/(p1q2*s)+
43624  &192*a2*p1p2*p2q2/(p1q2*s)+192*a1*a2*mt**2*p1p2*p2q2/(p1q2*s)+
43625  &144*a1*p1q1*p2q2/(p1q2*s)+96*a2*p1q1*p2q2/(p1q2*s)-
43626  &384*a1*a2*mb*mt*p1q1*p2q2/(p1q2*s)-
43627  &96*a12*mt**2*p1q1*p2q2/(p1q2*s)+
43628  &96*a1*a2*mt**2*p1q1*p2q2/(p1q2*s)
43629  v18=v18-576*a1*a2*p1p2*p1q1*p2q2/(p1q2*s)-
43630  &192*a12*p1q1**2*p2q2/(p1q2*s)-
43631  &384*a1*a2*p1q1**2*p2q2/(p1q2*s)-192*a12*p1q2*p2q2/s-
43632  &192*a2**2*p1q2*p2q2/s-96*a1*a2*mb*mt*p1q2*p2q2/(p1q1*s)-
43633  &192*a12*mt**2*p1q2*p2q2/(p1q1*s)-
43634  &96*a1*a2*mt**2*p1q2*p2q2/(p1q1*s)-
43635  &384*a1*a2*p1p2*p1q2*p2q2/(p1q1*s)-384*a12*p1q2**2*p2q2/(p1q1*s)-
43636  &384*a1*a2*p1q2**2*p2q2/(p1q1*s)-48*a2*mb**2*p2q2/(p2q1*s)+
43637  &96*a1*mb*mt*p2q2/(p2q1*s)-48*a2*mb*mt*p2q2/(p2q1*s)-
43638  &192*a1*p1p2*p2q2/(p2q1*s)-192*a2*p1p2*p2q2/(p2q1*s)+
43639  &192*a1*a2*mb*mt*p1p2*p2q2/(p2q1*s)+
43640  &192*a1*a2*p1p2**2*p2q2/(p2q1*s)-96*a1*p1q1*p2q2/(p2q1*s)-
43641  &144*a2*p1q1*p2q2/(p2q1*s)-96*a1*a2*mb**2*p1q1*p2q2/(p2q1*s)+
43642  &96*a2**2*mb**2*p1q1*p2q2/(p2q1*s)+
43643  &384*a1*a2*mb*mt*p1q1*p2q2/(p2q1*s)+
43644  &576*a1*a2*p1p2*p1q1*p2q2/(p2q1*s)+288*a1*a2*p1q1**2*p2q2/(p2q1*s)-
43645  &192*a1*mb*mt**3*p2q2/(p1q2*p2q1*s)
43646  v18=v18-96*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1*s)-
43647  &192*a1*mt**2*p1p2*p2q2/(p1q2*p2q1*s)-
43648  &96*a2*p1p2**2*p2q2/(p1q2*p2q1*s)-
43649  &96*a2*mb**2*p1q1*p2q2/(p1q2*p2q1*s)+
43650  &48*a1*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)
43651 
43652  v18bis=
43653  &48*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
43654  &96*a1*mt**2*p1q1*p2q2/(p1q2*p2q1*s)-
43655  &96*a1*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
43656  &96*a2*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
43657  &96*a1*p1q1**2*p2q2/(p1q2*p2q1*s)-96*a2*p1q1**2*p2q2/(p1q2*p2q1*s)+
43658  &96*a1*a2*mb**2*p1q2*p2q2/(p2q1*s)+
43659  &192*a2**2*mb**2*p1q2*p2q2/(p2q1*s)+
43660  &96*a1*a2*mb*mt*p1q2*p2q2/(p2q1*s)+
43661  &384*a1*a2*p1p2*p1q2*p2q2/(p2q1*s)+
43662  &96*a1*a2*p1q1*p1q2*p2q2/(p2q1*s)-576*a1*a2*p2q1*p2q2/s+
43663  &96*a1*a2*p1q1*p2q1*p2q2/(p1q2*s)+96*a1*a2*p1q2*p2q1*p2q2/(p1q1*s)-
43664  &96*a1*a2*p2q2**2/s+96*a1*a2*mt**2*p2q2**2/(p1q1*s)-
43665  &96*a1*a2*mt**2*p2q2**2/(p1q2*s)+288*a1*a2*p1q1*p2q2**2/(p1q2*s)+
43666  &192*a1*p2q2**2/(p2q1*s)+192*a2*p2q2**2/(p2q1*s)-
43667  &96*a1*a2*mb*mt*p2q2**2/(p2q1*s)+192*a2**2*mb*mt*p2q2**2/(p2q1*s)-
43668  &192*a1*a2*mt**2*p2q2**2/(p2q1*s)-192*a1*a2*p1p2*p2q2**2/(p2q1*s)
43669  v18bis=v18bis-384*a1*a2*p1q1*p2q2**2/(p2q1*s)-
43670  &192*a2**2*p1q1*p2q2**2/(p2q1*s)+
43671  &48*a2*mb*mt*p2q2**2/(p1q2*p2q1*s)+
43672  &192*a1*mt**2*p2q2**2/(p1q2*p2q1*s)+
43673  &96*a2*mt**2*p2q2**2/(p1q2*p2q1*s)+
43674  &96*a2*p1p2*p2q2**2/(p1q2*p2q1*s)+96*a1*p1q1*p2q2**2/(p1q2*p2q1*s)+
43675  &96*a2*p1q1*p2q2**2/(p1q2*p2q1*s)-384*a1*a2*p1q2*p2q2**2/(p2q1*s)-
43676  &384*a2**2*p1q2*p2q2**2/(p2q1*s)+512*a1*a2*s/3-
43677  &128*a1*mt**2*s/(3*p1q1**2)-128*a12*mb*mt**3*s/(3*p1q1**2)-
43678  &152*a1*s/(3*p1q1)+152*a12*mb*mt*s/(3*p1q1)+
43679  &128*a1*a2*mb*mt*s/(3*p1q1)+112*a1*a2*mt**2*s/(3*p1q1)-
43680  &16*a12*p1p2*s/p1q1+152*a1*a2*p1p2*s/(3*p1q1)-
43681  &128*a1*mt**2*s/(3*p1q2**2)-128*a12*mb*mt**3*s/(3*p1q2**2)-
43682  &152*a1*s/(3*p1q2)+152*a12*mb*mt*s/(3*p1q2)+
43683  &128*a1*a2*mb*mt*s/(3*p1q2)+112*a1*a2*mt**2*s/(3*p1q2)-
43684  &16*a12*p1p2*s/p1q2+152*a1*a2*p1p2*s/(3*p1q2)-
43685  &16*a1*mb*mt*s/(3*p1q1*p1q2)+32*a12*mb*mt**3*s/(3*p1q1*p1q2)
43686  v18bis=v18bis-16*a1*p1p2*s/(3*p1q1*p1q2)+
43687  &272*a1*a2*p1q1*s/(3*p1q2)+
43688  &272*a1*a2*p1q2*s/(3*p1q1)-128*a2*mb**2*s/(3*p2q1**2)-
43689  &128*a2**2*mb**3*mt*s/(3*p2q1**2)+
43690  &32*mb**2*mt**2*s/(3*p1q2**2*p2q1**2)+32*mb**2*s/(3*p1q2*p2q1**2)-
43691  &64*a2*mb**3*mt*s/(3*p1q2*p2q1**2)-
43692  &64*a2*mb**2*mt**2*s/(3*p1q2*p2q1**2)-
43693  &128*a2*mb**2*p1p2*s/(3*p1q2*p2q1**2)-
43694  &128*a2*mb**2*p1q1*s/(3*p1q2*p2q1**2)+
43695  &128*a2**2*mb**2*p1q2*s/(3*p2q1**2)+152*a2*s/(3*p2q1)-
43696  &112*a1*a2*mb**2*s/(3*p2q1)-128*a1*a2*mb*mt*s/(3*p2q1)-
43697  &152*a2**2*mb*mt*s/(3*p2q1)-152*a1*a2*p1p2*s/(3*p2q1)+
43698  &16*a2**2*p1p2*s/p2q1+8*a1*a2*mb**3*mt*s/(3*p1q1*p2q1)+
43699  &16*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q1)+
43700  &8*a1*a2*mb*mt**3*s/(3*p1q1*p2q1)-8*a1*p1p2*s/(3*p1q1*p2q1)-
43701  &8*a2*p1p2*s/(3*p1q1*p2q1)+8*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q1)+
43702  &16*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q1)
43703  v18bis=v18bis+8*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q1)+
43704  &32*a1*a2*p1p2**2*s/(3*p1q1*p2q1)-32*a2**2*p1q1*s/(3*p2q1)-
43705  &32*mt**2*s/(3*p1q2**2*p2q1)+64*a1*mb**2*mt**2*s/(3*p1q2**2*p2q1)+
43706  &64*a1*mb*mt**3*s/(3*p1q2**2*p2q1)+
43707  &128*a1*mt**2*p1p2*s/(3*p1q2**2*p2q1)-12*s/(p1q2*p2q1)+
43708  &24*a1*mb**2*s/(p1q2*p2q1)-64*a1*a2*mb**3*mt*s/(3*p1q2*p2q1)+
43709  &24*a2*mt**2*s/(p1q2*p2q1)-128*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q1)-
43710  &64*a1*a2*mb*mt**3*s/(3*p1q2*p2q1)+56*a1*p1p2*s/(3*p1q2*p2q1)+
43711  &56*a2*p1p2*s/(3*p1q2*p2q1)-64*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q1)-
43712  &128*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q1)-
43713  &64*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q1)-
43714  &256*a1*a2*p1p2**2*s/(3*p1q2*p2q1)+4*p1p2*s/(3*p1q1*p1q2*p2q1)+
43715  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1)-
43716  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1)+136*a2*p1q1*s/(3*p1q2*p2q1)-
43717  &128*a1*a2*mb**2*p1q1*s/(3*p1q2*p2q1)-
43718  &128*a1*a2*mb*mt*p1q1*s/(3*p1q2*p2q1)-
43719  &256*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q1)-160*a2**2*p1q2*s/(3*p2q1)
43720  v18bis=v18bis+16*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q1)-
43721  &32*a12*p2q1*s/(3*p1q1)-
43722  &128*a12*mt**2*p2q1*s/(3*p1q2**2)-160*a12*p2q1*s/(3*p1q2)-
43723  &128*a2*mb**2*s/(3*p2q2**2)-128*a2**2*mb**3*mt*s/(3*p2q2**2)+
43724  &32*mb**2*mt**2*s/(3*p1q1**2*p2q2**2)+32*mb**2*s/(3*p1q1*p2q2**2)-
43725  &64*a2*mb**3*mt*s/(3*p1q1*p2q2**2)-
43726  &64*a2*mb**2*mt**2*s/(3*p1q1*p2q2**2)-
43727  &128*a2*mb**2*p1p2*s/(3*p1q1*p2q2**2)+
43728  &128*a2**2*mb**2*p1q1*s/(3*p2q2**2)-
43729  &128*a2*mb**2*p1q2*s/(3*p1q1*p2q2**2)+152*a2*s/(3*p2q2)-
43730  &112*a1*a2*mb**2*s/(3*p2q2)-128*a1*a2*mb*mt*s/(3*p2q2)-
43731  &152*a2**2*mb*mt*s/(3*p2q2)-152*a1*a2*p1p2*s/(3*p2q2)+
43732  &16*a2**2*p1p2*s/p2q2-32*mt**2*s/(3*p1q1**2*p2q2)+
43733  &64*a1*mb**2*mt**2*s/(3*p1q1**2*p2q2)+
43734  &64*a1*mb*mt**3*s/(3*p1q1**2*p2q2)+
43735  &128*a1*mt**2*p1p2*s/(3*p1q1**2*p2q2)-12*s/(p1q1*p2q2)+
43736  &24*a1*mb**2*s/(p1q1*p2q2)-64*a1*a2*mb**3*mt*s/(3*p1q1*p2q2)
43737  v18bis=v18bis+24*a2*mt**2*s/(p1q1*p2q2)-
43738  &128*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q2)-
43739  &64*a1*a2*mb*mt**3*s/(3*p1q1*p2q2)+56*a1*p1p2*s/(3*p1q1*p2q2)+
43740  &56*a2*p1p2*s/(3*p1q1*p2q2)-64*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q2)-
43741  &128*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q2)-
43742  &64*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q2)-
43743  &256*a1*a2*p1p2**2*s/(3*p1q1*p2q2)-160*a2**2*p1q1*s/(3*p2q2)+
43744  &8*a1*a2*mb**3*mt*s/(3*p1q2*p2q2)+
43745  &16*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q2)+
43746  &8*a1*a2*mb*mt**3*s/(3*p1q2*p2q2)-8*a1*p1p2*s/(3*p1q2*p2q2)-
43747  &8*a2*p1p2*s/(3*p1q2*p2q2)+8*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q2)+
43748  &16*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q2)+
43749  &8*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q2)+
43750  &32*a1*a2*p1p2**2*s/(3*p1q2*p2q2)+4*p1p2*s/(3*p1q1*p1q2*p2q2)+
43751  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q2)-
43752  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q2)+
43753  &16*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q2)-32*a2**2*p1q2*s/(3*p2q2)
43754  v18bis=v18bis+136*a2*p1q2*s/(3*p1q1*p2q2)-
43755  &128*a1*a2*mb**2*p1q2*s/(3*p1q1*p2q2)-
43756  &128*a1*a2*mb*mt*p1q2*s/(3*p1q1*p2q2)-
43757  &256*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q2)-16*a2*mb*mt*s/(3*p2q1*p2q2)+
43758  &32*a2**2*mb**3*mt*s/(3*p2q1*p2q2)-16*a2*p1p2*s/(3*p2q1*p2q2)-
43759  &4*p1p2*s/(3*p1q1*p2q1*p2q2)+8*a2*mb**2*p1p2*s/(3*p1q1*p2q1*p2q2)-
43760  &8*a2*mb*mt*p1p2*s/(3*p1q1*p2q1*p2q2)-4*p1p2*s/(3*p1q2*p2q1*p2q2)+
43761  &8*a2*mb**2*p1p2*s/(3*p1q2*p2q1*p2q2)-
43762  &8*a2*mb*mt*p1p2*s/(3*p1q2*p2q1*p2q2)+
43763  &2*mb**3*mt*s/(3*p1q1*p1q2*p2q1*p2q2)+
43764  &4*mb**2*mt**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
43765  &2*mb*mt**3*s/(3*p1q1*p1q2*p2q1*p2q2)-
43766  &2*mb**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
43767  &4*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
43768  &2*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
43769  &8*p1p2**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
43770  &8*a2*p1p2*p1q1*s/(3*p1q2*p2q1*p2q2)
43771  v18bis=v18bis+8*a2*p1p2*p1q2*s/(3*p1q1*p2q1*p2q2)+
43772  &272*a1*a2*p2q1*s/(3*p2q2)-
43773  &128*a1*mt**2*p2q1*s/(3*p1q1**2*p2q2)-136*a1*p2q1*s/(3*p1q1*p2q2)+
43774  &128*a1*a2*mb*mt*p2q1*s/(3*p1q1*p2q2)+
43775  &128*a1*a2*mt**2*p2q1*s/(3*p1q1*p2q2)+
43776  &256*a1*a2*p1p2*p2q1*s/(3*p1q1*p2q2)-
43777  &16*a1*a2*p1p2*p2q1*s/(3*p1q2*p2q2)+
43778  &8*a1*p1p2*p2q1*s/(3*p1q1*p1q2*p2q2)+
43779  &256*a1*a2*p1q2*p2q1*s/(3*p1q1*p2q2)-
43780  &128*a12*mt**2*p2q2*s/(3*p1q1**2)-160*a12*p2q2*s/(3*p1q1)-
43781  &32*a12*p2q2*s/(3*p1q2)+272*a1*a2*p2q2*s/(3*p2q1)-
43782  &16*a1*a2*p1p2*p2q2*s/(3*p1q1*p2q1)-
43783  &128*a1*mt**2*p2q2*s/(3*p1q2**2*p2q1)-136*a1*p2q2*s/(3*p1q2*p2q1)+
43784  &128*a1*a2*mb*mt*p2q2*s/(3*p1q2*p2q1)+
43785  &128*a1*a2*mt**2*p2q2*s/(3*p1q2*p2q1)+
43786  &256*a1*a2*p1p2*p2q2*s/(3*p1q2*p2q1)+
43787  &8*a1*p1p2*p2q2*s/(3*p1q1*p1q2*p2q1)
43788  v18bis=v18bis+256*a1*a2*p1q1*p2q2*s/(3*p1q2*p2q1)+
43789  &8*a12*mb*mt*s**2/(3*p1q1*p1q2)+16*a12*p1p2*s**2/(3*p1q1*p1q2)-
43790  &8*a1*a2*p1p2*s**2/(3*p1q1*p2q1)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q1)-
43791  &8*a1*a2*p1p2*s**2/(3*p1q2*p2q2)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q2)+
43792  &8*a2**2*mb*mt*s**2/(3*p2q1*p2q2)+16*a2**2*p1p2*s**2/(3*p2q1*p2q2)-
43793  &4*a2*p1p2*s**2/(3*p1q1*p2q1*p2q2)-
43794  &4*a2*p1p2*s**2/(3*p1q2*p2q1*p2q2)+
43795  &2*p1p2*s**2/(3*p1q1*p1q2*p2q1*p2q2)
43796 C
43797 
43798  a18 = 640*a1/3+640*a2/3+32*a1*a2*mb**2+368*a12*mb*mt+
43799  &512*a1*a2*mb*mt/3+
43800  &368*a2**2*mb*mt+32*a1*a2*mt**2+496*a12*p1p2/3+
43801  &320*a1*a2*p1p2+496*a2**2*p1p2/3-128*a1*mb*mt**3/(3*p1q1**2)+
43802  &128*a1*mt**4/(3*p1q1**2)+256*a12*mb*mt**5/(3*p1q1**2)+
43803  &256*a1*mt**2*p1p2/(3*p1q1**2)-256*a12*mt**4*p1p2/(3*p1q1**2)+
43804  &8/(3*p1q1)+32*a1*mb*mt/p1q1+56*a2*mb*mt/(3*p1q1)+
43805  &88*a1*mt**2/(3*p1q1)+72*a2*mt**2/p1q1-
43806  &704*a12*mb*mt**3/(3*p1q1)+224*a1*a2*mb*mt**3/(3*p1q1)+
43807  &104*a1*p1p2/(3*p1q1)+48*a2*p1p2/p1q1-
43808  &128*a1*a2*mb*mt*p1p2/(3*p1q1)+512*a12*mt**2*p1p2/(3*p1q1)-
43809  &448*a1*a2*mt**2*p1p2/(3*p1q1)-32*a1*a2*p1p2**2/p1q1-
43810  &656*a1*a2*p1q1/3-224*a2**2*p1q1-128*a1*mb*mt**3/(3*p1q2**2)+
43811  &128*a1*mt**4/(3*p1q2**2)+256*a12*mb*mt**5/(3*p1q2**2)+
43812  &256*a1*mt**2*p1p2/(3*p1q2**2)-256*a12*mt**4*p1p2/(3*p1q2**2)+
43813  &256*a1*mt**2*p1q1/(3*p1q2**2)-256*a12*mb*mt**3*p1q1/(3*p1q2**2)+
43814  &8/(3*p1q2)+32*a1*mb*mt/p1q2+56*a2*mb*mt/(3*p1q2)
43815  a18=a18+88*a1*mt**2/(3*p1q2)+72*a2*mt**2/p1q2-
43816  &704*a12*mb*mt**3/(3*p1q2)+224*a1*a2*mb*mt**3/(3*p1q2)+
43817  &104*a1*p1p2/(3*p1q2)+48*a2*p1p2/p1q2-
43818  &128*a1*a2*mb*mt*p1p2/(3*p1q2)+512*a12*mt**2*p1p2/(3*p1q2)-
43819  &448*a1*a2*mt**2*p1p2/(3*p1q2)-32*a1*a2*p1p2**2/p1q2+
43820  &32*a1*mb*mt**3/(3*p1q1*p1q2)-32*a1*mt**4/(3*p1q1*p1q2)-
43821  &64*a12*mb*mt**5/(3*p1q1*p1q2)+16*p1p2/(3*p1q1*p1q2)-
43822  &64*a1*mt**2*p1p2/(3*p1q1*p1q2)+64*a12*mt**4*p1p2/(3*p1q1*p1q2)+
43823  &112*a1*p1q1/p1q2+272*a2*p1q1/(3*p1q2)-
43824  &272*a1*a2*mb**2*p1q1/(3*p1q2)-208*a12*mb*mt*p1q1/(3*p1q2)+
43825  &400*a1*a2*mb*mt*p1q1/(3*p1q2)-80*a1*a2*mt**2*p1q1/p1q2+
43826  &96*a12*p1p2*p1q1/p1q2-320*a1*a2*p1p2*p1q1/p1q2-
43827  &544*a1*a2*p1q1**2/(3*p1q2)-656*a1*a2*p1q2/3-224*a2**2*p1q2+
43828  &256*a1*mt**2*p1q2/(3*p1q1**2)-256*a12*mb*mt**3*p1q2/(3*p1q1**2)+
43829  &112*a1*p1q2/p1q1+272*a2*p1q2/(3*p1q1)-
43830  &272*a1*a2*mb**2*p1q2/(3*p1q1)-208*a12*mb*mt*p1q2/(3*p1q1)+
43831  &400*a1*a2*mb*mt*p1q2/(3*p1q1)-80*a1*a2*mt**2*p1q2/p1q1
43832  a18=a18+96*a12*p1p2*p1q2/p1q1-320*a1*a2*p1p2*p1q2/p1q1-
43833  &544*a1*a2*p1q2**2/(3*p1q1)+128*a2*mb**4/(3*p2q1**2)-
43834  &128*a2*mb**3*mt/(3*p2q1**2)+256*a2**2*mb**5*mt/(3*p2q1**2)+
43835  &256*a2*mb**2*p1p2/(3*p2q1**2)-256*a2**2*mb**4*p1p2/(3*p2q1**2)+
43836  &256*a2*mb**2*p1q1/(3*p2q1**2)-256*a2**2*mb**4*p1q1/(3*p2q1**2)+
43837  &64*mb**3*mt**3/(3*p1q2**2*p2q1**2)-
43838  &64*mb**2*mt**2*p1p2/(3*p1q2**2*p2q1**2)-
43839  &64*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1**2)-
43840  &64*mb**3*mt/(3*p1q2*p2q1**2)-
43841  &256*a2*mb**3*mt*p1p2/(3*p1q2*p2q1**2)+
43842  &256*a2*mb**2*p1p2**2/(3*p1q2*p2q1**2)-
43843  &256*a2*mb**3*mt*p1q1/(3*p1q2*p2q1**2)+
43844  &512*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1**2)+
43845  &256*a2*mb**2*p1q1**2/(3*p1q2*p2q1**2)-
43846  &256*a2**2*mb**4*p1q2/(3*p2q1**2)-8/(3*p2q1)-72*a1*mb**2/p2q1-
43847  &88*a2*mb**2/(3*p2q1)-56*a1*mb*mt/(3*p2q1)-32*a2*mb*mt/p2q1-
43848  &224*a1*a2*mb**3*mt/(3*p2q1)+704*a2**2*mb**3*mt/(3*p2q1)
43849  a18=a18-48*a1*p1p2/p2q1-104*a2*p1p2/(3*p2q1)+
43850  &448*a1*a2*mb**2*p1p2/(3*p2q1)-512*a2**2*mb**2*p1p2/(3*p2q1)+
43851  &128*a1*a2*mb*mt*p1p2/(3*p2q1)+32*a1*a2*p1p2**2/p2q1-
43852  &16*p1p2/(3*p1q1*p2q1)+32*a1*mb*mt*p1p2/(3*p1q1*p2q1)+
43853  &32*a2*mb*mt*p1p2/(3*p1q1*p2q1)+
43854  &64*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q1)-
43855  &64*a1*a2*p1p2**3/(3*p1q1*p2q1)-256*a2*p1q1/(3*p2q1)+
43856  &448*a1*a2*mb**2*p1q1/(3*p2q1)-368*a2**2*mb**2*p1q1/(3*p2q1)-
43857  &224*a1*a2*mb*mt*p1q1/(3*p2q1)+304*a1*a2*p1p2*p1q1/(3*p2q1)+
43858  &64*mb*mt**3/(3*p1q2**2*p2q1)+
43859  &256*a1*mb*mt**3*p1p2/(3*p1q2**2*p2q1)-
43860  &256*a1*mt**2*p1p2**2/(3*p1q2**2*p2q1)+
43861  &64*mt**2*p1q1/(3*p1q2**2*p2q1)-
43862  &128*a1*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1)+
43863  &128*a1*mb*mt**3*p1q1/(3*p1q2**2*p2q1)-
43864  &256*a1*mt**2*p1p2*p1q1/(3*p1q2**2*p2q1)-4*mb**2/(3*p1q2*p2q1)-
43865  &64*mb*mt/(3*p1q2*p2q1)+128*a2*mb**3*mt/(3*p1q2*p2q1)
43866  a18=a18-4*mt**2/(3*p1q2*p2q1)-128*a1*mb**2*mt**2/(3*p1q2*p2q1)-
43867  &128*a2*mb**2*mt**2/(3*p1q2*p2q1)+128*a1*mb*mt**3/(3*p1q2*p2q1)-
43868  &112*a2*mb**2*p1p2/(3*p1q2*p2q1)+32*a1*mb*mt*p1p2/(3*p1q2*p2q1)+
43869  &32*a2*mb*mt*p1p2/(3*p1q2*p2q1)-112*a1*mt**2*p1p2/(3*p1q2*p2q1)-
43870  &48*a1*p1p2**2/(p1q2*p2q1)-48*a2*p1p2**2/(p1q2*p2q1)-
43871  &512*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q1)+
43872  &512*a1*a2*p1p2**3/(3*p1q2*p2q1)+8*mb*mt*p1p2/(3*p1q1*p1q2*p2q1)-
43873  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q1)-
43874  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q1)-
43875  &16*p1p2**2/(3*p1q1*p1q2*p2q1)+
43876  &32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q1)+8*p1q1/(3*p1q2*p2q1)-
43877  &160*a1*mb**2*p1q1/(3*p1q2*p2q1)-272*a2*mb**2*p1q1/(3*p1q2*p2q1)-
43878  &56*a1*mb*mt*p1q1/(3*p1q2*p2q1)-200*a2*mb*mt*p1q1/(3*p1q2*p2q1)-
43879  &48*a1*p1p2*p1q1/(p1q2*p2q1)-256*a2*p1p2*p1q1/(3*p1q2*p2q1)+
43880  &256*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1)-
43881  &256*a1*a2*mb*mt*p1p2*p1q1/(p1q2*p2q1)+
43882  &1024*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q1)
43883  a18=a18-272*a2*p1q1**2/(3*p1q2*p2q1)+
43884  &256*a1*a2*mb**2*p1q1**2/(3*p1q2*p2q1)-
43885  &256*a1*a2*mb*mt*p1q1**2/(3*p1q2*p2q1)+
43886  &512*a1*a2*p1p2*p1q1**2/(3*p1q2*p2q1)+16*a2*p1q2/(3*p2q1)+
43887  &64*a1*a2*mb**2*p1q2/p2q1+32*a2**2*mb**2*p1q2/(3*p2q1)-
43888  &112*a1*a2*mb*mt*p1q2/(3*p2q1)+368*a1*a2*p1p2*p1q2/(3*p2q1)+
43889  &32*a2*p1p2*p1q2/(3*p1q1*p2q1)-
43890  &32*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1)+
43891  &32*a1*a2*mb*mt*p1p2*p1q2/(3*p1q1*p2q1)-
43892  &64*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q1)+224*a12*p2q1+
43893  &656*a1*a2*p2q1/3-256*a1*mt**2*p2q1/(3*p1q1**2)+
43894  &256*a12*mt**4*p2q1/(3*p1q1**2)-256*a1*p2q1/(3*p1q1)-
43895  &224*a1*a2*mb*mt*p2q1/(3*p1q1)-368*a12*mt**2*p2q1/(3*p1q1)+
43896  &448*a1*a2*mt**2*p2q1/(3*p1q1)+304*a1*a2*p1p2*p2q1/(3*p1q1)+
43897  &256*a12*mt**4*p2q1/(3*p1q2**2)+
43898  &256*a12*mt**2*p1q1*p2q1/(3*p1q2**2)+16*a1*p2q1/(3*p1q2)-
43899  &112*a1*a2*mb*mt*p2q1/(3*p1q2)+32*a12*mt**2*p2q1/(3*p1q2)
43900  a18=a18+64*a1*a2*mt**2*p2q1/p1q2+368*a1*a2*p1p2*p2q1/(3*p1q2)+
43901  &16*a1*mt**2*p2q1/(3*p1q1*p1q2)-64*a12*mt**4*p2q1/(3*p1q1*p1q2)+
43902  &640*a12*p1q1*p2q1/(3*p1q2)+544*a1*a2*p1q1*p2q1/(3*p1q2)+
43903  &32*a12*p1q2*p2q1/p1q1+944*a1*a2*p1q2*p2q1/(3*p1q1)+
43904  &128*a2*mb**4/(3*p2q2**2)-128*a2*mb**3*mt/(3*p2q2**2)+
43905  &256*a2**2*mb**5*mt/(3*p2q2**2)+256*a2*mb**2*p1p2/(3*p2q2**2)-
43906  &256*a2**2*mb**4*p1p2/(3*p2q2**2)+
43907  &64*mb**3*mt**3/(3*p1q1**2*p2q2**2)-
43908  &64*mb**2*mt**2*p1p2/(3*p1q1**2*p2q2**2)-
43909  &64*mb**3*mt/(3*p1q1*p2q2**2)-
43910  &256*a2*mb**3*mt*p1p2/(3*p1q1*p2q2**2)+
43911  &256*a2*mb**2*p1p2**2/(3*p1q1*p2q2**2)-
43912  &256*a2**2*mb**4*p1q1/(3*p2q2**2)+256*a2*mb**2*p1q2/(3*p2q2**2)-
43913  &256*a2**2*mb**4*p1q2/(3*p2q2**2)-
43914  &64*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2**2)-
43915  &256*a2*mb**3*mt*p1q2/(3*p1q1*p2q2**2)+
43916  &512*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2**2)
43917  a18=a18+256*a2*mb**2*p1q2**2/(3*p1q1*p2q2**2)-
43918  &256*a2*mb**2*p2q1/(3*p2q2**2)+256*a2**2*mb**3*mt*p2q1/(3*p2q2**2)+
43919  &64*mb**2*mt**2*p2q1/(3*p1q1**2*p2q2**2)+
43920  &64*mb**2*p2q1/(3*p1q1*p2q2**2)+
43921  &128*a2*mb**3*mt*p2q1/(3*p1q1*p2q2**2)-
43922  &128*a2*mb**2*mt**2*p2q1/(3*p1q1*p2q2**2)-
43923  &256*a2*mb**2*p1p2*p2q1/(3*p1q1*p2q2**2)+
43924  &256*a2**2*mb**2*p1q1*p2q1/(3*p2q2**2)-
43925  &256*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2**2)-8/(3*p2q2)-
43926  &72*a1*mb**2/p2q2-88*a2*mb**2/(3*p2q2)-56*a1*mb*mt/(3*p2q2)-
43927  &32*a2*mb*mt/p2q2-224*a1*a2*mb**3*mt/(3*p2q2)+
43928  &704*a2**2*mb**3*mt/(3*p2q2)-48*a1*p1p2/p2q2-
43929  &104*a2*p1p2/(3*p2q2)+448*a1*a2*mb**2*p1p2/(3*p2q2)-
43930  &512*a2**2*mb**2*p1p2/(3*p2q2)+128*a1*a2*mb*mt*p1p2/(3*p2q2)+
43931  &32*a1*a2*p1p2**2/p2q2+64*mb*mt**3/(3*p1q1**2*p2q2)+
43932  &256*a1*mb*mt**3*p1p2/(3*p1q1**2*p2q2)-
43933  &256*a1*mt**2*p1p2**2/(3*p1q1**2*p2q2)-4*mb**2/(3*p1q1*p2q2)
43934  a18=a18-64*mb*mt/(3*p1q1*p2q2)+128*a2*mb**3*mt/(3*p1q1*p2q2)-
43935  &4*mt**2/(3*p1q1*p2q2)-128*a1*mb**2*mt**2/(3*p1q1*p2q2)-
43936  &128*a2*mb**2*mt**2/(3*p1q1*p2q2)+128*a1*mb*mt**3/(3*p1q1*p2q2)-
43937  &112*a2*mb**2*p1p2/(3*p1q1*p2q2)+32*a1*mb*mt*p1p2/(3*p1q1*p2q2)+
43938  &32*a2*mb*mt*p1p2/(3*p1q1*p2q2)-112*a1*mt**2*p1p2/(3*p1q1*p2q2)-
43939  &48*a1*p1p2**2/(p1q1*p2q2)-48*a2*p1p2**2/(p1q1*p2q2)-
43940  &512*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q2)+
43941  &512*a1*a2*p1p2**3/(3*p1q1*p2q2)+16*a2*p1q1/(3*p2q2)+
43942  &64*a1*a2*mb**2*p1q1/p2q2+32*a2**2*mb**2*p1q1/(3*p2q2)-
43943  &112*a1*a2*mb*mt*p1q1/(3*p2q2)+368*a1*a2*p1p2*p1q1/(3*p2q2)-
43944  &16*p1p2/(3*p1q2*p2q2)+32*a1*mb*mt*p1p2/(3*p1q2*p2q2)+
43945  &32*a2*mb*mt*p1p2/(3*p1q2*p2q2)+
43946  &64*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q2)-
43947  &64*a1*a2*p1p2**3/(3*p1q2*p2q2)+8*mb*mt*p1p2/(3*p1q1*p1q2*p2q2)-
43948  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q2)-
43949  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q2)-
43950  &16*p1p2**2/(3*p1q1*p1q2*p2q2)
43951  a18=a18+32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q2)+
43952  &32*a2*p1p2*p1q1/(3*p1q2*p2q2)-
43953  &32*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q2)+
43954  &32*a1*a2*mb*mt*p1p2*p1q1/(3*p1q2*p2q2)-
43955  &64*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q2)-256*a2*p1q2/(3*p2q2)+
43956  &448*a1*a2*mb**2*p1q2/(3*p2q2)-368*a2**2*mb**2*p1q2/(3*p2q2)-
43957  &224*a1*a2*mb*mt*p1q2/(3*p2q2)+304*a1*a2*p1p2*p1q2/(3*p2q2)+
43958  &64*mt**2*p1q2/(3*p1q1**2*p2q2)-
43959  &128*a1*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2)+
43960  &128*a1*mb*mt**3*p1q2/(3*p1q1**2*p2q2)-
43961  &256*a1*mt**2*p1p2*p1q2/(3*p1q1**2*p2q2)+8*p1q2/(3*p1q1*p2q2)-
43962  &160*a1*mb**2*p1q2/(3*p1q1*p2q2)-272*a2*mb**2*p1q2/(3*p1q1*p2q2)-
43963  &56*a1*mb*mt*p1q2/(3*p1q1*p2q2)-200*a2*mb*mt*p1q2/(3*p1q1*p2q2)-
43964  &48*a1*p1p2*p1q2/(p1q1*p2q2)-256*a2*p1p2*p1q2/(3*p1q1*p2q2)+
43965  &256*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2)-
43966  &256*a1*a2*mb*mt*p1p2*p1q2/(p1q1*p2q2)+
43967  &1024*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q2)
43968  a18=a18-272*a2*p1q2**2/(3*p1q1*p2q2)+
43969  &256*a1*a2*mb**2*p1q2**2/(3*p1q1*p2q2)-
43970  &256*a1*a2*mb*mt*p1q2**2/(3*p1q1*p2q2)+
43971  &512*a1*a2*p1p2*p1q2**2/(3*p1q1*p2q2)-32*a2*mb**4/(3*p2q1*p2q2)+
43972  &32*a2*mb**3*mt/(3*p2q1*p2q2)-64*a2**2*mb**5*mt/(3*p2q1*p2q2)+
43973  &16*p1p2/(3*p2q1*p2q2)-64*a2*mb**2*p1p2/(3*p2q1*p2q2)+
43974  &64*a2**2*mb**4*p1p2/(3*p2q1*p2q2)+8*mb**2*p1p2/(3*p1q1*p2q1*p2q2)-
43975  &8*mb*mt*p1p2/(3*p1q1*p2q1*p2q2)+
43976  &32*a2*mb**3*mt*p1p2/(3*p1q1*p2q1*p2q2)+
43977  &16*p1p2**2/(3*p1q1*p2q1*p2q2)-
43978  &32*a2*mb**2*p1p2**2/(3*p1q1*p2q1*p2q2)-
43979  &16*a2*mb**2*p1q1/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q1/(3*p2q1*p2q2)+
43980  &8*mb**2*p1p2/(3*p1q2*p2q1*p2q2)-8*mb*mt*p1p2/(3*p1q2*p2q1*p2q2)+
43981  &32*a2*mb**3*mt*p1p2/(3*p1q2*p2q1*p2q2)+
43982  &16*p1p2**2/(3*p1q2*p2q1*p2q2)-
43983  &32*a2*mb**2*p1p2**2/(3*p1q2*p2q1*p2q2)-
43984  &16*mb*mt*p1p2**2/(3*p1q1*p1q2*p2q1*p2q2)
43985  a18=a18+16*p1p2**3/(3*p1q1*p1q2*p2q1*p2q2)-
43986  &32*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1*p2q2)-
43987  &16*a2*mb**2*p1q2/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q2/(3*p2q1*p2q2)-
43988  &32*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1*p2q2)+272*a1*p2q1/(3*p2q2)+
43989  &112*a2*p2q1/p2q2-80*a1*a2*mb**2*p2q1/p2q2+
43990  &400*a1*a2*mb*mt*p2q1/(3*p2q2)-208*a2**2*mb*mt*p2q1/(3*p2q2)-
43991  &272*a1*a2*mt**2*p2q1/(3*p2q2)-320*a1*a2*p1p2*p2q1/p2q2+
43992  &96*a2**2*p1p2*p2q1/p2q2-256*a1*mb*mt**3*p2q1/(3*p1q1**2*p2q2)+
43993  &512*a1*mt**2*p1p2*p2q1/(3*p1q1**2*p2q2)-8*p2q1/(3*p1q1*p2q2)+
43994  &200*a1*mb*mt*p2q1/(3*p1q1*p2q2)+56*a2*mb*mt*p2q1/(3*p1q1*p2q2)+
43995  &272*a1*mt**2*p2q1/(3*p1q1*p2q2)+160*a2*mt**2*p2q1/(3*p1q1*p2q2)+
43996  &256*a1*p1p2*p2q1/(3*p1q1*p2q2)+48*a2*p1p2*p2q1/(p1q1*p2q2)+
43997  &256*a1*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2)-
43998  &256*a1*a2*mt**2*p1p2*p2q1/(3*p1q1*p2q2)-
43999  &1024*a1*a2*p1p2**2*p2q1/(3*p1q1*p2q2)-
44000  &544*a1*a2*p1q1*p2q1/(3*p2q2)-640*a2**2*p1q1*p2q1/(3*p2q2)-
44001  &32*a1*p1p2*p2q1/(3*p1q2*p2q2)
44002  a18=a18-32*a1*a2*mb*mt*p1p2*p2q1/(3*p1q2*p2q2)+
44003  &32*a1*a2*mt**2*p1p2*p2q1/(3*p1q2*p2q2)+
44004  &64*a1*a2*p1p2**2*p2q1/(3*p1q2*p2q2)-
44005  &32*a1*mt**2*p1p2*p2q1/(3*p1q1*p1q2*p2q2)+
44006  &64*a1*a2*p1p2*p1q1*p2q1/(3*p1q2*p2q2)-
44007  &944*a1*a2*p1q2*p2q1/(3*p2q2)-32*a2**2*p1q2*p2q1/p2q2+
44008  &256*a1*mt**2*p1q2*p2q1/(3*p1q1**2*p2q2)+
44009  &96*a1*p1q2*p2q1/(p1q1*p2q2)+96*a2*p1q2*p2q1/(p1q1*p2q2)-
44010  &128*a1*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2)+
44011  &256*a1*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2)-
44012  &128*a1*a2*mt**2*p1q2*p2q1/(3*p1q1*p2q2)-
44013  &512*a1*a2*p1p2*p1q2*p2q1/(p1q1*p2q2)-
44014  &512*a1*a2*p1q2**2*p2q1/(3*p1q1*p2q2)+544*a1*a2*p2q1**2/(3*p2q2)-
44015  &256*a1*mt**2*p2q1**2/(3*p1q1**2*p2q2)-
44016  &272*a1*p2q1**2/(3*p1q1*p2q2)-
44017  &256*a1*a2*mb*mt*p2q1**2/(3*p1q1*p2q2)+
44018  &256*a1*a2*mt**2*p2q1**2/(3*p1q1*p2q2)
44019  a18=a18+512*a1*a2*p1p2*p2q1**2/(3*p1q1*p2q2)+
44020  &512*a1*a2*p1q2*p2q1**2/(3*p1q1*p2q2)+224*a12*p2q2+
44021  &656*a1*a2*p2q2/3+256*a12*mt**4*p2q2/(3*p1q1**2)+
44022  &16*a1*p2q2/(3*p1q1)-112*a1*a2*mb*mt*p2q2/(3*p1q1)+
44023  &32*a12*mt**2*p2q2/(3*p1q1)+64*a1*a2*mt**2*p2q2/p1q1+
44024  &368*a1*a2*p1p2*p2q2/(3*p1q1)-256*a1*mt**2*p2q2/(3*p1q2**2)+
44025  &256*a12*mt**4*p2q2/(3*p1q2**2)-256*a1*p2q2/(3*p1q2)-
44026  &224*a1*a2*mb*mt*p2q2/(3*p1q2)-368*a12*mt**2*p2q2/(3*p1q2)+
44027  &448*a1*a2*mt**2*p2q2/(3*p1q2)+304*a1*a2*p1p2*p2q2/(3*p1q2)+
44028  &16*a1*mt**2*p2q2/(3*p1q1*p1q2)-64*a12*mt**4*p2q2/(3*p1q1*p1q2)+
44029  &32*a12*p1q1*p2q2/p1q2+944*a1*a2*p1q1*p2q2/(3*p1q2)+
44030  &256*a12*mt**2*p1q2*p2q2/(3*p1q1**2)+
44031  &640*a12*p1q2*p2q2/(3*p1q1)+544*a1*a2*p1q2*p2q2/(3*p1q1)-
44032  &256*a2*mb**2*p2q2/(3*p2q1**2)+256*a2**2*mb**3*mt*p2q2/(3*p2q1**2)+
44033  &64*mb**2*mt**2*p2q2/(3*p1q2**2*p2q1**2)+
44034  &64*mb**2*p2q2/(3*p1q2*p2q1**2)+
44035  &128*a2*mb**3*mt*p2q2/(3*p1q2*p2q1**2)
44036  a18=a18-128*a2*mb**2*mt**2*p2q2/(3*p1q2*p2q1**2)-
44037  &256*a2*mb**2*p1p2*p2q2/(3*p1q2*p2q1**2)-
44038  &256*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1**2)+
44039  &256*a2**2*mb**2*p1q2*p2q2/(3*p2q1**2)+272*a1*p2q2/(3*p2q1)+
44040  &112*a2*p2q2/p2q1-80*a1*a2*mb**2*p2q2/p2q1+
44041  &400*a1*a2*mb*mt*p2q2/(3*p2q1)-208*a2**2*mb*mt*p2q2/(3*p2q1)-
44042  &272*a1*a2*mt**2*p2q2/(3*p2q1)-320*a1*a2*p1p2*p2q2/p2q1+
44043  &96*a2**2*p1p2*p2q2/p2q1-32*a1*p1p2*p2q2/(3*p1q1*p2q1)-
44044  &32*a1*a2*mb*mt*p1p2*p2q2/(3*p1q1*p2q1)+
44045  &32*a1*a2*mt**2*p1p2*p2q2/(3*p1q1*p2q1)+
44046  &64*a1*a2*p1p2**2*p2q2/(3*p1q1*p2q1)-944*a1*a2*p1q1*p2q2/(3*p2q1)-
44047  &32*a2**2*p1q1*p2q2/p2q1-256*a1*mb*mt**3*p2q2/(3*p1q2**2*p2q1)+
44048  &512*a1*mt**2*p1p2*p2q2/(3*p1q2**2*p2q1)+
44049  &256*a1*mt**2*p1q1*p2q2/(3*p1q2**2*p2q1)-8*p2q2/(3*p1q2*p2q1)+
44050  &200*a1*mb*mt*p2q2/(3*p1q2*p2q1)+56*a2*mb*mt*p2q2/(3*p1q2*p2q1)+
44051  &272*a1*mt**2*p2q2/(3*p1q2*p2q1)+160*a2*mt**2*p2q2/(3*p1q2*p2q1)+
44052  &256*a1*p1p2*p2q2/(3*p1q2*p2q1)+48*a2*p1p2*p2q2/(p1q2*p2q1)
44053  a18=a18+256*a1*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1)-
44054  &256*a1*a2*mt**2*p1p2*p2q2/(3*p1q2*p2q1)-
44055  &1024*a1*a2*p1p2**2*p2q2/(3*p1q2*p2q1)-
44056  &32*a1*mt**2*p1p2*p2q2/(3*p1q1*p1q2*p2q1)+
44057  &96*a1*p1q1*p2q2/(p1q2*p2q1)+96*a2*p1q1*p2q2/(p1q2*p2q1)-
44058  &128*a1*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1)+
44059  &256*a1*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1)-
44060  &128*a1*a2*mt**2*p1q1*p2q2/(3*p1q2*p2q1)-
44061  &512*a1*a2*p1p2*p1q1*p2q2/(p1q2*p2q1)-
44062  &512*a1*a2*p1q1**2*p2q2/(3*p1q2*p2q1)-544*a1*a2*p1q2*p2q2/(3*p2q1)-
44063  &640*a2**2*p1q2*p2q2/(3*p2q1)+
44064  &64*a1*a2*p1p2*p1q2*p2q2/(3*p1q1*p2q1)+544*a1*a2*p2q2**2/(3*p2q1)-
44065  &256*a1*mt**2*p2q2**2/(3*p1q2**2*p2q1)-
44066  &272*a1*p2q2**2/(3*p1q2*p2q1)-
44067  &256*a1*a2*mb*mt*p2q2**2/(3*p1q2*p2q1)+
44068  &256*a1*a2*mt**2*p2q2**2/(3*p1q2*p2q1)+
44069  &512*a1*a2*p1p2*p2q2**2/(3*p1q2*p2q1)
44070  a18=a18+512*a1*a2*p1q1*p2q2**2/(3*p1q2*p2q1)-
44071  &384*a12*mb*mt*p1q1**2/s**2+
44072  &384*a12*p1p2*p1q1**2/s**2-2688*a12*mb*mt*p1q1*p1q2/s**2+
44073  &2688*a12*p1p2*p1q1*p1q2/s**2-384*a12*mb*mt*p1q2**2/s**2+
44074  &384*a12*p1p2*p1q2**2/s**2-768*a1*a2*mb*mt*p1q1*p2q1/s**2+
44075  &768*a1*a2*p1p2*p1q1*p2q1/s**2-2688*a1*a2*mb*mt*p1q2*p2q1/s**2+
44076  &2688*a1*a2*p1p2*p1q2*p2q1/s**2-960*a12*p1q1*p1q2*p2q1/s**2-
44077  &960*a1*a2*p1q1*p1q2*p2q1/s**2+960*a12*p1q2**2*p2q1/s**2+
44078  &960*a1*a2*p1q2**2*p2q1/s**2-384*a2**2*mb*mt*p2q1**2/s**2+
44079  &384*a2**2*p1p2*p2q1**2/s**2-960*a1*a2*p1q2*p2q1**2/s**2-
44080  &960*a2**2*p1q2*p2q1**2/s**2-2688*a1*a2*mb*mt*p1q1*p2q2/s**2+
44081  &2688*a1*a2*p1p2*p1q1*p2q2/s**2+960*a12*p1q1**2*p2q2/s**2+
44082  &960*a1*a2*p1q1**2*p2q2/s**2-768*a1*a2*mb*mt*p1q2*p2q2/s**2+
44083  &768*a1*a2*p1p2*p1q2*p2q2/s**2-960*a12*p1q1*p1q2*p2q2/s**2-
44084  &960*a1*a2*p1q1*p1q2*p2q2/s**2-2688*a2**2*mb*mt*p2q1*p2q2/s**2+
44085  &2688*a2**2*p1p2*p2q1*p2q2/s**2+960*a1*a2*p1q1*p2q1*p2q2/s**2+
44086  &960*a2**2*p1q1*p2q1*p2q2/s**2+960*a1*a2*p1q2*p2q1*p2q2/s**2
44087  a18=a18+960*a2**2*p1q2*p2q1*p2q2/s**2-
44088  &384*a2**2*mb*mt*p2q2**2/s**2+
44089  &384*a2**2*p1p2*p2q2**2/s**2-960*a1*a2*p1q1*p2q2**2/s**2-
44090  &960*a2**2*p1q1*p2q2**2/s**2-96*a1*mb*mt/s-96*a2*mb*mt/s+
44091  &768*a2**2*mb**3*mt/s+768*a12*mb*mt**3/s-192*a1*p1p2/s-
44092  &192*a2*p1p2/s-768*a2**2*mb**2*p1p2/s+2304*a1*a2*mb*mt*p1p2/s-
44093  &768*a12*mt**2*p1p2/s-2304*a1*a2*p1p2**2/s+
44094  &96*a1*mb*mt**3/(p1q1*s)+192*a2*mb*mt*p1p2/(p1q1*s)-
44095  &96*a1*mt**2*p1p2/(p1q1*s)-192*a2*p1p2**2/(p1q1*s)-192*a1*p1q1/s-
44096  &144*a2*p1q1/s-384*a1*a2*mb**2*p1q1/s-480*a2**2*mb**2*p1q1/s+
44097  &480*a12*mb*mt*p1q1/s-96*a1*a2*mb*mt*p1q1/s-
44098  &864*a12*p1p2*p1q1/s-672*a1*a2*p1p2*p1q1/s-96*a1*a2*p1q1**2/s+
44099  &96*a1*mb*mt**3/(p1q2*s)+192*a2*mb*mt*p1p2/(p1q2*s)-
44100  &96*a1*mt**2*p1p2/(p1q2*s)-192*a2*p1p2**2/(p1q2*s)+
44101  &48*a1*mb*mt*p1q1/(p1q2*s)-96*a2*mb*mt*p1q1/(p1q2*s)-
44102  &48*a1*mt**2*p1q1/(p1q2*s)-192*a1*p1p2*p1q1/(p1q2*s)-
44103  &192*a2*p1p2*p1q1/(p1q2*s)-192*a1*a2*mb*mt*p1p2*p1q1/(p1q2*s)
44104  a18=a18+192*a1*a2*p1p2**2*p1q1/(p1q2*s)-192*a1*p1q1**2/(p1q2*s)-
44105  &192*a2*p1q1**2/(p1q2*s)+192*a1*a2*mb**2*p1q1**2/(p1q2*s)+
44106  &192*a12*mb*mt*p1q1**2/(p1q2*s)-96*a1*a2*mb*mt*p1q1**2/(p1q2*s)+
44107  &192*a1*a2*p1p2*p1q1**2/(p1q2*s)-192*a1*p1q2/s-144*a2*p1q2/s-
44108  &384*a1*a2*mb**2*p1q2/s-480*a2**2*mb**2*p1q2/s+
44109  &480*a12*mb*mt*p1q2/s-96*a1*a2*mb*mt*p1q2/s-
44110  &864*a12*p1p2*p1q2/s-672*a1*a2*p1p2*p1q2/s+
44111  &48*a1*mb*mt*p1q2/(p1q1*s)-96*a2*mb*mt*p1q2/(p1q1*s)-
44112  &48*a1*mt**2*p1q2/(p1q1*s)-192*a1*p1p2*p1q2/(p1q1*s)-
44113  &192*a2*p1p2*p1q2/(p1q1*s)-192*a1*a2*mb*mt*p1p2*p1q2/(p1q1*s)+
44114  &192*a1*a2*p1p2**2*p1q2/(p1q1*s)-576*a1*a2*p1q1*p1q2/s-
44115  &96*a1*a2*p1q2**2/s-192*a1*p1q2**2/(p1q1*s)-
44116  &192*a2*p1q2**2/(p1q1*s)+192*a1*a2*mb**2*p1q2**2/(p1q1*s)+
44117  &192*a12*mb*mt*p1q2**2/(p1q1*s)-96*a1*a2*mb*mt*p1q2**2/(p1q1*s)+
44118  &192*a1*a2*p1p2*p1q2**2/(p1q1*s)-96*a2*mb**3*mt/(p2q1*s)+
44119  &96*a2*mb**2*p1p2/(p2q1*s)-192*a1*mb*mt*p1p2/(p2q1*s)+
44120  &192*a1*p1p2**2/(p2q1*s)+96*a1*mb**2*p1q1/(p2q1*s)
44121  a18=a18+192*a2*mb**2*p1q1/(p2q1*s)-96*a1*mb*mt*p1q1/(p2q1*s)-
44122  &192*a1*a2*mb**3*mt*p1q1/(p2q1*s)+192*a1*p1p2*p1q1/(p2q1*s)+
44123  &192*a1*a2*mb**2*p1p2*p1q1/(p2q1*s)+
44124  &96*a1*a2*mb**2*p1q1**2/(p2q1*s)-
44125  &192*a2*mb**3*mt*p1q1/(p1q2*p2q1*s)+
44126  &192*a2*mb**2*p1p2*p1q1/(p1q2*p2q1*s)-
44127  &96*a1*mb*mt*p1p2*p1q1/(p1q2*p2q1*s)+
44128  &96*a1*p1p2**2*p1q1/(p1q2*p2q1*s)+
44129  &96*a1*mb**2*p1q1**2/(p1q2*p2q1*s)+
44130  &192*a2*mb**2*p1q1**2/(p1q2*p2q1*s)-
44131  &48*a1*mb*mt*p1q1**2/(p1q2*p2q1*s)+
44132  &96*a1*p1p2*p1q1**2/(p1q2*p2q1*s)+96*a1*mb**2*p1q2/(p2q1*s)+
44133  &48*a2*mb**2*p1q2/(p2q1*s)+192*a1*a2*mb**3*mt*p1q2/(p2q1*s)-
44134  &192*a1*a2*mb**2*p1p2*p1q2/(p2q1*s)-
44135  &96*a1*a2*mb**2*p1q2**2/(p2q1*s)+144*a1*p2q1/s+192*a2*p2q1/s+
44136  &96*a1*a2*mb*mt*p2q1/s-480*a2**2*mb*mt*p2q1/s+
44137  &480*a12*mt**2*p2q1/s+384*a1*a2*mt**2*p2q1/s
44138  a18=a18+672*a1*a2*p1p2*p2q1/s+864*a2**2*p1p2*p2q1/s-
44139  &96*a2*mb*mt*p2q1/(p1q1*s)+192*a1*mt**2*p2q1/(p1q1*s)+
44140  &96*a2*mt**2*p2q1/(p1q1*s)-192*a1*a2*mb*mt**3*p2q1/(p1q1*s)+
44141  &192*a2*p1p2*p2q1/(p1q1*s)+192*a1*a2*mt**2*p1p2*p2q1/(p1q1*s)-
44142  &192*a12*p1q1*p2q1/s-192*a2**2*p1q1*p2q1/s+
44143  &48*a1*mt**2*p2q1/(p1q2*s)+96*a2*mt**2*p2q1/(p1q2*s)+
44144  &192*a1*a2*mb*mt**3*p2q1/(p1q2*s)-
44145  &192*a1*a2*mt**2*p1p2*p2q1/(p1q2*s)+
44146  &96*a1*a2*mb*mt*p1q1*p2q1/(p1q2*s)-
44147  &192*a12*mt**2*p1q1*p2q1/(p1q2*s)-
44148  &96*a1*a2*mt**2*p1q1*p2q1/(p1q2*s)-
44149  &384*a1*a2*p1p2*p1q1*p2q1/(p1q2*s)-384*a12*p1q1**2*p2q1/(p1q2*s)-
44150  &384*a1*a2*p1q1**2*p2q1/(p1q2*s)-480*a12*p1q2*p2q1/s-
44151  &960*a1*a2*p1q2*p2q1/s-480*a2**2*p1q2*p2q1/s+
44152  &144*a1*p1q2*p2q1/(p1q1*s)+96*a2*p1q2*p2q1/(p1q1*s)+
44153  &384*a1*a2*mb*mt*p1q2*p2q1/(p1q1*s)-
44154  &96*a12*mt**2*p1q2*p2q1/(p1q1*s)
44155  a18=a18+96*a1*a2*mt**2*p1q2*p2q1/(p1q1*s)-
44156  &576*a1*a2*p1p2*p1q2*p2q1/(p1q1*s)-192*a12*p1q2**2*p2q1/(p1q1*s)-
44157  &384*a1*a2*p1q2**2*p2q1/(p1q1*s)-96*a1*a2*p2q1**2/s-
44158  &96*a1*a2*mt**2*p2q1**2/(p1q1*s)+96*a1*a2*mt**2*p2q1**2/(p1q2*s)+
44159  &288*a1*a2*p1q2*p2q1**2/(p1q1*s)-96*a2*mb**3*mt/(p2q2*s)+
44160  &96*a2*mb**2*p1p2/(p2q2*s)-192*a1*mb*mt*p1p2/(p2q2*s)+
44161  &192*a1*p1p2**2/(p2q2*s)+96*a1*mb**2*p1q1/(p2q2*s)+
44162  &48*a2*mb**2*p1q1/(p2q2*s)+192*a1*a2*mb**3*mt*p1q1/(p2q2*s)-
44163  &192*a1*a2*mb**2*p1p2*p1q1/(p2q2*s)-
44164  &96*a1*a2*mb**2*p1q1**2/(p2q2*s)+96*a1*mb**2*p1q2/(p2q2*s)+
44165  &192*a2*mb**2*p1q2/(p2q2*s)-96*a1*mb*mt*p1q2/(p2q2*s)-
44166  &192*a1*a2*mb**3*mt*p1q2/(p2q2*s)+192*a1*p1p2*p1q2/(p2q2*s)+
44167  &192*a1*a2*mb**2*p1p2*p1q2/(p2q2*s)-
44168  &192*a2*mb**3*mt*p1q2/(p1q1*p2q2*s)+
44169  &192*a2*mb**2*p1p2*p1q2/(p1q1*p2q2*s)-
44170  &96*a1*mb*mt*p1p2*p1q2/(p1q1*p2q2*s)+
44171  &96*a1*p1p2**2*p1q2/(p1q1*p2q2*s)+96*a1*a2*mb**2*p1q2**2/(p2q2*s)
44172  a18=a18+96*a1*mb**2*p1q2**2/(p1q1*p2q2*s)+
44173  &192*a2*mb**2*p1q2**2/(p1q1*p2q2*s)-
44174  &48*a1*mb*mt*p1q2**2/(p1q1*p2q2*s)+
44175  &96*a1*p1p2*p1q2**2/(p1q1*p2q2*s)-48*a2*mb**2*p2q1/(p2q2*s)-
44176  &96*a1*mb*mt*p2q1/(p2q2*s)+48*a2*mb*mt*p2q1/(p2q2*s)-
44177  &192*a1*p1p2*p2q1/(p2q2*s)-192*a2*p1p2*p2q1/(p2q2*s)-
44178  &192*a1*a2*mb*mt*p1p2*p2q1/(p2q2*s)+
44179  &192*a1*a2*p1p2**2*p2q1/(p2q2*s)+
44180  &192*a1*mb*mt**3*p2q1/(p1q1*p2q2*s)+
44181  &96*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2*s)-
44182  &192*a1*mt**2*p1p2*p2q1/(p1q1*p2q2*s)-
44183  &96*a2*p1p2**2*p2q1/(p1q1*p2q2*s)+
44184  &96*a1*a2*mb**2*p1q1*p2q1/(p2q2*s)+
44185  &192*a2**2*mb**2*p1q1*p2q1/(p2q2*s)-
44186  &96*a1*a2*mb*mt*p1q1*p2q1/(p2q2*s)+
44187  &384*a1*a2*p1p2*p1q1*p2q1/(p2q2*s)-96*a1*p1q2*p2q1/(p2q2*s)-
44188  &144*a2*p1q2*p2q1/(p2q2*s)-96*a1*a2*mb**2*p1q2*p2q1/(p2q2*s)
44189  a18=a18+96*a2**2*mb**2*p1q2*p2q1/(p2q2*s)-
44190  &384*a1*a2*mb*mt*p1q2*p2q1/(p2q2*s)+
44191  &576*a1*a2*p1p2*p1q2*p2q1/(p2q2*s)-
44192  &96*a2*mb**2*p1q2*p2q1/(p1q1*p2q2*s)-
44193  &48*a1*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
44194  &48*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
44195  &96*a1*mt**2*p1q2*p2q1/(p1q1*p2q2*s)-
44196  &96*a1*p1p2*p1q2*p2q1/(p1q1*p2q2*s)-
44197  &96*a2*p1p2*p1q2*p2q1/(p1q1*p2q2*s)+
44198  &96*a1*a2*p1q1*p1q2*p2q1/(p2q2*s)+288*a1*a2*p1q2**2*p2q1/(p2q2*s)-
44199  &96*a1*p1q2**2*p2q1/(p1q1*p2q2*s)-96*a2*p1q2**2*p2q1/(p1q1*p2q2*s)+
44200  &192*a1*p2q1**2/(p2q2*s)+192*a2*p2q1**2/(p2q2*s)+
44201  &96*a1*a2*mb*mt*p2q1**2/(p2q2*s)-192*a2**2*mb*mt*p2q1**2/(p2q2*s)-
44202  &192*a1*a2*mt**2*p2q1**2/(p2q2*s)-192*a1*a2*p1p2*p2q1**2/(p2q2*s)-
44203  &48*a2*mb*mt*p2q1**2/(p1q1*p2q2*s)+
44204  &192*a1*mt**2*p2q1**2/(p1q1*p2q2*s)+
44205  &96*a2*mt**2*p2q1**2/(p1q1*p2q2*s)
44206  a18=a18+96*a2*p1p2*p2q1**2/(p1q1*p2q2*s)-
44207  &384*a1*a2*p1q1*p2q1**2/(p2q2*s)-
44208  &384*a2**2*p1q1*p2q1**2/(p2q2*s)-384*a1*a2*p1q2*p2q1**2/(p2q2*s)-
44209  &192*a2**2*p1q2*p2q1**2/(p2q2*s)+96*a1*p1q2*p2q1**2/(p1q1*p2q2*s)+
44210  &96*a2*p1q2*p2q1**2/(p1q1*p2q2*s)+144*a1*p2q2/s+192*a2*p2q2/s+
44211  &96*a1*a2*mb*mt*p2q2/s-480*a2**2*mb*mt*p2q2/s+
44212  &480*a12*mt**2*p2q2/s+384*a1*a2*mt**2*p2q2/s+
44213  &672*a1*a2*p1p2*p2q2/s+864*a2**2*p1p2*p2q2/s+
44214  &48*a1*mt**2*p2q2/(p1q1*s)+96*a2*mt**2*p2q2/(p1q1*s)+
44215  &192*a1*a2*mb*mt**3*p2q2/(p1q1*s)-
44216  &192*a1*a2*mt**2*p1p2*p2q2/(p1q1*s)-480*a12*p1q1*p2q2/s-
44217  &960*a1*a2*p1q1*p2q2/s-480*a2**2*p1q1*p2q2/s-
44218  &96*a2*mb*mt*p2q2/(p1q2*s)+192*a1*mt**2*p2q2/(p1q2*s)+
44219  &96*a2*mt**2*p2q2/(p1q2*s)-192*a1*a2*mb*mt**3*p2q2/(p1q2*s)+
44220  &192*a2*p1p2*p2q2/(p1q2*s)+192*a1*a2*mt**2*p1p2*p2q2/(p1q2*s)+
44221  &144*a1*p1q1*p2q2/(p1q2*s)+96*a2*p1q1*p2q2/(p1q2*s)+
44222  &384*a1*a2*mb*mt*p1q1*p2q2/(p1q2*s)
44223  a18=a18-96*a12*mt**2*p1q1*p2q2/(p1q2*s)+
44224  &96*a1*a2*mt**2*p1q1*p2q2/(p1q2*s)-
44225  &576*a1*a2*p1p2*p1q1*p2q2/(p1q2*s)-192*a12*p1q1**2*p2q2/(p1q2*s)-
44226  &384*a1*a2*p1q1**2*p2q2/(p1q2*s)-192*a12*p1q2*p2q2/s-
44227  &192*a2**2*p1q2*p2q2/s+96*a1*a2*mb*mt*p1q2*p2q2/(p1q1*s)-
44228  &192*a12*mt**2*p1q2*p2q2/(p1q1*s)-
44229  &96*a1*a2*mt**2*p1q2*p2q2/(p1q1*s)-
44230  &384*a1*a2*p1p2*p1q2*p2q2/(p1q1*s)-384*a12*p1q2**2*p2q2/(p1q1*s)-
44231  &384*a1*a2*p1q2**2*p2q2/(p1q1*s)-48*a2*mb**2*p2q2/(p2q1*s)-
44232  &96*a1*mb*mt*p2q2/(p2q1*s)+48*a2*mb*mt*p2q2/(p2q1*s)-
44233  &192*a1*p1p2*p2q2/(p2q1*s)-192*a2*p1p2*p2q2/(p2q1*s)-
44234  &192*a1*a2*mb*mt*p1p2*p2q2/(p2q1*s)+
44235  &192*a1*a2*p1p2**2*p2q2/(p2q1*s)-96*a1*p1q1*p2q2/(p2q1*s)-
44236  &144*a2*p1q1*p2q2/(p2q1*s)-96*a1*a2*mb**2*p1q1*p2q2/(p2q1*s)+
44237  &96*a2**2*mb**2*p1q1*p2q2/(p2q1*s)-
44238  &384*a1*a2*mb*mt*p1q1*p2q2/(p2q1*s)+
44239  &576*a1*a2*p1p2*p1q1*p2q2/(p2q1*s)+288*a1*a2*p1q1**2*p2q2/(p2q1*s)
44240  a18=a18+192*a1*mb*mt**3*p2q2/(p1q2*p2q1*s)+
44241  &96*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1*s)-
44242  &192*a1*mt**2*p1p2*p2q2/(p1q2*p2q1*s)-
44243  &96*a2*p1p2**2*p2q2/(p1q2*p2q1*s)-
44244  &96*a2*mb**2*p1q1*p2q2/(p1q2*p2q1*s)-
44245  &48*a1*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
44246  &48*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
44247  &96*a1*mt**2*p1q1*p2q2/(p1q2*p2q1*s)-
44248  &96*a1*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
44249  &96*a2*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
44250  &96*a1*p1q1**2*p2q2/(p1q2*p2q1*s)-96*a2*p1q1**2*p2q2/(p1q2*p2q1*s)+
44251  &96*a1*a2*mb**2*p1q2*p2q2/(p2q1*s)+
44252  &192*a2**2*mb**2*p1q2*p2q2/(p2q1*s)-
44253  &96*a1*a2*mb*mt*p1q2*p2q2/(p2q1*s)+
44254  &384*a1*a2*p1p2*p1q2*p2q2/(p2q1*s)+
44255  &96*a1*a2*p1q1*p1q2*p2q2/(p2q1*s)-576*a1*a2*p2q1*p2q2/s+
44256  &96*a1*a2*p1q1*p2q1*p2q2/(p1q2*s)+96*a1*a2*p1q2*p2q1*p2q2/(p1q1*s)
44257  a18=a18-96*a1*a2*p2q2**2/s+96*a1*a2*mt**2*p2q2**2/(p1q1*s)-
44258  &96*a1*a2*mt**2*p2q2**2/(p1q2*s)+288*a1*a2*p1q1*p2q2**2/(p1q2*s)+
44259  &192*a1*p2q2**2/(p2q1*s)+192*a2*p2q2**2/(p2q1*s)+
44260  &96*a1*a2*mb*mt*p2q2**2/(p2q1*s)-192*a2**2*mb*mt*p2q2**2/(p2q1*s)-
44261  &192*a1*a2*mt**2*p2q2**2/(p2q1*s)-192*a1*a2*p1p2*p2q2**2/(p2q1*s)-
44262  &384*a1*a2*p1q1*p2q2**2/(p2q1*s)-192*a2**2*p1q1*p2q2**2/(p2q1*s)-
44263  &48*a2*mb*mt*p2q2**2/(p1q2*p2q1*s)+
44264  &192*a1*mt**2*p2q2**2/(p1q2*p2q1*s)+
44265  &96*a2*mt**2*p2q2**2/(p1q2*p2q1*s)+
44266  &96*a2*p1p2*p2q2**2/(p1q2*p2q1*s)+96*a1*p1q1*p2q2**2/(p1q2*p2q1*s)+
44267  &96*a2*p1q1*p2q2**2/(p1q2*p2q1*s)-384*a1*a2*p1q2*p2q2**2/(p2q1*s)-
44268  &384*a2**2*p1q2*p2q2**2/(p2q1*s)+512*a1*a2*s/3-
44269  &128*a1*mt**2*s/(3*p1q1**2)+128*a12*mb*mt**3*s/(3*p1q1**2)-
44270  &152*a1*s/(3*p1q1)-152*a12*mb*mt*s/(3*p1q1)-
44271  &128*a1*a2*mb*mt*s/(3*p1q1)+112*a1*a2*mt**2*s/(3*p1q1)-
44272  &16*a12*p1p2*s/p1q1+152*a1*a2*p1p2*s/(3*p1q1)-
44273  &128*a1*mt**2*s/(3*p1q2**2)+128*a12*mb*mt**3*s/(3*p1q2**2)
44274  a18=a18-152*a1*s/(3*p1q2)-152*a12*mb*mt*s/(3*p1q2)-
44275  &128*a1*a2*mb*mt*s/(3*p1q2)+112*a1*a2*mt**2*s/(3*p1q2)-
44276  &16*a12*p1p2*s/p1q2+152*a1*a2*p1p2*s/(3*p1q2)+
44277  &16*a1*mb*mt*s/(3*p1q1*p1q2)-32*a12*mb*mt**3*s/(3*p1q1*p1q2)-
44278  &16*a1*p1p2*s/(3*p1q1*p1q2)+272*a1*a2*p1q1*s/(3*p1q2)+
44279  &272*a1*a2*p1q2*s/(3*p1q1)-128*a2*mb**2*s/(3*p2q1**2)+
44280  &128*a2**2*mb**3*mt*s/(3*p2q1**2)+
44281  &32*mb**2*mt**2*s/(3*p1q2**2*p2q1**2)+32*mb**2*s/(3*p1q2*p2q1**2)
44282 
44283  a18bis=
44284  &64*a2*mb**3*mt*s/(3*p1q2*p2q1**2)-
44285  &64*a2*mb**2*mt**2*s/(3*p1q2*p2q1**2)-
44286  &128*a2*mb**2*p1p2*s/(3*p1q2*p2q1**2)-
44287  &128*a2*mb**2*p1q1*s/(3*p1q2*p2q1**2)+
44288  &128*a2**2*mb**2*p1q2*s/(3*p2q1**2)+152*a2*s/(3*p2q1)-
44289  &112*a1*a2*mb**2*s/(3*p2q1)+128*a1*a2*mb*mt*s/(3*p2q1)+
44290  &152*a2**2*mb*mt*s/(3*p2q1)-152*a1*a2*p1p2*s/(3*p2q1)+
44291  &16*a2**2*p1p2*s/p2q1-8*a1*a2*mb**3*mt*s/(3*p1q1*p2q1)+
44292  &16*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q1)-
44293  &8*a1*a2*mb*mt**3*s/(3*p1q1*p2q1)-8*a1*p1p2*s/(3*p1q1*p2q1)-
44294  &8*a2*p1p2*s/(3*p1q1*p2q1)+8*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q1)-
44295  &16*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q1)+
44296  &8*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q1)+
44297  &32*a1*a2*p1p2**2*s/(3*p1q1*p2q1)-32*a2**2*p1q1*s/(3*p2q1)-
44298  &32*mt**2*s/(3*p1q2**2*p2q1)+64*a1*mb**2*mt**2*s/(3*p1q2**2*p2q1)-
44299  &64*a1*mb*mt**3*s/(3*p1q2**2*p2q1)
44300  a18bis=a18bis+128*a1*mt**2*p1p2*s/(3*p1q2**2*p2q1)-
44301  &12*s/(p1q2*p2q1)+
44302  &24*a1*mb**2*s/(p1q2*p2q1)+64*a1*a2*mb**3*mt*s/(3*p1q2*p2q1)+
44303  &24*a2*mt**2*s/(p1q2*p2q1)-128*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q1)+
44304  &64*a1*a2*mb*mt**3*s/(3*p1q2*p2q1)+56*a1*p1p2*s/(3*p1q2*p2q1)+
44305  &56*a2*p1p2*s/(3*p1q2*p2q1)-64*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q1)+
44306  &128*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q1)-
44307  &64*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q1)-
44308  &256*a1*a2*p1p2**2*s/(3*p1q2*p2q1)+4*p1p2*s/(3*p1q1*p1q2*p2q1)-
44309  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1)-
44310  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1)+136*a2*p1q1*s/(3*p1q2*p2q1)-
44311  &128*a1*a2*mb**2*p1q1*s/(3*p1q2*p2q1)+
44312  &128*a1*a2*mb*mt*p1q1*s/(3*p1q2*p2q1)-
44313  &256*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q1)-160*a2**2*p1q2*s/(3*p2q1)+
44314  &16*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q1)-32*a12*p2q1*s/(3*p1q1)-
44315  &128*a12*mt**2*p2q1*s/(3*p1q2**2)-160*a12*p2q1*s/(3*p1q2)-
44316  &128*a2*mb**2*s/(3*p2q2**2)+128*a2**2*mb**3*mt*s/(3*p2q2**2)
44317  a18bis=a18bis+32*mb**2*mt**2*s/(3*p1q1**2*p2q2**2)+
44318  &32*mb**2*s/(3*p1q1*p2q2**2)+
44319  &64*a2*mb**3*mt*s/(3*p1q1*p2q2**2)-
44320  &64*a2*mb**2*mt**2*s/(3*p1q1*p2q2**2)-
44321  &128*a2*mb**2*p1p2*s/(3*p1q1*p2q2**2)+
44322  &128*a2**2*mb**2*p1q1*s/(3*p2q2**2)-
44323  &128*a2*mb**2*p1q2*s/(3*p1q1*p2q2**2)+152*a2*s/(3*p2q2)-
44324  &112*a1*a2*mb**2*s/(3*p2q2)+128*a1*a2*mb*mt*s/(3*p2q2)+
44325  &152*a2**2*mb*mt*s/(3*p2q2)-152*a1*a2*p1p2*s/(3*p2q2)+
44326  &16*a2**2*p1p2*s/p2q2-32*mt**2*s/(3*p1q1**2*p2q2)+
44327  &64*a1*mb**2*mt**2*s/(3*p1q1**2*p2q2)-
44328  &64*a1*mb*mt**3*s/(3*p1q1**2*p2q2)+
44329  &128*a1*mt**2*p1p2*s/(3*p1q1**2*p2q2)-12*s/(p1q1*p2q2)+
44330  &24*a1*mb**2*s/(p1q1*p2q2)+64*a1*a2*mb**3*mt*s/(3*p1q1*p2q2)+
44331  &24*a2*mt**2*s/(p1q1*p2q2)-128*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q2)+
44332  &64*a1*a2*mb*mt**3*s/(3*p1q1*p2q2)+56*a1*p1p2*s/(3*p1q1*p2q2)+
44333  &56*a2*p1p2*s/(3*p1q1*p2q2)-64*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q2)
44334  a18bis=a18bis+128*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q2)-
44335  &64*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q2)-
44336  &256*a1*a2*p1p2**2*s/(3*p1q1*p2q2)-160*a2**2*p1q1*s/(3*p2q2)-
44337  &8*a1*a2*mb**3*mt*s/(3*p1q2*p2q2)+
44338  &16*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q2)-
44339  &8*a1*a2*mb*mt**3*s/(3*p1q2*p2q2)-8*a1*p1p2*s/(3*p1q2*p2q2)-
44340  &8*a2*p1p2*s/(3*p1q2*p2q2)+8*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q2)-
44341  &16*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q2)+
44342  &8*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q2)+
44343  &32*a1*a2*p1p2**2*s/(3*p1q2*p2q2)+4*p1p2*s/(3*p1q1*p1q2*p2q2)-
44344  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q2)-
44345  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q2)+
44346  &16*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q2)-32*a2**2*p1q2*s/(3*p2q2)+
44347  &136*a2*p1q2*s/(3*p1q1*p2q2)-128*a1*a2*mb**2*p1q2*s/(3*p1q1*p2q2)+
44348  &128*a1*a2*mb*mt*p1q2*s/(3*p1q1*p2q2)-
44349  &256*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q2)+16*a2*mb*mt*s/(3*p2q1*p2q2)-
44350  &32*a2**2*mb**3*mt*s/(3*p2q1*p2q2)-16*a2*p1p2*s/(3*p2q1*p2q2)
44351  a18bis=a18bis-4*p1p2*s/(3*p1q1*p2q1*p2q2)+
44352  &8*a2*mb**2*p1p2*s/(3*p1q1*p2q1*p2q2)+
44353  &8*a2*mb*mt*p1p2*s/(3*p1q1*p2q1*p2q2)-4*p1p2*s/(3*p1q2*p2q1*p2q2)+
44354  &8*a2*mb**2*p1p2*s/(3*p1q2*p2q1*p2q2)+
44355  &8*a2*mb*mt*p1p2*s/(3*p1q2*p2q1*p2q2)-
44356  &2*mb**3*mt*s/(3*p1q1*p1q2*p2q1*p2q2)+
44357  &4*mb**2*mt**2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44358  &2*mb*mt**3*s/(3*p1q1*p1q2*p2q1*p2q2)-
44359  &2*mb**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)+
44360  &4*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44361  &2*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44362  &8*p1p2**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
44363  &8*a2*p1p2*p1q1*s/(3*p1q2*p2q1*p2q2)+
44364  &8*a2*p1p2*p1q2*s/(3*p1q1*p2q1*p2q2)+272*a1*a2*p2q1*s/(3*p2q2)-
44365  &128*a1*mt**2*p2q1*s/(3*p1q1**2*p2q2)-136*a1*p2q1*s/(3*p1q1*p2q2)-
44366  &128*a1*a2*mb*mt*p2q1*s/(3*p1q1*p2q2)+
44367  &128*a1*a2*mt**2*p2q1*s/(3*p1q1*p2q2)
44368  a18bis=a18bis+256*a1*a2*p1p2*p2q1*s/(3*p1q1*p2q2)-
44369  &16*a1*a2*p1p2*p2q1*s/(3*p1q2*p2q2)+
44370  &8*a1*p1p2*p2q1*s/(3*p1q1*p1q2*p2q2)+
44371  &256*a1*a2*p1q2*p2q1*s/(3*p1q1*p2q2)-
44372  &128*a12*mt**2*p2q2*s/(3*p1q1**2)-160*a12*p2q2*s/(3*p1q1)-
44373  &32*a12*p2q2*s/(3*p1q2)+272*a1*a2*p2q2*s/(3*p2q1)-
44374  &16*a1*a2*p1p2*p2q2*s/(3*p1q1*p2q1)-
44375  &128*a1*mt**2*p2q2*s/(3*p1q2**2*p2q1)-136*a1*p2q2*s/(3*p1q2*p2q1)-
44376  &128*a1*a2*mb*mt*p2q2*s/(3*p1q2*p2q1)+
44377  &128*a1*a2*mt**2*p2q2*s/(3*p1q2*p2q1)+
44378  &256*a1*a2*p1p2*p2q2*s/(3*p1q2*p2q1)+
44379  &8*a1*p1p2*p2q2*s/(3*p1q1*p1q2*p2q1)+
44380  &256*a1*a2*p1q1*p2q2*s/(3*p1q2*p2q1)-
44381  &8*a12*mb*mt*s**2/(3*p1q1*p1q2)+16*a12*p1p2*s**2/(3*p1q1*p1q2)-
44382  &8*a1*a2*p1p2*s**2/(3*p1q1*p2q1)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q1)-
44383  &8*a1*a2*p1p2*s**2/(3*p1q2*p2q2)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q2)-
44384  &8*a2**2*mb*mt*s**2/(3*p2q1*p2q2)+16*a2**2*p1p2*s**2/(3*p2q1*p2q2)
44385  a18bis=a18bis-4*a2*p1p2*s**2/(3*p1q1*p2q1*p2q2)-
44386  &4*a2*p1p2*s**2/(3*p1q2*p2q1*p2q2)+
44387  &2*p1p2*s**2/(3*p1q1*p1q2*p2q1*p2q2)
44388 C
44389  v18=v18+v18bis
44390  a18=a18+a18bis
44391  v910 =-48*a12*mb*mt-48*a2**2*mb*mt-48*a12*p1p2-48*a2**2*p1p2-
44392  &384*a12*mb*mt*p1q1*p1q2/s**2-384*a12*p1p2*p1q1*p1q2/s**2-
44393  &384*a1*a2*mb*mt*p1q2*p2q1/s**2-384*a1*a2*p1p2*p1q2*p2q1/s**2+
44394  &192*a12*p1q1*p1q2*p2q1/s**2+192*a1*a2*p1q1*p1q2*p2q1/s**2-
44395  &192*a12*p1q2**2*p2q1/s**2-192*a1*a2*p1q2**2*p2q1/s**2+
44396  &192*a1*a2*p1q2*p2q1**2/s**2+192*a2**2*p1q2*p2q1**2/s**2-
44397  &384*a1*a2*mb*mt*p1q1*p2q2/s**2-384*a1*a2*p1p2*p1q1*p2q2/s**2-
44398  &192*a12*p1q1**2*p2q2/s**2-192*a1*a2*p1q1**2*p2q2/s**2+
44399  &192*a12*p1q1*p1q2*p2q2/s**2+192*a1*a2*p1q1*p1q2*p2q2/s**2-
44400  &384*a2**2*mb*mt*p2q1*p2q2/s**2-384*a2**2*p1p2*p2q1*p2q2/s**2-
44401  &192*a1*a2*p1q1*p2q1*p2q2/s**2-192*a2**2*p1q1*p2q1*p2q2/s**2-
44402  &192*a1*a2*p1q2*p2q1*p2q2/s**2-192*a2**2*p1q2*p2q1*p2q2/s**2+
44403  &192*a1*a2*p1q1*p2q2**2/s**2+192*a2**2*p1q1*p2q2**2/s**2+
44404  &96*a12*mb*mt*p1q1/s-96*a1*a2*mb*mt*p1q1/s+
44405  &96*a12*p1p2*p1q1/s-96*a1*a2*p1p2*p1q1/s+96*a12*mb*mt*p1q2/s-
44406  &96*a1*a2*mb*mt*p1q2/s+96*a12*p1p2*p1q2/s-96*a1*a2*p1p2*p1q2/s+
44407  &96*a1*a2*mb*mt*p2q1/s-96*a2**2*mb*mt*p2q1/s
44408  v910=v910+96*a1*a2*p1p2*p2q1/s-
44409  &96*a2**2*p1p2*p2q1/s+96*a12*p1q2*p2q1/s+
44410  &192*a1*a2*p1q2*p2q1/s+96*a2**2*p1q2*p2q1/s+
44411  &96*a1*a2*mb*mt*p2q2/s-96*a2**2*mb*mt*p2q2/s+
44412  &96*a1*a2*p1p2*p2q2/s-96*a2**2*p1p2*p2q2/s+96*a12*p1q1*p2q2/s+
44413  &192*a1*a2*p1q1*p2q2/s+96*a2**2*p1q1*p2q2/s
44414 C
44415  a910 = 48*a12*mb*mt+48*a2**2*mb*mt-48*a12*p1p2-48*a2**2*p1p2+
44416  &384*a12*mb*mt*p1q1*p1q2/s**2-384*a12*p1p2*p1q1*p1q2/s**2+
44417  &384*a1*a2*mb*mt*p1q2*p2q1/s**2-384*a1*a2*p1p2*p1q2*p2q1/s**2+
44418  &192*a12*p1q1*p1q2*p2q1/s**2+192*a1*a2*p1q1*p1q2*p2q1/s**2-
44419  &192*a12*p1q2**2*p2q1/s**2-192*a1*a2*p1q2**2*p2q1/s**2+
44420  &192*a1*a2*p1q2*p2q1**2/s**2+192*a2**2*p1q2*p2q1**2/s**2+
44421  &384*a1*a2*mb*mt*p1q1*p2q2/s**2-384*a1*a2*p1p2*p1q1*p2q2/s**2-
44422  &192*a12*p1q1**2*p2q2/s**2-192*a1*a2*p1q1**2*p2q2/s**2+
44423  &192*a12*p1q1*p1q2*p2q2/s**2+192*a1*a2*p1q1*p1q2*p2q2/s**2+
44424  &384*a2**2*mb*mt*p2q1*p2q2/s**2-384*a2**2*p1p2*p2q1*p2q2/s**2-
44425  &192*a1*a2*p1q1*p2q1*p2q2/s**2-192*a2**2*p1q1*p2q1*p2q2/s**2-
44426  &192*a1*a2*p1q2*p2q1*p2q2/s**2-192*a2**2*p1q2*p2q1*p2q2/s**2+
44427  &192*a1*a2*p1q1*p2q2**2/s**2+192*a2**2*p1q1*p2q2**2/s**2-
44428  &96*a12*mb*mt*p1q1/s+96*a1*a2*mb*mt*p1q1/s+
44429  &96*a12*p1p2*p1q1/s-96*a1*a2*p1p2*p1q1/s-96*a12*mb*mt*p1q2/s+
44430  &96*a1*a2*mb*mt*p1q2/s+96*a12*p1p2*p1q2/s-96*a1*a2*p1p2*p1q2/s-
44431  &96*a1*a2*mb*mt*p2q1/s+96*a2**2*mb*mt*p2q1/s
44432  a910=a910+96*a1*a2*p1p2*p2q1/s-
44433  &96*a2**2*p1p2*p2q1/s+96*a12*p1q2*p2q1/s+
44434  &192*a1*a2*p1q2*p2q1/s+96*a2**2*p1q2*p2q1/s-
44435  &96*a1*a2*mb*mt*p2q2/s+96*a2**2*mb*mt*p2q2/s+
44436  &96*a1*a2*p1p2*p2q2/s-96*a2**2*p1p2*p2q2/s+96*a12*p1q1*p2q2/s+
44437  &192*a1*a2*p1q1*p2q2/s+96*a2**2*p1q1*p2q2/s
44438 C
44439 C FINAL RESULT;
44440 C
44441  amp2= fact*ps*vtb**2*(v**2 *(v18 +v910)+a**2 *(a18+a910) )
44442 
44443  END
44444 C---------------------------------------------------------
44445 C 2) Q QBAR ->TBH^+
44446  SUBROUTINE pytbhq(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44447 C
44448 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44449 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44450  IMPLICIT DOUBLE PRECISION(a-h, o-z)
44451  IMPLICIT INTEGER(I-N)
44452  DOUBLE PRECISION MW2,MT,MB,MHP,MW
44453  dimension q1(4),q2(4),p1(4),p2(4),p3(4)
44454  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
44455  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
44456  common/pymssm/imss(0:99),rmss(0:99)
44457  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
44458  SAVE /pydat1/,/pydat2/,/pymssm/,/pyctbh/
44459 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44460 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44461 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44462 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44463 C
44464 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44465 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44466 C
44467  dimension yy(2,2)
44468 
44469  pi = 4*datan(1.d0)
44470  mw = dsqrt(mw2)
44471 
44472 C COLLECTING THE RELEVANT OVERALL FACTORS:
44473 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44474  ps=1.d0/(3.d0*3.d0 *2.d0*2.d0)
44475 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44476  fact=(4.d0*pi*alpha)*(4.d0*pi*alphas)**2/sw2/2.d0
44477 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44478 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44479 C ALPHAS IS ALPHA_STRONG;
44480 C SW2 IS SIN(THETA_W)**2.
44481 C
44482 C VTB=.998D0
44483 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44484 C
44485  v = ( mt/mw/tanb +rmb/mw*tanb)/2.d0
44486  a = (-mt/mw/tanb +rmb/mw*tanb)/2.d0
44487 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44488 C
44489 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44490 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44491  DO 100 kk=1,4
44492  p2(kk)=p3(kk)-q1(kk)-q2(kk)+p1(kk)
44493  100 CONTINUE
44494 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44495  s = 2*pytbhs(q1,q2)
44496  p1q1=pytbhs(q1,p1)
44497  p1q2=pytbhs(p1,q2)
44498  p2q1=pytbhs(p2,q1)
44499  p2q2=pytbhs(p2,q2)
44500  p1p2=pytbhs(p1,p2)
44501 C
44502 C TOP WIDTH CALCULATION
44503  CALL pytbhb(mt,mb,mhp,br,gamt)
44504 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44505 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44506  a1inv= s -2*p1q1 -2*p1q2
44507  a1 =a1inv/(a1inv**2+ (gamt*mt)**2)
44508 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44509 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44510  a12 = 1.d0/(a1inv**2+ (gamt*mt)**2)
44511  a2 =1.d0/(s +2*p2q1 +2*p2q2)
44512 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44513 C NOW COMES THE AMP**2:
44514 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44515 C THE EXPRESSIONS BELOW
44516  yy(1, 1) = -16*a**2*a2**2*mb*mt+
44517  &64*a**2*a2**2*p1q2*p2q1**2/s**2+
44518  &128*a**2*a2**2*mb*mt*p2q1*p2q2/s**2-
44519  &128*a**2*a2**2*p1p2*p2q1*p2q2/s**2-
44520  &64*a**2*a2**2*p1q1*p2q1*p2q2/s**2-
44521  &64*a**2*a2**2*p1q2*p2q1*p2q2/s**2+
44522  &64*a**2*a2**2*p1q1*p2q2**2/s**2-
44523  &32*a**2*a2**2*mb**3*mt/s+32*a**2*a2**2*mb**2*p1p2/s+
44524  &32*a**2*a2**2*mb**2*p1q1/s+32*a**2*a2**2*mb**2*p1q2/s-
44525  &32*a**2*a2**2*p1p2*p2q1/s-32*a**2*a2**2*p1q1*p2q1/s-
44526  &32*a**2*a2**2*p1p2*p2q2/s-32*a**2*a2**2*p1q2*p2q2/s+
44527  &16*a2**2*mb*mt*v**2+64*a2**2*p1q2*p2q1**2*v**2/s**2-
44528  &128*a2**2*mb*mt*p2q1*p2q2*v**2/s**2-
44529  &128*a2**2*p1p2*p2q1*p2q2*v**2/s**2-
44530  &64*a2**2*p1q1*p2q1*p2q2*v**2/s**2-
44531  &64*a2**2*p1q2*p2q1*p2q2*v**2/s**2+
44532  &64*a2**2*p1q1*p2q2**2*v**2/s**2
44533  yy(1, 1)=yy(1, 1)+32*a2**2*mb**3*mt*v**2/s+
44534  &32*a2**2*mb**2*p1p2*v**2/s+
44535  &32*a2**2*mb**2*p1q1*v**2/s+32*a2**2*mb**2*p1q2*v**2/s-
44536  &32*a2**2*p1p2*p2q1*v**2/s-32*a2**2*p1q1*p2q1*v**2/s-
44537  &32*a2**2*p1p2*p2q2*v**2/s-32*a2**2*p1q2*p2q2*v**2/s
44538  yy(1, 1)=2*yy(1, 1)
44539 
44540  yy(1, 2) = -32*a**2*a1*a2*mb*mt+
44541  &128*a**2*a1*a2*mb*mt*p1q2*p2q1/s**2-
44542  &128*a**2*a1*a2*p1p2*p1q2*p2q1/s**2+
44543  &64*a**2*a1*a2*p1q1*p1q2*p2q1/s**2-
44544  &64*a**2*a1*a2*p1q2**2*p2q1/s**2+
44545  &64*a**2*a1*a2*p1q2*p2q1**2/s**2+
44546  &128*a**2*a1*a2*mb*mt*p1q1*p2q2/s**2-
44547  &128*a**2*a1*a2*p1p2*p1q1*p2q2/s**2-
44548  &64*a**2*a1*a2*p1q1**2*p2q2/s**2+
44549  &64*a**2*a1*a2*p1q1*p1q2*p2q2/s**2-
44550  &64*a**2*a1*a2*p1q1*p2q1*p2q2/s**2-
44551  &64*a**2*a1*a2*p1q2*p2q1*p2q2/s**2+
44552  &64*a**2*a1*a2*p1q1*p2q2**2/s**2-
44553  &64*a**2*a1*a2*mb*mt*p1p2/s+
44554  &64*a**2*a1*a2*p1p2**2/s+32*a**2*a1*a2*mb**2*p1q1/s+
44555  &32*a**2*a1*a2*p1p2*p1q1/s+32*a**2*a1*a2*mb**2*p1q2/s+
44556  &32*a**2*a1*a2*p1p2*p1q2/s-32*a**2*a1*a2*mt**2*p2q1/s
44557  yy(1, 2)=yy(1, 2)-32*a**2*a1*a2*p1p2*p2q1/s-
44558  &64*a**2*a1*a2*p1q1*p2q1/s-
44559  &32*a**2*a1*a2*mt**2*p2q2/s-32*a**2*a1*a2*p1p2*p2q2/s-
44560  &64*a**2*a1*a2*p1q2*p2q2/s+32*a1*a2*mb*mt*v**2-
44561  &128*a1*a2*mb*mt*p1q2*p2q1*v**2/s**2 -
44562  &128*a1*a2*p1p2*p1q2*p2q1*v**2/s**2+
44563  &64*a1*a2*p1q1*p1q2*p2q1*v**2/s**2-
44564  &64*a1*a2*p1q2**2*p2q1*v**2/s**2+
44565  &64*a1*a2*p1q2*p2q1**2*v**2/s**2-
44566  &128*a1*a2*mb*mt*p1q1*p2q2*v**2/s**2-
44567  &128*a1*a2*p1p2*p1q1*p2q2*v**2/s**2-
44568  &64*a1*a2*p1q1**2*p2q2*v**2/s**2+
44569  &64*a1*a2*p1q1*p1q2*p2q2*v**2/s**2-
44570  &64*a1*a2*p1q1*p2q1*p2q2*v**2/s**2-
44571  &64*a1*a2*p1q2*p2q1*p2q2*v**2/s**2+
44572  &64*a1*a2*p1q1*p2q2**2*v**2/s**2+
44573  &64*a1*a2*mb*mt*p1p2*v**2/s+64*a1*a2*p1p2**2*v**2/s
44574  yy(1, 2)=yy(1, 2)+32*a1*a2*mb**2*p1q1*v**2/s+
44575  &32*a1*a2*p1p2*p1q1*v**2/s+
44576  &32*a1*a2*mb**2*p1q2*v**2/s+32*a1*a2*p1p2*p1q2*v**2/s-
44577  &32*a1*a2*mt**2*p2q1*v**2/s-32*a1*a2*p1p2*p2q1*v**2/s-
44578  &64*a1*a2*p1q1*p2q1*v**2/s-32*a1*a2*mt**2*p2q2*v**2/s-
44579  &32*a1*a2*p1p2*p2q2*v**2/s-64*a1*a2*p1q2*p2q2*v**2/s
44580 
44581 
44582  yy(2, 2) =-16*a**2*a12*mb*mt+
44583  &128*a**2*a12*mb*mt*p1q1*p1q2/s**2-
44584  &128*a**2*a12*p1p2*p1q1*p1q2/s**2+
44585  &64*a**2*a12*p1q1*p1q2*p2q1/s**2-
44586  &64*a**2*a12*p1q2**2*p2q1/s**2-64*a**2*a12*p1q1**2*p2q2/s**2+
44587  &64*a**2*a12*p1q1*p1q2*p2q2/s**2-32*a**2*a12*mb*mt**3/s+
44588  &32*a**2*a12*mt**2*p1p2/s+32*a**2*a12*p1p2*p1q1/s+
44589  &32*a**2*a12*p1p2*p1q2/s-32*a**2*a12*mt**2*p2q1/s-
44590  &32*a**2*a12*p1q1*p2q1/s-32*a**2*a12*mt**2*p2q2/s-
44591  &32*a**2*a12*p1q2*p2q2/s+16*a12*mb*mt*v**2-
44592  &128*a12*mb*mt*p1q1*p1q2*v**2/s**2-
44593  &128*a12*p1p2*p1q1*p1q2*v**2/s**2+
44594  &64*a12*p1q1*p1q2*p2q1*v**2/s**2-
44595  &64*a12*p1q2**2*p2q1*v**2/s**2-64*a12*p1q1**2*p2q2*v**2/s**2+
44596  &64*a12*p1q1*p1q2*p2q2*v**2/s**2+32*a12*mb*mt**3*v**2/s+
44597  &32*a12*mt**2*p1p2*v**2/s+32*a12*p1p2*p1q1*v**2/s+
44598  &32*a12*p1p2*p1q2*v**2/s-32*a12*mt**2*p2q1*v**2/s
44599  yy(2, 2)=yy(2, 2)-32*a12*p1q1*p2q1*v**2/s-
44600  &32*a12*mt**2*p2q2*v**2/s-
44601  &32*a12*p1q2*p2q2*v**2/s
44602  yy(2, 2)=2*yy(2, 2)
44603 
44604  res=yy(1,1)+2*yy(1,2)+yy(2,2)
44605  amp2= fact*ps*vtb**2*res
44606 
44607  END
44608 C=====================================================================
44609 C ************* FUNCTION SCALAR PRODUCTS *************************
44610  DOUBLE PRECISION FUNCTION pytbhs(A,B)
44611  IMPLICIT DOUBLE PRECISION(a-h, o-z)
44612  IMPLICIT INTEGER(I-N)
44613  dimension a(4),b(4)
44614  dum=a(4)*b(4)
44615  DO 100 id=1,3
44616  dum=dum-a(id)*b(id)
44617  100 CONTINUE
44618  pytbhs=dum
44619  RETURN
44620  END
44621 
44622 C*********************************************************************
44623 
44624 C...PYMSIN
44625 C...Initializes supersymmetry: finds sparticle masses and
44626 C...branching ratios and stores this information.
44627 C...AUTHOR: STEPHEN MRENNA
44628 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44629 
44630  SUBROUTINE pymsin
44631 
44632 C...Double precision and integer declarations.
44633  IMPLICIT DOUBLE PRECISION(a-h, o-z)
44634  IMPLICIT INTEGER(I-N)
44635  INTEGER PYK,PYCHGE,PYCOMP
44636 C...Parameter statement to help give large particle numbers.
44637  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
44638  &kexcit=4000000,kdimen=5000000)
44639 C...Commonblocks.
44640  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
44641  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
44642  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
44643  common/pydat4/chaf(500,2)
44644  CHARACTER CHAF*16
44645  common/pypars/mstp(200),parp(200),msti(200),pari(200)
44646  common/pyint4/mwid(500),wids(500,5)
44647  common/pymssm/imss(0:99),rmss(0:99)
44648  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
44649  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
44650  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
44651  common/pyhtri/hhh(7)
44652  common/pyqnum/nqnum,nqdum,kqnum(500,0:9)
44653  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pypars/,/pyint4/,
44654  &/pymssm/,/pymsrv/,/pyssmt/
44655 
44656 C...Local variables.
44657  DOUBLE PRECISION ALFA,BETA
44658  DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44659  INTEGER I,J,J1,I1,K1
44660  INTEGER KC,LKNT,IDLAM(400,3)
44661  DOUBLE PRECISION XLAM(0:400)
44662  DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44663  DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44664  DOUBLE PRECISION DELM,XMDIF
44665  DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44666  DOUBLE PRECISION ARG,SGNMU,R
44667  INTEGER IMSSM
44668  INTEGER IRPRTY
44669  INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44670  SAVE mwidsu,mdcysu
44671  DATA kfsusy/
44672  &1000001,2000001,1000002,2000002,1000003,2000003,
44673  &1000004,2000004,1000005,2000005,1000006,2000006,
44674  &1000011,2000011,1000012,2000012,1000013,2000013,
44675  &1000014,2000014,1000015,2000015,1000016,2000016,
44676  &1000021,1000022,1000023,1000025,1000035,1000024,
44677  &1000037,1000039, 25, 35, 36, 37,
44678  & 6, 24, 45, 46,1000045, 9*0/
44679  DATA init/0/
44680 
44681 C...Automatically read QNUMBERS, MASS, and DECAY tables
44682  IF (imss(21).NE.0.OR.mstp(161).NE.0) THEN
44683  nqnum=0
44684  CALL pyslha(0,0,ifail)
44685  CALL pyslha(5,0,ifail)
44686  ENDIF
44687  IF (imss(22).NE.0.OR.mstp(161).NE.0) CALL pyslha(2,0,ifail)
44688 
44689 C...Do nothing further if SUSY not requested
44690  imssm=imss(1)
44691  IF(imssm.EQ.0) RETURN
44692 
44693 C...Save copy of MWID(KC) and MDCY(KC,1) values before
44694 C...they are set to zero for the LSP.
44695  IF(init.EQ.0) THEN
44696  init=1
44697  DO 100 i=1,36
44698  kf=kfsusy(i)
44699  kc=pycomp(kf)
44700  mwidsu(i)=mwid(kc)
44701  mdcysu(i)=mdcy(kc,1)
44702  100 CONTINUE
44703  ENDIF
44704 
44705 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44706  DO 110 i=1,36
44707  kf=kfsusy(i)
44708  kc=pycomp(kf)
44709  IF(mdcy(kc,1).EQ.0.AND.mdcysu(i).NE.0) THEN
44710  mwid(kc)=mwidsu(i)
44711  mdcy(kc,1)=mdcysu(i)
44712  ENDIF
44713  110 CONTINUE
44714 
44715 C...First part of routine: set masses and couplings.
44716 
44717 C...Reset mixing values in sfermion sector to pure left/right.
44718  DO 120 i=1,16
44719  sfmix(i,1)=1d0
44720  sfmix(i,4)=1d0
44721  sfmix(i,2)=0d0
44722  sfmix(i,3)=0d0
44723  120 CONTINUE
44724 
44725 C...Add NMSSM states if NMSSM switched on, and change old names.
44726  IF (imss(13).NE.0.AND.pycomp(1000045).EQ.0) THEN
44727 C... Switch on NMSSM
44728  WRITE(mstu(11),*) '(PYMSIN:) switching on NMSSM'
44729 
44730  kfn=25
44731  kcn=kfn
44732  chaf(kcn,1)='h_10'
44733  chaf(kcn,2)=' '
44734 
44735  kfn=35
44736  kcn=kfn
44737  chaf(kcn,1)='h_20'
44738  chaf(kcn,2)=' '
44739 
44740  kfn=45
44741  kcn=kfn
44742  chaf(kcn,1)='h_30'
44743  chaf(kcn,2)=' '
44744 
44745  kfn=36
44746  kcn=kfn
44747  chaf(kcn,1)='A_10'
44748  chaf(kcn,2)=' '
44749 
44750  kfn=46
44751  kcn=kfn
44752  chaf(kcn,1)='A_20'
44753  chaf(kcn,2)=' '
44754 
44755  kfn=1000045
44756  kcn=pycomp(kfn)
44757  IF (kcn.EQ.0) THEN
44758  DO 123 kct=100,mstu(6)
44759  IF(kchg(kct,4).GT.100) kcn=kct
44760  123 CONTINUE
44761  kcn=kcn+1
44762  kchg(kcn,4)=kfn
44763  mstu(20)=0
44764  ENDIF
44765 C... Set stable for now
44766  pmas(kcn,2)=1d-6
44767  mwid(kcn)=0
44768  mdcy(kcn,1)=0
44769  mdcy(kcn,2)=0
44770  mdcy(kcn,3)=0
44771  chaf(kcn,1)='~chi_50'
44772  chaf(kcn,2)=' '
44773  ENDIF
44774 
44775 C...Read spectrum from SLHA file.
44776  IF (imssm.EQ.11) THEN
44777  CALL pyslha(1,0,ifail)
44778  ENDIF
44779 
44780 C...Common couplings.
44781  tanb=rmss(5)
44782  beta=atan(tanb)
44783  cosb=cos(beta)
44784  sinb=tanb*cosb
44785  cos2b=cos(2d0*beta)
44786  alfa=rmss(18)
44787  xmw2=pmas(24,1)**2
44788  xmz2=pmas(23,1)**2
44789  xw=paru(102)
44790 
44791 C...Define sparticle masses for a general MSSM simulation.
44792  IF(imssm.EQ.1) THEN
44793  IF(imss(9).EQ.0) rmss(22)=rmss(9)
44794  DO 130 i=1,5,2
44795  kc=pycomp(ksusy1+i)
44796  pmas(kc,1)=sqrt(rmss(8)**2-(2d0*xmw2+xmz2)*cos2b/6d0)
44797  kc=pycomp(ksusy2+i)
44798  pmas(kc,1)=sqrt(rmss(9)**2+(xmw2-xmz2)*cos2b/3d0)
44799  kc=pycomp(ksusy1+i+1)
44800  pmas(kc,1)=sqrt(rmss(8)**2+(4d0*xmw2-xmz2)*cos2b/6d0)
44801  kc=pycomp(ksusy2+i+1)
44802  pmas(kc,1)=sqrt(rmss(22)**2-(xmw2-xmz2)*cos2b*2d0/3d0)
44803  130 CONTINUE
44804  xarg=rmss(6)**2-pmas(24,1)**2*abs(cos(2d0*beta))
44805  IF(xarg.LT.0d0) THEN
44806  WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44807  & ' FROM THE SUM RULE. '
44808  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44809  RETURN
44810  ELSE
44811  xarg=sqrt(xarg)
44812  ENDIF
44813  DO 140 i=11,15,2
44814  pmas(pycomp(ksusy1+i),1)=rmss(6)
44815  pmas(pycomp(ksusy2+i),1)=rmss(7)
44816  pmas(pycomp(ksusy1+i+1),1)=xarg
44817  pmas(pycomp(ksusy2+i+1),1)=9999d0
44818  140 CONTINUE
44819  IF(imss(8).EQ.1) THEN
44820  rmss(13)=rmss(6)
44821  rmss(14)=rmss(7)
44822  ENDIF
44823 
44824 C...Alternatively derive masses from SUGRA relations.
44825  ELSEIF(imssm.EQ.2) THEN
44826  rmss(36)=rmss(16)
44827  CALL pyapps
44828 C...Or use ISASUSY
44829  ELSEIF(imssm.EQ.12.OR.imssm.EQ.13) THEN
44830  rmss(36)=rmss(16)
44831  CALL pysugi
44832  alfa=rmss(18)
44833  GOTO 170
44834  ELSE
44835  GOTO 170
44836  ENDIF
44837 
44838 C...Add in extra D-term contributions.
44839  IF(imss(7).EQ.1) THEN
44840  r=0.43d0
44841  dx=rmss(23)
44842  dy=rmss(24)
44843  ds=rmss(25)
44844  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44845  WRITE(mstu(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44846  WRITE(mstu(11),*) 'C IN A U(B-L) THEORY '
44847  WRITE(mstu(11),*) 'C DX = ',dx
44848  WRITE(mstu(11),*) 'C DY = ',dy
44849  WRITE(mstu(11),*) 'C DS = ',ds
44850  WRITE(mstu(11),*) 'C '
44851  dy=r*dy-4d0/33d0*(1d0-r)*dx+(1d0-r)/33d0*ds
44852  WRITE(mstu(11),*) 'C DY AT THE WEAK SCALE = ',dy
44853  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44854  dq2=dy/6d0-dx/3d0-ds/3d0
44855  du2=-2d0*dy/3d0-dx/3d0-ds/3d0
44856  dd2=dy/3d0+dx-2d0*ds/3d0
44857  dl2=-dy/2d0+dx-2d0*ds/3d0
44858  de2=dy-dx/3d0-ds/3d0
44859  dhu2=dy/2d0+2d0*dx/3d0+2d0*ds/3d0
44860  dhd2=-dy/2d0-2d0*dx/3d0+ds
44861  dmu2=(-dy/2d0-2d0/3d0*dx+(cosb**2-2d0*sinb**2/3d0)*ds)
44862  & /abs(cos2b)
44863  dma2 = 2d0*dmu2+dhu2+dhd2
44864  DO 150 i=1,5,2
44865  kc=pycomp(ksusy1+i)
44866  pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
44867  kc=pycomp(ksusy2+i)
44868  pmas(kc,1)=sqrt(pmas(kc,1)**2+dd2)
44869  kc=pycomp(ksusy1+i+1)
44870  pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
44871  kc=pycomp(ksusy2+i+1)
44872  pmas(kc,1)=sqrt(pmas(kc,1)**2+du2)
44873  150 CONTINUE
44874  DO 160 i=11,15,2
44875  kc=pycomp(ksusy1+i)
44876  pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
44877  kc=pycomp(ksusy2+i)
44878  pmas(kc,1)=sqrt(pmas(kc,1)**2+de2)
44879  kc=pycomp(ksusy1+i+1)
44880  pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
44881  160 CONTINUE
44882  IF(rmss(4)**2+dmu2.LT.0d0) THEN
44883  WRITE(mstu(11),*) ' MU2 DRIVEN NEGATIVE '
44884  CALL pystop(104)
44885  ENDIF
44886  sgnmu=sign(1d0,rmss(4))
44887  rmss(4)=sgnmu*sqrt(rmss(4)**2+dmu2)
44888  arg=rmss(10)**2*sign(1d0,rmss(10))+dq2
44889  rmss(10)=sign(sqrt(abs(arg)),arg)
44890  arg=rmss(11)**2*sign(1d0,rmss(11))+dd2
44891  rmss(11)=sign(sqrt(abs(arg)),arg)
44892  arg=rmss(12)**2*sign(1d0,rmss(12))+du2
44893  rmss(12)=sign(sqrt(abs(arg)),arg)
44894  arg=rmss(13)**2*sign(1d0,rmss(13))+dl2
44895  rmss(13)=sign(sqrt(abs(arg)),arg)
44896  arg=rmss(14)**2*sign(1d0,rmss(14))+de2
44897  rmss(14)=sign(sqrt(abs(arg)),arg)
44898  IF( rmss(19)**2 + dma2 .LE. 50d0 ) THEN
44899  WRITE(mstu(11),*) ' MA DRIVEN TOO LOW '
44900  CALL pystop(104)
44901  ENDIF
44902  rmss(19)=sqrt(rmss(19)**2+dma2)
44903  rmss(6)=sqrt(rmss(6)**2+dl2)
44904  rmss(7)=sqrt(rmss(7)**2+de2)
44905  WRITE(mstu(11),*) ' MTL = ',rmss(10)
44906  WRITE(mstu(11),*) ' MBR = ',rmss(11)
44907  WRITE(mstu(11),*) ' MTR = ',rmss(12)
44908  WRITE(mstu(11),*) ' SEL = ',rmss(6),rmss(13)
44909  WRITE(mstu(11),*) ' SER = ',rmss(7),rmss(14)
44910  ENDIF
44911 
44912 C...Fix the third generation sfermions.
44913  CALL pythrg
44914 
44915 C...Fix the neutralino--chargino--gluino sector.
44916  CALL pyinom
44917 
44918 C...Fix the Higgs sector.
44919  CALL pyhggm(alfa)
44920 
44921 C...Choose the Gunion-Haber convention.
44922  alfa=-alfa
44923  rmss(18)=alfa
44924 
44925 C...Print information on mass parameters.
44926  IF(imssm.EQ.2.AND.mstp(122).GT.0) THEN
44927  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44928  WRITE(mstu(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
44929  WRITE(mstu(11),*) ' M0 = ',rmss(8)
44930  WRITE(mstu(11),*) ' M1/2=',rmss(1)
44931  WRITE(mstu(11),*) ' TANB=',rmss(5)
44932  WRITE(mstu(11),*) ' MU = ',rmss(4)
44933  WRITE(mstu(11),*) ' AT = ',rmss(16)
44934  WRITE(mstu(11),*) ' MA = ',rmss(19)
44935  WRITE(mstu(11),*) ' MTOP=',pmas(6,1)
44936  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44937  ENDIF
44938  IF(imss(20).EQ.1) THEN
44939  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44940  WRITE(mstu(11),*) ' DEBUG MODE '
44941  WRITE(mstu(11),*) ' UMIX = ',umix(1,1),umix(1,2),
44942  & umix(2,1),umix(2,2)
44943  WRITE(mstu(11),*) ' UMIXI = ',umixi(1,1),umixi(1,2),
44944  & umixi(2,1),umixi(2,2)
44945  WRITE(mstu(11),*) ' VMIX = ',vmix(1,1),vmix(1,2),
44946  & vmix(2,1),vmix(2,2)
44947  WRITE(mstu(11),*) ' VMIXI = ',vmixi(1,1),vmixi(1,2),
44948  & vmixi(2,1),vmixi(2,2)
44949  WRITE(mstu(11),*) ' ZMIX = ',(zmix(1,i),i=1,4)
44950  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(1,i),i=1,4)
44951  WRITE(mstu(11),*) ' ZMIX = ',(zmix(2,i),i=1,4)
44952  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(2,i),i=1,4)
44953  WRITE(mstu(11),*) ' ZMIX = ',(zmix(3,i),i=1,4)
44954  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(3,i),i=1,4)
44955  WRITE(mstu(11),*) ' ZMIX = ',(zmix(4,i),i=1,4)
44956  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(4,i),i=1,4)
44957  WRITE(mstu(11),*) ' ALFA = ',alfa
44958  WRITE(mstu(11),*) ' BETA = ',beta
44959  WRITE(mstu(11),*) ' STOP = ',(sfmix(6,i),i=1,4)
44960  WRITE(mstu(11),*) ' SBOT = ',(sfmix(5,i),i=1,4)
44961  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44962  ENDIF
44963 
44964 C...Set up the Higgs couplings - needed here since initialization
44965 C...in PYINRE did not yet occur when PYWIDT is called below.
44966  170 al=alfa
44967  be=beta
44968  sina=sin(al)
44969  cosa=cos(al)
44970  cosb=cos(be)
44971  sinb=tanb*cosb
44972  sbma=sin(be-al)
44973  sapb=sin(al+be)
44974  capb=cos(al+be)
44975  cbma=cos(be-al)
44976  c2a=cos(2d0*al)
44977  c2b=cosb**2-sinb**2
44978 C...tanb (used for H+)
44979  paru(141)=tanb
44980 
44981 C...Firstly: h
44982 C...Coupling to d-type quarks
44983  paru(161)=sina/cosb
44984 C...Coupling to u-type quarks
44985  paru(162)=-cosa/sinb
44986 C...Coupling to leptons
44987  paru(163)=paru(161)
44988 C...Coupling to Z
44989  paru(164)=sbma
44990 C...Coupling to W
44991  paru(165)=paru(164)
44992 
44993 C...Secondly: H
44994 C...Coupling to d-type quarks
44995  paru(171)=-cosa/cosb
44996 C...Coupling to u-type quarks
44997  paru(172)=-sina/sinb
44998 C...Coupling to leptons
44999  paru(173)=paru(171)
45000 C...Coupling to Z
45001  paru(174)=cbma
45002 C...Coupling to W
45003  paru(175)=paru(174)
45004 C...Coupling to h
45005  IF(imss(4).GE.2) THEN
45006  paru(176)=cos(2d0*al)*cos(be+al)-2d0*sin(2d0*al)*sin(be+al)
45007  ELSE
45008  hhh(3)=hhh(3)+hhh(4)+hhh(5)
45009  paru(176)=-3d0/hhh(1)*(hhh(1)*sina**2*cosb*cosa+
45010  1 hhh(2)*cosa**2*sinb*sina+hhh(3)*(sina**3*sinb+cosa**3*cosb-
45011  2 2d0/3d0*cbma)-hhh(6)*sina*(cosb*c2a+cosa*capb)+
45012  3 hhh(7)*cosa*(sinb*c2a+sina*capb))
45013  ENDIF
45014 C...Coupling to H+
45015 C...Define later
45016  IF(imss(4).GE.2) THEN
45017  paru(168)=-sbma-cos(2d0*be)*sapb/2d0/(1d0-xw)
45018  ELSE
45019  paru(168)=1d0/hhh(1)*(hhh(1)*sinb**2*cosb*sina-
45020  1 hhh(2)*cosb**2*sinb*cosa-hhh(3)*(sinb**3*cosa-cosb**3*sina)+
45021  2 2d0*hhh(5)*sbma-hhh(6)*sinb*(cosb*sapb+sina*c2b)-
45022  3 hhh(7)*cosb*(cosa*c2b-sinb*sapb)-(hhh(5)-hhh(4))*sbma)
45023  ENDIF
45024 C...Coupling to A
45025  IF(imss(4).GE.2) THEN
45026  paru(177)=cos(2d0*be)*cos(be+al)
45027  ELSE
45028  paru(177)=-1d0/hhh(1)*(hhh(1)*sinb**2*cosb*cosa+
45029  1 hhh(2)*cosb**2*sinb*sina+hhh(3)*(sinb**3*sina+cosb**3*cosa)-
45030  2 2d0*hhh(5)*cbma-hhh(6)*sinb*(cosb*capb+cosa*c2b)+
45031  3 hhh(7)*cosb*(sinb*capb+sina*c2b))
45032  ENDIF
45033 C...Coupling to H+
45034  IF(imss(4).GE.2) THEN
45035  paru(178)=paru(177)
45036  ELSE
45037  paru(178)=paru(177)-(hhh(5)-hhh(4))/hhh(1)*cbma
45038  ENDIF
45039 C...Thirdly, A
45040 C...Coupling to d-type quarks
45041  paru(181)=tanb
45042 C...Coupling to u-type quarks
45043  paru(182)=1d0/paru(181)
45044 C...Coupling to leptons
45045  paru(183)=paru(181)
45046  paru(184)=0d0
45047  paru(185)=0d0
45048 C...Coupling to Z h
45049  paru(186)=cos(be-al)
45050 C...Coupling to Z H
45051  paru(187)=sin(be-al)
45052  paru(188)=0d0
45053  paru(189)=0d0
45054  paru(190)=0d0
45055 
45056 C...Finally: H+
45057 C...Coupling to W h
45058  paru(195)=cos(be-al)
45059 
45060 C...Tell that all Higgs couplings have been set.
45061  mstp(4)=1
45062 
45063 C...Set R-Violating couplings.
45064 C...Set lambda couplings to common value or "natural values".
45065  IF ((imss(51).NE.3).AND.(imss(51).NE.0)) THEN
45066  vir3=1d0/(126d0)**3
45067  DO 200 irk=1,3
45068  DO 190 iri=1,3
45069  DO 180 irj=1,3
45070  IF (iri.NE.irj) THEN
45071  IF (iri.LT.irj) THEN
45072  rvlam(iri,irj,irk)=rmss(51)
45073  IF (imss(51).EQ.2) rvlam(iri,irj,irk)=rmss(51)*
45074  & sqrt(pmas(9+2*iri,1)*pmas(9+2*irj,1)*
45075  & pmas(9+2*irk,1)*vir3)
45076  ELSE
45077  rvlam(iri,irj,irk)=-rvlam(irj,iri,irk)
45078  ENDIF
45079  ELSE
45080  rvlam(iri,irj,irk)=0d0
45081  ENDIF
45082  180 CONTINUE
45083  190 CONTINUE
45084  200 CONTINUE
45085  ENDIF
45086 C...Set lambda' couplings to common value or "natural values".
45087  IF ((imss(52).NE.3).AND.(imss(52).NE.0)) THEN
45088  vir3=1d0/(126d0)**3
45089  DO 230 iri=1,3
45090  DO 220 irj=1,3
45091  DO 210 irk=1,3
45092  rvlamp(iri,irj,irk)=rmss(52)
45093  IF (imss(52).EQ.2) rvlamp(iri,irj,irk)=rmss(52)*
45094  & sqrt(pmas(9+2*iri,1)*0.5d0*(pmas(2*irj,1)+
45095  & pmas(2*irj-1,1))*pmas(2*irk-1,1)*vir3)
45096  210 CONTINUE
45097  220 CONTINUE
45098  230 CONTINUE
45099  ENDIF
45100 C...Set lambda'' couplings to common value or "natural values".
45101  IF ((imss(53).NE.3).AND.(imss(53).NE.0)) THEN
45102  vir3=1d0/(126d0)**3
45103  DO 260 iri=1,3
45104  DO 250 irj=1,3
45105  DO 240 irk=1,3
45106  IF (irj.NE.irk) THEN
45107  IF (irj.LT.irk) THEN
45108  rvlamb(iri,irj,irk)=rmss(53)
45109  IF (imss(53).EQ.2) rvlamb(iri,irj,irk)=
45110  & rmss(53)*sqrt(pmas(2*iri,1)*pmas(2*irj-1,1)*
45111  & pmas(2*irk-1,1)*vir3)
45112  ELSE
45113  rvlamb(iri,irj,irk)=-rvlamb(iri,irk,irj)
45114  ENDIF
45115  ELSE
45116  rvlamb(iri,irj,irk) = 0d0
45117  ENDIF
45118  240 CONTINUE
45119  250 CONTINUE
45120  260 CONTINUE
45121  ENDIF
45122 
45123 C...Antisymmetrize couplings set by user
45124  IF (imss(51).EQ.3.OR.imss(53).EQ.3) THEN
45125  DO 290 iri=1,3
45126  DO 280 irj=1,3
45127  DO 270 irk=1,3
45128  IF (rvlam(iri,irj,irk).NE.-rvlam(irj,iri,irk)) THEN
45129  rvlam(irj,iri,irk)=-rvlam(iri,irj,irk)
45130  IF (iri.EQ.irj) rvlam(iri,irj,irk)=0d0
45131  ENDIF
45132  IF (rvlamb(iri,irj,irk).NE.-rvlamb(iri,irk,irj)) THEN
45133  rvlamb(iri,irk,irj)=-rvlamb(iri,irj,irk)
45134  IF (irj.EQ.irk) rvlamb(iri,irj,irk)=0d0
45135  ENDIF
45136  270 CONTINUE
45137  280 CONTINUE
45138  290 CONTINUE
45139  ENDIF
45140 
45141 C...Write spectrum to SLHA file
45142  IF (imss(23).NE.0) THEN
45143  ifail=0
45144  CALL pyslha(3,0,ifail)
45145  ENDIF
45146 
45147 C...Second part of routine: set decay modes and branching ratios.
45148 
45149 C...Allow chi10 -> gravitino + gamma or not.
45150  kc=pycomp(ksusy1+39)
45151  IF( imss(11) .NE. 0 ) THEN
45152  pmas(kc,1)=rmss(21)/1d9
45153  pmas(kc,2)=0d0
45154  irprty=0
45155  WRITE(mstu(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45156  ELSE IF (imss(51).GE.1.OR.imss(52).GE.1.OR.imss(53).GE.1) THEN
45157  irprty=0
45158  IF (imss(51).GE.1) WRITE(mstu(11),*)
45159  & ' ALLOWING SUSY LLE DECAYS'
45160  IF (imss(52).GE.1) WRITE(mstu(11),*)
45161  & ' ALLOWING SUSY LQD DECAYS'
45162  IF (imss(53).GE.1) WRITE(mstu(11),*)
45163  & ' ALLOWING SUSY UDD DECAYS'
45164  IF (imss(53).GE.1.AND.imss(52).GE.1) WRITE(mstu(11),*)
45165  & ' --- Warning: R-Violating couplings possibly',
45166  & ' incompatible with proton decay'
45167  ELSE
45168  pmas(kc,1)=9999d0
45169  irprty=1
45170  ENDIF
45171 
45172 C...Loop over sparticle and Higgs species.
45173  pmchi1=pmas(pycomp(ksusy1+22),1)
45174 C...Find the LSP or NLSP for a gravitino LSP
45175  ilsp=0
45176  pmlsp=1d20
45177  DO 300 i=1,36
45178  kf=kfsusy(i)
45179  IF(kf.EQ.1000039) GOTO 300
45180  kc=pycomp(kf)
45181  IF(pmas(kc,1).LT.pmlsp) THEN
45182  ilsp=i
45183  pmlsp=pmas(kc,1)
45184  ENDIF
45185  300 CONTINUE
45186  DO 370 i=1,50
45187  IF (i.GT.39.AND.imss(13).NE.1) GOTO 370
45188  kf=kfsusy(i)
45189  IF (kf.EQ.0) GOTO 370
45190  kc=pycomp(kf)
45191  lknt=0
45192 
45193 C...Check if there are any decays listed for this sparticle
45194 C...in a file
45195  IF (imss(22).NE.0.OR.mstp(161).NE.0) THEN
45196  ifail=0
45197  CALL pyslha(2,kf,ifail)
45198  IF (ifail.EQ.0.OR.kf.EQ.6.OR.kf.EQ.24) GOTO 370
45199  ELSEIF (i.GE.37) THEN
45200  GOTO 370
45201  ENDIF
45202 
45203 C...Sfermion decays.
45204  IF(i.LE.24) THEN
45205 C...First check to see if sneutrino is lighter than chi10.
45206  IF((i.EQ.15.OR.i.EQ.19.OR.i.EQ.23).AND.
45207  & pmas(kc,1).LT.pmchi1) THEN
45208  ELSE
45209  CALL pysfdc(kf,xlam,idlam,lknt)
45210  ENDIF
45211 
45212 C...Gluino decays.
45213  ELSEIF(i.EQ.25) THEN
45214  CALL pyglui(kf,xlam,idlam,lknt)
45215  IF(i.EQ.ilsp.AND.irprty.EQ.1) lknt=0
45216 
45217 C...Neutralino decays.
45218  ELSEIF(i.GE.26.AND.i.LE.29) THEN
45219  CALL pynjdc(kf,xlam,idlam,lknt)
45220 C...chi10 stable or chi10 -> gravitino + gamma.
45221  IF(i.EQ.26.AND.irprty.EQ.1) THEN
45222  pmas(kc,2)=1d-6
45223  mdcy(kc,1)=0
45224  mwid(kc)=0
45225  ENDIF
45226 
45227 C...Chargino decays.
45228  ELSEIF(i.GE.30.AND.i.LE.31) THEN
45229  CALL pycjdc(kf,xlam,idlam,lknt)
45230 
45231 C...Gravitino is stable.
45232  ELSEIF(i.EQ.32) THEN
45233  mdcy(kc,1)=0
45234  mwid(kc)=0
45235 
45236 C...Higgs decays.
45237  ELSEIF(i.GE.33.AND.i.LE.36) THEN
45238 C...Calculate decays to non-SUSY particles.
45239  CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
45240  lknt=0
45241  DO 310 i1=0,100
45242  xlam(i1)=0d0
45243  310 CONTINUE
45244  DO 330 i1=1,mdcy(kc,3)
45245  k1=mdcy(kc,2)+i1-1
45246  IF(iabs(kfdp(k1,1)).GT.ksusy1.OR.
45247  & iabs(kfdp(k1,2)).GT.ksusy1) GOTO 330
45248  xlam(i1)=wdtp(i1)
45249  xlam(0)=xlam(0)+xlam(i1)
45250  DO 320 j1=1,3
45251  idlam(i1,j1)=kfdp(k1,j1)
45252  320 CONTINUE
45253  lknt=lknt+1
45254  330 CONTINUE
45255 C...Add the decays to SUSY particles.
45256  CALL pyhext(kf,xlam,idlam,lknt)
45257  ENDIF
45258 C...Zero the branching ratios for use in loop mode
45259 C...thanks to K. Matchev (FNAL)
45260  DO 340 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
45261  brat(idc)=0d0
45262  340 CONTINUE
45263 
45264 C...Set stable particles.
45265  IF(lknt.EQ.0) THEN
45266  mdcy(kc,1)=0
45267  mwid(kc)=0
45268  pmas(kc,2)=1d-6
45269  pmas(kc,3)=1d-5
45270  pmas(kc,4)=0d0
45271 
45272 C...Store branching ratios in the standard tables.
45273  ELSE
45274  idc=mdcy(kc,2)+mdcy(kc,3)-1
45275  delm=1d6
45276  DO 360 il=1,lknt
45277  idcsv=idc
45278  350 idc=idc+1
45279  brat(idc)=0d0
45280  IF(idc.EQ.mdcy(kc,2)+mdcy(kc,3)) idc=mdcy(kc,2)
45281  IF(idlam(il,1).EQ.kfdp(idc,1).AND.idlam(il,2).EQ.
45282  & kfdp(idc,2).AND.idlam(il,3).EQ.kfdp(idc,3)) THEN
45283  brat(idc)=xlam(il)/xlam(0)
45284  xmdif=pmas(kc,1)
45285  IF(mdme(idc,1).GE.1) THEN
45286  xmdif=xmdif-pmas(pycomp(kfdp(idc,1)),1)-
45287  & pmas(pycomp(kfdp(idc,2)),1)
45288  IF(kfdp(idc,3).NE.0) xmdif=xmdif-
45289  & pmas(pycomp(kfdp(idc,3)),1)
45290  ENDIF
45291  IF(i.LE.32) THEN
45292  IF(xmdif.GE.0d0) THEN
45293  delm=min(delm,xmdif)
45294  ELSE
45295  WRITE(mstu(11),*) ' ERROR WITH DELM ',delm,xmdif
45296  WRITE(mstu(11),*) ' KF = ',kf
45297  WRITE(mstu(11),*) ' KF(decay) = ',(kfdp(idc,j),j=1,3)
45298  ENDIF
45299  ENDIF
45300  GOTO 360
45301  ELSEIF(idc.EQ.idcsv) THEN
45302  WRITE(mstu(11),*) ' Error in PYMSIN: SUSY decay ',
45303  & 'channel not recognized:'
45304  WRITE(mstu(11),*) kf,' -> ',(idlam(il,j),j=1,3)
45305  GOTO 360
45306  ELSE
45307  GOTO 350
45308  ENDIF
45309  360 CONTINUE
45310 
45311 C...Store width, cutoff and lifetime.
45312  pmas(kc,2)=xlam(0)
45313  IF(pmas(kc,2).LT.0.1d0*delm) THEN
45314  pmas(kc,3)=pmas(kc,2)*10d0
45315  ELSE
45316  pmas(kc,3)=0.95d0*delm
45317  ENDIF
45318  IF(pmas(kc,2).NE.0d0) THEN
45319  pmas(kc,4)=paru(3)/pmas(kc,2)*1d-12
45320  ENDIF
45321 C...Write decays to SLHA file
45322  IF (imss(24).NE.0) THEN
45323  ifail=0
45324  CALL pyslha(4,kf,ifail)
45325  ENDIF
45326 
45327  ENDIF
45328  370 CONTINUE
45329 
45330  RETURN
45331  END
45332 C*********************************************************************
45333 
45334 C...PYSLHA
45335 C...Read/write spectrum or decay data from SLHA standard file(s).
45336 C...P. Skands
45337 
45338 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45339 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45340 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45341 C... (KFORIG=0 : read all decay tables)
45342 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45343 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45344 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45345 C... (KFORIG=0 : read all MASS entries)
45346 
45347  SUBROUTINE pyslha(MUPDA,KFORIG,IRETRN)
45348 
45349 C...Double precision and integer declarations.
45350  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45351  IMPLICIT INTEGER(I-N)
45352  INTEGER PYK,PYCHGE,PYCOMP
45353  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
45354  &kexcit=4000000,kdimen=5000000)
45355 C...Commonblocks.
45356  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45357  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45358  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
45359  common/pydat4/chaf(500,2)
45360  CHARACTER CHAF*16
45361  common/pypars/mstp(200),parp(200),msti(200),pari(200)
45362  CHARACTER*40 ISAVER,VISAJE
45363  common/pyint4/mwid(500),wids(500,5)
45364  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pypars/,/pyint4/
45365 C...SUSY blocks
45366  common/pymssm/imss(0:99),rmss(0:99)
45367  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
45368  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
45369  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
45370  SAVE /pymssm/,/pyssmt/,/pymsrv/
45371 
45372 C...Local arrays, character variables and data.
45373  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
45374  & au(3,3),ad(3,3),ae(3,3)
45375  common/pylh3c/cpro(2),cver(2)
45376 C...The common block of new states (QNUMBERS / PARTICLE)
45377  common/pyqnum/nqnum,nqdum,kqnum(500,0:9)
45378 C...- NQNUM : Number of QNUMBERS blocks that have been read in
45379 C...- KQNUM(I,0) : KF of new state
45380 C...- KQNUM(I,1) : 3 times electric charge
45381 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45382 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45383 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45384 C...- KQNUM(I,5:9) : space available for further quantum numbers
45385  dimension mmod(100),mspc(100),kfdec(100)
45386  SAVE /pylh3p/,/pylh3c/,/pyqnum/,mmod,mspc,kfdec
45387 C...MMOD: flags to set for each block read in.
45388 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45389 C...MSPC: Flags to set for each block read in.
45390 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45391 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45392 C...11: AD 12: AE 13: YU 14: YD 15: YE
45393 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45394  CHARACTER CPRO*12,CVER*12,CHNLIN*6
45395  CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45396  CHARACTER CHINL*120,CHKF*9,CHTMP*16
45397  INTEGER VERBOS
45398  SAVE verbos
45399 C...Date of last Change
45400  parameter(doc='23 Jan 2009')
45401 C...Local arrays and initial values
45402  dimension idc(5),kfsusy(50)
45403  SAVE kfsusy
45404  DATA nqnum /0/
45405  DATA ndecay /0/
45406  DATA verbos /1/
45407  DATA nhello /0/
45408  DATA mlhef /0/
45409  DATA mlhefd /0/
45410  DATA kfsusy/
45411  &1000001,1000002,1000003,1000004,1000005,1000006,
45412  &2000001,2000002,2000003,2000004,2000005,2000006,
45413  &1000011,1000012,1000013,1000014,1000015,1000016,
45414  &2000011,2000012,2000013,2000014,2000015,2000016,
45415  &1000021,1000022,1000023,1000025,1000035,1000024,
45416  &1000037,1000039, 25, 35, 36, 37,
45417  & 6, 24, 45, 46,1000045, 9*0/
45418  DATA kfdec/100*0/
45419  rmfun(ip)=pmas(pycomp(ip),1)
45420 
45421 C...Shorthand for spectrum and decay table unit numbers
45422  imss21=imss(21)
45423  imss22=imss(22)
45424 
45425 C...Default for LHEF input: read header information
45426  IF (imss21.EQ.0.AND.mstp(161).NE.0) imss21=mstp(161)
45427  IF (imss22.EQ.0.AND.mstp(161).NE.0) imss22=mstp(161)
45428  IF (imss21.EQ.mstp(161)) mlhef=1
45429  IF (imss22.EQ.mstp(161)) mlhefd=1
45430 
45431 C...Hello World
45432  IF (nhello.EQ.0) THEN
45433  IF ((mlhef.NE.1.AND.mlhefd.NE.1).OR.(imss(1).NE.0)) THEN
45434  WRITE(mstu(11),5000) doc
45435  nhello=1
45436  ENDIF
45437  ENDIF
45438 
45439 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45440 C...+MUPDA).
45441  lfn=imss21
45442  IF (mupda.EQ.2) lfn=imss22
45443  IF (mupda.EQ.3) lfn=imss(23)
45444  IF (mupda.EQ.4) lfn=imss(24)
45445 C...Flag that we have not yet found whatever we were asked to find.
45446  iretrn=1
45447 
45448 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45449  IF (lfn.EQ.0) THEN
45450  WRITE(mstu(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45451  GOTO 9999
45452  ENDIF
45453 
45454 C...If reading LHEF header, start by rewinding file
45455  IF (mlhef.EQ.1.OR.mlhefd.EQ.1) rewind(lfn)
45456 
45457 C...If told to read spectrum, first zero all previous information.
45458  IF (mupda.EQ.1) THEN
45459 C...Zero all block read flags
45460  DO 100 m=1,100
45461  mmod(m)=0
45462  mspc(m)=0
45463  100 CONTINUE
45464 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45465  DO 110 isusy=1,36
45466  kc=pycomp(kfsusy(isusy))
45467  pmas(kc,1)=0d0
45468  110 CONTINUE
45469 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45470  DO 130 j=1,4
45471  sfmix(5,j) =0d0
45472  sfmix(6,j) =0d0
45473  sfmix(15,j)=0d0
45474  DO 120 l=1,4
45475  zmix(l,j) =0d0
45476  zmixi(l,j)=0d0
45477  IF (j.LE.2.AND.l.LE.2) THEN
45478  umix(l,j) =0d0
45479  umixi(l,j)=0d0
45480  vmix(l,j) =0d0
45481  vmixi(l,j)=0d0
45482  ENDIF
45483  120 CONTINUE
45484 C...Zero signed masses.
45485  smz(j)=0d0
45486  IF (j.LE.2) smw(j)=0d0
45487  130 CONTINUE
45488 
45489 C...If reading decays, reset PYTHIA decay counters.
45490  ELSEIF (mupda.EQ.2) THEN
45491 C...Check if DECAY for this KF already read
45492  IF (kforig.NE.0) THEN
45493  DO 140 idec=1,ndecay
45494  IF (kforig.EQ.kfdec(idec)) THEN
45495  iretrn=0
45496  RETURN
45497  ENDIF
45498  140 CONTINUE
45499  ENDIF
45500  kcc=100
45501  ndc=0
45502  brsum=0d0
45503  DO 150 kc=1,mstu(6)
45504  IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
45505  ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
45506  150 CONTINUE
45507  ELSEIF (mupda.EQ.5) THEN
45508 C...Zero block read flags
45509  DO 160 m=1,100
45510  mspc(m)=0
45511  160 CONTINUE
45512  ENDIF
45513 
45514 C............READ
45515 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45516  IF(mupda.EQ.0.OR.mupda.EQ.1.OR.mupda.EQ.2.OR.mupda.EQ.5) THEN
45517 C...Initialize program and version strings
45518  IF(mupda.EQ.1.OR.mupda.EQ.2) THEN
45519  cpro(mupda)=' '
45520  cver(mupda)=' '
45521  ENDIF
45522 
45523 C...Initialize read loop
45524  merr=0
45525  nline=0
45526  chblck=' '
45527 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45528  170 chinl=' '
45529  READ(lfn,'(A120)',END=400) chinl
45530 C...Count which line number we're at.
45531  nline=nline+1
45532  WRITE(chnlin,'(I6)') nline
45533 
45534 C...Skip comment and empty lines without processing.
45535  IF (chinl(1:1).EQ.'#'.OR.chinl.EQ.' ') GOTO 170
45536 
45537 C...We assume all upper case below. Rewrite CHINL to all upper case.
45538  inl=0
45539  igood=0
45540  180 inl=inl+1
45541  IF (chinl(inl:inl).NE.'#') THEN
45542  DO 190 ich=97,122
45543  IF (char(ich).EQ.chinl(inl:inl)) chinl(inl:inl)=char(ich-32)
45544  190 CONTINUE
45545 C...Extra safety. Chek for sensible input on line
45546  IF (igood.EQ.0) THEN
45547  DO 200 ich=48,90
45548  IF (char(ich).EQ.chinl(inl:inl)) igood=1
45549  200 CONTINUE
45550  ENDIF
45551  IF (inl.LT.120) GOTO 180
45552  ENDIF
45553  IF (igood.EQ.0) GOTO 170
45554 
45555 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45556  DO 210 i1=1,10
45557  IF (chinl(i1:i1+5).EQ.'</SLHA'
45558  & .OR.chinl(i1:i1+5).EQ.'<EVENT'
45559  & .OR.chinl(i1:i1+4).EQ.'<INIT') THEN
45560  rewind(lfn)
45561  GOTO 400
45562  ENDIF
45563  210 CONTINUE
45564 
45565 C...Check for BLOCK begin statement (spectrum).
45566  IF (chinl(1:5).EQ.'BLOCK') THEN
45567  merr=0
45568  READ(chinl,'(A6,A)',err=580) chdum,chblck
45569 C...Check if another of this type of block was already read.
45570 C...(logarithmic interpolation not yet implemented, so duplicates always
45571 C...give errors)
45572  IF (chblck(1:6).EQ.'MODSEL'.AND.mmod(1).NE.0) merr=7
45573  IF (chblck(1:6).EQ.'MINPAR'.AND.mmod(2).NE.0) merr=7
45574  IF (chblck(1:6).EQ.'EXTPAR'.AND.mmod(3).NE.0) merr=7
45575  IF (chblck(1:8).EQ.'SMINPUTS'.AND.mmod(4).NE.0) merr=7
45576  IF (chblck(1:4).EQ.'MASS'.AND.mspc(1).NE.0) merr=7
45577  IF (chblck(1:4).EQ.'NMIX'.AND.mspc(2).NE.0) merr=7
45578  IF (chblck(1:4).EQ.'UMIX'.AND.mspc(3).NE.0) merr=7
45579  IF (chblck(1:4).EQ.'VMIX'.AND.mspc(4).NE.0) merr=7
45580  IF (chblck(1:7).EQ.'SBOTMIX'.AND.mspc(5).NE.0) merr=7
45581  IF (chblck(1:7).EQ.'STOPMIX'.AND.mspc(6).NE.0) merr=7
45582  IF (chblck(1:7).EQ.'STAUMIX'.AND.mspc(7).NE.0) merr=7
45583  IF (chblck(1:4).EQ.'HMIX'.AND.mspc(8).NE.0) merr=7
45584  IF (chblck(1:5).EQ.'ALPHA'.AND.mspc(17).NE.0) merr=7
45585  IF (chblck(1:5).EQ.'AU'.AND.mspc(10).NE.0) merr=7
45586  IF (chblck(1:5).EQ.'AD'.AND.mspc(11).NE.0) merr=7
45587  IF (chblck(1:5).EQ.'AE'.AND.mspc(12).NE.0) merr=7
45588  IF (chblck(1:5).EQ.'MSOFT'.AND.mspc(18).NE.0) merr=7
45589 C...Check for new particles
45590  IF (chblck(1:8).EQ.'QNUMBERS'.OR.chblck(1:8).EQ.'PARTICLE')
45591  & THEN
45592  mspc(19)=mspc(19)+1
45593 C...Read PDG code
45594  READ(chblck(9:60),*) kfq
45595 
45596  DO 220 mq=1,nqnum
45597  IF (kqnum(mq,0).EQ.kfq) THEN
45598  merr=17
45599  GOTO 380
45600  ENDIF
45601  220 CONTINUE
45602  IF (nhello.EQ.0) THEN
45603  WRITE(mstu(11),5000) doc
45604  nhello=1
45605  ENDIF
45606  WRITE(mstu(11),'(A,I9,A,F12.3)')
45607  & ' * (PYSLHA:) Reading '//chblck(1:8)//
45608  & ' for KF =',kfq
45609  nqnum=nqnum+1
45610  kqnum(nqnum,0)=kfq
45611  mspc(19)=mspc(19)+1
45612  kcq=pycomp(kfq)
45613 C...Only read in new codes (also OK to overwrite if KF > 3000000)
45614  IF (kcq.EQ.0.OR.iabs(kfq).GE.3000000) THEN
45615  IF (kcq.EQ.0) THEN
45616  DO 230 kct=100,mstu(6)
45617  IF(kchg(kct,4).GT.100) kcq=kct
45618  230 CONTINUE
45619  kcq=kcq+1
45620  ENDIF
45621  kcc=kcq
45622  kchg(kcq,4)=kfq
45623 C...First write PDG code as name
45624  WRITE(chtmp,*) kfq
45625  WRITE(chtmp,'(A)') chtmp(2:10)
45626 C...Then look for real name
45627  ibeg=9
45628  240 ibeg=ibeg+1
45629  IF (chblck(ibeg:ibeg).NE.'#'.AND.ibeg.LT.59) GOTO 240
45630  250 ibeg=ibeg+1
45631  IF (chblck(ibeg:ibeg).EQ.' '.AND.ibeg.LT.59) GOTO 250
45632  iend=ibeg-1
45633  260 iend=iend+1
45634  IF (chblck(iend+1:iend+1).NE.' '.AND.iend.LT.59) GOTO 260
45635  IF (iend.LT.59) THEN
45636  READ(chblck(ibeg:iend),'(A)',err=270) chdum
45637  IF (chdum.NE.' ') chtmp=chdum
45638  ENDIF
45639  270 READ(chtmp,'(A)') chaf(kcq,1)
45640  mstu(20)=0
45641 C...Set stable for now
45642  pmas(kcq,2)=1d-6
45643  mwid(kcq)=0
45644  mdcy(kcq,1)=0
45645  mdcy(kcq,2)=0
45646  mdcy(kcq,3)=0
45647  ELSE
45648  WRITE(mstu(11),*)
45649  & '* (PYSLHA:) KF =',kfq,' already exists: ',
45650  & chaf(kcq,1), '. Entry ignored.'
45651  merr=7
45652  ENDIF
45653  ENDIF
45654 C...Finalize this line and read next.
45655  GOTO 380
45656 C...Check for DECAY begin statement (decays).
45657  ELSEIF (chinl(1:3).EQ.'DEC') THEN
45658  merr=0
45659  brsum=0d0
45660  chblck='DECAY'
45661 C...Read KF code and WIDTH
45662  mpsign=1
45663  READ(chinl(7:inl),*,err=590) kf, width
45664  IF (kf.LE.0) THEN
45665  kf=-kf
45666  mpsign=-1
45667  ENDIF
45668 C...If this is not the KF we're looking for...
45669  IF ((kforig.NE.0.AND.kf.NE.kforig).OR.mupda.NE.2) THEN
45670 C...Set block skip flag and read next line.
45671  merr=16
45672  GOTO 380
45673  ELSE
45674 C...Check whether decay table for this particle already read in
45675  DO 280 idecay=1,ndecay
45676  IF (kfdec(idecay).EQ.kf) THEN
45677  WRITE(mstu(11),'(A,A,I9,A,A6,A)')
45678  & ' * (PYSLHA:) Ignoring DECAY table ',
45679  & 'for KF =',kf,' on line ',chnlin,
45680  & ' (duplicate)'
45681  merr=16
45682  GOTO 380
45683  ENDIF
45684  280 CONTINUE
45685  ENDIF
45686 
45687 C...Determine PYTHIA KC code of particle
45688  kcrep=0
45689  IF(kf.LE.100) THEN
45690  kcrep=kf
45691  ELSE
45692  DO 290 kcr=101,kcc
45693  IF(kchg(kcr,4).EQ.kf) kcrep=kcr
45694  290 CONTINUE
45695  ENDIF
45696  kc=kcrep
45697  IF (kcrep.NE.0) THEN
45698 C...Particle is already known. Do not overwrite low-mass SM particles,
45699 C...since this could give problems at hadronization / hadron decay stage.
45700  IF (iabs(kf).LT.1000000.AND.pmas(kc,1).LT.20d0) THEN
45701 C...Set block skip flag and read next line
45702  WRITE(mstu(11),'(A,I9,A,F12.3)')
45703  & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45704  & kf, ' (SLHA read-in not allowed)'
45705  merr=16
45706  GOTO 380
45707  ENDIF
45708  ELSE
45709 C... Add new particle. Actually, this should not happen.
45710 C... New particles should be added already when reading the spectrum
45711 C... information, so go under previously stable category.
45712  kcc=kcc+1
45713  kc=kcc
45714  ENDIF
45715 
45716  IF (width.LE.0d0) THEN
45717 C...Stable (i.e. LSP)
45718  WRITE(mstu(11),'(A,I9,A,A)')
45719  & '* (PYSLHA:) Reading SLHA stable particle KF =',
45720  & kf,', ',chaf(kcrep,1)(1:16)
45721  IF (width.LT.0d0) THEN
45722  CALL pyerrm(19,'(PYSLHA:) Negative width forced to'//
45723  & ' zero !')
45724  width=0d0
45725  ENDIF
45726  pmas(kc,2)=1d-6
45727  mwid(kc)=0
45728  mdcy(kc,1)=0
45729 C...Ignore any decay lines that may be present for this KF
45730  merr=16
45731  mdcy(kc,2)=0
45732  mdcy(kc,3)=0
45733 C...Return ok
45734  iretrn=0
45735  ENDIF
45736 C...Finalize and start reading in decay modes.
45737  GOTO 380
45738  ELSEIF (mod(merr,10).GE.6) THEN
45739 C...If ignore block flag set, skip directly to next line.
45740  GOTO 170
45741  ENDIF
45742 
45743 C...READ SPECTRUM
45744  IF (mupda.EQ.0.AND.merr.EQ.0) THEN
45745  IF (chblck(1:8).EQ.'QNUMBERS'.OR.chblck(1:8).EQ.'PARTICLE')
45746  & THEN
45747  READ(chinl,*) indx, ival
45748  IF (indx.GE.1.AND.indx.LE.9) kqnum(nqnum,indx)=ival
45749  IF (indx.EQ.1) kchg(kcq,1)=ival
45750  IF (indx.EQ.3) kchg(kcq,2)=0
45751  IF (indx.EQ.3.AND.ival.EQ.3) kchg(kcq,2)=1
45752  IF (indx.EQ.3.AND.ival.EQ.-3) kchg(kcq,2)=-1
45753  IF (indx.EQ.3.AND.ival.EQ.8) kchg(kcq,2)=2
45754  IF (indx.EQ.4) THEN
45755  kchg(kcq,3)=ival
45756  IF (ival.EQ.1) THEN
45757  chtmp=chaf(kcq,1)
45758  IF (chtmp.EQ.' ') THEN
45759  WRITE(chaf(kcq,1),*) kchg(kcq,4)
45760  WRITE(chaf(kcq,2),*) -kchg(kcq,4)
45761  ELSE
45762  ilast=17
45763  300 ilast=ilast-1
45764  IF (chtmp(ilast:ilast).EQ.' ') GOTO 300
45765  IF (chtmp(ilast:ilast).EQ.'+') THEN
45766  chtmp(ilast:ilast)='-'
45767  ELSE
45768  chtmp(ilast+1:min(16,ilast+4))='bar'
45769  ENDIF
45770  chaf(kcq,2)=chtmp
45771  ENDIF
45772  ENDIF
45773  ENDIF
45774  ELSE
45775  merr=8
45776  ENDIF
45777  ELSEIF ((mupda.EQ.1.OR.mupda.EQ.5).AND.merr.EQ.0) THEN
45778 C...MASS: Mass spectrum
45779  IF (chblck(1:4).EQ.'MASS') THEN
45780  READ(chinl,*) kf, val
45781  merr=1
45782  kc=0
45783  IF (mupda.EQ.1.OR.kf.EQ.kforig.OR.kforig.EQ.0) THEN
45784 C...Read in masses for almost anything
45785  merr=0
45786  kc=pycomp(kf)
45787  IF (kc.NE.0) THEN
45788 C...Don't read in masses for special code particles
45789  IF (iabs(kf).GE.80.AND.iabs(kf).LT.100) THEN
45790  WRITE(mstu(11),'(A,I9,A,F12.3)')
45791  & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45792  & kf, ' (KF reserved by PYTHIA)'
45793  GOTO 170
45794  ENDIF
45795 C...Be careful with light SM particles / hadrons
45796  IF (pmas(kc,1).LE.20d0) THEN
45797  IF (iabs(kf).LE.22) THEN
45798  WRITE(mstu(11),'(A,I9,A,F12.3)')
45799  & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45800  & kf, ' (SLHA read-in not allowed)'
45801 
45802  GOTO 170
45803  ELSEIF (iabs(kf).GE.100.AND.iabs(kf).LT.1000000) THEN
45804  WRITE(mstu(11),'(A,I9,A,F12.3)')
45805  & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45806  & kf, ' (SLHA read-in not allowed)'
45807  GOTO 170
45808  ENDIF
45809  ENDIF
45810  mspc(1)=mspc(1)+1
45811  pmas(kc,1) = abs(val)
45812  IF (mupda.EQ.5.AND.imss(1).EQ.0) THEN
45813  WRITE(mstu(11),'(A,I9,A,F12.3)')
45814  & ' * (PYSLHA:) Reading MASS entry for KF =',
45815  & kf, ', pole mass =', val
45816  iretrn=0
45817  ENDIF
45818 C...Check Z, W and top masses
45819  IF (kf.EQ.23.AND.abs(pmas(pycomp(23),1)-91.2d0).GT.1d0)
45820  & THEN
45821  WRITE(chtmp,*) pmas(pycomp(23),1)
45822  CALL pyerrm(9,'(PYSLHA:) Note Z boson mass, M ='
45823  & //chtmp)
45824  ENDIF
45825  IF (kf.EQ.24.AND.abs(pmas(pycomp(24),1)-80.4d0).GT.1d0)
45826  & THEN
45827  WRITE(chtmp,*) pmas(pycomp(23),1)
45828  CALL pyerrm(9,'(PYSLHA:) Note W boson mass, M ='
45829  & //chtmp)
45830  ENDIF
45831  IF (kf.EQ.6.AND.abs(pmas(pycomp(6),1)-175d0).GT.25d0)
45832  & THEN
45833  WRITE(chtmp,*) pmas(pycomp(6),1)
45834  CALL pyerrm(9,'(PYSLHA:) Note top quark mass, M ='
45835  & //chtmp//'GeV')
45836  ENDIF
45837 C... Signed masses
45838  IF (kf.EQ.1000021.AND.mspc(18).EQ.0) rmss(3)=val
45839  IF (kf.EQ.1000022) smz(1)=val
45840  IF (kf.EQ.1000023) smz(2)=val
45841  IF (kf.EQ.1000025) smz(3)=val
45842  IF (kf.EQ.1000035) smz(4)=val
45843  IF (kf.EQ.1000024) smw(1)=val
45844  IF (kf.EQ.1000037) smw(2)=val
45845  ENDIF
45846  ELSEIF (mupda.EQ.5) THEN
45847  merr=0
45848  ENDIF
45849 C... MODSEL: Model selection and global switches
45850  ELSEIF (chblck(1:6).EQ.'MODSEL') THEN
45851  READ(chinl,*) indx, ival
45852  IF (indx.LE.200.AND.indx.GT.0) THEN
45853  IF (imss(1).EQ.0) imss(1)=11
45854  modsel(indx)=ival
45855  mmod(1)=mmod(1)+1
45856  IF (indx.EQ.3.AND.ival.EQ.1.AND.pycomp(1000045).EQ.0) THEN
45857 C... Switch on NMSSM
45858  WRITE(mstu(11),*) '* (PYSLHA:) switching on NMSSM'
45859  imss(13)=max(1,imss(13))
45860 C... Add NMSSM states if not already done
45861 
45862  kfn=25
45863  kcn=kfn
45864  chaf(kcn,1)='h_10'
45865  chaf(kcn,2)=' '
45866 
45867  kfn=35
45868  kcn=kfn
45869  chaf(kcn,1)='h_20'
45870  chaf(kcn,2)=' '
45871 
45872  kfn=45
45873  kcn=kfn
45874  chaf(kcn,1)='h_30'
45875  chaf(kcn,2)=' '
45876 
45877  kfn=36
45878  kcn=kfn
45879  chaf(kcn,1)='A_10'
45880  chaf(kcn,2)=' '
45881 
45882  kfn=46
45883  kcn=kfn
45884  chaf(kcn,1)='A_20'
45885  chaf(kcn,2)=' '
45886 
45887  kfn=1000045
45888  kcn=pycomp(kfn)
45889  IF (kcn.EQ.0) THEN
45890  DO 310 kct=100,mstu(6)
45891  IF(kchg(kct,4).GT.100) kcn=kct
45892  310 CONTINUE
45893  kcn=kcn+1
45894  kchg(kcn,4)=kfn
45895  mstu(20)=0
45896  ENDIF
45897 C... Set stable for now
45898  pmas(kcn,2)=1d-6
45899  mwid(kcn)=0
45900  mdcy(kcn,1)=0
45901  mdcy(kcn,2)=0
45902  mdcy(kcn,3)=0
45903  chaf(kcn,1)='~chi_50'
45904  chaf(kcn,2)=' '
45905  ENDIF
45906  ELSE
45907  merr=1
45908  ENDIF
45909  ELSEIF (mupda.EQ.5) THEN
45910 C...If MUPDA = 5, skip all except MASS, return if MODSEL
45911  merr=8
45912  ELSEIF (chblck(1:8).EQ.'QNUMBERS'.OR.
45913  & chblck(1:8).EQ.'PARTICLE') THEN
45914 C...Don't print a warning for QNUMBERS when reading spectrum
45915  merr=8
45916 C...MINPAR: Minimal model parameters
45917  ELSEIF (chblck(1:6).EQ.'MINPAR') THEN
45918  READ(chinl,*) indx, val
45919  IF (indx.LE.100.AND.indx.GT.0) THEN
45920  parmin(indx)=val
45921  mmod(2)=mmod(2)+1
45922  ELSE
45923  merr=1
45924  ENDIF
45925  IF (mmod(3).NE.0) THEN
45926  WRITE(mstu(11),*)
45927  & '* (PYSLHA:) MINPAR should come before EXTPAR !'
45928  merr=1
45929  ENDIF
45930 C...tan(beta)
45931  IF (indx.EQ.3) rmss(5)=val
45932 C...EXTPAR: non-minimal model parameters.
45933  ELSEIF (chblck(1:6).EQ.'EXTPAR') THEN
45934  IF (mmod(1).NE.0) THEN
45935  READ(chinl,*) indx, val
45936  IF (indx.LE.200.AND.indx.GT.0) THEN
45937  parext(indx)=val
45938  mmod(3)=mmod(3)+1
45939  ELSE
45940  merr=1
45941  ENDIF
45942  ELSE
45943  WRITE(mstu(11),*)
45944  & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
45945  merr=1
45946  ENDIF
45947 C...tan(beta)
45948  IF (indx.EQ.25) rmss(5)=val
45949  ELSEIF (chblck(1:8).EQ.'SMINPUTS') THEN
45950  READ(chinl,*) indx, val
45951  IF (indx.LE.3.OR.indx.EQ.5.OR.indx.GE.7) THEN
45952  merr=1
45953  ELSEIF (indx.EQ.4) THEN
45954  pmas(pycomp(23),1)=val
45955  ELSEIF (indx.EQ.6) THEN
45956  pmas(pycomp(6),1)=val
45957  ENDIF
45958  ELSEIF (chblck(1:4).EQ.'NMIX'.OR.chblck(1:4).EQ.'VMIX'.or
45959  $ .chblck(1:4).EQ.'UMIX'.OR.chblck(1:7).EQ.'STOPMIX'.or
45960  $ .chblck(1:7).EQ.'SBOTMIX'.OR.chblck(1:7).EQ.'STAUMIX')
45961  $ THEN
45962 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
45963  im=0
45964  IF (chblck(5:6).EQ.'IM') im=1
45965  320 READ(chinl,*) indx1, indx2, val
45966  IF (chblck(1:1).EQ.'N'.AND.indx1.LE.4.AND.indx2.LE.4) THEN
45967  IF (im.EQ.0) zmix(indx1,indx2) = val
45968  IF (im.EQ.1) zmixi(indx1,indx2)= val
45969  mspc(2)=mspc(2)+1
45970  ELSEIF (chblck(1:1).EQ.'U') THEN
45971  IF (im.EQ.0) umix(indx1,indx2) = val
45972  IF (im.EQ.1) umixi(indx1,indx2)= val
45973  mspc(3)=mspc(3)+1
45974  ELSEIF (chblck(1:1).EQ.'V') THEN
45975  IF (im.EQ.0) vmix(indx1,indx2) = val
45976  IF (im.EQ.1) vmixi(indx1,indx2)= val
45977  mspc(4)=mspc(4)+1
45978  ELSEIF (chblck(1:4).EQ.'STOP'.OR.chblck(1:4).EQ.'SBOT'.or
45979  $ .chblck(1:4).EQ.'STAU') THEN
45980  IF (chblck(1:4).EQ.'STOP') THEN
45981  kfsm=6
45982  ispc=6
45983  ELSEIF (chblck(1:4).EQ.'SBOT') THEN
45984  kfsm=5
45985  ispc=5
45986  ELSEIF (chblck(1:4).EQ.'STAU') THEN
45987  kfsm=15
45988  ispc=7
45989  ENDIF
45990 C...Set SFMIX element
45991  sfmix(kfsm,2*(indx1-1)+indx2)=val
45992  mspc(ispc)=mspc(ispc)+1
45993  ENDIF
45994 C...Running parameters
45995  ELSEIF (chblck(1:4).EQ.'HMIX') THEN
45996  READ(chblck(8:25),*,err=620) q
45997  READ(chinl,*) indx, val
45998  mspc(8)=mspc(8)+1
45999  IF (indx.EQ.1) THEN
46000  rmss(4) = val
46001  ELSE
46002  merr=1
46003  mspc(8)=mspc(8)-1
46004  ENDIF
46005  ELSEIF (chblck(1:5).EQ.'ALPHA') THEN
46006  READ(chinl,*,err=630) val
46007  rmss(18)= val
46008  mspc(17)=mspc(17)+1
46009 C...Higgs parameters set manually or with FeynHiggs.
46010  imss(4)=max(2,imss(4))
46011  ELSEIF (chblck(1:2).EQ.'AU'.OR.chblck(1:2).EQ.'AD'.or
46012  & .chblck(1:2).EQ.'AE') THEN
46013  READ(chblck(9:26),*,err=620) q
46014  READ(chinl,*) indx1, indx2, val
46015  IF (chblck(2:2).EQ.'U') THEN
46016  au(indx1,indx2)=val
46017  IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(16)=val
46018  mspc(11)=mspc(11)+1
46019  ELSEIF (chblck(2:2).EQ.'D') THEN
46020  ad(indx1,indx2)=val
46021  IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(15)=val
46022  mspc(10)=mspc(10)+1
46023  ELSEIF (chblck(2:2).EQ.'E') THEN
46024  ae(indx1,indx2)=val
46025  IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(17)=val
46026  mspc(12)=mspc(12)+1
46027  ELSE
46028  merr=1
46029  ENDIF
46030  ELSEIF (chblck(1:5).EQ.'MSOFT') THEN
46031  IF (mspc(18).EQ.0) THEN
46032  READ(chblck(9:25),*,err=620) q
46033  rmsoft(0)=q
46034  ENDIF
46035  READ(chinl,*) indx, val
46036  rmsoft(indx)=val
46037  mspc(18)=mspc(18)+1
46038  ELSEIF (chblck(1:5).EQ.'GAUGE') THEN
46039  merr=8
46040  ELSEIF (chblck(1:2).EQ.'YU'.OR.chblck(1:2).EQ.'YD'.or
46041  & .chblck(1:2).EQ.'YE') THEN
46042  merr=8
46043  ELSEIF (chblck(1:6).EQ.'SPINFO') THEN
46044  READ(chinl(1:6),*) indx
46045  it=0
46046  mird=0
46047  330 it=it+1
46048  IF (chinl(it:it).EQ.' ') GOTO 330
46049 C...Don't read index
46050  IF (chinl(it:it).EQ.char(indx+48).AND.mird.EQ.0) THEN
46051  mird=1
46052  GOTO 330
46053  ENDIF
46054  IF (indx.EQ.1) cpro(1)=chinl(it:it+12)
46055  IF (indx.EQ.2) cver(1)=chinl(it:it+12)
46056  ELSE
46057 C... Set unrecognized block flag.
46058  merr=6
46059  ENDIF
46060 
46061 C...DECAY TABLES
46062 C...Read in decay information
46063  ELSEIF (mupda.EQ.2.AND.merr.EQ.0) THEN
46064 C...Read new decay chanel
46065  IF(chinl(1:1).EQ.' '.AND.chblck(1:5).EQ.'DECAY') THEN
46066  ndc=ndc+1
46067 C...Read in branching ratio and number of daughters for this mode.
46068  READ(chinl(4:50),*,err=390) brat(ndc)
46069  READ(chinl(4:50),*,err=600) dum, nda
46070  IF (nda.LE.5) THEN
46071  IF(ndc.GT.mstu(7)) CALL pyerrm(27,
46072  & '(PYSLHA:) Decay data arrays full by KF = '
46073  $ //chaf(kc,1))
46074 C...If first decay channel, set decays start point in decay table
46075  IF(brsum.LE.0d0.AND.brat(ndc).NE.0d0) THEN
46076  IF (kforig.EQ.0) WRITE(mstu(11),'(1x,A,I9,A,A16)')
46077  & '* (PYSLHA:) Reading DECAY table for '//
46078  & 'KF =',kf,', ',chaf(kcrep,1)(1:16)
46079 C...Set particle parameters (mass set when reading BLOCK MASS above)
46080  pmas(kc,2)=width
46081  IF (kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) THEN
46082  WRITE(mstu(11),'(1x,A)')
46083  & '* Note: the Pythia gg->h/H/A cross section'//
46084  & ' is proportional to the h/H/A->gg width'
46085  ELSEIF (kf.EQ.23.OR.kf.EQ.24.OR.kf.EQ.6.OR.kf.EQ.32
46086  & .OR.kf.EQ.33.OR.kf.EQ.34) THEN
46087  WRITE(mstu(11),'(1x,A,A16)')
46088  & '* Warning: will use DECAY table (fixed-width,'//
46089  & ' flat PS) for ',chaf(kc,1)(1:16)
46090  ENDIF
46091  pmas(kc,3)=0d0
46092  pmas(kc,4)=paru(3)*1d-12/width
46093  mwid(kc)=2
46094  mdcy(kc,1)=1
46095  mdcy(kc,2)=ndc
46096  mdcy(kc,3)=0
46097 C...Add to list of DECAY blocks currently read
46098  ndecay=ndecay+1
46099  kfdec(ndecay)=kf
46100 C...Return ok
46101  iretrn=0
46102  ENDIF
46103 C... Count up number of decay modes for this particle
46104  mdcy(kc,3)=mdcy(kc,3)+1
46105 C... Read in decay daughters.
46106  READ(chinl(4:120),*,err=610) dum,idm, (idc(ida),ida=1,nda)
46107 C... Flip sign if reading antiparticle decays (if antipartner exists)
46108  DO 340 ida=1,nda
46109  IF (kchg(pycomp(idc(ida)),3).NE.0)
46110  & idc(ida)=mpsign*idc(ida)
46111  340 CONTINUE
46112 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46113  mdme(ndc,1)=1
46114  IF (brat(ndc).LE.0d0) mdme(ndc,1)=0
46115  brsum=brsum+abs(brat(ndc))
46116  brat(ndc)=abs(brat(ndc))
46117  350 iflip=0
46118  DO 360 ida=1,nda-1
46119  IF (iabs(idc(ida+1)).GT.iabs(idc(ida))) THEN
46120  itmp=idc(ida)
46121  idc(ida)=idc(ida+1)
46122  idc(ida+1)=itmp
46123  iflip=iflip+1
46124  ENDIF
46125  360 CONTINUE
46126  IF (iflip.GT.0) GOTO 350
46127 C...Treat as ordinary decay, no fancy stuff.
46128  mdme(ndc,2)=0
46129  DO 370 ida=1,5
46130  IF (ida.LE.nda) THEN
46131  kfdp(ndc,ida)=idc(ida)
46132  ELSE
46133  kfdp(ndc,ida)=0
46134  ENDIF
46135  370 CONTINUE
46136 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46137 C & (KFDP(NDC,J),J=1,NDA)
46138  ELSE
46139  CALL pyerrm(7,'(PYSLHA:) Too many daughters on line '//
46140  & chnlin)
46141  merr=11
46142  ndc=ndc-1
46143  ENDIF
46144  ELSEIF(chinl(1:1).EQ.'+') THEN
46145  merr=11
46146  ELSEIF(chblck(1:6).EQ.'DCINFO') THEN
46147  merr=16
46148  ELSE
46149  merr=16
46150  ENDIF
46151  ENDIF
46152 C... Error check.
46153  380 IF (mod(merr,10).EQ.1.AND.(mupda.EQ.1.OR.mupda.EQ.2)) THEN
46154  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring line '//chnlin//': '
46155  & //chinl(1:40)
46156  merr=0
46157  ELSEIF (merr.EQ.6.AND.mupda.EQ.1) THEN
46158  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46159  & chblck(1:min(inl,40))//'... on line '//chnlin
46160  ELSEIF (merr.EQ.8.AND.mupda.EQ.1) THEN
46161  WRITE(mstu(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46162  & //chblck(1:inl)//'... on line'//chnlin
46163  ELSEIF (merr.EQ.16.AND.mupda.EQ.2.AND.imss21.EQ.0.AND.
46164  & chblck(1:1).NE.'D'.AND.verbos.EQ.1) THEN
46165  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring BLOCK '//chblck(1:inl)
46166  & //'... on line'//chnlin
46167  ELSEIF (merr.EQ.7.AND.mupda.EQ.1) THEN
46168  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46169  & /chblck(1:inl)//'... on line'//chnlin
46170  ELSEIF (merr.EQ.2.AND.mupda.EQ.1) THEN
46171  WRITE (chtmp,*) kf
46172  WRITE(mstu(11),*)
46173  & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46174  & chtmp(1:9)//' on line'//chnlin
46175  ENDIF
46176 C...Iterate read loop
46177  GOTO 170
46178 C...Error catching
46179  390 WRITE(*,*) '* (PYSLHA:) read BR error on line',nline,
46180  & ', ignoring subsequent lines.'
46181  WRITE(*,*) '* (PYSLHA:) Offending line:',chinl(1:46)
46182  chblck=' '
46183  GOTO 170
46184 C...End of read loop
46185  400 CONTINUE
46186 C...Set flag that KC codes have been rearranged.
46187  mstu(20)=0
46188  verbos=0
46189 
46190 C...Perform possible tests that new information is consistent.
46191  IF (mupda.EQ.1) THEN
46192  mstu23=mstu(23)
46193  mstu27=mstu(27)
46194 C...Check masses
46195  DO 410 isusy=1,37
46196  kf=kfsusy(isusy)
46197 C...Don't complain about right-handed neutrinos
46198  IF (kf.EQ.ksusy2+12.OR.kf.EQ.ksusy2+14.OR.kf.EQ.ksusy2
46199  & +16) GOTO 410
46200 C...Only check gravitino in GMSB scenarios
46201  IF (modsel(1).NE.2.AND.kf.EQ.ksusy1+39) GOTO 410
46202  kc=pycomp(kf)
46203  IF (pmas(kc,1).EQ.0d0) THEN
46204  WRITE(chtmp,*) kf
46205  CALL pyerrm(9
46206  & ,'(PYSLHA:) No mass information found for KF ='
46207  & //chtmp)
46208  ENDIF
46209  410 CONTINUE
46210 C...Check mixing matrices (MSSM only)
46211  IF (imss(13).EQ.0) THEN
46212  IF (mspc(2).NE.16.AND.mspc(2).NE.32) CALL pyerrm(9
46213  & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46214  IF (mspc(3).NE.4.AND.mspc(3).NE.8) CALL pyerrm(9
46215  & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46216  IF (mspc(4).NE.4.AND.mspc(4).NE.8) CALL pyerrm(9
46217  & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46218  IF (mspc(5).NE.4) CALL pyerrm(9
46219  & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46220  IF (mspc(6).NE.4) CALL pyerrm(9
46221  & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46222  IF (mspc(7).NE.4) CALL pyerrm(9
46223  & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46224  IF (mspc(8).LT.1) CALL pyerrm(9
46225  & ,'(PYSLHA:) Too few elements in HMIX')
46226  IF (mspc(10).EQ.0) CALL pyerrm(9
46227  & ,'(PYSLHA:) Missing A_b trilinear coupling')
46228  IF (mspc(11).EQ.0) CALL pyerrm(9
46229  & ,'(PYSLHA:) Missing A_t trilinear coupling')
46230  IF (mspc(12).EQ.0) CALL pyerrm(9
46231  & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46232  IF (mspc(17).LT.1) CALL pyerrm(9
46233  & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46234  ENDIF
46235 C...Check wavefunction normalizations.
46236 C...Sfermions
46237  DO 420 ispc=5,7
46238  IF (mspc(ispc).EQ.4) THEN
46239  kfsm=ispc
46240  IF (ispc.EQ.7) kfsm=15
46241  check=abs(sfmix(kfsm,1)*sfmix(kfsm,4)-sfmix(kfsm,2)
46242  & *sfmix(kfsm,3))
46243  IF (abs(1d0-check).GT.1d-3) THEN
46244  kcsm=pycomp(kfsm)
46245  CALL pyerrm(17
46246  & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46247  & //chaf(kcsm,1))
46248  ENDIF
46249 C...Bug fix 30/09 2008: PS
46250 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46251  IF (sfmix(kfsm,1)*sfmix(kfsm,4).LT.0d0) THEN
46252  sfmix(kfsm,3) = -sfmix(kfsm,3)
46253  sfmix(kfsm,4) = -sfmix(kfsm,4)
46254  ENDIF
46255  ENDIF
46256  420 CONTINUE
46257 C...Neutralinos + charginos
46258  DO 440 j=1,4
46259  cn1=0d0
46260  cn2=0d0
46261  cu1=0d0
46262  cu2=0d0
46263  cv1=0d0
46264  cv2=0d0
46265  DO 430 l=1,4
46266  cn1=cn1+zmix(j,l)**2
46267  cn2=cn2+zmix(l,j)**2
46268  IF (j.LE.2.AND.l.LE.2) THEN
46269  cu1=cu1+umix(j,l)**2
46270  cu2=cu2+umix(l,j)**2
46271  cv1=cv1+vmix(j,l)**2
46272  cv2=cv2+vmix(l,j)**2
46273  ENDIF
46274  430 CONTINUE
46275 C...NMIX normalization
46276  IF (mspc(2).EQ.16.AND.(abs(1d0-cn1).GT.1d-3.OR.abs(1d0-cn2)
46277  & .GT.1d-3).AND.imss(13).EQ.0) THEN
46278  CALL pyerrm(19,
46279  & '(PYSLHA:) NMIX: Inconsistent normalization.')
46280  WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F7.4))') j, cn1, cn2
46281  ENDIF
46282 C...UMIX, VMIX normalizations
46283  IF (mspc(3).EQ.4.OR.mspc(4).EQ.4.AND.imss(13).EQ.0) THEN
46284  IF (j.LE.2) THEN
46285  IF (abs(1d0-cu1).GT.1d-3.OR.abs(1d0-cu2).GT.1d-3) THEN
46286  CALL pyerrm(19
46287  & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46288  WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F6.2))') j, cu1,
46289  & cu2
46290  ENDIF
46291  IF (abs(1d0-cv1).GT.1d-3.OR.abs(1d0-cv2).GT.1d-3) THEN
46292  CALL pyerrm(19,
46293  & '(PYSLHA:) VMIX: Inconsistent normalization.')
46294  WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F6.2))') j, cv1,
46295  & cv2
46296  ENDIF
46297  ENDIF
46298  ENDIF
46299  440 CONTINUE
46300  IF (mstu(27).EQ.mstu27.AND.mstu(23).EQ.mstu23) THEN
46301  WRITE(mstu(11),'(1x,"*"/1x,A/1x,"*")')
46302  & '* (PYSLHA:) No spectrum inconsistencies were found.'
46303  ELSE
46304  WRITE(mstu(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46305  & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46306  & ,' Warning: one or more (serious)'//
46307  & ' inconsistencies were found in the spectrum !'
46308  & ,' Read the error messages above and check your'//
46309  & ' input file.'
46310  ENDIF
46311 C...Increase precision in Higgs sector using FeynHiggs
46312  IF (imss(4).EQ.3) THEN
46313 C...FeynHiggs needs MSOFT.
46314  ierr=0
46315  IF (mspc(18).EQ.0) THEN
46316  WRITE(mstu(11),'(1x,"*"/1x,A/)')
46317  & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46318  & ' Cannot call FeynHiggs.'
46319  ierr=-1
46320  ELSE
46321  WRITE(mstu(11),'(1x,/1x,A/)')
46322  & '* (PYSLHA:) Now calling FeynHiggs.'
46323  CALL pyfeyn(ierr)
46324  IF (ierr.NE.0) imss(4)=2
46325  ENDIF
46326  ENDIF
46327  ELSEIF (mupda.EQ.2.AND.iretrn.EQ.0.AND.merr.NE.16) THEN
46328  ibeg=1
46329  IF (kforig.NE.0) ibeg=ndecay
46330  DO 490 idecay=ibeg,ndecay
46331  kf = kfdec(idecay)
46332  kc = pycomp(kf)
46333  WRITE(chkf,8300) kf
46334  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3
46335  $ ),pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0.OR.(mdcy(kc,3)
46336  $ .EQ.0.AND.mdcy(kc,1).GE.1)) CALL pyerrm(17
46337  $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46338  $ //chkf)
46339  brsum=0d0
46340  bropn=0d0
46341  DO 460 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46342  IF(mdme(ida,2).GT.80) GOTO 460
46343  kq=kchg(kc,1)
46344  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
46345  merr=0
46346  DO 450 j=1,5
46347  kp=kfdp(ida,j)
46348  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
46349  IF(kp.EQ.81) kq=0
46350  ELSEIF(pycomp(kp).EQ.0) THEN
46351  merr=3
46352  ELSE
46353  kq=kq-pychge(kp)
46354  kpc=pycomp(kp)
46355  pms=pms-pmas(kpc,1)
46356  IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
46357  & pmas(kpc,3))
46358  ENDIF
46359  450 CONTINUE
46360  IF(kq.NE.0) merr=max(2,merr)
46361  IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
46362  & merr=max(1,merr)
46363  IF(merr.EQ.3) CALL pyerrm(17,
46364  & '(PYSLHA:) Unknown particle code in decay of KF ='
46365  $ //chkf)
46366  IF(merr.EQ.2) CALL pyerrm(17,
46367  & '(PYSLHA:) Charge not conserved in decay of KF ='
46368  $ //chkf)
46369  IF(merr.EQ.1) CALL pyerrm(7,
46370  & '(PYSLHA:) Kinematically unallowed decay of KF ='
46371  $ //chkf)
46372  brsum=brsum+brat(ida)
46373  IF (mdme(ida,1).GT.0) bropn=bropn+brat(ida)
46374  460 CONTINUE
46375 C...Check branching ratio sum.
46376  IF (bropn.LE.0d0) THEN
46377 C...If zero, set stable.
46378  WRITE(chtmp,8500) bropn
46379  CALL pyerrm(7
46380  & ,"(PYSLHA:) Effective BR sum for KF="//chkf//' is '//
46381  & chtmp(9:16)//'. Changed to stable.')
46382  pmas(kc,2)=1d-6
46383  mwid(kc)=0
46384 C...If BR's > 1, rescale.
46385  ELSEIF (brsum.GT.(1d0+1d-6)) THEN
46386  WRITE(chtmp,8500) brsum
46387  IF (brsum.GT.(1d0+1d-3)) CALL pyerrm(7
46388  & ,"(PYSLHA:) Forced rescaling of BR's for KF="//chkf//
46389  & ' ; sum was'//chtmp(9:16)//'.')
46390  fac=1d0/brsum
46391  DO 470 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46392  IF(mdme(ida,2).GT.80) GOTO 470
46393  brat(ida)=fac*brat(ida)
46394  470 CONTINUE
46395  ELSEIF (brsum.LT.(1d0-1d-6)) THEN
46396 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46397  WRITE(chtmp,8500) brsum
46398  IF (brsum.LT.(1d0-1d-3)) CALL pyerrm(7
46399  & ,"(PYSLHA:) Sum of BR's for KF="//chkf//' is '//
46400  & chtmp(9:16)//'. Dummy mode will be inserted.')
46401 C...Move table and insert dummy mode
46402  DO 480 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46403  ndc=ndc+1
46404  brat(ndc)=brat(ida)
46405  kfdp(ndc,1)=kfdp(ida,1)
46406  kfdp(ndc,2)=kfdp(ida,2)
46407  kfdp(ndc,3)=kfdp(ida,3)
46408  kfdp(ndc,4)=kfdp(ida,4)
46409  kfdp(ndc,5)=kfdp(ida,5)
46410  mdme(ndc,1)=mdme(ida,1)
46411  480 CONTINUE
46412  ndc=ndc+1
46413  brat(ndc)=1d0-brsum
46414  kfdp(ndc,1)=0
46415  kfdp(ndc,2)=0
46416  kfdp(ndc,3)=0
46417  kfdp(ndc,4)=0
46418  kfdp(ndc,5)=0
46419  mdme(ndc,1)=0
46420  brsum=1d0
46421 C...Update MDCY
46422  mdcy(kc,3)=mdcy(kc,3)+1
46423  mdcy(kc,2)=ndc-mdcy(kc,3)+1
46424  ENDIF
46425  490 CONTINUE
46426  ENDIF
46427 
46428 
46429 C...WRITE SPECTRUM ON SLHA FILE
46430  ELSEIF(mupda.EQ.3) THEN
46431 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46432  IF (imss(1).EQ.2.OR.imss(1).EQ.12) THEN
46433  modsel(1)=1
46434  parmin(1)=rmss(8)
46435  parmin(2)=rmss(1)
46436  parmin(3)=rmss(5)
46437  parmin(4)=sign(1d0,rmss(4))
46438  parmin(5)=rmss(36)
46439  ENDIF
46440 C...Write spectrum
46441  WRITE(lfn,7000) 'SLHA MSSM spectrum'
46442  WRITE(lfn,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46443  & // ' P. Skands.'
46444  WRITE(lfn,7010) 'MODSEL', 'Model selection'
46445  WRITE(lfn,7110) 1, modsel(1)
46446  WRITE(lfn,7010) 'MINPAR', 'Parameters for minimal model.'
46447  IF (modsel(1).EQ.1) THEN
46448  WRITE(lfn,7210) 1, parmin(1), 'm0'
46449  WRITE(lfn,7210) 2, parmin(2), 'm12'
46450  WRITE(lfn,7210) 3, parmin(3), 'tan(beta)'
46451  WRITE(lfn,7210) 4, parmin(4), 'sign(mu)'
46452  WRITE(lfn,7210) 5, parmin(5), 'a0'
46453  ELSEIF(modsel(2).EQ.2) THEN
46454  WRITE(lfn,7210) 1, parmin(1), 'Lambda'
46455  WRITE(lfn,7210) 2, parmin(2), 'M'
46456  WRITE(lfn,7210) 3, parmin(3), 'tan(beta)'
46457  WRITE(lfn,7210) 4, parmin(4), 'sign(mu)'
46458  WRITE(lfn,7210) 5, parmin(5), 'N5'
46459  WRITE(lfn,7210) 6, parmin(6), 'c_grav'
46460  ENDIF
46461  WRITE(lfn,7000) ' '
46462  WRITE(lfn,7010) 'MASS', 'Mass spectrum'
46463  DO 500 i=1,36
46464  kf=kfsusy(i)
46465  kc=pycomp(kf)
46466  IF (kf.EQ.1000039.AND.modsel(1).NE.2) GOTO 500
46467  kfsm=kf-ksusy1
46468  IF (kfsm.GE.22.AND.kfsm.LE.37) THEN
46469  IF (kfsm.EQ.22) WRITE(lfn,7220) kf, smz(1), chaf(kc,1)
46470  IF (kfsm.EQ.23) WRITE(lfn,7220) kf, smz(2), chaf(kc,1)
46471  IF (kfsm.EQ.25) WRITE(lfn,7220) kf, smz(3), chaf(kc,1)
46472  IF (kfsm.EQ.35) WRITE(lfn,7220) kf, smz(4), chaf(kc,1)
46473  IF (kfsm.EQ.24) WRITE(lfn,7220) kf, smw(1), chaf(kc,1)
46474  IF (kfsm.EQ.37) WRITE(lfn,7220) kf, smw(2), chaf(kc,1)
46475  ELSE
46476  WRITE(lfn,7220) kf, pmas(kc,1), chaf(kc,1)
46477  ENDIF
46478  500 CONTINUE
46479 C...SUSY scale
46480  rmsusy=sqrt(pmas(pycomp(ksusy1+6),1)*pmas(pycomp(ksusy2+6),1))
46481  WRITE(lfn,7020) 'HMIX',rmsusy,'Higgs parameters'
46482  WRITE(lfn,7210) 1, rmss(4),'mu'
46483  WRITE(lfn,7010) 'ALPHA',' '
46484  WRITE(lfn,7210) 1, rmss(18), 'alpha'
46485  WRITE(lfn,7020) 'AU',rmsusy
46486  WRITE(lfn,7410) 3, 3, rmss(16), 'A_t'
46487  WRITE(lfn,7020) 'AD',rmsusy
46488  WRITE(lfn,7410) 3, 3, rmss(15), 'A_b'
46489  WRITE(lfn,7020) 'AE',rmsusy
46490  WRITE(lfn,7410) 3, 3, rmss(17), 'A_tau'
46491  WRITE(lfn,7010) 'STOPMIX','~t mixing matrix'
46492  WRITE(lfn,7410) 1, 1, sfmix(6,1)
46493  WRITE(lfn,7410) 1, 2, sfmix(6,2)
46494  WRITE(lfn,7410) 2, 1, sfmix(6,3)
46495  WRITE(lfn,7410) 2, 2, sfmix(6,4)
46496  WRITE(lfn,7010) 'SBOTMIX','~b mixing matrix'
46497  WRITE(lfn,7410) 1, 1, sfmix(5,1)
46498  WRITE(lfn,7410) 1, 2, sfmix(5,2)
46499  WRITE(lfn,7410) 2, 1, sfmix(5,3)
46500  WRITE(lfn,7410) 2, 2, sfmix(5,4)
46501  WRITE(lfn,7010) 'STAUMIX','~tau mixing matrix'
46502  WRITE(lfn,7410) 1, 1, sfmix(15,1)
46503  WRITE(lfn,7410) 1, 2, sfmix(15,2)
46504  WRITE(lfn,7410) 2, 1, sfmix(15,3)
46505  WRITE(lfn,7410) 2, 2, sfmix(15,4)
46506  WRITE(lfn,7010) 'NMIX','~chi0 mixing matrix'
46507  DO 520 i1=1,4
46508  DO 510 i2=1,4
46509  WRITE(lfn,7410) i1, i2, zmix(i1,i2)
46510  510 CONTINUE
46511  520 CONTINUE
46512  WRITE(lfn,7010) 'UMIX','~chi^+ U mixing matrix'
46513  DO 540 i1=1,2
46514  DO 530 i2=1,2
46515  WRITE(lfn,7410) i1, i2, umix(i1,i2)
46516  530 CONTINUE
46517  540 CONTINUE
46518  WRITE(lfn,7010) 'VMIX','~chi^+ V mixing matrix'
46519  DO 560 i1=1,2
46520  DO 550 i2=1,2
46521  WRITE(lfn,7410) i1, i2, vmix(i1,i2)
46522  550 CONTINUE
46523  560 CONTINUE
46524  WRITE(lfn,7010) 'SPINFO'
46525  IF (imss(1).EQ.2) THEN
46526  cpro(1)='PYTHIA'
46527  cver(1)='6.4'
46528  ELSEIF (imss(1).EQ.12) THEN
46529  isaver=visaje()
46530  cpro(1)='ISASUSY'
46531  cver(1)=isaver(1:12)
46532  ENDIF
46533  WRITE(lfn,7310) 1, cpro(1), 'Spectrum Calculator'
46534  WRITE(lfn,7310) 2, cver(1), 'Version number'
46535  ENDIF
46536 
46537 C...Print user information about spectrum
46538  IF (mupda.EQ.1.OR.mupda.EQ.3) THEN
46539  IF (cpro(mod(mupda,2)).NE.' '.AND.cver(mod(mupda,2)).NE.' ')
46540  & WRITE(mstu(11),5030) cpro(1), cver(1)
46541  IF (imss(4).EQ.3) WRITE(mstu(11),5040)
46542  IF (mupda.EQ.1) THEN
46543  WRITE(mstu(11),5020) lfn
46544  ELSE
46545  WRITE(mstu(11),5010) lfn
46546  ENDIF
46547 
46548  WRITE(mstu(11),5400)
46549  WRITE(mstu(11),5500) 'Pole masses'
46550  WRITE(mstu(11),5700) (rmfun(ksusy1+ip),ip=1,6)
46551  $ ,(rmfun(ksusy2+ip),ip=1,6)
46552  WRITE(mstu(11),5800) (rmfun(ksusy1+ip),ip=11,16)
46553  $ ,(rmfun(ksusy2+ip),ip=11,16)
46554  IF (imss(13).EQ.0) THEN
46555  WRITE(mstu(11),5900) rmfun(ksusy1+21),rmfun(ksusy1+22)
46556  $ ,rmfun(ksusy1+23),rmfun(ksusy1+25),rmfun(ksusy1+35),
46557  $ rmfun(ksusy1+24),rmfun(ksusy1+37)
46558  WRITE(mstu(11),6000) chaf(25,1),chaf(35,1),chaf(36,1),
46559  & chaf(37,1), ' ', ' ',' ',' ',
46560  & rmfun(25), rmfun(35), rmfun(36), rmfun(37)
46561  ELSEIF (imss(13).EQ.1) THEN
46562  kf1=ksusy1+21
46563  kf2=ksusy1+22
46564  kf3=ksusy1+23
46565  kf4=ksusy1+25
46566  kf5=ksusy1+35
46567  kf6=ksusy1+45
46568  kf7=ksusy1+24
46569  kf8=ksusy1+37
46570  WRITE(mstu(11),6000) chaf(pycomp(kf1),1),chaf(pycomp(kf2),1),
46571  & chaf(pycomp(kf3),1),chaf(pycomp(kf4),1),
46572  & chaf(pycomp(kf5),1),chaf(pycomp(kf6),1),
46573  & chaf(pycomp(kf7),1),chaf(pycomp(kf8),1),
46574  & rmfun(kf1),rmfun(kf2),rmfun(kf3),rmfun(kf4),
46575  & rmfun(kf5),rmfun(kf6),rmfun(kf7),rmfun(kf8)
46576  WRITE(mstu(11),6000) chaf(25,1), chaf(35,1), chaf(45,1),
46577  & chaf(36,1), chaf(46,1), chaf(37,1),' ',' ',
46578  & rmfun(25), rmfun(35), rmfun(45), rmfun(36), rmfun(46),
46579  & rmfun(37)
46580  ENDIF
46581  WRITE(mstu(11),5400)
46582  WRITE(mstu(11),5500) 'Mixing structure'
46583  WRITE(mstu(11),6100) ((zmix(i,j), j=1,4),i=1,4)
46584  WRITE(mstu(11),6200) (umix(1,j), j=1,2),(vmix(1,j),j=1,2)
46585  & ,(umix(2,j), j=1,2),(vmix(2,j),j=1,2)
46586  WRITE(mstu(11),6300) (sfmix(5,j), j=1,2),(sfmix(6,j),j=1,2)
46587  & ,(sfmix(15,j), j=1,2),(sfmix(5,j),j=3,4),(sfmix(6,j), j=3,4
46588  & ),(sfmix(15,j),j=3,4)
46589  WRITE(mstu(11),5400)
46590  WRITE(mstu(11),5500) 'Couplings'
46591  WRITE(mstu(11),6400) rmss(15),rmss(16),rmss(17)
46592  WRITE(mstu(11),6450) rmss(18), rmss(5), rmss(4)
46593  WRITE(mstu(11),5400)
46594  WRITE(mstu(11),6500)
46595 
46596  ENDIF
46597 
46598 C...Only rewind when reading
46599  IF (mupda.LE.2.OR.mupda.EQ.5) rewind(lfn)
46600 
46601  9999 RETURN
46602 
46603 C...Serious error catching
46604  580 write(*,*) '* (PYSLHA:) read BLOCK error on line',nline
46605  write(*,*) chinl(1:80)
46606  CALL pystop(106)
46607  590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',nline
46608  WRITE(*,*) chinl(1:72)
46609  CALL pystop(106)
46610  600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',nline
46611  WRITE(*,*) chinl(1:80)
46612  CALL pystop(106)
46613  610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',nline
46614  WRITE(*,*) chinl(1:80)
46615  620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',chblck
46616  CALL pystop(106)
46617  630 WRITE(*,*) '* (PYSLHA:) read error in line ',nline,':'
46618  WRITE(*,*) chinl(1:80)
46619  CALL pystop(106)
46620 
46621  8300 FORMAT(i9)
46622  8500 FORMAT(f16.5)
46623 
46624 C...Formats for user information printout.
46625  5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.12: SUSY/BSM SPECTRUM '
46626  & ,'INTERFACE',1x,17('*')/1x,'*',1x
46627  & ,'(PYSLHA:) Last Change',1x,a,1x,'-',1x,'P.Z. Skands')
46628  5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',i3)
46629  5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',i3)
46630  5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',a,' version ',a)
46631  5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46632  5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46633  5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46634  & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(f8.2,1x),i8,2x,f8.2)
46635  5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46636  & ,'----------------')
46637  5400 FORMAT(1x,'*',1x,a)
46638  5500 FORMAT(1x,'*',1x,a,':')
46639  5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46640  & 1x,'*',2x,1p,2(1x,e8.2),2x,e8.2)
46641  5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46642  & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46643  & ,6(f8.2,1x)/1x,'*',2x,'R',1x,6(f8.2,1x))
46644  5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46645  & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46646  & ,'L',1x,6(f8.2,1x)/1x,'*',2x,'R',1x,6(f8.2,1x))
46647  5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46648  & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46649  & ,1x,'~chi_2+'/1x,'*',3x,1x,7(f8.2,1x))
46650  6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,a7,1x)/1x,'*',3x,1x,8(f8.2,1x))
46651  6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46652  & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46653  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46654  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46655  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46656  & ,1x,f6.3,1x),'|')
46657  6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46658  & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46659  & ,'~chi_1+',1x,2('|',1x,f6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46660  & ,f6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,f6.3,1x),'|',9x
46661  & ,'~chi_2+',1x,2('|',1x,f6.3,1x),'|')
46662  6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46663  & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46664  & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46665  & 1x,'*',3x,'~b_1',1x,2('|',1x,f6.3,1x),'|',3x,'~t_1',1x,2('|'
46666  & ,1x,f6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,f6.3,1x),'|'/
46667  & 1x,'*',3x,'~b_2',1x,2('|',1x,f6.3,1x),'|',3x,'~t_2',1x,2('|'
46668  & ,1x,f6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,f6.3,1x),'|')
46669  6400 FORMAT(1x,'*',3x,' A_b = ',f8.2,4x,' A_t = ',f8.2,4x
46670  & ,'A_tau = ',f8.2)
46671  6450 FORMAT(1x,'*',3x,'alpha = ',f8.2,4x,'tan(beta) = ',f8.2,4x
46672  & ,' mu = ',f8.2)
46673  6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46674 
46675 C...Format to use for comments
46676  7000 FORMAT('# ',a)
46677 C...Format to use for block statements
46678  7010 FORMAT('Block',1x,a,3x,'#',1x,a)
46679  7020 FORMAT('Block',1x,a,1x,'Q=',1p,e16.8,0p,3x,'#',1x,a)
46680 C...Indexed Int
46681  7110 FORMAT(1x,i4,1x,i4,3x,'#')
46682 C...Non-Indexed Double
46683  7200 FORMAT(9x,1p,e16.8,0p,3x,'#',1x,a)
46684 C...Indexed Double
46685  7210 FORMAT(1x,i4,3x,1p,e16.8,0p,3x,'#',1x,a)
46686 C...Long Indexed Double (PDG + double)
46687  7220 FORMAT(1x,i9,3x,1p,e16.8,0p,3x,'#',1x,a)
46688 C...Indexed Char(12)
46689  7310 FORMAT(1x,i4,3x,a12,3x,'#',1x,a)
46690 C...Single matrix
46691  7410 FORMAT(1x,i2,1x,i2,3x,1p,e16.8,0p,3x,'#',1x,a)
46692 C...Double Matrix
46693  7420 FORMAT(1x,i2,1x,i2,3x,1p,e16.8,3x,e16.8,0p,3x,'#',1x,a)
46694 C...Write Decay Table
46695  7500 FORMAT('Decay',1x,i9,1x,'WIDTH=',1p,e16.8,0p,3x,'#',1x,a)
46696  7510 FORMAT(4x,i5,1x,1p,e16.8,0p,3x,i2,3x,'IDA=',1x,5(1x,i9),
46697  & 3x,'#',1x,a)
46698 
46699  END
46700 
46701 
46702 C*********************************************************************
46703 
46704 C...PYAPPS
46705 C...Uses approximate analytical formulae to determine the full set of
46706 C...MSSM parameters from SUGRA input.
46707 C...See M. Drees and S.P. Martin, hep-ph/9504124
46708 
46709  SUBROUTINE pyapps
46710 
46711 C...Double precision and integer declarations.
46712  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46713  IMPLICIT INTEGER(I-N)
46714  INTEGER PYK,PYCHGE,PYCOMP
46715 C...Parameter statement to help give large particle numbers.
46716  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
46717  &kexcit=4000000,kdimen=5000000)
46718 C...Commonblocks.
46719  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46720  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
46721  common/pymssm/imss(0:99),rmss(0:99)
46722  SAVE /pydat1/,/pydat2/,/pymssm/
46723 
46724  WRITE(mstu(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46725  &' not intended for serious physics studies'
46726  imss(5)=0
46727  imss(8)=0
46728  xmt=pmas(6,1)
46729  xmz2=pmas(23,1)**2
46730  xmw2=pmas(24,1)**2
46731  tanb=rmss(5)
46732  beta=atan(tanb)
46733  xw=paru(102)
46734  xmg=rmss(1)
46735  xmg2=xmg*xmg
46736  xm0=rmss(8)
46737  xm02=xm0*xm0
46738 C...Temporary sign change for AT. Others unchanged.
46739  at=-rmss(16)
46740  rmss(15)=rmss(16)
46741  rmss(17)=rmss(16)
46742  sinb=tanb/sqrt(tanb**2+1d0)
46743  cosb=sinb/tanb
46744 
46745  dterm=xmz2*cos(2d0*beta)
46746  xmer=sqrt(xm02+0.15d0*xmg2-xw*dterm)
46747  xmel=sqrt(xm02+0.52d0*xmg2-(0.5d0-xw)*dterm)
46748  rmss(6)=xmel
46749  rmss(7)=xmer
46750  xmur=sqrt(pyrnmq(2,2d0/3d0*xw*dterm))
46751  xmdr=sqrt(pyrnmq(3,-1d0/3d0*xw*dterm))
46752  xmul=sqrt(pyrnmq(1,(0.5d0-2d0/3d0*xw)*dterm))
46753  xmdl=sqrt(pyrnmq(1,-(0.5d0-1d0/3d0*xw)*dterm))
46754  DO 100 i=1,5,2
46755  pmas(pycomp(ksusy1+i),1)=xmdl
46756  pmas(pycomp(ksusy2+i),1)=xmdr
46757  pmas(pycomp(ksusy1+i+1),1)=xmul
46758  pmas(pycomp(ksusy2+i+1),1)=xmur
46759  100 CONTINUE
46760  xarg=xmel**2-xmw2*abs(cos(2d0*beta))
46761  IF(xarg.LT.0d0) THEN
46762  WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46763  & ' FROM THE SUM RULE. '
46764  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46765  RETURN
46766  ELSE
46767  xarg=sqrt(xarg)
46768  ENDIF
46769  DO 110 i=11,15,2
46770  pmas(pycomp(ksusy1+i),1)=xmel
46771  pmas(pycomp(ksusy2+i),1)=xmer
46772  pmas(pycomp(ksusy1+i+1),1)=xarg
46773  pmas(pycomp(ksusy2+i+1),1)=9999d0
46774  110 CONTINUE
46775  rmt=pymrun(6,pmas(6,1)**2)
46776  xtop=(rmt/150d0/sinb)**2*(.9d0*xm02+2.1d0*xmg2+
46777  &(1d0-(rmt/190d0/sinb)**3)*(.24d0*at**2+at*xmg))
46778  rmb=pymrun(5,pmas(6,1)**2)
46779  xbot=(rmb/150d0/cosb)**2*(.9d0*xm02+2.1d0*xmg2+
46780  &(1d0-(rmb/190d0/cosb)**3)*(.24d0*at**2+at*xmg))
46781  xtau=1d-4/cosb**2*(xm02+0.15d0*xmg2+at**2/3d0)
46782  atp=at*(1d0-(rmt/190d0/sinb)**2)+xmg*(3.47d0-1.9d0*(rmt/190d0/
46783  &sinb)**2)
46784  rmss(16)=-atp
46785  xmu2=-.5d0*xmz2+(sinb**2*(xm02+.52d0*xmg2-xtop)-
46786  &cosb**2*(xm02+.52d0*xmg2-xbot-xtau/3d0))/(cosb**2-sinb**2)
46787  xma2=2d0*(xm02+.52d0*xmg2+xmu2)-xtop-xbot-xtau/3d0
46788  xmu=sign(sqrt(xmu2),rmss(4))
46789  rmss(4)=xmu
46790  IF(xma2.GT.0d0) THEN
46791  rmss(19)=sqrt(xma2)
46792  ELSE
46793  WRITE(mstu(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46794  CALL pystop(102)
46795  ENDIF
46796  arg=xm02+0.15d0*xmg2-2d0*xtau/3d0-xw*dterm
46797  IF(arg.GT.0d0) THEN
46798  rmss(14)=sqrt(arg)
46799  ELSE
46800  WRITE(mstu(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46801  CALL pystop(102)
46802  ENDIF
46803  arg=xm02+0.52d0*xmg2-xtau/3d0-(0.5d0-xw)*dterm
46804  IF(arg.GT.0d0) THEN
46805  rmss(13)=sqrt(arg)
46806  ELSE
46807  WRITE(mstu(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46808  CALL pystop(102)
46809  ENDIF
46810  arg=pyrnmq(1,-(xbot+xtop)/3d0)
46811  IF(arg.GT.0d0) THEN
46812  rmss(10)=sqrt(arg)
46813  ELSE
46814  rmss(10)=-sqrt(-arg)
46815  ENDIF
46816  arg=pyrnmq(2,-2d0*xtop/3d0)
46817  IF(arg.GT.0d0) THEN
46818  rmss(12)=sqrt(arg)
46819  ELSE
46820  rmss(12)=-sqrt(-arg)
46821  ENDIF
46822  arg=pyrnmq(3,-2d0*xbot/3d0)
46823  IF(arg.GT.0d0) THEN
46824  rmss(11)=sqrt(arg)
46825  ELSE
46826  rmss(11)=-sqrt(-arg)
46827  ENDIF
46828 
46829  RETURN
46830  END
46831 
46832 C*********************************************************************
46833 
46834 C...PYSUGI
46835 C...Interface to ISASUSY version 7.71.
46836 C...Warning: this interface should not be used with earlier versions
46837 C...of ISASUSY, since common block incompatibilities may then arise.
46838 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46839 C...Then converts to Gunion-Haber conventions.
46840 
46841  SUBROUTINE pysugi
46842  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46843 
46844  INTEGER PYK,PYCHGE,PYCOMP
46845  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
46846  &kexcit=4000000,kdimen=5000000)
46847 
46848 C...Date of Change
46849  CHARACTER DOC*11
46850  parameter(doc='01 May 2006')
46851 
46852 C...ISASUGRA Input:
46853  REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46854 C...XISAIN contains the MSSMi inputs in natural order.
46855  COMMON /sugxin/ xisain(24),xsugin(7),xgmin(14),xnrin(4),
46856  $xamin(7)
46857  REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46858  SAVE /sugxin/
46859 C...ISASUGRA Output
46860  CHARACTER*40 ISAVER,VISAJE
46861  REAL SUPER
46862  COMMON /sspar/ super(72)
46863  COMMON /sugmg/ mss(32),gss(31),mgutss,ggutss,agutss,ftgut,
46864  $fbgut,ftagut,fngut
46865  REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46866  COMMON /sugpas/ xtanb,msusy,amt,mgut,mu,g2,gp,v,vp,xw,
46867  $a1mz,a2mz,asmz,ftamz,fbmz,b,sin2b,ftmt,g3mt,vev,higfrz,
46868  $fnmz,amnrmj,nogood,ial3un,itachy,mhpneg,asm3,
46869  $vumt,vdmt,asmtp,asmss,m3q
46870  REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46871  $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46872  $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46873  INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46874  INTEGER IALLOW
46875  SAVE /sugmg/,/sspar/
46876 C SUPER: Filled by ISASUGRA.
46877 C SUPER(1) = mass of ~g
46878 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46879 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46880 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46881 C ,~tau_2
46882 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46883 C SUPER(29) = Higgsino mass = - mu
46884 C SUPER(30) = ratio v2/v1 of vev's
46885 C SUPER(31:34) = Signed neutralino masses
46886 C SUPER(35:50) = Neutralino mixing matrix
46887 C SUPER(51:52) = Signed chargino masses
46888 C SUPER(53:54) = Chargino left, right mixing angles
46889 C SUPER(55:58) = mass of h0, H0, A0, H+
46890 C SUPER(59) = Higgs mixing angle alpha
46891 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46892 C SUPER(66) = Gravitino mass
46893 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46894 C SUPER(70) = b-Yukawa at mA scale (not used)
46895 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46896 C GSS: Filled by ISASUGRA
46897 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
46898 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
46899 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
46900 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
46901 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
46902 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
46903 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
46904 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
46905 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
46906 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
46907 C GSS(31) = log(vuq)
46908 C MSS: Filled by ISASUGRA
46909 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
46910 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
46911 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
46912 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
46913 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
46914 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
46915 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
46916 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
46917 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
46918 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
46919 C MSS(31) = ha0 MSS(32) = h+
46920 C Unification, filled by ISASUGRA if applicable.
46921 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
46922 
46923 C...SPYTHIA Input/Output
46924  INTEGER IMSS
46925  DOUBLE PRECISION RMSS
46926  common/pymssm/imss(0:99),rmss(0:99)
46927  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
46928  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
46929 C...SLHA Input/Output
46930  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
46931  & au(3,3),ad(3,3),ae(3,3)
46932 C...PYTHIA common blocks
46933  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46934  common/pypars/mstp(200),parp(200),msti(200),pari(200)
46935  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
46936 
46937  SAVE /pymssm/,/pyssmt/,/pylh3p/,/pydat1/,/pypars/,/pydat2/
46938 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46939  INTEGER IMODEL
46940  REAL M0,MHF,A0,MT
46941  CHARACTER*20 CHMOD(5)
46942  CHARACTER*32 FNAME
46943 
46944  COMMON /sugnu/ xnusug(18)
46945  REAL XNUSUG
46946  SAVE /sugnu/
46947 
46948  DATA chmod/'mSUGRA','mGMSB','non-universal SUGRA',
46949  & 'truly unified SUGRA', 'non-minimal GMSB'/
46950 
46951 C...Start by checking for incompatibilities/inconsistencies:
46952  DO 100 ichk=2,9
46953  IF (ichk.NE.8.AND.ichk.NE.4.AND.imss(ichk).NE.0) THEN
46954  WRITE (mstu(11),*) '(PYSUGI:) IMSS(',ichk,')=',imss(ichk)
46955  & ,' option not used by PYSUGI'
46956  ENDIF
46957  100 CONTINUE
46958 C...ISAJET works with REAL numbers.
46959  mzero=real(rmss(8))
46960  mhlf=real(rmss(1))
46961  azero=real(rmss(16))
46962  tanb=real(rmss(5))
46963  sgnmu=real(rmss(4))
46964  mtop=real(pmas(6,1))
46965  imodel=0
46966  IF (imss(1).EQ.12) THEN
46967  imodel=1
46968  GOTO 130
46969  ELSEIF(imss(1).EQ.13) THEN
46970 C...Read from isajet par file in IMSS(20)
46971  lfn=imss(20)
46972 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46973  IF (lfn.EQ.0) THEN
46974  WRITE(mstu(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
46975  GOTO 9999
46976  ENDIF
46977  WRITE(mstu(11),*) 'READING SUSY MODEL FROM FILE...'
46978 CMrenna change to allow any susy model
46979  WRITE(mstu(11),*) 'ENTER 1 for mSUGRA:'
46980  WRITE(mstu(11),*) 'ENTER 2 for mGMSB:'
46981  WRITE(mstu(11),*) 'ENTER 3 for non-universal SUGRA:'
46982  WRITE(mstu(11),*) 'ENTER 4 for SUGRA with truly unified'//
46983  & ' gauge couplings:'
46984  WRITE(mstu(11),*) 'ENTER 5 for non-minimal GMSB:'
46985  READ(lfn,*) imodel
46986  IF (imodel.EQ.4) THEN
46987  ial3un=1
46988  imodel=1
46989  ENDIF
46990  IF (imodel.EQ.1.OR.imodel.EQ.3) THEN
46991  WRITE(mstu(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
46992  & //' sgn(mu), M_t:'
46993  READ(lfn,*) m0,mhf,a0,tanb,sgnmu,mt
46994  IF (imodel.EQ.3) THEN
46995  imodel=1
46996  110 WRITE(mstu(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
46997  & //' 0 to continue:'
46998  WRITE(mstu(11),*) ' NUSUG1 = GUT scale gaugino masses'
46999  WRITE(mstu(11),*) ' NUSUG2 = GUT scale A terms'
47000  WRITE(mstu(11),*) ' NUSUG3 = GUT scale Higgs masses'
47001  WRITE(mstu(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47002  & //' generation masses'
47003  WRITE(mstu(11),*)
47004  & ' NUSUG5 = GUT scale 3rd generation masses'
47005  READ(lfn,*) inusug
47006  IF (inusug.EQ.0) THEN
47007  GOTO 120
47008  ELSEIF (inusug.EQ.1) THEN
47009  WRITE(mstu(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47010  READ(lfn,*) xnusug(1),xnusug(2),xnusug(3)
47011  IF (xnusug(3).LE.0.) THEN
47012  WRITE(mstu(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47013  CALL pystop(109)
47014  END IF
47015  ELSEIF (inusug.EQ.2) THEN
47016  WRITE(mstu(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47017  READ(lfn,*) xnusug(6),xnusug(5),xnusug(4)
47018  ELSEIF (inusug.EQ.3) THEN
47019  WRITE(mstu(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47020  READ(lfn,*) xnusug(7),xnusug(8)
47021  ELSEIF (inusug.EQ.4) THEN
47022  WRITE(mstu(11),*) 'Enter GUT scale M(ul), M(dr),'
47023  & //' M(ur), M(el), M(er):'
47024  READ(lfn,*) xnusug(13),xnusug(11),xnusug(12),
47025  & xnusug(10),xnusug(9)
47026  ELSEIF (inusug.EQ.5) THEN
47027  WRITE(mstu(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47028  & //' M(Ll), M(Lr):'
47029  READ(lfn,*) xnusug(18),xnusug(16),xnusug(17),
47030  & xnusug(15),xnusug(14)
47031  ENDIF
47032  GOTO 110
47033  ENDIF
47034  ELSEIF (imodel.EQ.2.OR.imodel.EQ.5) THEN
47035  imss(11)=1
47036  WRITE(mstu(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47037  & ,' sgn(mu), M_t, C_gv:'
47038  READ(lfn,*) m0,mhf,a0,tanb,sgnmu,mt,xcmgv
47039  xgmin(7)=xcmgv
47040  xgmin(8)=1.
47041 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47042  ampl=2.4d18
47043  amgvss=m0*mhf*xcmgv/sqrt(3d0)/ampl
47044  IF (imodel.EQ.5) THEN
47045  imodel=2
47046  WRITE(mstu(11),*) 'Rsl = factor multiplying gaugino'
47047  & ,' masses at M_mes'
47048  WRITE(mstu(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47049  & ,' shifts at M_mes'
47050  WRITE(mstu(11),*) 'd_Y = mass**2 shifts proportional to',
47051  & ' Y at M_mes'
47052  WRITE(mstu(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47053  & ,'SU(2),SU(3)'
47054  WRITE(mstu(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47055  & ,' n5_2, n5_3'
47056  READ(lfn,*) xgmin(8),xgmin(9),xgmin(10),xgmin(11),xgmin(12),
47057  $ xgmin(13),xgmin(14)
47058  ENDIF
47059  ELSE
47060  WRITE(mstu(11),*) 'Invalid model choice.'
47061  GOTO 9999
47062  ENDIF
47063  ENDIF
47064 
47065  120 mzero=m0
47066  mhlf=mhf
47067  azero=a0
47068 C TANB=REAL(RMSS(5))
47069 C SGNMU=REAL(RMSS(4))
47070  mtop=mt
47071 
47072 C...Initialize MSSM parameter array
47073  130 DO 140 ipar=1,72
47074  super(ipar)=0.0
47075  140 CONTINUE
47076 C...Call ISASUGRA
47077  CALL sugra(mzero,mhlf,azero,tanb,sgnmu,mtop,imodel)
47078 C...Check whether ISASUSY thought the model was OK.
47079  IF (nogood.NE.0) THEN
47080  IF (nogood.EQ.1) CALL pyerrm(26
47081  & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47082  IF (nogood.EQ.2) CALL pyerrm(26
47083  & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47084  IF (nogood.EQ.3) CALL pyerrm(26
47085  & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47086  IF (nogood.EQ.4) CALL pyerrm(26
47087  & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47088  IF (nogood.EQ.7) CALL pyerrm(26
47089  & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47090  IF (nogood.EQ.8) CALL pyerrm(26
47091  & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47092 C...Give warning, but don't stop, if LSP not ~chi_10.
47093  IF (nogood.EQ.5) CALL pyerrm(16
47094  & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47095  ENDIF
47096 C...Warn about possible GUT scale tachyons.
47097  IF (itachy.NE.0) CALL pyerrm(16,
47098  & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47099 C...Finalize spectrum (last iteration)
47100 C...(Thanks to A. Raklev for pointing this out.)
47101 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47102  CALL ssmssm(xisain(1),xisain(2),xisain(3),
47103  $ xisain(4),xisain(5),xisain(6),xisain(7),xisain(8),xisain(9),
47104  $ xisain(10),xisain(11),xisain(12),xisain(13),xisain(14),
47105  $ xisain(15),xisain(16),xisain(17),xisain(18),xisain(19),
47106  $ xisain(20),xisain(21),xisain(22),xisain(23),xisain(24),
47107  $ mtop,iallow,1)
47108 
47109 C...M1, M2, M3.
47110  rmss(1)=dble(gss(7))
47111  rmss(2)=dble(gss(8))
47112  rmss(3)=dble(gss(9))
47113  rmsoft(1)=dble(gss(7))
47114  rmsoft(2)=dble(gss(8))
47115  rmsoft(3)=dble(gss(9))
47116 C...Mu = - Higgsino mass.
47117  rmss(4)=-super(29)
47118  rmss(5)=tanb
47119 C...Slepton and squark masses. 2 first generations.
47120  rmss(6)=0.5*(super(18)+super(20))
47121  rmss(7)=0.5*(super(19)+super(21))
47122  rmss(8)=0.25*(super(2)+super(4)+super(6)+super(8))
47123  rmss(9)=0.25*(super(3)+super(5)+super(7)+super(9))
47124 C...Third generation.
47125  rmss(10)=0.5*(super(14)+super(10))
47126  rmss(11)=super(11)
47127  rmss(12)=super(15)
47128  rmss(13)=super(22)
47129  rmss(14)=super(23)
47130 C...SLHA: store exact soft spectrum in RMSOFT
47131  rmsoft(31)=super(18)
47132  rmsoft(32)=super(20)
47133  rmsoft(33)=super(22)
47134  rmsoft(34)=super(19)
47135  rmsoft(35)=super(21)
47136  rmsoft(36)=super(23)
47137  rmsoft(41)=0.5d0*(super(2)+super(4))
47138  rmsoft(42)=0.5d0*(super(6)+super(8))
47139  rmsoft(43)=0.5d0*(super(10)+super(14))
47140  rmsoft(44)=super(3)
47141  rmsoft(45)=super(9)
47142  rmsoft(46)=super(15)
47143  rmsoft(47)=super(5)
47144  rmsoft(48)=super(7)
47145  rmsoft(49)=super(11)
47146 
47147 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47148  rmss(15)=super(62)
47149  rmss(16)=super(60)
47150  rmss(17)=super(64)
47151  rmss(26)=super(63)
47152  rmss(27)=super(61)
47153  rmss(28)=super(65)
47154 C...SLHA trilinears
47155  DO 142 k1=1,3
47156  DO 141 k2=1,3
47157  ae(k1,k2)=0d0
47158  au(k1,k2)=0d0
47159  ad(k1,k2)=0d0
47160  141 CONTINUE
47161  142 CONTINUE
47162  ae(3,3)=super(64)
47163  au(3,3)=super(60)
47164  ad(3,3)=super(62)
47165 C...Higgs mixing angle alpha (Gunion-Haber convention).
47166  rmss(18)=-super(59)
47167 C...A0 mass.
47168  rmss(19)=super(57)
47169 C...GUT scale coupling
47170  rmss(20)=agutss
47171 C...Gravitino mass (for future compatibility)
47172  rmss(21)=max(rmss(21),dble(super(66)))
47173 
47174 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47175 C...Higgs sector.
47176  pmas(pycomp(25),1)=abs(super(55))
47177  pmas(pycomp(35),1)=abs(super(56))
47178  pmas(pycomp(36),1)=abs(super(57))
47179  pmas(pycomp(37),1)=abs(super(58))
47180 C...Gluino.
47181  pmas(pycomp(ksusy1+21),1)=abs(super(1))
47182 C...Squarks and Sleptons.
47183  DO 150 ilr=1,2
47184  ilrm=ilr-1
47185  pmas(pycomp(ilr*ksusy1+1),1)=abs(super(4+ilrm))
47186  pmas(pycomp(ilr*ksusy1+2),1)=abs(super(2+ilrm))
47187  pmas(pycomp(ilr*ksusy1+3),1)=abs(super(6+ilrm))
47188  pmas(pycomp(ilr*ksusy1+4),1)=abs(super(8+ilrm))
47189  pmas(pycomp(ilr*ksusy1+5),1)=abs(super(12+ilrm))
47190  pmas(pycomp(ilr*ksusy1+6),1)=abs(super(16+ilrm))
47191  pmas(pycomp(ilr*ksusy1+11),1)=abs(super(18+ilrm))
47192  pmas(pycomp(ilr*ksusy1+13),1)=abs(super(20+ilrm))
47193  pmas(pycomp(ilr*ksusy1+15),1)=abs(super(24+ilrm))
47194  150 CONTINUE
47195  pmas(pycomp(ksusy1+12),1)=abs(super(26))
47196  pmas(pycomp(ksusy1+14),1)=abs(super(27))
47197  pmas(pycomp(ksusy1+16),1)=abs(super(28))
47198 C...Neutralinos.
47199  pmas(pycomp(ksusy1+22),1)=abs(super(31))
47200  pmas(pycomp(ksusy1+23),1)=abs(super(32))
47201  pmas(pycomp(ksusy1+25),1)=abs(super(33))
47202  pmas(pycomp(ksusy1+35),1)=abs(super(34))
47203 C...Signed masses (extra minus from going to G-H convention).
47204  smz(1)=-super(31)
47205  smz(2)=-super(32)
47206  smz(3)=-super(33)
47207  smz(4)=-super(34)
47208 C...Charginos
47209  pmas(pycomp(ksusy1+24),1)=abs(super(51))
47210  pmas(pycomp(ksusy1+37),1)=abs(super(52))
47211 C...Signed masses (extra minus from going to G-H convention).
47212  smw(1)=-super(51)
47213  smw(2)=-super(52)
47214 
47215 C... Neutralino Mixing.
47216  DO 160 in=1,4
47217  zmix(in,1)= super(38+4*(in-1))
47218  zmix(in,2)= super(37+4*(in-1))
47219  zmix(in,3)=-super(36+4*(in-1))
47220  zmix(in,4)=-super(35+4*(in-1))
47221  160 CONTINUE
47222 C...Chargino Mixing (PYTHIA same angle as HERWIG).
47223  thx=1d0
47224  thy=1d0
47225  IF (super(53).GT.0) thx=-1d0
47226  IF (super(54).GT.0) thy=-1d0
47227  umix(1,1) = -sin(super(53))
47228  umix(1,2) = -cos(super(53))
47229  umix(2,1) = -thx*cos(super(53))
47230  umix(2,2) = thx*sin(super(53))
47231  vmix(1,1) = -sin(super(54))
47232  vmix(1,2) = -cos(super(54))
47233  vmix(2,1) = -thy*cos(super(54))
47234  vmix(2,2) = thy*sin(super(54))
47235 C...Sfermion mixing (PYTHIA same angle as ISAJET)
47236  sfmix(5,1)=cos(super(63))
47237  sfmix(5,2)=sin(super(63))
47238  sfmix(5,3)=-sin(super(63))
47239  sfmix(5,4)=cos(super(63))
47240  sfmix(6,1)=cos(super(61))
47241  sfmix(6,2)=sin(super(61))
47242  sfmix(6,3)=-sin(super(61))
47243  sfmix(6,4)=cos(super(61))
47244  sfmix(15,1)=cos(super(65))
47245  sfmix(15,2)=sin(super(65))
47246  sfmix(15,3)=-sin(super(65))
47247  sfmix(15,4)=cos(super(65))
47248 
47249  IF (mstp(122).NE.0) THEN
47250 C...Print a few lines to make the user know what's happening
47251  isaver=visaje()
47252  WRITE(mstu(11),5000) doc, isaver
47253  WRITE(mstu(11),5100)
47254  IF (imodel.EQ.1) THEN
47255  WRITE(mstu(11),5200) mzero, mhlf, azero, tanb, nint(sgnmu),
47256  & mtop
47257  WRITE(mstu(11),5300)
47258  ENDIF
47259  WRITE(mstu(11),5500) 'Pole masses'
47260  WRITE(mstu(11),5700) (super(ip),ip=2,16,2),(super(ip),ip=3,17,2)
47261  WRITE(mstu(11),5800) (super(ip),ip=18,24,2),(super(ip),ip=26,28)
47262  & ,(super(ip),ip=19,25,2)
47263  WRITE(mstu(11),5900) super(1),(smz(ip),ip=1,4), (smw(ip)
47264  & ,ip=1,2)
47265  WRITE(mstu(11),5400)
47266  WRITE(mstu(11),6000) (super(ip),ip=55,58)
47267  WRITE(mstu(11),5400)
47268  WRITE(mstu(11),5500) 'EW scale mixing structure'
47269  WRITE(mstu(11),6100) ((zmix(i,j), j=1,4),i=1,4)
47270  WRITE(mstu(11),6200) (umix(1,j), j=1,2),(vmix(1,j),j=1,2)
47271  & ,(umix(2,j), j=1,2),(vmix(2,j),j=1,2)
47272  WRITE(mstu(11),6300) (sfmix(5,j), j=1,2),(sfmix(6,j),j=1,2)
47273  & ,(sfmix(15,j), j=1,2),(sfmix(5,j),j=3,4),(sfmix(6,j), j=3,4
47274  & ),(sfmix(15,j),j=3,4)
47275  WRITE(mstu(11),5400)
47276  WRITE(mstu(11),6450) rmss(18)
47277  WRITE(mstu(11),5400)
47278  WRITE(mstu(11),5500) 'Couplings'
47279  WRITE(mstu(11),6400) rmss(15),rmss(16),rmss(17),rmss(20)
47280  WRITE(mstu(11),5400)
47281  ENDIF
47282 
47283 C...Call FeynHiggs to improve Higgs sector if requested
47284  IF (imss(4).EQ.3) THEN
47285  IF (mstp(122).NE.0) WRITE(mstu(11),'(1x,"*"/1x,"*",A)')
47286  & ' (PYSUGI:) Now calling FeynHiggs.'
47287  CALL pyfeyn(ierr)
47288  IF (ierr.EQ.0) THEN
47289  imss(4)=2
47290  IF (mstp(122).NE.0) THEN
47291  WRITE(mstu(11),5400)
47292  WRITE(mstu(11),5500)
47293  & 'Corrected Higgs masses and mixing'
47294  WRITE(mstu(11),6000) pmas(25,1),pmas(35,1),pmas(36,1),
47295  & pmas(37,1)
47296  WRITE(mstu(11),6450) rmss(18)
47297  WRITE(mstu(11),5400)
47298  ENDIF
47299  ENDIF
47300  ENDIF
47301 
47302  IF (mstp(122).NE.0) WRITE(mstu(11),6500)
47303 
47304 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47305 C...output by ISASUSY.
47306  imss(4)=max(2,imss(4))
47307 
47308  5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47309  & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,a
47310  & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,a/1x,'*')
47311  5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47312  5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47313  & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(f8.2,1x),i8,2x,f8.2)
47314  5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47315  & ,'----------------')
47316  5400 FORMAT(1x,'*',1x,a)
47317  5500 FORMAT(1x,'*',1x,a,':')
47318  5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47319  & 1x,'*',2x,1p,2(1x,e8.2),2x,e8.2)
47320  5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47321  & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47322  & '~t(12)'/1x,'*',2x,'L',1x,8(f8.2,1x)/1x,'*',2x,'R',1x,8(f8.2
47323  & ,1x))
47324  5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47325  & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47326  & ,'~nu_tau'/1x,'*',2x,'L',1x,7(f8.2,1x)/1x,'*',2x,'R',1x,4(f8
47327  & .2,1x))
47328  5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47329  & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47330  & ,1x,'~chi_2+'/1x,'*',3x,1x,7(f8.2,1x))
47331  6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47332  & ,1x,4x,'H+'/1x,'*',3x,1x,5(f8.2,1x))
47333  6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47334  & ,1x,4x,'H+'/1x,'*',3x,1x,5(f8.2,1x),3x,'(Before FeynHiggs)')
47335  6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47336  & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47337  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47338  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47339  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47340  & ,1x,f6.3,1x),'|')
47341  6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47342  & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47343  & ,'~chi_1+',1x,2('|',1x,f6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47344  & ,f6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,f6.3,1x),'|',9x
47345  & ,'~chi_2+',1x,2('|',1x,f6.3,1x),'|')
47346  6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47347  & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47348  & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47349  & 1x,'*',3x,'~b_1',1x,2('|',1x,f6.3,1x),'|',3x,'~t_1',1x,2('|'
47350  & ,1x,f6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,f6.3,1x),'|'/
47351  & 1x,'*',3x,'~b_2',1x,2('|',1x,f6.3,1x),'|',3x,'~t_2',1x,2('|'
47352  & ,1x,f6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,f6.3,1x),'|')
47353  6400 FORMAT(1x,'*',3x,'A_b = ',f8.2,4x,'A_t = ',f8.2,4x,'A_tau = ',f8.2
47354  & ,4x,'Alpha_GUT = ',f8.2)
47355  6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',f8.4)
47356  6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47357 
47358  9999 RETURN
47359  END
47360 
47361 C*********************************************************************
47362 
47363 C...PYFEYN
47364 C...Interface to FeynHiggs for MSSM Higgs sector.
47365 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47366 C...P. Skands
47367 
47368  SUBROUTINE pyfeyn(IERR)
47369 
47370 C...Double precision and integer declarations.
47371  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47372  IMPLICIT INTEGER(I-N)
47373  INTEGER PYK,PYCHGE,PYCOMP
47374 C...Commonblocks.
47375  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47376  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47377 C...SUSY blocks
47378  common/pymssm/imss(0:99),rmss(0:99)
47379 C...FeynHiggs variables
47380  DOUBLE PRECISION RMHIGG(4)
47381  DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47382  DOUBLE COMPLEX DMU,
47383  & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47384  & DM1, DM2, DM3
47385 C...SLHA Common Block
47386  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
47387  & au(3,3),ad(3,3),ae(3,3)
47388  SAVE /pydat1/,/pydat2/,/pymssm/,/pylh3p/
47389 
47390  ierr=0
47391  CALL fhsetflags(ierr,4,0,0,2,0,2,1,1)
47392  IF (ierr.NE.0) THEN
47393  CALL pyerrm(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47394  & //'Will not use FeynHiggs for this run.')
47395  RETURN
47396  ENDIF
47397  q=rmsoft(0)
47398  dmb=pmas(5,1)
47399  dmt=pmas(6,1)
47400  dmz=pmas(23,1)
47401  dmw=pmas(24,1)
47402  dma=pmas(36,1)
47403  dm1=rmsoft(1)
47404  dm2=rmsoft(2)
47405  dm3=rmsoft(3)
47406  dtanb=rmss(5)
47407  dmu=rmss(4)
47408  dm3sl=rmsoft(33)
47409  dm3se=rmsoft(36)
47410  dm3sq=rmsoft(43)
47411  dm3su=rmsoft(46)
47412  dm3sd=rmsoft(49)
47413  dm2sl=rmsoft(32)
47414  dm2se=rmsoft(35)
47415  dm2sq=rmsoft(42)
47416  dm2su=rmsoft(45)
47417  dm2sd=rmsoft(48)
47418  dm1sl=rmsoft(31)
47419  dm1se=rmsoft(34)
47420  dm1sq=rmsoft(41)
47421  dm1su=rmsoft(44)
47422  dm1sd=rmsoft(47)
47423  ae33=ae(3,3)
47424  ae22=ae(2,2)
47425  ae11=ae(1,1)
47426  au33=au(3,3)
47427  au22=au(2,2)
47428  au11=au(1,1)
47429  ad33=ad(3,3)
47430  ad22=ad(2,2)
47431  ad11=ad(1,1)
47432  CALL fhsetpara(ierr, 1d0, dmt, dmb, dmw, dmz, dtanb,
47433  & dma,0d0, dm3sl, dm3se, dm3sq, dm3su, dm3sd,
47434  & dm2sl, dm2se, dm2sq, dm2su, dm2sd,
47435  & dm1sl, dm1se, dm1sq, dm1su, dm1sd,dmu,
47436  & ae33, au33, ad33, ae22, au22, ad22, ae11, au11, ad11,
47437  & dm1, dm2, dm3, 0d0, 0d0,q,q,q)
47438  IF (ierr.NE.0) THEN
47439  CALL pyerrm(11,'(PYHGGM:) Caught error from FHSETPARA.'
47440  & //' Will not use FeynHiggs for this run.')
47441  RETURN
47442  ENDIF
47443 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47444  saeff=0d0
47445  CALL fhhiggscorr(ierr, rmhigg, saeff, uhiggs)
47446  IF (ierr.NE.0) THEN
47447  CALL pyerrm(11,'(PYFEYN:) Caught error from FHHIG'//
47448  & 'GSCORR. Will not use FeynHiggs for this run.')
47449  RETURN
47450  ENDIF
47451  alpha = asin(dble(saeff))
47452  r=rmss(18)/alpha
47453  IF (r.LT.0d0.OR.abs(r).GT.1.2d0.OR.abs(r).LT.0.8d0) THEN
47454  CALL pyerrm(1,'(PYFEYN:) Large corrections in Higgs sector.')
47455  WRITE(mstu(11),*) ' Old Alpha:', rmss(18)
47456  WRITE(mstu(11),*) ' New Alpha:', alpha
47457  ENDIF
47458  IF (rmhigg(1).LT.0.85d0*pmas(25,1).OR.rmhigg(1).GT.
47459  & 1.15d0*pmas(25,1)) THEN
47460  CALL pyerrm(1,'(PYFEYN:) Large corrections in Higgs sector.')
47461  WRITE(mstu(11),*) ' Old m(h0):', pmas(25,1)
47462  WRITE(mstu(11),*) ' New m(h0):', rmhigg(1)
47463  ENDIF
47464  rmss(18)=alpha
47465  pmas(25,1)=rmhigg(1)
47466  pmas(35,1)=rmhigg(2)
47467  pmas(36,1)=rmhigg(3)
47468  pmas(37,1)=rmhigg(4)
47469 
47470  RETURN
47471  END
47472 
47473 C*********************************************************************
47474 
47475 C...PYRNMQ
47476 C...Determines the running mass of Squarks.
47477 
47478  FUNCTION pyrnmq(ID,DTERM)
47479 
47480 C...Double precision and integer declarations.
47481  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47482  IMPLICIT INTEGER(I-N)
47483  INTEGER PYK,PYCHGE,PYCOMP
47484 C...Commonblock.
47485  common/pymssm/imss(0:99),rmss(0:99)
47486  SAVE /pymssm/
47487 
47488 C...Local variables.
47489  DOUBLE PRECISION PI,R
47490  DOUBLE PRECISION TOL
47491  DOUBLE PRECISION CI(3)
47492  EXTERNAL pyalps
47493  DOUBLE PRECISION PYALPS
47494  DATA tol/0.001d0/
47495  DATA pi,r/3.141592654d0,.61803399d0/
47496  DATA ci/0.47d0,0.07d0,0.02d0/
47497 
47498  c=1d0-r
47499  ca=ci(id)
47500  ag=(0.71d0)**2/4d0/pi
47501  ag=rmss(20)
47502  xm0=rmss(8)
47503  xmg=rmss(1)
47504  xm02=xm0*xm0
47505  xmg2=xmg*xmg
47506 
47507  as=pyalps(xm02+6d0*xmg2)
47508  cg=8d0/9d0*((as/ag)**2-1d0)
47509  bx=xm02+(ca+cg)*xmg2+dterm
47510  ax=min(50d0**2,0.5d0*bx)
47511  cx=max(2000d0**2,2d0*bx)
47512 
47513  x0=ax
47514  x3=cx
47515  IF(abs(cx-bx).GT.abs(bx-ax))THEN
47516  x1=bx
47517  x2=bx+c*(cx-bx)
47518  ELSE
47519  x2=bx
47520  x1=bx-c*(bx-ax)
47521  ENDIF
47522  as1=pyalps(x1)
47523  cg=8d0/9d0*((as1/ag)**2-1d0)
47524  f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
47525  as2=pyalps(x2)
47526  cg=8d0/9d0*((as2/ag)**2-1d0)
47527  f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
47528  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
47529  IF(f2.LT.f1) THEN
47530  x0=x1
47531  x1=x2
47532  x2=r*x1+c*x3
47533  f1=f2
47534  as2=pyalps(x2)
47535  cg=8d0/9d0*((as2/ag)**2-1d0)
47536  f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
47537  ELSE
47538  x3=x2
47539  x2=x1
47540  x1=r*x2+c*x0
47541  f2=f1
47542  as1=pyalps(x1)
47543  cg=8d0/9d0*((as1/ag)**2-1d0)
47544  f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
47545  ENDIF
47546  GOTO 100
47547  ENDIF
47548  IF(f1.LT.f2) THEN
47549  pyrnmq=x1
47550  xmin=x1
47551  ELSE
47552  pyrnmq=x2
47553  xmin=x2
47554  ENDIF
47555 
47556  RETURN
47557  END
47558 
47559 C*********************************************************************
47560 
47561 C...PYTHRG
47562 C...Calculates the mass eigenstates of the third generation sfermions.
47563 C...Created: 5-31-96
47564 
47565  SUBROUTINE pythrg
47566 
47567 C...Double precision and integer declarations.
47568  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47569  IMPLICIT INTEGER(I-N)
47570  INTEGER PYK,PYCHGE,PYCOMP
47571 C...Parameter statement to help give large particle numbers.
47572  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
47573  &kexcit=4000000,kdimen=5000000)
47574 C...Commonblocks.
47575  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47576  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47577  common/pymssm/imss(0:99),rmss(0:99)
47578  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
47579  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
47580  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
47581 
47582 C...Local variables.
47583  DOUBLE PRECISION BETA
47584  DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47585  DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47586  DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47587  DOUBLE PRECISION ATR,AMQR,AMQL
47588  INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47589  INTEGER IF,I,J,II,JJ,IT,L
47590  LOGICAL DTERM
47591  DATA small/1d-3/
47592  DATA id1/10,10,13/
47593  DATA id2/5,6,15/
47594  DATA id3/15,16,17/
47595  DATA id4/11,12,14/
47596  DATA dterm/.true./
47597 
47598  xmz2=pmas(23,1)**2
47599  xmw2=pmas(24,1)**2
47600  tanb=rmss(5)
47601  xmu=-rmss(4)
47602  beta=atan(tanb)
47603  cos2b=cos(2d0*beta)
47604 
47605 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47606 
47607  iopt=imss(5)
47608  IF(iopt.EQ.1) THEN
47609  ctt=dcos(rmss(27))
47610  ctt2=ctt**2
47611  stt=dsin(rmss(27))
47612  stt2=stt**2
47613  xm12=rmss(10)**2
47614  xm22=rmss(12)**2
47615  xmql2=ctt2*xm12+stt2*xm22
47616  xmqr2=stt2*xm12+ctt2*xm22
47617  xmf2=pymrun(6,pmas(6,1)**2)**2
47618  atop=-xmu/tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
47619  rmss(16)=atop
47620 C......SUBTRACT OUT D-TERM AND FERMION MASS
47621  xmql2=xmql2-xmf2-(4d0*xmw2-xmz2)*cos2b/6d0
47622  xmqr2=xmqr2-xmf2+(xmw2-xmz2)*cos2b*2d0/3d0
47623  IF(xmql2.GE.0d0) THEN
47624  rmss(10)=sqrt(xmql2)
47625  ELSE
47626  rmss(10)=-sqrt(-xmql2)
47627  ENDIF
47628  IF(xmqr2.GE.0d0) THEN
47629  rmss(12)=sqrt(xmqr2)
47630  ELSE
47631  rmss(12)=-sqrt(-xmqr2)
47632  ENDIF
47633 
47634 C SAME FOR BOTTOM SQUARK
47635  ctt=dcos(rmss(26))
47636  ctt2=ctt**2
47637  stt=dsin(rmss(26))
47638  stt2=stt**2
47639  xm22=rmss(11)**2
47640  xmf2=pymrun(5,pmas(6,1)**2)**2
47641  xmql2=sign(rmss(10)**2,rmss(10))-(2d0*xmw2+xmz2)*cos2b/6d0+xmf2
47642  IF(abs(ctt).GE..9999d0) THEN
47643  abot=-xmu*tanb
47644  xmqr2=rmss(11)**2
47645  ELSEIF(abs(ctt).LE.1d-4) THEN
47646  abot=-xmu*tanb
47647  xmqr2=rmss(11)**2
47648  ELSE
47649  xm12=(xmql2-stt2*xm22)/ctt2
47650  xmqr2=stt2*xm12+ctt2*xm22
47651  abot=-xmu*tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
47652  ENDIF
47653  rmss(15)=abot
47654 C......SUBTRACT OUT D-TERM AND FERMION MASS
47655  xmqr2=xmqr2-(xmw2-xmz2)*cos2b/3d0-xmf2
47656  IF(xmqr2.GE.0d0) THEN
47657  rmss(11)=sqrt(xmqr2)
47658  ELSE
47659  rmss(11)=-sqrt(-xmqr2)
47660  ENDIF
47661 C SAME FOR TAU SLEPTON
47662  ctt=dcos(rmss(28))
47663  ctt2=ctt**2
47664  stt=dsin(rmss(28))
47665  stt2=stt**2
47666  xm12=rmss(13)**2
47667  xm22=rmss(14)**2
47668  xmql2=ctt2*xm12+stt2*xm22
47669  xmqr2=stt2*xm12+ctt2*xm22
47670  xmfr=pmas(15,1)
47671  xmf2=xmfr**2
47672  atau=-xmu*tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
47673  rmss(17)=atau
47674 C......SUBTRACT OUT D-TERM AND FERMION MASS
47675  xmql2=xmql2-xmf2+(-.5d0*xmz2+xmw2)*cos2b
47676  xmqr2=xmqr2-xmf2+(xmz2-xmw2)*cos2b
47677  IF(xmql2.GE.0d0) THEN
47678  rmss(13)=sqrt(xmql2)
47679  ELSE
47680  rmss(13)=-sqrt(-xmql2)
47681  ENDIF
47682  IF(xmqr2.GE.0d0) THEN
47683  rmss(14)=sqrt(xmqr2)
47684  ELSE
47685  rmss(14)=-sqrt(-xmqr2)
47686  ENDIF
47687  ENDIF
47688  DO 170 l=1,3
47689  amql=rmss(id1(l))
47690  IF(amql.LT.0d0) THEN
47691  xmql2=-amql**2
47692  ELSE
47693  xmql2=amql**2
47694  ENDIF
47695  atr=rmss(id3(l))
47696  amqr=rmss(id4(l))
47697  IF(amqr.LT.0d0) THEN
47698  xmqr2=-amqr**2
47699  ELSE
47700  xmqr2=amqr**2
47701  ENDIF
47702  if=id2(l)
47703  xmf=pymrun(IF,pmas(6,1)**2)
47704  xmf2=xmf**2
47705  am2(1,1)=xmql2+xmf2
47706  am2(2,2)=xmqr2+xmf2
47707  IF(am2(1,1).EQ.am2(2,2)) am2(2,2)=am2(2,2)*1.00001d0
47708  IF(dterm) THEN
47709  IF(l.EQ.1) THEN
47710  am2(1,1)=am2(1,1)-(2d0*xmw2+xmz2)*cos2b/6d0
47711  am2(2,2)=am2(2,2)+(xmw2-xmz2)*cos2b/3d0
47712  am2(1,2)=xmf*(atr+xmu*tanb)
47713  ELSEIF(l.EQ.2) THEN
47714  am2(1,1)=am2(1,1)+(4d0*xmw2-xmz2)*cos2b/6d0
47715  am2(2,2)=am2(2,2)-(xmw2-xmz2)*cos2b*2d0/3d0
47716  am2(1,2)=xmf*(atr+xmu/tanb)
47717  ELSEIF(l.EQ.3) THEN
47718  IF(imss(8).EQ.1) THEN
47719  am2(1,1)=rmss(6)**2
47720  am2(2,2)=rmss(7)**2
47721  am2(1,2)=0d0
47722  rmss(13)=rmss(6)
47723  rmss(14)=rmss(7)
47724  ELSE
47725  am2(1,1)=am2(1,1)-(-.5d0*xmz2+xmw2)*cos2b
47726  am2(2,2)=am2(2,2)-(xmz2-xmw2)*cos2b
47727  am2(1,2)=xmf*(atr+xmu*tanb)
47728  ENDIF
47729  ENDIF
47730  ENDIF
47731  am2(2,1)=am2(1,2)
47732  detm=am2(1,1)*am2(2,2)-am2(2,1)**2
47733  IF(detm.LT.0d0) THEN
47734  WRITE(mstu(11),*) id2(l),detm,am2
47735  CALL pyerrm(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47736  ENDIF
47737  same=0.5d0*(am2(1,1)+am2(2,2))
47738  diff=0.5d0*sqrt((am2(1,1)-am2(2,2))**2+4d0*am2(1,2)*am2(2,1))
47739  xmf12=same-diff
47740  xmf22=same+diff
47741  it=0
47742  IF(xmf22-xmf12.GT.0d0) THEN
47743  rt(1,1) = sqrt(max(0d0,(xmf22-am2(1,1))/(xmf22-xmf12)))
47744  rt(2,2) = rt(1,1)
47745  rt(1,2) = -sign(sqrt(max(0d0,1d0-rt(1,1)**2)),
47746  & am2(1,2)/(xmf22-xmf12))
47747  rt(2,1) = -rt(1,2)
47748  ELSE
47749  rt(1,1) = 1d0
47750  rt(2,2) = rt(1,1)
47751  rt(1,2) = 0d0
47752  rt(2,1) = -rt(1,2)
47753  ENDIF
47754  100 CONTINUE
47755  it=it+1
47756 
47757  DO 140 i=1,2
47758  DO 130 jj=1,2
47759  di(i,jj)=0d0
47760  DO 120 ii=1,2
47761  DO 110 j=1,2
47762  di(i,jj)=di(i,jj)+rt(i,j)*am2(j,ii)*rt(jj,ii)
47763  110 CONTINUE
47764  120 CONTINUE
47765  130 CONTINUE
47766  140 CONTINUE
47767 
47768  IF(di(1,1).GT.di(2,2)) THEN
47769  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION '
47770  WRITE(mstu(11),*) l,sqrt(xmf12),sqrt(xmf22)
47771  WRITE(mstu(11),*) am2
47772  WRITE(mstu(11),*) di
47773  WRITE(mstu(11),*) rt
47774  di(1,1)=-rt(2,1)
47775  di(2,2)=rt(1,2)
47776  di(1,2)=-rt(2,2)
47777  di(2,1)=rt(1,1)
47778  DO 160 i=1,2
47779  DO 150 j=1,2
47780  rt(i,j)=di(i,j)
47781  150 CONTINUE
47782  160 CONTINUE
47783  GOTO 100
47784  ELSEIF(abs(di(1,2)*di(2,1)/di(1,1)/di(2,2)).GT.small) THEN
47785  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
47786  & ' OFF DIAGONAL ELEMENTS '
47787  WRITE(mstu(11),*) 'MASSES = ',l,sqrt(xmf12),sqrt(xmf22)
47788  WRITE(mstu(11),*) di
47789  WRITE(mstu(11),*) ' ROTATION = ',rt
47790 C...STOP
47791  ELSEIF(di(1,1).LT.0d0.OR.di(2,2).LT.0d0) THEN
47792  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
47793  & ' NEGATIVE MASSES '
47794  CALL pystop(111)
47795  ENDIF
47796  pmas(pycomp(ksusy1+if),1)=sqrt(xmf12)
47797  pmas(pycomp(ksusy2+if),1)=sqrt(xmf22)
47798  sfmix(IF,1)=rt(1,1)
47799  sfmix(IF,2)=rt(1,2)
47800  sfmix(IF,3)=rt(2,1)
47801  sfmix(IF,4)=rt(2,2)
47802  170 CONTINUE
47803 
47804 C.....TAU SNEUTRINO MASS...L=3
47805 
47806  xarg=am2(1,1)+xmw2*cos2b
47807  IF(xarg.LT.0d0) THEN
47808  WRITE(mstu(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47809  & ' FROM THE SUM RULE. '
47810  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47811  RETURN
47812  ELSE
47813  pmas(pycomp(ksusy1+16),1)=sqrt(xarg)
47814  ENDIF
47815 
47816  RETURN
47817  END
47818 C*********************************************************************
47819 
47820 C...PYINOM
47821 C...Finds the mass eigenstates and mixing matrices for neutralinos
47822 C...and charginos.
47823 
47824  SUBROUTINE pyinom
47825 
47826 C...Double precision and integer declarations.
47827  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47828  IMPLICIT INTEGER(I-N)
47829  INTEGER PYCOMP
47830 C...Parameter statement to help give large particle numbers.
47831  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
47832  &kexcit=4000000,kdimen=5000000)
47833 C...Commonblocks.
47834  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47835  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47836  common/pymssm/imss(0:99),rmss(0:99)
47837  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
47838  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
47839  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
47840 
47841 C...Local variables.
47842  DOUBLE PRECISION XMW,XMZ,XM(4)
47843  DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47844  DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47845  DOUBLE PRECISION COSW,SINW
47846  DOUBLE PRECISION XMU
47847  DOUBLE PRECISION TANB,COSB,SINB
47848  DOUBLE PRECISION XM1,XM2,XM3,BETA
47849  DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47850  DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47851  DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47852  DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47853  DOUBLE PRECISION PYALPS,PYALEM
47854  DOUBLE PRECISION PYRNM3
47855  COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47856  INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47857  DATA kfnchi/1000022,1000023,1000025,1000035/
47858 
47859  iopt=imss(2)
47860  IF(imss(1).EQ.2) THEN
47861  iopt=1
47862  ENDIF
47863 C...M1, M2, AND M3 ARE INDEPENDENT
47864  IF(iopt.EQ.0) THEN
47865  xm1=rmss(1)
47866  xm2=rmss(2)
47867  xm3=rmss(3)
47868  ELSEIF(iopt.GE.1) THEN
47869  q2=pmas(23,1)**2
47870  aem=pyalem(q2)
47871  a2=aem/paru(102)
47872  a1=aem/(1d0-paru(102))
47873  xm1=rmss(1)
47874  xm2=rmss(2)
47875  IF(imss(1).EQ.2) xm1=rmss(1)/rmss(20)*a1*5d0/3d0
47876  IF(iopt.EQ.1) THEN
47877  xm2=xm1*a2/a1*3d0/5d0
47878  rmss(2)=xm2
47879  ELSEIF(iopt.EQ.3) THEN
47880  xm1=xm2*5d0/3d0*a1/a2
47881  rmss(1)=xm1
47882  ENDIF
47883  xm3=pyrnm3(xm2/a2)
47884  rmss(3)=xm3
47885  IF(xm3.LE.0d0) THEN
47886  WRITE(mstu(11),*) ' ERROR WITH M3 = ',xm3
47887  CALL pystop(105)
47888  ENDIF
47889  ENDIF
47890 
47891 C...GLUINO MASS
47892  IF(imss(3).EQ.1) THEN
47893  pmas(pycomp(ksusy1+21),1)=abs(xm3)
47894  ELSE
47895  aq=0d0
47896  DO 110 i=1,4
47897  DO 100 ilr=1,2
47898  rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
47899  aq=aq+0.5d0*((2d0-rm1)*(rm1*log(rm1)-1d0)
47900  & +(1d0-rm1)**2*log(abs(1d0-rm1)))
47901  100 CONTINUE
47902  110 CONTINUE
47903 
47904  DO 130 i=5,6
47905  DO 120 ilr=1,2
47906  rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
47907  rm2=pmas(i,1)**2/xm3**2
47908  arg=(rm1-rm2-1d0)**2-4d0*rm2**2
47909  IF(arg.GE.0d0) THEN
47910  x0=0.5d0*(1d0+rm2-rm1-sqrt(arg))
47911  ax0=abs(x0)
47912  x1=0.5d0*(1d0+rm2-rm1+sqrt(arg))
47913  ax1=abs(x1)
47914  IF(x0.EQ.1d0) THEN
47915  at=-1d0
47916  bt=0.25d0
47917  ELSEIF(x0.EQ.0d0) THEN
47918  at=0d0
47919  bt=-0.25d0
47920  ELSE
47921  at=0.5d0*log(abs(1d0-x0))*(1d0-x0**2)+
47922  & 0.5d0*x0**2*log(ax0)
47923  bt=(-1d0-2d0*x0)/4d0
47924  ENDIF
47925  IF(x1.EQ.1d0) THEN
47926  at=-1d0+at
47927  bt=0.25d0+bt
47928  ELSEIF(x1.EQ.0d0) THEN
47929  at=0d0+at
47930  bt=-0.25d0+bt
47931  ELSE
47932  at=0.5d0*log(abs(1d0-x1))*(1d0-x1**2)+0.5d0*
47933  & x1**2*log(ax1)+at
47934  bt=(-1d0-2d0*x1)/4d0+bt
47935  ENDIF
47936  aq=aq+at+bt
47937  ELSE
47938  x0=0.5d0*(1d0+rm2-rm1)
47939  y0=-0.5d0*sqrt(-arg)
47940  amgx0=sqrt(x0**2+y0**2)
47941  am1x0=sqrt((1d0-x0)**2+y0**2)
47942  argx0=atan2(-x0,-y0)
47943  ar1x0=atan2(1d0-x0,y0)
47944  x1=x0
47945  y1=-y0
47946  amgx1=amgx0
47947  am1x1=am1x0
47948  argx1=atan2(-x1,-y1)
47949  ar1x1=atan2(1d0-x1,y1)
47950  at=0.5d0*log(am1x0)*(1d0-x0**2+3d0*y0**2)
47951  & +0.5d0*(x0**2-y0**2)*log(amgx0)
47952  bt=(-1d0-2d0*x0)/4d0+x0*y0*( ar1x0-argx0 )
47953  at=at+0.5d0*log(am1x1)*(1d0-x1**2+3d0*y1**2)
47954  & +0.5d0*(x1**2-y1**2)*log(amgx1)
47955  bt=bt+(-1d0-2d0*x1)/4d0+x1*y1*( ar1x1-argx1 )
47956  aq=aq+at+bt
47957  ENDIF
47958  120 CONTINUE
47959  130 CONTINUE
47960  pmas(pycomp(ksusy1+21),1)=abs(xm3)*(1d0+pyalps(xm3**2)
47961  & /(2d0*paru(2))*(15d0+aq))
47962  ENDIF
47963 
47964 C...NEUTRALINO MASSES
47965  DO 150 i=1,4
47966  DO 140 j=1,4
47967  ai(i,j)=0d0
47968  140 CONTINUE
47969  150 CONTINUE
47970  xmz=pmas(23,1)/100d0
47971  xmw=pmas(24,1)/100d0
47972  xmu=rmss(4)/100d0
47973  sinw=sqrt(paru(102))
47974  cosw=sqrt(1d0-paru(102))
47975  tanb=rmss(5)
47976  beta=atan(tanb)
47977  cosb=cos(beta)
47978  sinb=tanb*cosb
47979 
47980  xm2=xm2/100d0
47981  xm1=xm1/100d0
47982 
47983 
47984 C... Definitions:
47985 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
47986 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
47987  ar(1,1) = xm1*cos(rmss(30))
47988  ai(1,1) = xm1*sin(rmss(30))
47989  ar(2,2) = xm2*cos(rmss(31))
47990  ai(2,2) = xm2*sin(rmss(31))
47991  ar(3,3) = 0d0
47992  ar(4,4) = 0d0
47993  ar(1,2) = 0d0
47994  ar(2,1) = 0d0
47995  ar(1,3) = -xmz*sinw*cosb
47996  ar(3,1) = ar(1,3)
47997  ar(1,4) = xmz*sinw*sinb
47998  ar(4,1) = ar(1,4)
47999  ar(2,3) = xmz*cosw*cosb
48000  ar(3,2) = ar(2,3)
48001  ar(2,4) = -xmz*cosw*sinb
48002  ar(4,2) = ar(2,4)
48003  ar(3,4) = -xmu*cos(rmss(33))
48004  ai(3,4) = -xmu*sin(rmss(33))
48005  ar(4,3) = -xmu*cos(rmss(33))
48006  ai(4,3) = -xmu*sin(rmss(33))
48007 C CALL PYEIG4(AR,WR,ZR)
48008  CALL pyeicg(5,4,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
48009  IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
48010  & 'PROBLEM WITH PYEICG IN PYINOM ')
48011  DO 160 i=1,4
48012  index(i)=i
48013  xm(i)=abs(wr(i))
48014  160 CONTINUE
48015  DO 180 i=2,4
48016  k=i
48017  DO 170 j=i-1,1,-1
48018  IF(xm(k).LT.xm(j)) THEN
48019  itmp=index(j)
48020  xtmp=xm(j)
48021  index(j)=index(k)
48022  xm(j)=xm(k)
48023  index(k)=itmp
48024  xm(k)=xtmp
48025  k=k-1
48026  ELSE
48027  GOTO 180
48028  ENDIF
48029  170 CONTINUE
48030  180 CONTINUE
48031 
48032 
48033  DO 210 i=1,4
48034  k=index(i)
48035  smz(i)=wr(k)*100d0
48036  pmas(pycomp(kfnchi(i)),1)=abs(smz(i))
48037  s=0d0
48038  DO 190 j=1,4
48039  s=s+zr(j,k)**2+zi(j,k)**2
48040  190 CONTINUE
48041  DO 200 j=1,4
48042  zmix(i,j)=zr(j,k)/sqrt(s)
48043  zmixi(i,j)=zi(j,k)/sqrt(s)
48044  IF(abs(zmix(i,j)).LT.1d-6) zmix(i,j)=0d0
48045  IF(abs(zmixi(i,j)).LT.1d-6) zmixi(i,j)=0d0
48046  200 CONTINUE
48047  210 CONTINUE
48048 
48049 C...CHARGINO MASSES
48050 C.....Find eigenvectors of X X^*
48051  DO i=1,4
48052  DO j=1,4
48053  ar(i,j)=0d0
48054  ai(i,j)=0d0
48055  ENDDO
48056  ENDDO
48057  ai(1,1) = 0d0
48058  ai(2,2) = 0d0
48059  ar(1,1) = xm2**2+2d0*xmw**2*sinb**2
48060  ar(2,2) = xmu**2+2d0*xmw**2*cosb**2
48061  ar(1,2) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*cosb+
48062  &xmu*cos(rmss(33))*sinb)
48063  ai(1,2) = sqrt(2d0)*xmw*(xm2*sin(rmss(31))*cosb-
48064  &xmu*sin(rmss(33))*sinb)
48065  ar(2,1) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*cosb+
48066  &xmu*cos(rmss(33))*sinb)
48067  ai(2,1) = sqrt(2d0)*xmw*(-xm2*sin(rmss(31))*cosb+
48068  &xmu*sin(rmss(33))*sinb)
48069  CALL pyeicg(5,2,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
48070  IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
48071  & 'PROBLEM WITH PYEICG IN PYINOM ')
48072  index(1)=1
48073  index(2)=2
48074  IF(wr(2).LT.wr(1)) THEN
48075  index(1)=2
48076  index(2)=1
48077  ENDIF
48078 
48079 
48080  DO 240 i=1,2
48081  k=index(i)
48082  smw(i)=sqrt(wr(k))*100d0
48083  s=0d0
48084  DO 220 j=1,2
48085  s=s+zr(j,k)**2+zi(j,k)**2
48086  220 CONTINUE
48087  DO 230 j=1,2
48088  umix(i,j)=zr(j,k)/sqrt(s)
48089  umixi(i,j)=-zi(j,k)/sqrt(s)
48090  IF(abs(umix(i,j)).LT.1d-6) umix(i,j)=0d0
48091  IF(abs(umixi(i,j)).LT.1d-6) umixi(i,j)=0d0
48092  230 CONTINUE
48093  240 CONTINUE
48094 C...Force chargino mass > neutralino mass
48095  ifrc=0
48096  IF(abs(smw(1)).LT.abs(smz(1))+2d0*pmas(pycomp(111),1)) THEN
48097  CALL pyerrm(8,'(PYINOM:) '//
48098  & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48099  smw(1)=sign(abs(smz(1))+2d0*pmas(pycomp(111),1),smw(1))
48100  ifrc=1
48101  ENDIF
48102  pmas(pycomp(ksusy1+24),1)=smw(1)
48103  pmas(pycomp(ksusy1+37),1)=smw(2)
48104 
48105 C.....Find eigenvectors of X^* X
48106  DO i=1,4
48107  DO j=1,4
48108  ar(i,j)=0d0
48109  ai(i,j)=0d0
48110  zr(i,j)=0d0
48111  zi(i,j)=0d0
48112  ENDDO
48113  ENDDO
48114  ai(1,1) = 0d0
48115  ai(2,2) = 0d0
48116  ar(1,1) = xm2**2+2d0*xmw**2*cosb**2
48117  ar(2,2) = xmu**2+2d0*xmw**2*sinb**2
48118  ar(1,2) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*sinb+
48119  &xmu*cos(rmss(33))*cosb)
48120  ai(1,2) = sqrt(2d0)*xmw*(-xm2*sin(rmss(31))*sinb+
48121  &xmu*sin(rmss(33))*cosb)
48122  ar(2,1) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*sinb+
48123  &xmu*cos(rmss(33))*cosb)
48124  ai(2,1) = sqrt(2d0)*xmw*(xm2*sin(rmss(31))*sinb-
48125  &xmu*sin(rmss(33))*cosb)
48126  CALL pyeicg(5,2,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
48127  IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
48128  & 'PROBLEM WITH PYEICG IN PYINOM ')
48129  index(1)=1
48130  index(2)=2
48131  IF(wr(2).LT.wr(1)) THEN
48132  index(1)=2
48133  index(2)=1
48134  ENDIF
48135 
48136  simag=0d0
48137  DO 270 i=1,2
48138  k=index(i)
48139  s=0d0
48140  DO 250 j=1,2
48141  s=s+zr(j,k)**2+zi(j,k)**2
48142  simag=simag+zi(j,k)**2
48143  250 CONTINUE
48144  DO 260 j=1,2
48145  vmix(i,j)=zr(j,k)/sqrt(s)
48146  vmixi(i,j)=-zi(j,k)/sqrt(s)
48147  IF(abs(vmix(i,j)).LT.1d-6) vmix(i,j)=0d0
48148  IF(abs(vmixi(i,j)).LT.1d-6) vmixi(i,j)=0d0
48149  260 CONTINUE
48150  270 CONTINUE
48151 
48152 C.....Simplify if no phases
48153  IF(simag.LT.1d-6) THEN
48154  ar(1,1) = xm2*cos(rmss(31))
48155  ar(2,2) = xmu*cos(rmss(33))
48156  ar(1,2) = sqrt(2d0)*xmw*sinb
48157  ar(2,1) = sqrt(2d0)*xmw*cosb
48158  iknt=0
48159  300 CONTINUE
48160  DO i=1,2
48161  DO j=1,2
48162  zr(i,j)=0d0
48163  ENDDO
48164  ENDDO
48165 
48166  DO i=1,2
48167  DO j=1,2
48168  DO k=1,2
48169  DO l=1,2
48170  zr(i,j)=zr(i,j)+umix(i,k)*ar(k,l)*vmix(j,l)
48171  ENDDO
48172  ENDDO
48173  ENDDO
48174  ENDDO
48175  vmix(1,1)=vmix(1,1)*smw(1)/zr(1,1)/100d0
48176  vmix(1,2)=vmix(1,2)*smw(1)/zr(1,1)/100d0
48177  vmix(2,1)=vmix(2,1)*smw(2)/zr(2,2)/100d0
48178  vmix(2,2)=vmix(2,2)*smw(2)/zr(2,2)/100d0
48179  IF(iknt.EQ.2.AND.ifrc.EQ.0) THEN
48180  CALL pyerrm(18,'(PYINOM:) Problem with Charginos')
48181  ELSEIF(zr(1,1).LT.0d0.OR.zr(2,2).LT.0d0) THEN
48182  iknt=iknt+1
48183  GOTO 300
48184  ENDIF
48185 C.....Must deal with phases
48186  ELSE
48187  car(1,1) = xm2*cmplx(cos(rmss(31)),sin(rmss(31)))
48188  car(2,2) = xmu*cmplx(cos(rmss(33)),sin(rmss(33)))
48189  car(1,2) = sqrt(2d0)*xmw*sinb*cmplx(1d0,0d0)
48190  car(2,1) = sqrt(2d0)*xmw*cosb*cmplx(1d0,0d0)
48191 
48192  iknt=0
48193  310 CONTINUE
48194  DO i=1,2
48195  DO j=1,2
48196  cai(i,j)=cmplx(0d0,0d0)
48197  ENDDO
48198  ENDDO
48199 
48200  DO i=1,2
48201  DO j=1,2
48202  DO k=1,2
48203  DO l=1,2
48204  cai(i,j)=cai(i,j)+cmplx(umix(i,k),-umixi(i,k))*car(k,l)*
48205  & cmplx(vmix(j,l),vmixi(j,l))
48206  ENDDO
48207  ENDDO
48208  ENDDO
48209  ENDDO
48210 
48211  ca1=smw(1)*cai(1,1)/abs(cai(1,1))**2/100d0
48212  ca2=smw(2)*cai(2,2)/abs(cai(2,2))**2/100d0
48213  tempr=vmix(1,1)
48214  tempi=vmixi(1,1)
48215  vmix(1,1)=tempr*dble(ca1)-tempi*dimag(ca1)
48216  vmixi(1,1)=tempi*dble(ca1)+tempr*dimag(ca1)
48217  tempr=vmix(1,2)
48218  tempi=vmixi(1,2)
48219  vmix(1,2)=tempr*dble(ca1)-tempi*dimag(ca1)
48220  vmixi(1,2)=tempi*dble(ca1)+tempr*dimag(ca1)
48221  tempr=vmix(2,1)
48222  tempi=vmixi(2,1)
48223  vmix(2,1)=tempr*dble(ca2)-tempi*dimag(ca2)
48224  vmixi(2,1)=tempi*dble(ca2)+tempr*dimag(ca2)
48225  tempr=vmix(2,2)
48226  tempi=vmixi(2,2)
48227  vmix(2,2)=tempr*dble(ca2)-tempi*dimag(ca2)
48228  vmixi(2,2)=tempi*dble(ca2)+tempr*dimag(ca2)
48229  IF(iknt.EQ.2.AND.ifrc.EQ.0) THEN
48230  CALL pyerrm(18,'(PYINOM:) Problem with Charginos')
48231  ELSEIF(dble(ca1).LT.0d0.OR.dble(ca2).LT.0d0.OR.
48232  & abs(imag(ca1)).GT.1d-3.OR.abs(imag(ca2)).GT.1d-3) THEN
48233  iknt=iknt+1
48234  GOTO 310
48235  ENDIF
48236  ENDIF
48237  RETURN
48238  END
48239 
48240 C*********************************************************************
48241 
48242 C...PYRNM3
48243 C...Calculates the running of M3, the SU(3) gluino mass parameter.
48244 
48245  FUNCTION pyrnm3(RGUT)
48246 
48247 C...Double precision and integer declarations.
48248  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48249  IMPLICIT INTEGER(I-N)
48250  INTEGER PYK,PYCHGE,PYCOMP
48251 
48252 C...Local variables.
48253  DOUBLE PRECISION R
48254  DOUBLE PRECISION TOL
48255  EXTERNAL pyalps
48256  DOUBLE PRECISION PYALPS
48257  DATA tol/0.001d0/
48258  DATA r/0.61803399d0/
48259 
48260  c=1d0-r
48261 
48262  bx=rgut*pyalps(rgut**2)
48263  ax=min(50d0,bx*0.5d0)
48264  cx=max(2000d0,2d0*bx)
48265 
48266  x0=ax
48267  x3=cx
48268  IF(abs(cx-bx).GT.abs(bx-ax))THEN
48269  x1=bx
48270  x2=bx+c*(cx-bx)
48271  ELSE
48272  x2=bx
48273  x1=bx-c*(bx-ax)
48274  ENDIF
48275  as1=pyalps(x1**2)
48276  f1=abs(x1-rgut*as1)
48277  as2=pyalps(x2**2)
48278  f2=abs(x2-rgut*as2)
48279  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
48280  IF(f2.LT.f1) THEN
48281  x0=x1
48282  x1=x2
48283  x2=r*x1+c*x3
48284  f1=f2
48285  as2=pyalps(x2**2)
48286  f2=abs(x2-rgut*as2)
48287  ELSE
48288  x3=x2
48289  x2=x1
48290  x1=r*x2+c*x0
48291  f2=f1
48292  as1=pyalps(x1**2)
48293  f1=abs(x1-rgut*as1)
48294  ENDIF
48295  GOTO 100
48296  ENDIF
48297  IF(f1.LT.f2) THEN
48298  pyrnm3=x1
48299  xmin=x1
48300  ELSE
48301  pyrnm3=x2
48302  xmin=x2
48303  ENDIF
48304 
48305  RETURN
48306  END
48307 
48308 C*********************************************************************
48309 
48310 C...PYEIG4
48311 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48312 C...Specific application: mixing in neutralino sector.
48313 
48314  SUBROUTINE pyeig4(A,W,Z)
48315 
48316 C...Double precision and integer declarations.
48317  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48318  IMPLICIT INTEGER(I-N)
48319  INTEGER PYK,PYCHGE,PYCOMP
48320 
48321 C...Arrays: in call and local.
48322  dimension a(4,4),w(4),z(4,4),x(4),d(4,4),e(4)
48323 
48324 C...Coefficients of fourth-degree equation from matrix.
48325 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48326  b3=-(a(1,1)+a(2,2)+a(3,3)+a(4,4))
48327  b2=0d0
48328  DO 110 i=1,3
48329  DO 100 j=i+1,4
48330  b2=b2+a(i,i)*a(j,j)-a(i,j)*a(j,i)
48331  100 CONTINUE
48332  110 CONTINUE
48333  b1=0d0
48334  b0=0d0
48335  DO 120 i=1,4
48336  i1=mod(i,4)+1
48337  i2=mod(i+1,4)+1
48338  i3=mod(i+2,4)+1
48339  b1=b1+a(i,i)*(-a(i1,i1)*a(i2,i2)+a(i1,i2)*a(i2,i1)+
48340  & a(i1,i3)*a(i3,i1)+a(i2,i3)*a(i3,i2))-
48341  & a(i,i1)*a(i1,i2)*a(i2,i)-a(i,i2)*a(i2,i1)*a(i1,i)
48342  b0=b0+(-1d0)**(i+1)*a(1,i)*(
48343  & a(2,i1)*(a(3,i2)*a(4,i3)-a(3,i3)*a(4,i2))+
48344  & a(2,i2)*(a(3,i3)*a(4,i1)-a(3,i1)*a(4,i3))+
48345  & a(2,i3)*(a(3,i1)*a(4,i2)-a(3,i2)*a(4,i1)))
48346  120 CONTINUE
48347 
48348 C...Coefficients of third-degree equation needed for
48349 C...separation into two second-degree equations.
48350 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48351  c2=-b2
48352  c1=b1*b3-4d0*b0
48353  c0=-b1**2-b0*b3**2+4d0*b0*b2
48354  cq=c1/3d0-c2**2/9d0
48355  cr=c1*c2/6d0-c0/2d0-c2**3/27d0
48356  cqr=cq**3+cr**2
48357 
48358 C...Cases with one or three real roots.
48359  IF(cqr.GE.0d0) THEN
48360  s1=(cr+sqrt(cqr))**(1d0/3d0)
48361  s2=(cr-sqrt(cqr))**(1d0/3d0)
48362  u=s1+s2-c2/3d0
48363  ELSE
48364  sabs=sqrt(-cq)
48365  the=acos(cr/sabs**3)/3d0
48366  sre=sabs*cos(the)
48367  u=2d0*sre-c2/3d0
48368  ENDIF
48369 
48370 C...Find and solve two second-degree equations.
48371  p1=b3/2d0-sqrt(b3**2/4d0+u-b2)
48372  p2=b3/2d0+sqrt(b3**2/4d0+u-b2)
48373  q1=u/2d0+sqrt(u**2/4d0-b0)
48374  q2=u/2d0-sqrt(u**2/4d0-b0)
48375  IF(abs(p1*q1+p2*q2-b1).LT.abs(p1*q2+p2*q1-b1)) THEN
48376  qsav=q1
48377  q1=q2
48378  q2=qsav
48379  ENDIF
48380  x(1)=-p1/2d0+sqrt(p1**2/4d0-q1)
48381  x(2)=-p1/2d0-sqrt(p1**2/4d0-q1)
48382  x(3)=-p2/2d0+sqrt(p2**2/4d0-q2)
48383  x(4)=-p2/2d0-sqrt(p2**2/4d0-q2)
48384 
48385 C...Order eigenvalues in asceding mass.
48386  w(1)=x(1)
48387  DO 150 i1=2,4
48388  DO 130 i2=i1-1,1,-1
48389  IF(abs(x(i1)).GE.abs(w(i2))) GOTO 140
48390  w(i2+1)=w(i2)
48391  130 CONTINUE
48392  140 w(i2+1)=x(i1)
48393  150 CONTINUE
48394 
48395 C...Find equation system for eigenvectors.
48396  DO 250 i=1,4
48397  DO 170 j1=1,4
48398  d(j1,j1)=a(j1,j1)-w(i)
48399  DO 160 j2=j1+1,4
48400  d(j1,j2)=a(j1,j2)
48401  d(j2,j1)=a(j2,j1)
48402  160 CONTINUE
48403  170 CONTINUE
48404 
48405 C...Find largest element in matrix.
48406  damax=0d0
48407  DO 190 j1=1,4
48408  DO 180 j2=1,4
48409  IF(abs(d(j1,j2)).LE.damax) GOTO 180
48410  ja=j1
48411  jb=j2
48412  damax=abs(d(j1,j2))
48413  180 CONTINUE
48414  190 CONTINUE
48415 
48416 C...Subtract others by multiple of row selected above.
48417  damax=0d0
48418  DO 210 j3=ja+1,ja+3
48419  j1=j3-4*((j3-1)/4)
48420  rl=d(j1,jb)/d(ja,jb)
48421  DO 200 j2=1,4
48422  d(j1,j2)=d(j1,j2)-rl*d(ja,j2)
48423  IF(abs(d(j1,j2)).LE.damax) GOTO 200
48424  jc=j1
48425  jd=j2
48426  damax=abs(d(j1,j2))
48427  200 CONTINUE
48428  210 CONTINUE
48429 
48430 C...Do one more subtraction of a row.
48431  damax=0d0
48432  DO 230 j3=jc+1,jc+3
48433  j1=j3-4*((j3-1)/4)
48434  IF(j1.EQ.ja) GOTO 230
48435  rl=d(j1,jd)/d(jc,jd)
48436  DO 220 j2=1,4
48437  IF(j2.EQ.jb) GOTO 220
48438  d(j1,j2)=d(j1,j2)-rl*d(jc,j2)
48439  IF(abs(d(j1,j2)).LE.damax) GOTO 220
48440  je=j1
48441  damax=abs(d(j1,j2))
48442  220 CONTINUE
48443  230 CONTINUE
48444 
48445 C...Construct unnormalized eigenvector.
48446  jf1=jd+1-4*(jd/4)
48447  jf2=jd+2-4*((jd+1)/4)
48448  IF(jf1.EQ.jb) jf1=jd+3-4*((jd+2)/4)
48449  IF(jf2.EQ.jb) jf2=jd+3-4*((jd+2)/4)
48450  e(jf1)=-d(je,jf2)
48451  e(jf2)=d(je,jf1)
48452  e(jd)=-(d(jc,jf1)*e(jf1)+d(jc,jf2)*e(jf2))/d(jc,jd)
48453  e(jb)=-(d(ja,jf1)*e(jf1)+d(ja,jf2)*e(jf2)+d(ja,jd)*e(jd))/
48454  & d(ja,jb)
48455 
48456 C...Normalize and fill in final array.
48457  ea=sqrt(e(1)**2+e(2)**2+e(3)**2+e(4)**2)
48458  sgn=(-1d0)**int(pyr(0)+0.5d0)
48459  DO 240 j=1,4
48460  z(i,j)=sgn*e(j)/ea
48461  240 CONTINUE
48462  250 CONTINUE
48463 
48464  RETURN
48465  END
48466 
48467 C*********************************************************************
48468 
48469 C...PYHGGM
48470 C...Determines the Higgs boson mass spectrum using several inputs.
48471 
48472  SUBROUTINE pyhggm(ALPHA)
48473 
48474 C...Double precision and integer declarations.
48475  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48476  IMPLICIT INTEGER(I-N)
48477  INTEGER PYK,PYCHGE,PYCOMP
48478 C...Parameter statement to help give large particle numbers.
48479  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
48480  &kexcit=4000000,kdimen=5000000)
48481 C...Commonblocks.
48482  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48483  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48484  common/pypars/mstp(200),parp(200),msti(200),pari(200)
48485  common/pymssm/imss(0:99),rmss(0:99)
48486  SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/
48487 
48488 C...Local variables.
48489  DOUBLE PRECISION AT,AB,XMU,TANB
48490  DOUBLE PRECISION ALPHA
48491  INTEGER IHOPT
48492  DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48493  DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48494  DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48495  DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48496 
48497  ihopt=imss(4)
48498  IF(ihopt.EQ.2) THEN
48499  alpha=rmss(18)
48500  RETURN
48501  ENDIF
48502  at=rmss(16)
48503  ab=rmss(15)
48504  dmgl=rmss(3)
48505  xmu=rmss(4)
48506  tanb=rmss(5)
48507 
48508  dma=rmss(19)
48509  dtanb=tanb
48510  dmq=rmss(10)
48511  dmur=rmss(12)
48512  dmdr=rmss(11)
48513  dmtop=pmas(6,1)
48514  dmc=pmas(pycomp(ksusy1+37),1)
48515  dau=at
48516  dad=ab
48517  dmu=xmu
48518  rmss(40)=0d0
48519  rmss(41)=0d0
48520 
48521  IF(ihopt.EQ.0) THEN
48522  CALL pysubh (dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
48523  & dmhch,dsa,dca,dtanba)
48524  ELSEIF(ihopt.EQ.1) THEN
48525  CALL pysubh (dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
48526  & dmhch,dsa,dca,dtanba)
48527  CALL pypole(3,dmc,dma,dtanb,dmq,dmur,dmdr,dmtop,dau,dad,dmu,
48528  & dmh,dmhp,dhm,dhmp,damp,dsa,dca,
48529  & dstop1,dstop2,dsbot1,dsbot2,dtanba,dmgl,ddt,ddb)
48530  rmss(40)=ddt
48531  rmss(41)=ddb
48532  dmh=dmhp
48533  dhm=dhmp
48534  dma=damp
48535  IF(abs(pmas(pycomp(1000006),1)-dstop2).GT.5d-1) THEN
48536  WRITE(mstu(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48537  WRITE(mstu(11),*) ' STOP1 MASSES = ',
48538  & pmas(pycomp(1000006),1),dstop2
48539  ENDIF
48540  IF(abs(pmas(pycomp(2000006),1)-dstop1).GT.5d-1) THEN
48541  WRITE(mstu(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48542  WRITE(mstu(11),*) ' STOP2 MASSES = ',
48543  & pmas(pycomp(2000006),1),dstop1
48544  ENDIF
48545  IF(abs(pmas(pycomp(1000005),1)-dsbot2).GT.5d-1) THEN
48546  WRITE(mstu(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48547  WRITE(mstu(11),*) ' SBOT1 MASSES = ',
48548  & pmas(pycomp(1000005),1),dsbot2
48549  ENDIF
48550  IF(abs(pmas(pycomp(2000005),1)-dsbot1).GT.5d-1) THEN
48551  WRITE(mstu(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48552  WRITE(mstu(11),*) ' SBOT2 MASSES = ',
48553  & pmas(pycomp(2000005),1),dsbot1
48554  ENDIF
48555 
48556  ELSEIF (ihopt.EQ.3) THEN
48557 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48558 C...Currently only available for SLHA spectrum read-in.
48559  IF (imss(1).NE.11.AND.imss(1).NE.12.AND.imss(1).NE.13) THEN
48560  CALL pyerrm(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48561  & //' spectrum, change IMSS(1) or IMSS(4) option.')
48562  ENDIF
48563  alpha=rmss(18)
48564  RETURN
48565  ENDIF
48566 
48567  alpha=acos(dca)
48568 
48569  pmas(25,1)=dmh
48570  pmas(35,1)=dhm
48571  pmas(36,1)=dma
48572  pmas(37,1)=dmhch
48573 
48574  RETURN
48575  END
48576 
48577 C*********************************************************************
48578 
48579 C...PYSUBH
48580 C...This routine computes the renormalization group improved
48581 C...values of Higgs masses and couplings in the MSSM.
48582 
48583 C...Program based on the work by M. Carena, J.R. Espinosa,
48584 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48585 
48586 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48587 C...All masses in GeV units. MA is the CP-odd Higgs mass,
48588 C...MTOP is the physical top mass, MQ and MUR are the soft
48589 C...supersymmetry breaking mass parameters of left handed
48590 C...and right handed stops respectively, AU and AD are the
48591 C...stop and sbottom trilinear soft breaking terms,
48592 C...respectively, and MU is the supersymmetric
48593 C...Higgs mass parameter. We use the conventions from
48594 C...the physics report of Haber and Kane: left right
48595 C...stop mixing term proportional to (AU - MU/TANB)
48596 C...We use as input TANB defined at the scale MTOP
48597 
48598 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48599 C...where MH and HM are the lightest and heaviest CP-even
48600 C...Higgs masses, MHCH is the charged Higgs mass and
48601 C...ALPHA is the Higgs mixing angle
48602 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48603 
48604 C...Range of validity:
48605 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48606 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48607 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48608 C...are the sbottom mass eigenvalues, respectively. This
48609 C...range automatically excludes the existence of tachyons.
48610 C...For the charged Higgs mass computation, the method is
48611 C...valid if
48612 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48613 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48614 C...where M_SUSY**2 is the average of the squared stop mass
48615 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48616 C...masses have been assumed to be of order of the stop ones
48617 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48618 
48619  SUBROUTINE pysubh (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48620  &XMHCH,SA,CA,TANBA)
48621 
48622 C...Double precision and integer declarations.
48623  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48624  IMPLICIT INTEGER(I-N)
48625  INTEGER PYK,PYCHGE,PYCOMP
48626 C...Parameter statement to help give large particle numbers.
48627  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
48628  &kexcit=4000000,kdimen=5000000)
48629 C...Commonblocks.
48630  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48631  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48632  common/pyhtri/hhh(7)
48633  SAVE /pydat1/,/pydat2/
48634 
48635 C...Local variables.
48636  DOUBLE PRECISION PYALEM,PYALPS
48637  DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48638  DOUBLE PRECISION XMHCH,SA,CA
48639  DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48640  DOUBLE PRECISION Q02
48641  DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48642  DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48643  DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48644  DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48645  DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48646  DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48647  DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48648  DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48649 
48650  xmz = pmas(23,1)
48651  q02=xmz**2
48652  aem=pyalem(q02)
48653  alp1=aem/(1d0-paru(102))
48654  alp2=aem/paru(102)
48655  alph3z=pyalps(q02)
48656 
48657  alp1 = 0.0101d0
48658  alp2 = 0.0337d0
48659  alph3z = 0.12d0
48660 
48661  v = 174.1d0
48662  pi = paru(1)
48663  tanba = tanb
48664  tanbt = tanb
48665 
48666 C...MBOTTOM(MTOP) = 3. GEV
48667  xmb = pymrun(5,xmtop**2)
48668  alp3 = alph3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alph3z*
48669  &log(xmtop**2/xmz**2))
48670 
48671 C...RMTOP= RUNNING TOP QUARK MASS
48672  rmtop = xmtop/(1d0+4d0*alp3/3d0/pi)
48673  xms = ((xmq**2 + xmur**2)/2d0 + xmtop**2)**0.5d0
48674  t = log(xms**2/xmtop**2)
48675  sinb = tanb/((1d0 + tanb**2)**0.5d0)
48676  cosb = sinb/tanb
48677 C...IF(MA.LE.XMTOP) TANBA = TANBT
48678  IF(xma.GT.xmtop)
48679  &tanba = tanbt*(1d0-3d0/32d0/pi**2*
48680  &(rmtop**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*
48681  &log(xma**2/xmtop**2))
48682 
48683  sinbt = tanbt/sqrt(1d0 + tanbt**2)
48684  cosbt = 1d0/sqrt(1d0 + tanbt**2)
48685 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48686  g1 = sqrt(alp1*4d0*pi)
48687  g2 = sqrt(alp2*4d0*pi)
48688  g3 = sqrt(alp3*4d0*pi)
48689  hu = rmtop/v/sinbt
48690  hd = xmb/v/cosbt
48691  hu2=hu*hu
48692  hd2=hd*hd
48693  hu4=hu2*hu2
48694  hd4=hd2*hd2
48695  au2=au**2
48696  ad2=ad**2
48697  xms2=xms**2
48698  xms3=xms**3
48699  xms4=xms2*xms2
48700  xmu2=xmu*xmu
48701  pi2=pi*pi
48702 
48703  xau = (2d0*au2/xms2)*(1d0 - au2/12d0/xms2)
48704  xad = (2d0*ad2/xms2)*(1d0 - ad2/12d0/xms2)
48705  aud = (-6d0*xmu2/xms2 - ( xmu2- ad*au)**2/xms4
48706  &+ 3d0*(au + ad)**2/xms2)/6d0
48707  xlam1 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hd2*t/8d0/pi2)
48708  &+(3d0*hd4/8d0/pi2) * (t + xad/2d0 + (3d0*hd2/2d0 + hu2/2d0
48709  &- 8d0*g3**2) * (xad*t + t**2)/16d0/pi2)
48710  &-(3d0*hu4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hu2 -5d0* hd2
48711  &- 16d0*g3**2) *t/16d0/pi2)
48712  xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu2*t/8d0/pi2)
48713  &+(3d0*hu4/8d0/pi2) * (t + xau/2d0 + (3d0*hu2/2d0 + hd2/2d0
48714  &- 8d0*g3**2) * (xau*t + t**2)/16d0/pi2)
48715  &-(3d0*hd4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hd2 -5d0* hu2
48716  &- 16d0*g3**2) *t/16d0/pi2)
48717  xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
48718  &(hu2 + hd2)*t/16d0/pi2)
48719  &+(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
48720  &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
48721  &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
48722  &xms4)* (1d0+ (6d0*hu2 -2d0* hd2/2d0
48723  &- 16d0*g3**2) *t/16d0/pi2)
48724  &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
48725  &xms4)*(1d0+ (6d0*hd2 -2d0* hu2
48726  &- 16d0*g3**2) *t/16d0/pi2)
48727  xlam4 = (- g2**2/2d0)*(1d0-3d0*(hu2 + hd2)*t/16d0/pi2)
48728  &-(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
48729  &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
48730  &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
48731  &xms4)*
48732  &(1+ (6d0*hu2 -2d0* hd2
48733  &- 16d0*g3**2) *t/16d0/pi2)
48734  &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
48735  &xms4)*
48736  &(1+ (6d0*hd2 -2d0* hu2/2d0
48737  &- 16d0*g3**2) *t/16d0/pi2)
48738  xlam5 = -(3d0*hu4* xmu2*au2/96d0/pi2/xms4) *
48739  &(1- (2d0*hd2 -6d0* hu2 + 16d0*g3**2) *t/16d0/pi2)
48740  &-(3d0*hd4* xmu2*ad2/96d0/pi2/xms4) *
48741  &(1- (2d0*hu2 -6d0* hd2 + 16d0*g3**2) *t/16d0/pi2)
48742  xlam6 = (3d0*hu4* xmu**3*au/96d0/pi2/xms4) *
48743  &(1- (7d0*hd2/2d0 -15d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48744  &+(3d0*hd4* xmu *(ad**3/xms3 - 6d0*ad/xms )/96d0/pi2/xms) *
48745  &(1- (hu2/2d0 -9d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48746  xlam7 = (3d0*hd4* xmu**3*ad/96d0/pi2/xms4) *
48747  &(1- (7d0*hu2/2d0 -15d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48748  &+(3d0*hu4* xmu *(au**3/xms3 - 6d0*au/xms )/96d0/pi2/xms) *
48749  &(1- (hd2/2d0 -9d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48750  hhh(1)=xlam1
48751  hhh(2)=xlam2
48752  hhh(3)=xlam3
48753  hhh(4)=xlam4
48754  hhh(5)=xlam5
48755  hhh(6)=xlam6
48756  hhh(7)=xlam7
48757  trm2 = xma**2 + 2d0*v**2* (xlam1* cosbt**2 +
48758  &2d0* xlam6*sinbt*cosbt
48759  &+ xlam5*sinbt**2 + xlam2* sinbt**2 + 2d0* xlam7*sinbt*cosbt
48760  &+ xlam5*cosbt**2)
48761  detm2 = 4d0*v**4*(-(sinbt*cosbt*(xlam3 + xlam4) +
48762  &xlam6*cosbt**2
48763  &+ xlam7* sinbt**2)**2 + (xlam1* cosbt**2 +
48764  &2d0* xlam6* cosbt*sinbt
48765  &+ xlam5*sinbt**2)*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
48766  &+ xlam5*cosbt**2)) + xma**2*2d0*v**2 *
48767  &((xlam1* cosbt**2 +2d0*
48768  &xlam6* cosbt*sinbt + xlam5*sinbt**2)*cosbt**2 +
48769  &(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt + xlam5*cosbt**2)
48770  &*sinbt**2
48771  &+2d0*sinbt*cosbt* (sinbt*cosbt*(xlam3
48772  &+ xlam4) + xlam6*cosbt**2
48773  &+ xlam7* sinbt**2))
48774 
48775  xmh2 = (trm2 - sqrt(trm2**2 - 4d0* detm2))/2d0
48776  xhm2 = (trm2 + sqrt(trm2**2 - 4d0* detm2))/2d0
48777  xhm = sqrt(xhm2)
48778  xmh = sqrt(xmh2)
48779  xmhch2 = xma**2 + (xlam5 - xlam4)* v**2
48780  xmhch = sqrt(xmhch2)
48781 
48782  sinalp = sqrt(((trm2**2 - 4d0* detm2)**0.5d0) -
48783  &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
48784  &xlam6* cosbt*sinbt
48785  &+ xlam5*sinbt**2) + xma**2*sinbt**2)
48786  &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
48787  &+ xlam5*cosbt**2) + xma**2*cosbt**2)))/
48788  &sqrt(((trm2**2 - 4d0* detm2)**0.5d0))/2d0**0.5d0
48789 
48790  cosalp = (2d0*(2d0*v**2*(sinbt*cosbt*(xlam3 + xlam4) +
48791  &xlam6*cosbt**2 + xlam7* sinbt**2) -
48792  &xma**2*sinbt*cosbt))/2d0**0.5d0/
48793  &sqrt(((trm2**2 - 4d0* detm2)**0.5d0)*
48794  &(((trm2**2 - 4d0* detm2)**0.5d0) -
48795  &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
48796  &xlam6* cosbt*sinbt
48797  &+ xlam5*sinbt**2) + xma**2*sinbt**2)
48798  &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
48799  &+ xlam5*cosbt**2) + xma**2*cosbt**2))))
48800 
48801  sa = -sinalp
48802  ca = -cosalp
48803 
48804  100 CONTINUE
48805 
48806  RETURN
48807  END
48808 
48809 C*********************************************************************
48810 
48811 C...PYPOLE
48812 C...This subroutine computes the CP-even higgs and CP-odd pole
48813 c...Higgs masses and mixing angles.
48814 
48815 C...Program based on the work by M. Carena, M. Quiros
48816 C...and C.E.M. Wagner, "Effective potential methods and
48817 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48818 
48819 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48820 C...AT,AB,MU
48821 C...where MCHI is the largest chargino mass, MA is the running
48822 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48823 C...expectaion values at the scale MTOP, MQ is the third generation
48824 C...left handed squark mass parameter, MUR is the third generation
48825 C...right handed stop mass parameter, MDR is the third generation
48826 C...right handed sbottom mass parameter, MTOP is the pole top quark
48827 C...mass; AT,AB are the soft supersymmetry breaking trilinear
48828 C...couplings of the stop and sbottoms, respectively, and MU is the
48829 C...supersymmetric mass parameter
48830 
48831 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48832 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48833 C...masses are given, what makes the running of the program
48834 c...much faster and it is quite generally a good approximation
48835 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48836 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48837 c...and if IHIGGS=3, then h,H,A polarizations are computed
48838 
48839 C...Output: MH and MHP which are the lightest CP-even Higgs running
48840 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48841 C...Higgs running and pole masses, repectively; SA and CA are the
48842 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48843 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48844 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48845 C...the value of TANB at the CP-odd Higgs mass scale
48846 
48847 C...This subroutine makes use of CERN library subroutine
48848 C...integration package, which makes the computation of the
48849 C...pole Higgs masses somewhat faster. We thank P. Janot for this
48850 C...improvement. Those who are not able to call the CERN
48851 C...libraries, please use the subroutine SUBHPOLE2.F, which
48852 C...although somewhat slower, gives identical results
48853 
48854  SUBROUTINE pypole(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48855  &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48856 
48857 C...Double precision and integer declarations.
48858  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48859  IMPLICIT INTEGER(I-N)
48860 
48861 C...Parameters.
48862  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48863  SAVE /pydat1/
48864  INTEGER PYK,PYCHGE,PYCOMP
48865 
48866 C...Local variables.
48867  dimension delta(2,2),coupt(2,2),t(2,2),sstop2(2),
48868  &ssbot2(2),b(2,2),coupb(2,2),
48869  &hcoupt(2,2),hcoupb(2,2),
48870  &acoupt(2,2),acoupb(2,2),pr(3), polar(3)
48871 
48872  delta(1,1) = 1d0
48873  delta(2,2) = 1d0
48874  delta(1,2) = 0d0
48875  delta(2,1) = 0d0
48876  v = 174.1d0
48877  xmz=91.18d0
48878  pi=paru(1)
48879  rxmt=pymrun(6,xmt**2)
48880  CALL pyrghm(xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,
48881  &xmu,xmh,hm,xmch,sa,ca,sab,cab,tanba,xmg,dt,db)
48882 
48883  sinb = tanb/(tanb**2+1d0)**0.5d0
48884  cosb = 1d0/(tanb**2+1d0)**0.5d0
48885  cos2b = sinb**2 - cosb**2
48886  sinbpa = sinb*ca + cosb*sa
48887  cosbpa = cosb*ca - sinb*sa
48888  rmbot = pymrun(5,xmt**2)
48889  xmq2 = xmq**2
48890  xmur2 = xmur**2
48891  IF(xmur.LT.0d0) xmur2=-xmur2
48892  xmdr2 = xmdr**2
48893  xmst11 = rxmt**2 + xmq2 - 0.35d0*xmz**2*cos2b
48894  xmst22 = rxmt**2 + xmur2 - 0.15d0*xmz**2*cos2b
48895  IF(xmst11.LT.0d0) GOTO 500
48896  IF(xmst22.LT.0d0) GOTO 500
48897  xmsb11 = rmbot**2 + xmq2 + 0.42d0*xmz**2*cos2b
48898  xmsb22 = rmbot**2 + xmdr2 + 0.08d0*xmz**2*cos2b
48899  IF(xmsb11.LT.0d0) GOTO 500
48900  IF(xmsb22.LT.0d0) GOTO 500
48901 C WMST11 = RXMT**2 + XMQ2
48902 C WMST22 = RXMT**2 + XMUR2
48903  xmst12 = rxmt*(at - xmu/tanb)
48904  xmsb12 = rmbot*(ab - xmu*tanb)
48905 
48906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48907 C...STOP EIGENVALUES CALCULATION
48908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48909 
48910  stop12 = 0.5d0*(xmst11+xmst22) +
48911  &0.5d0*((xmst11+xmst22)**2 -
48912  &4d0*(xmst11*xmst22 - xmst12**2))**0.5d0
48913  stop22 = 0.5d0*(xmst11+xmst22) -
48914  &0.5d0*((xmst11+xmst22)**2 - 4d0*(xmst11*xmst22 -
48915  &xmst12**2))**0.5d0
48916 
48917  IF(stop22.LT.0d0) GOTO 500
48918  sstop2(1) = stop12
48919  sstop2(2) = stop22
48920  stop1 = stop12**0.5d0
48921  stop2 = stop22**0.5d0
48922 C STOP1W = STOP1
48923 C STOP2W = STOP2
48924 
48925  IF(xmst12.EQ.0d0) xst11 = 1d0
48926  IF(xmst12.EQ.0d0) xst12 = 0d0
48927  IF(xmst12.EQ.0d0) xst21 = 0d0
48928  IF(xmst12.EQ.0d0) xst22 = 1d0
48929 
48930  IF(xmst12.EQ.0d0) GOTO 110
48931 
48932  100 xst11 = xmst12/(xmst12**2+(xmst11-stop12)**2)**0.5d0
48933  xst12 = - (xmst11-stop12)/(xmst12**2+(xmst11-stop12)**2)**0.5d0
48934  xst21 = xmst12/(xmst12**2+(xmst11-stop22)**2)**0.5d0
48935  xst22 = - (xmst11-stop22)/(xmst12**2+(xmst11-stop22)**2)**0.5d0
48936 
48937  110 t(1,1) = xst11
48938  t(2,2) = xst22
48939  t(1,2) = xst12
48940  t(2,1) = xst21
48941 
48942  sbot12 = 0.5d0*(xmsb11+xmsb22) +
48943  &0.5d0*((xmsb11+xmsb22)**2 -
48944  &4d0*(xmsb11*xmsb22 - xmsb12**2))**0.5d0
48945  sbot22 = 0.5d0*(xmsb11+xmsb22) -
48946  &0.5d0*((xmsb11+xmsb22)**2 - 4d0*(xmsb11*xmsb22 -
48947  &xmsb12**2))**0.5d0
48948  IF(sbot22.LT.0d0) GOTO 500
48949  sbot1 = sbot12**0.5d0
48950  sbot2 = sbot22**0.5d0
48951 
48952  ssbot2(1) = sbot12
48953  ssbot2(2) = sbot22
48954 
48955  IF(xmsb12.EQ.0d0) xsb11 = 1d0
48956  IF(xmsb12.EQ.0d0) xsb12 = 0d0
48957  IF(xmsb12.EQ.0d0) xsb21 = 0d0
48958  IF(xmsb12.EQ.0d0) xsb22 = 1d0
48959 
48960  IF(xmsb12.EQ.0d0) GOTO 130
48961 
48962  120 xsb11 = xmsb12/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
48963  xsb12 = - (xmsb11-sbot12)/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
48964  xsb21 = xmsb12/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
48965  xsb22 = - (xmsb11-sbot22)/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
48966 
48967  130 b(1,1) = xsb11
48968  b(2,2) = xsb22
48969  b(1,2) = xsb12
48970  b(2,1) = xsb21
48971 
48972 
48973  sint = 0.2320d0
48974  sqr = dsqrt(2d0)
48975  vp = 174.1d0*sqr
48976 
48977 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48978 C...STARTING OF LIGHT HIGGS
48979 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48980 
48981  IF(ihiggs.EQ.0) GOTO 490
48982 
48983  DO 150 i = 1,2
48984  DO 140 j = 1,2
48985  coupt(i,j) =
48986  & sint*xmz**2*2d0*sqr/174.1d0/3d0*sinbpa*(delta(i,j) +
48987  & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
48988  & -rxmt**2/174.1d0**2*vp/sinb*ca*delta(i,j)
48989  & -rxmt/vp/sinb*(at*ca + xmu*sa)*(t(1,i)*t(2,j) +
48990  & t(1,j)*t(2,i))
48991  140 CONTINUE
48992  150 CONTINUE
48993 
48994 
48995  DO 170 i = 1,2
48996  DO 160 j = 1,2
48997  coupb(i,j) =
48998  & -sint*xmz**2*2d0*sqr/174.1d0/6d0*sinbpa*(delta(i,j) +
48999  & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
49000  & +rmbot**2/174.1d0**2*vp/cosb*sa*delta(i,j)
49001  & +rmbot/vp/cosb*(ab*sa + xmu*ca)*(b(1,i)*b(2,j) +
49002  & b(1,j)*b(2,i))
49003  160 CONTINUE
49004  170 CONTINUE
49005 
49006  prun = xmh
49007  eps = 1d-4*prun
49008  iter = 0
49009  180 iter = iter + 1
49010  DO 230 i3 = 1,3
49011 
49012  pr(i3)=prun+(i3-2)*eps/2
49013  p2=pr(i3)**2
49014  polt = 0d0
49015  DO 200 i = 1,2
49016  DO 190 j = 1,2
49017  polt = polt + coupt(i,j)**2*3d0*
49018  & pyfint(p2,sstop2(i),sstop2(j))/16d0/pi**2
49019  190 CONTINUE
49020  200 CONTINUE
49021 
49022  polb = 0d0
49023  DO 220 i = 1,2
49024  DO 210 j = 1,2
49025  polb = polb + coupb(i,j)**2*3d0*
49026  & pyfint(p2,ssbot2(i),ssbot2(j))/16d0/pi**2
49027  210 CONTINUE
49028  220 CONTINUE
49029 C RXMT2 = RXMT**2
49030  xmt2=xmt**2
49031 
49032  poltt =
49033  & 3d0*rxmt**2/8d0/pi**2/ v **2*
49034  & ca**2/sinb**2 *
49035  & (-2d0*xmt**2+0.5d0*p2)*
49036  & pyfint(p2,xmt2,xmt2)
49037 
49038  pol = polt + polb + poltt
49039  polar(i3) = p2 - xmh**2 - pol
49040  230 CONTINUE
49041  deriv = (polar(3)-polar(1))/eps
49042  drun = - polar(2)/deriv
49043  prun = prun + drun
49044  p2 = prun**2
49045  IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) GOTO 240
49046  GOTO 180
49047  240 CONTINUE
49048 
49049  xmhp = dsqrt(p2)
49050 
49051 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49052 C...END OF LIGHT HIGGS
49053 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49054 
49055  250 IF(ihiggs.EQ.1) GOTO 490
49056 
49057 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49058 C... STARTING OF HEAVY HIGGS
49059 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49060 
49061  DO 270 i = 1,2
49062  DO 260 j = 1,2
49063  hcoupt(i,j) =
49064  & -sint*xmz**2*2d0*sqr/174.1d0/3d0*cosbpa*(delta(i,j) +
49065  & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
49066  & -rxmt**2/174.1d0**2*vp/sinb*sa*delta(i,j)
49067  & -rxmt/vp/sinb*(at*sa - xmu*ca)*(t(1,i)*t(2,j) +
49068  & t(1,j)*t(2,i))
49069  260 CONTINUE
49070  270 CONTINUE
49071 
49072  DO 290 i = 1,2
49073  DO 280 j = 1,2
49074  hcoupb(i,j) =
49075  & sint*xmz**2*2d0*sqr/174.1d0/6d0*cosbpa*(delta(i,j) +
49076  & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
49077  & -rmbot**2/174.1d0**2*vp/cosb*ca*delta(i,j)
49078  & -rmbot/vp/cosb*(ab*ca - xmu*sa)*(b(1,i)*b(2,j) +
49079  & b(1,j)*b(2,i))
49080  hcoupb(i,j)=0d0
49081  280 CONTINUE
49082  290 CONTINUE
49083 
49084  prun = hm
49085  eps = 1d-4*prun
49086  iter = 0
49087  300 iter = iter + 1
49088  DO 350 i3 = 1,3
49089  pr(i3)=prun+(i3-2)*eps/2
49090  hp2=pr(i3)**2
49091 
49092  hpolt = 0d0
49093  DO 320 i = 1,2
49094  DO 310 j = 1,2
49095  hpolt = hpolt + hcoupt(i,j)**2*3d0*
49096  & pyfint(hp2,sstop2(i),sstop2(j))/16d0/pi**2
49097  310 CONTINUE
49098  320 CONTINUE
49099 
49100  hpolb = 0d0
49101  DO 340 i = 1,2
49102  DO 330 j = 1,2
49103  hpolb = hpolb + hcoupb(i,j)**2*3d0*
49104  & pyfint(hp2,ssbot2(i),ssbot2(j))/16d0/pi**2
49105  330 CONTINUE
49106  340 CONTINUE
49107 
49108 C RXMT2 = RXMT**2
49109  xmt2 = xmt**2
49110 
49111  hpoltt =
49112  & 3d0*rxmt**2/8d0/pi**2/ v **2*
49113  & sa**2/sinb**2 *
49114  & (-2d0*xmt**2+0.5d0*hp2)*
49115  & pyfint(hp2,xmt2,xmt2)
49116 
49117  hpol = hpolt + hpolb + hpoltt
49118  polar(i3) =hp2-hm**2-hpol
49119  350 CONTINUE
49120  deriv = (polar(3)-polar(1))/eps
49121  drun = - polar(2)/deriv
49122  prun = prun + drun
49123  hp2 = prun**2
49124  IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) GOTO 360
49125  GOTO 300
49126  360 CONTINUE
49127 
49128 
49129  370 CONTINUE
49130  hmp = hp2**0.5d0
49131 
49132 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49133 C... END OF HEAVY HIGGS
49134 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49135 
49136  IF(ihiggs.EQ.2) GOTO 490
49137 
49138 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49139 C...BEGINNING OF PSEUDOSCALAR HIGGS
49140 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49141 
49142  DO 390 i = 1,2
49143  DO 380 j = 1,2
49144  acoupt(i,j) =
49145  & -rxmt/vp/sinb*(at*cosb + xmu*sinb)*
49146  & (t(1,i)*t(2,j) -t(1,j)*t(2,i))
49147  380 CONTINUE
49148  390 CONTINUE
49149  DO 410 i = 1,2
49150  DO 400 j = 1,2
49151  acoupb(i,j) =
49152  & rmbot/vp/cosb*(ab*sinb + xmu*cosb)*
49153  & (b(1,i)*b(2,j) -b(1,j)*b(2,i))
49154  400 CONTINUE
49155  410 CONTINUE
49156 
49157  prun = xma
49158  eps = 1d-4*prun
49159  iter = 0
49160  420 iter = iter + 1
49161  DO 470 i3 = 1,3
49162  pr(i3)=prun+(i3-2)*eps/2
49163  ap2=pr(i3)**2
49164  apolt = 0d0
49165  DO 440 i = 1,2
49166  DO 430 j = 1,2
49167  apolt = apolt + acoupt(i,j)**2*3d0*
49168  & pyfint(ap2,sstop2(i),sstop2(j))/16d0/pi**2
49169  430 CONTINUE
49170  440 CONTINUE
49171  apolb = 0d0
49172  DO 460 i = 1,2
49173  DO 450 j = 1,2
49174  apolb = apolb + acoupb(i,j)**2*3d0*
49175  & pyfint(ap2,ssbot2(i),ssbot2(j))/16d0/pi**2
49176  450 CONTINUE
49177  460 CONTINUE
49178 C RXMT2 = RXMT**2
49179  xmt2=xmt**2
49180  apoltt =
49181  & 3d0*rxmt**2/8d0/pi**2/ v **2*
49182  & cosb**2/sinb**2 *
49183  & (-0.5d0*ap2)*
49184  & pyfint(ap2,xmt2,xmt2)
49185  apol = apolt + apolb + apoltt
49186  polar(i3) = ap2 - xma**2 -apol
49187  470 CONTINUE
49188  deriv = (polar(3)-polar(1))/eps
49189  drun = - polar(2)/deriv
49190  prun = prun + drun
49191  ap2 = prun**2
49192  IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) GOTO 480
49193  GOTO 420
49194  480 CONTINUE
49195 
49196  amp = dsqrt(ap2)
49197 
49198 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49199 C...END OF PSEUDOSCALAR HIGGS
49200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49201 
49202  IF(ihiggs.EQ.3) GOTO 490
49203 
49204  490 CONTINUE
49205  RETURN
49206  500 CONTINUE
49207  WRITE(mstu(11),*) ' EXITING IN PYPOLE '
49208  WRITE(mstu(11),*) ' XMST11,XMST22 = ',xmst11,xmst22
49209  WRITE(mstu(11),*) ' XMSB11,XMSB22 = ',xmsb11,xmsb22
49210  WRITE(mstu(11),*) ' STOP22,SBOT22 = ',stop22,sbot22
49211  CALL pystop(107)
49212  END
49213 
49214 C*********************************************************************
49215 
49216 C...PYRGHM
49217 C...Auxiliary to PYPOLE.
49218 
49219  SUBROUTINE pyrghm(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49220  * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49221  IMPLICIT DOUBLE PRECISION(a-h,l,m,o-z)
49222  dimension vh(2,2),m2(2,2),m2p(2,2)
49223 C...Parameters.
49224  INTEGER MSTU,MSTJ
49225  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49226  SAVE /pydat1/
49227 
49228  mz = 91.18d0
49229  pi = paru(1)
49230  v = 174.1d0
49231  alpha1 = 0.0101d0
49232  alpha2 = 0.0337d0
49233  alpha3z = 0.12d0
49234  tanba = tanb
49235  tanbt = tanb
49236 C MBOTTOM(MTOP) = 3. GEV
49237  mb = pymrun(5,mtop**2)
49238  alpha3 = alpha3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alpha3z*
49239  *log(mtop**2/mz**2))
49240 C RMTOP= RUNNING TOP QUARK MASS
49241  rmtop = mtop/(1d0+4d0*alpha3/3d0/pi)
49242  tq = log((mq**2+mtop**2)/mtop**2)
49243  tu = log((mur**2 + mtop**2)/mtop**2)
49244  td = log((md**2 + mtop**2)/mtop**2)
49245 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49246 C
49247 C NEW DEFINITION, TGLU.
49248 C
49249 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49250  tglu = log(mglu**2/mtop**2)
49251  sinb = tanb/dsqrt(1d0 + tanb**2)
49252  cosb = sinb/tanb
49253  IF(ma.GT.mtop)
49254  *tanba = tanb*(1d0-3d0/32d0/pi**2*
49255  *(rmtop**2/v**2/sinb**2-mb**2/v**2/cosb**2)*
49256  *log(ma**2/mtop**2))
49257  IF(ma.LT.mtop.OR.ma.EQ.mtop) tanbt = tanba
49258  sinb = tanbt/sqrt(1d0 + tanbt**2)
49259  cosb = 1d0/dsqrt(1d0 + tanbt**2)
49260  g1 = sqrt(alpha1*4d0*pi)
49261  g2 = sqrt(alpha2*4d0*pi)
49262  g3 = sqrt(alpha3*4d0*pi)
49263  hu = rmtop/v/sinb
49264  hd = mb/v/cosb
49265  CALL pygfxx(ma,tanba,mq,mur,md,mtop,au,ad,mu,mglu,vh,stop1,stop2,
49266  *sbot1,sbot2,deltamt,deltamb)
49267  IF(mq.GT.mur) tp = tq - tu
49268  IF(mq.LT.mur.OR.mq.EQ.mur) tp = tu - tq
49269  IF(mq.GT.mur) tdp = tu
49270  IF(mq.LT.mur.OR.mq.EQ.mur) tdp = tq
49271  IF(mq.GT.md) tpd = tq - td
49272  IF(mq.LT.md.OR.mq.EQ.md) tpd = td - tq
49273  IF(mq.GT.md) tdpd = td
49274  IF(mq.LT.md.OR.mq.EQ.md) tdpd = tq
49275 
49276  IF(mq.GT.md) dlambda1 = 6d0/96d0/pi**2*g1**2*hd**2*tpd
49277  IF(mq.LT.md.OR.mq.EQ.md) dlambda1 = 3d0/32d0/pi**2*
49278  * hd**2*(g1**2/3d0+g2**2)*tpd
49279 
49280  IF(mq.GT.mur) dlambda2 =12d0/96d0/pi**2*g1**2*hu**2*tp
49281  IF(mq.LT.mur.OR.mq.EQ.mur) dlambda2 = 3d0/32d0/pi**2*
49282  * hu**2*(-g1**2/3d0+g2**2)*tp
49283 
49284 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49285 C
49286 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49287 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49288 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49289 C TWO STOPS.
49290 C
49291 C
49292 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49293 
49294  dlambdap2 = 0d0
49295  IF(mglu.LT.mur.OR.mglu.LT.mq) THEN
49296  IF(mq.GT.mur.AND.mglu.GT.mur) THEN
49297  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tglu**2)
49298  ENDIF
49299 
49300  IF(mq.GT.mur.AND.mglu.LT.mur) THEN
49301  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tu**2)
49302  ENDIF
49303 
49304  IF(mq.GT.mur.AND.mglu.EQ.mur) THEN
49305  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tu**2)
49306  ENDIF
49307 
49308  IF(mur.GT.mq.AND.mglu.GT.mq) THEN
49309  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tglu**2)
49310  ENDIF
49311 
49312  IF(mur.GT.mq.AND.mglu.LT.mq) THEN
49313  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tq**2)
49314  ENDIF
49315 
49316  IF(mur.GT.mq.AND.mglu.EQ.mq) THEN
49317  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tq**2)
49318  ENDIF
49319  ENDIF
49320  dlambda3 = 0d0
49321  dlambda4 = 0d0
49322  IF(mq.GT.md) dlambda3 = -1d0/32d0/pi**2*g1**2*hd**2*tpd
49323  IF(mq.LT.md.OR.mq.EQ.md) dlambda3 = 3d0/64d0/pi**2*hd**2*
49324  *(g2**2-g1**2/3d0)*tpd
49325  IF(mq.GT.mur) dlambda3 = dlambda3 -
49326  *1d0/16d0/pi**2*g1**2*hu**2*tp
49327  IF(mq.LT.mur.OR.mq.EQ.mur) dlambda3 = dlambda3 +
49328  * 3d0/64d0/pi**2*hu**2*(g2**2+g1**2/3d0)*tp
49329  IF(mq.LT.mur) dlambda4 = -3d0/32d0/pi**2*g2**2*hu**2*tp
49330  IF(mq.LT.md) dlambda4 = dlambda4 - 3d0/32d0/pi**2*g2**2*
49331  *hd**2*tpd
49332  lambda1 = ((g1**2 + g2**2)/4d0)*
49333  * (1d0-3d0*hd**2*(tpd + tdpd)/8d0/pi**2)
49334  *+(3d0*hd**4d0/16d0/pi**2) *tpd*(1d0
49335  *+ (3d0*hd**2/2d0 + hu**2/2d0
49336  *- 8d0*g3**2) * (tpd + 2d0*tdpd)/16d0/pi**2)
49337  *+(3d0*hd**4d0/8d0/pi**2) *tdpd*(1d0 + (3d0*hd**2/2d0 + hu**2/2d0
49338  *- 8d0*g3**2) * tdpd/16d0/pi**2) + dlambda1
49339  lambda2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu**2*
49340  *(tp + tdp)/8d0/pi**2)
49341  *+(3d0*hu**4d0/16d0/pi**2) *tp*(1d0
49342  *+ (3d0*hu**2/2d0 + hd**2/2d0
49343  *- 8d0*g3**2) * (tp + 2d0*tdp)/16d0/pi**2)
49344  *+(3d0*hu**4d0/8d0/pi**2) *tdp*(1d0 + (3d0*hu**2/2d0 + hd**2/2d0
49345  *- 8d0*g3**2) * tdp/16d0/pi**2) + dlambda2 + dlambdap2
49346  lambda3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
49347  *(hu**2)*(tp + tdp)/16d0/pi**2 -3d0*
49348  *(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlambda3
49349  lambda4 = (- g2**2/2d0)*(1d0
49350  *-3d0*(hu**2)*(tp + tdp)/16d0/pi**2
49351  *-3d0*(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlambda4
49352 
49353  lambda5 = 0d0
49354  lambda6 = 0d0
49355  lambda7 = 0d0
49356 
49357  m2(1,1) = 2d0*v**2*(lambda1*cosb**2+2d0*lambda6*
49358  *cosb*sinb + lambda5*sinb**2) + ma**2*sinb**2
49359 
49360  m2(2,2) = 2d0*v**2*(lambda5*cosb**2+2d0*lambda7*
49361  *cosb*sinb + lambda2*sinb**2) + ma**2*cosb**2
49362  m2(1,2) = 2d0*v**2*(lambda6*cosb**2+(lambda3+lambda4)*
49363  *cosb*sinb + lambda7*sinb**2) - ma**2*sinb*cosb
49364 
49365  m2(2,1) = m2(1,2)
49366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49367 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49368 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49369 
49370  mssusy=dsqrt(.5d0*(mq**2+mur**2)+mtop**2)
49371 
49372  IF(mchi.GT.mssusy) GOTO 100
49373  IF(mchi.LT.mtop) mchi=mtop
49374 
49375  tchar=log(mssusy**2/mchi**2)
49376 
49377  deltal12=(9d0/64d0/pi**2*g2**4+5d0/192d0/pi**2*g1**4)*tchar
49378  deltal3p4=(3d0/64d0/pi**2*g2**4+7d0/192d0/pi**2*g1**4
49379  *+4d0/32d0/pi**2*g1**2*g2**2)*tchar
49380 
49381  deltam112=2d0*deltal12*v**2*cosb**2
49382  deltam222=2d0*deltal12*v**2*sinb**2
49383  deltam122=2d0*deltal3p4*v**2*sinb*cosb
49384 
49385  m2(1,1)=m2(1,1)+deltam112
49386  m2(2,2)=m2(2,2)+deltam222
49387  m2(1,2)=m2(1,2)+deltam122
49388  m2(2,1)=m2(2,1)+deltam122
49389 
49390  100 CONTINUE
49391 
49392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49393 CCC END OF CHARGINOS/NEUTRALINOS
49394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49395 
49396  DO 120 i = 1,2
49397  DO 110 j = 1,2
49398  m2p(i,j) = m2(i,j) + vh(i,j)
49399  110 CONTINUE
49400  120 CONTINUE
49401  trm2p = m2p(1,1) + m2p(2,2)
49402  detm2p = m2p(1,1)*m2p(2,2) - m2p(1,2)*m2p(2,1)
49403  mh2p = (trm2p - dsqrt(trm2p**2 - 4d0* detm2p))/2d0
49404  hm2p = (trm2p + dsqrt(trm2p**2 - 4d0* detm2p))/2d0
49405  hmp = dsqrt(hm2p)
49406  mch2=ma**2+(lambda5-lambda4)*v**2
49407  mch=dsqrt(mch2)
49408  IF(mh2p.LT.0.) GOTO 130
49409  mhp = sqrt(mh2p)
49410  sin2alpha = 2d0*m2p(1,2)/sqrt(trm2p**2-4d0*detm2p)
49411  cos2alpha = (m2p(1,1)-m2p(2,2))/sqrt(trm2p**2-4d0*detm2p)
49412  IF(cos2alpha.GE.0.) THEN
49413  alpha = asin(sin2alpha)/2d0
49414  ELSE
49415  alpha = -pi/2d0-asin(sin2alpha)/2d0
49416  ENDIF
49417  sa = sin(alpha)
49418  ca = cos(alpha)
49419 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49420 C
49421 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49422 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49423 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49424 C
49425 C
49426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49427  sab = sa*(1d0-deltamb/(1d0+deltamb)*(1d0+ca/sa/tanb))
49428  cab = ca*(1d0-deltamb/(1d0+deltamb)*(1d0-sa/ca/tanb))
49429  130 CONTINUE
49430  RETURN
49431  END
49432 
49433 C*********************************************************************
49434 
49435 C...PYGFXX
49436 C...Auxiliary to PYRGHM.
49437 
49438  SUBROUTINE pygfxx(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49439  * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49440  IMPLICIT DOUBLE PRECISION(a-h,m,o-z)
49441  dimension vh(2,2),vh3t(2,2),vh3b(2,2),al(2,2)
49442 C...Commonblocks.
49443  INTEGER MSTU,MSTJ,KCHG
49444  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49445  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49446  SAVE /pydat1/,/pydat2/
49447 
49448  g(x,y) = 2.d0 - (x+y)/(x-y)*dlog(x/y)
49449 
49450  t(x,y,z) = (x**2*y**2*log(x**2/y**2) + x**2*z**2*log(z**2/x**2)
49451  * + y**2*z**2*log(y**2/z**2))/((x**2-y**2)*(y**2-z**2)*(x**2-z**2))
49452 
49453  IF(dabs(xmu).LT.0.000001d0) xmu = 0.000001d0
49454  mq2 = mq**2
49455  mur2 = mur**2
49456  md2 = md**2
49457  tanba = tanb
49458  sinba = tanba/dsqrt(tanba**2+1d0)
49459  cosba = sinba/tanba
49460 
49461  sinb = tanb/dsqrt(tanb**2+1d0)
49462  cosb = sinb/tanb
49463 
49464  pi = paru(1)
49465  mz = pmas(23,1)
49466  mw = pmas(24,1)
49467  sw = 1d0-mw**2/mz**2
49468  v = 174.1d0
49469 
49470  alpha3 = 0.12d0/(1d0+23/12d0/pi*0.12d0*log(mtop**2/mz**2))
49471  g2 = dsqrt(0.0336d0*4d0*pi)
49472  g1 = dsqrt(0.0101d0*4d0*pi)
49473 
49474  IF(mq.GT.mur) mst = mq
49475  IF(mur.GT.mq.OR.mur.EQ.mq) mst = mur
49476 
49477  msusyt = dsqrt(mst**2 + mtop**2)
49478 
49479  IF(mq.GT.md) msb = mq
49480  IF(md.GT.mq.OR.md.EQ.mq) msb = md
49481 
49482  mb = pymrun(5,msb**2)
49483  msusyb = dsqrt(msb**2 + mb**2)
49484  tt = log(msusyt**2/mtop**2)
49485  tb = log(msusyb**2/mtop**2)
49486 
49487  rmtop = mtop/(1d0+4d0*alpha3/3d0/pi)
49488  ht = rmtop/(v*sinb)
49489  htst = rmtop/v
49490  hb = mb/v/cosb
49491  g32 = alpha3*4d0*pi
49492  bt2 = -(8d0*g32 - 9d0*ht**2/2d0 - hb**2/2d0)/(4d0*pi)**2
49493  bb2 = -(8d0*g32 - 9d0*hb**2/2d0 - ht**2/2d0)/(4d0*pi)**2
49494  al2 = 3d0/8d0/pi**2*ht**2
49495 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49496 C ALST = 3./8./PI**2*HTST**2
49497  al1 = 3d0/8d0/pi**2*hb**2
49498 
49499  al(1,1) = al1
49500  al(1,2) = (al2+al1)/2d0
49501  al(2,1) = (al2+al1)/2d0
49502  al(2,2) = al2
49503 
49504  IF(ma.GT.mtop) THEN
49505  vi = v*(1d0 + 3d0/32d0/pi**2*htst**2*
49506  * log(mtop**2/ma**2))
49507  h1i = vi* cosba
49508  h2i = vi*sinba
49509  h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(ma**2/msusyt**2))**.25d0
49510  h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(ma**2/msusyt**2))**.25d0
49511  h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(ma**2/msusyb**2))**.25d0
49512  h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(ma**2/msusyb**2))**.25d0
49513  ELSE
49514  vi = v
49515  h1i = vi*cosb
49516  h2i = vi*sinb
49517  h1t=h1i*(1d0+3d0/8d0/pi**2*hb**2*log(mtop**2/msusyt**2))**.25d0
49518  h2t=h2i*(1d0+3d0/8d0/pi**2*ht**2*log(mtop**2/msusyt**2))**.25d0
49519  h1b=h1i*(1d0+3d0/8d0/pi**2*hb**2*log(mtop**2/msusyb**2))**.25d0
49520  h2b=h2i*(1d0+3d0/8d0/pi**2*ht**2*log(mtop**2/msusyb**2))**.25d0
49521  ENDIF
49522 
49523  tanbst = h2t/h1t
49524  sinbt = tanbst/dsqrt(1d0+tanbst**2)
49525 
49526  tanbsb = h2b/h1b
49527  sinbb = tanbsb/dsqrt(1d0+tanbsb**2)
49528  cosbb = sinbb/tanbsb
49529 
49530  deltamt = 0d0
49531  deltamb = 0d0
49532 
49533  mtop4 = rmtop**4*(1d0+2d0*bt2*tt- al2*tt - 4d0*deltamt)
49534  mtop2 = dsqrt(mtop4)
49535  mbot4 = mb**4*(1d0+2d0*bb2*tb - al1*tb)
49536  * /(1d0+deltamb)**4
49537  mbot2 = dsqrt(mbot4)
49538 
49539  stop12 = (mq2 + mur2)*.5d0 + mtop2
49540  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49541  * +sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49542  * mq2 - mur2)**2*0.25d0 + mtop2*(at-xmu/tanbst)**2)
49543  stop22 = (mq2 + mur2)*.5d0 + mtop2
49544  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49545  * - sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49546  * mq2 - mur2)**2*0.25d0
49547  * + mtop2*(at-xmu/tanbst)**2)
49548  IF(stop22.LT.0.) GOTO 120
49549  sbot12 = (mq2 + md2)*.5d0
49550  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49551  * + sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49552  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49553  sbot22 = (mq2 + md2)*.5d0
49554  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49555  * - sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49556  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49557  IF(sbot22.LT.0.) sbot22 = 10000d0
49558 
49559  stop1 = dsqrt(stop12)
49560  stop2 = dsqrt(stop22)
49561  sbot1 = dsqrt(sbot12)
49562  sbot2 = dsqrt(sbot22)
49563 
49564 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49565 C
49566 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49567 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49568 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49569 C INDUCED CORRECTIONS.
49570 C
49571 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49572 
49573  x=sbot1
49574  y=sbot2
49575  z=xmgl
49576  IF(x.EQ.y) x = x - 0.00001d0
49577  IF(x.EQ.z) x = x - 0.00002d0
49578  IF(y.EQ.z) y = y - 0.00003d0
49579 
49580  t1=t(x,y,z)
49581  x=stop1
49582  y=stop2
49583  z=xmu
49584  IF(x.EQ.y) x = x - 0.00001d0
49585  IF(x.EQ.z) x = x - 0.00002d0
49586  IF(y.EQ.z) y = y - 0.00003d0
49587  t2=t(x,y,z)
49588  deltamb = -2*alpha3/3d0/pi*xmgl*(ab-xmu*tanb)*t1
49589  * + ht**2/(4d0*pi)**2*(at-xmu/tanb)*xmu*tanb*t2
49590  x=stop1
49591  y=stop2
49592  z=xmgl
49593  IF(x.EQ.y) x = x - 0.00001d0
49594  IF(x.EQ.z) x = x - 0.00002d0
49595  IF(y.EQ.z) y = y - 0.00003d0
49596  t3=t(x,y,z)
49597  deltamt = -2d0*alpha3/3d0/pi*(at-xmu/tanb)*xmgl*t3
49598 
49599 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49600 C
49601 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49602 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49603 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49604 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49605 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49606 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49607 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49608 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49609 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49610 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49611 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49612 C
49613 C
49614 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49615 
49616  mtop4 = rmtop**4*(1d0+2d0*bt2*tt- al2*tt - 4d0*deltamt)
49617  mtop2 = dsqrt(mtop4)
49618  mbot4 = mb**4*(1d0+2d0*bb2*tb - al1*tb)
49619  * /(1d0+deltamb)**4
49620  mbot2 = dsqrt(mbot4)
49621 
49622  stop12 = (mq2 + mur2)*.5d0 + mtop2
49623  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49624  * +sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49625  * mq2 - mur2)**2*0.25d0 + mtop2*(at-xmu/tanbst)**2)
49626  stop22 = (mq2 + mur2)*.5d0 + mtop2
49627  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49628  * - sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49629  * mq2 - mur2)**2*0.25d0
49630  * + mtop2*(at-xmu/tanbst)**2)
49631 
49632  IF(stop22.LT.0.) GOTO 120
49633  sbot12 = (mq2 + md2)*.5d0
49634  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49635  * + sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49636  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49637  sbot22 = (mq2 + md2)*.5d0
49638  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49639  * - sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49640  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49641  IF(sbot22.LT.0.) GOTO 120
49642 
49643 
49644  stop1 = dsqrt(stop12)
49645  stop2 = dsqrt(stop22)
49646  sbot1 = dsqrt(sbot12)
49647  sbot2 = dsqrt(sbot22)
49648 
49649 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49650 CCC D-TERMS
49651 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49652  stw=sw
49653 
49654  f1t=(mq2-mur2)/(stop12-stop22)*(.5d0-4d0/3d0*stw)*
49655  * log(stop1/stop2)
49656  * +(.5d0-2d0/3d0*stw)*log(stop1*stop2/(mq2+mtop2))
49657  * + 2d0/3d0*stw*log(stop1*stop2/(mur2+mtop2))
49658 
49659  f1b=(mq2-md2)/(sbot12-sbot22)*(-.5d0+2d0/3d0*stw)*
49660  * log(sbot1/sbot2)
49661  * +(-.5d0+1d0/3d0*stw)*log(sbot1*sbot2/(mq2+mbot2))
49662  * - 1d0/3d0*stw*log(sbot1*sbot2/(md2+mbot2))
49663 
49664  f2t=dsqrt(mtop2)*(at-xmu/tanbst)/(stop12-stop22)*
49665  * (-.5d0*log(stop12/stop22)
49666  * +(4d0/3d0*stw-.5d0)*(mq2-mur2)/(stop12-stop22)*
49667  * g(stop12,stop22))
49668 
49669  f2b=dsqrt(mbot2)*(ab-xmu*tanbsb)/(sbot12-sbot22)*
49670  * (.5d0*log(sbot12/sbot22)
49671  * +(-2d0/3d0*stw+.5d0)*(mq2-md2)/(sbot12-sbot22)*
49672  * g(sbot12,sbot22))
49673 
49674  vh3b(1,1) = mbot4/(cosbb**2)*(log(sbot1**2*sbot2**2/
49675  * (mq2+mbot2)/(md2+mbot2))
49676  * + 2d0*(ab*(ab-xmu*tanbsb)/(sbot1**2-sbot2**2))*
49677  * log(sbot1**2/sbot2**2)) +
49678  * mbot4/(cosbb**2)*(ab*(ab-xmu*tanbsb)/
49679  * (sbot1**2-sbot2**2))**2*g(sbot12,sbot22)
49680 
49681  vh3t(1,1) =
49682  * mtop4/(sinbt**2)*(xmu*(-at+xmu/tanbst)/(stop1**2
49683  * -stop2**2))**2*g(stop12,stop22)
49684 
49685  vh3b(1,1)=vh3b(1,1)+
49686  * mz**2*(2*mbot2*f1b-dsqrt(mbot2)*ab*f2b)
49687 
49688  vh3t(1,1) = vh3t(1,1) +
49689  * mz**2*(dsqrt(mtop2)*xmu/tanbst*f2t)
49690 
49691  vh3t(2,2) = mtop4/(sinbt**2)*(log(stop1**2*stop2**2/
49692  * (mq2+mtop2)/(mur2+mtop2))
49693  * + 2d0*(at*(at-xmu/tanbst)/(stop1**2-stop2**2))*
49694  * log(stop1**2/stop2**2)) +
49695  * mtop4/(sinbt**2)*(at*(at-xmu/tanbst)/
49696  * (stop1**2-stop2**2))**2*g(stop12,stop22)
49697 
49698  vh3b(2,2) =
49699  * mbot4/(cosbb**2)*(xmu*(-ab+xmu*tanbsb)/(sbot1**2
49700  * -sbot2**2))**2*g(sbot12,sbot22)
49701 
49702  vh3t(2,2)=vh3t(2,2)+
49703  * mz**2*(-2*mtop2*f1t+dsqrt(mtop2)*at*f2t)
49704  vh3b(2,2) = vh3b(2,2) -mz**2*dsqrt(mbot2)*xmu*tanbsb*f2b
49705  vh3t(1,2) = -
49706  * mtop4/(sinbt**2)*xmu*(at-xmu/tanbst)/
49707  * (stop1**2-stop2**2)*(log(stop1**2/stop2**2) + at*
49708  * (at - xmu/tanbst)/(stop1**2-stop2**2)*g(stop12,stop22))
49709 
49710  vh3b(1,2) =
49711  * - mbot4/(cosbb**2)*xmu*(ab-xmu*tanbsb)/
49712  * (sbot1**2-sbot2**2)*(log(sbot1**2/sbot2**2) + ab*
49713  * (ab - xmu*tanbsb)/(sbot1**2-sbot2**2)*g(sbot12,sbot22))
49714 
49715 
49716  vh3t(1,2)=vh3t(1,2) +
49717  *mz**2*(mtop2/tanbst*f1t-dsqrt(mtop2)*(at/tanbst+xmu)/2d0*f2t)
49718 
49719  vh3b(1,2)=vh3b(1,2) +
49720  *mz**2*(-mbot2*tanbsb*f1b+dsqrt(mbot2)*(ab*tanbsb+xmu)/2d0*f2b)
49721 
49722  vh3t(2,1) = vh3t(1,2)
49723  vh3b(2,1) = vh3b(1,2)
49724 
49725 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49726 C TU = LOG((MUR2+MTOP2)/MTOP2)
49727 C TQD = LOG((MQ2 + MB**2)/MB**2)
49728 C TD = LOG((MD2+MB**2)/MB**2)
49729 
49730  DO 110 i = 1,2
49731  DO 100 j = 1,2
49732  vh(i,j) =
49733  * 6d0/(8d0*pi**2*(h1t**2+h2t**2))
49734  * *vh3t(i,j)*0.5d0*(1d0-al(i,j)*tt/2d0) +
49735  * 6d0/(8d0*pi**2*(h1b**2+h2b**2))
49736  * *vh3b(i,j)*0.5d0*(1d0-al(i,j)*tb/2d0)
49737  100 CONTINUE
49738  110 CONTINUE
49739 
49740  GOTO 150
49741  120 DO 140 i =1,2
49742  DO 130 j = 1,2
49743  vh(i,j) = -1d15
49744  130 CONTINUE
49745  140 CONTINUE
49746 
49747 
49748  150 RETURN
49749  END
49750 
49751 
49752 
49753 
49754 
49755 C*********************************************************************
49756 
49757 C...PYFINT
49758 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49759 
49760  FUNCTION pyfint(A,B,C)
49761 
49762 C...Double precision and integer declarations.
49763  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49764  IMPLICIT INTEGER(I-N)
49765  INTEGER PYK,PYCHGE,PYCOMP
49766 C...Commonblock.
49767  common/pyints/xxm(20)
49768  SAVE/pyints/
49769 
49770 C...Local variables.
49771  EXTERNAL pyfisb
49772  DOUBLE PRECISION PYFISB
49773 
49774  XXM(1)=a
49775  xxm(2)=b
49776  xxm(3)=c
49777  xlo=0d0
49778  xhi=1d0
49779  pyfint = pygaus(pyfisb,xlo,xhi,1d-3)
49780 
49781  RETURN
49782  END
49783 
49784 C*********************************************************************
49785 
49786 C...PYFISB
49787 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49788 
49789  FUNCTION pyfisb(X)
49790 
49791 C...Double precision and integer declarations.
49792  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49793  IMPLICIT INTEGER(I-N)
49794  INTEGER PYK,PYCHGE,PYCOMP
49795 C...Commonblock.
49796  common/pyints/xxm(20)
49797  SAVE/pyints/
49798 
49799  pyfisb = log(abs(x*xxm(2)+(1-x)*xxm(3)-x*(1-x)*xxm(1))/
49800  &(x*(xxm(2)-xxm(3))+xxm(3)))
49801 
49802  RETURN
49803  END
49804 
49805 C*********************************************************************
49806 
49807 C...PYSFDC
49808 C...Calculates decays of sfermions.
49809 
49810  SUBROUTINE pysfdc(KFIN,XLAM,IDLAM,IKNT)
49811 
49812 C...Double precision and integer declarations.
49813  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49814  IMPLICIT INTEGER(I-N)
49815  INTEGER PYK,PYCHGE,PYCOMP
49816 C...Parameter statement to help give large particle numbers.
49817  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
49818  &kexcit=4000000,kdimen=5000000)
49819 C...Commonblocks.
49820  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49821  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49822  common/pymssm/imss(0:99),rmss(0:99)
49823  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
49824  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
49825  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
49826 
49827 C...Local variables.
49828  COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49829  COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49830  INTEGER KFIN,KCIN
49831  DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49832  DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49833  DOUBLE PRECISION PYLAMF,XL
49834  DOUBLE PRECISION TANW,XW,AEM,C1,AS
49835  DOUBLE PRECISION AL,AR,BL,BR
49836  DOUBLE PRECISION CH1,CH2,CH3,CH4
49837  DOUBLE PRECISION XMBOT,XMTOP
49838  DOUBLE PRECISION XLAM(0:400)
49839  INTEGER IDLAM(400,3)
49840  INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49841  DOUBLE PRECISION SR2
49842  DOUBLE PRECISION CBETA,SBETA
49843  DOUBLE PRECISION CW
49844  DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49845  DOUBLE PRECISION COSA,SINA,TANB
49846  DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49847  DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49848  INTEGER IG,KF1,KF2
49849  INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49850  DATA igg/23,25,35,36/
49851  DATA pi/3.141592654d0/
49852  DATA sr2/1.4142136d0/
49853  DATA kfnchi/1000022,1000023,1000025,1000035/
49854  DATA kfcchi/1000024,1000037/
49855 
49856 C...COUNT THE NUMBER OF DECAY MODES
49857  lknt=0
49858 
49859 C...NO NU_R DECAYS
49860  IF(kfin.EQ.ksusy2+12.OR.kfin.EQ.ksusy2+14.OR.
49861  &kfin.EQ.ksusy2+16) RETURN
49862 
49863  xmw=pmas(24,1)
49864  xmw2=xmw**2
49865  xmz=pmas(23,1)
49866  xw=paru(102)
49867  tanw = sqrt(xw/(1d0-xw))
49868  cw=sqrt(1d0-xw)
49869 
49870  DO 110 i=1,4
49871  DO 100 j=1,4
49872  zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
49873  100 CONTINUE
49874  110 CONTINUE
49875  DO 130 i=1,2
49876  DO 120 j=1,2
49877  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
49878  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
49879  120 CONTINUE
49880  130 CONTINUE
49881 
49882 C...KCIN
49883  kcin=pycomp(kfin)
49884 C...ILR is 1 for left and 2 for right.
49885  ilr=kfin/ksusy1
49886 C...IFL is matching non-SUSY flavour.
49887  ifl=mod(kfin,ksusy1)
49888 C...IDU is weak isospin, 1 for down and 2 for up.
49889  idu=2-mod(ifl,2)
49890 
49891  xmi=pmas(kcin,1)
49892  xmi2=xmi**2
49893  aem=pyalem(xmi2)
49894  as =pyalps(xmi2)
49895  c1=aem/xw
49896  xmi3=xmi**3
49897  ei=kchg(ifl,1)/3d0
49898 
49899  xmbot=pymrun(5,xmi2)
49900  xmtop=pymrun(6,xmi2)
49901 
49902  tanb=rmss(5)
49903  beta=atan(tanb)
49904  alfa=rmss(18)
49905  cbeta=cos(beta)
49906  sbeta=tanb*cbeta
49907  sina=sin(alfa)
49908  cosa=cos(alfa)
49909  xmu=-rmss(4)
49910  atrit=rmss(16)
49911  atrib=rmss(15)
49912  atril=rmss(17)
49913 
49914 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
49915 
49916  IF(imss(11).EQ.1) THEN
49917  xmp=rmss(29)
49918  idg=39+ksusy1
49919  xmgr=pmas(pycomp(idg),1)
49920  xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi
49921  IF(ifl.EQ.5) THEN
49922  xmf=xmbot
49923  ELSEIF(ifl.EQ.6) THEN
49924  xmf=xmtop
49925  ELSE
49926  xmf=pmas(ifl,1)
49927  ENDIF
49928  IF(xmi.GT.xmgr+xmf) THEN
49929  lknt=lknt+1
49930  idlam(lknt,1)=idg
49931  idlam(lknt,2)=ifl
49932  idlam(lknt,3)=0
49933  xlam(lknt)=xfac*(1d0-xmf**2/xmi2)**4
49934  ENDIF
49935  ENDIF
49936 
49937 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
49938 
49939 C...CHARGED DECAYS:
49940  DO 140 ix=1,2
49941 C...DI -> U CHI1-,CHI2-
49942  IF(idu.EQ.1) THEN
49943  xmfp=pmas(ifl+1,1)
49944  xmf =pmas(ifl,1)
49945 C...UI -> D CHI1+,CHI2+
49946  ELSE
49947  xmfp=pmas(ifl-1,1)
49948  xmf =pmas(ifl,1)
49949  ENDIF
49950  xmj=smw(ix)
49951  axmj=abs(xmj)
49952  IF(xmi.GE.axmj+xmfp) THEN
49953  xma2=xmj**2
49954  xmb2=xmfp**2
49955  IF(idu.EQ.2) THEN
49956  IF(ifl.EQ.6) THEN
49957  xmfp=xmbot
49958  xmf =xmtop
49959  ELSEIF(ifl.LT.6) THEN
49960  xmf=0d0
49961  xmfp=0d0
49962  ENDIF
49963  cbl=vmixc(ix,1)
49964  cal=-xmfp*umixc(ix,2)/sr2/xmw/cbeta
49965  cbr=-xmf*vmixc(ix,2)/sr2/xmw/sbeta
49966  car=0d0
49967  ELSE
49968  IF(ifl.EQ.5) THEN
49969  xmf =xmbot
49970  xmfp=xmtop
49971  ELSEIF(ifl.LT.5) THEN
49972  xmf=0d0
49973  xmfp=0d0
49974  ENDIF
49975  cbl=umixc(ix,1)
49976  cal=-xmfp*vmixc(ix,2)/sr2/xmw/sbeta
49977  cbr=-xmf*umixc(ix,2)/sr2/xmw/cbeta
49978  car=0d0
49979  ENDIF
49980 
49981  calp=sfmix(ifl,1)*cal + sfmix(ifl,2)*car
49982  cblp=sfmix(ifl,1)*cbl + sfmix(ifl,2)*cbr
49983  carp=sfmix(ifl,4)*car + sfmix(ifl,3)*cal
49984  cbrp=sfmix(ifl,4)*cbr + sfmix(ifl,3)*cbl
49985  cal=calp
49986  cbl=cblp
49987  car=carp
49988  cbr=cbrp
49989 
49990 C...F1 -> F` CHI
49991  IF(ilr.EQ.1) THEN
49992  ca=cal
49993  cb=cbl
49994 C...F2 -> F` CHI
49995  ELSE
49996  ca=car
49997  cb=cbr
49998  ENDIF
49999  lknt=lknt+1
50000  xl=pylamf(xmi2,xma2,xmb2)
50001 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50002  xlam(lknt)=2d0*c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
50003  & (abs(ca)**2+abs(cb)**2)-4d0*dble(ca*dconjg(cb))*xmj*xmfp)
50004  idlam(lknt,3)=0
50005  IF(idu.EQ.1) THEN
50006  idlam(lknt,1)=-kfcchi(ix)
50007  idlam(lknt,2)=ifl+1
50008  ELSE
50009  idlam(lknt,1)=kfcchi(ix)
50010  idlam(lknt,2)=ifl-1
50011  ENDIF
50012  ENDIF
50013  140 CONTINUE
50014 
50015 C...NEUTRAL DECAYS
50016  DO 150 ix=1,4
50017 C...DI -> D CHI10
50018  xmf=pmas(ifl,1)
50019  xmj=smz(ix)
50020  axmj=abs(xmj)
50021  IF(xmi.GE.axmj+xmf) THEN
50022  xma2=xmj**2
50023  xmb2=xmf**2
50024  IF(idu.EQ.1) THEN
50025  IF(ifl.EQ.5) THEN
50026  xmf=xmbot
50027  ELSEIF(ifl.LT.5) THEN
50028  xmf=0d0
50029  ENDIF
50030  cbl=-zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei+1)
50031  cal=xmf*zmixc(ix,3)/xmw/cbeta
50032  car=-2d0*ei*tanw*zmixc(ix,1)
50033  cbr=cal
50034  ELSE
50035  IF(ifl.EQ.6) THEN
50036  xmf=xmtop
50037  ELSEIF(ifl.LT.5) THEN
50038  xmf=0d0
50039  ENDIF
50040  cbl=zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-1)
50041  cal=xmf*zmixc(ix,4)/xmw/sbeta
50042  car=-2d0*ei*tanw*zmixc(ix,1)
50043  cbr=cal
50044  ENDIF
50045 
50046  calp=sfmix(ifl,1)*cal + sfmix(ifl,2)*car
50047  cblp=sfmix(ifl,1)*cbl + sfmix(ifl,2)*cbr
50048  carp=sfmix(ifl,4)*car + sfmix(ifl,3)*cal
50049  cbrp=sfmix(ifl,4)*cbr + sfmix(ifl,3)*cbl
50050  cal=calp
50051  cbl=cblp
50052  car=carp
50053  cbr=cbrp
50054 
50055 C...F1 -> F CHI
50056  IF(ilr.EQ.1) THEN
50057  ca=cal
50058  cb=cbl
50059 C...F2 -> F CHI
50060  ELSE
50061  ca=car
50062  cb=cbr
50063  ENDIF
50064  lknt=lknt+1
50065  xl=pylamf(xmi2,xma2,xmb2)
50066 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50067  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
50068  & (abs(ca)**2+abs(cb)**2)-4d0*dble(ca*dconjg(cb))*xmj*xmf)
50069  idlam(lknt,1)=kfnchi(ix)
50070  idlam(lknt,2)=ifl
50071  idlam(lknt,3)=0
50072  ENDIF
50073  150 CONTINUE
50074 
50075 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50076 C...IG=23,25,35,36
50077  DO 160 ii=1,4
50078  ig=igg(ii)
50079  IF(ilr.EQ.1) GOTO 160
50080  xmb=pmas(ig,1)
50081  xmsf1=pmas(pycomp(kfin-ksusy1),1)
50082  IF(xmi.LT.xmsf1+xmb) GOTO 160
50083  IF(ig.EQ.23) THEN
50084  bl=-sign(.5d0,ei)/cw+ei*xw/cw
50085  br=ei*xw/cw
50086  blr=0d0
50087  ELSEIF(ig.EQ.25) THEN
50088  IF(ifl.EQ.5) THEN
50089  xmf=xmbot
50090  ELSEIF(ifl.EQ.6) THEN
50091  xmf=xmtop
50092  ELSEIF(ifl.LT.5) THEN
50093  xmf=0d0
50094  ELSE
50095  xmf=pmas(ifl,1)
50096  ENDIF
50097  IF(idu.EQ.2) THEN
50098  ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
50099  & xmf**2/xmw*cosa/sbeta
50100  ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
50101  & xmf**2/xmw*cosa/sbeta
50102  ELSE
50103  ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
50104  & xmf**2/xmw*(-sina)/cbeta
50105  ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
50106  & xmf**2/xmw*(-sina)/cbeta
50107  ENDIF
50108  IF(ifl.EQ.5) THEN
50109  at=atrib
50110  ELSEIF(ifl.EQ.6) THEN
50111  at=atrit
50112  ELSEIF(ifl.EQ.15) THEN
50113  at=atril
50114  ELSE
50115  at=0d0
50116  ENDIF
50117 C.........need to complexify
50118  IF(idu.EQ.2) THEN
50119  ghlr=xmf/2d0/xmw/sbeta*(-xmu*sina+
50120  & at*cosa)
50121  ELSE
50122  ghlr=xmf/2d0/xmw/cbeta*(xmu*cosa-
50123  & at*sina)
50124  ENDIF
50125  bl=ghll
50126  br=ghrr
50127  blr=-ghlr
50128  ELSEIF(ig.EQ.35) THEN
50129  IF(ifl.EQ.5) THEN
50130  xmf=xmbot
50131  ELSEIF(ifl.EQ.6) THEN
50132  xmf=xmtop
50133  ELSEIF(ifl.LT.5) THEN
50134  xmf=0d0
50135  ELSE
50136  xmf=pmas(ifl,1)
50137  ENDIF
50138  IF(idu.EQ.2) THEN
50139  ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
50140  & xmf**2/xmw*sina/sbeta
50141  ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
50142  & xmf**2/xmw*sina/sbeta
50143  ELSE
50144  ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
50145  & xmf**2/xmw*cosa/cbeta
50146  ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
50147  & xmf**2/xmw*cosa/cbeta
50148  ENDIF
50149  IF(ifl.EQ.5) THEN
50150  at=atrib
50151  ELSEIF(ifl.EQ.6) THEN
50152  at=atrit
50153  ELSEIF(ifl.EQ.15) THEN
50154  at=atril
50155  ELSE
50156  at=0d0
50157  ENDIF
50158 C.........Need to complexify
50159  IF(idu.EQ.2) THEN
50160  ghlr=xmf/2d0/xmw/sbeta*(xmu*cosa+
50161  & at*sina)
50162  ELSE
50163  ghlr=xmf/2d0/xmw/cbeta*(xmu*sina+
50164  & at*cosa)
50165  ENDIF
50166  bl=ghll
50167  br=ghrr
50168  blr=ghlr
50169  ELSEIF(ig.EQ.36) THEN
50170  ghll=0d0
50171  ghrr=0d0
50172  IF(ifl.EQ.5) THEN
50173  xmf=xmbot
50174  ELSEIF(ifl.EQ.6) THEN
50175  xmf=xmtop
50176  ELSEIF(ifl.LT.5) THEN
50177  xmf=0d0
50178  ELSE
50179  xmf=pmas(ifl,1)
50180  ENDIF
50181  IF(ifl.EQ.5) THEN
50182  at=atrib
50183  ELSEIF(ifl.EQ.6) THEN
50184  at=atrit
50185  ELSEIF(ifl.EQ.15) THEN
50186  at=atril
50187  ELSE
50188  at=0d0
50189  ENDIF
50190 C.........Need to complexify
50191  IF(idu.EQ.2) THEN
50192  ghlr=xmf/2d0/xmw*(-xmu+at/tanb)
50193  ELSE
50194  ghlr=xmf/2d0/xmw/(-xmu+at*tanb)
50195  ENDIF
50196  bl=ghll
50197  br=ghrr
50198  blr=ghlr
50199  ENDIF
50200  al=sfmix(ifl,1)*sfmix(ifl,3)*bl+
50201  & sfmix(ifl,2)*sfmix(ifl,4)*br+
50202  & (sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,3)*sfmix(ifl,2))*blr
50203  xl=pylamf(xmi2,xmsf1**2,xmb**2)
50204  lknt=lknt+1
50205  IF(ig.EQ.23) THEN
50206  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
50207  ELSE
50208  xlam(lknt)=c1/4d0/xmi3*sqrt(xl)*al**2
50209  ENDIF
50210  idlam(lknt,3)=0
50211  idlam(lknt,1)=kfin-ksusy1
50212  idlam(lknt,2)=ig
50213  160 CONTINUE
50214 
50215 C...SF -> SF' + W
50216  xmb=pmas(24,1)
50217  IF(mod(ifl,2).EQ.0) THEN
50218  kf1=ksusy1+ifl-1
50219  ELSE
50220  kf1=ksusy1+ifl+1
50221  ENDIF
50222  kf2=kf1+ksusy1
50223  xmsf1=pmas(pycomp(kf1),1)
50224  xmsf2=pmas(pycomp(kf2),1)
50225  IF(xmi.GT.xmb+xmsf1) THEN
50226  IF(mod(ifl,2).EQ.0) THEN
50227  IF(ilr.EQ.1) THEN
50228  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,1)
50229  ELSE
50230  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,1)
50231  ENDIF
50232  ELSE
50233  IF(ilr.EQ.1) THEN
50234  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,1)
50235  ELSE
50236  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,1)
50237  ENDIF
50238  ENDIF
50239  xl=pylamf(xmi2,xmsf1**2,xmb**2)
50240  lknt=lknt+1
50241  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
50242  idlam(lknt,3)=0
50243  idlam(lknt,1)=kf1
50244  idlam(lknt,2)=sign(24,kchg(ifl,1))
50245  ENDIF
50246  IF(xmi.GT.xmb+xmsf2) THEN
50247  IF(mod(ifl,2).EQ.0) THEN
50248  IF(ilr.EQ.1) THEN
50249  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,3)
50250  ELSE
50251  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,3)
50252  ENDIF
50253  ELSE
50254  IF(ilr.EQ.1) THEN
50255  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,3)
50256  ELSE
50257  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,3)
50258  ENDIF
50259  ENDIF
50260  xl=pylamf(xmi2,xmsf2**2,xmb**2)
50261  lknt=lknt+1
50262  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
50263  idlam(lknt,3)=0
50264  idlam(lknt,1)=kf2
50265  idlam(lknt,2)=sign(24,kchg(ifl,1))
50266  ENDIF
50267 
50268 C...SF -> SF' + HC
50269  xmb=pmas(37,1)
50270  IF(mod(ifl,2).EQ.0) THEN
50271  kf1=ksusy1+ifl-1
50272  ELSE
50273  kf1=ksusy1+ifl+1
50274  ENDIF
50275  kf2=kf1+ksusy1
50276  xmsf1=pmas(pycomp(kf1),1)
50277  xmsf2=pmas(pycomp(kf2),1)
50278  IF(xmi.GT.xmb+xmsf1) THEN
50279  xmf=0d0
50280  xmfp=0d0
50281  at=0d0
50282  ab=0d0
50283  IF(mod(ifl,2).EQ.0) THEN
50284 C...T1-> B1 HC
50285  IF(ilr.EQ.1) THEN
50286  ch1=-sfmix(ifl,1)*sfmix(ifl-1,1)
50287  ch2= sfmix(ifl,2)*sfmix(ifl-1,2)
50288  ch3=-sfmix(ifl,1)*sfmix(ifl-1,2)
50289  ch4=-sfmix(ifl,2)*sfmix(ifl-1,1)
50290 C...T2-> B1 HC
50291  ELSE
50292  ch1= sfmix(ifl,3)*sfmix(ifl-1,1)
50293  ch2=-sfmix(ifl,4)*sfmix(ifl-1,2)
50294  ch3= sfmix(ifl,3)*sfmix(ifl-1,2)
50295  ch4= sfmix(ifl,4)*sfmix(ifl-1,1)
50296  ENDIF
50297  IF(ifl.EQ.6) THEN
50298  xmf=xmtop
50299  xmfp=xmbot
50300  at=atrit
50301  ab=atrib
50302  ENDIF
50303  ELSE
50304 C...B1 -> T1 HC
50305  IF(ilr.EQ.1) THEN
50306  ch1=-sfmix(ifl+1,1)*sfmix(ifl,1)
50307  ch2= sfmix(ifl+1,2)*sfmix(ifl,2)
50308  ch3=-sfmix(ifl+1,1)*sfmix(ifl,2)
50309  ch4=-sfmix(ifl+1,2)*sfmix(ifl,1)
50310 C...B2-> T1 HC
50311  ELSE
50312  ch1= sfmix(ifl,3)*sfmix(ifl+1,1)
50313  ch2=-sfmix(ifl,4)*sfmix(ifl+1,2)
50314  ch3= sfmix(ifl,4)*sfmix(ifl+1,1)
50315  ch4= sfmix(ifl,3)*sfmix(ifl+1,2)
50316  ENDIF
50317  IF(ifl.EQ.5) THEN
50318  xmf=xmtop
50319  xmfp=xmbot
50320  at=atrit
50321  ab=atrib
50322  ENDIF
50323  ENDIF
50324  xl=pylamf(xmi2,xmsf1**2,xmb**2)
50325  lknt=lknt+1
50326 C.......Need to complexify
50327  al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
50328  & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
50329  & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
50330  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
50331  idlam(lknt,3)=0
50332  idlam(lknt,1)=kf1
50333  idlam(lknt,2)=sign(37,kchg(ifl,1))
50334  ENDIF
50335  IF(xmi.GT.xmb+xmsf2) THEN
50336  xmf=0d0
50337  xmfp=0d0
50338  at=0d0
50339  ab=0d0
50340  IF(mod(ifl,2).EQ.0) THEN
50341 C...T1-> B2 HC
50342  IF(ilr.EQ.1) THEN
50343  ch1= sfmix(ifl-1,3)*sfmix(ifl,1)
50344  ch2=-sfmix(ifl-1,4)*sfmix(ifl,2)
50345  ch3= sfmix(ifl-1,4)*sfmix(ifl,1)
50346  ch4= sfmix(ifl-1,3)*sfmix(ifl,2)
50347 C...T2-> B2 HC
50348  ELSE
50349  ch1= -sfmix(ifl,3)*sfmix(ifl-1,3)
50350  ch2= sfmix(ifl,4)*sfmix(ifl-1,4)
50351  ch3= -sfmix(ifl,3)*sfmix(ifl-1,4)
50352  ch4= -sfmix(ifl,4)*sfmix(ifl-1,3)
50353  ENDIF
50354  IF(ifl.EQ.6) THEN
50355  xmf=xmtop
50356  xmfp=xmbot
50357  at=atrit
50358  ab=atrib
50359  ENDIF
50360  ELSE
50361 C...B1 -> T2 HC
50362  IF(ilr.EQ.1) THEN
50363  ch1= sfmix(ifl+1,3)*sfmix(ifl,1)
50364  ch2=-sfmix(ifl+1,4)*sfmix(ifl,2)
50365  ch3= sfmix(ifl+1,3)*sfmix(ifl,2)
50366  ch4= sfmix(ifl+1,4)*sfmix(ifl,1)
50367 C...B2-> T2 HC
50368  ELSE
50369  ch1= -sfmix(ifl+1,3)*sfmix(ifl,3)
50370  ch2= sfmix(ifl+1,4)*sfmix(ifl,4)
50371  ch3= -sfmix(ifl+1,3)*sfmix(ifl,4)
50372  ch4= -sfmix(ifl+1,4)*sfmix(ifl,3)
50373  ENDIF
50374  IF(ifl.EQ.5) THEN
50375  xmf=xmtop
50376  xmfp=xmbot
50377  at=atrit
50378  ab=atrib
50379  ENDIF
50380  ENDIF
50381  xl=pylamf(xmi2,xmsf1**2,xmb**2)
50382  lknt=lknt+1
50383 C.......Need to complexify
50384  al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
50385  & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
50386  & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
50387  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
50388  idlam(lknt,3)=0
50389  idlam(lknt,1)=kf2
50390  idlam(lknt,2)=sign(37,kchg(ifl,1))
50391  ENDIF
50392 
50393 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50394 
50395  IF(ifl.LE.6) THEN
50396  xmfp=0d0
50397  xmf=0d0
50398  IF(ifl.EQ.6) xmf=pmas(6,1)
50399  IF(ifl.EQ.5) xmf=pmas(5,1)
50400  xmj=pmas(pycomp(ksusy1+21),1)
50401  axmj=abs(xmj)
50402  IF(xmi.GE.axmj+xmf) THEN
50403  al=-sfmix(ifl,3)
50404  bl=sfmix(ifl,1)
50405  ar=-sfmix(ifl,4)
50406  br=sfmix(ifl,2)
50407 C...F1 -> F CHI
50408  IF(ilr.EQ.1) THEN
50409  xca=al
50410  xcb=bl
50411 C...F2 -> F CHI
50412  ELSE
50413  xca=ar
50414  xcb=br
50415  ENDIF
50416  lknt=lknt+1
50417  xma2=xmj**2
50418  xmb2=xmf**2
50419  xl=pylamf(xmi2,xma2,xmb2)
50420  xlam(lknt)=4d0/3d0*as/2d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
50421  & (xca**2+xcb**2)+4d0*xca*xcb*xmj*xmf)
50422  idlam(lknt,1)=ksusy1+21
50423  idlam(lknt,2)=ifl
50424  idlam(lknt,3)=0
50425  ENDIF
50426  ENDIF
50427 
50428 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50429  IF(kfin.EQ.ksusy1+6.AND.pmas(kcin,1).GT.
50430  &pmas(pycomp(ksusy1+22),1)+pmas(4,1)) THEN
50431 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50432 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50433 C...M*M = C1**2 * G**2/(16PI**2)
50434 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50435  lknt=lknt+1
50436  xl=pylamf(xmi2,0d0,pmas(pycomp(ksusy1+22),1)**2)
50437  xlam(lknt)=c1**3/64d0/pi**2/xmi3*sqrt(xl)
50438  IF(xlam(lknt).EQ.0) xlam(lknt)=1d-3
50439  idlam(lknt,1)=ksusy1+22
50440  idlam(lknt,2)=4
50441  idlam(lknt,3)=0
50442  ENDIF
50443 
50444 C...R-violating sfermion decays (SKANDS).
50445  CALL pyrvsf(kfin,xlam,idlam,lknt)
50446 
50447  iknt=lknt
50448  xlam(0)=0d0
50449  DO 170 i=1,iknt
50450  IF(xlam(i).LT.0d0) xlam(i)=0d0
50451  xlam(0)=xlam(0)+xlam(i)
50452  170 CONTINUE
50453  IF(xlam(0).EQ.0d0) xlam(0)=1d-3
50454 
50455  RETURN
50456  END
50457 
50458 C*********************************************************************
50459 
50460 C...PYGLUI
50461 C...Calculates gluino decay modes.
50462 
50463  SUBROUTINE pyglui(KFIN,XLAM,IDLAM,IKNT)
50464 
50465 C...Double precision and integer declarations.
50466  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50467  IMPLICIT INTEGER(I-N)
50468  INTEGER PYK,PYCHGE,PYCOMP
50469 C...Parameter statement to help give large particle numbers.
50470  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
50471  &kexcit=4000000,kdimen=5000000)
50472 C...Commonblocks.
50473  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50474  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50475  common/pymssm/imss(0:99),rmss(0:99)
50476  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
50477  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
50478 CC &SFMIX(16,4),
50479 C COMMON/PYINTS/XXM(20)
50480  COMPLEX*16 CXC
50481  COMMON/PYINTC/XXC(10),CXC(8)
50482  SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50483 
50484 C...Local variables
50485  COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50486  DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50487  DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50488  DOUBLE PRECISION PYLAMF,XL
50489  DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50490  DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50491  DOUBLE PRECISION XLAM(0:400)
50492  INTEGER IDLAM(400,3)
50493  INTEGER LKNT,IX,ILR,I,IKNT,IFL
50494  DOUBLE PRECISION SR2
50495  DOUBLE PRECISION GAM
50496  DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50497  EXTERNAL pygaus,pyxxz6
50498  DOUBLE PRECISION PYGAUS,PYXXZ6
50499  DOUBLE PRECISION PREC
50500  INTEGER KFNCHI(4),KFCCHI(2)
50501  DATA pi/3.141592654d0/
50502  DATA sr2/1.4142136d0/
50503  DATA prec/1d-2/
50504  DATA kfnchi/1000022,1000023,1000025,1000035/
50505  DATA kfcchi/1000024,1000037/
50506 
50507 C...COUNT THE NUMBER OF DECAY MODES
50508  lknt=0
50509  IF(kfin.NE.ksusy1+21) RETURN
50510  kcin=pycomp(kfin)
50511 
50512  xw=paru(102)
50513  tanw = sqrt(xw/(1d0-xw))
50514 
50515  xmi=pmas(kcin,1)
50516  axmi=abs(xmi)
50517  xmi2=xmi**2
50518  aem=pyalem(xmi2)
50519  as =pyalps(xmi2)
50520  c1=aem/xw
50521  xmi3=axmi**3
50522 
50523  xmi=sign(xmi,rmss(3))
50524 
50525 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50526 
50527  IF(imss(11).EQ.1) THEN
50528  xmp=rmss(29)
50529  idg=39+ksusy1
50530  xmgr=pmas(pycomp(idg),1)
50531  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
50532  IF(axmi.GT.xmgr) THEN
50533  lknt=lknt+1
50534  idlam(lknt,1)=idg
50535  idlam(lknt,2)=21
50536  idlam(lknt,3)=0
50537  xlam(lknt)=xfac
50538  ENDIF
50539  ENDIF
50540 
50541 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50542 
50543  DO 110 ifl=1,6
50544  DO 100 ilr=1,2
50545  xmj=pmas(pycomp(ilr*ksusy1+ifl),1)
50546  axmj=abs(xmj)
50547  xmf=pmas(ifl,1)
50548  IF(axmi.GE.axmj+xmf) THEN
50549 C...Minus sign difference from gluino-quark-squark feynman rules
50550  al=sfmix(ifl,1)
50551  bl=-sfmix(ifl,3)
50552  ar=sfmix(ifl,2)
50553  br=-sfmix(ifl,4)
50554 C...F1 -> F CHI
50555  IF(ilr.EQ.1) THEN
50556  ca=al
50557  cb=bl
50558 C...F2 -> F CHI
50559  ELSE
50560  ca=ar
50561  cb=br
50562  ENDIF
50563  lknt=lknt+1
50564  xma2=xmj**2
50565  xmb2=xmf**2
50566  xl=pylamf(xmi2,xma2,xmb2)
50567  xlam(lknt)=4d0/8d0*as/4d0/xmi3*sqrt(xl)*((xmi2+xmb2-xma2)*
50568  & (ca**2+cb**2)-4d0*ca*cb*xmi*xmf)
50569  idlam(lknt,1)=ilr*ksusy1+ifl
50570  idlam(lknt,2)=-ifl
50571  idlam(lknt,3)=0
50572  lknt=lknt+1
50573  xlam(lknt)=xlam(lknt-1)
50574  idlam(lknt,1)=-idlam(lknt-1,1)
50575  idlam(lknt,2)=-idlam(lknt-1,2)
50576  idlam(lknt,3)=0
50577  ENDIF
50578  100 CONTINUE
50579  110 CONTINUE
50580 
50581 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50582 C...GLUINO -> NI Q QBAR
50583  DO 170 ix=1,4
50584  xmj=smz(ix)
50585  axmj=abs(xmj)
50586  IF(axmi.GE.axmj) THEN
50587  DO 120 i=1,4
50588  zmixc(ix,i)=dcmplx(zmix(ix,i),zmixi(ix,i))
50589  120 CONTINUE
50590  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))/sr2
50591  orpp=dconjg(olpp)
50592  xxc(1)=0d0
50593  xxc(2)=xmj
50594  xxc(3)=0d0
50595  xxc(4)=xmi
50596  ia=1
50597  xxc(5)=pmas(pycomp(ksusy1+ia),1)
50598  xxc(6)=pmas(pycomp(ksusy2+ia),1)
50599  xxc(7)=xxc(5)
50600  xxc(8)=xxc(6)
50601  xxc(9)=1d6
50602  xxc(10)=0d0
50603  ei=kchg(ia,1)/3d0
50604  t3i=sign(1d0,ei+1d-6)/2d0
50605  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
50606  grij=zmixc(ix,1)*(ei*tanw)*orpp
50607  cxc(1)=0d0
50608  cxc(2)=-glij
50609  cxc(3)=0d0
50610  cxc(4)=dconjg(glij)
50611  cxc(5)=0d0
50612  cxc(6)=grij
50613  cxc(7)=0d0
50614  cxc(8)=-dconjg(grij)
50615  s12min=0d0
50616  s12max=(axmi-axmj)**2
50617  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 130
50618  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
50619  lknt=lknt+1
50620  xlam(lknt)=c1*as/xmi3/(16d0*pi)*
50621  & pygaus(pyxxz6,s12min,s12max,1d-2)
50622  idlam(lknt,1)=kfnchi(ix)
50623  idlam(lknt,2)=1
50624  idlam(lknt,3)=-1
50625  ENDIF
50626  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
50627  lknt=lknt+1
50628  xlam(lknt)=xlam(lknt-1)
50629  idlam(lknt,1)=kfnchi(ix)
50630  idlam(lknt,2)=3
50631  idlam(lknt,3)=-3
50632  ENDIF
50633  130 CONTINUE
50634  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
50635  pmold=pmas(pycomp(ksusy1+5),1)
50636  IF(axmi.GT.pmas(pycomp(ksusy2+5),1)+pmas(5,1)) THEN
50637  GOTO 140
50638  ELSEIF(axmi.GT.pmas(pycomp(ksusy1+5),1)+pmas(5,1)) THEN
50639  pmas(pycomp(ksusy1+5),1)=100d0*xmi
50640  ENDIF
50641  CALL pytbbn(ix,100,-1d0/3d0,xmi,gam)
50642  lknt=lknt+1
50643  xlam(lknt)=gam
50644  idlam(lknt,1)=kfnchi(ix)
50645  idlam(lknt,2)=5
50646  idlam(lknt,3)=-5
50647  pmas(pycomp(ksusy1+5),1)=pmold
50648  ENDIF
50649 C...U-TYPE QUARKS
50650  140 CONTINUE
50651  ia=2
50652  xxc(5)=pmas(pycomp(ksusy1+ia),1)
50653  xxc(6)=pmas(pycomp(ksusy2+ia),1)
50654 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50655  xxc(7)=xxc(5)
50656  xxc(8)=xxc(6)
50657  ei=kchg(ia,1)/3d0
50658  t3i=sign(1d0,ei+1d-6)/2d0
50659  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
50660  grij=zmixc(ix,1)*(ei*tanw)*orpp
50661  cxc(2)=-glij
50662  cxc(4)=dconjg(glij)
50663  cxc(6)=grij
50664  cxc(8)=-dconjg(grij)
50665  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 150
50666  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
50667  lknt=lknt+1
50668  xlam(lknt)=c1*as/xmi3/(16d0*pi)*
50669  & pygaus(pyxxz6,s12min,s12max,1d-2)
50670  idlam(lknt,1)=kfnchi(ix)
50671  idlam(lknt,2)=2
50672  idlam(lknt,3)=-2
50673  ENDIF
50674  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
50675  lknt=lknt+1
50676  xlam(lknt)=xlam(lknt-1)
50677  idlam(lknt,1)=kfnchi(ix)
50678  idlam(lknt,2)=4
50679  idlam(lknt,3)=-4
50680  ENDIF
50681  150 CONTINUE
50682 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50683 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50684  xmf=pmas(6,1)
50685  IF(axmi.GE.axmj+2d0*xmf) THEN
50686  pmold=pmas(pycomp(ksusy1+6),1)
50687  IF(axmi.GT.pmas(pycomp(ksusy2+6),1)+xmf) THEN
50688  GOTO 160
50689  ELSEIF(axmi.GT.pmas(pycomp(ksusy1+6),1)+xmf) THEN
50690  pmas(pycomp(ksusy1+6),1)=100d0*xmi
50691  ENDIF
50692  CALL pytbbn(ix,100,2d0/3d0,xmi,gam)
50693  lknt=lknt+1
50694  xlam(lknt)=gam
50695  idlam(lknt,1)=kfnchi(ix)
50696  idlam(lknt,2)=6
50697  idlam(lknt,3)=-6
50698  pmas(pycomp(ksusy1+6),1)=pmold
50699  ENDIF
50700  160 CONTINUE
50701  ENDIF
50702  170 CONTINUE
50703 
50704 C...GLUINO -> CI Q QBAR'
50705  DO 210 ix=1,2
50706  xmj=smw(ix)
50707  axmj=abs(xmj)
50708  IF(axmi.GE.axmj) THEN
50709  DO 180 i=1,2
50710  vmixc(ix,i)=dcmplx(vmix(ix,i),vmixi(ix,i))
50711  umixc(ix,i)=dcmplx(umix(ix,i),umixi(ix,i))
50712  180 CONTINUE
50713  s12min=0d0
50714  s12max=(axmi-axmj)**2
50715  xxc(1)=0d0
50716  xxc(2)=xmj
50717  xxc(3)=0d0
50718  xxc(4)=xmi
50719  xxc(5)=pmas(pycomp(ksusy1+1),1)
50720  xxc(6)=pmas(pycomp(ksusy1+2),1)
50721  xxc(9)=1d6
50722  xxc(10)=0d0
50723  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))
50724  orpp=dconjg(olpp)
50725  cxc(1)=dcmplx(0d0,0d0)
50726  cxc(3)=dcmplx(0d0,0d0)
50727  cxc(5)=dcmplx(0d0,0d0)
50728  cxc(7)=dcmplx(0d0,0d0)
50729  cxc(2)=umixc(ix,1)*olpp/sr2
50730  cxc(4)=-dconjg(vmixc(ix,1))*orpp/sr2
50731  cxc(6)=dcmplx(0d0,0d0)
50732  cxc(8)=dcmplx(0d0,0d0)
50733  IF(xxc(5).LT.axmi) THEN
50734  xxc(5)=1d6
50735  ELSEIF(xxc(6).LT.axmi) THEN
50736  xxc(6)=1d6
50737  ENDIF
50738  xxc(7)=xxc(6)
50739  xxc(8)=xxc(5)
50740  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 190
50741  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
50742  lknt=lknt+1
50743  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
50744  & pygaus(pyxxz6,s12min,s12max,prec)
50745  idlam(lknt,1)=kfcchi(ix)
50746  idlam(lknt,2)=1
50747  idlam(lknt,3)=-2
50748  lknt=lknt+1
50749  xlam(lknt)=xlam(lknt-1)
50750  idlam(lknt,1)=-idlam(lknt-1,1)
50751  idlam(lknt,2)=-idlam(lknt-1,2)
50752  idlam(lknt,3)=-idlam(lknt-1,3)
50753  ENDIF
50754  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
50755  lknt=lknt+1
50756  xlam(lknt)=xlam(lknt-1)
50757  idlam(lknt,1)=kfcchi(ix)
50758  idlam(lknt,2)=3
50759  idlam(lknt,3)=-4
50760  lknt=lknt+1
50761  xlam(lknt)=xlam(lknt-1)
50762  idlam(lknt,1)=-idlam(lknt-1,1)
50763  idlam(lknt,2)=-idlam(lknt-1,2)
50764  idlam(lknt,3)=-idlam(lknt-1,3)
50765  ENDIF
50766  190 CONTINUE
50767 
50768  xmf=pmas(6,1)
50769  xmfp=pmas(5,1)
50770  IF(axmi.GE.axmj+xmf+xmfp) THEN
50771  IF(xmi.GT.min(pmas(pycomp(ksusy1+5),1)+xmfp,
50772  $ pmas(pycomp(ksusy2+6),1)+xmf)) GOTO 200
50773  pmolt2=pmas(pycomp(ksusy2+6),1)
50774  pmolb2=pmas(pycomp(ksusy2+5),1)
50775  pmolt1=pmas(pycomp(ksusy1+6),1)
50776  pmolb1=pmas(pycomp(ksusy1+5),1)
50777  IF(xmi.GT.pmolt2+xmf) pmas(pycomp(ksusy2+6),1)=100d0*axmi
50778  IF(xmi.GT.pmolt1+xmf) pmas(pycomp(ksusy1+6),1)=100d0*axmi
50779  IF(xmi.GT.pmolb2+xmfp) pmas(pycomp(ksusy2+5),1)=100d0*axmi
50780  IF(xmi.GT.pmolb1+xmfp) pmas(pycomp(ksusy1+5),1)=100d0*axmi
50781  CALL pytbbc(ix,100,xmi,gam)
50782  lknt=lknt+1
50783  xlam(lknt)=gam
50784  idlam(lknt,1)=kfcchi(ix)
50785  idlam(lknt,2)=5
50786  idlam(lknt,3)=-6
50787  lknt=lknt+1
50788  xlam(lknt)=xlam(lknt-1)
50789  idlam(lknt,1)=-idlam(lknt-1,1)
50790  idlam(lknt,2)=-idlam(lknt-1,2)
50791  idlam(lknt,3)=-idlam(lknt-1,3)
50792  pmas(pycomp(ksusy2+6),1)=pmolt2
50793  pmas(pycomp(ksusy2+5),1)=pmolb2
50794  pmas(pycomp(ksusy1+6),1)=pmolt1
50795  pmas(pycomp(ksusy1+5),1)=pmolb1
50796  ENDIF
50797  200 CONTINUE
50798  ENDIF
50799  210 CONTINUE
50800 
50801 C...R-parity violating (3-body) decays.
50802  CALL pyrvgl(kfin,xlam,idlam,lknt)
50803 
50804  iknt=lknt
50805  xlam(0)=0d0
50806  DO 220 i=1,iknt
50807  IF(xlam(i).LT.0d0) xlam(i)=0d0
50808  xlam(0)=xlam(0)+xlam(i)
50809  220 CONTINUE
50810  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
50811 
50812  RETURN
50813  END
50814 
50815 
50816 C*********************************************************************
50817 
50818 C...PYTBBN
50819 C...Calculates the three-body decay of gluinos into
50820 C...neutralinos and third generation fermions.
50821 
50822  SUBROUTINE pytbbn(I,NN,E,XMGLU,GAM)
50823 
50824 C...Double precision and integer declarations.
50825  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50826  IMPLICIT INTEGER(I-N)
50827  INTEGER PYK,PYCHGE,PYCOMP
50828 C...Parameter statement to help give large particle numbers.
50829  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
50830  &kexcit=4000000,kdimen=5000000)
50831 C...Commonblocks.
50832  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50833  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50834  common/pymssm/imss(0:99),rmss(0:99)
50835  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
50836  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
50837  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
50838 
50839 C...Local variables.
50840  EXTERNAL pysimp,pylamf
50841  DOUBLE PRECISION PYSIMP,PYLAMF
50842  INTEGER LIN,NN
50843  DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50844  DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50845  DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50846  DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50847  DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50848  DOUBLE PRECISION XLN1,XLN2,B1,B2
50849  DOUBLE PRECISION E,XMGLU,GAM
50850  DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50851  SAVE hrb,hlb,flb,frb
50852  DOUBLE PRECISION ALPHAW,ALPHAS
50853  DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50854  SAVE hlt,hrt,flt,frt
50855  DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50856  SAVE amn,an,zn
50857  DOUBLE PRECISION AMBOT,SINC,COSC
50858  DOUBLE PRECISION AMTOP,SINA,COSA
50859  DOUBLE PRECISION SINW,COSW,TANW
50860  DOUBLE PRECISION ROT1(4,4)
50861  LOGICAL IFIRST
50862  SAVE ifirst
50863  DATA ifirst/.true./
50864 
50865  tanb=rmss(5)
50866  sinb=tanb/sqrt(1d0+tanb**2)
50867  cosb=sinb/tanb
50868  xw=paru(102)
50869  sinw=sqrt(xw)
50870  cosw=sqrt(1d0-xw)
50871  tanw=sinw/cosw
50872  amw=pmas(24,1)
50873  cosc=sfmix(5,1)
50874  sinc=sfmix(5,3)
50875  cosa=sfmix(6,1)
50876  sina=sfmix(6,3)
50877  ambot=pymrun(5,xmglu**2)
50878  amtop=pymrun(6,xmglu**2)
50879  w2=sqrt(2d0)
50880  fakt1=ambot/w2/amw/cosb
50881  fakt2=amtop/w2/amw/sinb
50882  IF(ifirst) THEN
50883  DO 110 ii=1,4
50884  amn(ii)=smz(ii)
50885  DO 100 j=1,4
50886  rot1(ii,j)=0d0
50887  an(ii,j)=0d0
50888  100 CONTINUE
50889  110 CONTINUE
50890  rot1(1,1)=cosw
50891  rot1(1,2)=-sinw
50892  rot1(2,1)=-rot1(1,2)
50893  rot1(2,2)=rot1(1,1)
50894  rot1(3,3)=cosb
50895  rot1(3,4)=sinb
50896  rot1(4,3)=-rot1(3,4)
50897  rot1(4,4)=rot1(3,3)
50898  DO 140 ii=1,4
50899  DO 130 j=1,4
50900  DO 120 jj=1,4
50901  an(ii,j)=an(ii,j)+zmix(ii,jj)*rot1(jj,j)
50902  120 CONTINUE
50903  130 CONTINUE
50904  140 CONTINUE
50905  DO 150 j=1,4
50906  zn(1)=-fakt2*(-sinb*an(j,3)+cosb*an(j,4))
50907  zn(2)=-2d0*w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
50908  zn(3)=-2*w2/3d0*sinw*an(j,1)-w2*(0.5d0-2d0/3d0*
50909  & xw)*an(j,2)/cosw
50910  hrt(j)=zn(1)*cosa-zn(3)*sina
50911  hlt(j)=zn(1)*cosa+zn(2)*sina
50912  flt(j)=zn(3)*cosa+zn(1)*sina
50913  frt(j)=zn(2)*cosa-zn(1)*sina
50914 C FLU(J)=ZN(3)
50915 C FRU(J)=ZN(2)
50916  zn(1)=-fakt1*(cosb*an(j,3)+sinb*an(j,4))
50917  zn(2)=w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
50918  zn(3)=w2/3d0*sinw*an(j,1)+w2*(0.5d0-xw/3d0)*an(j,2)/cosw
50919  hrb(j)=zn(1)*cosc-zn(3)*sinc
50920  hlb(j)=zn(1)*cosc+zn(2)*sinc
50921  flb(j)=zn(3)*cosc+zn(1)*sinc
50922  frb(j)=zn(2)*cosc-zn(1)*sinc
50923 C FLD(J)=ZN(3)
50924 C FRD(J)=ZN(2)
50925  150 CONTINUE
50926 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50927 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50928 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50929 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50930  ifirst=.false.
50931  ENDIF
50932 
50933  IF(nint(3d0*e).EQ.2) THEN
50934  hl=hlt(i)
50935  hr=hrt(i)
50936  fl=flt(i)
50937  fr=frt(i)
50938  cosd=sfmix(6,1)
50939  sind=sfmix(6,3)
50940  xms2(1)=pmas(pycomp(ksusy1+6),1)**2
50941  xms2(2)=pmas(pycomp(ksusy2+6),1)**2
50942  xm=pmas(6,1)
50943  ELSE
50944  hl=hlb(i)
50945  hr=hrb(i)
50946  fl=flb(i)
50947  fr=frb(i)
50948  cosd=sfmix(5,1)
50949  sind=sfmix(5,3)
50950  xms2(1)=pmas(pycomp(ksusy1+5),1)**2
50951  xms2(2)=pmas(pycomp(ksusy2+5),1)**2
50952  xm=pmas(5,1)
50953  ENDIF
50954  cosd2=cosd*cosd
50955  sind2=sind*sind
50956  cos2d=cosd2-sind2
50957  sin2d=sind*cosd*2d0
50958  hl2=hl*hl
50959  hr2=hr*hr
50960  fl2=fl*fl
50961  fr2=fr*fr
50962  ff=fl*fr
50963  hh=hl*hr
50964  hfl=hl*fl
50965  hfr=hr*fr
50966  hrfl=hr*fl
50967  hlfr=hl*fr
50968  xm2=xm*xm
50969  xmg=xmglu
50970  xmg2=xmg*xmg
50971  alphaw=pyalem(xmg2)
50972  alphas=pyalps(xmg2)
50973  xmr=amn(i)
50974  xmr2=xmr*xmr
50975  xmq4=xmg*xm2*xmr
50976  xm24=(xmg2+xm2)*(xm2+xmr2)
50977  smin=4d0*xm2
50978  smax=(xmg-abs(xmr))**2
50979  xmqa=xmg2+2d0*xm2+xmr2
50980  DO 170 lin=1,nn-1
50981  sbar=smin+dble(lin)*(smax-smin)/dble(nn)
50982  grs=sbar-xmqa
50983  w=pylamf(xmg2,xmr2,sbar)*(0.25d0-xm2/sbar)
50984  w=dsqrt(w)
50985  xln1=log(abs((grs/2d0+xms2(1)-w)/(grs/2d0+xms2(1)+w)))
50986  xln2=log(abs((grs/2d0+xms2(2)-w)/(grs/2d0+xms2(2)+w)))
50987  b1=1d0/(grs/2d0+xms2(1)-w)-1d0/(grs/2d0+xms2(1)+w)
50988  b2=1d0/(grs/2d0+xms2(2)-w)-1d0/(grs/2d0+xms2(2)+w)
50989  g(0)=-2d0*(hl2+fl2+hr2+fr2+(hfr-hfl)*sin2d
50990  & +2d0*(ff*sind2-hh*cosd2))*w
50991  g(1)=((hl2+fl2)*(xmqa-2d0*xms2(1)-2d0*xm*xmg*sin2d)
50992  & +4d0*hfl*xm*xmr)*xln1
50993  & +((hl2+fl2)*((xmqa-xms2(1))*xms2(1)-xm24
50994  & +2d0*xm*xmg*(xm2+xmr2-xms2(1))*sin2d)
50995  & -4d0*hfl*xmr*xm*(xmg2+xm2-xms2(1))
50996  & +8d0*hfl*xmq4*sin2d)*b1
50997  g(2)=((hr2+fr2)*(xmqa-2d0*xms2(2)+2d0*xm*xmg*sin2d)
50998  & +4d0*hfr*xmr*xm)*xln2
50999  & +((hr2+fr2)*((xmqa-xms2(2))*xms2(2)-xm24
51000  & +2d0*xmg*xm*sin2d*(xms2(2)-xm2-xmr2))
51001  & +4d0*hfr*xm*xmr*(xms2(2)-xmg2-xm2)
51002  & -8d0*hfr*xmq4*sin2d)*b2
51003  g(3)=(2d0*hfl*sin2d*(xms2(1)*(grs+xms2(1))+xm2*(sbar-xmg2-xmr2)
51004  & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hl2*sind2+fl2*cosd2)*sbar
51005  & -2d0*xmg*xm*hfl*(sbar+xmr2-xmg2)
51006  & +xmr*xm*(hl2+fl2)*sin2d*(sbar+xmg2-xmr2)
51007  & -4d0*xmq4*(hl2-fl2)*cos2d)/(grs+2d0*xms2(1))*xln1
51008  g(4)=4d0*cos2d*xm*xmg/(xms2(1)-xms2(2))*
51009  & (((hlfr+hrfl)*(xm2+xmr2)+2d0*xm*xmr*(hh+ff))*(xln1-xln2)
51010  & +(hlfr+hrfl)*(xms2(2)*xln2-xms2(1)*xln1))
51011  g(5)=(2d0*(hh*cosd2-ff*sind2)
51012  & *((xms2(2)*(xms2(2)+grs)+xm2*xm2+xmg2*xmr2)*xln2
51013  & +(xms2(1)*(xms2(1)+grs)+xm2*xm2+xmg2*xmr2)*xln1)
51014  & +xm*((hh-ff)*sin2d*xmg-(hrfl-hlfr)*xmr)
51015  & *((grs+xms2(1)*2d0)*xln1-(grs+xms2(2)*2d0)*xln2)
51016  & +((hrfl-hlfr)*xmr*(sin2d*xmg*(sbar-4d0*xm2)
51017  & +cos2d*xm*(sbar+xmg2-xmr2))
51018  & +2d0*(ff*cosd2-hh*sind2)*xm2*(sbar-xmg2-xmr2))
51019  & *(xln1+xln2))/(grs+xms2(1)+xms2(2))
51020  g(6)=(-2d0*hfr*sin2d*(xms2(2)*(grs+xms2(2))+xm2*(sbar-xmg2-xmr2)
51021  & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hr2*sind2+fr2*cosd2)*sbar
51022  & -2d0*xmg*xm*hfr*(sbar+xmr2-xmg2)
51023  & -xmr*xm*(hr2+fr2)*sin2d*(sbar+xmg2-xmr2)
51024  & -4d0*xmq4*(hr2-fr2)*cos2d)/(grs+2d0*xms2(2))*xln2
51025  summe(lin)=0d0
51026  DO 160 j=0,6
51027  summe(lin)=summe(lin)+g(j)
51028  160 CONTINUE
51029  170 CONTINUE
51030  summe(0)=0d0
51031  summe(nn)=0d0
51032  gam = alphaw * alphas * pysimp(summe,smin,smax,nn)
51033  &/ (16d0 * paru(1) * paru(102) * xmglu**3)
51034 
51035  RETURN
51036  END
51037 
51038 C*********************************************************************
51039 
51040 C...PYTBBC
51041 C...Calculates the three-body decay of gluinos into
51042 C...charginos and third generation fermions.
51043 
51044  SUBROUTINE pytbbc(I,NN,XMGLU,GAM)
51045 
51046 C...Double precision and integer declarations.
51047  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51048  IMPLICIT INTEGER(I-N)
51049  INTEGER PYK,PYCHGE,PYCOMP
51050 C...Parameter statement to help give large particle numbers.
51051  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
51052  &kexcit=4000000,kdimen=5000000)
51053 C...Commonblocks.
51054  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51055  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
51056  common/pymssm/imss(0:99),rmss(0:99)
51057  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
51058  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
51059  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
51060 
51061 C...Local variables.
51062  EXTERNAL pysimp,pylamf
51063  DOUBLE PRECISION PYSIMP,PYLAMF
51064  INTEGER I,NN,LIN
51065  DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51066  DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51067  DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51068  DOUBLE PRECISION SUMME(0:100),A(4,8)
51069  DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51070  DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51071  DOUBLE PRECISION XMGLU,GAM
51072  DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51073  &ddd(2),eee(2),fff(2)
51074  SAVE xx1,xx2,aaa,bbb,ccc,ddd,eee,fff
51075  DOUBLE PRECISION ALPHAW,ALPHAS
51076  DOUBLE PRECISION AMC(2)
51077  SAVE AMC
51078  DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51079  DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51080  SAVE amsb,amst
51081  LOGICAL IFIRST
51082  SAVE ifirst
51083  DATA ifirst/.true./
51084 
51085  tanb=rmss(5)
51086  sinb=tanb/sqrt(1d0+tanb**2)
51087  cosb=sinb/tanb
51088  xw=paru(102)
51089  amw=pmas(24,1)
51090  cosc=sfmix(5,1)
51091  sinc=sfmix(5,3)
51092  cosa=sfmix(6,1)
51093  sina=sfmix(6,3)
51094  ambot=pymrun(5,xmglu**2)
51095  amtop=pymrun(6,xmglu**2)
51096  w2=sqrt(2d0)
51097  amw=pmas(24,1)
51098  fakt1=ambot/w2/amw/cosb
51099  fakt2=amtop/w2/amw/sinb
51100  IF(ifirst) THEN
51101  amc(1)=smw(1)
51102  amc(2)=smw(2)
51103  DO 100 jj=1,2
51104  ccc(jj)=fakt1*umix(jj,2)*sinc-umix(jj,1)*cosc
51105  eee(jj)=fakt2*vmix(jj,2)*cosc
51106  ddd(jj)=fakt1*umix(jj,2)*cosc+umix(jj,1)*sinc
51107  fff(jj)=fakt2*vmix(jj,2)*sinc
51108  xx1(jj)=fakt2*vmix(jj,2)*sina-vmix(jj,1)*cosa
51109  aaa(jj)=fakt1*umix(jj,2)*cosa
51110  xx2(jj)=fakt2*vmix(jj,2)*cosa+vmix(jj,1)*sina
51111  bbb(jj)=fakt1*umix(jj,2)*sina
51112  100 CONTINUE
51113  amst(1)=pmas(pycomp(ksusy1+6),1)
51114  amst(2)=pmas(pycomp(ksusy2+6),1)
51115  amsb(1)=pmas(pycomp(ksusy1+5),1)
51116  amsb(2)=pmas(pycomp(ksusy2+5),1)
51117  ifirst=.false.
51118  ENDIF
51119 
51120  ulr(1)=xx1(i)*xx1(i)+aaa(i)*aaa(i)
51121  ulr(2)=xx2(i)*xx2(i)+bbb(i)*bbb(i)
51122  vlr(1)=ccc(i)*ccc(i)+eee(i)*eee(i)
51123  vlr(2)=ddd(i)*ddd(i)+fff(i)*fff(i)
51124 
51125  cos2a=cosa**2-sina**2
51126  sin2a=sina*cosa*2d0
51127  cos2c=cosc**2-sinc**2
51128  sin2c=sinc*cosc*2d0
51129 
51130  xmg=xmglu
51131  xmt=pmas(6,1)
51132  xmb=pmas(5,1)
51133  xmr=amc(i)
51134  xmg2=xmg*xmg
51135  alphaw=pyalem(xmg2)
51136  alphas=pyalps(xmg2)
51137  xmt2=xmt*xmt
51138  xmb2=xmb*xmb
51139  xmr2=xmr*xmr
51140  xmq2=xmg2+xmt2+xmb2+xmr2
51141  xmq4=xmg*xmt*xmb*xmr
51142  xmq3=xmg2*xmr2+xmt2*xmb2
51143  xmgbtr=(xmg2+xmb2)*(xmt2+xmr2)
51144  xmgtbr=(xmg2+xmt2)*(xmb2+xmr2)
51145 
51146  xmst(1)=amst(1)*amst(1)
51147  xmst(2)=amst(1)*amst(1)
51148  xmst(3)=amst(2)*amst(2)
51149  xmst(4)=amst(2)*amst(2)
51150  xmsb(1)=amsb(1)*amsb(1)
51151  xmsb(2)=amsb(2)*amsb(2)
51152  xmsb(3)=amsb(1)*amsb(1)
51153  xmsb(4)=amsb(2)*amsb(2)
51154 
51155  a(1,1)=-cosa*sinc*ccc(i)*aaa(i)-sina*cosc*eee(i)*xx1(i)
51156  a(1,2)=xmg*xmb*(cosa*cosc*ccc(i)*aaa(i)+sina*sinc*eee(i)*xx1(i))
51157  a(1,3)=-xmg*xmr*(cosa*cosc*ccc(i)*xx1(i)+sina*sinc*eee(i)*aaa(i))
51158  a(1,4)=xmb*xmr*(cosa*sinc*ccc(i)*xx1(i)+sina*cosc*eee(i)*aaa(i))
51159  a(1,5)=xmg*xmt*(cosa*cosc*eee(i)*xx1(i)+sina*sinc*ccc(i)*aaa(i))
51160  a(1,6)=-xmt*xmb*(cosa*sinc*eee(i)*xx1(i)+sina*cosc*ccc(i)*aaa(i))
51161  a(1,7)=xmt*xmr*(cosa*sinc*eee(i)*aaa(i)+sina*cosc*ccc(i)*xx1(i))
51162  a(1,8)=-xmq4*(cosa*cosc*eee(i)*aaa(i)+sina*sinc*ccc(i)*xx1(i))
51163 
51164  a(2,1)=-cosa*cosc*ddd(i)*aaa(i)-sina*sinc*fff(i)*xx1(i)
51165  a(2,2)=-xmg*xmb*(cosa*sinc*ddd(i)*aaa(i)+sina*cosc*fff(i)*xx1(i))
51166  a(2,3)=xmg*xmr*(cosa*sinc*ddd(i)*xx1(i)+sina*cosc*fff(i)*aaa(i))
51167  a(2,4)=xmb*xmr*(cosa*cosc*ddd(i)*xx1(i)+sina*sinc*fff(i)*aaa(i))
51168  a(2,5)=xmg*xmt*(cosa*sinc*fff(i)*xx1(i)+sina*cosc*ddd(i)*aaa(i))
51169  a(2,6)=xmt*xmb*(cosa*cosc*fff(i)*xx1(i)+sina*sinc*ddd(i)*aaa(i))
51170  a(2,7)=-xmt*xmr*(cosa*cosc*fff(i)*aaa(i)+sina*sinc*ddd(i)*xx1(i))
51171  a(2,8)=-xmq4*(cosa*sinc*fff(i)*aaa(i)+sina*cosc*ddd(i)*xx1(i))
51172 
51173  a(3,1)=-cosa*cosc*eee(i)*xx2(i)-sina*sinc*ccc(i)*bbb(i)
51174  a(3,2)=xmg*xmb*(cosa*sinc*eee(i)*xx2(i)+sina*cosc*ccc(i)*bbb(i))
51175  a(3,3)=xmg*xmr*(cosa*sinc*eee(i)*bbb(i)+sina*cosc*ccc(i)*xx2(i))
51176  a(3,4)=-xmb*xmr*(cosa*cosc*eee(i)*bbb(i)+sina*sinc*ccc(i)*xx2(i))
51177  a(3,5)=-xmg*xmt*(cosa*sinc*ccc(i)*bbb(i)+sina*cosc*eee(i)*xx2(i))
51178  a(3,6)=xmt*xmb*(cosa*cosc*ccc(i)*bbb(i)+sina*sinc*eee(i)*xx2(i))
51179  a(3,7)=xmt*xmr*(cosa*cosc*ccc(i)*xx2(i)+sina*sinc*eee(i)*bbb(i))
51180  a(3,8)=-xmq4*(cosa*sinc*ccc(i)*xx2(i)+sina*cosc*eee(i)*bbb(i))
51181 
51182  a(4,1)=-cosa*sinc*fff(i)*xx2(i)-sina*cosc*ddd(i)*bbb(i)
51183  a(4,2)=-xmg*xmb*(cosa*cosc*fff(i)*xx2(i)+sina*sinc*ddd(i)*bbb(i))
51184  a(4,3)=-xmg*xmr*(cosa*cosc*fff(i)*bbb(i)+sina*sinc*ddd(i)*xx2(i))
51185  a(4,4)=-xmb*xmr*(cosa*sinc*fff(i)*bbb(i)+sina*cosc*ddd(i)*xx2(i))
51186  a(4,5)=-xmg*xmt*(cosa*cosc*ddd(i)*bbb(i)+sina*sinc*fff(i)*xx2(i))
51187  a(4,6)=-xmt*xmb*(cosa*sinc*ddd(i)*bbb(i)+sina*cosc*fff(i)*xx2(i))
51188  a(4,7)=-xmt*xmr*(cosa*sinc*ddd(i)*xx2(i)+sina*cosc*fff(i)*bbb(i))
51189  a(4,8)=-xmq4*(cosa*cosc*ddd(i)*xx2(i)+sina*sinc*fff(i)*bbb(i))
51190 
51191  smax=(xmg-abs(xmr))**2
51192  smin=(xmb+xmt)**2+0.1d0
51193 
51194  DO 120 lin=0,nn-1
51195  sbar=smin+dble(lin)*(smax-smin)/dble(nn)
51196  am=(xmg2-xmr2)*(xmt2-xmb2)/2d0/sbar
51197  grs=sbar-xmq2
51198  w=pylamf(sbar,xmb2,xmt2)*pylamf(sbar,xmg2,xmr2)
51199  w=dsqrt(w)/2d0/sbar
51200  ant1=log(abs((grs/2d0+am+xmst(1)-w)/(grs/2d0+am+xmst(1)+w)))
51201  ant2=log(abs((grs/2d0+am+xmst(3)-w)/(grs/2d0+am+xmst(3)+w)))
51202  anb1=log(abs((grs/2d0-am+xmsb(1)-w)/(grs/2d0-am+xmsb(1)+w)))
51203  anb2=log(abs((grs/2d0-am+xmsb(2)-w)/(grs/2d0-am+xmsb(2)+w)))
51204  summe(lin)=-ulr(1)*w+(ulr(1)*(xmq2/2d0-xmst(1)-xmg*xmt*sin2a)
51205  & +2d0*xx1(i)*aaa(i)*xmr*xmb)*ant1
51206  & +(ulr(1)/2d0*(xmst(1)*(xmq2-xmst(1))-xmgtbr
51207  & -2d0*xmg*xmt*sin2a*(xmst(1)-xmb2-xmr2))
51208  & +2d0*xx1(i)*aaa(i)*xmr*xmb*(xmst(1)-xmg2-xmt2)
51209  & +4d0*sin2a*xx1(i)*aaa(i)*xmq4)
51210  & *(1d0/(grs/2d0+am+xmst(1)-w)-1d0/(grs/2d0+am+xmst(1)+w))
51211  summe(lin)=summe(lin)-ulr(2)*w
51212  & +(ulr(2)*(xmq2/2d0-xmst(3)+xmg*xmt*sin2a)
51213  & -2d0*xx2(i)*bbb(i)*xmr*xmb)*ant2
51214  & +(ulr(2)/2d0*(xmst(3)*(xmq2-xmst(3))-xmgtbr
51215  & +2d0*xmg*xmt*sin2a*(xmst(3)-xmb2-xmr2))
51216  & -2d0*xx2(i)*bbb(i)*xmr*xmb*(xmst(3)-xmg2-xmt2)
51217  & +4d0*sin2a*xx2(i)*bbb(i)*xmq4)
51218  & *(1d0/(grs/2d0+am+xmst(3)-w)-1d0/(grs/2d0+am+xmst(3)+w))
51219  summe(lin)=summe(lin)-vlr(1)*w
51220  & +(vlr(1)*(xmq2/2d0-xmsb(1)-xmg*xmb*sin2c)
51221  & +2d0*ccc(i)*eee(i)*xmr*xmt)*anb1
51222  & +(vlr(1)/2d0*(xmsb(1)*(xmq2-xmsb(1))-xmgbtr
51223  & -2d0*xmg*xmb*sin2c*(xmsb(1)-xmt2-xmr2))
51224  & +2d0*ccc(i)*eee(i)*xmr*xmt*(xmsb(1)-xmg2-xmb2)
51225  & +4d0*sin2c*ccc(i)*eee(i)*xmq4)
51226  & *(1d0/(grs/2d0-am+xmsb(1)-w)-1d0/(grs/2d0-am+xmsb(1)+w))
51227  summe(lin)=summe(lin)-vlr(2)*w
51228  & +(vlr(2)*(xmq2/2d0-xmsb(2)+xmg*xmb*sin2c)
51229  & -2d0*ddd(i)*fff(i)*xmr*xmt)*anb2
51230  & +(vlr(2)/2d0*(xmsb(2)*(xmq2-xmsb(2))-xmgbtr
51231  & +2d0*xmg*xmb*sin2c*(xmsb(2)-xmt2-xmr2))
51232  & -2d0*ddd(i)*fff(i)*xmr*xmt*(xmsb(2)-xmg2-xmb2)
51233  & +4d0*sin2c*ddd(i)*fff(i)*xmq4)
51234  & *(1d0/(grs/2d0-am+xmsb(2)-w)-1d0/(grs/2d0-am+xmsb(2)+w))
51235  summe(lin)=summe(lin)+2d0*xmg*xmt*cos2a/(xmst(3)-xmst(1))
51236  & *((aaa(i)*bbb(i)-xx1(i)*xx2(i))
51237  & *((xmst(3)-xmb2-xmr2)*ant2-(xmst(1)-xmb2-xmr2)*ant1)
51238  & +2d0*(aaa(i)*xx2(i)-xx1(i)*bbb(i))*xmb*xmr*(ant2-ant1))
51239  summe(lin)=summe(lin)+2d0*xmg*xmb*cos2c/(xmsb(2)-xmsb(1))
51240  & *((eee(i)*fff(i)-ccc(i)*ddd(i))
51241  & *((xmsb(2)-xmt2-xmr2)*anb2-(xmsb(1)-xmt2-xmr2)*anb1)
51242  & +2d0*(eee(i)*ddd(i)-ccc(i)*fff(i))*xmt*xmr*(anb2-anb1))
51243  DO 110 j=1,4
51244  summe(lin)=summe(lin)-2d0*a(j,1)*w
51245  & +((-a(j,1)*(xmsb(j)*(grs+xmsb(j))+xmq3)
51246  & +a(j,2)*(xmsb(j)-xmt2-xmr2)+a(j,3)*(sbar-xmb2-xmt2)
51247  & +a(j,4)*(xmsb(j)+sbar-xmb2-xmr2)
51248  & -a(j,5)*(xmsb(j)+sbar-xmg2-xmt2)+a(j,6)*(xmg2+xmr2-sbar)
51249  & -a(j,7)*(xmsb(j)-xmg2-xmb2)+2d0*a(j,8))
51250  & *log(abs((grs/2d0+xmsb(j)-am-w)/(grs/2d0+xmsb(j)-am+w)))
51251  & -(a(j,1)*(xmst(j)*(grs+xmst(j))+xmq3)
51252  & +a(j,2)*(xmst(j)+sbar-xmg2-xmb2)-a(j,3)*(sbar-xmb2-xmt2)
51253  & +a(j,4)*(xmst(j)-xmg2-xmt2)-a(j,5)*(xmst(j)-xmr2-xmb2)
51254  & -a(j,6)*(xmg2+xmr2-sbar)
51255  & -a(j,7)*(xmst(j)+sbar-xmt2-xmr2)-2d0*a(j,8))
51256  & *log(abs((grs/2d0+xmst(j)+am-w)/(grs/2d0+xmst(j)+am+w))))
51257  & /(grs+xmsb(j)+xmst(j))
51258  110 CONTINUE
51259  120 CONTINUE
51260  summe(nn)=0d0
51261  gam= alphaw * alphas * pysimp(summe,smin,smax,nn)
51262  &/ (16d0 * paru(1) * paru(102) * xmglu**3)
51263 
51264  RETURN
51265  END
51266 
51267 C*********************************************************************
51268 
51269 C...PYNJDC
51270 C...Calculates decay widths for the neutralinos (admixtures of
51271 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51272 
51273 C...Input: KCIN = KF code for particle
51274 C...Output: XLAM = widths
51275 C... IDLAM = KF codes for decay particles
51276 C... IKNT = number of decay channels defined
51277 C...AUTHOR: STEPHEN MRENNA
51278 C...Last change:
51279 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51280 C...when CHIGAMMA .NE. 0
51281 C...10 FEB 96: Calculate this decay for small tan(beta)
51282 
51283  SUBROUTINE pynjdc(KFIN,XLAM,IDLAM,IKNT)
51284 
51285 C...Double precision and integer declarations.
51286  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51287  IMPLICIT INTEGER(I-N)
51288  INTEGER PYK,PYCHGE,PYCOMP
51289 C...Parameter statement to help give large particle numbers.
51290  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
51291  &kexcit=4000000,kdimen=5000000)
51292 C...Commonblocks.
51293  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51294  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
51295  common/pymssm/imss(0:99),rmss(0:99)
51296 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51297 c &SFMIX(16,4)
51298  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
51299  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
51300 C COMMON/PYINTS/XXM(20)
51301  COMPLEX*16 CXC
51302  common/pyintc/xxc(10),cxc(8)
51303  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyintc/
51304 
51305 C...Local variables.
51306  COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51307  COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51308  INTEGER KFIN
51309  DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51310  &xmz,xmz2,axmj,axmi
51311  DOUBLE PRECISION S12MIN,S12MAX
51312  DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51313  DOUBLE PRECISION PYLAMF,XL
51314  DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51315  DOUBLE PRECISION PYX2XH,PYX2XG
51316  DOUBLE PRECISION XLAM(0:400)
51317  INTEGER IDLAM(400,3)
51318  INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51319  INTEGER ITH(3),KF1,KF2
51320  INTEGER ITHC
51321  DOUBLE PRECISION DH(3),EH(3)
51322  DOUBLE PRECISION SR2
51323  DOUBLE PRECISION CBETA,SBETA
51324  DOUBLE PRECISION GAMCON,XMT1,XMT2
51325  DOUBLE PRECISION PYALEM,PI,PYALPS
51326  DOUBLE PRECISION RAT1,RAT2
51327  DOUBLE PRECISION T3T,FCOL
51328  DOUBLE PRECISION ALFA,BETA,TANB
51329  DOUBLE PRECISION PYXXGA
51330  EXTERNAL pygaus,pyxxz6
51331  DOUBLE PRECISION PYGAUS,PYXXZ6
51332  DOUBLE PRECISION PREC
51333  INTEGER KFNCHI(4),KFCCHI(2)
51334  DATA ith/25,35,36/
51335  DATA ithc/37/
51336  DATA prec/1d-2/
51337  DATA pi/3.141592654d0/
51338  DATA sr2/1.4142136d0/
51339  DATA kfnchi/1000022,1000023,1000025,1000035/
51340  DATA kfcchi/1000024,1000037/
51341 
51342 C...COUNT THE NUMBER OF DECAY MODES
51343  lknt=0
51344 
51345  xmw=pmas(24,1)
51346  xmw2=xmw**2
51347  xmz=pmas(23,1)
51348  xmz2=xmz**2
51349  xw=1d0-xmw2/xmz2
51350  xw1=1d0-xw
51351  tanw = sqrt(xw/xw1)
51352 
51353 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51354  ix=1
51355  IF(kfin.EQ.kfnchi(2)) ix=2
51356  IF(kfin.EQ.kfnchi(3)) ix=3
51357  IF(kfin.EQ.kfnchi(4)) ix=4
51358 
51359  xmi=smz(ix)
51360  xmi2=xmi**2
51361  axmi=abs(xmi)
51362  aem=pyalem(xmi2)
51363  as =pyalps(xmi2)
51364  c1=aem/xw
51365  xmi3=abs(xmi**3)
51366 
51367  tanb=rmss(5)
51368  beta=atan(tanb)
51369  alfa=rmss(18)
51370  cbeta=cos(beta)
51371  sbeta=tanb*cbeta
51372  calfa=cos(alfa)
51373  salfa=sin(alfa)
51374 
51375  DO 110 i=1,4
51376  DO 100 j=1,4
51377  zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
51378  100 CONTINUE
51379  110 CONTINUE
51380  DO 130 i=1,2
51381  DO 120 j=1,2
51382  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
51383  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
51384  120 CONTINUE
51385  130 CONTINUE
51386 
51387 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51388  IF(ix.EQ.1.AND.imss(11).EQ.0) GOTO 300
51389 
51390 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51391  IF(ix.EQ.2 .AND. imss(10).NE.0 ) THEN
51392  xmj=smz(1)
51393  axmj=abs(xmj)
51394  lknt=lknt+1
51395  gamcon=aem**3/8d0/pi/xmw2/xw
51396  xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
51397  xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
51398  xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
51399  idlam(lknt,1)=ksusy1+22
51400  idlam(lknt,2)=22
51401  idlam(lknt,3)=0
51402  WRITE(mstu(11),*) 'FORCED N2 -> N1 + GAMMA ',xlam(lknt)
51403  GOTO 340
51404  ENDIF
51405 
51406 C...GRAVITINO DECAY MODES
51407 
51408  IF(imss(11).EQ.1) THEN
51409  xmp=rmss(29)
51410  idg=39+ksusy1
51411  xmgr=pmas(pycomp(idg),1)
51412  sinw=sqrt(xw)
51413  cosw=sqrt(1d0-xw)
51414  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
51415  IF(axmi.GT.xmgr+pmas(22,1)) THEN
51416  lknt=lknt+1
51417  idlam(lknt,1)=idg
51418  idlam(lknt,2)=22
51419  idlam(lknt,3)=0
51420  xlam(lknt)=xfac*abs(zmixc(ix,1)*cosw+zmixc(ix,2)*sinw)**2
51421  ENDIF
51422  IF(axmi.GT.xmgr+xmz) THEN
51423  lknt=lknt+1
51424  idlam(lknt,1)=idg
51425  idlam(lknt,2)=23
51426  idlam(lknt,3)=0
51427  xlam(lknt)=xfac*(abs(zmixc(ix,1)*sinw-zmixc(ix,2)*cosw)**2 +
51428  $ .5d0*abs(zmixc(ix,3)*cbeta-zmixc(ix,4)*sbeta)**2)*
51429  & (1d0-xmz2/xmi2)**4
51430  ENDIF
51431  IF(axmi.GT.xmgr+pmas(25,1)) THEN
51432  lknt=lknt+1
51433  idlam(lknt,1)=idg
51434  idlam(lknt,2)=25
51435  idlam(lknt,3)=0
51436  xlam(lknt)=xfac*(abs(zmixc(ix,3)*salfa-zmixc(ix,4)*calfa)**2)*
51437  $ .5d0*(1d0-pmas(25,1)**2/xmi2)**4
51438  ENDIF
51439  IF(axmi.GT.xmgr+pmas(35,1)) THEN
51440  lknt=lknt+1
51441  idlam(lknt,1)=idg
51442  idlam(lknt,2)=35
51443  idlam(lknt,3)=0
51444  xlam(lknt)=xfac*(abs(zmixc(ix,3)*calfa+zmixc(ix,4)*salfa)**2)*
51445  $ .5d0*(1d0-pmas(35,1)**2/xmi2)**4
51446  ENDIF
51447  IF(axmi.GT.xmgr+pmas(36,1)) THEN
51448  lknt=lknt+1
51449  idlam(lknt,1)=idg
51450  idlam(lknt,2)=36
51451  idlam(lknt,3)=0
51452  xlam(lknt)=xfac*(abs(zmixc(ix,3)*sbeta+zmixc(ix,4)*cbeta)**2)*
51453  $ .5d0*(1d0-pmas(36,1)**2/xmi2)**4
51454  ENDIF
51455  IF(ix.EQ.1) GOTO 300
51456  ENDIF
51457 
51458  DO 220 ij=1,ix-1
51459  xmj=smz(ij)
51460  axmj=abs(xmj)
51461  xmj2=xmj**2
51462 
51463 C...CHI0_I -> CHI0_J + GAMMA
51464  IF(axmi.GE.axmj.AND.sbeta/cbeta.LE.2d0) THEN
51465  rat1=abs(zmixc(ij,1))**2+abs(zmixc(ij,2))**2
51466  rat1=rat1/( 1d-6+abs(zmixc(ix,3))**2+abs(zmixc(ix,4))**2 )
51467  rat2=abs(zmixc(ix,1))**2+abs(zmixc(ix,2))**2
51468  rat2=rat2/( 1d-6+abs(zmixc(ij,3))**2+abs(zmixc(ij,4))**2 )
51469  IF((rat1.GT. 0.90d0 .AND. rat1.LT. 1.10d0) .OR.
51470  & (rat2.GT. 0.90d0 .AND. rat2.LT. 1.10d0)) THEN
51471  lknt=lknt+1
51472  idlam(lknt,1)=kfnchi(ij)
51473  idlam(lknt,2)=22
51474  idlam(lknt,3)=0
51475  gamcon=aem**3/8d0/pi/xmw2/xw
51476  xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
51477  xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
51478  xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
51479  ENDIF
51480  ENDIF
51481 
51482 C...CHI0_I -> CHI0_J + Z0
51483  IF(axmi.GE.axmj+xmz) THEN
51484  lknt=lknt+1
51485  olpp=(zmixc(ix,3)*dconjg(zmixc(ij,3))-
51486  & zmixc(ix,4)*dconjg(zmixc(ij,4)))/2d0
51487  orpp=-dconjg(olpp)
51488  gx2=abs(olpp)**2+abs(orpp)**2
51489  glr=dble(olpp*dconjg(orpp))
51490  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gx2,glr)
51491  idlam(lknt,1)=kfnchi(ij)
51492  idlam(lknt,2)=23
51493  idlam(lknt,3)=0
51494  ELSEIF(axmi.GE.axmj) THEN
51495  xxc(1)=0d0
51496  xxc(2)=xmj
51497  xxc(3)=0d0
51498  xxc(4)=xmi
51499  xxc(9)=xmz
51500  xxc(10)=pmas(23,2)
51501  olpp=(zmixc(ix,3)*dconjg(zmixc(ij,3))-
51502  & zmixc(ix,4)*dconjg(zmixc(ij,4)))/2d0
51503  orpp=dconjg(olpp)
51504 C...CHARGED LEPTONS
51505  fid=11
51506  xxc(5)=pmas(pycomp(ksusy1+fid),1)
51507  xxc(6)=pmas(pycomp(ksusy2+fid),1)
51508  ei=kchg(fid,1)/3d0
51509  t3i=sign(1d0,ei+1d-6)/2d0
51510  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51511  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51512  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51513  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51514  cxc(2)=-glij
51515  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51516  cxc(4)=dconjg(glij)
51517  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51518  cxc(6)=grij
51519  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51520  cxc(8)=-dconjg(grij)
51521  s12min=0d0
51522  s12max=(axmi-axmj)**2
51523  IF( xxc(5).LT.axmi ) THEN
51524  xxc(5)=1d6
51525  ENDIF
51526  IF(xxc(6).LT.axmi ) THEN
51527  xxc(6)=1d6
51528  ENDIF
51529  xxc(7)=xxc(5)
51530  xxc(8)=xxc(6)
51531 
51532  IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
51533  lknt=lknt+1
51534  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51535  & pygaus(pyxxz6,s12min,s12max,1d-3)
51536  idlam(lknt,1)=kfnchi(ij)
51537  idlam(lknt,2)=fid
51538  idlam(lknt,3)=-fid
51539  IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
51540  lknt=lknt+1
51541  xlam(lknt)=xlam(lknt-1)
51542  idlam(lknt,1)=kfnchi(ij)
51543  idlam(lknt,2)=13
51544  idlam(lknt,3)=-13
51545  ENDIF
51546  ENDIF
51547  140 CONTINUE
51548  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
51549  xxc(5)=pmas(pycomp(ksusy1+15),1)
51550  xxc(6)=pmas(pycomp(ksusy2+15),1)
51551  ELSE
51552  xxc(6)=pmas(pycomp(ksusy1+15),1)
51553  xxc(5)=pmas(pycomp(ksusy2+15),1)
51554  ENDIF
51555  IF( xxc(5).LT.axmi ) THEN
51556  xxc(5)=1d6
51557  ENDIF
51558  IF(xxc(6).LT.axmi ) THEN
51559  xxc(6)=1d6
51560  ENDIF
51561  xxc(7)=xxc(5)
51562  xxc(8)=xxc(6)
51563 
51564  IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
51565  lknt=lknt+1
51566  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51567  & pygaus(pyxxz6,s12min,s12max,1d-3)
51568  idlam(lknt,1)=kfnchi(ij)
51569  idlam(lknt,2)=15
51570  idlam(lknt,3)=-15
51571  ENDIF
51572 
51573 C...NEUTRINOS
51574  150 CONTINUE
51575  fid=12
51576  xxc(5)=pmas(pycomp(ksusy1+fid),1)
51577  xxc(6)=pmas(pycomp(ksusy2+fid),1)
51578  ei=kchg(fid,1)/3d0
51579  t3i=sign(1d0,ei+1d-6)/2d0
51580  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51581  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51582  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51583  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51584  cxc(2)=-glij
51585  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51586  cxc(4)=dconjg(glij)
51587  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51588  cxc(6)=grij
51589  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51590  cxc(8)=-dconjg(grij)
51591  s12min=0d0
51592  s12max=(axmi-axmj)**2
51593  IF( xxc(5).LT.axmi ) THEN
51594  xxc(5)=1d6
51595  ENDIF
51596  IF( xxc(6).LT.axmi ) THEN
51597  xxc(6)=1d6
51598  ENDIF
51599  xxc(7)=xxc(5)
51600  xxc(8)=xxc(6)
51601 
51602  lknt=lknt+1
51603  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51604  & pygaus(pyxxz6,s12min,s12max,1d-3)
51605  idlam(lknt,1)=kfnchi(ij)
51606  idlam(lknt,2)=12
51607  idlam(lknt,3)=-12
51608  lknt=lknt+1
51609  xlam(lknt)=xlam(lknt-1)
51610  idlam(lknt,1)=kfnchi(ij)
51611  idlam(lknt,2)=14
51612  idlam(lknt,3)=-14
51613  160 CONTINUE
51614 
51615  IF(pmas(pycomp(ksusy1+16),1).NE.pmas(pycomp(ksusy1+12),1))
51616  & THEN
51617  xxc(5)=pmas(pycomp(ksusy1+16),1)
51618  IF( xxc(5).LT.axmi ) THEN
51619  xxc(5)=1d6
51620  ENDIF
51621  xxc(7)=xxc(5)
51622  lknt=lknt+1
51623  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51624  & pygaus(pyxxz6,s12min,s12max,1d-3)
51625  ELSE
51626  lknt=lknt+1
51627  xlam(lknt)=xlam(lknt-1)
51628  ENDIF
51629  idlam(lknt,1)=kfnchi(ij)
51630  idlam(lknt,2)=16
51631  idlam(lknt,3)=-16
51632 C...D-TYPE QUARKS
51633  170 CONTINUE
51634  fid=1
51635  xxc(5)=pmas(pycomp(ksusy1+fid),1)
51636  xxc(6)=pmas(pycomp(ksusy2+fid),1)
51637  ei=kchg(fid,1)/3d0
51638  t3i=sign(1d0,ei+1d-6)/2d0
51639  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51640  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51641  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51642  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51643  cxc(2)=-glij
51644  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51645  cxc(4)=dconjg(glij)
51646  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51647  cxc(6)=grij
51648  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51649  cxc(8)=-dconjg(grij)
51650  s12min=0d0
51651  s12max=(axmi-axmj)**2
51652  IF( xxc(5).LT.axmi ) THEN
51653  xxc(5)=1d6
51654  ENDIF
51655  IF( xxc(6).LT.axmi ) THEN
51656  xxc(6)=1d6
51657  ENDIF
51658  xxc(7)=xxc(5)
51659  xxc(8)=xxc(6)
51660 
51661  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
51662  lknt=lknt+1
51663  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51664  & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
51665  idlam(lknt,1)=kfnchi(ij)
51666  idlam(lknt,2)=1
51667  idlam(lknt,3)=-1
51668  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
51669  lknt=lknt+1
51670  xlam(lknt)=xlam(lknt-1)
51671  idlam(lknt,1)=kfnchi(ij)
51672  idlam(lknt,2)=3
51673  idlam(lknt,3)=-3
51674  ENDIF
51675  ENDIF
51676  180 CONTINUE
51677  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
51678  xxc(5)=pmas(pycomp(ksusy1+5),1)
51679  xxc(6)=pmas(pycomp(ksusy2+5),1)
51680  ELSE
51681  xxc(6)=pmas(pycomp(ksusy1+5),1)
51682  xxc(5)=pmas(pycomp(ksusy2+5),1)
51683  ENDIF
51684  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 190
51685  IF(xxc(5).LT.axmi) THEN
51686  xxc(5)=1d6
51687  ELSEIF(xxc(6).LT.axmi) THEN
51688  xxc(6)=1d6
51689  ENDIF
51690  xxc(7)=xxc(5)
51691  xxc(8)=xxc(6)
51692  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
51693  lknt=lknt+1
51694  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51695  & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
51696  idlam(lknt,1)=kfnchi(ij)
51697  idlam(lknt,2)=5
51698  idlam(lknt,3)=-5
51699  ENDIF
51700 
51701 C...U-TYPE QUARKS
51702  190 CONTINUE
51703  fid=2
51704  xxc(5)=pmas(pycomp(ksusy1+fid),1)
51705  xxc(6)=pmas(pycomp(ksusy2+fid),1)
51706  ei=kchg(fid,1)/3d0
51707  t3i=sign(1d0,ei+1d-6)/2d0
51708  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51709  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51710  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51711  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51712  cxc(2)=-glij
51713  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51714  cxc(4)=dconjg(glij)
51715  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51716  cxc(6)=grij
51717  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51718  cxc(8)=-dconjg(grij)
51719 
51720  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 200
51721  IF(xxc(5).LT.axmi) THEN
51722  xxc(5)=1d6
51723  ELSEIF(xxc(6).LT.axmi) THEN
51724  xxc(6)=1d6
51725  ENDIF
51726  xxc(7)=xxc(5)
51727  xxc(8)=xxc(6)
51728 
51729  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
51730  lknt=lknt+1
51731  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51732  & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
51733  idlam(lknt,1)=kfnchi(ij)
51734  idlam(lknt,2)=2
51735  idlam(lknt,3)=-2
51736  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
51737  lknt=lknt+1
51738  xlam(lknt)=xlam(lknt-1)
51739  idlam(lknt,1)=kfnchi(ij)
51740  idlam(lknt,2)=4
51741  idlam(lknt,3)=-4
51742  ENDIF
51743  ENDIF
51744  200 CONTINUE
51745  ENDIF
51746 
51747 C...CHI0_I -> CHI0_J + H0_K
51748  eh(1)=sin(alfa)
51749  eh(2)=cos(alfa)
51750  eh(3)=-sin(beta)
51751  dh(1)=cos(alfa)
51752  dh(2)=-sin(alfa)
51753  dh(3)=cos(beta)
51754  qij=zmixc(ix,3)*dconjg(zmixc(ij,2))+
51755  & dconjg(zmixc(ij,3))*zmixc(ix,2)-
51756  & tanw*(zmixc(ix,3)*dconjg(zmixc(ij,1))+
51757  & dconjg(zmixc(ij,3))*zmixc(ix,1))
51758  rij=dconjg(zmixc(ix,4))*zmixc(ij,2)+
51759  & zmixc(ij,4)*dconjg(zmixc(ix,2))-
51760  & tanw*(dconjg(zmixc(ix,4))*zmixc(ij,1)+
51761  & zmixc(ij,4)*dconjg(zmixc(ix,1)))
51762  DO 210 ih=1,3
51763  xmh=pmas(ith(ih),1)
51764  xmh2=xmh**2
51765  IF(axmi.GE.axmj+xmh) THEN
51766  lknt=lknt+1
51767  xl=pylamf(xmi2,xmj2,xmh2)
51768  f21k=0.5d0*(qij*eh(ih)+rij*dh(ih))
51769  f12k=f21k
51770 C...SIGN OF MASSES I,J
51771  xmk=xmj
51772  IF(ih.EQ.3) xmk=-xmk
51773  gx2=abs(f21k)**2+abs(f12k)**2
51774  glr=dble(f21k*dconjg(f12k))
51775  xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,gx2,glr)
51776  idlam(lknt,1)=kfnchi(ij)
51777  idlam(lknt,2)=ith(ih)
51778  idlam(lknt,3)=0
51779  ENDIF
51780  210 CONTINUE
51781  220 CONTINUE
51782 
51783 C...CHI0_I -> CHI+_J + W-
51784  DO 260 ij=1,2
51785  xmj=smw(ij)
51786  axmj=abs(xmj)
51787  xmj2=xmj**2
51788  IF(axmi.GE.axmj+xmw) THEN
51789  lknt=lknt+1
51790  cxc(1)=(dconjg(zmixc(ix,2))*vmixc(ij,1)-
51791  & dconjg(zmixc(ix,4))*vmixc(ij,2)/sr2)
51792  cxc(3)=(zmixc(ix,2)*dconjg(umixc(ij,1))+
51793  & zmixc(ix,3)*dconjg(umixc(ij,2))/sr2)
51794  gx2=abs(cxc(1))**2+abs(cxc(3))**2
51795  glr=dble(cxc(1)*dconjg(cxc(3)))
51796  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gx2,glr)
51797  idlam(lknt,1)=kfcchi(ij)
51798  idlam(lknt,2)=-24
51799  idlam(lknt,3)=0
51800  lknt=lknt+1
51801  xlam(lknt)=xlam(lknt-1)
51802  idlam(lknt,1)=-kfcchi(ij)
51803  idlam(lknt,2)=24
51804  idlam(lknt,3)=0
51805  ELSEIF(axmi.GE.axmj) THEN
51806  s12min=0d0
51807  s12max=(axmi-axmj)**2
51808  rt2i = 1d0/sqrt(2d0)
51809  cxc(1)=(dconjg(zmixc(ix,2))*vmixc(ij,1)-
51810  & dconjg(zmixc(ix,4))*vmixc(ij,2)*rt2i)*rt2i
51811  cxc(3)=(zmixc(ix,2)*dconjg(umixc(ij,1))+
51812  & zmixc(ix,3)*dconjg(umixc(ij,2))*rt2i)*rt2i
51813  cxc(5)=dcmplx(0d0,0d0)
51814  cxc(7)=dcmplx(0d0,0d0)
51815  ia=11
51816  ja=12
51817  ei=kchg(ia,1)/3d0
51818  t3i=sign(1d0,ei+1d-6)/2d0
51819  ej=kchg(ja,1)/3d0
51820  t3j=sign(1d0,ej+1d-6)/2d0
51821  cxc(2)=vmixc(ij,1)*dconjg(zmixc(ix,1)*(ej-t3j)*
51822  & tanw+zmixc(ix,2)*t3j)*rt2i
51823  cxc(4)=-dconjg(umixc(ij,1))*(
51824  & zmixc(ix,1)*(ei-t3i)*tanw+zmixc(ix,2)*t3i)*rt2i
51825  cxc(6)=dcmplx(0d0,0d0)
51826  cxc(8)=dcmplx(0d0,0d0)
51827  xxc(1)=0d0
51828  xxc(2)=xmj
51829  xxc(3)=0d0
51830  xxc(4)=xmi
51831  xxc(5)=pmas(pycomp(ksusy1+ja),1)
51832  xxc(6)=pmas(pycomp(ksusy1+ia),1)
51833  xxc(9)=pmas(24,1)
51834  xxc(10)=pmas(24,2)
51835  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 230
51836  IF(xxc(5).LT.axmi) THEN
51837  xxc(5)=1d6
51838  ELSEIF(xxc(6).LT.axmi) THEN
51839  xxc(6)=1d6
51840  ENDIF
51841  xxc(7)=xxc(6)
51842  xxc(8)=xxc(5)
51843  IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
51844  lknt=lknt+1
51845  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51846  & pygaus(pyxxz6,s12min,s12max,prec)
51847  idlam(lknt,1)=kfcchi(ij)
51848  idlam(lknt,2)=11
51849  idlam(lknt,3)=-12
51850  lknt=lknt+1
51851  xlam(lknt)=xlam(lknt-1)
51852  idlam(lknt,1)=-idlam(lknt-1,1)
51853  idlam(lknt,2)=-idlam(lknt-1,2)
51854  idlam(lknt,3)=-idlam(lknt-1,3)
51855  IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
51856  lknt=lknt+1
51857  xlam(lknt)=xlam(lknt-1)
51858  idlam(lknt,1)=kfcchi(ij)
51859  idlam(lknt,2)=13
51860  idlam(lknt,3)=-14
51861  lknt=lknt+1
51862  xlam(lknt)=xlam(lknt-1)
51863  idlam(lknt,1)=-idlam(lknt-1,1)
51864  idlam(lknt,2)=-idlam(lknt-1,2)
51865  idlam(lknt,3)=-idlam(lknt-1,3)
51866  ENDIF
51867  ENDIF
51868  230 CONTINUE
51869  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
51870  xxc(5)=pmas(pycomp(ksusy1+15),1)
51871  xxc(6)=pmas(pycomp(ksusy1+16),1)
51872  ELSE
51873  xxc(5)=pmas(pycomp(ksusy2+15),1)
51874  xxc(6)=pmas(pycomp(ksusy1+16),1)
51875  ENDIF
51876  IF(xxc(5).LT.axmi) THEN
51877  xxc(5)=1d6
51878  ENDIF
51879  IF(xxc(6).LT.axmi) THEN
51880  xxc(6)=1d6
51881  ENDIF
51882  xxc(7)=xxc(6)
51883  xxc(8)=xxc(5)
51884  IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
51885  lknt=lknt+1
51886  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51887  & pygaus(pyxxz6,s12min,s12max,prec)
51888  xlam(lknt)=xlam(lknt-1)
51889  idlam(lknt,1)=kfcchi(ij)
51890  idlam(lknt,2)=15
51891  idlam(lknt,3)=-16
51892  lknt=lknt+1
51893  xlam(lknt)=xlam(lknt-1)
51894  idlam(lknt,1)=-idlam(lknt-1,1)
51895  idlam(lknt,2)=-idlam(lknt-1,2)
51896  idlam(lknt,3)=-idlam(lknt-1,3)
51897  ENDIF
51898 
51899 C...NOW, DO THE QUARKS
51900  240 CONTINUE
51901  ia=1
51902  ja=2
51903  ei=kchg(ia,1)/3d0
51904  t3i=sign(1d0,ei+1d-6)/2d0
51905  ej=kchg(ja,1)/3d0
51906  t3j=sign(1d0,ej+1d-6)/2d0
51907  cxc(2)=vmixc(ij,1)*dconjg(zmixc(ix,1)*(ej-t3j)*
51908  & tanw+zmixc(ix,2)*t3j)
51909  cxc(4)=-dconjg(umixc(ij,1))*(
51910  & zmixc(ix,1)*(ei-t3i)*tanw+zmixc(ix,2)*t3i)
51911  xxc(5)=pmas(pycomp(ksusy1+ia),1)
51912  xxc(6)=pmas(pycomp(ksusy1+ja),1)
51913  IF(xxc(5).LT.axmi) THEN
51914  xxc(5)=1d6
51915  ENDIF
51916  IF(xxc(6).LT.axmi) THEN
51917  xxc(6)=1d6
51918  ENDIF
51919  xxc(7)=xxc(6)
51920  xxc(8)=xxc(5)
51921  IF(axmi.GE.axmj+pmas(2,1)+pmas(1,1)) THEN
51922  lknt=lknt+1
51923  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
51924  & pygaus(pyxxz6,s12min,s12max,prec)
51925  idlam(lknt,1)=kfcchi(ij)
51926  idlam(lknt,2)=1
51927  idlam(lknt,3)=-2
51928  lknt=lknt+1
51929  xlam(lknt)=xlam(lknt-1)
51930  idlam(lknt,1)=-idlam(lknt-1,1)
51931  idlam(lknt,2)=-idlam(lknt-1,2)
51932  idlam(lknt,3)=-idlam(lknt-1,3)
51933  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
51934  lknt=lknt+1
51935  xlam(lknt)=xlam(lknt-1)
51936  idlam(lknt,1)=kfcchi(ij)
51937  idlam(lknt,2)=3
51938  idlam(lknt,3)=-4
51939  lknt=lknt+1
51940  xlam(lknt)=xlam(lknt-1)
51941  idlam(lknt,1)=-idlam(lknt-1,1)
51942  idlam(lknt,2)=-idlam(lknt-1,2)
51943  idlam(lknt,3)=-idlam(lknt-1,3)
51944  ENDIF
51945  ENDIF
51946  250 CONTINUE
51947  ENDIF
51948  260 CONTINUE
51949  270 CONTINUE
51950 
51951 C...CHI0_I -> CHI+_I + H-
51952  DO 280 ij=1,2
51953  xmj=smw(ij)
51954  axmj=abs(xmj)
51955  xmj2=xmj**2
51956  xmhp=pmas(ithc,1)
51957  IF(axmi.GE.axmj+xmhp) THEN
51958  lknt=lknt+1
51959  olpp=cbeta*(zmixc(ix,4)*dconjg(vmixc(ij,1))+(zmixc(ix,2)+
51960  & zmixc(ix,1)*tanw)*dconjg(vmixc(ij,2))/sr2)
51961  orpp=sbeta*(dconjg(zmixc(ix,3))*umixc(ij,1)-
51962  & (dconjg(zmixc(ix,2))+dconjg(zmixc(ix,1))*tanw)*
51963  & umixc(ij,2)/sr2)
51964  gx2=abs(olpp)**2+abs(orpp)**2
51965  glr=dble(olpp*dconjg(orpp))
51966  xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gx2,glr)
51967  idlam(lknt,1)=kfcchi(ij)
51968  idlam(lknt,2)=-ithc
51969  idlam(lknt,3)=0
51970  lknt=lknt+1
51971  xlam(lknt)=xlam(lknt-1)
51972  idlam(lknt,1)=-idlam(lknt-1,1)
51973  idlam(lknt,2)=-idlam(lknt-1,2)
51974  idlam(lknt,3)=-idlam(lknt-1,3)
51975  ELSE
51976 
51977  ENDIF
51978  280 CONTINUE
51979 
51980 C...2-BODY DECAYS TO FERMION SFERMION
51981  DO 290 j=1,16
51982  IF(j.GE.7.AND.j.LE.10) GOTO 290
51983  kf1=ksusy1+j
51984  kf2=ksusy2+j
51985  xmsf1=pmas(pycomp(kf1),1)
51986  xmsf2=pmas(pycomp(kf2),1)
51987  xmf=pmas(j,1)
51988  IF(j.LE.6) THEN
51989  fcol=3d0
51990  ELSE
51991  fcol=1d0
51992  ENDIF
51993 
51994  ei=kchg(j,1)/3d0
51995  t3t=sign(1d0,ei)
51996  IF(j.EQ.12.OR.j.EQ.14.OR.j.EQ.16) t3t=1d0
51997  IF(mod(j,2).EQ.0) THEN
51998  cbl=t3t*zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-t3t)
51999  cal=xmf*zmixc(ix,4)/xmw/sbeta
52000  car=-2d0*ei*tanw*zmixc(ix,1)
52001  cbr=cal
52002  ELSE
52003  cbl=t3t*zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-t3t)
52004  cal=xmf*zmixc(ix,3)/xmw/cbeta
52005  car=-2d0*ei*tanw*zmixc(ix,1)
52006  cbr=cal
52007  ENDIF
52008 
52009 C...D~ D_L
52010  IF(axmi.GE.xmf+xmsf1) THEN
52011  lknt=lknt+1
52012  xma2=xmsf1**2
52013  xmb2=xmf**2
52014  xl=pylamf(xmi2,xma2,xmb2)
52015  ca=cal*sfmix(j,1)+car*sfmix(j,2)
52016  cb=cbl*sfmix(j,1)+cbr*sfmix(j,2)
52017  xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52018  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52019  idlam(lknt,1)=kf1
52020  idlam(lknt,2)=-j
52021  idlam(lknt,3)=0
52022  lknt=lknt+1
52023  xlam(lknt)=xlam(lknt-1)
52024  idlam(lknt,1)=-idlam(lknt-1,1)
52025  idlam(lknt,2)=-idlam(lknt-1,2)
52026  idlam(lknt,3)=0
52027  ENDIF
52028 
52029 C...D~ D_R
52030  IF(axmi.GE.xmf+xmsf2) THEN
52031  lknt=lknt+1
52032  xma2=xmsf2**2
52033  xmb2=xmf**2
52034  ca=cal*sfmix(j,3)+car*sfmix(j,4)
52035  cb=cbl*sfmix(j,3)+cbr*sfmix(j,4)
52036  xl=pylamf(xmi2,xma2,xmb2)
52037  xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52038  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52039  idlam(lknt,1)=kf2
52040  idlam(lknt,2)=-j
52041  idlam(lknt,3)=0
52042  lknt=lknt+1
52043  xlam(lknt)=xlam(lknt-1)
52044  idlam(lknt,1)=-idlam(lknt-1,1)
52045  idlam(lknt,2)=-idlam(lknt-1,2)
52046  idlam(lknt,3)=0
52047  ENDIF
52048  290 CONTINUE
52049  300 CONTINUE
52050 C...3-BODY DECAY TO Q Q~ GLUINO
52051  xmj=pmas(pycomp(ksusy1+21),1)
52052  IF(axmi.GE.xmj) THEN
52053  rt2i = 1d0/sqrt(2d0)
52054  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))*rt2i
52055  orpp=dconjg(olpp)
52056  axmj=abs(xmj)
52057  xxc(1)=0d0
52058  xxc(2)=xmj
52059  xxc(3)=0d0
52060  xxc(4)=xmi
52061  fid=1
52062  xxc(5)=pmas(pycomp(ksusy1+fid),1)
52063  xxc(6)=pmas(pycomp(ksusy2+fid),1)
52064  xxc(7)=xxc(5)
52065  xxc(8)=xxc(6)
52066  xxc(9)=1d6
52067  xxc(10)=0d0
52068  ei=kchg(fid,1)/3d0
52069  t3i=sign(1d0,ei+1d-6)/2d0
52070  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
52071  grij=zmixc(ix,1)*(ei*tanw)*orpp
52072  cxc(1)=0d0
52073  cxc(2)=-glij
52074  cxc(3)=0d0
52075  cxc(4)=dconjg(glij)
52076  cxc(5)=0d0
52077  cxc(6)=grij
52078  cxc(7)=0d0
52079  cxc(8)=-dconjg(grij)
52080  s12min=0d0
52081  s12max=(axmi-axmj)**2
52082 CMRENNA.This statement must be here to define S12MAX
52083  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 310
52084 C...ALL QUARKS BUT T
52085  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
52086  lknt=lknt+1
52087  xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
52088  & pygaus(pyxxz6,s12min,s12max,1d-3)
52089  idlam(lknt,1)=ksusy1+21
52090  idlam(lknt,2)=1
52091  idlam(lknt,3)=-1
52092  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
52093  lknt=lknt+1
52094  xlam(lknt)=xlam(lknt-1)
52095  idlam(lknt,1)=ksusy1+21
52096  idlam(lknt,2)=3
52097  idlam(lknt,3)=-3
52098  ENDIF
52099  ENDIF
52100  310 CONTINUE
52101  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
52102  xxc(5)=pmas(pycomp(ksusy1+5),1)
52103  xxc(6)=pmas(pycomp(ksusy2+5),1)
52104  ELSE
52105  xxc(6)=pmas(pycomp(ksusy1+5),1)
52106  xxc(5)=pmas(pycomp(ksusy2+5),1)
52107  ENDIF
52108  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 320
52109  xxc(7)=xxc(5)
52110  xxc(8)=xxc(6)
52111  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
52112  lknt=lknt+1
52113  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
52114  & pygaus(pyxxz6,s12min,s12max,1d-3)
52115  idlam(lknt,1)=ksusy1+21
52116  idlam(lknt,2)=5
52117  idlam(lknt,3)=-5
52118  ENDIF
52119 C...U-TYPE QUARKS
52120  320 CONTINUE
52121  fid=2
52122  xxc(5)=pmas(pycomp(ksusy1+fid),1)
52123  xxc(6)=pmas(pycomp(ksusy2+fid),1)
52124  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 330
52125  xxc(7)=xxc(5)
52126  xxc(8)=xxc(6)
52127  ei=kchg(fid,1)/3d0
52128  t3i=sign(1d0,ei+1d-6)/2d0
52129  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
52130  grij=zmixc(ix,1)*(ei*tanw)*orpp
52131  cxc(2)=-glij
52132  cxc(4)=dconjg(glij)
52133  cxc(6)=grij
52134  cxc(8)=-dconjg(grij)
52135  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
52136  lknt=lknt+1
52137  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
52138  & pygaus(pyxxz6,s12min,s12max,1d-3)
52139  idlam(lknt,1)=ksusy1+21
52140  idlam(lknt,2)=2
52141  idlam(lknt,3)=-2
52142  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
52143  lknt=lknt+1
52144  xlam(lknt)=xlam(lknt-1)
52145  idlam(lknt,1)=ksusy1+21
52146  idlam(lknt,2)=4
52147  idlam(lknt,3)=-4
52148  ENDIF
52149  ENDIF
52150  330 CONTINUE
52151  ENDIF
52152 
52153 C...R-violating decay modes (SKANDS).
52154  CALL pyrvne(kfin,xlam,idlam,lknt)
52155 
52156  340 iknt=lknt
52157  xlam(0)=0d0
52158  DO 350 i=1,iknt
52159  IF(xlam(i).LT.0d0) xlam(i)=0d0
52160  xlam(0)=xlam(0)+xlam(i)
52161  350 CONTINUE
52162  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
52163 
52164  RETURN
52165  END
52166 
52167 C*********************************************************************
52168 
52169 C...PYCJDC
52170 C...Calculate decay widths for the charginos (admixtures of
52171 C...charged Wino and charged Higgsino.
52172 
52173 C...Input: KCIN = KF code for particle
52174 C...Output: XLAM = widths
52175 C... IDLAM = KF codes for decay particles
52176 C... IKNT = number of decay channels defined
52177 C...AUTHOR: STEPHEN MRENNA
52178 C...Last change:
52179 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52180 C...when CHIENU .NE. 0
52181 
52182  SUBROUTINE pycjdc(KFIN,XLAM,IDLAM,IKNT)
52183 
52184 C...Double precision and integer declarations.
52185  IMPLICIT DOUBLE PRECISION(a-h, o-z)
52186  IMPLICIT INTEGER(I-N)
52187  INTEGER PYK,PYCHGE,PYCOMP
52188 C...Parameter statement to help give large particle numbers.
52189  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
52190  &kexcit=4000000,kdimen=5000000)
52191 C...Commonblocks.
52192  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
52193  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
52194  common/pymssm/imss(0:99),rmss(0:99)
52195  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
52196  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
52197 CC &SFMIX(16,4),
52198 C COMMON/PYINTS/XXM(20)
52199  COMPLEX*16 CXC
52200  COMMON/PYINTC/XXC(10),CXC(8)
52201  SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52202 
52203 C...Local variables
52204  COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52205  COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52206  INTEGER KFIN,KCIN
52207  DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52208  &xmz,xmz2,axmj,axmi
52209  DOUBLE PRECISION S12MIN,S12MAX
52210  DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52211  DOUBLE PRECISION PYLAMF,XL
52212  DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52213  DOUBLE PRECISION PYX2XH,PYX2XG
52214  DOUBLE PRECISION XLAM(0:400)
52215  INTEGER IDLAM(400,3)
52216  INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52217  INTEGER ITH(3)
52218  INTEGER ITHC
52219  DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52220  DOUBLE PRECISION SR2
52221  DOUBLE PRECISION CBETA,SBETA,TANB
52222 
52223  DOUBLE PRECISION PYALEM,PI,PYALPS
52224  DOUBLE PRECISION FCOL
52225  INTEGER KF1,KF2,ISF
52226  INTEGER KFNCHI(4),KFCCHI(2)
52227 
52228  DOUBLE PRECISION TEMP
52229  EXTERNAL pygaus,pyxxz6
52230  DOUBLE PRECISION PYGAUS,PYXXZ6
52231  DOUBLE PRECISION PREC
52232  DATA ith/25,35,36/
52233  DATA ithc/37/
52234  DATA etah/1d0,1d0,-1d0/
52235  DATA sr2/1.4142136d0/
52236  DATA pi/3.141592654d0/
52237  DATA prec/1d-2/
52238  DATA kfnchi/1000022,1000023,1000025,1000035/
52239  DATA kfcchi/1000024,1000037/
52240 
52241 C...COUNT THE NUMBER OF DECAY MODES
52242  lknt=0
52243  xmw=pmas(24,1)
52244  xmw2=xmw**2
52245  xmz=pmas(23,1)
52246  xmz2=xmz**2
52247  xw=1d0-xmw2/xmz2
52248  xw1=1d0-xw
52249  tanw = sqrt(xw/xw1)
52250 
52251 C...1 OR 2 DEPENDING ON CHARGINO TYPE
52252  ix=1
52253  IF(kfin.EQ.kfcchi(2)) ix=2
52254  kcin=pycomp(kfin)
52255 
52256  xmi=smw(ix)
52257  xmi2=xmi**2
52258  axmi=abs(xmi)
52259  aem=pyalem(xmi2)
52260  as =pyalps(xmi2)
52261  c1=aem/xw
52262  xmi3=abs(xmi**3)
52263  tanb=rmss(5)
52264  beta=atan(tanb)
52265  cbeta=cos(beta)
52266  sbeta=tanb*cbeta
52267  alfa=rmss(18)
52268 
52269  DO 110 i=1,2
52270  DO 100 j=1,2
52271  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
52272  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
52273  100 CONTINUE
52274  110 CONTINUE
52275 
52276 C...GRAVITINO DECAY MODES
52277 
52278  IF(imss(11).EQ.1) THEN
52279  xmp=rmss(29)
52280  idg=39+ksusy1
52281  xmgr=pmas(pycomp(idg),1)
52282 C SINW=SQRT(XW)
52283 C COSW=SQRT(1D0-XW)
52284  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
52285  IF(axmi.GT.xmgr+xmw) THEN
52286  lknt=lknt+1
52287  idlam(lknt,1)=idg
52288  idlam(lknt,2)=24
52289  idlam(lknt,3)=0
52290  xlam(lknt)=xfac*(
52291  & .5d0*(abs(vmixc(ix,1))**2+abs(umixc(ix,1))**2)+
52292  & .5d0*((abs(vmixc(ix,2))*sbeta)**2+(abs(umixc(ix,2))*cbeta)**2))*
52293  & (1d0-xmw2/xmi2)**4
52294  ENDIF
52295  IF(axmi.GT.xmgr+pmas(37,1)) THEN
52296  lknt=lknt+1
52297  idlam(lknt,1)=idg
52298  idlam(lknt,2)=37
52299  idlam(lknt,3)=0
52300  xlam(lknt)=xfac*(.5d0*((abs(vmixc(ix,2))*cbeta)**2+
52301  & (abs(umixc(ix,2))*sbeta)**2))
52302  & *(1d0-pmas(37,1)**2/xmi2)**4
52303  ENDIF
52304  ENDIF
52305 
52306 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52307  IF(ix.EQ.1) GOTO 170
52308  xmj=smw(1)
52309  axmj=abs(xmj)
52310  xmj2=xmj**2
52311 
52312 C...CHI_2+ -> CHI_1+ + Z0
52313  IF(axmi.GE.axmj+xmz) THEN
52314  lknt=lknt+1
52315  ij=1
52316  olpp=-vmixc(ij,1)*dconjg(vmixc(ix,1))-
52317  & vmixc(ij,2)*dconjg(vmixc(ix,2))/2d0
52318  orpp=-umixc(ix,1)*dconjg(umixc(ij,1))-
52319  & umixc(ix,2)*dconjg(umixc(ij,2))/2d0
52320  gx2=abs(olpp)**2+abs(orpp)**2
52321  glr=dble(olpp*dconjg(orpp))
52322  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gx2,glr)
52323  idlam(lknt,1)=kfcchi(1)
52324  idlam(lknt,2)=23
52325  idlam(lknt,3)=0
52326 
52327 C...CHARGED LEPTONS
52328  ELSEIF(axmi.GE.axmj) THEN
52329  s12min=0d0
52330  s12max=(axmi-axmj)**2
52331  ia=11
52332  ja=12
52333  ei=kchg(iabs(ia),1)/3d0
52334  t3i=sign(1d0,ei+1d-6)/2d0
52335  xxc(1)=0d0
52336  xxc(2)=xmj
52337  xxc(3)=0d0
52338  xxc(4)=xmi
52339  xxc(5)=pmas(pycomp(ksusy1+ja),1)
52340  xxc(6)=1d6
52341  xxc(9)=pmas(23,1)
52342  xxc(10)=pmas(23,2)
52343  ij=1
52344  olpp=-vmixc(ij,1)*dconjg(vmixc(ix,1))-
52345  & vmixc(ij,2)*dconjg(vmixc(ix,2))/2d0
52346  orpp=-umixc(ix,1)*dconjg(umixc(ij,1))-
52347  & umixc(ix,2)*dconjg(umixc(ij,2))/2d0
52348  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52349  cxc(2)=dcmplx(0d0,0d0)
52350  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52351  cxc(4)=-vmixc(ij,1)*dconjg(vmixc(ix,1))*dcmplx(t3i/xw)
52352  cxc(5)=-dcmplx(ei/xw1)*orpp
52353  cxc(6)=dcmplx(0d0,0d0)
52354  cxc(7)=-dcmplx(ei/xw1)*olpp
52355  cxc(8)=dcmplx(0d0,0d0)
52356  IF( xxc(5).LT.axmi ) THEN
52357  xxc(5)=1d6
52358  ENDIF
52359  xxc(7)=xxc(5)
52360  xxc(8)=xxc(6)
52361  IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
52362  lknt=lknt+1
52363  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52364  & pygaus(pyxxz6,s12min,s12max,prec)
52365  idlam(lknt,1)=kfcchi(1)
52366  idlam(lknt,2)=11
52367  idlam(lknt,3)=-11
52368  IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
52369  lknt=lknt+1
52370  xlam(lknt)=xlam(lknt-1)
52371  idlam(lknt,1)=kfcchi(1)
52372  idlam(lknt,2)=13
52373  idlam(lknt,3)=-13
52374  ENDIF
52375  IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
52376  lknt=lknt+1
52377  xlam(lknt)=xlam(lknt-1)
52378  idlam(lknt,1)=kfcchi(1)
52379  idlam(lknt,2)=15
52380  idlam(lknt,3)=-15
52381  ENDIF
52382  ENDIF
52383 
52384 C...NEUTRINOS
52385  120 CONTINUE
52386  ia=12
52387  ja=11
52388  ei=kchg(iabs(ia),1)/3d0
52389  t3i=sign(1d0,ei+1d-6)/2d0
52390  xxc(5)=pmas(pycomp(ksusy1+ja),1)
52391  xxc(6)=1d6
52392  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52393  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52394  cxc(4)=-umixc(ij,1)*dconjg(umixc(ix,1))*dcmplx(t3i/xw)
52395  cxc(5)=-dcmplx(ei/xw1)*orpp
52396  cxc(7)=-dcmplx(ei/xw1)*olpp
52397  IF( xxc(5).LT.axmi ) THEN
52398  xxc(5)=1d6
52399  ENDIF
52400  xxc(7)=xxc(5)
52401  xxc(8)=xxc(6)
52402  IF(axmi.GE.axmj+2d0*pmas(12,1)) THEN
52403  lknt=lknt+1
52404  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52405  & pygaus(pyxxz6,s12min,s12max,prec)
52406  idlam(lknt,1)=kfcchi(1)
52407  idlam(lknt,2)=12
52408  idlam(lknt,3)=-12
52409  lknt=lknt+1
52410  xlam(lknt)=xlam(lknt-1)
52411  idlam(lknt,1)=kfcchi(1)
52412  idlam(lknt,2)=14
52413  idlam(lknt,3)=-14
52414  ENDIF
52415  IF(axmi.GE.axmj+2d0*pmas(16,1)) THEN
52416  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
52417  xxc(5)=pmas(pycomp(ksusy1+15),1)
52418  ELSE
52419  xxc(5)=pmas(pycomp(ksusy2+15),1)
52420  ENDIF
52421  IF( xxc(5).LT.axmi ) THEN
52422  xxc(5)=1d6
52423  ENDIF
52424  xxc(7)=xxc(5)
52425  lknt=lknt+1
52426  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52427  & pygaus(pyxxz6,s12min,s12max,prec)
52428  idlam(lknt,1)=kfcchi(1)
52429  idlam(lknt,2)=16
52430  idlam(lknt,3)=-16
52431  ENDIF
52432 
52433 C...D-TYPE QUARKS
52434  130 CONTINUE
52435  ia=1
52436  ja=2
52437  ei=kchg(iabs(ia),1)/3d0
52438  t3i=sign(1d0,ei+1d-6)/2d0
52439  xxc(5)=pmas(pycomp(ksusy1+ja),1)
52440  xxc(6)=1d6
52441  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52442  cxc(2)=dcmplx(0d0,0d0)
52443  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52444  cxc(4)=-vmixc(ij,1)*dconjg(vmixc(ix,1))*dcmplx(t3i/xw)
52445  cxc(5)=-dcmplx(ei/xw1)*orpp
52446  cxc(6)=dcmplx(0d0,0d0)
52447  cxc(7)=-dcmplx(ei/xw1)*olpp
52448  cxc(8)=dcmplx(0d0,0d0)
52449  IF( xxc(5).LT.axmi ) THEN
52450  xxc(5)=1d6
52451  ENDIF
52452  xxc(7)=xxc(5)
52453  xxc(8)=xxc(6)
52454  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
52455  lknt=lknt+1
52456  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52457  & pygaus(pyxxz6,s12min,s12max,prec)
52458  idlam(lknt,1)=kfcchi(1)
52459  idlam(lknt,2)=1
52460  idlam(lknt,3)=-1
52461  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
52462  lknt=lknt+1
52463  xlam(lknt)=xlam(lknt-1)
52464  idlam(lknt,1)=kfcchi(1)
52465  idlam(lknt,2)=3
52466  idlam(lknt,3)=-3
52467  ENDIF
52468  ENDIF
52469  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
52470  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
52471  xxc(5)=pmas(pycomp(ksusy1+5),1)
52472  ELSE
52473  xxc(5)=pmas(pycomp(ksusy2+5),1)
52474  ENDIF
52475  IF( xxc(5).LT.axmi ) THEN
52476  xxc(5)=1d6
52477  ENDIF
52478  xxc(7)=xxc(5)
52479  lknt=lknt+1
52480  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52481  & pygaus(pyxxz6,s12min,s12max,prec)
52482  idlam(lknt,1)=kfcchi(1)
52483  idlam(lknt,2)=5
52484  idlam(lknt,3)=-5
52485  ENDIF
52486 
52487 C...U-TYPE QUARKS
52488  140 CONTINUE
52489  ia=2
52490  ja=1
52491  ei=kchg(iabs(ia),1)/3d0
52492  t3i=sign(1d0,ei+1d-6)/2d0
52493  xxc(5)=pmas(pycomp(ksusy1+ja),1)
52494  xxc(6)=1d6
52495  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52496  cxc(2)=dcmplx(0d0,0d0)
52497  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52498  cxc(4)=-umixc(ij,1)*dconjg(umixc(ix,1))*dcmplx(t3i/xw)
52499  cxc(5)=-dcmplx(ei/xw1)*orpp
52500  cxc(6)=dcmplx(0d0,0d0)
52501  cxc(7)=-dcmplx(ei/xw1)*olpp
52502  cxc(8)=dcmplx(0d0,0d0)
52503  IF( xxc(5).LT.axmi ) THEN
52504  xxc(5)=1d6
52505  ENDIF
52506  xxc(7)=xxc(5)
52507  xxc(8)=xxc(6)
52508  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
52509  lknt=lknt+1
52510  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52511  & pygaus(pyxxz6,s12min,s12max,prec)
52512  idlam(lknt,1)=kfcchi(1)
52513  idlam(lknt,2)=2
52514  idlam(lknt,3)=-2
52515  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
52516  lknt=lknt+1
52517  xlam(lknt)=xlam(lknt-1)
52518  idlam(lknt,1)=kfcchi(1)
52519  idlam(lknt,2)=4
52520  idlam(lknt,3)=-4
52521  ENDIF
52522  ENDIF
52523  150 CONTINUE
52524  ENDIF
52525 
52526 C...CHI_2+ -> CHI_1+ + H0_K
52527  eh(2)=cos(alfa)
52528  eh(1)=sin(alfa)
52529  eh(3)=-sbeta
52530  dh(2)=-sin(alfa)
52531  dh(1)=cos(alfa)
52532  dh(3)=cos(beta)
52533  DO 160 ih=1,3
52534  xmh=pmas(ith(ih),1)
52535  xmh2=xmh**2
52536 C...NO 3-BODY OPTION
52537  IF(axmi.GE.axmj+xmh) THEN
52538  lknt=lknt+1
52539  xl=pylamf(xmi2,xmj2,xmh2)
52540  olpp=(vmixc(2,1)*dconjg(umixc(1,2))*eh(ih) -
52541  & vmixc(2,2)*dconjg(umixc(1,1))*dh(ih))/sr2
52542  orpp=(dconjg(vmixc(1,1))*umixc(2,2)*eh(ih) -
52543  & dconjg(vmixc(1,2))*umixc(2,1)*dh(ih))/sr2
52544  xmk=xmj*etah(ih)
52545  gx2=abs(olpp)**2+abs(orpp)**2
52546  glr=dble(olpp*dconjg(orpp))
52547  xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,gx2,glr)
52548  idlam(lknt,1)=kfcchi(1)
52549  idlam(lknt,2)=ith(ih)
52550  idlam(lknt,3)=0
52551  ENDIF
52552  160 CONTINUE
52553 
52554 C...CHI1 JUMPS TO HERE
52555  170 CONTINUE
52556 
52557 C...CHI+_I -> CHI0_J + W+
52558  DO 220 ij=1,4
52559  xmj=smz(ij)
52560  axmj=abs(xmj)
52561  xmj2=xmj**2
52562  IF(axmi.GE.axmj+xmw) THEN
52563  lknt=lknt+1
52564  DO 180 i=1,4
52565  zmixc(ij,i)=dcmplx(zmix(ij,i),zmixi(ij,i))
52566  180 CONTINUE
52567  cxc(1)=(dconjg(zmixc(ij,2))*vmixc(ix,1)-
52568  & dconjg(zmixc(ij,4))*vmixc(ix,2)/sr2)
52569  cxc(3)=(zmixc(ij,2)*dconjg(umixc(ix,1))+
52570  & zmixc(ij,3)*dconjg(umixc(ix,2))/sr2)
52571  gx2=abs(cxc(1))**2+abs(cxc(3))**2
52572  glr=dble(cxc(1)*dconjg(cxc(3)))
52573  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gx2,glr)
52574  idlam(lknt,1)=kfnchi(ij)
52575  idlam(lknt,2)=24
52576  idlam(lknt,3)=0
52577 C...LEPTONS
52578  ELSEIF(axmi.GE.axmj) THEN
52579  s12min=0d0
52580  s12max=(axmi-axmj)**2
52581  DO 190 i=1,4
52582  zmixc(ij,i)=dcmplx(zmix(ij,i),zmixi(ij,i))
52583  190 CONTINUE
52584  cxc(1)=(dconjg(zmixc(ij,2))*vmixc(ix,1)-
52585  & dconjg(zmixc(ij,4))*vmixc(ix,2)/sr2)/sr2
52586  cxc(3)=(zmixc(ij,2)*dconjg(umixc(ix,1))+
52587  & zmixc(ij,3)*dconjg(umixc(ix,2))/sr2)/sr2
52588  cxc(5)=dcmplx(0d0,0d0)
52589  cxc(7)=dcmplx(0d0,0d0)
52590  ia=11
52591  ja=12
52592  ei=kchg(ia,1)/3d0
52593  t3i=sign(1d0,ei+1d-6)/2d0
52594  ej=kchg(ja,1)/3d0
52595  t3j=sign(1d0,ej+1d-6)/2d0
52596  cxc(2)=vmixc(ix,1)*dconjg(zmixc(ij,1)*(ej-t3j)*
52597  & tanw+zmixc(ij,2)*t3j)/sr2
52598  cxc(4)=-dconjg(umixc(ix,1))*(
52599  & zmixc(ij,1)*(ei-t3i)*tanw+zmixc(ij,2)*t3i)/sr2
52600  cxc(6)=dcmplx(0d0,0d0)
52601  cxc(8)=dcmplx(0d0,0d0)
52602  xxc(1)=0d0
52603  xxc(2)=xmj
52604  xxc(3)=0d0
52605  xxc(4)=xmi
52606  xxc(5)=pmas(pycomp(ksusy1+ja),1)
52607  xxc(6)=pmas(pycomp(ksusy1+ia),1)
52608  xxc(9)=pmas(24,1)
52609  xxc(10)=pmas(24,2)
52610 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52611  IF(xxc(5).LT.axmi) THEN
52612  xxc(5)=1d6
52613  ELSEIF(xxc(6).LT.axmi) THEN
52614  xxc(6)=1d6
52615  ENDIF
52616  xxc(7)=xxc(6)
52617  xxc(8)=xxc(5)
52618 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52619 C...--> 1/(16PI)/M**3*(AEM/XW)**2
52620  IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
52621  lknt=lknt+1
52622  temp=pygaus(pyxxz6,s12min,s12max,prec)
52623  xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
52624  idlam(lknt,1)=kfnchi(ij)
52625  idlam(lknt,2)=-11
52626  idlam(lknt,3)=12
52627 C...ONLY DECAY CHI+1 -> E+ NU_E
52628  IF( imss(12).NE. 0 ) GOTO 260
52629  IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
52630  lknt=lknt+1
52631  xlam(lknt)=xlam(lknt-1)
52632  idlam(lknt,1)=kfnchi(ij)
52633  idlam(lknt,2)=-13
52634  idlam(lknt,3)=14
52635  ENDIF
52636  ENDIF
52637  IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
52638  lknt=lknt+1
52639  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
52640  xxc(6)=pmas(pycomp(ksusy1+15),1)
52641  ELSE
52642  xxc(6)=pmas(pycomp(ksusy2+15),1)
52643  ENDIF
52644  xxc(5)=pmas(pycomp(ksusy1+16),1)
52645  IF(xxc(5).LT.axmi) THEN
52646  xxc(5)=1d6
52647  ELSEIF(xxc(6).LT.axmi) THEN
52648  xxc(6)=1d6
52649  ENDIF
52650  xxc(7)=xxc(6)
52651  xxc(8)=xxc(5)
52652  temp=pygaus(pyxxz6,s12min,s12max,prec)
52653  xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
52654  idlam(lknt,1)=kfnchi(ij)
52655  idlam(lknt,2)=-15
52656  idlam(lknt,3)=16
52657  ENDIF
52658 
52659 C...NOW, DO THE QUARKS
52660  200 CONTINUE
52661  ia=1
52662  ja=2
52663  ei=kchg(ia,1)/3d0
52664  t3i=sign(1d0,ei+1d-6)/2d0
52665  ej=kchg(ja,1)/3d0
52666  t3j=sign(1d0,ej+1d-6)/2d0
52667  cxc(2)=vmixc(ix,1)*dconjg(zmixc(ij,1)*(ej-t3j)*
52668  & tanw+zmixc(ij,2)*t3j)
52669  cxc(4)=-dconjg(umixc(ix,1))*(
52670  & zmixc(ij,1)*(ei-t3i)*tanw+zmixc(ij,2)*t3i)
52671  xxc(5)=pmas(pycomp(ksusy1+ja),1)
52672  xxc(6)=pmas(pycomp(ksusy1+ia),1)
52673  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 210
52674  IF(xxc(5).LT.axmi) THEN
52675  xxc(5)=1d6
52676  ENDIF
52677  IF(xxc(6).LT.axmi) THEN
52678  xxc(6)=1d6
52679  ENDIF
52680  xxc(7)=xxc(6)
52681  xxc(8)=xxc(5)
52682  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
52683  lknt=lknt+1
52684  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52685  & pygaus(pyxxz6,s12min,s12max,prec)
52686  idlam(lknt,1)=kfnchi(ij)
52687  idlam(lknt,2)=-1
52688  idlam(lknt,3)=2
52689  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
52690  lknt=lknt+1
52691  xlam(lknt)=xlam(lknt-1)
52692  idlam(lknt,1)=kfnchi(ij)
52693  idlam(lknt,2)=-3
52694  idlam(lknt,3)=4
52695  ENDIF
52696  ENDIF
52697  210 CONTINUE
52698  ENDIF
52699  220 CONTINUE
52700 
52701 C...CHI+_I -> CHI0_J + H+
52702  DO 230 ij=1,4
52703  xmj=smz(ij)
52704  axmj=abs(xmj)
52705  xmj2=xmj**2
52706  xmhp=pmas(ithc,1)
52707  IF(axmi.GE.axmj+xmhp) THEN
52708  lknt=lknt+1
52709  olpp=cbeta*(zmixc(ij,4)*dconjg(vmixc(ix,1))+(zmixc(ij,2)+
52710  & zmixc(ij,1)*tanw)*dconjg(vmixc(ix,2))/sr2)
52711  orpp=sbeta*(dconjg(zmixc(ij,3))*umixc(ix,1)-
52712  & (dconjg(zmixc(ij,2))+dconjg(zmixc(ij,1))*tanw)*
52713  & umixc(ix,2)/sr2)
52714  gx2=abs(olpp)**2+abs(orpp)**2
52715  glr=dble(olpp*dconjg(orpp))
52716  xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gx2,glr)
52717  idlam(lknt,1)=kfnchi(ij)
52718  idlam(lknt,2)=ithc
52719  idlam(lknt,3)=0
52720  ELSE
52721 
52722  ENDIF
52723  230 CONTINUE
52724 
52725 C...2-BODY DECAYS TO FERMION SFERMION
52726  DO 240 j=1,16
52727  IF(j.GE.7.AND.j.LE.10) GOTO 240
52728  IF(mod(j,2).EQ.0) THEN
52729  kf1=ksusy1+j-1
52730  ELSE
52731  kf1=ksusy1+j+1
52732  ENDIF
52733  kf2=kf1+ksusy1
52734  xmsf1=pmas(pycomp(kf1),1)
52735  xmsf2=pmas(pycomp(kf2),1)
52736  xmf=pmas(j,1)
52737  IF(j.LE.6) THEN
52738  fcol=3d0
52739  ELSE
52740  fcol=1d0
52741  ENDIF
52742 
52743 C...U~ D_L
52744  IF(mod(j,2).EQ.0) THEN
52745  xmfp=pmas(j-1,1)
52746  cal=umixc(ix,1)
52747  cbl=-xmf*vmixc(ix,2)/xmw/sbeta/sr2
52748  car=-xmfp*umixc(ix,2)/xmw/cbeta/sr2
52749  cbr=0d0
52750  isf=j-1
52751  ELSE
52752  xmfp=pmas(j+1,1)
52753  cal=vmixc(ix,1)
52754  cbl=-xmf*umixc(ix,2)/xmw/cbeta/sr2
52755  cbr=0d0
52756  car=-xmfp*vmixc(ix,2)/xmw/sbeta/sr2
52757  isf=j+1
52758  ENDIF
52759 
52760 C...~U_L D
52761  IF(axmi.GE.xmf+xmsf1) THEN
52762  lknt=lknt+1
52763  xma2=xmsf1**2
52764  xmb2=xmf**2
52765  xl=pylamf(xmi2,xma2,xmb2)
52766  ca=cal*sfmix(isf,1)+car*sfmix(isf,2)
52767  cb=cbl*sfmix(isf,1)+cbr*sfmix(isf,2)
52768  xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52769  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52770  idlam(lknt,3)=0
52771  IF(mod(j,2).EQ.0) THEN
52772  idlam(lknt,1)=-kf1
52773  idlam(lknt,2)=j
52774  ELSE
52775  idlam(lknt,1)=kf1
52776  idlam(lknt,2)=-j
52777  ENDIF
52778  ENDIF
52779 
52780 C...U~ D_R
52781  IF(axmi.GE.xmf+xmsf2) THEN
52782  lknt=lknt+1
52783  xma2=xmsf2**2
52784  xmb2=xmf**2
52785  ca=cal*sfmix(isf,3)+car*sfmix(isf,4)
52786  cb=cbl*sfmix(isf,3)+cbr*sfmix(isf,4)
52787  xl=pylamf(xmi2,xma2,xmb2)
52788  xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52789  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52790  idlam(lknt,3)=0
52791  IF(mod(j,2).EQ.0) THEN
52792  idlam(lknt,1)=-kf2
52793  idlam(lknt,2)=j
52794  ELSE
52795  idlam(lknt,1)=kf2
52796  idlam(lknt,2)=-j
52797  ENDIF
52798  ENDIF
52799  240 CONTINUE
52800 
52801 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52802 C...A 2-BODY -- 2-BODY CHAIN
52803  xmj=pmas(pycomp(ksusy1+21),1)
52804  IF(axmi.GE.xmj) THEN
52805  axmj=abs(xmj)
52806  s12min=0d0
52807  s12max=(axmi-axmj)**2
52808  xxc(1)=0d0
52809  xxc(2)=xmj
52810  xxc(3)=0d0
52811  xxc(4)=xmi
52812  xxc(5)=pmas(pycomp(ksusy1+1),1)
52813  xxc(6)=pmas(pycomp(ksusy1+2),1)
52814  xxc(9)=1d6
52815  xxc(10)=0d0
52816  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))
52817  orpp=dconjg(olpp)
52818  cxc(1)=dcmplx(0d0,0d0)
52819  cxc(3)=dcmplx(0d0,0d0)
52820  cxc(5)=dcmplx(0d0,0d0)
52821  cxc(7)=dcmplx(0d0,0d0)
52822  cxc(2)=umixc(ix,1)*olpp/sr2
52823  cxc(4)=-dconjg(vmixc(ix,1))*orpp/sr2
52824  cxc(6)=dcmplx(0d0,0d0)
52825  cxc(8)=dcmplx(0d0,0d0)
52826  IF(xxc(5).LT.axmi) THEN
52827  xxc(5)=1d6
52828  ELSEIF(xxc(6).LT.axmi) THEN
52829  xxc(6)=1d6
52830  ENDIF
52831  xxc(7)=xxc(6)
52832  xxc(8)=xxc(5)
52833  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 250
52834  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
52835  lknt=lknt+1
52836  xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
52837  & pygaus(pyxxz6,s12min,s12max,prec)
52838  idlam(lknt,1)=ksusy1+21
52839  idlam(lknt,2)=-1
52840  idlam(lknt,3)=2
52841  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
52842  lknt=lknt+1
52843  xlam(lknt)=xlam(lknt-1)
52844  idlam(lknt,1)=ksusy1+21
52845  idlam(lknt,2)=-3
52846  idlam(lknt,3)=4
52847  ENDIF
52848  ENDIF
52849  250 CONTINUE
52850  ENDIF
52851 
52852 C...R-violating decay modes (SKANDS).
52853  CALL pyrvch(kfin,xlam,idlam,lknt)
52854 
52855  260 iknt=lknt
52856  xlam(0)=0d0
52857  DO 270 i=1,iknt
52858  xlam(0)=xlam(0)+xlam(i)
52859  IF(xlam(i).LT.0d0) THEN
52860  WRITE(mstu(11),*) ' XLAM(I) = ',xlam(i),kcin,
52861  & (idlam(i,j),j=1,3)
52862  xlam(i)=0d0
52863  ENDIF
52864  270 CONTINUE
52865  IF(xlam(0).EQ.0d0) THEN
52866  xlam(0)=1d-6
52867  WRITE(mstu(11),*) ' XLAM(0) = ',xlam(0)
52868  WRITE(mstu(11),*) lknt
52869  WRITE(mstu(11),*) (xlam(j),j=1,lknt)
52870  ENDIF
52871 
52872  RETURN
52873  END
52874 
52875 C*********************************************************************
52876 
52877 C...PYXXZ6
52878 C...Used in the calculation of inoi -> inoj + f + ~f.
52879 
52880  FUNCTION pyxxz6(X)
52881 
52882 C...Double precision and integer declarations.
52883  IMPLICIT DOUBLE PRECISION(a-h, o-z)
52884  IMPLICIT INTEGER(I-N)
52885  INTEGER PYK,PYCHGE,PYCOMP
52886 C...Parameter statement to help give large particle numbers.
52887  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
52888  &kexcit=4000000,kdimen=5000000)
52889 C...Commonblocks.
52890  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
52891 C COMMON/PYINTS/XXM(20)
52892  COMPLEX*16 CXC
52893  COMMON/PYINTC/XXC(10),CXC(8)
52894  SAVE /pydat1/,/pyintc/
52895 
52896 C...Local variables.
52897  COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
52898  DOUBLE PRECISION PYXXZ6,X
52899  DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
52900  DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
52901  DOUBLE PRECISION SIJ
52902  DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
52903  DOUBLE PRECISION OL2
52904  DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
52905  INTEGER I
52906 
52907 C...Statement functions.
52908 C...Integral from x to y of (t-a)(b-t) dt.
52909  tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
52910 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
52911  tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
52912  &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
52913 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
52914  tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
52915  &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
52916 C...Integral from x to y of (t-a)/(b-t) dt.
52917  utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)
52918 C...Integral from x to y of 1/(t-a) dt.
52919  tprop(x,y,a)=log(abs((x-a)/(y-a)))
52920 
52921  xm12=xxc(1)**2
52922  xm22=xxc(2)**2
52923  xm32=xxc(3)**2
52924  s=xxc(4)**2
52925  s13=x
52926 
52927  s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
52928  s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
52929  &( (x-xm22-s)**2 -4d0*xm22*s ) )
52930 
52931  s23min=(s23ave-s23del)
52932  s23max=(s23ave+s23del)
52933 
52934  xmsd1=xxc(5)**2
52935  xmsd2=xxc(7)**2
52936  xmsu1=xxc(6)**2
52937  xmsu2=xxc(8)**2
52938 
52939  xmv=xxc(9)
52940  xmg=xxc(10)
52941  qlls=cxc(1)
52942  qllu=cxc(2)
52943  qlrs=cxc(3)
52944  qlrt=cxc(4)
52945  qrls=cxc(5)
52946  qrlt=cxc(6)
52947  qrrs=cxc(7)
52948  qrru=cxc(8)
52949  wprop2=(s13-xmv**2)**2+(xmv*xmg)**2
52950  sij=2d0*xxc(2)*xxc(4)*s13
52951  IF(xmv.LE.1000d0) THEN
52952  ol2=abs(qlls)**2+abs(qrrs)**2+abs(qlrs)**2+abs(qrls)**2
52953  olr=-2d0*dble(qlrs*dconjg(qlls)+qrls*dconjg(qrrs))
52954  ww=(ol2*2d0*tint(s23max,s23min,xm22,s)
52955  & +olr*sij*(s23max-s23min))/wprop2
52956  IF(xxc(5).LE.10000d0) THEN
52957  wfl1=4d0*(dble(qlls*dconjg(qllu))*
52958  & tint2(s23max,s23min,xm22,s,xmsd1)-
52959  & .5d0*dble(qlls*dconjg(qlrt))*sij*tprop(s23max,s23min,xmsd2)+
52960  & dble(qlrs*dconjg(qlrt))*tint2(s23max,s23min,xm22,s,xmsd2)-
52961  & .5d0*dble(qlrs*dconjg(qllu))*sij*tprop(s23max,s23min,xmsd1))
52962  & *(s13-xmv**2)/wprop2
52963  ELSE
52964  wfl1=0d0
52965  ENDIF
52966 
52967  IF(xxc(6).LE.10000d0) THEN
52968  wfl2=4d0*(dble(qrrs*dconjg(qrru))*
52969  & tint2(s23max,s23min,xm22,s,xmsu1)-
52970  & .5d0*dble(qrrs*dconjg(qrlt))*sij*tprop(s23max,s23min,xmsu2)+
52971  & dble(qrls*dconjg(qrlt))*tint2(s23max,s23min,xm22,s,xmsu2)-
52972  & .5d0*dble(qrls*dconjg(qrru))*sij*tprop(s23max,s23min,xmsu1))
52973  & *(s13-xmv**2)/wprop2
52974  ELSE
52975  wfl2=0d0
52976  ENDIF
52977  ELSE
52978  ww=0d0
52979  wfl1=0d0
52980  wfl2=0d0
52981  ENDIF
52982  IF(xxc(5).LE.10000d0) THEN
52983  wf1=2d0*abs(qllu)**2*tint3(s23max,s23min,xm22,s,xmsd1)
52984  & +2d0*abs(qlrt)**2*tint3(s23max,s23min,xm22,s,xmsd2)
52985  & - 2d0*dble(qlrt*dconjg(qllu))*
52986  & sij*utint(s23max,s23min,xmsd1,xm22+s-s13-xmsd2)
52987  ELSE
52988  wf1=0d0
52989  ENDIF
52990  IF(xxc(6).LE.10000d0) THEN
52991  wf2=2d0*abs(qrru)**2*tint3(s23max,s23min,xm22,s,xmsu1)
52992  & +2d0*abs(qrlt)**2*tint3(s23max,s23min,xm22,s,xmsu2)
52993  & - 2d0*dble(qrlt*dconjg(qrru))*
52994  & sij*utint(s23max,s23min,xmsu1,xm22+s-s13-xmsu2)
52995  ELSE
52996  wf2=0d0
52997  ENDIF
52998 
52999  pyxxz6=(ww+wf1+wf2+wfl1+wfl2)
53000 
53001  IF(pyxxz6.LT.0d0) THEN
53002  WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ6 '
53003  WRITE(mstu(11),*) (xxc(i),i=1,5)
53004  WRITE(mstu(11),*) (xxc(i),i=6,10)
53005  WRITE(mstu(11),*) ww,wf1,wf2,wfl1,wfl2
53006  WRITE(mstu(11),*) s23min,s23max
53007  pyxxz6=0d0
53008  ENDIF
53009 
53010  RETURN
53011  END
53012 
53013 
53014 C*********************************************************************
53015 
53016 C...PYXXGA
53017 C...Calculates chi0_i -> chi0_j + gamma.
53018 
53019  FUNCTION pyxxga(C0,XM1,XM2,XMTR,XMTL)
53020 
53021 C...Double precision and integer declarations.
53022  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53023  IMPLICIT INTEGER(I-N)
53024  INTEGER PYK,PYCHGE,PYCOMP
53025 
53026 C...Local variables.
53027  DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53028  DOUBLE PRECISION F1,F2
53029 
53030  F1=(1d0+xmtr/(1d0-xmtr)*log(xmtr))/(1d0-xmtr)
53031  f2=(1d0+xmtl/(1d0-xmtl)*log(xmtl))/(1d0-xmtl)
53032  pyxxga=c0*((xm1**2-xm2**2)/xm1)**3
53033  pyxxga=pyxxga*(2d0/3d0*(f1+f2)-13d0/12d0)**2
53034 
53035  RETURN
53036  END
53037 
53038 C*********************************************************************
53039 
53040 C...PYX2XG
53041 C...Calculates the decay rate for ino -> ino + gauge boson.
53042 
53043  FUNCTION pyx2xg(C1,XM1,XM2,XM3,GX2,GLR)
53044 
53045 C...Double precision and integer declarations.
53046  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53047  IMPLICIT INTEGER(I-N)
53048  INTEGER PYK,PYCHGE,PYCOMP
53049 
53050 C...Local variables.
53051  DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53052  DOUBLE PRECISION XL,PYLAMF,C1
53053  DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53054 
53055  xmi2=xm1**2
53056  xmi3=abs(xm1**3)
53057  xmj2=xm2**2
53058  xmv2=xm3**2
53059  xl=pylamf(xmi2,xmj2,xmv2)
53060  pyx2xg=c1/8d0/xmi3*sqrt(xl)
53061  &*(gx2*(xl+3d0*xmv2*(xmi2+xmj2-xmv2))-
53062  &12d0*glr*xm1*xm2*xmv2)
53063 
53064  RETURN
53065  END
53066 
53067 C*********************************************************************
53068 
53069 C...PYX2XH
53070 C...Calculates the decay rate for ino -> ino + H.
53071 
53072  FUNCTION pyx2xh(C1,XM1,XM2,XM3,GX2,GLR)
53073 
53074 C...Double precision and integer declarations.
53075  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53076  IMPLICIT INTEGER(I-N)
53077  INTEGER PYK,PYCHGE,PYCOMP
53078 
53079 C...Local variables.
53080  DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53081  DOUBLE PRECISION XL,PYLAMF,C1
53082  DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53083 
53084  xmi2=xm1**2
53085  xmi3=abs(xm1**3)
53086  xmj2=xm2**2
53087  xmv2=xm3**2
53088  xl=pylamf(xmi2,xmj2,xmv2)
53089  pyx2xh=c1/8d0/xmi3*sqrt(xl)
53090  &*(gx2*(xmi2+xmj2-xmv2)+
53091  &4d0*glr*xm1*xm2)
53092 
53093  RETURN
53094  END
53095 
53096 C*********************************************************************
53097 
53098 C...PYHEXT
53099 C...Calculates the non-standard decay modes of the Higgs boson.
53100 C...
53101 C...Author: Stephen Mrenna
53102 C...Last Update: April 2001
53103 C......Allow complex values for Z,U, and V
53104 
53105  SUBROUTINE pyhext(KFIN,XLAM,IDLAM,IKNT)
53106 
53107 C...Double precision and integer declarations.
53108  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53109  IMPLICIT INTEGER(I-N)
53110  INTEGER PYK,PYCHGE,PYCOMP
53111 C...Parameter statement to help give large particle numbers.
53112  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
53113  &kexcit=4000000,kdimen=5000000)
53114 C...Commonblocks.
53115  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53116  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
53117  common/pypars/mstp(200),parp(200),msti(200),pari(200)
53118  common/pymssm/imss(0:99),rmss(0:99)
53119  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
53120  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
53121  SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/,/pyssmt/
53122 
53123 C...Local variables.
53124  COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53125  COMPLEX*16 QIJ,RIJ,F21K,F12K
53126  INTEGER KFIN
53127  DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53128  DOUBLE PRECISION XMI2,XMI3,XMJ2
53129  DOUBLE PRECISION PYLAMF,XL,CF,EI
53130  INTEGER IDU,IFL
53131  DOUBLE PRECISION TANW,XW,AEM,C1,AS
53132  DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53133  DOUBLE PRECISION XLAM(0:400)
53134  INTEGER IDLAM(400,3)
53135  INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53136  INTEGER ITH(4)
53137  INTEGER KFNCHI(4),KFCCHI(2)
53138  DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53139  DOUBLE PRECISION SR2
53140  DOUBLE PRECISION BETA,ALFA
53141  DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53142  DOUBLE PRECISION PYALEM
53143  DOUBLE PRECISION AL,AR,ALR
53144  DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53145  DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53146  DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53147  DATA ith/25,35,36,37/
53148  DATA etah/1d0,1d0,-1d0/
53149  DATA sr2/1.4142136d0/
53150  DATA kfnchi/1000022,1000023,1000025,1000035/
53151  DATA kfcchi/1000024,1000037/
53152 
53153 C...COUNT THE NUMBER OF DECAY MODES
53154  lknt=iknt
53155 
53156  xmw=pmas(24,1)
53157  xmw2=xmw**2
53158  xmz=pmas(23,1)
53159  xw=paru(102)
53160  tanw = sqrt(xw/(1d0-xw))
53161  cw=sqrt(1d0-xw)
53162 
53163 C...1 - 4 DEPENDING ON Higgs species.
53164  ih=1
53165  IF(kfin.EQ.ith(2)) ih=2
53166  IF(kfin.EQ.ith(3)) ih=3
53167  IF(kfin.EQ.ith(4)) ih=4
53168 
53169  xmi=pmas(kfin,1)
53170  xmi2=xmi**2
53171  axmi=abs(xmi)
53172  aem=pyalem(xmi2)
53173  c1=aem/xw
53174  xmi3=abs(xmi**3)
53175 
53176  tanb=rmss(5)
53177  beta=atan(tanb)
53178  cbeta=cos(beta)
53179  sbeta=tanb*cbeta
53180  alfa=rmss(18)
53181  cosa=cos(alfa)
53182  sina=sin(alfa)
53183  atrit=rmss(16)
53184  atrib=rmss(15)
53185  atril=rmss(17)
53186  xmuz=-rmss(4)
53187 
53188  DO 110 i=1,4
53189  DO 100 j=1,4
53190  zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
53191  100 CONTINUE
53192  110 CONTINUE
53193  DO 130 i=1,2
53194  DO 120 j=1,2
53195  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
53196  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
53197  120 CONTINUE
53198  130 CONTINUE
53199 
53200 
53201  IF(ih.EQ.4) GOTO 220
53202 
53203 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53204 C...H0_K -> CHI0_I + CHI0_J
53205  eh(2)=sina
53206  eh(1)=cosa
53207  eh(3)=cbeta
53208  dh(2)=cosa
53209  dh(1)=-sina
53210  dh(3)=sbeta
53211  DO 150 ij=1,4
53212  xmj=smz(ij)
53213  axmj=abs(xmj)
53214  DO 140 ik=1,ij
53215  xmk=smz(ik)
53216  axmk=abs(xmk)
53217  IF(axmi.GE.axmj+axmk) THEN
53218  lknt=lknt+1
53219  qij=zmixc(ik,3)*zmixc(ij,2)+
53220  & zmixc(ij,3)*zmixc(ik,2)-
53221  & tanw*(zmixc(ik,3)*zmixc(ij,1)+
53222  & zmixc(ij,3)*zmixc(ik,1))
53223  rij=zmixc(ik,4)*zmixc(ij,2)+
53224  & zmixc(ij,4)*zmixc(ik,2)-
53225  & tanw*(zmixc(ik,4)*zmixc(ij,1)+
53226  & zmixc(ij,4)*zmixc(ik,1))
53227  f21k=0.5d0*dconjg(qij*dh(ih)-rij*eh(ih))
53228  f12k=0.5d0*(qij*dh(ih)-rij*eh(ih))
53229 C...SIGN OF MASSES I,J
53230  xml=xmk*etah(ih)
53231  gx2=abs(f12k)**2+abs(f21k)**2
53232  glr=dble(f12k*dconjg(f21k))
53233  xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,gx2,glr)
53234  IF(ij.EQ.ik) xlam(lknt)=xlam(lknt)*0.5d0
53235  idlam(lknt,1)=kfnchi(ij)
53236  idlam(lknt,2)=kfnchi(ik)
53237  idlam(lknt,3)=0
53238  ENDIF
53239  140 CONTINUE
53240  150 CONTINUE
53241 
53242 C...H0_K -> CHI+_I CHI-_J
53243  DO 170 ij=1,2
53244  xmj=smw(ij)
53245  axmj=abs(xmj)
53246  DO 160 ik=1,2
53247  xmk=smw(ik)
53248  axmk=abs(xmk)
53249  IF(axmi.GE.axmj+axmk) THEN
53250  lknt=lknt+1
53251  olpp=dconjg(vmixc(ij,1)*umixc(ik,2)*dh(ih) +
53252  & vmixc(ij,2)*umixc(ik,1)*eh(ih))/sr2
53253  orpp=(vmixc(ik,1)*umixc(ij,2)*dh(ih) +
53254  & vmixc(ik,2)*umixc(ij,1)*eh(ih))/sr2
53255  gx2=abs(olpp)**2+abs(orpp)**2
53256  glr=dble(olpp*dconjg(orpp))
53257  xml=xmk*etah(ih)
53258  xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,gx2,glr)
53259  idlam(lknt,1)=kfcchi(ij)
53260  idlam(lknt,2)=-kfcchi(ik)
53261  idlam(lknt,3)=0
53262  ENDIF
53263  160 CONTINUE
53264  170 CONTINUE
53265 
53266 C...HIGGS TO SFERMION SFERMION
53267  DO 200 ifl=1,16
53268  IF(ifl.GE.7.AND.ifl.LE.10) GOTO 200
53269  ij=ksusy1+ifl
53270  xmjl=pmas(pycomp(ij),1)
53271  xmjr=pmas(pycomp(ij+ksusy1),1)
53272  IF(axmi.GE.2d0*min(xmjl,xmjr)) THEN
53273  xmj=xmjl
53274  xmj2=xmj**2
53275  xl=pylamf(xmi2,xmj2,xmj2)
53276  xmf=pmas(ifl,1)
53277  ei=kchg(ifl,1)/3d0
53278  idu=2-mod(ifl,2)
53279 
53280  IF(ih.EQ.1) THEN
53281  IF(idu.EQ.1) THEN
53282  ghll=-xmz/cw*(0.5d0+ei*xw)*sin(alfa+beta)+
53283  & xmf**2/xmw*sina/cbeta
53284  ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)+
53285  & xmf**2/xmw*sina/cbeta
53286  IF(ifl.EQ.5) THEN
53287  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
53288  & atrib*sina)
53289  ELSEIF(ifl.EQ.15) THEN
53290  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
53291  & atril*sina)
53292  ELSE
53293  ghlr=0d0
53294  ENDIF
53295  ELSE
53296  ghll=xmz/cw*(0.5d0-ei*xw)*sin(alfa+beta)-
53297  & xmf**2/xmw*cosa/sbeta
53298  ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)-
53299  & xmf**2/xmw*cosa/sbeta
53300  IF(ifl.EQ.6) THEN
53301  ghlr=xmf/2d0/xmw/sbeta*(xmuz*sina-
53302  & atrit*cosa)
53303  ELSE
53304  ghlr=0d0
53305  ENDIF
53306  ENDIF
53307 
53308  ELSEIF(ih.EQ.2) THEN
53309  IF(idu.EQ.1) THEN
53310  ghll=xmz/cw*(0.5d0+ei*xw)*cos(alfa+beta)-
53311  & xmf**2/xmw*cosa/cbeta
53312  ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
53313  & xmf**2/xmw*cosa/cbeta
53314  IF(ifl.EQ.5) THEN
53315  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
53316  & atrib*cosa)
53317  ELSEIF(ifl.EQ.15) THEN
53318  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
53319  & atril*cosa)
53320  ELSE
53321  ghlr=0d0
53322  ENDIF
53323  ELSE
53324  ghll=-xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)-
53325  & xmf**2/xmw*sina/sbeta
53326  ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
53327  & xmf**2/xmw*sina/sbeta
53328  IF(ifl.EQ.6) THEN
53329  ghlr=-xmf/2d0/xmw/sbeta*(xmuz*cosa+
53330  & atrit*sina)
53331  ELSE
53332  ghlr=0d0
53333  ENDIF
53334  ENDIF
53335 
53336  ELSEIF(ih.EQ.3) THEN
53337  ghll=0d0
53338  ghrr=0d0
53339  ghlr=0d0
53340  IF(idu.EQ.1) THEN
53341  IF(ifl.EQ.5) THEN
53342  ghlr=xmf/2d0/xmw*(atrib*tanb-xmuz)
53343  ELSEIF(ifl.EQ.15) THEN
53344  ghlr=xmf/2d0/xmw*(atril*tanb-xmuz)
53345  ENDIF
53346  ELSE
53347  IF(ifl.EQ.6) THEN
53348  ghlr=xmf/2d0/xmw*(atrit/tanb-xmuz)
53349  ENDIF
53350  ENDIF
53351  ENDIF
53352  IF(ih.EQ.3) GOTO 180
53353 
53354  al=sfmix(ifl,1)**2
53355  ar=sfmix(ifl,2)**2
53356  alr=sfmix(ifl,1)*sfmix(ifl,2)
53357  IF(ifl.LE.6) THEN
53358  cf=3d0
53359  ELSE
53360  cf=1d0
53361  ENDIF
53362 
53363  IF(axmi.GE.2d0*xmj) THEN
53364  lknt=lknt+1
53365  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53366  & (ghll*al+ghrr*ar
53367  & +2d0*ghlr*alr)**2
53368  idlam(lknt,1)=ij
53369  idlam(lknt,2)=-ij
53370  idlam(lknt,3)=0
53371  ENDIF
53372 
53373  IF(axmi.GE.2d0*xmjr) THEN
53374  lknt=lknt+1
53375  al=sfmix(ifl,3)**2
53376  ar=sfmix(ifl,4)**2
53377  alr=sfmix(ifl,3)*sfmix(ifl,4)
53378  xmj=xmjr
53379  xmj2=xmj**2
53380  xl=pylamf(xmi2,xmj2,xmj2)
53381  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53382  & (ghll*al+ghrr*ar
53383  & +2d0*ghlr*alr)**2
53384  idlam(lknt,1)=ij+ksusy1
53385  idlam(lknt,2)=-(ij+ksusy1)
53386  idlam(lknt,3)=0
53387  ENDIF
53388  180 CONTINUE
53389 
53390  IF(axmi.GE.xmjl+xmjr) THEN
53391  lknt=lknt+1
53392  al=sfmix(ifl,1)*sfmix(ifl,3)
53393  ar=sfmix(ifl,2)*sfmix(ifl,4)
53394  alr=sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,2)*sfmix(ifl,3)
53395  xmj=xmjr
53396  xmj2=xmj**2
53397  xl=pylamf(xmi2,xmj2,xmjl**2)
53398  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53399  & (ghll*al+ghrr*ar)**2
53400  idlam(lknt,1)=ij
53401  idlam(lknt,2)=-(ij+ksusy1)
53402  idlam(lknt,3)=0
53403  lknt=lknt+1
53404  idlam(lknt,1)=-ij
53405  idlam(lknt,2)=ij+ksusy1
53406  idlam(lknt,3)=0
53407  xlam(lknt)=xlam(lknt-1)
53408  ENDIF
53409  ENDIF
53410  190 CONTINUE
53411  200 CONTINUE
53412  210 CONTINUE
53413 
53414  GOTO 270
53415  220 CONTINUE
53416 
53417 C...H+ -> CHI+_I + CHI0_J
53418  DO 240 ij=1,4
53419  xmj=smz(ij)
53420  axmj=abs(xmj)
53421  xmj2=xmj**2
53422  DO 230 ik=1,2
53423  xmk=smw(ik)
53424  axmk=abs(xmk)
53425  IF(axmi.GE.axmj+axmk) THEN
53426  lknt=lknt+1
53427  olpp=cbeta*dconjg(zmixc(ij,4)*vmixc(ik,1)+(zmixc(ij,2)+
53428  & zmixc(ij,1)*tanw)*vmixc(ik,2)/sr2)
53429  orpp=sbeta*(zmixc(ij,3)*umixc(ik,1)-
53430  & (zmixc(ij,2)+zmixc(ij,1)*tanw)*umixc(ik,2)/sr2)
53431  gx2=abs(olpp)**2+abs(orpp)**2
53432  glr=dble(olpp*dconjg(orpp))
53433  xlam(lknt)=pyh2xx(c1,xmi,xmj,-xmk,gx2,glr)
53434  idlam(lknt,1)=kfnchi(ij)
53435  idlam(lknt,2)=kfcchi(ik)
53436  idlam(lknt,3)=0
53437  ENDIF
53438  230 CONTINUE
53439  240 CONTINUE
53440 
53441  gl=-xmw/sr2*(sin(2d0*beta)-pmas(6,1)**2/tanb/xmw2)
53442  gr=-pmas(6,1)/sr2/xmw*(xmuz-atrit/tanb)
53443  al=0d0
53444  ar=0d0
53445  cf=3d0
53446 
53447 C...H+ -> T_1 B_1~
53448  xm1=pmas(pycomp(ksusy1+6),1)
53449  xm2=pmas(pycomp(ksusy1+5),1)
53450  IF(xmi.GE.xm1+xm2) THEN
53451  xl=pylamf(xmi2,xm1**2,xm2**2)
53452  lknt=lknt+1
53453  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53454  & (gl*sfmix(6,1)*sfmix(5,1)+gr*sfmix(6,2)*sfmix(5,1))**2
53455  idlam(lknt,1)=ksusy1+6
53456  idlam(lknt,2)=-(ksusy1+5)
53457  idlam(lknt,3)=0
53458  ENDIF
53459 
53460 C...H+ -> T_2 B_1~
53461  xm1=pmas(pycomp(ksusy2+6),1)
53462  xm2=pmas(pycomp(ksusy1+5),1)
53463  IF(xmi.GE.xm1+xm2) THEN
53464  xl=pylamf(xmi2,xm1**2,xm2**2)
53465  lknt=lknt+1
53466  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53467  & (gl*sfmix(6,3)*sfmix(5,1)+gr*sfmix(6,4)*sfmix(5,1))**2
53468  idlam(lknt,1)=ksusy2+6
53469  idlam(lknt,2)=-(ksusy1+5)
53470  idlam(lknt,3)=0
53471  ENDIF
53472 
53473 C...H+ -> T_1 B_2~
53474  xm1=pmas(pycomp(ksusy1+6),1)
53475  xm2=pmas(pycomp(ksusy2+5),1)
53476  IF(xmi.GE.xm1+xm2) THEN
53477  xl=pylamf(xmi2,xm1**2,xm2**2)
53478  lknt=lknt+1
53479  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53480  & (gl*sfmix(6,1)*sfmix(5,3)+gr*sfmix(6,2)*sfmix(5,3))**2
53481  idlam(lknt,1)=ksusy1+6
53482  idlam(lknt,2)=-(ksusy2+5)
53483  idlam(lknt,3)=0
53484  ENDIF
53485 
53486 C...H+ -> T_2 B_2~
53487  xm1=pmas(pycomp(ksusy2+6),1)
53488  xm2=pmas(pycomp(ksusy2+5),1)
53489  IF(xmi.GE.xm1+xm2) THEN
53490  xl=pylamf(xmi2,xm1**2,xm2**2)
53491  lknt=lknt+1
53492  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53493  & (gl*sfmix(6,3)*sfmix(5,3)+gr*sfmix(6,4)*sfmix(5,3))**2
53494  idlam(lknt,1)=ksusy2+6
53495  idlam(lknt,2)=-(ksusy2+5)
53496  idlam(lknt,3)=0
53497  ENDIF
53498 
53499 C...H+ -> UL DL~
53500  gl=-xmw/sr2*sin(2d0*beta)
53501  DO 250 ij=1,3,2
53502  xm1=pmas(pycomp(ksusy1+ij),1)
53503  xm2=pmas(pycomp(ksusy1+ij+1),1)
53504  IF(xmi.GE.xm1+xm2) THEN
53505  xl=pylamf(xmi2,xm1**2,xm2**2)
53506  lknt=lknt+1
53507  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2
53508  idlam(lknt,1)=-(ksusy1+ij)
53509  idlam(lknt,2)=ksusy1+ij+1
53510  idlam(lknt,3)=0
53511  ENDIF
53512  250 CONTINUE
53513 
53514 C...H+ -> EL~ NUL
53515  cf=1d0
53516  DO 260 ij=11,13,2
53517  xm1=pmas(pycomp(ksusy1+ij),1)
53518  xm2=pmas(pycomp(ksusy1+ij+1),1)
53519  IF(xmi.GE.xm1+xm2) THEN
53520  xl=pylamf(xmi2,xm1**2,xm2**2)
53521  lknt=lknt+1
53522  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2
53523  idlam(lknt,1)=-(ksusy1+ij)
53524  idlam(lknt,2)=ksusy1+ij+1
53525  idlam(lknt,3)=0
53526  ENDIF
53527  260 CONTINUE
53528 
53529 C...H+ -> TAU1 NUTAUL
53530  xm1=pmas(pycomp(ksusy1+15),1)
53531  xm2=pmas(pycomp(ksusy1+16),1)
53532  IF(xmi.GE.xm1+xm2) THEN
53533  xl=pylamf(xmi2,xm1**2,xm2**2)
53534  lknt=lknt+1
53535  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2*sfmix(15,1)**2
53536  idlam(lknt,1)=-(ksusy1+15)
53537  idlam(lknt,2)= ksusy1+16
53538  idlam(lknt,3)=0
53539  ENDIF
53540 
53541 C...H+ -> TAU2 NUTAUL
53542  xm1=pmas(pycomp(ksusy2+15),1)
53543  xm2=pmas(pycomp(ksusy1+16),1)
53544  IF(xmi.GE.xm1+xm2) THEN
53545  xl=pylamf(xmi2,xm1**2,xm2**2)
53546  lknt=lknt+1
53547  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2*sfmix(15,3)**2
53548  idlam(lknt,1)=-(ksusy2+15)
53549  idlam(lknt,2)= ksusy1+16
53550  idlam(lknt,3)=0
53551  ENDIF
53552 
53553  270 CONTINUE
53554  iknt=lknt
53555  xlam(0)=0d0
53556  DO 280 i=1,iknt
53557  IF(xlam(i).LE.0d0) xlam(i)=0d0
53558  xlam(0)=xlam(0)+xlam(i)
53559  280 CONTINUE
53560  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
53561 
53562  RETURN
53563  END
53564 
53565 C*********************************************************************
53566 
53567 C...PYH2XX
53568 C...Calculates the decay rate for a Higgs to an ino pair.
53569 
53570  FUNCTION pyh2xx(C1,XM1,XM2,XM3,GX2,GLR)
53571 
53572 C...Double precision and integer declarations.
53573  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53574  IMPLICIT INTEGER(I-N)
53575  INTEGER PYK,PYCHGE,PYCOMP
53576 C...Commonblocks.
53577  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53578  SAVE /pydat1/
53579 
53580 C...Local variables.
53581  DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53582  DOUBLE PRECISION XL,PYLAMF,C1
53583  DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53584 
53585  xmi2=xm1**2
53586  xmi3=abs(xm1**3)
53587  xmj2=xm2**2
53588  xmk2=xm3**2
53589  xl=pylamf(xmi2,xmj2,xmk2)
53590  pyh2xx=c1/4d0/xmi3*sqrt(xl)
53591  &*(gx2*(xmi2-xmj2-xmk2)-
53592  &4d0*glr*xm3*xm2)
53593  IF(pyh2xx.LT.0d0) pyh2xx=0d0
53594 
53595  RETURN
53596  END
53597 
53598 C*********************************************************************
53599 
53600 C...PYGAUS
53601 C...Integration by adaptive Gaussian quadrature.
53602 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53603 
53604  FUNCTION pygaus(F, A, B, EPS)
53605 
53606 C...Double precision and integer declarations.
53607  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53608  IMPLICIT INTEGER(I-N)
53609  INTEGER PYK,PYCHGE,PYCOMP
53610 
53611 C...Local declarations.
53612  EXTERNAL f
53613  DOUBLE PRECISION F,W(12), X(12)
53614  DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53615  DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53616  DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
53617  DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
53618  DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
53619  DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
53620  DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
53621  DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
53622  DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
53623  DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
53624  DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
53625  DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
53626 
53627 C...The Gaussian quadrature algorithm.
53628  h = 0d0
53629  IF(b .EQ. a) GOTO 140
53630  const = 5d-3 / abs(b-a)
53631  bb = a
53632  100 CONTINUE
53633  aa = bb
53634  bb = b
53635  110 CONTINUE
53636  c1 = 0.5d0*(bb+aa)
53637  c2 = 0.5d0*(bb-aa)
53638  s8 = 0d0
53639  DO 120 i = 1, 4
53640  u = c2*x(i)
53641  s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
53642  120 CONTINUE
53643  s16 = 0d0
53644  DO 130 i = 5, 12
53645  u = c2*x(i)
53646  s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
53647  130 CONTINUE
53648  s16 = c2*s16
53649  IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
53650  h = h + s16
53651  IF(bb .NE. b) GOTO 100
53652  ELSE
53653  bb = c1
53654  IF(1d0 + const*abs(c2) .NE. 1d0) GOTO 110
53655  h = 0d0
53656  CALL pyerrm(18,'(PYGAUS:) too high accuracy required')
53657  GOTO 140
53658  ENDIF
53659  140 CONTINUE
53660  pygaus = h
53661 
53662  RETURN
53663  END
53664 
53665 C*********************************************************************
53666 
53667 C...PYGAU2
53668 C...Integration by adaptive Gaussian quadrature.
53669 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53670 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53671 
53672  FUNCTION pygau2(F, A, B, EPS)
53673 
53674 C...Double precision and integer declarations.
53675  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53676  IMPLICIT INTEGER(I-N)
53677  INTEGER PYK,PYCHGE,PYCOMP
53678 
53679 C...Local declarations.
53680  EXTERNAL f
53681  DOUBLE PRECISION F,W(12), X(12)
53682  DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53683  DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53684  DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
53685  DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
53686  DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
53687  DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
53688  DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
53689  DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
53690  DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
53691  DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
53692  DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
53693  DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
53694 
53695 C...The Gaussian quadrature algorithm.
53696  h = 0d0
53697  IF(b .EQ. a) GOTO 140
53698  const = 5d-3 / abs(b-a)
53699  bb = a
53700  100 CONTINUE
53701  aa = bb
53702  bb = b
53703  110 CONTINUE
53704  c1 = 0.5d0*(bb+aa)
53705  c2 = 0.5d0*(bb-aa)
53706  s8 = 0d0
53707  DO 120 i = 1, 4
53708  u = c2*x(i)
53709  s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
53710  120 CONTINUE
53711  s16 = 0d0
53712  DO 130 i = 5, 12
53713  u = c2*x(i)
53714  s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
53715  130 CONTINUE
53716  s16 = c2*s16
53717  IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
53718  h = h + s16
53719  IF(bb .NE. b) GOTO 100
53720  ELSE
53721  bb = c1
53722  IF(1d0 + const*abs(c2) .NE. 1d0) GOTO 110
53723  h = 0d0
53724  CALL pyerrm(18,'(PYGAU2:) too high accuracy required')
53725  GOTO 140
53726  ENDIF
53727  140 CONTINUE
53728  pygau2 = h
53729 
53730  RETURN
53731  END
53732 
53733 C*********************************************************************
53734 
53735 C...PYSIMP
53736 C...Simpson formula for an integral.
53737 
53738  FUNCTION pysimp(Y,X0,X1,N)
53739 
53740 C...Double precision and integer declarations.
53741  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53742  IMPLICIT INTEGER(I-N)
53743  INTEGER PYK,PYCHGE,PYCOMP
53744 
53745 C...Local variables.
53746  DOUBLE PRECISION Y,X0,X1,H,S
53747  dimension y(0:n)
53748 
53749  s=0d0
53750  h=(x1-x0)/n
53751  DO 100 i=0,n-2,2
53752  s=s+y(i)+4d0*y(i+1)+y(i+2)
53753  100 CONTINUE
53754  pysimp=s*h/3d0
53755 
53756  RETURN
53757  END
53758 
53759 C*********************************************************************
53760 
53761 C...PYLAMF
53762 C...The standard lambda function.
53763 
53764  FUNCTION pylamf(X,Y,Z)
53765 
53766 C...Double precision and integer declarations.
53767  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53768  IMPLICIT INTEGER(I-N)
53769  INTEGER PYK,PYCHGE,PYCOMP
53770 
53771 C...Local variables.
53772  DOUBLE PRECISION PYLAMF,X,Y,Z
53773 
53774  pylamf=(x-(y+z))**2-4d0*y*z
53775  IF(pylamf.LT.0d0) pylamf=0d0
53776 
53777  RETURN
53778  END
53779 
53780 C*********************************************************************
53781 
53782 C...PYTBDY
53783 C...Generates 3-body decays of gauginos.
53784 
53785  SUBROUTINE pytbdy(IDIN)
53786 
53787 C...Double precision and integer declarations.
53788  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53789  IMPLICIT INTEGER(I-N)
53790  INTEGER PYK,PYCHGE,PYCOMP
53791 C...Parameter statement to help give large particle numbers.
53792  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
53793  &kexcit=4000000,kdimen=5000000)
53794 C...Commonblocks.
53795  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
53796  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53797  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
53798 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53799 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53800  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
53801  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
53802 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53803  SAVE /pyjets/,/pydat1/,/pydat2/,/pyssmt/
53804 
53805 C...Local variables.
53806  DOUBLE PRECISION XM(5)
53807  COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53808  COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53809  COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53810  DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53811  DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53812  DOUBLE PRECISION CPHI1,SPHI1
53813  DOUBLE PRECISION S23DEL,EPS
53814  DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53815  parameter(r=0.61803399d0,c=1d0-r,tol=1d-3)
53816  DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53817  INTEGER INOID(4)
53818  DATA inoid/22,23,25,35/
53819  DATA eps/1d-6/
53820 
53821  id=idin
53822  iskip=1
53823  xm(1)=p(n+1,5)
53824  xm(2)=p(n+2,5)
53825  xm(3)=p(n+3,5)
53826  xm(5)=p(id,5)
53827 
53828 C...GENERATE S12
53829  s12min=(xm(1)+xm(2))**2
53830  s12max=(xm(5)-xm(3))**2
53831  yjaco1=s12max-s12min
53832 
53833 C...Initialize some parameters
53834  xw=paru(102)
53835  xw1=1d0-xw
53836  tanw=sqrt(xw/xw1)
53837  izid1=0
53838  iwid1=0
53839  izid2=0
53840  iwid2=0
53841 
53842  ia=k(n+2,2)
53843  ja=k(n+3,2)
53844 
53845 C...Mrenna: check that we are indeed decaying a SUSY particle
53846  IF(iabs(k(id,2)).LT.ksusy1.OR.iabs(k(id,2)).GE.3000000) THEN
53847 
53848  ELSE
53849  DO 100 i1=1,4
53850  IF(mod(k(n+1,2),ksusy1).EQ.inoid(i1)) izid1=i1
53851  IF(mod(k(id,2),ksusy1).EQ.inoid(i1)) izid2=i1
53852  100 CONTINUE
53853  IF(mod(k(n+1,2),ksusy1).EQ.24) iwid1=1
53854  IF(mod(k(n+1,2),ksusy1).EQ.37) iwid1=2
53855  IF(mod(k(id,2),ksusy1).EQ.24) iwid2=1
53856  IF(mod(k(id,2),ksusy1).EQ.37) iwid2=2
53857  zm12=xm(5)**2
53858  zm22=xm(1)**2
53859  ei=kchg(pycomp(iabs(ia)),1)/3d0
53860  t3i=sign(1d0,ei+1d-6)/2d0
53861  ENDIF
53862 
53863  IF(max(abs(ia),abs(ja)).EQ.6) THEN
53864  iskip=0
53865  ELSEIF(izid1*izid2.NE.0) THEN
53866  sqmz=pmas(23,1)**2
53867  gmmz=pmas(23,1)*pmas(23,2)
53868  DO 110 i=1,4
53869  zmixc(izid1,i)=dcmplx(zmix(izid1,i),zmixi(izid1,i))
53870  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
53871  110 CONTINUE
53872  olpp=(zmixc(izid1,3)*dconjg(zmixc(izid2,3))-
53873  & zmixc(izid1,4)*dconjg(zmixc(izid2,4)))/2d0
53874  orpp=dconjg(olpp)
53875  xll2=pmas(pycomp(ksusy1+iabs(ia)),1)**2
53876  xlr2=xll2
53877  xrr2=pmas(pycomp(ksusy2+iabs(ia)),1)**2
53878  xrl2=xrr2
53879  glij=(t3i*zmixc(izid1,2)-tanw*(t3i-ei)*zmixc(izid1,1))*
53880  & dconjg(t3i*zmixc(izid2,2)-tanw*(t3i-ei)*zmixc(izid2,1))
53881  grij=zmixc(izid1,1)*dconjg(zmixc(izid2,1))*(ei*tanw)**2
53882  xm1m2=smz(izid1)*smz(izid2)
53883  qlls=dcmplx((t3i-ei*xw)/xw1)*olpp
53884  qllu=-glij
53885  qlrs=-dcmplx((t3i-ei*xw)/xw1)*orpp
53886  qlrt=dconjg(glij)
53887  qrls=-dcmplx((ei*xw)/xw1)*olpp
53888  qrlt=grij
53889  qrrs=dcmplx((ei*xw)/xw1)*orpp
53890  qrru=-dconjg(grij)
53891  ELSEIF(izid1*iwid2.NE.0.OR.izid2*iwid1.NE.0) THEN
53892  IF(izid1.NE.0) THEN
53893  xm1m2=smz(izid1)*smw(iwid2)
53894  izid1=iwid2
53895  izid2=izid1
53896  ELSE
53897  xm1m2=smz(izid2)*smw(iwid1)
53898  izid1=iwid1
53899  ENDIF
53900  rt2i = 1d0/sqrt(2d0)
53901  sqmz=pmas(24,1)**2
53902  gmmz=pmas(24,1)*pmas(24,2)
53903  DO 120 i=1,2
53904  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
53905  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
53906  120 CONTINUE
53907  DO 130 i=1,4
53908  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
53909  130 CONTINUE
53910  qlls=(dconjg(zmixc(izid2,2))*vmixc(izid1,1)-
53911  & dconjg(zmixc(izid2,4))*vmixc(izid1,2)*rt2i)
53912  qlrs=(zmixc(izid2,2)*dconjg(umixc(izid1,1))+
53913  & zmixc(izid2,3)*dconjg(umixc(izid1,2))*rt2i)
53914  ej=kchg(iabs(ja),1)/3d0
53915  t3j=sign(1d0,ej+1d-6)/2d0
53916  qrls=dcmplx(0d0,0d0)
53917  qrlt=qrls
53918  qrrs=qrls
53919  qrru=qrls
53920  xrr2=1d6**2
53921  xrl2=xrr2
53922  xlr2 = pmas(pycomp(ksusy1+iabs(ja)),1)**2
53923  xll2 = pmas(pycomp(ksusy1+iabs(ia)),1)**2
53924  IF(mod(ia,2).EQ.0) THEN
53925  qllu=vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ei-t3i)*
53926  & tanw+zmixc(izid2,2)*t3i)
53927  qlrt=-dconjg(umixc(izid1,1))*(
53928  & zmixc(izid2,1)*(ej-t3j)*tanw+zmixc(izid2,2)*t3j)
53929  ELSE
53930  qllu=vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ej-t3j)*
53931  & tanw+zmixc(izid2,2)*t3j)
53932  qlrt=-dconjg(umixc(izid1,1))*(
53933  & zmixc(izid2,1)*(ei-t3i)*tanw+zmixc(izid2,2)*t3i)
53934  ENDIF
53935  ELSEIF(iwid1*iwid2.NE.0) THEN
53936  izid1=iwid1
53937  izid2=iwid2
53938  xm1m2=smw(iwid1)*smw(iwid2)
53939  sqmz=pmas(23,1)**2
53940  gmmz=pmas(23,1)*pmas(23,2)
53941  DO 140 i=1,2
53942  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
53943  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
53944  vmixc(izid2,i)=dcmplx(vmix(izid2,i),vmixi(izid2,i))
53945  umixc(izid2,i)=dcmplx(umix(izid2,i),umixi(izid2,i))
53946  140 CONTINUE
53947  olpp=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))-
53948  & vmixc(izid2,2)*dconjg(vmixc(izid1,2))/2d0
53949  orpp=-umixc(izid1,1)*dconjg(umixc(izid2,1))-
53950  & umixc(izid1,2)*dconjg(umixc(izid2,2))/2d0
53951  qrls=-dcmplx(ei/xw1)*orpp
53952  qlls=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
53953  qrrs=-dcmplx(ei/xw1)*olpp
53954  qlrs=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
53955  IF(mod(ia,2).EQ.0) THEN
53956  xlr2=pmas(pycomp(ksusy1+iabs(ia)-1),1)**2
53957  qlrt=-umixc(izid2,1)*dconjg(umixc(izid1,1))*dcmplx(t3i/xw)
53958  ELSE
53959  xlr2=pmas(pycomp(ksusy1+iabs(ia)+1),1)**2
53960  qlrt=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))*dcmplx(t3i/xw)
53961  ENDIF
53962  ELSEIF(mod(k(n+1,2),ksusy1).EQ.21.OR.mod(k(id,2),ksusy1).EQ.21)
53963  &THEN
53964  iskip=0
53965  ELSE
53966  iskip=0
53967  ENDIF
53968 
53969  IF(iskip.NE.0) THEN
53970  wtmax=0d0
53971  DO 160 kt=1,100
53972  s12=s12min+yjaco1*(kt-1)/99
53973  s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
53974  & *(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
53975  s23df1=(s12-xm(2)**2-xm(1)**2)**2
53976  & -(2d0*xm(1)*xm(2))**2
53977  s23df2=(s12-xm(3)**2-xm(5)**2)**2
53978  & -(2d0*xm(3)*xm(5))**2
53979  s23df1=s23df1*eps
53980  s23df2=s23df2*eps
53981  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*s12)
53982  s23del=s23del/eps
53983  s23min=s23ave-s23del
53984  s23max=s23ave+s23del
53985  yjaco2=s23max-s23min
53986  th=s12
53987  DO 150 ks=1,100
53988  s23=s23min+yjaco2*(ks-1)/99
53989  sh=s23
53990  uh=zm12+zm22-sh-th
53991  wu2 = (uh-zm12)*(uh-zm22)
53992  wt2 = (th-zm12)*(th-zm22)
53993  ws2 = xm1m2*sh
53994  propz2 = (sh-sqmz)**2 + gmmz**2
53995  propz=dcmplx(sh-sqmz,-gmmz)/dcmplx(propz2)
53996  qll=qlls*propz+qllu/dcmplx(uh-xll2)
53997  qlr=qlrs*propz+qlrt/dcmplx(th-xlr2)
53998  qrl=qrls*propz+qrlt/dcmplx(th-xrl2)
53999  qrr=qrrs*propz+qrru/dcmplx(uh-xrr2)
54000  wt0=-((abs(qll)**2+abs(qrr)**2)*wu2+
54001  & (abs(qrl)**2+abs(qlr)**2)*wt2+
54002  & 2d0*dble(qlr*dconjg(qll)+qrl*dconjg(qrr))*ws2)
54003  IF(wt0.GT.wtmax) wtmax=wt0
54004  150 CONTINUE
54005  160 CONTINUE
54006 
54007  wtmax=wtmax*1.05d0
54008  ENDIF
54009 
54010 C...FIND S12*
54011  ax=s12min
54012  cx=s12max
54013  bx=s12min+0.5d0*yjaco1
54014  x0=ax
54015  x3=cx
54016  IF(abs(cx-bx).GT.abs(bx-ax))THEN
54017  x1=bx
54018  x2=bx+c*(cx-bx)
54019  ELSE
54020  x2=bx
54021  x1=bx-c*(bx-ax)
54022  ENDIF
54023 
54024 C...SOLVE FOR F1 AND F2
54025  s23df1=(x1-xm(2)**2-xm(1)**2)**2
54026  &-(2d0*xm(1)*xm(2))**2
54027  s23df2=(x1-xm(3)**2-xm(5)**2)**2
54028  &-(2d0*xm(3)*xm(5))**2
54029  s23df1=s23df1*eps
54030  s23df2=s23df2*eps
54031  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x1)
54032  f1=-2d0*s23del/eps
54033  s23df1=(x2-xm(2)**2-xm(1)**2)**2
54034  &-(2d0*xm(1)*xm(2))**2
54035  s23df2=(x2-xm(3)**2-xm(5)**2)**2
54036  &-(2d0*xm(3)*xm(5))**2
54037  s23df1=s23df1*eps
54038  s23df2=s23df2*eps
54039  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x2)
54040  f2=-2d0*s23del/eps
54041 
54042  170 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2)))THEN
54043 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54044  IF(f2.LE.f1)THEN
54045  x0=x1
54046  x1=x2
54047  x2=r*x1+c*x3
54048  f1=f2
54049  s23df1=(x2-xm(2)**2-xm(1)**2)**2
54050  & -(2d0*xm(1)*xm(2))**2
54051  s23df2=(x2-xm(3)**2-xm(5)**2)**2
54052  & -(2d0*xm(3)*xm(5))**2
54053  s23df1=s23df1*eps
54054  s23df2=s23df2*eps
54055  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x2)
54056  f2=-2d0*s23del/eps
54057  ELSE
54058  x3=x2
54059  x2=x1
54060  x1=r*x2+c*x0
54061  f2=f1
54062  s23df1=(x1-xm(2)**2-xm(1)**2)**2
54063  & -(2d0*xm(1)*xm(2))**2
54064  s23df2=(x1-xm(3)**2-xm(5)**2)**2
54065  & -(2d0*xm(3)*xm(5))**2
54066  s23df1=s23df1*eps
54067  s23df2=s23df2*eps
54068  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x1)
54069  f1=-2d0*s23del/eps
54070  ENDIF
54071  GOTO 170
54072  ENDIF
54073 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54074  IF(f1.LT.f2)THEN
54075  golden=-f1
54076  xmin=x1
54077  ELSE
54078  golden=-f2
54079  xmin=x2
54080  ENDIF
54081 
54082  iknt=0
54083  180 s12=s12min+pyr(0)*yjaco1
54084  iknt=iknt+1
54085 C...GENERATE S23
54086  s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
54087  &*(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
54088  s23df1=(s12-xm(2)**2-xm(1)**2)**2
54089  &-(2d0*xm(1)*xm(2))**2
54090  s23df2=(s12-xm(3)**2-xm(5)**2)**2
54091  &-(2d0*xm(3)*xm(5))**2
54092  s23df1=s23df1*eps
54093  s23df2=s23df2*eps
54094  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*s12)
54095  s23del=s23del/eps
54096  s23min=s23ave-s23del
54097  s23max=s23ave+s23del
54098  yjaco2=s23max-s23min
54099  s23=s23min+pyr(0)*yjaco2
54100 
54101 C...CHECK THE SAMPLING
54102  IF(iknt.GT.100) THEN
54103  WRITE(mstu(11),*) ' IKNT > 100 IN PYTBDY '
54104  GOTO 190
54105  ENDIF
54106  IF(yjaco2.LT.pyr(0)*golden) GOTO 180
54107 
54108  IF(iskip.EQ.0) GOTO 190
54109 
54110  sh=s23
54111  th=s12
54112  uh=zm12+zm22-sh-th
54113 
54114  wu2 = (uh-zm12)*(uh-zm22)
54115  wt2 = (th-zm12)*(th-zm22)
54116  ws2 = xm1m2*sh
54117  propz2 = (sh-sqmz)**2 + gmmz**2
54118  propz=dcmplx(sh-sqmz,-gmmz)/dcmplx(propz2)
54119 
54120  qll=qlls*propz+qllu/dcmplx(uh-xll2)
54121  qlr=qlrs*propz+qlrt/dcmplx(th-xlr2)
54122  qrl=qrls*propz+qrlt/dcmplx(th-xrl2)
54123  qrr=qrrs*propz+qrru/dcmplx(uh-xrr2)
54124 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54125 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54126 c &/DCMPLX(TH-XML2)
54127 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54128 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54129 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54130  wt=-((abs(qll)**2+abs(qrr)**2)*wu2+
54131  &(abs(qrl)**2+abs(qlr)**2)*wt2+
54132  &2d0*dble(qlr*dconjg(qll)+qrl*dconjg(qrr))*ws2)
54133 
54134  IF(wt.LT.pyr(0)*wtmax) GOTO 180
54135  IF(wt.GT.wtmax) print*,' WT > WTMAX ',wt,wtmax
54136 
54137  190 d3=(xm(5)**2+xm(3)**2-s12)/(2d0*xm(5))
54138  d1=(xm(5)**2+xm(1)**2-s23)/(2d0*xm(5))
54139  d2=xm(5)-d1-d3
54140  p1=sqrt(d1*d1-xm(1)**2)
54141  p2=sqrt(d2*d2-xm(2)**2)
54142  p3=sqrt(d3*d3-xm(3)**2)
54143  cthe1=2d0*pyr(0)-1d0
54144  ang1=2d0*pyr(0)*paru(1)
54145  cphi1=cos(ang1)
54146  sphi1=sin(ang1)
54147  arg=1d0-cthe1**2
54148  IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
54149  sthe1=sqrt(arg)
54150  p(n+1,1)=p1*sthe1*cphi1
54151  p(n+1,2)=p1*sthe1*sphi1
54152  p(n+1,3)=p1*cthe1
54153  p(n+1,4)=d1
54154 
54155 C...GET CPHI3
54156  ang3=2d0*pyr(0)*paru(1)
54157  cphi3=cos(ang3)
54158  sphi3=sin(ang3)
54159  cthe3=(p2**2-p1**2-p3**2)/2d0/p1/p3
54160  arg=1d0-cthe3**2
54161  IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
54162  sthe3=sqrt(arg)
54163  p(n+3,1)=-p3*sthe3*cphi3*cthe1*cphi1
54164  &+p3*sthe3*sphi3*sphi1
54165  &+p3*cthe3*sthe1*cphi1
54166  p(n+3,2)=-p3*sthe3*cphi3*cthe1*sphi1
54167  &-p3*sthe3*sphi3*cphi1
54168  &+p3*cthe3*sthe1*sphi1
54169  p(n+3,3)=p3*sthe3*cphi3*sthe1
54170  &+p3*cthe3*cthe1
54171  p(n+3,4)=d3
54172 
54173  DO 200 i=1,3
54174  p(n+2,i)=-p(n+1,i)-p(n+3,i)
54175  200 CONTINUE
54176  p(n+2,4)=d2
54177 
54178  RETURN
54179  END
54180 
54181 
54182 C*********************************************************************
54183 
54184 C...PYTECM
54185 C...Finds the s-hat dependent eigenvalues of the inverse propagator
54186 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54187 C...phase space generation. Extended to include techni-a meson, and
54188 C...to return the width.
54189 
54190  SUBROUTINE pytecm(SMIN,SMOU,WIDO,IOPT)
54191 
54192 C...Double precision and integer declarations.
54193  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54194  IMPLICIT INTEGER(I-N)
54195  INTEGER PYK,PYCHGE,PYCOMP
54196 C...Parameter statement to help give large particle numbers.
54197  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
54198  &kexcit=4000000,kdimen=5000000)
54199 C...Commonblocks.
54200  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54201  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54202  common/pypars/mstp(200),parp(200),msti(200),pari(200)
54203  common/pytcsm/itcm(0:99),rtcm(0:99)
54204  SAVE /pydat1/,/pydat2/,/pypars/,/pytcsm/
54205 
54206 C...Local variables.
54207  DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54208  &at(5,5),wi(5),fv1(5),fv2(5),fv3(5),sh,aem,tanw,ct2w,qupd,alprht,
54209  &far,fao,fzr,fzo,shr,r1,r2,s1,s2,wdtp(0:400),wdte(0:400,0:5),wx(5)
54210  INTEGER i,j,ierr
54211 
54212  sh=smin
54213  shr=sqrt(sh)
54214  aem=pyalem(sh)
54215 
54216  sinw=min(sqrt(paru(102)),1d0)
54217  cosw=sqrt(1d0-sinw**2)
54218  tanw=sinw/cosw
54219  ct2w=(1d0-2d0*paru(102))/(2d0*paru(102)/tanw)
54220  qupd=2d0*rtcm(2)-1d0
54221 
54222  alprht=2.16d0*(3d0/dble(itcm(1)))
54223  far=sqrt(aem/alprht)
54224  fao=far*qupd
54225  fzr=far*ct2w
54226  fzo=-fao*tanw
54227  fzx=-far/rtcm(47)/(2d0*sinw*cosw)
54228  fwr=far/(2d0*sinw)
54229  fwx=-fwr/rtcm(47)
54230 
54231  DO 110 i=1,5
54232  DO 100 j=1,5
54233  at(i,j)=0d0
54234  100 CONTINUE
54235  110 CONTINUE
54236 
54237 C...NC
54238  IF(iopt.EQ.1) THEN
54239  ar(1,1) = sh
54240  ar(2,2) = sh-pmas(23,1)**2
54241  ar(3,3) = sh-pmas(pycomp(ktechn+113),1)**2
54242  ar(4,4) = sh-pmas(pycomp(ktechn+223),1)**2
54243  ar(5,5) = sh-pmas(pycomp(ktechn+115),1)**2
54244  ar(1,2) = 0d0
54245  ar(2,1) = 0d0
54246  ar(1,3) = sh*far
54247  ar(3,1) = ar(1,3)
54248  ar(1,4) = sh*fao
54249  ar(4,1) = ar(1,4)
54250  ar(2,3) = sh*fzr
54251  ar(3,2) = ar(2,3)
54252  ar(2,4) = sh*fzo
54253  ar(4,2) = ar(2,4)
54254  ar(3,4) = 0d0
54255  ar(4,3) = 0d0
54256  ar(2,5) = sh*fzx
54257  ar(5,2) = ar(2,5)
54258  ar(1,5) = 0d0
54259  ar(5,1) = ar(1,5)
54260  ar(3,5) = 0d0
54261  ar(5,3) = ar(3,5)
54262  ar(4,5) = 0d0
54263  ar(5,4) = ar(4,5)
54264  CALL pywidt(23,sh,wdtp,wdte)
54265  at(2,2) = wdtp(0)*shr
54266  CALL pywidt(ktechn+113,sh,wdtp,wdte)
54267  at(3,3) = wdtp(0)*shr
54268  CALL pywidt(ktechn+223,sh,wdtp,wdte)
54269  at(4,4) = wdtp(0)*shr
54270  CALL pywidt(ktechn+115,sh,wdtp,wdte)
54271  at(5,5) = wdtp(0)*shr
54272  idim=5
54273 C...CC
54274  ELSE
54275  ar(1,1) = sh-pmas(24,1)**2
54276  ar(2,2) = sh-pmas(pycomp(ktechn+213),1)**2
54277  ar(3,3) = sh-pmas(pycomp(ktechn+215),1)**2
54278  ar(1,2) = sh*fwr
54279  ar(2,1) = ar(1,2)
54280  ar(1,3) = sh*fwx
54281  ar(3,1) = ar(1,3)
54282  ar(2,3) = 0d0
54283  ar(3,2) = 0d0
54284  CALL pywidt(24,sh,wdtp,wdte)
54285  at(1,1) = wdtp(0)*shr
54286  CALL pywidt(ktechn+213,sh,wdtp,wdte)
54287  at(2,2) = wdtp(0)*shr
54288  CALL pywidt(ktechn+215,sh,wdtp,wdte)
54289  at(3,3) = wdtp(0)*shr
54290  idim=3
54291  ENDIF
54292  CALL pyeicg(idim,idim,ar,at,wr,wi,0,zr,zi,fv1,fv2,fv3,ierr)
54293 
54294  imin=1
54295  sxmn=1d20
54296  DO 120 i=1,idim
54297  wx(i)=sqrt(abs(sh-wr(i)))
54298  wr(i)=abs(wr(i))
54299  IF(wr(i).LT.sxmn) THEN
54300  sxmn=wr(i)
54301  imin=i
54302  ENDIF
54303  120 CONTINUE
54304  smou=wx(imin)**2
54305  wido=wi(imin)/shr
54306 
54307  RETURN
54308  END
54309 C*********************************************************************
54310 
54311 C...PYXDIN
54312 C...Universal Extra Dimensions Model (UED)
54313 C...Initialize the xd masses and widths
54314 C...M. ELKACIMI 4/03/2006
54315 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54316 
54317  SUBROUTINE pyxdin
54318 
54319 C...Double precision and integer declarations.
54320  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54321  IMPLICIT INTEGER(I-N)
54322  INTEGER PYK,PYCHGE,PYCOMP
54323 C...Commonblocks.
54324  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54325  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
54326  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
54327 C...UED Pythia common
54328  common/pypued/iued(0:99),rued(0:99)
54329 
54330 C...SAVE statements
54331  SAVE /pydat1/,/pydat3/,/pysubs/,/pypued/
54332 
54333 C...Print out some info about the UED model
54334  WRITE(mstu(11),7000)
54335  & ' ',
54336  & '********** PYXDIN: initialization of UED ******************',
54337  & ' ',
54338  & 'Universal Extra Dimensions (UED) switched on ',
54339  & ' ',
54340  & 'This implementation is courtesy of',
54341  & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54342  & ' see [hep-ph/0602198] (Les Houches 2005) ',
54343  & ' ',
54344  & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54345  & 'Dobrescu), with gravity-mediated decay widths calculated in',
54346  & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54347  & 'radiative corrections to the KK masses from [hep/ph0204342]',
54348  & '(Cheng, Matchev, Schmaltz).'
54349  WRITE(mstu(11),7000)
54350  & ' ',
54351  & 'SM particles can propagate into one small extra dimension ',
54352  & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54353  & 'graviton is further allowed to propagate into N = IUED(4)',
54354  & 'large (eV^-1) extra dimensions.'
54355  WRITE(mstu(11),7000)
54356  & ' ',
54357  & 'The switches and parameters for UED are:',
54358  & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54359  & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54360  & ' IUED(3): (D=5) number of quark flavours',
54361  & ' IUED(4): (D=6) number of large extra dimensions into',
54362  & ' which the graviton propagates',
54363  & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54364  & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54365  & ' ',
54366  & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54367  & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54368  & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54369  & ' when IUED(5)=0',
54370  & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54371  WRITE(mstu(11),7000)
54372  & ' ',
54373  & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54374  & 'model, but is set through pmas(25,1).',
54375  & ' '
54376 
54377 C...Hardcoded switch, required by current implementation
54378  CALL pygive('MSTP(42)=0')
54379 
54380 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54381  IF(iued(2).EQ.0) CALL pygive('MDCY(C5100022,1)=0')
54382 
54383 C...Calculated the radiative corrections to the KK particle masses
54384  CALL pyuedc
54385 
54386 C...Initialize the graviton mass
54387 C...only if the KK particles decays gravitationally
54388  IF(iued(2).EQ.1) CALL pygram(0)
54389 
54390  WRITE(mstu(11),7000)
54391  & '********** PYXDIN: UED initialization completed ***********'
54392 
54393 C...Format to use for comments
54394  7000 FORMAT(' * ',a)
54395 
54396  RETURN
54397  END
54398 C*********************************************************************
54399 
54400 C...PYUEDC
54401 C...Auxiliary to PYXDIN
54402 C...Mass kk states radiative corrections
54403 C...Radiative corrections are included (hep/ph0204342)
54404 
54405  SUBROUTINE pyuedc
54406 
54407 C...Double precision and integer declarations.
54408  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54409  IMPLICIT INTEGER(I-N)
54410  INTEGER PYK,PYCHGE,PYCOMP
54411 
54412  parameter(kkpart=25,kkfla=450)
54413 
54414 C...UED Pythia common
54415  common/pypued/iued(0:99),rued(0:99)
54416 C...Pythia common: particles properties
54417  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54418 C...Parameters.
54419  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54420 C...Decay information.
54421  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
54422 C...Resonance width and secondary decay treatment.
54423  common/pyint4/mwid(500),wids(500,5)
54424  common/pypars/mstp(200),parp(200),msti(200),pari(200)
54425 
54426 C...Local variables
54427  DOUBLE PRECISION PI,QUP,QDW
54428  DOUBLE PRECISION WDTP,WDTE
54429  DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54430  DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54431  DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54432  DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54433  DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54434  DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54435  DOUBLE PRECISION SWW1,CWW1
54436  DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54437  DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54438  DOUBLE PRECISION SW21,CW21,SW021,CW021
54439  common/sw1/sw021,cw021
54440 C...UED related declarations:
54441 C...equivalences between ordered particles (451->475)
54442 C...and UED particle code (5 000 000 + id)
54443  dimension iuedeq(475)
54444  DATA (iuedeq(i),i=451,475)/
54445 C...Singlet quarks
54446  & 6100001,6100002,6100003,6100004,6100005,6100006,
54447 C...Doublet quarks
54448  & 5100001,5100002,5100003,5100004,5100005,5100006,
54449 C...Singlet leptons
54450  & 6100011,6100013,6100015,
54451 C...Doublet leptons
54452  & 5100012,5100011,5100014,5100013,5100016,5100015,
54453 C...Gauge boson KK excitations
54454  & 5100021,5100022,5100023,5100024/
54455 
54456 C...N.B. rinv=rued(1)
54457  IF(rued(1).LE.0.)THEN
54458  WRITE(mstu(11),*) 'PYUEDC: RINV < 0 : ',rued(1)
54459  WRITE(mstu(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54460  RETURN
54461  ENDIF
54462 
54463  pi=dacos(-1.d0)
54464  rmz = pmas(23,1)
54465  rmz2 = rmz**2
54466  rmw = pmas(24,1)
54467  rmw2 = rmw**2
54468  alphem = paru(101)
54469  qup = 2./3.
54470  qdw = -1./3.
54471 
54472 c...qt is q-tilde, qs is q-star
54473 c...strong coupling value
54474  q2 = rued(1)**2
54475  alphs=pyalps(q2)
54476 
54477 c...weak mixing angle
54478  sw2=paru(102)
54479  cw2=1d0-paru(102)
54480 
54481 c...for the mass corrections
54482  rmkk = rued(1)
54483  rmkk2 = rmkk**2
54484  zeta3= 1.2
54485 
54486 C... Either fix the cutoff scale LAMUED
54487  IF(iued(5).EQ.0)THEN
54488  loglam = dlog((rued(3)*(1./rued(1)))**2)
54489 C... or the ratio LAMUED/RINV (=product Lambda*R)
54490  ELSEIF(iued(5).EQ.1)THEN
54491  loglam = dlog(rued(4)**2)
54492  ELSE
54493  WRITE(mstu(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54494  CALL pystop(6000)
54495  ENDIF
54496 
54497 C...Calculate the radiative corrections for the UED KK masses
54498  IF(iued(6).EQ.1)THEN
54499  rfact=1.d0
54500 C...or induce a minute mass difference
54501 C...keeping the UED KK mass values nearly equal to 1/R
54502  ELSEIF(iued(6).EQ.0)THEN
54503  rfact=0.01d0
54504  ELSE
54505  WRITE(mstu(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54506  CALL pystop(6001)
54507  ENDIF
54508 
54509 c...Take into account only the strong interactions:
54510 
54511 c...The space bulk corrections :
54512  dsmg2 = rmkk2*(-1.5)*(alphs/4./pi)*zeta3/pi**2
54513 c...The boundary terms:
54514  dbmg2 = rmkk2*(23./2.)*(alphs/4./pi)*loglam
54515 
54516 c...Mass corrections for fermions are extracted from
54517 c...Phys. Rev. D66 036005(2002)9
54518  dbmqdo=rmkk*(3.*(alphs/4./pi)+27./16.*(alphem/4./pi/sw2)
54519  . +1./16.*(alphem/4./pi/cw2))*loglam
54520  dbmqu=rmkk*(3.*(alphs/4./pi)
54521  . +(alphem/4./pi/cw2))*loglam
54522  dbmqd=rmkk*(3.*(alphs/4./pi)
54523  . +0.25*(alphem/4./pi/cw2))*loglam
54524 
54525  dbmldo=rmkk *((27./16.)*(alphem/4./pi/sw2)+9./16.*
54526  . (alphem/4./pi/cw2))*loglam
54527  dbmle=rmkk *(9./4.*(alphem/4./pi/cw2))*loglam
54528 
54529 c...Vector boson masss matrix diagonalization
54530  dbmb2 = rmkk2*(-1./6.)*(alphem/4./pi/cw2)*loglam
54531  dsmb2 = rmkk2*(-39./2.)*(alphem/4./pi**3/cw2)*zeta3
54532  dbma2 = rmkk2*(15./2.)*(alphem/4./pi/sw2)*loglam
54533  dsma2 = rmkk2*(-5./2.)*(alphem/4./pi**3/sw2)*zeta3
54534 
54535 c...Elements of the mass matrix
54536  a = rmz2*sw2 + dbmb2 + dsmb2
54537  b = rmz2*cw2 + dbma2 + dsma2
54538  c = rmz2*dsqrt(sw2*cw2)
54539  sqrdel = dsqrt( (a-b)**2 + 4*c**2 )
54540 
54541 c...Eigenvalues: corrections to X1 and Z1 masses
54542  dmb2 = (a+b-sqrdel)/2.
54543  dma2 = (a+b+sqrdel)/2.
54544 
54545 c...Rotation angles
54546  sww1 = 2*c
54547  cww1 = a-b-sqrdel
54548 C...Weinberg angle
54549  sw21= sww1**2/(sww1**2 + cww1**2)
54550  cw21= 1. - sw21
54551 
54552  sw021=sw21
54553  cw021=cw21
54554 
54555 c...Masses:
54556  rmgst = rmkk+rfact*(dsqrt(rmkk2 + dsmg2 + dbmg2)-rmkk)
54557 
54558  rmdqst=rmkk+rfact*dbmqdo
54559  rmsqus=rmkk+rfact*dbmqu
54560  rmsqds=rmkk+rfact*dbmqd
54561 
54562 C...Note: MZ mass is included in ma2
54563  rmphst= rmkk+rfact*(dsqrt(rmkk2 + dmb2)-rmkk)
54564  rmzst = rmkk+rfact*(dsqrt(rmkk2 + dma2)-rmkk)
54565  rmwst = rmkk+rfact*(dsqrt(rmkk2 + dbma2 + dsma2 + rmw**2)-rmkk)
54566 
54567  rmlsld=rmkk+rfact*dbmldo
54568  rmlsle=rmkk+rfact*dbmle
54569 
54570  DO 100 ipart=1,5,2
54571  pmas(kkfla+ipart,1)=rmsqds
54572  100 CONTINUE
54573  DO 110 ipart=2,6,2
54574  pmas(kkfla+ipart,1)=rmsqus
54575  110 CONTINUE
54576  DO 120 ipart=7,12
54577  pmas(kkfla+ipart,1)=rmdqst
54578  120 CONTINUE
54579  DO 130 ipart=13,15
54580  pmas(kkfla+ipart,1)=rmlsle
54581  130 CONTINUE
54582  DO 140 ipart=16,21
54583  pmas(kkfla+ipart,1)=rmlsld
54584  140 CONTINUE
54585  pmas(kkfla+22,1)=rmgst
54586  pmas(kkfla+23,1)=rmphst
54587  pmas(kkfla+24,1)=rmzst
54588  pmas(kkfla+25,1)=rmwst
54589 
54590  WRITE(mstu(11),7000) ' PYUEDC: ',
54591  & 'UED Mass Spectrum (GeV) :'
54592  WRITE(mstu(11),7100) ' m(d*_S,s*_S,b*_S) = ',rmsqds
54593  WRITE(mstu(11),7100) ' m(u*_S,c*_S,t*_S) = ',rmsqus
54594  WRITE(mstu(11),7100) ' m(q*_D) = ',rmdqst
54595  WRITE(mstu(11),7100) ' m(l*_S) = ',rmlsle
54596  WRITE(mstu(11),7100) ' m(l*_D) = ',rmlsld
54597  WRITE(mstu(11),7100) ' m(g*) = ',rmgst
54598  WRITE(mstu(11),7100) ' m(gamma*) = ',rmphst
54599  WRITE(mstu(11),7100) ' m(Z*) = ',rmzst
54600  WRITE(mstu(11),7100) ' m(W*) = ',rmwst
54601  WRITE(mstu(11),7000) ' '
54602 
54603 C...Initialize widths, branching ratios and life time
54604  DO 199 ipart=1,25
54605  kc=kkfla+ipart
54606  IF(mwid(kc).EQ.1.AND.mdcy(kc,1).EQ.1)THEN
54607  CALL pywidt(iuedeq(kc),pmas(kc,1)**2,wdtp,wdte)
54608  IF(wdtp(0).LE.0)THEN
54609  WRITE(mstu(11),*)
54610  + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', kc
54611  WRITE(mstu(11),*) 'INITIAL VALUE IS TAKEN',pmas(kc,2)
54612  GOTO 199
54613  ELSE
54614  DO 180 idc=1,mdcy(kc,3)
54615  ic=idc+mdcy(kc,2)-1
54616  IF(mdme(ic,1).EQ.1.AND.wdtp(idc).GT.0.)THEN
54617 C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54618  pmas(kc,4)=paru(3)/wdtp(idc)*1.d-12
54619  brat(ic)=wdtp(idc)/wdtp(0)
54620  ENDIF
54621  180 CONTINUE
54622  ENDIF
54623  ENDIF
54624  199 CONTINUE
54625 
54626 C...Format to use for comments
54627  7000 FORMAT(' * ',a)
54628  7100 FORMAT(' * ',a,f12.3)
54629 
54630  END
54631 C********************************************************************
54632 C...PYXUED
54633 C... Last change:
54634 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54635 C... Original version:
54636 C... M. El Kacimi
54637 C... 05/07/2005
54638 C Universal Extra Dimensions Subprocess cross sections
54639 C The expressions used are from atl-com-phys-2005-003
54640 C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54641 C For each UED subprocess, the color flow used is the same
54642 C as the equivalent QCD subprocess. Different configuration
54643 C color flows are considered to have the same probability.
54644 C
54645 C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54646 C by G.Azuelos and P.H.Beauchemin.
54647 C
54648 C This routine is called from pysigh.
54649 
54650  SUBROUTINE pyxued(NCHN,SIGS)
54651 
54652 C...Double precision and integer declarations
54653  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54654  IMPLICIT INTEGER(I-N)
54655 C...
54656  INTEGER NGRDEC
54657  common/decmod/ngrdec
54658 C...
54659  parameter(kkpart=25,kkfla=450)
54660 C...Commonblocks
54661  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54662  common/pypars/mstp(200),parp(200),msti(200),pari(200)
54663  common/pyint1/mint(400),vint(400)
54664  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
54665  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
54666  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
54667  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
54668  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
54669  SAVE /pydat2/,/pyint1/,/pyint3/,/pypars/
54670 C...UED Pythia common
54671  common/pypued/iued(0:99),rued(0:99)
54672 C...Local arrays and complex variables
54673  DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54674  + ,FAC1,XMNKK,XMUED,SIGS
54675  INTEGER NCHN
54676 
54677 C...Return if UED not switched on
54678  IF (iued(1).LE.0) THEN
54679  RETURN
54680  ENDIF
54681 
54682 C...Energy scale of the parton processus
54683 C...taken equal to the mass of the final state kk
54684 c Q2=XMNKK**2
54685 
54686 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54687  xmnkk=pmas(kkfla+23,1)
54688 
54689 C...To compare the cross section with phys-pub-2005-03
54690 C...(no radiative corrections),
54691 C...take xmnkk=rinv and q2=rinv**2
54692 c++lnk
54693 C...n.b. (rinv=rued(1))
54694 c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54695  IF(ngrdec.EQ.1)xmnkk=rued(1)
54696 c--lnk
54697 
54698  shat=vint(44)
54699  sp=shat
54700  that=vint(45)
54701  tp=that-xmnkk**2
54702  uhat=vint(46)
54703  up=uhat-xmnkk**2
54704  beta34=dsqrt(1.d0-4.d0*xmnkk**2/shat)
54705  pi=dacos(-1.d0)
54706 c++lnk
54707 c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54708  q2=rued(1)**2+(tp*up-rued(1)**4)/sp
54709 
54710 c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54711  IF(ngrdec.EQ.1)q2=rued(1)**2
54712 c--lnk
54713 
54714 C...Strong coupling value
54715  alphas=pyalps(q2)
54716 
54717  IF(isub.EQ.311)THEN
54718 C...gg --> g* g*
54719  fac1=9./8.*alphas**2/(sp*tp*up)**2
54720  xmued=fac1*(xmnkk**4*(6.*tp**4+18.*tp**3*up+
54721  & 24.*tp**2*up**2+18.*tp*up**3+6.*up**4)
54722  & +xmnkk**2*(6.*tp**4*up+12.*tp**3*up**2+
54723  & 12.*tp**2*up**3+6*tp*up**4)
54724  & +2.*tp**6+6*tp**5*up+13*tp**4*up**2+
54725  & 15.*tp**3*up**3+13*tp**2*up**4+
54726  & 6.*tp*up**5+2.*up**6)
54727  nchn=nchn+1
54728  isig(nchn,1)=21
54729  isig(nchn,2)=21
54730 C...Three color flow configurations (qcd g+g->g+g)
54731  xcol=pyr(0)
54732  IF(xcol.LE.1./3.)THEN
54733  isig(nchn,3)=1
54734  ELSEIF(xcol.LE.2./3.)THEN
54735  isig(nchn,3)=2
54736  ELSE
54737  isig(nchn,3)=3
54738  ENDIF
54739  sigh(nchn)=comfac*xmued
54740  ELSEIF(isub.EQ.312)THEN
54741 C...q + g -> q*_D + g*, q*_S + g*
54742 C...(the two channels have the same cross section)
54743  fac1=-1./36.*alphas**2/(sp*tp*up)**2
54744  xmued=fac1*(12.*sp*up**5+5.*sp**2*up**4+22.*sp**3*up**3+
54745  & 5.*sp**4*up**2+12.*sp**5*up)
54746  xmued=comfac*2.*xmued
54747 
54748  DO 190 i=mmina,mmaxa
54749  IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 190
54750  DO 180 isde=1,2
54751 
54752  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 180
54753  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 180
54754  nchn=nchn+1
54755  isig(nchn,isde)=i
54756  isig(nchn,3-isde)=21
54757  isig(nchn,3)=1
54758  sigh(nchn)=xmued
54759  IF(pyr(0).GT.0.5)isig(nchn,3)=2
54760  180 CONTINUE
54761  190 CONTINUE
54762 
54763  ELSEIF(isub.EQ.313)THEN
54764 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54765 C...(the two channels have the same cross section)
54766 C...qi and qj have the same charge sign
54767  DO 100 i=mmin1,mmax1
54768  ia=iabs(i)
54769  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 100
54770  DO 101 j=mmin2,mmax2
54771  ja=iabs(j)
54772  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).
54773  & eq.0) GOTO 101
54774  IF(j*i.LE.0)GOTO 101
54775  nchn=nchn+1
54776  isig(nchn,1)=i
54777  isig(nchn,2)=j
54778  IF(j.EQ.i)THEN
54779  fac1=1./72.*alphas**2/(tp*up)**2
54780  xmued=fac1*
54781  & (xmnkk**2*(8*tp**3+4./3.*tp**2*up+4./3.*tp*up**2
54782  & +8.*up**3)+8.*tp**4+56./3.*tp**3*up+
54783  & 20.*tp**2*up**2+56./3.*
54784  & tp*up**3+8.*up**4)
54785  sigh(nchn)=comfac*2.*xmued
54786  isig(nchn,3)=1
54787  IF(pyr(0).GT.0.5)isig(nchn,3)=2
54788  ELSE
54789  fac1=2./9.*alphas**2/tp**2
54790  xmued=fac1*(-xmnkk**2*sp+sp**2+0.25*tp**2)
54791  sigh(nchn)=comfac*2.*xmued
54792  isig(nchn,3)=1
54793  ENDIF
54794  101 CONTINUE
54795  100 CONTINUE
54796  ELSEIF(isub.EQ.314)THEN
54797 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54798 C...(the two channels have the same cross section)
54799  nchn=nchn+1
54800  isig(nchn,1)=21
54801  isig(nchn,2)=21
54802  isig(nchn,3)=int(1.5+pyr(0))
54803 
54804  fac1=5./6.*alphas**2/(sp*tp*up)**2
54805  xmued=fac1*(-xmnkk**4*(8.*tp*up**3+8.*tp**2*up**2+8.*tp**3*up
54806  + +4.*up**4+4*tp**4)
54807  + -xmnkk**2*(0.5*tp*up**4+4.*tp**2*up**3+15./2.*tp**3
54808  + *up**2+ 4.*tp**4*up)+tp*up**5-0.25*tp**2*up**4+
54809  + 2.*tp**3*up**3-0.25*tp**4*up**2+tp**5*up)
54810 
54811  sigh(nchn)=comfac*xmued
54812 C...has been multiplied by 5: all possible quark flavors in final state
54813 
54814  ELSEIF(isub.EQ.315)THEN
54815 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54816 C...(the two channels have the same cross section)
54817  DO 141 i=mmin1,mmax1
54818  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
54819  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 141
54820  DO 142 j=mmin2,mmax2
54821  IF(j.EQ.0.OR.abs(i).NE.abs(j).OR.i*j.GE.0) GOTO 142
54822  fac1=2./9.*alphas**2*1./(sp*tp)**2
54823  xmued=fac1*(xmnkk**2*sp*(4.*tp**2-sp*tp-sp**2)+
54824  & 4.*tp**4+3.*sp*tp**3+11./12.*tp**2*sp**2-
54825  & 2./3.*sp**3*tp+sp**4)
54826  nchn=nchn+1
54827  isig(nchn,1)=i
54828  isig(nchn,2)=-i
54829  isig(nchn,3)=1
54830  sigh(nchn)=comfac*2.*xmued
54831  142 CONTINUE
54832  141 CONTINUE
54833  ELSEIF(isub.EQ.316)THEN
54834 C...q + qbar' -> q*_D + q*_Sbar'
54835  fac1=2./9.*alphas**2
54836  DO 300 i=mmin1,mmax1
54837  ia=iabs(i)
54838  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 300
54839  DO 301 j=mmin2,mmax2
54840  ja=iabs(j)
54841  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 301
54842  IF(j*i.GE.0.OR.ia.EQ.ja)GOTO 301
54843  nchn=nchn+1
54844  isig(nchn,1)=i
54845  isig(nchn,2)=j
54846  isig(nchn,3)=1
54847  fac1=2./9.*alphas**2/tp**2
54848  xmued=fac1*(-xmnkk**2*sp+sp**2+0.25*tp**2)
54849  sigh(nchn)=comfac*xmued
54850  301 CONTINUE
54851  300 CONTINUE
54852 
54853  ELSEIF(isub.EQ.317)THEN
54854 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54855 C...(the two channels have the same cross section)
54856  DO 400 i=mmin1,mmax1
54857  ia=iabs(i)
54858  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 400
54859  DO 401 j=mmin1,mmax1
54860  ja=iabs(j)
54861  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 401
54862  IF(j*i.GE.0.OR.ia.EQ.ja)GOTO 401
54863  nchn=nchn+1
54864  isig(nchn,1)=i
54865  isig(nchn,2)=j
54866  isig(nchn,3)=1
54867  fac1=1./18.*alphas**2/tp**2
54868  xmued=fac1*(4.*xmnkk**2*sp+4.*sp**2+8.*sp*tp+5*tp**2)
54869  sigh(nchn)=comfac*2.*xmued
54870  401 CONTINUE
54871  400 CONTINUE
54872  ELSEIF(isub.EQ.318)THEN
54873 C...q + q' -> q*_D + q*_S'
54874  DO 500 i=mmin1,mmax1
54875  ia=iabs(i)
54876  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 500
54877  DO 501 j=mmin2,mmax2
54878  ja=iabs(j)
54879  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 501
54880  IF(j*i.LE.0)GOTO 501
54881  IF(ia.EQ.ja)THEN
54882  nchn=nchn+1
54883  isig(nchn,1)=i
54884  isig(nchn,2)=j
54885  isig(nchn,3)=int(1.5+pyr(0))
54886  fac1=1./36.*alphas**2/(tp*up)**2
54887  xmued=fac1*(-8.*xmnkk**2*(tp**3+tp**2*up+tp*up**2+up**3)
54888  & +8.*tp**4+4.*tp**2*up**2+8.*up**4)
54889  sigh(nchn)=comfac*xmued
54890  ELSE
54891  nchn=nchn+1
54892  isig(nchn,1)=i
54893  isig(nchn,2)=j
54894  isig(nchn,3)=1
54895  fac1=1./18.*alphas**2/tp**2
54896  xmued=fac1*(4.*xmnkk**2*sp+4.*sp**2+8.*sp*tp+5*tp**2)
54897  sigh(nchn)=comfac*2.*xmued
54898  ENDIF
54899  501 CONTINUE
54900  500 CONTINUE
54901  ELSEIF(isub.EQ.319)THEN
54902 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
54903 C...(the two channels have the same cross section)
54904  DO 741 i=mmin1,mmax1
54905  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
54906  & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 741
54907  DO 742 j=mmin2,mmax2
54908  IF(j.EQ.0.OR.iabs(j).NE.iabs(i).OR.j*i.GT.0) GOTO 742
54909  fac1=16./9.*alphas**2*1./(sp)**2
54910  xmued=fac1*(2.*xmnkk**2*sp+sp**2+2.*sp*tp+2.*tp**2)
54911  nchn=nchn+1
54912  isig(nchn,1)=i
54913  isig(nchn,2)=-i
54914  isig(nchn,3)=1
54915  sigh(nchn)=comfac*2.*xmued
54916  742 CONTINUE
54917  741 CONTINUE
54918 
54919  ENDIF
54920 
54921  RETURN
54922  END
54923 C*********************************************************************
54924 
54925 C...PYGRAM
54926 C...Universal Extra Dimensions Model (UED)
54927 C...Computation of the Graviton mass.
54928 
54929  SUBROUTINE pygram(IN)
54930 
54931 C...Double precision and integer declarations
54932  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54933  IMPLICIT INTEGER(I-N)
54934 
54935 C...Pythia commonblocks
54936  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54937  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54938 C...UED Pythia common
54939  common/pypued/iued(0:99),rued(0:99)
54940 
54941 C...Local variables
54942  INTEGER KCFLA,NMAX
54943  parameter(kcfla=450,nmax=5000)
54944  dimension yvec(5000),resvec(5000)
54945  common/intsav/ysav,ymax,resmax
54946  common/uedgra/xmplnk,xmd,rinv,ndim
54947  common/kappa/xkappa
54948 
54949 C...External function (used in call to PYGAUS)
54950  EXTERNAL pygraw
54951 
54952 C...SAVE statements
54953  SAVE /pydat1/,/pydat2/,/pypued/,/intsav/
54954 
54955 C...Initialization
54956  ndim=iued(4)
54957  rinv=rued(1)
54958  xmd=rued(2)
54959  pi=paru(1)
54960 
54961 C...Initialize for numerical integration
54962  xmplnk=2.4d+18
54963  xkappa=dsqrt(2.d0)/xmplnk
54964 
54965 C...For NDIM=2, compute graviton mass distribution numerically
54966  IF(ndim.EQ.2)THEN
54967 
54968 C... For first event: tabulate distribution of stepwise integrals:
54969 C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
54970  IF(in.EQ.0)THEN
54971  resmax = 0d0
54972  ymax = 0d0
54973  DO 100 i=1,nmax
54974  ysav = (i-0.5)/dble(nmax)
54975  tol = 1d-6
54976 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
54977  resint = pygaus(pygraw,0d0,1d0,tol)
54978  yvec(i) = ysav
54979  resvec(i) = resint
54980 C... Save max of distribution (for accept/reject below)
54981  IF(resint.GT.resmax)THEN
54982  resmax = resint
54983  ymax = yvec(i)
54984  ENDIF
54985  100 CONTINUE
54986  ENDIF
54987 
54988 C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
54989  pcujet=1d0
54990  kcgakk=kcfla+23
54991  xmgamk=pmas(kcgakk,1)
54992 
54993 C... Pick random graviton mass, accept according to stored integrals
54994  ammax=dsqrt(xmgamk**2-2d0*xmgamk*pcujet)
54995  110 rmg=ammax*pyr(0)
54996  x=rmg/xmgamk
54997 
54998 C... Bin enumeration starts at 1, but make sure always in range
54999  ibin=int(nmax*x)+1
55000  ibin=min(ibin,nmax)
55001  IF(resvec(ibin)/resmax.LT.pyr(0)) GOTO 110
55002 
55003 C... For NDIM=4 and 6, the analytical expression for the
55004 C... graviton mass distribution integral is used.
55005  ELSEIF(ndim.EQ.4.OR.ndim.EQ.6)THEN
55006 
55007 C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55008  pcujet=1d0
55009 
55010 C... KK photon (?) compressed code and mass
55011  kcgakk=kcfla+23
55012  xmgamk=pmas(kcgakk,1)
55013 
55014 C... Find maximum of (dGamma/dMg)
55015  IF(in.EQ.0)THEN
55016  resmax=0d0
55017  ymax=0d0
55018  DO 120 i=1,nmax-1
55019  y=i/dble(nmax)
55020  resint=y**(ndim-3)*(1d0/(1d0-y**2))*(1d0+dcos(pi*y))
55021  IF(resint.GE.resmax)THEN
55022  resmax=resint
55023  ymax=y
55024  ENDIF
55025  120 CONTINUE
55026  ENDIF
55027 
55028 C... Pick random graviton mass, accept/reject
55029  ammax=dsqrt(xmgamk**2-2d0*xmgamk*pcujet)
55030  130 rmg=ammax*pyr(0)
55031  x=rmg/xmgamk
55032  dgadmg=x**(ndim-3)*(1./(1.-x**2))*(1.+dcos(pi*x))
55033  IF(dgadmg/resmax.LT.pyr(0)) GOTO 130
55034 
55035 C... If the user has not chosen N=2,4 or 6, STOP
55036  ELSE
55037  WRITE(mstu(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',ndim,
55038  & ' (MUST BE 2, 4, OR 6) '
55039  CALL pystop(6002)
55040  ENDIF
55041 
55042 C... Now store the sampled Mg
55043  pmas(39,1)=rmg
55044 
55045  RETURN
55046  END
55047 
55048 C*********************************************************************
55049 
55050 C...PYGRAW
55051 C...Universal Extra Dimensions Model (UED)
55052 C...
55053 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55054 C...
55055 C...Integrand for the KK boson -> SM boson + graviton
55056 C...graviton mass distribution (and gravity mediated total width),
55057 C...which contains (see 0201300 and below for the full product)
55058 C...the gravity mediated partial decay width Gamma(xx, yy)
55059 C... i.e. GRADEN(YY)*PYWDKK(XXA)
55060 C... where xx is exclusive to gravity
55061 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55062 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55063 
55064  DOUBLE PRECISION FUNCTION pygraw(YIN)
55065 
55066 C...Double precision and integer declarations
55067  IMPLICIT DOUBLE PRECISION (a-h,o-z)
55068  IMPLICIT INTEGER (I-N)
55069 
55070 C...Pythia commonblocks
55071  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55072 
55073 C...Local UED commonblocks and variables
55074  common/uedgra/xmplnk,xmd,rinv,ndim
55075  common/intsav/ysav,ymax,resmax
55076 
55077 C...SAVE statements
55078  SAVE /pydat1/,/intsav/
55079 
55080 C...External: Pythia's Gamma function
55081  EXTERNAL pygamm
55082 
55083 C...Pi
55084  pi=paru(1)
55085  pi2=pi*pi
55086 
55087  ymin=1.d-9/rinv
55088  yy=ysav
55089  xx=dsqrt(1.-yy**2)*yin
55090  djac=(1.-ymin)*dsqrt(1.-yy**2)
55091  fac=2.*pi**((ndim-1.)/2.)*xmplnk**2*rinv**ndim/xmd**(ndim+2)
55092  xnd=(ndim-1.)/2.
55093  gammn=pygamm(xnd)
55094  fac=fac/gammn
55095  xxa=dsqrt(xx**2+yy**2)
55096  graden=4./pi2 * (yy**2/(1.-yy**2)**2)*(1.+dcos(pi*yy))
55097 
55098  pygraw=djac*
55099  + fac*xx**(ndim-2)*graden*pywdkk(xxa)
55100 
55101  RETURN
55102  END
55103 C*********************************************************************
55104 
55105 C...PYWDKK
55106 C...Universal Extra Dimensions Model (UED)
55107 C...
55108 C...Multiplied by the square modulus of a form factor
55109 C...(see GRADEN in function PYGRAW)
55110 C...PYWDKK is the KK boson -> SM boson + graviton
55111 C...gravity mediated partial decay width Gamma(xx, yy)
55112 C... where xx is exclusive to gravity
55113 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55114 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55115 C...
55116 C...N.B. The Feynman rules for the couplings of the graviton fields
55117 C...to the UED fields are related to the corresponding couplings of
55118 C...the graviton fields to the SM fields by the form factor.
55119 
55120  DOUBLE PRECISION FUNCTION pywdkk(X)
55121 
55122 C...Double precision and integer declarations
55123  IMPLICIT DOUBLE PRECISION (a-h,o-z)
55124  IMPLICIT INTEGER (I-N)
55125 
55126 C...Pythia commonblocks
55127  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55128  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
55129 
55130 C...Local UED commonblocks and variables
55131  common/uedgra/xmplnk,xmd,rinv,ndim
55132  common/kappa/xkappa
55133 
55134 C...SAVE statements
55135  SAVE /pydat1/,/pydat2/,/uedgra/,/kappa/
55136 
55137  pi=paru(1)
55138 
55139 C...gamma* mass 473
55140  kcqkk=473
55141  xmnkk=pmas(kcqkk,1)
55142 
55143 C...Bosons partial width Macesanu hep-ph/0201300
55144  pywdkk=xkappa**2/(96.*pi)*xmnkk**3/x**4*
55145  + ((1.-x**2)**2*(1.+3.*x**2+6.*x**4))
55146 
55147  RETURN
55148  END
55149 
55150 C*********************************************************************
55151 
55152 C...PYEIGC
55153 C...Finds eigenvalues of a general complex matrix
55154 C
55155 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55156 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55157 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55158 C OF A COMPLEX GENERAL MATRIX.
55159 C
55160 C ON INPUT
55161 C
55162 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55163 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55164 C DIMENSION STATEMENT.
55165 C
55166 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55167 C
55168 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55169 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55170 C
55171 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55172 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55173 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55174 C
55175 C ON OUTPUT
55176 C
55177 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55178 C RESPECTIVELY, OF THE EIGENVALUES.
55179 C
55180 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55181 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55182 C
55183 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55184 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55185 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55186 C
55187 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55188 C
55189 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55190 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55191 C
55192 C THIS VERSION DATED AUGUST 1983.
55193 C
55194 
55195  SUBROUTINE pyeicg(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55196 
55197  INTEGER N,NM,IS1,IS2,IERR,MATZ
55198  DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55199  x fv1(5),fv2(5),fv3(5)
55200  IF (n .LE. nm) GOTO 100
55201  ierr = 10 * n
55202  GOTO 120
55203 C
55204  100 CALL pycbal(nm,n,ar,ai,is1,is2,fv1)
55205  CALL pycrth(nm,n,is1,is2,ar,ai,fv2,fv3)
55206  IF (matz .NE. 0) GOTO 110
55207 C .......... FIND EIGENVALUES ONLY ..........
55208  CALL pycmqr(nm,n,is1,is2,ar,ai,wr,wi,ierr)
55209  GOTO 120
55210 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55211  110 CALL pycmq2(nm,n,is1,is2,fv2,fv3,ar,ai,wr,wi,zr,zi,ierr)
55212  IF (ierr .NE. 0) GOTO 120
55213  CALL pycba2(nm,n,is1,is2,fv1,n,zr,zi)
55214  120 RETURN
55215  END
55216 
55217 C*********************************************************************
55218 
55219 C...PYCMQR
55220 C...Auxiliary to PYEICG.
55221 C
55222 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55223 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55224 C AND WILKINSON.
55225 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55226 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55227 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55228 C
55229 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55230 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55231 C
55232 C ON INPUT
55233 C
55234 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55235 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55236 C DIMENSION STATEMENT.
55237 C
55238 C N IS THE ORDER OF THE MATRIX.
55239 C
55240 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55241 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55242 C SET LOW=1, IGH=N.
55243 C
55244 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55245 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55246 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55247 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55248 C THE REDUCTION BY CORTH, IF PERFORMED.
55249 C
55250 C ON OUTPUT
55251 C
55252 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55253 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55254 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55255 C EIGENVECTORS IS TO BE PERFORMED.
55256 C
55257 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55258 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55259 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55260 C FOR INDICES IERR+1,...,N.
55261 C
55262 C IERR IS SET TO
55263 C ZERO FOR NORMAL RETURN,
55264 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55265 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55266 C
55267 C CALLS PYCDIV FOR COMPLEX DIVISION.
55268 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55269 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55270 C
55271 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55272 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55273 C
55274 C THIS VERSION DATED AUGUST 1983.
55275 C
55276 
55277  SUBROUTINE pycmqr(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55278 
55279  INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55280  DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55281  DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55282  X PYTHAG
55283 
55284  ierr = 0
55285  IF (low .EQ. igh) GOTO 130
55286 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55287  l = low + 1
55288 C
55289  DO 120 i = l, igh
55290  ll = min0(i+1,igh)
55291  IF (hi(i,i-1) .EQ. 0.0d0) GOTO 120
55292  norm = pythag(hr(i,i-1),hi(i,i-1))
55293  yr = hr(i,i-1) / norm
55294  yi = hi(i,i-1) / norm
55295  hr(i,i-1) = norm
55296  hi(i,i-1) = 0.0d0
55297 C
55298  DO 100 j = i, igh
55299  si = yr * hi(i,j) - yi * hr(i,j)
55300  hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
55301  hi(i,j) = si
55302  100 CONTINUE
55303 C
55304  DO 110 j = low, ll
55305  si = yr * hi(j,i) + yi * hr(j,i)
55306  hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
55307  hi(j,i) = si
55308  110 CONTINUE
55309 C
55310  120 CONTINUE
55311 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55312  130 DO 140 i = 1, n
55313  IF (i .GE. low .AND. i .LE. igh) GOTO 140
55314  wr(i) = hr(i,i)
55315  wi(i) = hi(i,i)
55316  140 CONTINUE
55317 C
55318  en = igh
55319  tr = 0.0d0
55320  ti = 0.0d0
55321  itn = 30*n
55322 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55323  150 IF (en .LT. low) GOTO 320
55324  its = 0
55325  enm1 = en - 1
55326 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55327 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55328  160 DO 170 ll = low, en
55329  l = en + low - ll
55330  IF (l .EQ. low) GOTO 180
55331  tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
55332  x + dabs(hr(l,l)) + dabs(hi(l,l))
55333  tst2 = tst1 + dabs(hr(l,l-1))
55334  IF (tst2 .EQ. tst1) GOTO 180
55335  170 CONTINUE
55336 C .......... FORM SHIFT ..........
55337  180 IF (l .EQ. en) GOTO 300
55338  IF (itn .EQ. 0) GOTO 310
55339  IF (its .EQ. 10 .OR. its .EQ. 20) GOTO 200
55340  sr = hr(en,en)
55341  si = hi(en,en)
55342  xr = hr(enm1,en) * hr(en,enm1)
55343  xi = hi(enm1,en) * hr(en,enm1)
55344  IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) GOTO 210
55345  yr = (hr(enm1,enm1) - sr) / 2.0d0
55346  yi = (hi(enm1,enm1) - si) / 2.0d0
55347  CALL pycsrt(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
55348  IF (yr * zzr + yi * zzi .GE. 0.0d0) GOTO 190
55349  zzr = -zzr
55350  zzi = -zzi
55351  190 CALL pycdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
55352  sr = sr - xr
55353  si = si - xi
55354  GOTO 210
55355 C .......... FORM EXCEPTIONAL SHIFT ..........
55356  200 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
55357  si = 0.0d0
55358 C
55359  210 DO 220 i = low, en
55360  hr(i,i) = hr(i,i) - sr
55361  hi(i,i) = hi(i,i) - si
55362  220 CONTINUE
55363 C
55364  tr = tr + sr
55365  ti = ti + si
55366  its = its + 1
55367  itn = itn - 1
55368 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55369  lp1 = l + 1
55370 C
55371  DO 240 i = lp1, en
55372  sr = hr(i,i-1)
55373  hr(i,i-1) = 0.0d0
55374  norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
55375  xr = hr(i-1,i-1) / norm
55376  wr(i-1) = xr
55377  xi = hi(i-1,i-1) / norm
55378  wi(i-1) = xi
55379  hr(i-1,i-1) = norm
55380  hi(i-1,i-1) = 0.0d0
55381  hi(i,i-1) = sr / norm
55382 C
55383  DO 230 j = i, en
55384  yr = hr(i-1,j)
55385  yi = hi(i-1,j)
55386  zzr = hr(i,j)
55387  zzi = hi(i,j)
55388  hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
55389  hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
55390  hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
55391  hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
55392  230 CONTINUE
55393 C
55394  240 CONTINUE
55395 C
55396  si = hi(en,en)
55397  IF (si .EQ. 0.0d0) GOTO 250
55398  norm = pythag(hr(en,en),si)
55399  sr = hr(en,en) / norm
55400  si = si / norm
55401  hr(en,en) = norm
55402  hi(en,en) = 0.0d0
55403 C .......... INVERSE OPERATION (COLUMNS) ..........
55404  250 DO 280 j = lp1, en
55405  xr = wr(j-1)
55406  xi = wi(j-1)
55407 C
55408  DO 270 i = l, j
55409  yr = hr(i,j-1)
55410  yi = 0.0d0
55411  zzr = hr(i,j)
55412  zzi = hi(i,j)
55413  IF (i .EQ. j) GOTO 260
55414  yi = hi(i,j-1)
55415  hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
55416  260 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
55417  hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
55418  hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
55419  270 CONTINUE
55420 C
55421  280 CONTINUE
55422 C
55423  IF (si .EQ. 0.0d0) GOTO 160
55424 C
55425  DO 290 i = l, en
55426  yr = hr(i,en)
55427  yi = hi(i,en)
55428  hr(i,en) = sr * yr - si * yi
55429  hi(i,en) = sr * yi + si * yr
55430  290 CONTINUE
55431 C
55432  GOTO 160
55433 C .......... A ROOT FOUND ..........
55434  300 wr(en) = hr(en,en) + tr
55435  wi(en) = hi(en,en) + ti
55436  en = enm1
55437  GOTO 150
55438 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55439 C CONVERGED AFTER 30*N ITERATIONS ..........
55440  310 ierr = en
55441  320 RETURN
55442  END
55443 
55444 C*********************************************************************
55445 
55446 C...PYCMQ2
55447 C...Auxiliary to PYEICG.
55448 C
55449 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55450 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55451 C AND WILKINSON.
55452 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55453 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55454 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55455 C
55456 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55457 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55458 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55459 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55460 C THIS GENERAL MATRIX TO HESSENBERG FORM.
55461 C
55462 C ON INPUT
55463 C
55464 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55465 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55466 C DIMENSION STATEMENT.
55467 C
55468 C N IS THE ORDER OF THE MATRIX.
55469 C
55470 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55471 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55472 C SET LOW=1, IGH=N.
55473 C
55474 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55475 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55476 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55477 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55478 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55479 C
55480 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55481 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55482 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55483 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55484 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55485 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55486 C ARBITRARY.
55487 C
55488 C ON OUTPUT
55489 C
55490 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55491 C HAVE BEEN DESTROYED.
55492 C
55493 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55494 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55495 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55496 C FOR INDICES IERR+1,...,N.
55497 C
55498 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55499 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55500 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55501 C THE EIGENVECTORS HAS BEEN FOUND.
55502 C
55503 C IERR IS SET TO
55504 C ZERO FOR NORMAL RETURN,
55505 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55506 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55507 C
55508 C CALLS PYCDIV FOR COMPLEX DIVISION.
55509 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55510 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55511 C
55512 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55513 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55514 C
55515 C THIS VERSION DATED OCTOBER 1989.
55516 C
55517 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55518 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55519 C
55520 
55521  SUBROUTINE pycmq2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55522 
55523  INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55524  X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55525  DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55526  X ORTR(5),ORTI(5)
55527  DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55528  X PYTHAG
55529 
55530  ierr = 0
55531 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55532  DO 110 j = 1, n
55533 C
55534  DO 100 i = 1, n
55535  zr(i,j) = 0.0d0
55536  zi(i,j) = 0.0d0
55537  100 CONTINUE
55538  zr(j,j) = 1.0d0
55539  110 CONTINUE
55540 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55541 C FROM THE INFORMATION LEFT BY CORTH ..........
55542  iend = igh - low - 1
55543  IF (iend.LT.0) GOTO 220
55544  IF (iend.EQ.0) GOTO 170
55545 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55546  DO 160 ii = 1, iend
55547  i = igh - ii
55548  IF (ortr(i) .EQ. 0.0d0 .AND. orti(i) .EQ. 0.0d0) GOTO 160
55549  IF (hr(i,i-1) .EQ. 0.0d0 .AND. hi(i,i-1) .EQ. 0.0d0) GOTO 160
55550 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55551  norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)
55552  ip1 = i + 1
55553 C
55554  DO 120 k = ip1, igh
55555  ortr(k) = hr(k,i-1)
55556  orti(k) = hi(k,i-1)
55557  120 CONTINUE
55558 C
55559  DO 150 j = i, igh
55560  sr = 0.0d0
55561  si = 0.0d0
55562 C
55563  DO 130 k = i, igh
55564  sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
55565  si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
55566  130 CONTINUE
55567 C
55568  sr = sr / norm
55569  si = si / norm
55570 C
55571  DO 140 k = i, igh
55572  zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
55573  zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
55574  140 CONTINUE
55575 C
55576  150 CONTINUE
55577 C
55578  160 CONTINUE
55579 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55580  170 l = low + 1
55581 C
55582  DO 210 i = l, igh
55583  ll = min0(i+1,igh)
55584  IF (hi(i,i-1) .EQ. 0.0d0) GOTO 210
55585  norm = pythag(hr(i,i-1),hi(i,i-1))
55586  yr = hr(i,i-1) / norm
55587  yi = hi(i,i-1) / norm
55588  hr(i,i-1) = norm
55589  hi(i,i-1) = 0.0d0
55590 C
55591  DO 180 j = i, n
55592  si = yr * hi(i,j) - yi * hr(i,j)
55593  hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
55594  hi(i,j) = si
55595  180 CONTINUE
55596 C
55597  DO 190 j = 1, ll
55598  si = yr * hi(j,i) + yi * hr(j,i)
55599  hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
55600  hi(j,i) = si
55601  190 CONTINUE
55602 C
55603  DO 200 j = low, igh
55604  si = yr * zi(j,i) + yi * zr(j,i)
55605  zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
55606  zi(j,i) = si
55607  200 CONTINUE
55608 C
55609  210 CONTINUE
55610 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55611  220 DO 230 i = 1, n
55612  IF (i .GE. low .AND. i .LE. igh) GOTO 230
55613  wr(i) = hr(i,i)
55614  wi(i) = hi(i,i)
55615  230 CONTINUE
55616 C
55617  en = igh
55618  tr = 0.0d0
55619  ti = 0.0d0
55620  itn = 30*n
55621 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55622  240 IF (en .LT. low) GOTO 430
55623  its = 0
55624  enm1 = en - 1
55625 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55626 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55627  250 DO 260 ll = low, en
55628  l = en + low - ll
55629  IF (l .EQ. low) GOTO 270
55630  tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
55631  x + dabs(hr(l,l)) + dabs(hi(l,l))
55632  tst2 = tst1 + dabs(hr(l,l-1))
55633  IF (tst2 .EQ. tst1) GOTO 270
55634  260 CONTINUE
55635 C .......... FORM SHIFT ..........
55636  270 IF (l .EQ. en) GOTO 420
55637  IF (itn .EQ. 0) GOTO 550
55638  IF (its .EQ. 10 .OR. its .EQ. 20) GOTO 290
55639  sr = hr(en,en)
55640  si = hi(en,en)
55641  xr = hr(enm1,en) * hr(en,enm1)
55642  xi = hi(enm1,en) * hr(en,enm1)
55643  IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) GOTO 300
55644  yr = (hr(enm1,enm1) - sr) / 2.0d0
55645  yi = (hi(enm1,enm1) - si) / 2.0d0
55646  CALL pycsrt(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
55647  IF (yr * zzr + yi * zzi .GE. 0.0d0) GOTO 280
55648  zzr = -zzr
55649  zzi = -zzi
55650  280 CALL pycdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
55651  sr = sr - xr
55652  si = si - xi
55653  GOTO 300
55654 C .......... FORM EXCEPTIONAL SHIFT ..........
55655  290 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
55656  si = 0.0d0
55657 C
55658  300 DO 310 i = low, en
55659  hr(i,i) = hr(i,i) - sr
55660  hi(i,i) = hi(i,i) - si
55661  310 CONTINUE
55662 C
55663  tr = tr + sr
55664  ti = ti + si
55665  its = its + 1
55666  itn = itn - 1
55667 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55668  lp1 = l + 1
55669 C
55670  DO 330 i = lp1, en
55671  sr = hr(i,i-1)
55672  hr(i,i-1) = 0.0d0
55673  norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
55674  xr = hr(i-1,i-1) / norm
55675  wr(i-1) = xr
55676  xi = hi(i-1,i-1) / norm
55677  wi(i-1) = xi
55678  hr(i-1,i-1) = norm
55679  hi(i-1,i-1) = 0.0d0
55680  hi(i,i-1) = sr / norm
55681 C
55682  DO 320 j = i, n
55683  yr = hr(i-1,j)
55684  yi = hi(i-1,j)
55685  zzr = hr(i,j)
55686  zzi = hi(i,j)
55687  hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
55688  hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
55689  hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
55690  hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
55691  320 CONTINUE
55692 C
55693  330 CONTINUE
55694 C
55695  si = hi(en,en)
55696  IF (si .EQ. 0.0d0) GOTO 350
55697  norm = pythag(hr(en,en),si)
55698  sr = hr(en,en) / norm
55699  si = si / norm
55700  hr(en,en) = norm
55701  hi(en,en) = 0.0d0
55702  IF (en .EQ. n) GOTO 350
55703  ip1 = en + 1
55704 C
55705  DO 340 j = ip1, n
55706  yr = hr(en,j)
55707  yi = hi(en,j)
55708  hr(en,j) = sr * yr + si * yi
55709  hi(en,j) = sr * yi - si * yr
55710  340 CONTINUE
55711 C .......... INVERSE OPERATION (COLUMNS) ..........
55712  350 DO 390 j = lp1, en
55713  xr = wr(j-1)
55714  xi = wi(j-1)
55715 C
55716  DO 370 i = 1, j
55717  yr = hr(i,j-1)
55718  yi = 0.0d0
55719  zzr = hr(i,j)
55720  zzi = hi(i,j)
55721  IF (i .EQ. j) GOTO 360
55722  yi = hi(i,j-1)
55723  hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
55724  360 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
55725  hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
55726  hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
55727  370 CONTINUE
55728 C
55729  DO 380 i = low, igh
55730  yr = zr(i,j-1)
55731  yi = zi(i,j-1)
55732  zzr = zr(i,j)
55733  zzi = zi(i,j)
55734  zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
55735  zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
55736  zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
55737  zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
55738  380 CONTINUE
55739 C
55740  390 CONTINUE
55741 C
55742  IF (si .EQ. 0.0d0) GOTO 250
55743 C
55744  DO 400 i = 1, en
55745  yr = hr(i,en)
55746  yi = hi(i,en)
55747  hr(i,en) = sr * yr - si * yi
55748  hi(i,en) = sr * yi + si * yr
55749  400 CONTINUE
55750 C
55751  DO 410 i = low, igh
55752  yr = zr(i,en)
55753  yi = zi(i,en)
55754  zr(i,en) = sr * yr - si * yi
55755  zi(i,en) = sr * yi + si * yr
55756  410 CONTINUE
55757 C
55758  GOTO 250
55759 C .......... A ROOT FOUND ..........
55760  420 hr(en,en) = hr(en,en) + tr
55761  wr(en) = hr(en,en)
55762  hi(en,en) = hi(en,en) + ti
55763  wi(en) = hi(en,en)
55764  en = enm1
55765  GOTO 240
55766 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55767 C VECTORS OF UPPER TRIANGULAR FORM ..........
55768  430 norm = 0.0d0
55769 C
55770  DO 440 i = 1, n
55771 C
55772  DO 440 j = i, n
55773  tr = dabs(hr(i,j)) + dabs(hi(i,j))
55774  IF (tr .GT. norm) norm = tr
55775  440 CONTINUE
55776 C
55777  IF (n .EQ. 1 .OR. norm .EQ. 0.0d0) GOTO 560
55778 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55779  DO 500 nn = 2, n
55780  en = n + 2 - nn
55781  xr = wr(en)
55782  xi = wi(en)
55783  hr(en,en) = 1.0d0
55784  hi(en,en) = 0.0d0
55785  enm1 = en - 1
55786 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55787  DO 490 ii = 1, enm1
55788  i = en - ii
55789  zzr = 0.0d0
55790  zzi = 0.0d0
55791  ip1 = i + 1
55792 C
55793  DO 450 j = ip1, en
55794  zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
55795  zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
55796  450 CONTINUE
55797 C
55798  yr = xr - wr(i)
55799  yi = xi - wi(i)
55800  IF (yr .NE. 0.0d0 .OR. yi .NE. 0.0d0) GOTO 470
55801  tst1 = norm
55802  yr = tst1
55803  460 yr = 0.01d0 * yr
55804  tst2 = norm + yr
55805  IF (tst2 .GT. tst1) GOTO 460
55806  470 CONTINUE
55807  CALL pycdiv(zzr,zzi,yr,yi,hr(i,en),hi(i,en))
55808 C .......... OVERFLOW CONTROL ..........
55809  tr = dabs(hr(i,en)) + dabs(hi(i,en))
55810  IF (tr .EQ. 0.0d0) GOTO 490
55811  tst1 = tr
55812  tst2 = tst1 + 1.0d0/tst1
55813  IF (tst2 .GT. tst1) GOTO 490
55814  DO 480 j = i, en
55815  hr(j,en) = hr(j,en)/tr
55816  hi(j,en) = hi(j,en)/tr
55817  480 CONTINUE
55818 C
55819  490 CONTINUE
55820 C
55821  500 CONTINUE
55822 C .......... END BACKSUBSTITUTION ..........
55823 C .......... VECTORS OF ISOLATED ROOTS ..........
55824  DO 520 i = 1, n
55825  IF (i .GE. low .AND. i .LE. igh) GOTO 520
55826 C
55827  DO 510 j = i, n
55828  zr(i,j) = hr(i,j)
55829  zi(i,j) = hi(i,j)
55830  510 CONTINUE
55831 C
55832  520 CONTINUE
55833 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55834 C VECTORS OF ORIGINAL FULL MATRIX.
55835 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55836  DO 540 jj = low, n
55837  j = n + low - jj
55838  m = min0(j,igh)
55839 C
55840  DO 540 i = low, igh
55841  zzr = 0.0d0
55842  zzi = 0.0d0
55843 C
55844  DO 530 k = low, m
55845  zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
55846  zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
55847  530 CONTINUE
55848 C
55849  zr(i,j) = zzr
55850  zi(i,j) = zzi
55851  540 CONTINUE
55852 C
55853  GOTO 560
55854 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55855 C CONVERGED AFTER 30*N ITERATIONS ..........
55856  550 ierr = en
55857  560 RETURN
55858  END
55859 
55860 C*********************************************************************
55861 
55862 C...PYCDIV
55863 C...Auxiliary to PYCMQR
55864 C
55865 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55866 C
55867 
55868  SUBROUTINE pycdiv(AR,AI,BR,BI,CR,CI)
55869 
55870  DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55871  DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55872 
55873  s = dabs(br) + dabs(bi)
55874  ars = ar/s
55875  ais = ai/s
55876  brs = br/s
55877  bis = bi/s
55878  s = brs**2 + bis**2
55879  cr = (ars*brs + ais*bis)/s
55880  ci = (ais*brs - ars*bis)/s
55881  RETURN
55882  END
55883 
55884 C*********************************************************************
55885 
55886 C...PYCSRT
55887 C...Auxiliary to PYCMQR
55888 C
55889 C (YR,YI) = COMPLEX DSQRT(XR,XI)
55890 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
55891 C
55892 
55893  SUBROUTINE pycsrt(XR,XI,YR,YI)
55894 
55895  DOUBLE PRECISION XR,XI,YR,YI
55896  DOUBLE PRECISION S,TR,TI,PYTHAG
55897 
55898  tr = xr
55899  ti = xi
55900  s = dsqrt(0.5d0*(pythag(tr,ti) + dabs(tr)))
55901  IF (tr .GE. 0.0d0) yr = s
55902  IF (ti .LT. 0.0d0) s = -s
55903  IF (tr .LE. 0.0d0) yi = s
55904  IF (tr .LT. 0.0d0) yr = 0.5d0*(ti/yi)
55905  IF (tr .GT. 0.0d0) yi = 0.5d0*(ti/yr)
55906  RETURN
55907  END
55908 
55909  DOUBLE PRECISION FUNCTION pythag(A,B)
55910  DOUBLE PRECISION A,B
55911 C
55912 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
55913 C
55914  DOUBLE PRECISION P,R,S,T,U
55915  P = dmax1(dabs(a),dabs(b))
55916  IF (p .EQ. 0.0d0) GOTO 110
55917  r = (dmin1(dabs(a),dabs(b))/p)**2
55918  100 CONTINUE
55919  t = 4.0d0 + r
55920  IF (t .EQ. 4.0d0) GOTO 110
55921  s = r/t
55922  u = 1.0d0 + 2.0d0*s
55923  p = u*p
55924  r = (s/u)**2 * r
55925  GOTO 100
55926  110 pythag = p
55927  RETURN
55928  END
55929 
55930 C*********************************************************************
55931 
55932 C...PYCBAL
55933 C...Auxiliary to PYEICG
55934 C
55935 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
55936 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
55937 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
55938 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
55939 C
55940 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
55941 C EIGENVALUES WHENEVER POSSIBLE.
55942 C
55943 C ON INPUT
55944 C
55945 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55946 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55947 C DIMENSION STATEMENT.
55948 C
55949 C N IS THE ORDER OF THE MATRIX.
55950 C
55951 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55952 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
55953 C
55954 C ON OUTPUT
55955 C
55956 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55957 C RESPECTIVELY, OF THE BALANCED MATRIX.
55958 C
55959 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
55960 C ARE EQUAL TO ZERO IF
55961 C (1) I IS GREATER THAN J AND
55962 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
55963 C
55964 C SCALE CONTAINS INFORMATION DETERMINING THE
55965 C PERMUTATIONS AND SCALING FACTORS USED.
55966 C
55967 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
55968 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
55969 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
55970 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
55971 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
55972 C = D(J,J) J = LOW,...,IGH
55973 C = P(J) J = IGH+1,...,N.
55974 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
55975 C THEN 1 TO LOW-1.
55976 C
55977 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
55978 C
55979 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
55980 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
55981 C K,L HAVE BEEN REVERSED.)
55982 C
55983 C ARITHMETIC IS REAL THROUGHOUT.
55984 C
55985 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55986 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55987 C
55988 C THIS VERSION DATED AUGUST 1983.
55989 C
55990 
55991  SUBROUTINE pycbal(NM,N,AR,AI,LOW,IGH,SCALE)
55992 
55993  INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
55994  DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
55995  DOUBLE PRECISION C,F,G,R,S,B2,RADIX
55996  LOGICAL NOCONV
55997 
55998  radix = 16.0d0
55999 C
56000  b2 = radix * radix
56001  k = 1
56002  l = n
56003  GOTO 150
56004 C .......... IN-LINE PROCEDURE FOR ROW AND
56005 C COLUMN EXCHANGE ..........
56006  100 scale(m) = j
56007  IF (j .EQ. m) GOTO 130
56008 C
56009  DO 110 i = 1, l
56010  f = ar(i,j)
56011  ar(i,j) = ar(i,m)
56012  ar(i,m) = f
56013  f = ai(i,j)
56014  ai(i,j) = ai(i,m)
56015  ai(i,m) = f
56016  110 CONTINUE
56017 C
56018  DO 120 i = k, n
56019  f = ar(j,i)
56020  ar(j,i) = ar(m,i)
56021  ar(m,i) = f
56022  f = ai(j,i)
56023  ai(j,i) = ai(m,i)
56024  ai(m,i) = f
56025  120 CONTINUE
56026 C
56027  130 IF(iexc.EQ.1) GOTO 140
56028  IF(iexc.EQ.2) GOTO 180
56029 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56030 C AND PUSH THEM DOWN ..........
56031  140 IF (l .EQ. 1) GOTO 320
56032  l = l - 1
56033 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56034  150 DO 170 jj = 1, l
56035  j = l + 1 - jj
56036 C
56037  DO 160 i = 1, l
56038  IF (i .EQ. j) GOTO 160
56039  IF (ar(j,i) .NE. 0.0d0 .OR. ai(j,i) .NE. 0.0d0) GOTO 170
56040  160 CONTINUE
56041 C
56042  m = l
56043  iexc = 1
56044  GOTO 100
56045  170 CONTINUE
56046 C
56047  GOTO 190
56048 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56049 C AND PUSH THEM LEFT ..........
56050  180 k = k + 1
56051 C
56052  190 DO 210 j = k, l
56053 C
56054  DO 200 i = k, l
56055  IF (i .EQ. j) GOTO 200
56056  IF (ar(i,j) .NE. 0.0d0 .OR. ai(i,j) .NE. 0.0d0) GOTO 210
56057  200 CONTINUE
56058 C
56059  m = k
56060  iexc = 2
56061  GOTO 100
56062  210 CONTINUE
56063 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56064  DO 220 i = k, l
56065  220 scale(i) = 1.0d0
56066 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56067  230 noconv = .false.
56068 C
56069  DO 310 i = k, l
56070  c = 0.0d0
56071  r = 0.0d0
56072 C
56073  DO 240 j = k, l
56074  IF (j .EQ. i) GOTO 240
56075  c = c + dabs(ar(j,i)) + dabs(ai(j,i))
56076  r = r + dabs(ar(i,j)) + dabs(ai(i,j))
56077  240 CONTINUE
56078 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56079  IF (c .EQ. 0.0d0 .OR. r .EQ. 0.0d0) GOTO 310
56080  g = r / radix
56081  f = 1.0d0
56082  s = c + r
56083  250 IF (c .GE. g) GOTO 260
56084  f = f * radix
56085  c = c * b2
56086  GOTO 250
56087  260 g = r * radix
56088  270 IF (c .LT. g) GOTO 280
56089  f = f / radix
56090  c = c / b2
56091  GOTO 270
56092 C .......... NOW BALANCE ..........
56093  280 IF ((c + r) / f .GE. 0.95d0 * s) GOTO 310
56094  g = 1.0d0 / f
56095  scale(i) = scale(i) * f
56096  noconv = .true.
56097 C
56098  DO 290 j = k, n
56099  ar(i,j) = ar(i,j) * g
56100  ai(i,j) = ai(i,j) * g
56101  290 CONTINUE
56102 C
56103  DO 300 j = 1, l
56104  ar(j,i) = ar(j,i) * f
56105  ai(j,i) = ai(j,i) * f
56106  300 CONTINUE
56107 C
56108  310 CONTINUE
56109 C
56110  IF (noconv) GOTO 230
56111 C
56112  320 low = k
56113  igh = l
56114  RETURN
56115  END
56116 
56117 C*********************************************************************
56118 
56119 C...PYCBA2
56120 C...Auxiliary to PYEICG.
56121 C
56122 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56123 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56124 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56125 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56126 C
56127 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56128 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56129 C BALANCED MATRIX DETERMINED BY CBAL.
56130 C
56131 C ON INPUT
56132 C
56133 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56134 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56135 C DIMENSION STATEMENT.
56136 C
56137 C N IS THE ORDER OF THE MATRIX.
56138 C
56139 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56140 C
56141 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56142 C AND SCALING FACTORS USED BY CBAL.
56143 C
56144 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56145 C
56146 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56147 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56148 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56149 C
56150 C ON OUTPUT
56151 C
56152 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56153 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56154 C IN THEIR FIRST M COLUMNS.
56155 C
56156 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56157 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56158 C
56159 C THIS VERSION DATED AUGUST 1983.
56160 C
56161 
56162  SUBROUTINE pycba2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56163 
56164  INTEGER I,J,K,M,N,II,NM,IGH,LOW
56165  DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56166  DOUBLE PRECISION S
56167 
56168  IF (m .EQ. 0) GOTO 150
56169  IF (igh .EQ. low) GOTO 120
56170 C
56171  DO 110 i = low, igh
56172  s = scale(i)
56173 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56174 C IF THE FOREGOING STATEMENT IS REPLACED BY
56175 C S=1.0D0/SCALE(I). ..........
56176  DO 100 j = 1, m
56177  zr(i,j) = zr(i,j) * s
56178  zi(i,j) = zi(i,j) * s
56179  100 CONTINUE
56180 C
56181  110 CONTINUE
56182 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56183 C IGH+1 STEP 1 UNTIL N DO -- ..........
56184  120 DO 140 ii = 1, n
56185  i = ii
56186  IF (i .GE. low .AND. i .LE. igh) GOTO 140
56187  IF (i .LT. low) i = low - ii
56188  k = scale(i)
56189  IF (k .EQ. i) GOTO 140
56190 C
56191  DO 130 j = 1, m
56192  s = zr(i,j)
56193  zr(i,j) = zr(k,j)
56194  zr(k,j) = s
56195  s = zi(i,j)
56196  zi(i,j) = zi(k,j)
56197  zi(k,j) = s
56198  130 CONTINUE
56199 C
56200  140 CONTINUE
56201 C
56202  150 RETURN
56203  END
56204 
56205 C*********************************************************************
56206 
56207 C...PYCRTH
56208 C...Auxiliary to PYEICG.
56209 C
56210 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56211 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56212 C BY MARTIN AND WILKINSON.
56213 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56214 C
56215 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56216 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56217 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56218 C UNITARY SIMILARITY TRANSFORMATIONS.
56219 C
56220 C ON INPUT
56221 C
56222 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56223 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56224 C DIMENSION STATEMENT.
56225 C
56226 C N IS THE ORDER OF THE MATRIX.
56227 C
56228 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56229 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56230 C SET LOW=1, IGH=N.
56231 C
56232 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56233 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56234 C
56235 C ON OUTPUT
56236 C
56237 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56238 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56239 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56240 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56241 C HESSENBERG MATRIX.
56242 C
56243 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56244 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56245 C
56246 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56247 C
56248 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56249 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56250 C
56251 C THIS VERSION DATED AUGUST 1983.
56252 C
56253 
56254  SUBROUTINE pycrth(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56255 
56256  INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56257  DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56258  DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56259 
56260  la = igh - 1
56261  kp1 = low + 1
56262  IF (la .LT. kp1) GOTO 210
56263 C
56264  DO 200 m = kp1, la
56265  h = 0.0d0
56266  ortr(m) = 0.0d0
56267  orti(m) = 0.0d0
56268  scale = 0.0d0
56269 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56270  DO 100 i = m, igh
56271  100 scale = scale + dabs(ar(i,m-1)) + dabs(ai(i,m-1))
56272 C
56273  IF (scale .EQ. 0.0d0) GOTO 200
56274  mp = m + igh
56275 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56276  DO 110 ii = m, igh
56277  i = mp - ii
56278  ortr(i) = ar(i,m-1) / scale
56279  orti(i) = ai(i,m-1) / scale
56280  h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
56281  110 CONTINUE
56282 C
56283  g = dsqrt(h)
56284  f = pythag(ortr(m),orti(m))
56285  IF (f .EQ. 0.0d0) GOTO 120
56286  h = h + f * g
56287  g = g / f
56288  ortr(m) = (1.0d0 + g) * ortr(m)
56289  orti(m) = (1.0d0 + g) * orti(m)
56290  GOTO 130
56291 C
56292  120 ortr(m) = g
56293  ar(m,m-1) = scale
56294 C .......... FORM (I-(U*UT)/H) * A ..........
56295  130 DO 160 j = m, n
56296  fr = 0.0d0
56297  fi = 0.0d0
56298 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56299  DO 140 ii = m, igh
56300  i = mp - ii
56301  fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
56302  fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
56303  140 CONTINUE
56304 C
56305  fr = fr / h
56306  fi = fi / h
56307 C
56308  DO 150 i = m, igh
56309  ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i)
56310  ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i)
56311  150 CONTINUE
56312 C
56313  160 CONTINUE
56314 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56315  DO 190 i = 1, igh
56316  fr = 0.0d0
56317  fi = 0.0d0
56318 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56319  DO 170 jj = m, igh
56320  j = mp - jj
56321  fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
56322  fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
56323  170 CONTINUE
56324 C
56325  fr = fr / h
56326  fi = fi / h
56327 C
56328  DO 180 j = m, igh
56329  ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j)
56330  ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j)
56331  180 CONTINUE
56332 C
56333  190 CONTINUE
56334 C
56335  ortr(m) = scale * ortr(m)
56336  orti(m) = scale * orti(m)
56337  ar(m,m-1) = -g * ar(m,m-1)
56338  ai(m,m-1) = -g * ai(m,m-1)
56339  200 CONTINUE
56340 C
56341  210 RETURN
56342  END
56343 
56344 C*********************************************************************
56345 
56346 C...PYLDCM
56347 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56348 C...processes.
56349 
56350  SUBROUTINE pyldcm(A,N,NP,INDX,D)
56351  IMPLICIT NONE
56352  INTEGER N,NP,INDX(N)
56353  REAL*8 D,TINY
56354  COMPLEX*16 A(NP,NP)
56355  parameter(tiny=1.0d-20)
56356  INTEGER I,IMAX,J,K
56357  real*8 aamax,vv(6),dum
56358  COMPLEX*16 SUM,DUMC
56359 
56360  d=1d0
56361  DO 110 i=1,n
56362  aamax=0d0
56363  DO 100 j=1,n
56364  IF (abs(a(i,j)).GT.aamax) aamax=abs(a(i,j))
56365  100 CONTINUE
56366  IF (aamax.EQ.0d0) CALL pyerrm(28,'(PYLDCM:) singular matrix')
56367  vv(i)=1d0/aamax
56368  110 CONTINUE
56369  DO 180 j=1,n
56370  DO 130 i=1,j-1
56371  sum=a(i,j)
56372  DO 120 k=1,i-1
56373  sum=sum-a(i,k)*a(k,j)
56374  120 CONTINUE
56375  a(i,j)=sum
56376  130 CONTINUE
56377  aamax=0d0
56378  DO 150 i=j,n
56379  sum=a(i,j)
56380  DO 140 k=1,j-1
56381  sum=sum-a(i,k)*a(k,j)
56382  140 CONTINUE
56383  a(i,j)=sum
56384  dum=vv(i)*abs(sum)
56385  IF (dum.GE.aamax) THEN
56386  imax=i
56387  aamax=dum
56388  ENDIF
56389  150 CONTINUE
56390  IF (j.NE.imax)THEN
56391  DO 160 k=1,n
56392  dumc=a(imax,k)
56393  a(imax,k)=a(j,k)
56394  a(j,k)=dumc
56395  160 CONTINUE
56396  d=-d
56397  vv(imax)=vv(j)
56398  ENDIF
56399  indx(j)=imax
56400  IF(abs(a(j,j)).EQ.0d0) a(j,j)=dcmplx(tiny,0d0)
56401  IF(j.NE.n)THEN
56402  DO 170 i=j+1,n
56403  a(i,j)=a(i,j)/a(j,j)
56404  170 CONTINUE
56405  ENDIF
56406  180 CONTINUE
56407 
56408  RETURN
56409  END
56410 
56411 C*********************************************************************
56412 
56413 C...PYBKSB
56414 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56415 C...processes.
56416 
56417  SUBROUTINE pybksb(A,N,NP,INDX,B)
56418  IMPLICIT NONE
56419  INTEGER N,NP,INDX(N)
56420  COMPLEX*16 A(NP,NP),B(N)
56421  INTEGER I,II,J,LL
56422  COMPLEX*16 SUM
56423 
56424  ii=0
56425  DO 110 i=1,n
56426  ll=indx(i)
56427  sum=b(ll)
56428  b(ll)=b(i)
56429  IF (ii.NE.0)THEN
56430  DO 100 j=ii,i-1
56431  sum=sum-a(i,j)*b(j)
56432  100 CONTINUE
56433  ELSE IF (abs(sum).NE.0d0) THEN
56434  ii=i
56435  ENDIF
56436  b(i)=sum
56437  110 CONTINUE
56438  DO 130 i=n,1,-1
56439  sum=b(i)
56440  DO 120 j=i+1,n
56441  sum=sum-a(i,j)*b(j)
56442  120 CONTINUE
56443  b(i)=sum/a(i,i)
56444  130 CONTINUE
56445  RETURN
56446  END
56447 
56448 C***********************************************************************
56449 
56450 C...PYWIDX
56451 C...Calculates full and partial widths of resonances.
56452 C....copy of PYWIDT, used for techniparticle widths
56453 
56454  SUBROUTINE pywidx(KFLR,SH,WDTP,WDTE)
56455 
56456 C...Double precision and integer declarations.
56457  IMPLICIT DOUBLE PRECISION(a-h, o-z)
56458  IMPLICIT INTEGER(I-N)
56459  INTEGER PYK,PYCHGE,PYCOMP
56460 C...Parameter statement to help give large particle numbers.
56461  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
56462  &kexcit=4000000,kdimen=5000000)
56463 C...Commonblocks.
56464  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
56465  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
56466  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
56467  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
56468  common/pypars/mstp(200),parp(200),msti(200),pari(200)
56469  common/pyint1/mint(400),vint(400)
56470  common/pyint4/mwid(500),wids(500,5)
56471  common/pymssm/imss(0:99),rmss(0:99)
56472  common/pytcsm/itcm(0:99),rtcm(0:99)
56473  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
56474  &/pyint4/,/pymssm/,/pytcsm/
56475 C...Local arrays and saved variables.
56476  dimension wdtp(0:400),wdte(0:400,0:5),mofsv(3,2),widwsv(3,2),
56477  &wid2sv(3,2)
56478  SAVE mofsv,widwsv,wid2sv
56479  DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
56480 
56481 C...Compressed code and sign; mass.
56482  kfla=iabs(kflr)
56483  kfls=isign(1,kflr)
56484  kc=pycomp(kfla)
56485  shr=sqrt(sh)
56486  pmr=pmas(kc,1)
56487 
56488 C...Reset width information.
56489  DO i=0,400
56490  wdtp(i)=0d0
56491  ENDDO
56492 
56493 C...Common electroweak and strong constants.
56494  xw=paru(102)
56495  xwv=xw
56496  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
56497  xw1=1d0-xw
56498  aem=pyalem(sh)
56499  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
56500  as=pyalps(sh)
56501  radc=1d0+as/paru(1)
56502 
56503  IF(kfla.EQ.23) THEN
56504 C...Z0:
56505  xwc=1d0/(16d0*xw*xw1)
56506  fac=(aem*xwc/3d0)*shr
56507  120 CONTINUE
56508  DO 130 i=1,mdcy(kc,3)
56509  idc=i+mdcy(kc,2)-1
56510  IF(mdme(idc,1).LT.0) GOTO 130
56511  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
56512  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
56513  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 130
56514  IF(i.LE.8) THEN
56515 C...Z0 -> q + qbar
56516  ef=kchg(i,1)/3d0
56517  af=sign(1d0,ef+0.1d0)
56518  vf=af-4d0*ef*xwv
56519  fcof=3d0*radc
56520  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
56521  ELSEIF(i.LE.16) THEN
56522 C...Z0 -> l+ + l-, nu + nubar
56523  ef=kchg(i+2,1)/3d0
56524  af=sign(1d0,ef+0.1d0)
56525  vf=af-4d0*ef*xwv
56526  fcof=1d0
56527  ENDIF
56528  be34=sqrt(max(0d0,1d0-4d0*rm1))
56529  wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
56530  & be34
56531  wdtp(0)=wdtp(0)+wdtp(i)
56532  130 CONTINUE
56533 
56534 
56535  ELSEIF(kfla.EQ.24) THEN
56536 C...W+/-:
56537  fac=(aem/(24d0*xw))*shr
56538  DO 140 i=1,mdcy(kc,3)
56539  idc=i+mdcy(kc,2)-1
56540  IF(mdme(idc,1).LT.0) GOTO 140
56541  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
56542  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
56543  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 140
56544  wid2=1d0
56545  IF(i.LE.16) THEN
56546 C...W+/- -> q + qbar'
56547  fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
56548  ELSEIF(i.LE.20) THEN
56549 C...W+/- -> l+/- + nu
56550  fcof=1d0
56551  ENDIF
56552  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
56553  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
56554  wdtp(0)=wdtp(0)+wdtp(i)
56555  140 CONTINUE
56556 
56557 C.....V8 -> quark anti-quark
56558  ELSEIF(kfla.EQ.ktechn+100021) THEN
56559  fac=as/6d0*shr
56560  tant3=rtcm(21)
56561  IF(itcm(2).EQ.0) THEN
56562  imdl=1
56563  ELSEIF(itcm(2).EQ.1) THEN
56564  imdl=2
56565  ENDIF
56566  DO 150 i=1,mdcy(kc,3)
56567  idc=i+mdcy(kc,2)-1
56568  IF(mdme(idc,1).LT.0) GOTO 150
56569  pm1=pmas(pycomp(kfdp(idc,1)),1)
56570  rm1=pm1**2/sh
56571  IF(rm1.GT.0.25d0) GOTO 150
56572  wid2=1d0
56573  IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
56574  fmix=1d0/tant3**2
56575  ELSE
56576  fmix=tant3**2
56577  ENDIF
56578  wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*fmix
56579  IF(i.EQ.6) wid2=wids(6,1)
56580  wdtp(0)=wdtp(0)+wdtp(i)
56581  150 CONTINUE
56582  ENDIF
56583 
56584  RETURN
56585  END
56586 
56587 C*********************************************************************
56588 
56589 C...PYRVSF
56590 C...Calculates R-violating decays of sfermions.
56591 C...P. Z. Skands
56592 
56593  SUBROUTINE pyrvsf(KFIN,XLAM,IDLAM,LKNT)
56594 
56595 C...Double precision and integer declarations.
56596  IMPLICIT DOUBLE PRECISION(a-h, o-z)
56597  IMPLICIT INTEGER(I-N)
56598 C...Parameter statement to help give large particle numbers.
56599  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
56600  &kexcit=4000000,kdimen=5000000)
56601 C...Commonblocks.
56602  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
56603  common/pymssm/imss(0:99),rmss(0:99)
56604  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
56605  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
56606  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
56607 C...Local variables.
56608  DOUBLE PRECISION XLAM(0:400)
56609  INTEGER IDLAM(400,3), PYCOMP
56610  SAVE /pymsrv/,/pyssmt/,/pymssm/,/pydat2/
56611 
56612 C...IS R-VIOLATION ON ?
56613  IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
56614 C...Mass eigenstate counter
56615  icnt=int(kfin/ksusy1)
56616 C...SM KF code of SUSY particle
56617  kfsm=kfin-icnt*ksusy1
56618 C...Squared Sparticle Mass
56619  sm=pmas(pycomp(kfin),1)**2
56620 C... Squared mass of top quark
56621  smt=pmas(pycomp(6),1)**2
56622 C...IS L-VIOLATION ON ?
56623  IF ((imss(51).GE.1).OR.(imss(52).GE.1)) THEN
56624 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56625  IF(icnt.NE.0.AND.(kfsm.EQ.11.OR.kfsm.EQ.13.OR.kfsm.EQ.15))
56626  & THEN
56627  k=int((kfsm-9)/2)
56628  DO 110 i=1,3
56629  DO 100 j=1,3
56630  IF(i.NE.j) THEN
56631 C...~e,~mu,~tau -> nu_I + lepton-_J
56632  lknt = lknt+1
56633  idlam(lknt,1)= 12 +2*(i-1)
56634  idlam(lknt,2)= 11 +2*(j-1)
56635  idlam(lknt,3)= 0
56636  xlam(lknt)=0d0
56637  rm2=rvlam(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56638  IF (imss(51).NE.0) xlam(lknt) =
56639  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56640 C...KINEMATICS CHECK
56641  IF (xlam(lknt).EQ.0d0) THEN
56642  lknt=lknt-1
56643  ENDIF
56644  ENDIF
56645  100 CONTINUE
56646  110 CONTINUE
56647 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56648  j=int((kfsm-9)/2)
56649  DO 130 i=1,3
56650  IF(i.NE.j) THEN
56651  DO 120 k=1,3
56652  lknt = lknt+1
56653  idlam(lknt,1)=-12 -2*(i-1)
56654  idlam(lknt,2)= 11 +2*(k-1)
56655  idlam(lknt,3)= 0
56656  xlam(lknt)=0d0
56657  rm2=rvlam(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56658  IF (imss(51).NE.0) xlam(lknt) =
56659  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56660 C...KINEMATICS CHECK
56661  IF (xlam(lknt).EQ.0d0) THEN
56662  lknt=lknt-1
56663  ENDIF
56664  120 CONTINUE
56665  ENDIF
56666  130 CONTINUE
56667 C...~e,~mu,~tau -> u_Jbar + d_K
56668  i=int((kfsm-9)/2)
56669  DO 150 j=1,3
56670  DO 140 k=1,3
56671  lknt = lknt+1
56672  idlam(lknt,1)=-2 -2*(j-1)
56673  idlam(lknt,2)= 1 +2*(k-1)
56674  idlam(lknt,3)= 0
56675  xlam(lknt)=0
56676  IF (imss(52).NE.0) THEN
56677 C...Use massive top quark
56678  IF (idlam(lknt,1).EQ.-6) THEN
56679  rm2=3*rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2
56680  & * (sm-smt)
56681  xlam(lknt) =
56682  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,3)
56683 C...If no top quark, all decay products massless
56684  ELSE
56685  rm2=3*rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56686  xlam(lknt) =
56687  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56688  ENDIF
56689 C...KINEMATICS CHECK
56690  IF (xlam(lknt).EQ.0d0) THEN
56691  lknt=lknt-1
56692  ENDIF
56693  ENDIF
56694  140 CONTINUE
56695  150 CONTINUE
56696  ENDIF
56697 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56698 C...No right-handed neutrinos
56699  IF(icnt.EQ.1) THEN
56700  IF(kfsm.EQ.12.OR.kfsm.EQ.14.OR.kfsm.EQ.16) THEN
56701  j=int((kfsm-10)/2)
56702  DO 170 i=1,3
56703  DO 160 k=1,3
56704  IF (i.NE.j) THEN
56705 C...~nu_J -> lepton+_I + lepton-_K
56706  lknt = lknt+1
56707  idlam(lknt,1)=-11 -2*(i-1)
56708  idlam(lknt,2)= 11 +2*(k-1)
56709  idlam(lknt,3)= 0
56710  xlam(lknt)=0d0
56711  rm2=rvlam(i,j,k)**2 * sm
56712  IF (imss(51).NE.0) xlam(lknt) =
56713  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56714 C...KINEMATICS CHECK
56715  IF (xlam(lknt).EQ.0d0) THEN
56716  lknt=lknt-1
56717  ENDIF
56718  ENDIF
56719  160 CONTINUE
56720  170 CONTINUE
56721 C...~nu_I -> dbar_J + d_K
56722  i=int((kfsm-10)/2)
56723  DO 190 j=1,3
56724  DO 180 k=1,3
56725  lknt = lknt+1
56726  idlam(lknt,1)=-1 -2*(j-1)
56727  idlam(lknt,2)= 1 +2*(k-1)
56728  idlam(lknt,3)= 0
56729  xlam(lknt)=0d0
56730  rm2=3*rvlamp(i,j,k)**2 * sm
56731  IF (imss(52).NE.0) xlam(lknt) =
56732  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56733 C...KINEMATICS CHECK
56734  IF (xlam(lknt).EQ.0d0) THEN
56735  lknt=lknt-1
56736  ENDIF
56737  180 CONTINUE
56738  190 CONTINUE
56739  ENDIF
56740  ENDIF
56741 C * SDOWN -> NU(BAR) + D and LEPTON- + U
56742  IF(icnt.NE.0.AND.(kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5)) THEN
56743  j=int((kfsm+1)/2)
56744  DO 210 i=1,3
56745  DO 200 k=1,3
56746 C...~d_J -> nu_Ibar + d_K
56747  lknt = lknt+1
56748  idlam(lknt,1)=-12 -2*(i-1)
56749  idlam(lknt,2)= 1 +2*(k-1)
56750  idlam(lknt,3)= 0
56751  xlam(lknt)=0d0
56752  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56753  IF (imss(52).NE.0) xlam(lknt) =
56754  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56755 C...KINEMATICS CHECK
56756  IF (xlam(lknt).EQ.0d0) THEN
56757  lknt=lknt-1
56758  ENDIF
56759  200 CONTINUE
56760  210 CONTINUE
56761  k=int((kfsm+1)/2)
56762  DO 240 i=1,3
56763  DO 230 j=1,3
56764 C...~d_K -> nu_I + d_J
56765  lknt = lknt+1
56766  idlam(lknt,1)= 12 +2*(i-1)
56767  idlam(lknt,2)= 1 +2*(j-1)
56768  idlam(lknt,3)= 0
56769  xlam(lknt)=0d0
56770  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56771  IF (imss(52).NE.0) xlam(lknt) =
56772  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56773 C...KINEMATICS CHECK
56774  IF (xlam(lknt).EQ.0d0) THEN
56775  lknt=lknt-1
56776  ENDIF
56777 C...~d_K -> lepton_I- + u_J
56778  220 lknt = lknt+1
56779  idlam(lknt,1)= 11 +2*(i-1)
56780  idlam(lknt,2)= 2 +2*(j-1)
56781  idlam(lknt,3)= 0
56782  xlam(lknt)=0d0
56783  IF (imss(52).NE.0) THEN
56784 C...Use massive top quark
56785  IF (idlam(lknt,2).EQ.6) THEN
56786  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2*(sm-smt)
56787  xlam(lknt) =
56788  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,2)
56789 C...If no top quark, all decay products massless
56790  ELSE
56791  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56792  xlam(lknt) =
56793  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56794  ENDIF
56795 C...KINEMATICS CHECK
56796  IF (xlam(lknt).EQ.0d0) THEN
56797  lknt=lknt-1
56798  ENDIF
56799  ENDIF
56800  230 CONTINUE
56801  240 CONTINUE
56802  ENDIF
56803 C * SUP -> LEPTON+ + D
56804  IF(icnt.NE.0.AND.(kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6)) THEN
56805  j=nint(kfsm/2.)
56806  DO 260 i=1,3
56807  DO 250 k=1,3
56808 C...~u_J -> lepton_I+ + d_K
56809  lknt = lknt+1
56810  idlam(lknt,1)=-11 -2*(i-1)
56811  idlam(lknt,2)= 1 +2*(k-1)
56812  idlam(lknt,3)= 0
56813  xlam(lknt)=0d0
56814  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56815  IF (imss(52).NE.0) xlam(lknt) =
56816  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56817 C...KINEMATICS CHECK
56818  IF (xlam(lknt).EQ.0d0) THEN
56819  lknt=lknt-1
56820  ENDIF
56821  250 CONTINUE
56822  260 CONTINUE
56823  ENDIF
56824  ENDIF
56825 C...BARYON NUMBER VIOLATING DECAYS
56826  IF (imss(53).GE.1) THEN
56827 C * SUP -> DBAR + DBAR
56828  IF(icnt.NE.0.AND.(kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6)) THEN
56829  i = kfsm/2
56830  DO 280 j=1,3
56831  DO 270 k=1,3
56832 C...~u_I -> dbar_J + dbar_K
56833  IF (j.LT.k) THEN
56834 C...(anti-) symmetry J <-> K.
56835  lknt = lknt + 1
56836  idlam(lknt,1) = -1 -2*(j-1)
56837  idlam(lknt,2) = -1 -2*(k-1)
56838  idlam(lknt,3) = 0
56839  xlam(lknt) = 0d0
56840  rm2 = 2.*(rvlamb(i,j,k)**2)
56841  & * sfmix(kfsm,2*icnt)**2 * sm
56842  xlam(lknt) =
56843  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56844 C...KINEMATICS CHECK
56845  IF (xlam(lknt).EQ.0d0) THEN
56846  lknt = lknt-1
56847  ENDIF
56848  ENDIF
56849  270 CONTINUE
56850  280 CONTINUE
56851  ENDIF
56852 C * SDOWN -> UBAR + DBAR
56853  IF(icnt.NE.0.AND.(kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5)) THEN
56854  k=(kfsm+1)/2
56855  DO 300 i=1,3
56856  DO 290 j=1,3
56857 C...LAMB coupling antisymmetric in J and K.
56858  IF (j.NE.k) THEN
56859 C...~d_K -> ubar_I + dbar_K
56860  lknt = lknt + 1
56861  idlam(lknt,1)= -2 -2*(i-1)
56862  idlam(lknt,2)= -1 -2*(j-1)
56863  idlam(lknt,3)= 0
56864  xlam(lknt)=0d0
56865 C...Use massive top quark
56866  IF (idlam(lknt,1).EQ.-6) THEN
56867  rm2=2*rvlamb(i,j,k)**2*sfmix(kfsm,2*icnt)**2*(sm-smt
56868  & )
56869  xlam(lknt) =
56870  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,3)
56871 C...If no top quark, all decay products massless
56872  ELSE
56873  rm2=2*rvlamb(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56874  xlam(lknt) =
56875  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56876  ENDIF
56877 C...KINEMATICS CHECK
56878  IF (xlam(lknt).EQ.0d0) THEN
56879  lknt=lknt-1
56880  ENDIF
56881  ENDIF
56882  290 CONTINUE
56883  300 CONTINUE
56884  ENDIF
56885  ENDIF
56886  ENDIF
56887 
56888  RETURN
56889  END
56890 
56891 C*********************************************************************
56892 
56893 C...PYRVNE
56894 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
56895 C...P. Z. Skands
56896 
56897  SUBROUTINE pyrvne(KFIN,XLAM,IDLAM,LKNT)
56898 
56899 C...Double precision and integer declarations.
56900  IMPLICIT DOUBLE PRECISION(a-h, o-z)
56901  IMPLICIT INTEGER(I-N)
56902 C...Parameter statement to help give large particle numbers.
56903  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
56904  &kexcit=4000000,kdimen=5000000)
56905 C...Commonblocks.
56906  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
56907  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
56908  common/pymssm/imss(0:99),rmss(0:99)
56909  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
56910  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
56911  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
56912 C...Local variables.
56913  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
56914  & ,dcmass,kfr(3)
56915  DOUBLE PRECISION XLAM(0:400)
56916  DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
56917  INTEGER IDLAM(400,3), PYCOMP
56918  LOGICAL DCMASS
56919  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pymsrv/,/pyrvnv/
56920 
56921 C...R-VIOLATING DECAYS
56922  IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
56923  kfsm=kfin-ksusy1
56924  IF(kfsm.EQ.22.OR.kfsm.EQ.23.OR.kfsm.EQ.25.OR.kfsm.EQ.35) THEN
56925 C...WHICH NEUTRALINO ?
56926  nchi=1
56927  IF (kfsm.EQ.23) nchi=2
56928  IF (kfsm.EQ.25) nchi=3
56929  IF (kfsm.EQ.35) nchi=4
56930 C...SIGN OF MASS (Opposite convention as HERWIG)
56931  ism = 1
56932  IF (smz(nchi).LT.0d0) ism = -ism
56933 
56934 C...Useful parameters for the calculation of the A and B constants.
56935  wmass = pmas(pycomp(24),1)
56936  echg = 2*sqrt(paru(103)*paru(1))
56937  cosb=1/(sqrt(1+rmss(5)**2))
56938  sinb=rmss(5)/sqrt(1+rmss(5)**2)
56939  cosw=sqrt(1-paru(102))
56940  sinw=sqrt(paru(102))
56941  gw=2d0*sqrt(paru(103)*paru(1))/sinw
56942 C...Run quark masses to neutralino mass squared (for Higgs-type
56943 C...couplings)
56944  sqmchi=pmas(pycomp(kfin),1)**2
56945  DO 100 i=1,6
56946  rmq(i)=pymrun(i,sqmchi)
56947  100 CONTINUE
56948 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
56949  DO 110 nchj=1,4
56950  zpmix(nchj,1)= zmix(nchj,1)*cosw+zmix(nchj,2)*sinw
56951  zpmix(nchj,2)=-zmix(nchj,1)*sinw+zmix(nchj,2)*cosw
56952  zpmix(nchj,3)= zmix(nchj,3)
56953  zpmix(nchj,4)= zmix(nchj,4)
56954  110 CONTINUE
56955  c1=gw*zpmix(nchi,3)/(2d0*cosb*wmass)
56956  c1u=gw*zpmix(nchi,4)/(2d0*sinb*wmass)
56957  c2=echg*zpmix(nchi,1)
56958  c3=gw*zpmix(nchi,2)/cosw
56959  eu=2d0/3d0
56960  ed=-1d0/3d0
56961 C... AB(x,y,z):
56962 C x=1-2 : Select A or B constant (1:A ; 2:B)
56963 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
56964 C 11-16:e,nu_e,mu,...)
56965 C z=1-2 : Mass eigenstate number
56966 C...CALCULATE COUPLINGS
56967  DO 120 i = 11,15,2
56968  cms=pmas(pycomp(i),1)
56969 C...Intermediate sleptons
56970  ab(1,i,1)=ism*(cms*c1*sfmix(i,1) + sfmix(i,2)
56971  & *(c2-c3*sinw**2))
56972  ab(1,i,2)=ism*(cms*c1*sfmix(i,3) + sfmix(i,4)
56973  & *(c2-c3*sinw**2))
56974  ab(2,i,1)= cms*c1*sfmix(i,2) - sfmix(i,1)*(c2+c3*(5d-1-sinw
56975  & **2))
56976  ab(2,i,2)=cms*c1*sfmix(i,4) - sfmix(i,3)*(c2+c3*(5d-1-sinw
56977  & **2))
56978 C...Inermediate sneutrinos
56979  ab(1,i+1,1)=0d0
56980  ab(2,i+1,1)=5d-1*c3
56981  ab(1,i+1,2)=0d0
56982  ab(2,i+1,2)=0d0
56983 C...Inermediate sdown
56984  j=i-10
56985  cms=rmq(j)
56986  ab(1,j,1)=ism*(cms*c1*sfmix(j,1) - sfmix(j,2)
56987  & *ed*(c2-c3*sinw**2))
56988  ab(1,j,2)=ism*(cms*c1*sfmix(j,3) - sfmix(j,4)
56989  & *ed*(c2-c3*sinw**2))
56990  ab(2,j,1)=cms*c1*sfmix(j,2) + sfmix(j,1)
56991  & *(ed*c2-c3*(1d0/2d0+ed*sinw**2))
56992  ab(2,j,2)=cms*c1*sfmix(j,4) + sfmix(j,3)
56993  & *(ed*c2-c3*(1d0/2d0+ed*sinw**2))
56994 C...Inermediate sup
56995  j=j+1
56996  cms=rmq(j)
56997  ab(1,j,1)=ism*(cms*c1u*sfmix(j,1) - sfmix(j,2)
56998  & *eu*(c2-c3*sinw**2))
56999  ab(1,j,2)=ism*(cms*c1u*sfmix(j,3) - sfmix(j,4)
57000  & *eu*(c2-c3*sinw**2))
57001  ab(2,j,1)=cms*c1u*sfmix(j,2) + sfmix(j,1)
57002  & *(eu*c2+c3*(1d0/2d0-eu*sinw**2))
57003  ab(2,j,2)=cms*c1u*sfmix(j,4) + sfmix(j,3)
57004  & *(eu*c2+c3*(1d0/2d0-eu*sinw**2))
57005  120 CONTINUE
57006 
57007  IF (imss(51).GE.1) THEN
57008 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57009 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57010 C...STEP IN I,J,K USING SINGLE COUNTER
57011  DO 130 isc=0,26
57012 C...LAMBDA COUPLING ASYM IN I,J
57013  IF(mod(isc/9,3).NE.mod(isc/3,3)) THEN
57014  lknt = lknt+1
57015  idlam(lknt,1) =-12 -2*mod(isc/9,3)
57016  idlam(lknt,2) =-11 -2*mod(isc/3,3)
57017  idlam(lknt,3) = 11 +2*mod(isc,3)
57018  xlam(lknt) = 0d0
57019 C...Set coupling, and decay product masses on/off
57020  rvlamc = rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1
57021  & ,mod(isc,3)+1)**2
57022  dcmass=.false.
57023  IF (idlam(lknt,2).EQ.-15.OR.idlam(lknt,3).EQ.15)
57024  & dcmass = .true.
57025 C...Resonance KF codes (1=I,2=J,3=K)
57026  kfr(1)=-idlam(lknt,1)
57027  kfr(2)=-idlam(lknt,2)
57028  kfr(3)=-idlam(lknt,3)
57029 C...Calculate width.
57030  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57031  & idlam(lknt,3),xlam(lknt))
57032  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57033 C...Charge conjugate mode.
57034  lknt=lknt+1
57035  idlam(lknt,1)=-idlam(lknt-1,1)
57036  idlam(lknt,2)=-idlam(lknt-1,2)
57037  idlam(lknt,3)=-idlam(lknt-1,3)
57038  xlam(lknt)=xlam(lknt-1)
57039 C...KINEMATICS CHECK
57040  IF (xlam(lknt).EQ.0d0) THEN
57041  lknt=lknt-2
57042  ENDIF
57043  ENDIF
57044  130 CONTINUE
57045  ENDIF
57046 
57047  IF (imss(52).GE.1) THEN
57048 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57049 C * CHI0 -> NUBAR_I + DBAR_J + D_K
57050  DO 140 isc=0,26
57051  lknt = lknt+1
57052  idlam(lknt,1) =-12 -2*mod(isc/9,3)
57053  idlam(lknt,2) = -1 -2*mod(isc/3,3)
57054  idlam(lknt,3) = 1 +2*mod(isc,3)
57055  xlam(lknt) = 0d0
57056 C...Set coupling, and decay product masses on/off
57057  rvlamc = 3 * rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1
57058  & ,mod(isc,3)+1)**2
57059  dcmass=.false.
57060  IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.5)
57061  & dcmass = .true.
57062 C...Resonance KF codes (1=I,2=J,3=K)
57063  kfr(1)=-idlam(lknt,1)
57064  kfr(2)=-idlam(lknt,2)
57065  kfr(3)=-idlam(lknt,3)
57066 C...Calculate width.
57067  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57068  & ,xlam(lknt))
57069  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57070 C...Charge conjugate mode.
57071  lknt=lknt+1
57072  idlam(lknt,1)=-idlam(lknt-1,1)
57073  idlam(lknt,2)=-idlam(lknt-1,2)
57074  idlam(lknt,3)=-idlam(lknt-1,3)
57075  xlam(lknt)=xlam(lknt-1)
57076 C...KINEMATICS CHECK
57077  IF (xlam(lknt).EQ.0d0) THEN
57078  lknt=lknt-2
57079  ENDIF
57080 
57081 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57082  lknt = lknt+1
57083  idlam(lknt,1) =-11 -2*mod(isc/9,3)
57084  idlam(lknt,2) = -2 -2*mod(isc/3,3)
57085  idlam(lknt,3) = 1 +2*mod(isc,3)
57086  xlam(lknt) = 0d0
57087 C...Set coupling, and decay product masses on/off
57088  rvlamc = 3 * rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1
57089  & ,mod(isc,3)+1)**2
57090  dcmass=.false.
57091  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-6
57092  & .OR.idlam(lknt,3).EQ.5) dcmass=.true.
57093 C...Resonance KF codes (1=I,2=J,3=K)
57094  kfr(1)=-idlam(lknt,1)
57095  kfr(2)=-idlam(lknt,2)
57096  kfr(3)=-idlam(lknt,3)
57097 C...Calculate width.
57098  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57099  & ,xlam(lknt))
57100  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57101 C...Charge conjugate mode.
57102  lknt=lknt+1
57103  idlam(lknt,1)=-idlam(lknt-1,1)
57104  idlam(lknt,2)=-idlam(lknt-1,2)
57105  idlam(lknt,3)=-idlam(lknt-1,3)
57106  xlam(lknt)=xlam(lknt-1)
57107 C...KINEMATICS CHECK
57108  IF (xlam(lknt).EQ.0d0) THEN
57109  lknt=lknt-2
57110  ENDIF
57111  140 CONTINUE
57112  ENDIF
57113 
57114  IF (imss(53).GE.1) THEN
57115 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57116 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57117  DO 150 isc=0,26
57118 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57119  IF (mod(isc/3,3).LT.mod(isc,3)) THEN
57120  lknt = lknt+1
57121  idlam(lknt,1) = -2 -2*mod(isc/9,3)
57122  idlam(lknt,2) = -1 -2*mod(isc/3,3)
57123  idlam(lknt,3) = -1 -2*mod(isc,3)
57124  xlam(lknt) = 0d0
57125 C...Set coupling, and decay product masses on/off
57126  rvlamc = 6. * rvlamb(mod(isc/9,3)+1,mod(isc/3,3)
57127  & +1,mod(isc,3)+1)**2
57128  dcmass=.false.
57129  IF (idlam(lknt,1).EQ.-6.OR.idlam(lknt,2).EQ.-5
57130  & .OR.idlam(lknt,3).EQ.-5) dcmass=.true.
57131 C...Resonance KF codes (1=I,2=J,3=K)
57132  kfr(1) = idlam(lknt,1)
57133  kfr(2) = idlam(lknt,2)
57134  kfr(3) = idlam(lknt,3)
57135 C...Calculate width.
57136  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57137  & idlam(lknt,3),xlam(lknt))
57138  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57139 C...Charge conjugate mode.
57140  lknt=lknt+1
57141  idlam(lknt,1)=-idlam(lknt-1,1)
57142  idlam(lknt,2)=-idlam(lknt-1,2)
57143  idlam(lknt,3)=-idlam(lknt-1,3)
57144  xlam(lknt)=xlam(lknt-1)
57145 C...KINEMATICS CHECK
57146  IF (xlam(lknt).EQ.0d0) THEN
57147  lknt=lknt-2
57148  ENDIF
57149  ENDIF
57150  150 CONTINUE
57151  ENDIF
57152  ENDIF
57153  ENDIF
57154 
57155  RETURN
57156  END
57157 
57158 C*********************************************************************
57159 
57160 C...PYRVCH
57161 C...Calculates R-violating chargino decay widths.
57162 C...P. Z. Skands
57163 
57164  SUBROUTINE pyrvch(KFIN,XLAM,IDLAM,LKNT)
57165 
57166 C...Double precision and integer declarations.
57167  IMPLICIT DOUBLE PRECISION(a-h, o-z)
57168  IMPLICIT INTEGER(I-N)
57169 C...Parameter statement to help give large particle numbers.
57170  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57171  &kexcit=4000000,kdimen=5000000)
57172 C...Commonblocks.
57173  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57174  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57175  common/pymssm/imss(0:99),rmss(0:99)
57176  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57177  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57178  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
57179 C...Local variables.
57180  DOUBLE PRECISION XLAM(0:400)
57181  INTEGER IDLAM(400,3), PYCOMP
57182 C...Information from main routine to PYRVGW
57183  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
57184  & ,dcmass,kfr(3)
57185 C...Auxiliary variables needed for BV (RV Gauge STOre)
57186  common/rvgsto/xresi,xresj,xresk,xresij,xresik,xresjk,rvlijk,rvlkij
57187  & ,rvljki,rvljik
57188 C...Running quark masses
57189  DOUBLE PRECISION RMQ(6)
57190 C...Decay product masses on/off
57191  LOGICAL DCMASS
57192  SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57193  & /rvgsto/
57194 
57195 
57196 C...IF R-VIOLATION ON.
57197  IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
57198  kfsm=kfin-ksusy1
57199  IF(kfsm.EQ.24.OR.kfsm.EQ.37) THEN
57200 C...WHICH CHARGINO ?
57201  nchi = 1
57202  IF (kfsm.EQ.37) nchi = 2
57203 
57204 C...Useful parameters for calculating the A and B constants.
57205 C...SIGN OF MASS (Opposite convention as HERWIG)
57206  ism = 1
57207  IF (smw(nchi).LT.0d0) ism = -1
57208  wmass = pmas(pycomp(24),1)
57209  cosb = 1/(sqrt(1+rmss(5)**2))
57210  sinb = rmss(5)/sqrt(1+rmss(5)**2)
57211  gw2 = 4*paru(103)*paru(1)/paru(102)
57212  c1u = umix(nchi,2)/(sqrt(2d0)*cosb*wmass)
57213  c1v = vmix(nchi,2)/(sqrt(2d0)*sinb*wmass)
57214  c2 = umix(nchi,1)
57215  c3 = vmix(nchi,1)
57216 C...Running masses at Q^2=MCHI^2.
57217  sqmchi = pmas(pycomp(kfsm),1)**2
57218  DO 100 i=1,6
57219  rmq(i)=pymrun(i,sqmchi)
57220  100 CONTINUE
57221 
57222 C... AB(x,y,z) coefficients:
57223 C x=1-2 : A or B coefficient (1:A ; 2:B)
57224 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57225 C 11-16:e,nu_e,mu,...)
57226 C z=1-2 : Mass eigenstate number
57227  DO 110 i = 11,15,2
57228 C...Intermediate sleptons
57229  ab(1,i,1) = 0d0
57230  ab(1,i,2) = 0d0
57231  ab(2,i,1) = -pmas(pycomp(i),1)*c1u*sfmix(i,2) +
57232  & sfmix(i,1)*c2
57233  ab(2,i,2) = -pmas(pycomp(i),1)*c1u*sfmix(i,4) +
57234  & sfmix(i,3)*c2
57235 C...Intermediate sneutrinos
57236  ab(1,i+1,1) = -pmas(pycomp(i),1)*c1u
57237  ab(1,i+1,2) = 0d0
57238  ab(2,i+1,1) = ism*c3
57239  ab(2,i+1,2) = 0d0
57240 C...Intermediate sdown
57241  j=i-10
57242  ab(1,j,1) = -rmq(j+1)*c1v*sfmix(j,1)
57243  ab(1,j,2) = -rmq(j+1)*c1v*sfmix(j,3)
57244  ab(2,j,1) = -ism*(rmq(j)*c1u*sfmix(j,2) - sfmix(j,1)*c2)
57245  ab(2,j,2) = -ism*(rmq(j)*c1u*sfmix(j,4) - sfmix(j,3)*c2)
57246 C...Intermediate sup
57247  j=j+1
57248  ab(1,j,1) = -rmq(j-1)*c1u*sfmix(j,1)
57249  ab(1,j,2) = -rmq(j-1)*c1u*sfmix(j,3)
57250  ab(2,j,1) = -ism*(rmq(j)*c1v*sfmix(j,2) - sfmix(j,1)*c3)
57251  ab(2,j,2) = -ism*(rmq(j)*c1v*sfmix(j,4) - sfmix(j,3)*c3)
57252  110 CONTINUE
57253 
57254 C...LLE TYPE R-VIOLATION
57255  IF (imss(51).GE.1) THEN
57256 C...LOOP OVER DECAY MODES
57257  DO 140 isc=0,26
57258 
57259 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57260  IF(mod(isc/9,3).NE.mod(isc/3,3)) THEN
57261  lknt = lknt+1
57262  idlam(lknt,1) = -12 -2*mod(isc/9,3)
57263  idlam(lknt,2) = -11 -2*mod(isc/3,3)
57264  idlam(lknt,3) = 12 +2*mod(isc,3)
57265  xlam(lknt) = 0d0
57266 C...Set coupling, and decay product masses on/off
57267  rvlamc = gw2 * 5d-1 *
57268  & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
57269  & **2
57270  dcmass=.false.
57271  IF (idlam(lknt,2).EQ.-15) dcmass = .true.
57272 C...Resonance KF codes (1=I,2=J,3=K).
57273  kfr(1) = 0
57274  kfr(2) = 0
57275  kfr(3) = -idlam(lknt,3)+1
57276 C...Calculate width.
57277  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57278  & idlam(lknt,3),xlam(lknt))
57279  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57280 C...KINEMATICS CHECK
57281  IF (xlam(lknt).EQ.0d0) THEN
57282  lknt=lknt-1
57283  ENDIF
57284 
57285 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57286  120 IF (mod(isc/9,3).LT.mod(isc/3,3)) THEN
57287  lknt = lknt+1
57288  idlam(lknt,1) = 12 +2*mod(isc/9,3)
57289  idlam(lknt,2) = 12 +2*mod(isc/3,3)
57290  idlam(lknt,3) =-11 -2*mod(isc,3)
57291  xlam(lknt) = 0d0
57292 C...Set coupling, and decay product masses on/off
57293  rvlamc = gw2 * 5d-1 *
57294  & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57295 C...I,J SYMMETRY => FACTOR 2
57296  rvlamc=2*rvlamc
57297  dcmass=.false.
57298  IF (idlam(lknt,3).EQ.-15) dcmass = .true.
57299 C...Resonance KF codes (1=I,2=J,3=K)
57300  kfr(1)=idlam(lknt,1)-1
57301  kfr(2)=idlam(lknt,2)-1
57302  kfr(3)=0
57303 C...Calculate width.
57304  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57305  & idlam(lknt,3),xlam(lknt))
57306  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57307 C...KINEMATICS CHECK
57308  IF (xlam(lknt).EQ.0d0) THEN
57309  lknt=lknt-1
57310  ENDIF
57311  130 ENDIF
57312 
57313 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57314  lknt = lknt+1
57315  idlam(lknt,1) =-11 -2*mod(isc/9,3)
57316  idlam(lknt,2) =-11 -2*mod(isc/3,3)
57317  idlam(lknt,3) = 11 +2*mod(isc,3)
57318  xlam(lknt) = 0d0
57319 C...Set coupling, and decay product masses on/off
57320  rvlamc = gw2 * 5d-1 *
57321  & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57322 C...I,J SYMMETRY => FACTOR 2
57323  rvlamc=2*rvlamc
57324  dcmass=.false.
57325  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-15
57326  & .OR.idlam(lknt,3).EQ.15) dcmass = .true.
57327 C...Resonance KF codes (1=I,2=J,3=K)
57328  kfr(1) =-idlam(lknt,1)+1
57329  kfr(2) =-idlam(lknt,2)+1
57330  kfr(3) = 0
57331 C...Calculate width.
57332  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57333  & idlam(lknt,3),xlam(lknt))
57334  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57335 C...KINEMATICS CHECK
57336  IF (xlam(lknt).EQ.0d0) THEN
57337  lknt=lknt-1
57338  ENDIF
57339  ENDIF
57340  140 CONTINUE
57341  ENDIF
57342 
57343 C...LQD TYPE R-VIOLATION
57344  IF (imss(52).GE.1) THEN
57345 C...LOOP OVER DECAY MODES
57346  DO 180 isc=0,26
57347 
57348 C...CHI+ -> NUBAR_I + DBAR_J + U_K
57349  lknt = lknt+1
57350  idlam(lknt,1) =-12 -2*mod(isc/9,3)
57351  idlam(lknt,2) = -1 -2*mod(isc/3,3)
57352  idlam(lknt,3) = 2 +2*mod(isc,3)
57353  xlam(lknt) = 0d0
57354 C...Set coupling, and decay product masses on/off
57355  rvlamc = 3. * gw2 * 5d-1 *
57356  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57357  dcmass=.false.
57358  IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.6)
57359  & dcmass = .true.
57360 C...Resonance KF codes (1=I,2=J,3=K)
57361  kfr(1)=0
57362  kfr(2)=0
57363  kfr(3)=-idlam(lknt,3)+1
57364 C...Calculate width.
57365  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57366  & ,xlam(lknt))
57367  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57368 C...KINEMATICS CHECK
57369  IF (xlam(lknt).EQ.0d0) THEN
57370  lknt=lknt-1
57371  ENDIF
57372 
57373 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57374  150 lknt = lknt+1
57375  idlam(lknt,1) =-11 -2*mod(isc/9,3)
57376  idlam(lknt,2) = -2 -2*mod(isc/3,3)
57377  idlam(lknt,3) = 2 +2*mod(isc,3)
57378  xlam(lknt) = 0d0
57379 C...Set coupling, and decay product masses on/off
57380  rvlamc = 3. * gw2 * 5d-1 *
57381  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57382  dcmass=.false.
57383  IF (idlam(lknt,1).EQ.-11.OR.idlam(lknt,2).EQ.-6
57384  & .OR.idlam(lknt,3).EQ.6) dcmass = .true.
57385 C...Resonance KF codes (1=I,2=J,3=K)
57386  kfr(1)=0
57387  kfr(2)=0
57388  kfr(3)=-idlam(lknt,3)+1
57389 C...Calculate width.
57390  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57391  & ,xlam(lknt))
57392  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57393 C...KINEMATICS CHECK
57394  IF (xlam(lknt).EQ.0d0) THEN
57395  lknt=lknt-1
57396  ENDIF
57397 
57398 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57399  160 lknt = lknt+1
57400  idlam(lknt,1) =-11 -2*mod(isc/9,3)
57401  idlam(lknt,2) = -1 -2*mod(isc/3,3)
57402  idlam(lknt,3) = 1 +2*mod(isc,3)
57403  xlam(lknt) = 0d0
57404 C...Set coupling, and decay product masses on/off
57405  rvlamc = 3. * gw2 * 5d-1 *
57406  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57407  dcmass = .false.
57408  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-5
57409  & .OR.idlam(lknt,3).EQ.5) dcmass = .true.
57410 C...Resonance KF codes (1=I,2=J,3=K)
57411  kfr(1)=-idlam(lknt,1)+1
57412  kfr(2)=-idlam(lknt,2)+1
57413  kfr(3)=0
57414 C...Calculate width.
57415  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57416  & ,xlam(lknt))
57417  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57418 C...KINEMATICS CHECK
57419  IF (xlam(lknt).EQ.0d0) THEN
57420  lknt=lknt-1
57421  ENDIF
57422 
57423 C * CHI+ -> NU_I + U_J + DBAR_K.
57424  170 lknt = lknt+1
57425  idlam(lknt,1) = 12 +2*mod(isc/9,3)
57426  idlam(lknt,2) = 2 +2*mod(isc/3,3)
57427  idlam(lknt,3) = -1 -2*mod(isc,3)
57428  xlam(lknt) = 0d0
57429 C...Set coupling, and decay product masses on/off
57430  dcmass = .false.
57431  rvlamc = 3. * gw2 * 5d-1 *
57432  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57433  IF (idlam(lknt,2).EQ.6.OR.idlam(lknt,3).EQ.-5)
57434  & dcmass = .true.
57435 C...Resonance KF codes (1=I,2=J,3=K)
57436  kfr(1)=idlam(lknt,1)-1
57437  kfr(2)=idlam(lknt,2)-1
57438  kfr(3)=0
57439 C...Calculate width.
57440  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57441  & ,xlam(lknt))
57442  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57443 C...KINEMATICS CHECK
57444  IF (xlam(lknt).EQ.0d0) THEN
57445  lknt=lknt-1
57446  ENDIF
57447 
57448  180 CONTINUE
57449  ENDIF
57450 
57451 C...UDD TYPE R-VIOLATION
57452 C...These decays need special treatment since more than one BV coupling
57453 C...contributes (with interference). Consider e.g. (symbolically)
57454 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57455 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57456 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57457 C...The problem is that a single call to PYRVGW would evaluate all
57458 C...these terms and sum them, but without the different couplings. The
57459 C...way out is to call PYRVGW three times, once for the first line, once
57460 C...for the second line, and then once for all the lines (it is
57461 C...impossible to get just the last line out) without multiplying by
57462 C...couplings. The last line is then obtained as the result of the third
57463 C...call minus the results of the two first calls. Each term is then
57464 C...multiplied by its respective coupling before the whole thing is
57465 C...summed up in XLAM.
57466 C...Note that with three interfering resonances, this procedure becomes
57467 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57468 
57469  IF (imss(53).GE.1) THEN
57470 C...LOOP OVER DECAY MODES
57471  DO 190 isc=1,25
57472 
57473 C...CHI+ -> U_I + U_J + D_K
57474 C...Decay mode I<->J symmetric.
57475  IF (mod(isc/9,3).LE.mod(isc/3,3).AND.isc.NE.13) THEN
57476  lknt = lknt+1
57477  idlam(lknt,1) = 2 +2*mod(isc/9,3)
57478  idlam(lknt,2) = 2 +2*mod(isc/3,3)
57479  idlam(lknt,3) = 1 +2*mod(isc,3)
57480  xlam(lknt) = 0d0
57481 C...Set coupling, and decay product masses on/off
57482  rvlamc= 6. * gw2 * 5d-1
57483  rvljik= rvlamb(mod(isc/3,3)+1,mod(isc/9,3)+1,mod(isc,3)
57484  & +1)
57485  rvlijk= rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)
57486  & +1)
57487  IF (mod(isc/9,3).EQ.mod(isc/3,3)) rvlamc = 5d-1
57488  & * rvlamc
57489  dcmass=.false.
57490  IF (idlam(lknt,1).EQ.6.OR.idlam(lknt,2).EQ.6
57491  & .OR.idlam(lknt,3).EQ.5) dcmass =.true.
57492 C...Resonance KF codes (1=I,2=J,3=K)
57493  kfr(1) = -idlam(lknt,1)+1
57494  kfr(2) = 0
57495  kfr(3) = 0
57496 C...Calculate width.
57497  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57498  & idlam(lknt,3),xresi)
57499 C...Resonance KF codes (1=I,2=J,3=K)
57500  kfr(1) = 0
57501  kfr(2) = -idlam(lknt,2)+1
57502  kfr(3) = 0
57503 C...Calculate width.
57504  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57505  & idlam(lknt,3),xresj)
57506 C...Resonance KF codes (1=I,2=J,3=K)
57507  kfr(1) = -idlam(lknt,1)+1
57508  kfr(2) = -idlam(lknt,2)+1
57509  kfr(3) = 0
57510 C...Calculate width.
57511  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57512  & idlam(lknt,3),xresij)
57513  IF (abs(xresi+xresj-xresij).GT.1d-4*xresij) THEN
57514  xresij = xresij-xresi-xresj
57515  ELSE
57516  xresij = 0d0
57517  ENDIF
57518 C...CALCULATE TOTAL WIDTH
57519  xlam(lknt) = rvljik**2 * xresi + rvlijk**2 * xresj
57520  & + rvljik*rvlijk * xresij
57521  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57522 C...KINEMATICS CHECK
57523  IF (xlam(lknt).EQ.0d0) THEN
57524  lknt=lknt-1
57525  ENDIF
57526  ENDIF
57527 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57528 C...Symmetry I<->J<->K.
57529  IF ((mod(isc/9,3).LE.mod(isc/3,3)).AND.(mod(isc/3,3).le
57530  & .mod(isc,3)).AND.isc.NE.13) THEN
57531  lknt = lknt+1
57532  idlam(lknt,1) = -1 -2*mod(isc/9,3)
57533  idlam(lknt,2) = -1 -2*mod(isc/3,3)
57534  idlam(lknt,3) = -1 -2*mod(isc,3)
57535  xlam(lknt) = 0d0
57536 C...Set coupling, and decay product masses on/off
57537  rvlamc = 6. * gw2 * 5d-1
57538  rvlijk = rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)
57539  & +1)
57540  rvlkij = rvlamb(mod(isc,3)+1,mod(isc/9,3)+1,mod(isc/3,3)
57541  & +1)
57542  rvljki = rvlamb(mod(isc/3,3)+1,mod(isc,3)+1,mod(isc/9,3)
57543  & +1)
57544  dcmass = .false.
57545  IF (idlam(lknt,1).EQ.-5.OR.idlam(lknt,2).EQ.-5
57546  & .OR.idlam(lknt,3).EQ.-5) dcmass = .true.
57547 C...Collect symmetry factors
57548  IF (mod(isc/9,3).EQ.mod(isc/3,3).OR.mod(isc/3,3).eq
57549  & .mod(isc,3).OR.mod(isc/9,3).EQ.mod(isc,3))
57550  & rvlamc = 5d-1 * rvlamc
57551 C...Resonance KF codes (1=I,2=J,3=K)
57552  kfr(1) = idlam(lknt,1)-1
57553  kfr(2) = 0
57554  kfr(3) = 0
57555 C...Calculate width.
57556  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57557  & idlam(lknt,3),xresi)
57558 C...Resonance KF codes (1=I,2=J,3=K)
57559  kfr(1) = 0
57560  kfr(2) = idlam(lknt,2)-1
57561  kfr(3) = 0
57562 C...Calculate width.
57563  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57564  & idlam(lknt,3),xresj)
57565 C...Resonance KF codes (1=I,2=J,3=K)
57566  kfr(1) = 0
57567  kfr(2) = 0
57568  kfr(3) = idlam(lknt,3)-1
57569 C...Calculate width.
57570  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57571  & idlam(lknt,3),xresk)
57572 C...Resonance KF codes (1=I,2=J,3=K)
57573  kfr(1) = idlam(lknt,1)-1
57574  kfr(2) = idlam(lknt,2)-1
57575  kfr(3) = 0
57576 C...Calculate width.
57577  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57578  & idlam(lknt,3),xresij)
57579  IF (abs(xresi+xresj-xresij).GT.1d-4*(xresi+xresj)) THEN
57580  xresij = xresi+xresj-xresij
57581  ELSE
57582  xresij = 0d0
57583  ENDIF
57584 C...Resonance KF codes (1=I,2=J,3=K)
57585  kfr(1) = 0
57586  kfr(2) = idlam(lknt,2)-1
57587  kfr(3) = idlam(lknt,3)-1
57588 C...Calculate width.
57589  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57590  & idlam(lknt,3),xresjk)
57591  IF (abs(xresj+xresk-xresjk).GT.1d-4*(xresj+xresk)) THEN
57592  xresjk = xresj+xresk-xresjk
57593  ELSE
57594  xresjk = 0d0
57595  ENDIF
57596 C...Resonance KF codes (1=I,2=J,3=K)
57597  kfr(1) = idlam(lknt,1)-1
57598  kfr(2) = 0
57599  kfr(3) = idlam(lknt,3)-1
57600 C...Calculate width.
57601  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57602  & idlam(lknt,3),xresik)
57603  IF (abs(xresi+xresk-xresik).GT.1d-4*(xresi+xresk)) THEN
57604  xresik = xresi+xresk-xresik
57605  ELSE
57606  xresik = 0d0
57607  ENDIF
57608 C...CALCULATE TOTAL WIDTH
57609  xlam(lknt) =
57610  & rvlijk**2 * xresi
57611  & + rvljki**2 * xresj
57612  & + rvlkij**2 * xresk
57613  & + rvlijk*rvljki * xresij
57614  & + rvlijk*rvlkij * xresik
57615  & + rvljki*rvlkij * xresjk
57616  xlam(lknt)=xlam(lknt)*rvlamc/((2.*paru(1)*rms(0))**3*32)
57617 C...KINEMATICS CHECK
57618  IF (xlam(lknt).EQ.0d0) THEN
57619  lknt=lknt-1
57620  ENDIF
57621  ENDIF
57622  190 CONTINUE
57623  ENDIF
57624  ENDIF
57625  ENDIF
57626 
57627  RETURN
57628  END
57629 
57630 C*********************************************************************
57631 
57632 C...PYRVGL
57633 C...Calculates R-violating gluino decay widths.
57634 C...See BV part of PYRVCH for comments about the way the BV decay width
57635 C...is calculated. Same comments apply here.
57636 C...P. Z. Skands
57637 
57638  SUBROUTINE pyrvgl(KFIN,XLAM,IDLAM,LKNT)
57639 
57640 C...Double precision and integer declarations.
57641  IMPLICIT DOUBLE PRECISION(a-h, o-z)
57642  IMPLICIT INTEGER(I-N)
57643 C...Parameter statement to help give large particle numbers.
57644  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57645  &kexcit=4000000,kdimen=5000000)
57646 C...Commonblocks.
57647  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57648  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57649  common/pymssm/imss(0:99),rmss(0:99)
57650  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57651  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57652  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
57653 C...Local variables.
57654  DOUBLE PRECISION XLAM(0:400)
57655  INTEGER IDLAM(400,3), PYCOMP
57656 C...Information from main routine to PYRVGW
57657  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
57658  & ,dcmass,kfr(3)
57659 C...Auxiliary variables needed for BV (RV Gauge STOre)
57660  common/rvgsto/xresi,xresj,xresk,xresij,xresik,xresjk,rvlijk,rvlkij
57661  & ,rvljki,rvljik
57662 C...Running quark masses
57663  DOUBLE PRECISION RMQ(6)
57664 C...Decay product masses on/off
57665  LOGICAL DCMASS
57666  SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57667  & /rvgsto/
57668 
57669 C...IF LQD OR UDD TYPE R-VIOLATION ON.
57670  IF (imss(52).GE.1.OR.imss(53).GE.1) THEN
57671  kfsm=kfin-ksusy1
57672 
57673 C... AB(x,y,z):
57674 C x=1-2 : Select A or B coupling (1:A ; 2:B)
57675 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57676 C 11-16:e,nu_e,mu,... not used here)
57677 C z=1-2 : Mass eigenstate number
57678  DO 100 i = 1,6
57679 C...A Couplings
57680  ab(1,i,1) = sfmix(i,2)
57681  ab(1,i,2) = sfmix(i,4)
57682 C...B Couplings
57683  ab(2,i,1) = -sfmix(i,1)
57684  ab(2,i,2) = -sfmix(i,3)
57685  100 CONTINUE
57686  gstr2 = 4d0*paru(1) * pyalps(pmas(pycomp(kfin),1)**2)
57687 C...LQD DECAYS.
57688  IF (imss(52).GE.1) THEN
57689 C...STEP IN I,J,K USING SINGLE COUNTER
57690  DO 120 isc=0,26
57691 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57692  lknt = lknt+1
57693  idlam(lknt,1) =-12 -2*mod(isc/9,3)
57694  idlam(lknt,2) = -1 -2*mod(isc/3,3)
57695  idlam(lknt,3) = 1 +2*mod(isc,3)
57696  xlam(lknt)=0d0
57697 C...Set coupling, and decay product masses on/off
57698  rvlamc=rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57699  & * 5d-1 * gstr2
57700  dcmass = .false.
57701  IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.5) dcmass=.true.
57702 C...Resonance KF codes (1=I,2=J,3=K)
57703  kfr(1) = 0
57704  kfr(2) = -idlam(lknt,2)
57705  kfr(3) = -idlam(lknt,3)
57706 C...Calculate width.
57707  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57708  & ,xlam(lknt))
57709 C...Normalize
57710  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57711 C...Charge conjugate mode.
57712  110 lknt = lknt+1
57713  idlam(lknt,1) =-idlam(lknt-1,1)
57714  idlam(lknt,2) =-idlam(lknt-1,2)
57715  idlam(lknt,3) =-idlam(lknt-1,3)
57716  xlam(lknt) = xlam(lknt-1)
57717 C...KINEMATICS CHECK
57718  IF (xlam(lknt).EQ.0d0) THEN
57719  lknt=lknt-2
57720  ENDIF
57721 
57722 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57723  lknt = lknt+1
57724  idlam(lknt,1) =-11 -2*mod(isc/9,3)
57725  idlam(lknt,2) = -2 -2*mod(isc/3,3)
57726  idlam(lknt,3) = 1 +2*mod(isc,3)
57727  xlam(lknt)=0d0
57728 C...Set coupling, and decay product masses on/off
57729  rvlamc = rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
57730  & **2* 5d-1 * gstr2
57731  dcmass = .false.
57732  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-6
57733  & .OR.idlam(lknt,3).EQ.5) dcmass = .true.
57734 C...Resonance KF codes (1=I,2=J,3=K)
57735  kfr(1) = 0
57736  kfr(2) = -idlam(lknt,2)
57737  kfr(3) = -idlam(lknt,3)
57738 C...Calculate width.
57739  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57740  & ,xlam(lknt))
57741  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57742 C...Charge conjugate mode.
57743  lknt=lknt+1
57744  idlam(lknt,1) = -idlam(lknt-1,1)
57745  idlam(lknt,2) = -idlam(lknt-1,2)
57746  idlam(lknt,3) = -idlam(lknt-1,3)
57747  xlam(lknt) = xlam(lknt-1)
57748 C...KINEMATICS CHECK
57749  IF (xlam(lknt).EQ.0d0) THEN
57750  lknt=lknt-2
57751  ENDIF
57752 
57753  120 CONTINUE
57754  ENDIF
57755 
57756 C...UDD DECAYS.
57757  IF (imss(53).GE.1) THEN
57758 C...STEP IN I,J,K USING SINGLE COUNTER
57759  DO 130 isc=0,26
57760 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57761  IF (mod(isc/3,3).LT.mod(isc,3)) THEN
57762  lknt = lknt+1
57763  idlam(lknt,1) = -2 -2*mod(isc/9,3)
57764  idlam(lknt,2) = -1 -2*mod(isc/3,3)
57765  idlam(lknt,3) = -1 -2*mod(isc,3)
57766  xlam(lknt)=0d0
57767 C...Set coupling, and decay product masses on/off. A factor of 2 for
57768 C...(N_C-1) has been used to cancel a factor 0.5.
57769  rvlamc=rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
57770  & **2 * gstr2
57771  dcmass = .false.
57772  IF (idlam(lknt,1).EQ.-6.OR.idlam(lknt,2).EQ.-5
57773  & .OR.idlam(lknt,3).EQ.-5) dcmass=.true.
57774 C...Resonance KF codes (1=I,2=J,3=K)
57775  kfr(1) = idlam(lknt,1)
57776  kfr(2) = 0
57777  kfr(3) = 0
57778 C...Calculate width.
57779  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57780  & ,xresi)
57781 C...Resonance KF codes (1=I,2=J,3=K)
57782  kfr(1) = 0
57783  kfr(2) = idlam(lknt,2)
57784  kfr(3) = 0
57785 C...Calculate width.
57786  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57787  & ,xresj)
57788 C...Resonance KF codes (1=I,2=J,3=K)
57789  kfr(1) = 0
57790  kfr(2) = 0
57791  kfr(3) = idlam(lknt,3)
57792 C...Calculate width.
57793  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57794  & ,xresk)
57795 C...Resonance KF codes (1=I,2=J,3=K)
57796  kfr(1) = idlam(lknt,1)
57797  kfr(2) = idlam(lknt,2)
57798  kfr(3) = 0
57799 C...Calculate width.
57800  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57801  & ,xresij)
57802 C...Calculate interference function. (Factor -1/2 to make up for factor
57803 C...-2 in PYRVGW.
57804  IF (abs(xresi+xresj-xresij).GT.1d-4*xresij) THEN
57805  xresij = 5d-1 * (xresi+xresj-xresij)
57806  ELSE
57807  xresij = 0d0
57808  ENDIF
57809 C...Resonance KF codes (1=I,2=J,3=K)
57810  kfr(1) = 0
57811  kfr(2) = idlam(lknt,2)
57812  kfr(3) = idlam(lknt,3)
57813 C...Calculate width.
57814  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57815  & ,xresjk)
57816  IF (abs(xresj+xresk-xresjk).GT.1d-4*xresjk) THEN
57817  xresjk = 5d-1 * (xresj+xresk-xresjk)
57818  ELSE
57819  xresjk = 0d0
57820  ENDIF
57821 C...Resonance KF codes (1=I,2=J,3=K)
57822  kfr(1) = idlam(lknt,1)
57823  kfr(2) = 0
57824  kfr(3) = idlam(lknt,3)
57825 C...Calculate width.
57826  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57827  & ,xresik)
57828  IF (abs(xresi+xresk-xresik).GT.1d-4*xresik) THEN
57829  xresik = 5d-1 * (xresi+xresk-xresik)
57830  ELSE
57831  xresik = 0d0
57832  ENDIF
57833 C...Calculate total width (factor 1/2 from 1/(N_C-1))
57834  xlam(lknt) = xresi + xresj + xresk
57835  & + 5d-1 * (xresij + xresik + xresjk)
57836 C...Normalize
57837  xlam(lknt) = xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57838 C...Charge conjugate mode.
57839  lknt = lknt+1
57840  idlam(lknt,1) =-idlam(lknt-1,1)
57841  idlam(lknt,2) =-idlam(lknt-1,2)
57842  idlam(lknt,3) =-idlam(lknt-1,3)
57843  xlam(lknt) = xlam(lknt-1)
57844 C...KINEMATICS CHECK
57845  IF (xlam(lknt).EQ.0d0) THEN
57846  lknt=lknt-2
57847  ENDIF
57848  ENDIF
57849  130 CONTINUE
57850  ENDIF
57851  ENDIF
57852  RETURN
57853  END
57854 
57855 C*********************************************************************
57856 
57857 C...PYRVSB
57858 C...Auxiliary function to PYRVSF for calculating R-Violating
57859 C...sfermion widths. Though the decay products are most often treated
57860 C...as massless in the calculation, the kinematical boundary of phase
57861 C...space is tested using the true masses.
57862 C...MODE = 1: All decay products massive
57863 C...MODE = 2: Decay product 1 massless
57864 C...MODE = 3: Decay product 2 massless
57865 C...MODE = 4: All decay products massless
57866 
57867  FUNCTION pyrvsb(KFIN,ID1,ID2,RM2,MODE)
57868 
57869  IMPLICIT DOUBLE PRECISION (a-h,o-z)
57870  IMPLICIT INTEGER (I-N)
57871  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57872  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57873  SAVE /pydat1/,/pydat2/
57874  DOUBLE PRECISION SM(3)
57875  INTEGER PYCOMP, KC(3)
57876  kc(1)=pycomp(kfin)
57877  kc(2)=pycomp(id1)
57878  kc(3)=pycomp(id2)
57879  sm(1)=pmas(kc(1),1)**2
57880  sm(2)=pmas(kc(2),1)**2
57881  sm(3)=pmas(kc(3),1)**2
57882 C...Kinematics check
57883  IF ((sm(1)-(pmas(kc(2),1)+pmas(kc(3),1))**2).LE.0d0) THEN
57884  pyrvsb=0d0
57885  RETURN
57886  ENDIF
57887 C...CM momenta squared
57888  IF (mode.EQ.1) THEN
57889  p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(2),1)+pmas(kc(3),1))**2)
57890  & * (sm(1)-(pmas(kc(2),1)-pmas(kc(3),1))**2)
57891  ELSE IF (mode.EQ.2) THEN
57892  p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(3),1))**2)**2
57893  ELSE IF (mode.EQ.3) THEN
57894  p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(2),1))**2)**2
57895  ELSE
57896  p2cm=sm(1)/4.
57897  ENDIF
57898 C...Calculate Width
57899  pyrvsb=rm2*sqrt(max(0d0,p2cm))/(8*paru(1)*sm(1))
57900  RETURN
57901  END
57902 
57903 C*********************************************************************
57904 
57905 C...PYRVGW
57906 C...Generalized Matrix Element for R-Violating 3-body widths.
57907 C...P. Z. Skands
57908  SUBROUTINE pyrvgw(KFIN,ID1,ID2,ID3,XLAM)
57909 
57910  IMPLICIT DOUBLE PRECISION (a-h,o-z)
57911  IMPLICIT INTEGER (I-N)
57912  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57913  &kexcit=4000000,kdimen=5000000)
57914  parameter(eps=1d-4)
57915  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57916  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
57917  & ,dcmass,kfr(3)
57918  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57919  & sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57920  DOUBLE PRECISION XLIM(3,3)
57921  INTEGER KC(0:3), PYCOMP
57922  LOGICAL DCMASS, DCHECK(6)
57923  SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
57924 
57925  xlam = 0d0
57926 
57927  kc(0) = pycomp(kfin)
57928  kc(1) = pycomp(id1)
57929  kc(2) = pycomp(id2)
57930  kc(3) = pycomp(id3)
57931  rms(0) = pmas(kc(0),1)
57932  rms(1) = pymrun(id1,pmas(kc(1),1)**2)
57933  rms(2) = pymrun(id2,pmas(kc(2),1)**2)
57934  rms(3) = pymrun(id3,pmas(kc(3),1)**2)
57935 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
57936  xlim(1,1)=(rms(1)+rms(2))**2
57937  xlim(1,2)=(rms(0)-rms(3))**2
57938  xlim(1,3)=xlim(1,2)-xlim(1,1)
57939  xlim(2,1)=(rms(2)+rms(3))**2
57940  xlim(2,2)=(rms(0)-rms(1))**2
57941  xlim(2,3)=xlim(2,2)-xlim(2,1)
57942  xlim(3,1)=(rms(1)+rms(3))**2
57943  xlim(3,2)=(rms(0)-rms(2))**2
57944  xlim(3,3)=xlim(3,2)-xlim(3,1)
57945 C...Check Phase Space
57946  IF (xlim(1,3).LT.0d0.OR.xlim(2,3).LT.0d0.OR.xlim(3,3).LT.0d0) THEN
57947  RETURN
57948  ENDIF
57949 
57950 C...INITIALIZE RESONANCE INFORMATION
57951  DO 110 jres = 1,3
57952  DO 100 imass = 1,2
57953  ires = 2*(jres-1)+imass
57954  intres(ires,1) = 0
57955  dcheck(ires) =.false.
57956 C...NO RIGHT-HANDED NEUTRINOS
57957  IF (((imass.EQ.2).AND.((iabs(kfr(jres)).EQ.12).or
57958  & .(iabs(kfr(jres)).EQ.14).OR.(iabs(kfr(jres)).EQ.16))).or
57959  & .kfr(jres).EQ.0) GOTO 100
57960  res(ires,1) = pmas(pycomp(imass*ksusy1+iabs(kfr(jres))),1)
57961  res(ires,2) = pmas(pycomp(imass*ksusy1+iabs(kfr(jres))),2)
57962  intres(ires,1) = iabs(kfr(jres))
57963  intres(ires,2) = imass
57964  IF (kfr(jres).LT.0) intres(ires,3) = 1
57965  IF (kfr(jres).GT.0) intres(ires,3) = 0
57966  100 CONTINUE
57967  110 CONTINUE
57968 
57969 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
57970 
57971 C...RESONANCE CONTRIBUTIONS
57972 C...(Only sum contributions where the resonance is off shell).
57973 C...Store whether diagram on/off in DCHECK.
57974 C...LOOP OVER MASS STATES
57975  DO 120 j=1,2
57976  idr=j
57977  IF(intres(idr,1).NE.0) THEN
57978 
57979  tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
57980  IF ((rms(0).LT.(rms(1)+res(idr,1)).OR.(res(idr,1).LT.(rms(2)
57981  & +rms(3)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
57982  dcheck(idr) =.true.
57983  xlam = xlam + tmix * pyrvi1(2,3,1)
57984  ENDIF
57985  ENDIF
57986 
57987  idr=j+2
57988  IF(intres(idr,1).NE.0) THEN
57989  tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
57990  IF ((rms(0).LT.(rms(2)+res(idr,1)).OR.(res(idr,1).LT.(rms(1)
57991  & +rms(3)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
57992  dcheck(idr) =.true.
57993  xlam = xlam + tmix * pyrvi1(1,3,2)
57994  ENDIF
57995  ENDIF
57996 
57997  idr=j+4
57998  IF(intres(idr,1).NE.0) THEN
57999  tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
58000  IF ((rms(0).LT.(rms(3)+res(idr,1)).OR.(res(idr,1).LT.(rms(1)
58001  & +rms(2)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
58002  dcheck(idr) =.true.
58003  xlam = xlam + tmix * pyrvi1(1,2,3)
58004  ENDIF
58005  ENDIF
58006  120 CONTINUE
58007 C... L-R INTERFERENCES
58008 C... (Only add contributions where both contributing diagrams
58009 C... are non-resonant).
58010  idr=1
58011  IF (dcheck(1).AND.dcheck(2)) THEN
58012 C...Bug corrected 11/12 2001. Skands.
58013  xlam = xlam + 2d0 * pyrvi2(2,3,1)
58014  & * sfmix(intres(1,1),2+intres(1,3)-1)
58015  & * sfmix(intres(2,1),4+intres(2,3)-1)
58016  ENDIF
58017 
58018  idr=3
58019  IF (dcheck(3).AND.dcheck(4)) THEN
58020  xlam = xlam + 2d0 * pyrvi2(1,3,2)
58021  & * sfmix(intres(3,1),2+intres(3,3)-1)
58022  & * sfmix(intres(4,1),4+intres(4,3)-1)
58023  ENDIF
58024 
58025  idr=5
58026  IF (dcheck(5).AND.dcheck(6)) THEN
58027  xlam = xlam + 2d0 * pyrvi2(1,2,3)
58028  & * sfmix(intres(5,1),2+intres(5,3)-1)
58029  & * sfmix(intres(6,1),4+intres(6,3)-1)
58030  ENDIF
58031 C... TRUE INTERFERENCES
58032 C... (Only add contributions where both contributing diagrams
58033 C... are non-resonant).
58034  pref=-2d0
58035  IF ((kfin-ksusy1).EQ.24.OR.(kfin-ksusy1).EQ.37) pref=2d0
58036  DO 140 ikr1 = 1,2
58037  DO 130 ikr2 = 1,2
58038  idr = ikr1+2
58039  idr2 = ikr2
58040  IF (dcheck(idr).AND.dcheck(idr2)) THEN
58041  xlam = xlam + pref*pyrvi3(1,3,2) *
58042  & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
58043  & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
58044  ENDIF
58045 
58046  idr = ikr1+4
58047  idr2 = ikr2
58048  IF (dcheck(idr).AND.dcheck(idr2)) THEN
58049  xlam = xlam + pref*pyrvi3(1,2,3) *
58050  & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
58051  & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
58052  ENDIF
58053 
58054  idr = ikr1+4
58055  idr2 = ikr2+2
58056  IF (dcheck(idr).AND.dcheck(idr2)) THEN
58057  xlam = xlam + pref*pyrvi3(2,1,3) *
58058  & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
58059  & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
58060  ENDIF
58061  130 CONTINUE
58062  140 CONTINUE
58063 
58064  RETURN
58065  END
58066 
58067 C*********************************************************************
58068 
58069 C...PYRVI1
58070 C...Function to integrate resonance contributions
58071 
58072  FUNCTION pyrvi1(ID1,ID2,ID3)
58073 
58074  IMPLICIT NONE
58075  DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58076  DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58077  INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58078  LOGICAL MFLAG,DCMASS
58079  EXTERNAL pyrvg1,pygaus
58080  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58081  & ,dcmass,kfr(3)
58082  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58083  SAVE/pyrvnv/,/pyrvpm/
58084 C...Initialize mass and width information
58085  pyrvi1 = 0d0
58086  rm(0) = rms(0)
58087  rm(1) = rms(id1)
58088  rm(2) = rms(id2)
58089  rm(3) = rms(id3)
58090  resm(1)= res(idr,1)
58091  resw(1)= res(idr,2)
58092 C...A->B and B->A for antisparticles
58093  a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
58094  b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
58095 C...Integration boundaries and mass flag
58096  lo = (rm(1)+rm(2))**2
58097  hi = (rm(0)-rm(3))**2
58098  mflag = dcmass
58099  pyrvi1 = pygaus(pyrvg1,lo,hi,1d-3)
58100  RETURN
58101  END
58102 
58103 C*********************************************************************
58104 
58105 C...PYRVI2
58106 C...Function to integrate L-R interference contributions
58107 
58108  FUNCTION pyrvi2(ID1,ID2,ID3)
58109 
58110  IMPLICIT NONE
58111  DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58112  DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58113  INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58114  LOGICAL MFLAG,DCMASS
58115  EXTERNAL pyrvg2,pygaus
58116  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58117  & ,dcmass,kfr(3)
58118  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58119  SAVE/pyrvnv/,/pyrvpm/
58120 C...Initialize mass and width information
58121  pyrvi2 = 0d0
58122  rm(0) = rms(0)
58123  rm(1) = rms(id1)
58124  rm(2) = rms(id2)
58125  rm(3) = rms(id3)
58126  resm(1)= res(idr,1)
58127  resw(1)= res(idr,2)
58128  resm(2)= res(idr+1,1)
58129  resw(2)= res(idr+1,2)
58130 C...A->B and B->A for antisparticles
58131  a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
58132  b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
58133  a(2) = ab(1+intres(idr+1,3),intres(idr+1,1),intres(idr+1,2))
58134  b(2) = ab(2-intres(idr+1,3),intres(idr+1,1),intres(idr+1,2))
58135 C...Boundaries and mass flag
58136  lo = (rm(1)+rm(2))**2
58137  hi = (rm(0)-rm(3))**2
58138  mflag = dcmass
58139  pyrvi2 = pygaus(pyrvg2,lo,hi,1d-3)
58140  RETURN
58141  END
58142 
58143 C*********************************************************************
58144 
58145 C...PYRVI3
58146 C...Function to integrate true interference contributions
58147 
58148  FUNCTION pyrvi3(ID1,ID2,ID3)
58149 
58150  IMPLICIT NONE
58151  DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58152  DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58153  INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58154  LOGICAL MFLAG,DCMASS
58155  EXTERNAL pyrvg3,pygaus
58156  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58157  & ,dcmass,kfr(3)
58158  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58159  SAVE/pyrvnv/,/pyrvpm/
58160 C...Initialize mass and width information
58161  pyrvi3 = 0d0
58162  rm(0) = rms(0)
58163  rm(1) = rms(id1)
58164  rm(2) = rms(id2)
58165  rm(3) = rms(id3)
58166  resm(1)= res(idr,1)
58167  resw(1)= res(idr,2)
58168  resm(2)= res(idr2,1)
58169  resw(2)= res(idr2,2)
58170 C...A -> B and B -> A for antisparticles
58171  a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
58172  b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
58173  a(2) = ab(1+intres(idr2,3),intres(idr2,1),intres(idr2,2))
58174  b(2) = ab(2-intres(idr2,3),intres(idr2,1),intres(idr2,2))
58175 C...Boundaries and mass flag
58176  lo = (rm(1)+rm(2))**2
58177  hi = (rm(0)-rm(3))**2
58178  mflag = dcmass
58179  pyrvi3 = pygaus(pyrvg3,lo,hi,1d-3)
58180  RETURN
58181  END
58182 
58183 C*********************************************************************
58184 
58185 C...PYRVG1
58186 C...Integrand for resonance contributions
58187 
58188  FUNCTION pyrvg1(X)
58189 
58190  IMPLICIT NONE
58191  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58192  DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58193  DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58194  LOGICAL MFLAG
58195  SAVE/pyrvpm/
58196  rvr = pyrvr(x,resm(1),resw(1))
58197  c1 = 2d0*sqrt(max(0d0,x))
58198  IF (.NOT.mflag) THEN
58199  e2 = x/c1
58200  e3 = (rm(0)**2-x)/c1
58201  deltay = 4d0*e2*e3
58202  pyrvg1 = deltay*rvr*x*(a(1)**2+b(1)**2)*(rm(0)**2-x)
58203  ELSE
58204  e2 = (x-rm(1)**2+rm(2)**2)/c1
58205  e3 = (rm(0)**2-x-rm(3)**2)/c1
58206  sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
58207  sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
58208  deltay = 4d0*sr1*sr2
58209  a1 = 4.*a(1)*b(1)*rm(3)*rm(0)
58210  a2 = (a(1)**2+b(1)**2)*(rm(0)**2+rm(3)**2-x)
58211  pyrvg1 = deltay*rvr*(x-rm(1)**2-rm(2)**2)*(a1+a2)
58212  ENDIF
58213  RETURN
58214  END
58215 
58216 C*********************************************************************
58217 
58218 C...PYRVG2
58219 C...Integrand for L-R interference contributions
58220 
58221  FUNCTION pyrvg2(X)
58222 
58223  IMPLICIT NONE
58224  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58225  DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58226  DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58227  LOGICAL MFLAG
58228  SAVE/pyrvpm/
58229  c1 = 2d0*sqrt(max(0d0,x))
58230  rvs = pyrvs(x,x,resm(1),resw(1),resm(2),resw(2))
58231  IF (.NOT.mflag) THEN
58232  e2 = x/c1
58233  e3 = (rm(0)**2-x)/c1
58234  deltay = 4d0*e2*e3
58235  pyrvg2 = deltay*rvs*x*(a(1)*a(2)+b(1)*b(2))*(rm(0)**2-x)
58236  ELSE
58237  e2 = (x-rm(1)**2+rm(2)**2)/c1
58238  e3 = (rm(0)**2-x-rm(3)**2)/c1
58239  sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
58240  sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
58241  deltay = 4d0*sr1*sr2
58242  pyrvg2 = deltay*rvs*(x-rm(1)**2-rm(2)**2)*((a(1)*a(2)
58243  & + b(1)*b(2))*(rm(0)**2+rm(3)**2-x)
58244  & + 2d0*(a(1)*b(2)+a(2)*b(1))*rm(3)*rm(0))
58245  ENDIF
58246  RETURN
58247  END
58248 
58249 C*********************************************************************
58250 
58251 C...PYRVG3
58252 C...Function to do Y integration over true interference contributions
58253 
58254  FUNCTION pyrvg3(X)
58255 
58256  IMPLICIT NONE
58257  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58258 C...Second Dalitz variable for PYRVG4
58259  common/pyg2dx/x1
58260  DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58261  DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58262  DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58263  LOGICAL MFLAG
58264  EXTERNAL pygau2,pyrvg4
58265  SAVE/pyrvpm/,/pyg2dx/
58266  pyrvg3=0d0
58267  c1=2d0*sqrt(max(1d-9,x))
58268  x1=x
58269  IF (.NOT.mflag) THEN
58270  e2 = x/c1
58271  e3 = (rm(0)**2-x)/c1
58272  ymin = 0d0
58273  ymax = 4d0*e2*e3
58274  ELSE
58275  e2 = (x-rm(1)**2+rm(2)**2)/c1
58276  e3 = (rm(0)**2-x-rm(3)**2)/c1
58277  sq1 = (e2+e3)**2
58278  sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
58279  sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
58280  ymin = sq1-(sr1+sr2)**2
58281  ymax = sq1-(sr1-sr2)**2
58282  ENDIF
58283  pyrvg3 = pygau2(pyrvg4,ymin,ymax,1d-3)
58284  RETURN
58285  END
58286 
58287 C*********************************************************************
58288 
58289 C...PYRVG4
58290 C...Integrand for true intereference contributions
58291 
58292  FUNCTION pyrvg4(Y)
58293 
58294  IMPLICIT NONE
58295  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58296  common/pyg2dx/x
58297  DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58298  LOGICAL MFLAG
58299  SAVE /pyrvpm/,/pyg2dx/
58300  pyrvg4=0d0
58301  rvs=pyrvs(x,y,resm(1),resw(1),resm(2),resw(2))
58302  IF (.NOT.mflag) THEN
58303  pyrvg4 = rvs*b(1)*b(2)*x*y
58304  ELSE
58305  pyrvg4 = rvs*(rm(1)*rm(3)*a(1)*a(2)*(x+y-rm(1)**2-rm(3)**2)
58306  & + rm(1)*rm(0)*b(1)*a(2)*(y-rm(2)**2-rm(3)**2)
58307  & + rm(3)*rm(0)*a(1)*b(2)*(x-rm(1)**2-rm(2)**2)
58308  & + b(1)*b(2)*(x*y-(rm(1)*rm(3))**2-(rm(0)*rm(2))**2))
58309  ENDIF
58310  RETURN
58311  END
58312 
58313 C*********************************************************************
58314 
58315 C...PYRVR
58316 C...Breit-Wigner for resonance contributions
58317 
58318  FUNCTION pyrvr(Mab2,RM,RW)
58319 
58320  IMPLICIT NONE
58321  DOUBLE PRECISION Mab2,RM,RW,PYRVR
58322  pyrvr = 1d0/((mab2-rm**2)**2+rm**2*rw**2)
58323  RETURN
58324  END
58325 
58326 C*********************************************************************
58327 
58328 C...PYRVS
58329 C...Interference function
58330 
58331  FUNCTION pyrvs(X,Y,M1,W1,M2,W2)
58332 
58333  IMPLICIT NONE
58334  DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58335  pyrvs = pyrvr(x,m1,w1)*pyrvr(y,m2,w2)*((x-m1**2)*(y-m2**2)
58336  & +w1*w2*m1*m2)
58337  RETURN
58338  END
58339 
58340 C*********************************************************************
58341 
58342 C...PY1ENT
58343 C...Stores one parton/particle in commonblock PYJETS.
58344 
58345  SUBROUTINE py1ent(IP,KF,PE,THE,PHI)
58346 
58347 C...Double precision and integer declarations.
58348  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58349  IMPLICIT INTEGER(I-N)
58350  INTEGER PYK,PYCHGE,PYCOMP
58351 C...Commonblocks.
58352  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58353  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58354  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58355  SAVE /pyjets/,/pydat1/,/pydat2/
58356 
58357 C...Standard checks.
58358  mstu(28)=0
58359  IF(mstu(12).NE.12345) CALL pylist(0)
58360  ipa=max(1,iabs(ip))
58361  IF(ipa.GT.mstu(4)) CALL pyerrm(21,
58362  &'(PY1ENT:) writing outside PYJETS memory')
58363  kc=pycomp(kf)
58364  IF(kc.EQ.0) CALL pyerrm(12,'(PY1ENT:) unknown flavour code')
58365 
58366 C...Find mass. Reset K, P and V vectors.
58367  pm=0d0
58368  IF(mstu(10).EQ.1) pm=p(ipa,5)
58369  IF(mstu(10).GE.2) pm=pymass(kf)
58370  DO 100 j=1,5
58371  k(ipa,j)=0
58372  p(ipa,j)=0d0
58373  v(ipa,j)=0d0
58374  100 CONTINUE
58375 
58376 C...Store parton/particle in K and P vectors.
58377  k(ipa,1)=1
58378  IF(ip.LT.0) k(ipa,1)=2
58379  k(ipa,2)=kf
58380  p(ipa,5)=pm
58381  p(ipa,4)=max(pe,pm)
58382  pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
58383  p(ipa,1)=pa*sin(the)*cos(phi)
58384  p(ipa,2)=pa*sin(the)*sin(phi)
58385  p(ipa,3)=pa*cos(the)
58386 
58387 C...Set N. Optionally fragment/decay.
58388  n=ipa
58389  IF(ip.EQ.0) CALL pyexec
58390 
58391  RETURN
58392  END
58393 
58394 C*********************************************************************
58395 
58396 C...PY2ENT
58397 C...Stores two partons/particles in their CM frame,
58398 C...with the first along the +z axis.
58399 
58400  SUBROUTINE py2ent(IP,KF1,KF2,PECM)
58401 
58402 C...Double precision and integer declarations.
58403  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58404  IMPLICIT INTEGER(I-N)
58405  INTEGER PYK,PYCHGE,PYCOMP
58406 C...Commonblocks.
58407  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58408  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58409  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58410  SAVE /pyjets/,/pydat1/,/pydat2/
58411 
58412 C...Standard checks.
58413  mstu(28)=0
58414  IF(mstu(12).NE.12345) CALL pylist(0)
58415  ipa=max(1,iabs(ip))
58416  IF(ipa.GT.mstu(4)-1) CALL pyerrm(21,
58417  &'(PY2ENT:) writing outside PYJETS memory')
58418  kc1=pycomp(kf1)
58419  kc2=pycomp(kf2)
58420  IF(kc1.EQ.0.OR.kc2.EQ.0) CALL pyerrm(12,
58421  &'(PY2ENT:) unknown flavour code')
58422 
58423 C...Find masses. Reset K, P and V vectors.
58424  pm1=0d0
58425  IF(mstu(10).EQ.1) pm1=p(ipa,5)
58426  IF(mstu(10).GE.2) pm1=pymass(kf1)
58427  pm2=0d0
58428  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
58429  IF(mstu(10).GE.2) pm2=pymass(kf2)
58430  DO 110 i=ipa,ipa+1
58431  DO 100 j=1,5
58432  k(i,j)=0
58433  p(i,j)=0d0
58434  v(i,j)=0d0
58435  100 CONTINUE
58436  110 CONTINUE
58437 
58438 C...Check flavours.
58439  kq1=kchg(kc1,2)*isign(1,kf1)
58440  kq2=kchg(kc2,2)*isign(1,kf2)
58441  IF(mstu(19).EQ.1) THEN
58442  mstu(19)=0
58443  ELSE
58444  IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL pyerrm(2,
58445  & '(PY2ENT:) unphysical flavour combination')
58446  ENDIF
58447  k(ipa,2)=kf1
58448  k(ipa+1,2)=kf2
58449 
58450 C...Store partons/particles in K vectors for normal case.
58451  IF(ip.GE.0) THEN
58452  k(ipa,1)=1
58453  IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
58454  k(ipa+1,1)=1
58455 
58456 C...Store partons in K vectors for parton shower evolution.
58457  ELSE
58458  k(ipa,1)=3
58459  k(ipa+1,1)=3
58460  k(ipa,4)=mstu(5)*(ipa+1)
58461  k(ipa,5)=k(ipa,4)
58462  k(ipa+1,4)=mstu(5)*ipa
58463  k(ipa+1,5)=k(ipa+1,4)
58464  ENDIF
58465 
58466 C...Check kinematics and store partons/particles in P vectors.
58467  IF(pecm.LE.pm1+pm2) CALL pyerrm(13,
58468  &'(PY2ENT:) energy smaller than sum of masses')
58469  pa=sqrt(max(0d0,(pecm**2-pm1**2-pm2**2)**2-(2d0*pm1*pm2)**2))/
58470  &(2d0*pecm)
58471  p(ipa,3)=pa
58472  p(ipa,4)=sqrt(pm1**2+pa**2)
58473  p(ipa,5)=pm1
58474  p(ipa+1,3)=-pa
58475  p(ipa+1,4)=sqrt(pm2**2+pa**2)
58476  p(ipa+1,5)=pm2
58477 
58478 C...Set N. Optionally fragment/decay.
58479  n=ipa+1
58480  IF(ip.EQ.0) CALL pyexec
58481 
58482  RETURN
58483  END
58484 
58485 C*********************************************************************
58486 
58487 C...PY3ENT
58488 C...Stores three partons or particles in their CM frame,
58489 C...with the first along the +z axis and the third in the (x,z)
58490 C...plane with x > 0.
58491 
58492  SUBROUTINE py3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
58493 
58494 C...Double precision and integer declarations.
58495  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58496  IMPLICIT INTEGER(I-N)
58497  INTEGER PYK,PYCHGE,PYCOMP
58498 C...Commonblocks.
58499  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58500  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58501  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58502  SAVE /pyjets/,/pydat1/,/pydat2/
58503 
58504 C...Standard checks.
58505  mstu(28)=0
58506  IF(mstu(12).NE.12345) CALL pylist(0)
58507  ipa=max(1,iabs(ip))
58508  IF(ipa.GT.mstu(4)-2) CALL pyerrm(21,
58509  &'(PY3ENT:) writing outside PYJETS memory')
58510  kc1=pycomp(kf1)
58511  kc2=pycomp(kf2)
58512  kc3=pycomp(kf3)
58513  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL pyerrm(12,
58514  &'(PY3ENT:) unknown flavour code')
58515 
58516 C...Find masses. Reset K, P and V vectors.
58517  pm1=0d0
58518  IF(mstu(10).EQ.1) pm1=p(ipa,5)
58519  IF(mstu(10).GE.2) pm1=pymass(kf1)
58520  pm2=0d0
58521  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
58522  IF(mstu(10).GE.2) pm2=pymass(kf2)
58523  pm3=0d0
58524  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
58525  IF(mstu(10).GE.2) pm3=pymass(kf3)
58526  DO 110 i=ipa,ipa+2
58527  DO 100 j=1,5
58528  k(i,j)=0
58529  p(i,j)=0d0
58530  v(i,j)=0d0
58531  100 CONTINUE
58532  110 CONTINUE
58533 
58534 C...Check flavours.
58535  kq1=kchg(kc1,2)*isign(1,kf1)
58536  kq2=kchg(kc2,2)*isign(1,kf2)
58537  kq3=kchg(kc3,2)*isign(1,kf3)
58538  IF(mstu(19).EQ.1) THEN
58539  mstu(19)=0
58540  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
58541  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
58542  & kq1+kq3.EQ.4)) THEN
58543  ELSE
58544  CALL pyerrm(2,'(PY3ENT:) unphysical flavour combination')
58545  ENDIF
58546  k(ipa,2)=kf1
58547  k(ipa+1,2)=kf2
58548  k(ipa+2,2)=kf3
58549 
58550 C...Store partons/particles in K vectors for normal case.
58551  IF(ip.GE.0) THEN
58552  k(ipa,1)=1
58553  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
58554  k(ipa+1,1)=1
58555  IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
58556  k(ipa+2,1)=1
58557 
58558 C...Store partons in K vectors for parton shower evolution.
58559  ELSE
58560  k(ipa,1)=3
58561  k(ipa+1,1)=3
58562  k(ipa+2,1)=3
58563  kcs=4
58564  IF(kq1.EQ.-1) kcs=5
58565  k(ipa,kcs)=mstu(5)*(ipa+1)
58566  k(ipa,9-kcs)=mstu(5)*(ipa+2)
58567  k(ipa+1,kcs)=mstu(5)*(ipa+2)
58568  k(ipa+1,9-kcs)=mstu(5)*ipa
58569  k(ipa+2,kcs)=mstu(5)*ipa
58570  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
58571  ENDIF
58572 
58573 C...Check kinematics.
58574  mkerr=0
58575  IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*(2d0-x1-x3)*pecm.LE.pm2.OR.
58576  &0.5d0*x3*pecm.LE.pm3) mkerr=1
58577  pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
58578  pa2=sqrt(max(1d-10,(0.5d0*(2d0-x1-x3)*pecm)**2-pm2**2))
58579  pa3=sqrt(max(1d-10,(0.5d0*x3*pecm)**2-pm3**2))
58580  cthe2=(pa3**2-pa1**2-pa2**2)/(2d0*pa1*pa2)
58581  cthe3=(pa2**2-pa1**2-pa3**2)/(2d0*pa1*pa3)
58582  IF(abs(cthe2).GE.1.001d0.OR.abs(cthe3).GE.1.001d0) mkerr=1
58583  cthe3=max(-1d0,min(1d0,cthe3))
58584  IF(mkerr.NE.0) CALL pyerrm(13,
58585  &'(PY3ENT:) unphysical kinematical variable setup')
58586 
58587 C...Store partons/particles in P vectors.
58588  p(ipa,3)=pa1
58589  p(ipa,4)=sqrt(pa1**2+pm1**2)
58590  p(ipa,5)=pm1
58591  p(ipa+2,1)=pa3*sqrt(1d0-cthe3**2)
58592  p(ipa+2,3)=pa3*cthe3
58593  p(ipa+2,4)=sqrt(pa3**2+pm3**2)
58594  p(ipa+2,5)=pm3
58595  p(ipa+1,1)=-p(ipa+2,1)
58596  p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
58597  p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
58598  p(ipa+1,5)=pm2
58599 
58600 C...Set N. Optionally fragment/decay.
58601  n=ipa+2
58602  IF(ip.EQ.0) CALL pyexec
58603 
58604  RETURN
58605  END
58606 
58607 C*********************************************************************
58608 
58609 C...PY4ENT
58610 C...Stores four partons or particles in their CM frame, with
58611 C...the first along the +z axis, the last in the xz plane with x > 0
58612 C...and the second having y < 0 and y > 0 with equal probability.
58613 
58614  SUBROUTINE py4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58615 
58616 C...Double precision and integer declarations.
58617  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58618  IMPLICIT INTEGER(I-N)
58619  INTEGER PYK,PYCHGE,PYCOMP
58620 C...Commonblocks.
58621  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58622  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58623  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58624  SAVE /pyjets/,/pydat1/,/pydat2/
58625 
58626 C...Standard checks.
58627  mstu(28)=0
58628  IF(mstu(12).NE.12345) CALL pylist(0)
58629  ipa=max(1,iabs(ip))
58630  IF(ipa.GT.mstu(4)-3) CALL pyerrm(21,
58631  &'(PY4ENT:) writing outside PYJETS momory')
58632  kc1=pycomp(kf1)
58633  kc2=pycomp(kf2)
58634  kc3=pycomp(kf3)
58635  kc4=pycomp(kf4)
58636  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL pyerrm(12,
58637  &'(PY4ENT:) unknown flavour code')
58638 
58639 C...Find masses. Reset K, P and V vectors.
58640  pm1=0d0
58641  IF(mstu(10).EQ.1) pm1=p(ipa,5)
58642  IF(mstu(10).GE.2) pm1=pymass(kf1)
58643  pm2=0d0
58644  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
58645  IF(mstu(10).GE.2) pm2=pymass(kf2)
58646  pm3=0d0
58647  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
58648  IF(mstu(10).GE.2) pm3=pymass(kf3)
58649  pm4=0d0
58650  IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
58651  IF(mstu(10).GE.2) pm4=pymass(kf4)
58652  DO 110 i=ipa,ipa+3
58653  DO 100 j=1,5
58654  k(i,j)=0
58655  p(i,j)=0d0
58656  v(i,j)=0d0
58657  100 CONTINUE
58658  110 CONTINUE
58659 
58660 C...Check flavours.
58661  kq1=kchg(kc1,2)*isign(1,kf1)
58662  kq2=kchg(kc2,2)*isign(1,kf2)
58663  kq3=kchg(kc3,2)*isign(1,kf3)
58664  kq4=kchg(kc4,2)*isign(1,kf4)
58665  IF(mstu(19).EQ.1) THEN
58666  mstu(19)=0
58667  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
58668  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
58669  & kq1+kq4.EQ.4)) THEN
58670  ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0d0)
58671  & THEN
58672  ELSE
58673  CALL pyerrm(2,'(PY4ENT:) unphysical flavour combination')
58674  ENDIF
58675  k(ipa,2)=kf1
58676  k(ipa+1,2)=kf2
58677  k(ipa+2,2)=kf3
58678  k(ipa+3,2)=kf4
58679 
58680 C...Store partons/particles in K vectors for normal case.
58681  IF(ip.GE.0) THEN
58682  k(ipa,1)=1
58683  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
58684  k(ipa+1,1)=1
58685  IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
58686  & k(ipa+1,1)=2
58687  k(ipa+2,1)=1
58688  IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
58689  k(ipa+3,1)=1
58690 
58691 C...Store partons for parton shower evolution from q-g-g-qbar or
58692 C...g-g-g-g event.
58693  ELSEIF(kq1+kq2.NE.0) THEN
58694  k(ipa,1)=3
58695  k(ipa+1,1)=3
58696  k(ipa+2,1)=3
58697  k(ipa+3,1)=3
58698  kcs=4
58699  IF(kq1.EQ.-1) kcs=5
58700  k(ipa,kcs)=mstu(5)*(ipa+1)
58701  k(ipa,9-kcs)=mstu(5)*(ipa+3)
58702  k(ipa+1,kcs)=mstu(5)*(ipa+2)
58703  k(ipa+1,9-kcs)=mstu(5)*ipa
58704  k(ipa+2,kcs)=mstu(5)*(ipa+3)
58705  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
58706  k(ipa+3,kcs)=mstu(5)*ipa
58707  k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
58708 
58709 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58710  ELSE
58711  k(ipa,1)=3
58712  k(ipa+1,1)=3
58713  k(ipa+2,1)=3
58714  k(ipa+3,1)=3
58715  k(ipa,4)=mstu(5)*(ipa+1)
58716  k(ipa,5)=k(ipa,4)
58717  k(ipa+1,4)=mstu(5)*ipa
58718  k(ipa+1,5)=k(ipa+1,4)
58719  k(ipa+2,4)=mstu(5)*(ipa+3)
58720  k(ipa+2,5)=k(ipa+2,4)
58721  k(ipa+3,4)=mstu(5)*(ipa+2)
58722  k(ipa+3,5)=k(ipa+3,4)
58723  ENDIF
58724 
58725 C...Check kinematics.
58726  mkerr=0
58727  IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*x2*pecm.LE.pm2.OR.
58728  &0.5d0*(2d0-x1-x2-x4)*pecm.LE.pm3.OR.0.5d0*x4*pecm.LE.pm4)
58729  &mkerr=1
58730  pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
58731  pa2=sqrt(max(1d-10,(0.5d0*x2*pecm)**2-pm2**2))
58732  pa4=sqrt(max(1d-10,(0.5d0*x4*pecm)**2-pm4**2))
58733  x24=x1+x2+x4-1d0-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
58734  cthe4=(x1*x4-2d0*x14)*pecm**2/(4d0*pa1*pa4)
58735  IF(abs(cthe4).GE.1.002d0) mkerr=1
58736  cthe4=max(-1d0,min(1d0,cthe4))
58737  sthe4=sqrt(1d0-cthe4**2)
58738  cthe2=(x1*x2-2d0*x12)*pecm**2/(4d0*pa1*pa2)
58739  IF(abs(cthe2).GE.1.002d0) mkerr=1
58740  cthe2=max(-1d0,min(1d0,cthe2))
58741  sthe2=sqrt(1d0-cthe2**2)
58742  cphi2=((x2*x4-2d0*x24)*pecm**2-4d0*pa2*cthe2*pa4*cthe4)/
58743  &max(1d-8*pecm**2,4d0*pa2*sthe2*pa4*sthe4)
58744  IF(abs(cphi2).GE.1.05d0) mkerr=1
58745  cphi2=max(-1d0,min(1d0,cphi2))
58746  IF(mkerr.EQ.1) CALL pyerrm(13,
58747  &'(PY4ENT:) unphysical kinematical variable setup')
58748 
58749 C...Store partons/particles in P vectors.
58750  p(ipa,3)=pa1
58751  p(ipa,4)=sqrt(pa1**2+pm1**2)
58752  p(ipa,5)=pm1
58753  p(ipa+3,1)=pa4*sthe4
58754  p(ipa+3,3)=pa4*cthe4
58755  p(ipa+3,4)=sqrt(pa4**2+pm4**2)
58756  p(ipa+3,5)=pm4
58757  p(ipa+1,1)=pa2*sthe2*cphi2
58758  p(ipa+1,2)=pa2*sthe2*sqrt(1d0-cphi2**2)*(-1d0)**int(pyr(0)+0.5d0)
58759  p(ipa+1,3)=pa2*cthe2
58760  p(ipa+1,4)=sqrt(pa2**2+pm2**2)
58761  p(ipa+1,5)=pm2
58762  p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
58763  p(ipa+2,2)=-p(ipa+1,2)
58764  p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
58765  p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
58766  p(ipa+2,5)=pm3
58767 
58768 C...Set N. Optionally fragment/decay.
58769  n=ipa+3
58770  IF(ip.EQ.0) CALL pyexec
58771 
58772  RETURN
58773  END
58774 
58775 C*********************************************************************
58776 
58777 C...PY2FRM
58778 C...An interface from a two-fermion generator to include
58779 C...parton showers and hadronization.
58780 
58781  SUBROUTINE py2frm(IRAD,ITAU,ICOM)
58782 
58783 C...Double precision and integer declarations.
58784  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58785  IMPLICIT INTEGER(I-N)
58786  INTEGER PYK,PYCHGE,PYCOMP
58787 C...Commonblocks.
58788  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58789  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58790  SAVE /pyjets/,/pydat1/
58791 C...Local arrays.
58792  dimension ijoin(2),intau(2)
58793 
58794 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58795  IF(icom.EQ.0) THEN
58796  mstu(28)=0
58797  CALL pyhepc(2)
58798  ENDIF
58799 
58800 C...Loop through entries and pick up all final fermions/antifermions.
58801  i1=0
58802  i2=0
58803  DO 100 i=1,n
58804  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
58805  kfa=iabs(k(i,2))
58806  IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
58807  IF(k(i,2).GT.0) THEN
58808  IF(i1.EQ.0) THEN
58809  i1=i
58810  ELSE
58811  CALL pyerrm(16,'(PY2FRM:) more than one fermion')
58812  ENDIF
58813  ELSE
58814  IF(i2.EQ.0) THEN
58815  i2=i
58816  ELSE
58817  CALL pyerrm(16,'(PY2FRM:) more than one antifermion')
58818  ENDIF
58819  ENDIF
58820  ENDIF
58821  100 CONTINUE
58822 
58823 C...Check that event is arranged according to conventions.
58824  IF(i1.EQ.0.OR.i2.EQ.0) THEN
58825  CALL pyerrm(16,'(PY2FRM:) event contains too few fermions')
58826  ENDIF
58827  IF(i2.LT.i1) THEN
58828  CALL pyerrm(6,'(PY2FRM:) fermions arranged in wrong order')
58829  ENDIF
58830 
58831 C...Check whether fermion pair is quarks or leptons.
58832  IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
58833  iql12=1
58834  ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
58835  iql12=2
58836  ELSE
58837  CALL pyerrm(16,'(PY2FRM:) fermion pair inconsistent')
58838  ENDIF
58839 
58840 C...Decide whether to allow or not photon radiation in showers.
58841  mstj(41)=2
58842  IF(irad.EQ.0) mstj(41)=1
58843 
58844 C...Do colour joining and parton showers.
58845  ip1=i1
58846  ip2=i2
58847  IF(iql12.EQ.1) THEN
58848  ijoin(1)=ip1
58849  ijoin(2)=ip2
58850  CALL pyjoin(2,ijoin)
58851  ENDIF
58852  IF(iql12.EQ.1.OR.irad.EQ.1) THEN
58853  pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
58854  & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
58855  CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
58856  ENDIF
58857 
58858 C...Do fragmentation and decays. Possibly except tau decay.
58859  IF(itau.EQ.0) THEN
58860  ntau=0
58861  DO 110 i=1,n
58862  IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
58863  ntau=ntau+1
58864  intau(ntau)=i
58865  k(i,1)=11
58866  ENDIF
58867  110 CONTINUE
58868  ENDIF
58869  CALL pyexec
58870  IF(itau.EQ.0) THEN
58871  DO 120 i=1,ntau
58872  k(intau(i),1)=1
58873  120 CONTINUE
58874  ENDIF
58875 
58876 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58877  IF(icom.EQ.0) THEN
58878  mstu(28)=0
58879  CALL pyhepc(1)
58880  ENDIF
58881 
58882  END
58883 
58884 C*********************************************************************
58885 
58886 C...PY4FRM
58887 C...An interface from a four-fermion generator to include
58888 C...parton showers and hadronization.
58889 
58890  SUBROUTINE py4frm(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
58891 
58892 C...Double precision and integer declarations.
58893  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58894  IMPLICIT INTEGER(I-N)
58895  INTEGER PYK,PYCHGE,PYCOMP
58896 C...Commonblocks.
58897  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58898  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58899  common/pypars/mstp(200),parp(200),msti(200),pari(200)
58900  common/pyint1/mint(400),vint(400)
58901  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
58902 C...Local arrays.
58903  dimension ijoin(2),intau(4)
58904 
58905 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58906  IF(icom.EQ.0) THEN
58907  mstu(28)=0
58908  CALL pyhepc(2)
58909  ENDIF
58910 
58911 C...Loop through entries and pick up all final fermions/antifermions.
58912  i1=0
58913  i2=0
58914  i3=0
58915  i4=0
58916  DO 100 i=1,n
58917  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
58918  kfa=iabs(k(i,2))
58919  IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
58920  IF(k(i,2).GT.0) THEN
58921  IF(i1.EQ.0) THEN
58922  i1=i
58923  ELSEIF(i3.EQ.0) THEN
58924  i3=i
58925  ELSE
58926  CALL pyerrm(16,'(PY4FRM:) more than two fermions')
58927  ENDIF
58928  ELSE
58929  IF(i2.EQ.0) THEN
58930  i2=i
58931  ELSEIF(i4.EQ.0) THEN
58932  i4=i
58933  ELSE
58934  CALL pyerrm(16,'(PY4FRM:) more than two antifermions')
58935  ENDIF
58936  ENDIF
58937  ENDIF
58938  100 CONTINUE
58939 
58940 C...Check that event is arranged according to conventions.
58941  IF(i3.EQ.0.OR.i4.EQ.0) THEN
58942  CALL pyerrm(16,'(PY4FRM:) event contains too few fermions')
58943  ENDIF
58944  IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
58945  CALL pyerrm(6,'(PY4FRM:) fermions arranged in wrong order')
58946  ENDIF
58947 
58948 C...Check which fermion pairs are quarks and which leptons.
58949  IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
58950  iql12=1
58951  ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
58952  iql12=2
58953  ELSE
58954  CALL pyerrm(16,'(PY4FRM:) first fermion pair inconsistent')
58955  ENDIF
58956  IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
58957  iql34=1
58958  ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
58959  iql34=2
58960  ELSE
58961  CALL pyerrm(16,'(PY4FRM:) second fermion pair inconsistent')
58962  ENDIF
58963 
58964 C...Decide whether to allow or not photon radiation in showers.
58965  mstj(41)=2
58966  IF(irad.EQ.0) mstj(41)=1
58967 
58968 C...Decide on dipole pairing.
58969  ip1=i1
58970  ip2=i2
58971  ip3=i3
58972  ip4=i4
58973  IF(iql12.EQ.iql34) THEN
58974  r1sq=a1sq
58975  r2sq=a2sq
58976  delta=atotsq-a1sq-a2sq
58977  IF(istrat.EQ.1) THEN
58978  IF(delta.GT.0d0) r1sq=r1sq+delta
58979  IF(delta.LT.0d0) r2sq=max(0d0,r2sq+delta)
58980  ELSEIF(istrat.EQ.2) THEN
58981  IF(delta.GT.0d0) r2sq=r2sq+delta
58982  IF(delta.LT.0d0) r1sq=max(0d0,r1sq+delta)
58983  ENDIF
58984  IF(r2sq.GT.pyr(0)*(r1sq+r2sq)) THEN
58985  ip2=i4
58986  ip4=i2
58987  ENDIF
58988  ENDIF
58989 
58990 C...If colour reconnection then bookkeep W+W- or Z0Z0
58991 C...and copy q qbar q qbar consecutively.
58992  IF(mstp(115).GE.1.AND.iql12.EQ.1.AND.iql34.EQ.1) THEN
58993  k(n+1,1)=11
58994  k(n+1,3)=ip1
58995  k(n+1,4)=n+3
58996  k(n+1,5)=n+4
58997  k(n+2,1)=11
58998  k(n+2,3)=ip3
58999  k(n+2,4)=n+5
59000  k(n+2,5)=n+6
59001  IF(k(ip1,2)+k(ip2,2).EQ.0) THEN
59002  k(n+1,2)=23
59003  k(n+2,2)=23
59004  mint(1)=22
59005  ELSEIF(pychge(k(ip1,2)).GT.0) THEN
59006  k(n+1,2)=24
59007  k(n+2,2)=-24
59008  mint(1)=25
59009  ELSE
59010  k(n+1,2)=-24
59011  k(n+2,2)=24
59012  mint(1)=25
59013  ENDIF
59014  DO 110 j=1,5
59015  k(n+3,j)=k(ip1,j)
59016  k(n+4,j)=k(ip2,j)
59017  k(n+5,j)=k(ip3,j)
59018  k(n+6,j)=k(ip4,j)
59019  p(n+1,j)=p(ip1,j)+p(ip2,j)
59020  p(n+2,j)=p(ip3,j)+p(ip4,j)
59021  p(n+3,j)=p(ip1,j)
59022  p(n+4,j)=p(ip2,j)
59023  p(n+5,j)=p(ip3,j)
59024  p(n+6,j)=p(ip4,j)
59025  v(n+1,j)=v(ip1,j)
59026  v(n+2,j)=v(ip3,j)
59027  v(n+3,j)=v(ip1,j)
59028  v(n+4,j)=v(ip2,j)
59029  v(n+5,j)=v(ip3,j)
59030  v(n+6,j)=v(ip4,j)
59031  110 CONTINUE
59032  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59033  & p(n+1,3)**2))
59034  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59035  & p(n+2,3)**2))
59036  k(n+3,3)=n+1
59037  k(n+4,3)=n+1
59038  k(n+5,3)=n+2
59039  k(n+6,3)=n+2
59040 C...Remove original q qbar q qbar and update counters.
59041  k(ip1,1)=k(ip1,1)+10
59042  k(ip2,1)=k(ip2,1)+10
59043  k(ip3,1)=k(ip3,1)+10
59044  k(ip4,1)=k(ip4,1)+10
59045  iw1=n+1
59046  iw2=n+2
59047  nsd1=n+2
59048  ip1=n+3
59049  ip2=n+4
59050  ip3=n+5
59051  ip4=n+6
59052  n=n+6
59053  ENDIF
59054 
59055 C...Do colour joinings and parton showers.
59056  IF(iql12.EQ.1) THEN
59057  ijoin(1)=ip1
59058  ijoin(2)=ip2
59059  CALL pyjoin(2,ijoin)
59060  ENDIF
59061  IF(iql12.EQ.1.OR.irad.EQ.1) THEN
59062  pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
59063  & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
59064  CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
59065  ENDIF
59066  naft1=n
59067  IF(iql34.EQ.1) THEN
59068  ijoin(1)=ip3
59069  ijoin(2)=ip4
59070  CALL pyjoin(2,ijoin)
59071  ENDIF
59072  IF(iql34.EQ.1.OR.irad.EQ.1) THEN
59073  pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
59074  & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
59075  CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
59076  ENDIF
59077 
59078 C...Optionally do colour reconnection.
59079  mint(32)=0
59080  msti(32)=0
59081  IF(mstp(115).GE.1.AND.iql12.EQ.1.AND.iql34.EQ.1) THEN
59082  CALL pyreco(iw1,iw2,nsd1,naft1)
59083  msti(32)=mint(32)
59084  ENDIF
59085 
59086 C...Do fragmentation and decays. Possibly except tau decay.
59087  IF(itau.EQ.0) THEN
59088  ntau=0
59089  DO 120 i=1,n
59090  IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
59091  ntau=ntau+1
59092  intau(ntau)=i
59093  k(i,1)=11
59094  ENDIF
59095  120 CONTINUE
59096  ENDIF
59097  CALL pyexec
59098  IF(itau.EQ.0) THEN
59099  DO 130 i=1,ntau
59100  k(intau(i),1)=1
59101  130 CONTINUE
59102  ENDIF
59103 
59104 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59105  IF(icom.EQ.0) THEN
59106  mstu(28)=0
59107  CALL pyhepc(1)
59108  ENDIF
59109 
59110  END
59111 
59112 C*********************************************************************
59113 
59114 C...PY6FRM
59115 C...An interface from a six-fermion generator to include
59116 C...parton showers and hadronization.
59117 
59118  SUBROUTINE py6frm(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59119 
59120 C...Double precision and integer declarations.
59121  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59122  IMPLICIT INTEGER(I-N)
59123  INTEGER PYK,PYCHGE,PYCOMP
59124 C...Commonblocks.
59125  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59126  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59127  SAVE /pyjets/,/pydat1/
59128 C...Local arrays.
59129  dimension ijoin(2),intau(6),beta(3),betao(3),betan(3)
59130 
59131 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59132  IF(icom.EQ.0) THEN
59133  mstu(28)=0
59134  CALL pyhepc(2)
59135  ENDIF
59136 
59137 C...Loop through entries and pick up all final fermions/antifermions.
59138  i1=0
59139  i2=0
59140  i3=0
59141  i4=0
59142  i5=0
59143  i6=0
59144  DO 100 i=1,n
59145  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
59146  kfa=iabs(k(i,2))
59147  IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
59148  IF(k(i,2).GT.0) THEN
59149  IF(i1.EQ.0) THEN
59150  i1=i
59151  ELSEIF(i3.EQ.0) THEN
59152  i3=i
59153  ELSEIF(i5.EQ.0) THEN
59154  i5=i
59155  ELSE
59156  CALL pyerrm(16,'(PY6FRM:) more than three fermions')
59157  ENDIF
59158  ELSE
59159  IF(i2.EQ.0) THEN
59160  i2=i
59161  ELSEIF(i4.EQ.0) THEN
59162  i4=i
59163  ELSEIF(i6.EQ.0) THEN
59164  i6=i
59165  ELSE
59166  CALL pyerrm(16,'(PY6FRM:) more than three antifermions')
59167  ENDIF
59168  ENDIF
59169  ENDIF
59170  100 CONTINUE
59171 
59172 C...Check that event is arranged according to conventions.
59173  IF(i5.EQ.0.OR.i6.EQ.0) THEN
59174  CALL pyerrm(16,'(PY6FRM:) event contains too few fermions')
59175  ENDIF
59176  IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3.OR.i5.LT.i4.OR.i6.LT.i5) THEN
59177  CALL pyerrm(6,'(PY6FRM:) fermions arranged in wrong order')
59178  ENDIF
59179 
59180 C...Check which fermion pairs are quarks and which leptons.
59181  IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
59182  iql12=1
59183  ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
59184  iql12=2
59185  ELSE
59186  CALL pyerrm(16,'(PY6FRM:) first fermion pair inconsistent')
59187  ENDIF
59188  IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
59189  iql34=1
59190  ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
59191  iql34=2
59192  ELSE
59193  CALL pyerrm(16,'(PY6FRM:) second fermion pair inconsistent')
59194  ENDIF
59195  IF(iabs(k(i5,2)).LT.10.AND.iabs(k(i6,2)).LT.10) THEN
59196  iql56=1
59197  ELSEIF(iabs(k(i5,2)).GT.10.AND.iabs(k(i6,2)).GT.10) THEN
59198  iql56=2
59199  ELSE
59200  CALL pyerrm(16,'(PY6FRM:) third fermion pair inconsistent')
59201  ENDIF
59202 
59203 C...Decide whether to allow or not photon radiation in showers.
59204  mstj(41)=2
59205  IF(irad.EQ.0) mstj(41)=1
59206 
59207 C...Allow dipole pairings only among leptons and quarks separately.
59208  p12d=p12
59209  p13d=0d0
59210  IF(iql34.EQ.iql56) p13d=p13
59211  p21d=0d0
59212  IF(iql12.EQ.iql34) p21d=p21
59213  p23d=0d0
59214  IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p23d=p23
59215  p31d=0d0
59216  IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p31d=p31
59217  p32d=0d0
59218  IF(iql12.EQ.iql56) p32d=p32
59219 
59220 C...Decide whether t+tbar.
59221  itop=0
59222  IF(pyr(0).LT.ptop) THEN
59223  itop=1
59224 
59225 C...If t+tbar: reconstruct t's.
59226  it=n+1
59227  itb=n+2
59228  DO 110 j=1,5
59229  k(it,j)=0
59230  k(itb,j)=0
59231  p(it,j)=p(i1,j)+p(i3,j)+p(i4,j)
59232  p(itb,j)=p(i2,j)+p(i5,j)+p(i6,j)
59233  v(it,j)=0d0
59234  v(itb,j)=0d0
59235  110 CONTINUE
59236  k(it,1)=1
59237  k(itb,1)=1
59238  k(it,2)=6
59239  k(itb,2)=-6
59240  p(it,5)=sqrt(max(0d0,p(it,4)**2-p(it,1)**2-p(it,2)**2-
59241  & p(it,3)**2))
59242  p(itb,5)=sqrt(max(0d0,p(itb,4)**2-p(itb,1)**2-p(itb,2)**2-
59243  & p(itb,3)**2))
59244  n=n+2
59245 
59246 C...If t+tbar: colour join t's and let them shower.
59247  ijoin(1)=it
59248  ijoin(2)=itb
59249  CALL pyjoin(2,ijoin)
59250  pmtts=(p(it,4)+p(itb,4))**2-(p(it,1)+p(itb,1))**2-
59251  & (p(it,2)+p(itb,2))**2-(p(it,3)+p(itb,3))**2
59252  CALL pyshow(it,itb,sqrt(max(0d0,pmtts)))
59253 
59254 C...If t+tbar: pick up the t's after shower.
59255  itnew=it
59256  itbnew=itb
59257  DO 120 i=itb+1,n
59258  IF(k(i,2).EQ.6) itnew=i
59259  IF(k(i,2).EQ.-6) itbnew=i
59260  120 CONTINUE
59261 
59262 C...If t+tbar: loop over two top systems.
59263  DO 200 it1=1,2
59264  IF(it1.EQ.1) THEN
59265  ito=it
59266  itn=itnew
59267  ibo=i1
59268  iw1=i3
59269  iw2=i4
59270  ELSE
59271  ito=itb
59272  itn=itbnew
59273  ibo=i2
59274  iw1=i5
59275  iw2=i6
59276  ENDIF
59277  IF(iabs(k(ibo,2)).NE.5) CALL pyerrm(6,
59278  & '(PY6FRM:) not b in t decay')
59279 
59280 C...If t+tbar: find boost from original to new top frame.
59281  DO 130 j=1,3
59282  betao(j)=p(ito,j)/p(ito,4)
59283  betan(j)=p(itn,j)/p(itn,4)
59284  130 CONTINUE
59285 
59286 C...If t+tbar: boost copy of b by t shower and connect it in colour.
59287  n=n+1
59288  ib=n
59289  k(ib,1)=3
59290  k(ib,2)=k(ibo,2)
59291  k(ib,3)=itn
59292  DO 140 j=1,5
59293  p(ib,j)=p(ibo,j)
59294  v(ib,j)=0d0
59295  140 CONTINUE
59296  CALL pyrobo(ib,ib,0d0,0d0,-betao(1),-betao(2),-betao(3))
59297  CALL pyrobo(ib,ib,0d0,0d0,betan(1),betan(2),betan(3))
59298  k(ib,4)=mstu(5)*itn
59299  k(ib,5)=mstu(5)*itn
59300  k(itn,4)=k(itn,4)+ib
59301  k(itn,5)=k(itn,5)+ib
59302  k(itn,1)=k(itn,1)+10
59303  k(ibo,1)=k(ibo,1)+10
59304 
59305 C...If t+tbar: construct W recoiling against b.
59306  n=n+1
59307  iw=n
59308  DO 150 j=1,5
59309  k(iw,j)=0
59310  v(iw,j)=0d0
59311  150 CONTINUE
59312  k(iw,1)=1
59313  kchw=pychge(k(iw1,2))+pychge(k(iw2,2))
59314  IF(iabs(kchw).EQ.3) THEN
59315  k(iw,2)=isign(24,kchw)
59316  ELSE
59317  CALL pyerrm(16,'(PY6FRM:) fermion pair inconsistent with W')
59318  ENDIF
59319  k(iw,3)=iw1
59320 
59321 C...If t+tbar: construct W momentum, including boost by t shower.
59322  DO 160 j=1,4
59323  p(iw,j)=p(iw1,j)+p(iw2,j)
59324  160 CONTINUE
59325  p(iw,5)=sqrt(max(0d0,p(iw,4)**2-p(iw,1)**2-p(iw,2)**2-
59326  & p(iw,3)**2))
59327  CALL pyrobo(iw,iw,0d0,0d0,-betao(1),-betao(2),-betao(3))
59328  CALL pyrobo(iw,iw,0d0,0d0,betan(1),betan(2),betan(3))
59329 
59330 C...If t+tbar: boost b and W to top rest frame.
59331  DO 170 j=1,3
59332  beta(j)=(p(ib,j)+p(iw,j))/(p(ib,4)+p(iw,4))
59333  170 CONTINUE
59334  CALL pyrobo(ib,ib,0d0,0d0,-beta(1),-beta(2),-beta(3))
59335  CALL pyrobo(iw,iw,0d0,0d0,-beta(1),-beta(2),-beta(3))
59336 
59337 C...If t+tbar: let b shower and pick up modified W.
59338  pmts=(p(ib,4)+p(iw,4))**2-(p(ib,1)+p(iw,1))**2-
59339  & (p(ib,2)+p(iw,2))**2-(p(ib,3)+p(iw,3))**2
59340  CALL pyshow(ib,iw,sqrt(max(0d0,pmts)))
59341  DO 180 i=iw,n
59342  IF(iabs(k(i,2)).EQ.24) iwm=i
59343  180 CONTINUE
59344 
59345 C...If t+tbar: take copy of W decay products.
59346  DO 190 j=1,5
59347  k(n+1,j)=k(iw1,j)
59348  p(n+1,j)=p(iw1,j)
59349  v(n+1,j)=v(iw1,j)
59350  k(n+2,j)=k(iw2,j)
59351  p(n+2,j)=p(iw2,j)
59352  v(n+2,j)=v(iw2,j)
59353  190 CONTINUE
59354  k(iw1,1)=k(iw1,1)+10
59355  k(iw2,1)=k(iw2,1)+10
59356  k(iwm,1)=k(iwm,1)+10
59357  k(iwm,4)=n+1
59358  k(iwm,5)=n+2
59359  k(n+1,3)=iwm
59360  k(n+2,3)=iwm
59361  IF(it1.EQ.1) THEN
59362  i3=n+1
59363  i4=n+2
59364  ELSE
59365  i5=n+1
59366  i6=n+2
59367  ENDIF
59368  n=n+2
59369 
59370 C...If t+tbar: boost W decay products, first by effects of t shower,
59371 C...then by those of b shower. b and its shower simple boost back.
59372  CALL pyrobo(n-1,n,0d0,0d0,-betao(1),-betao(2),-betao(3))
59373  CALL pyrobo(n-1,n,0d0,0d0,betan(1),betan(2),betan(3))
59374  CALL pyrobo(n-1,n,0d0,0d0,-beta(1),-beta(2),-beta(3))
59375  CALL pyrobo(n-1,n,0d0,0d0,-p(iw,1)/p(iw,4),
59376  & -p(iw,2)/p(iw,4),-p(iw,3)/p(iw,4))
59377  CALL pyrobo(n-1,n,0d0,0d0,p(iwm,1)/p(iwm,4),
59378  & p(iwm,2)/p(iwm,4),p(iwm,3)/p(iwm,4))
59379  CALL pyrobo(ib,ib,0d0,0d0,beta(1),beta(2),beta(3))
59380  CALL pyrobo(iw,n,0d0,0d0,beta(1),beta(2),beta(3))
59381  200 CONTINUE
59382  ENDIF
59383 
59384 C...Decide on dipole pairing.
59385  ip1=i1
59386  ip3=i3
59387  ip5=i5
59388  prn=pyr(0)*(p12d+p13d+p21d+p23d+p31d+p32d)
59389  IF(itop.EQ.1.OR.prn.LT.p12d) THEN
59390  ip2=i2
59391  ip4=i4
59392  ip6=i6
59393  ELSEIF(prn.LT.p12d+p13d) THEN
59394  ip2=i2
59395  ip4=i6
59396  ip6=i4
59397  ELSEIF(prn.LT.p12d+p13d+p21d) THEN
59398  ip2=i4
59399  ip4=i2
59400  ip6=i6
59401  ELSEIF(prn.LT.p12d+p13d+p21d+p23d) THEN
59402  ip2=i4
59403  ip4=i6
59404  ip6=i2
59405  ELSEIF(prn.LT.p12d+p13d+p21d+p23d+p31d) THEN
59406  ip2=i6
59407  ip4=i2
59408  ip6=i4
59409  ELSE
59410  ip2=i6
59411  ip4=i4
59412  ip6=i2
59413  ENDIF
59414 
59415 C...Do colour joinings and parton showers
59416 C...(except ones already made for t+tbar).
59417  IF(itop.EQ.0) THEN
59418  IF(iql12.EQ.1) THEN
59419  ijoin(1)=ip1
59420  ijoin(2)=ip2
59421  CALL pyjoin(2,ijoin)
59422  ENDIF
59423  IF(iql12.EQ.1.OR.irad.EQ.1) THEN
59424  pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
59425  & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
59426  CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
59427  ENDIF
59428  ENDIF
59429  IF(iql34.EQ.1) THEN
59430  ijoin(1)=ip3
59431  ijoin(2)=ip4
59432  CALL pyjoin(2,ijoin)
59433  ENDIF
59434  IF(iql34.EQ.1.OR.irad.EQ.1) THEN
59435  pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
59436  & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
59437  CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
59438  ENDIF
59439  IF(iql56.EQ.1) THEN
59440  ijoin(1)=ip5
59441  ijoin(2)=ip6
59442  CALL pyjoin(2,ijoin)
59443  ENDIF
59444  IF(iql56.EQ.1.OR.irad.EQ.1) THEN
59445  pm56s=(p(ip5,4)+p(ip6,4))**2-(p(ip5,1)+p(ip6,1))**2-
59446  & (p(ip5,2)+p(ip6,2))**2-(p(ip5,3)+p(ip6,3))**2
59447  CALL pyshow(ip5,ip6,sqrt(max(0d0,pm56s)))
59448  ENDIF
59449 
59450 C...Do fragmentation and decays. Possibly except tau decay.
59451  IF(itau.EQ.0) THEN
59452  ntau=0
59453  DO 210 i=1,n
59454  IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
59455  ntau=ntau+1
59456  intau(ntau)=i
59457  k(i,1)=11
59458  ENDIF
59459  210 CONTINUE
59460  ENDIF
59461  CALL pyexec
59462  IF(itau.EQ.0) THEN
59463  DO 220 i=1,ntau
59464  k(intau(i),1)=1
59465  220 CONTINUE
59466  ENDIF
59467 
59468 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59469  IF(icom.EQ.0) THEN
59470  mstu(28)=0
59471  CALL pyhepc(1)
59472  ENDIF
59473 
59474  END
59475 
59476 C*********************************************************************
59477 
59478 C...PY4JET
59479 C...An interface from a four-parton generator to include
59480 C...parton showers and hadronization.
59481 
59482  SUBROUTINE py4jet(PMAX,IRAD,ICOM)
59483 
59484 C...Double precision and integer declarations.
59485  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59486  IMPLICIT INTEGER(I-N)
59487  INTEGER PYK,PYCHGE,PYCOMP
59488 C...Commonblocks.
59489  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59490  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59491  SAVE /pyjets/,/pydat1/
59492 C...Local arrays.
59493  dimension ijoin(2),ptot(4),beta(3)
59494 
59495 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59496  IF(icom.EQ.0) THEN
59497  mstu(28)=0
59498  CALL pyhepc(2)
59499  ENDIF
59500 
59501 C...Loop through entries and pick up all final partons.
59502  i1=0
59503  i2=0
59504  i3=0
59505  i4=0
59506  DO 100 i=1,n
59507  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
59508  kfa=iabs(k(i,2))
59509  IF((kfa.GE.1.AND.kfa.LE.6).OR.kfa.EQ.21) THEN
59510  IF(k(i,2).GT.0.AND.k(i,2).LE.6) THEN
59511  IF(i1.EQ.0) THEN
59512  i1=i
59513  ELSEIF(i3.EQ.0) THEN
59514  i3=i
59515  ELSE
59516  CALL pyerrm(16,'(PY4JET:) more than two quarks')
59517  ENDIF
59518  ELSEIF(k(i,2).LT.0) THEN
59519  IF(i2.EQ.0) THEN
59520  i2=i
59521  ELSEIF(i4.EQ.0) THEN
59522  i4=i
59523  ELSE
59524  CALL pyerrm(16,'(PY4JET:) more than two antiquarks')
59525  ENDIF
59526  ELSE
59527  IF(i3.EQ.0) THEN
59528  i3=i
59529  ELSEIF(i4.EQ.0) THEN
59530  i4=i
59531  ELSE
59532  CALL pyerrm(16,'(PY4JET:) more than two gluons')
59533  ENDIF
59534  ENDIF
59535  ENDIF
59536  100 CONTINUE
59537 
59538 C...Check that event is arranged according to conventions.
59539  IF(i1.EQ.0.OR.i2.EQ.0.OR.i3.EQ.0.OR.i4.EQ.0) THEN
59540  CALL pyerrm(16,'(PY4JET:) event contains too few partons')
59541  ENDIF
59542  IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
59543  CALL pyerrm(6,'(PY4JET:) partons arranged in wrong order')
59544  ENDIF
59545 
59546 C...Check whether second pair are quarks or gluons.
59547  IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
59548  iqg34=1
59549  ELSEIF(k(i3,2).EQ.21.AND.k(i4,2).EQ.21) THEN
59550  iqg34=2
59551  ELSE
59552  CALL pyerrm(16,'(PY4JET:) second parton pair inconsistent')
59553  ENDIF
59554 
59555 C...Boost partons to their cm frame.
59556  DO 110 j=1,4
59557  ptot(j)=p(i1,j)+p(i2,j)+p(i3,j)+p(i4,j)
59558  110 CONTINUE
59559  ecm=sqrt(max(0d0,ptot(4)**2-ptot(1)**2-ptot(2)**2-ptot(3)**2))
59560  DO 120 j=1,3
59561  beta(j)=ptot(j)/ptot(4)
59562  120 CONTINUE
59563  CALL pyrobo(i1,i1,0d0,0d0,-beta(1),-beta(2),-beta(3))
59564  CALL pyrobo(i2,i2,0d0,0d0,-beta(1),-beta(2),-beta(3))
59565  CALL pyrobo(i3,i3,0d0,0d0,-beta(1),-beta(2),-beta(3))
59566  CALL pyrobo(i4,i4,0d0,0d0,-beta(1),-beta(2),-beta(3))
59567  nsav=n
59568 
59569 C...Decide and set up shower history for q qbar q' qbar' events.
59570  IF(iqg34.EQ.1) THEN
59571  w1=py4jtw(0,i1,i3,i4)
59572  w2=py4jtw(0,i2,i3,i4)
59573  IF(w1.GT.pyr(0)*(w1+w2)) THEN
59574  CALL py4jts(0,i1,i3,i4,i2,qmax)
59575  ELSE
59576  CALL py4jts(0,i2,i3,i4,i1,qmax)
59577  ENDIF
59578 
59579 C...Decide and set up shower history for q qbar g g events.
59580  ELSE
59581  w1=py4jtw(i1,i3,i2,i4)
59582  w2=py4jtw(i1,i4,i2,i3)
59583  w3=py4jtw(0,i3,i1,i4)
59584  w4=py4jtw(0,i4,i1,i3)
59585  w5=py4jtw(0,i3,i2,i4)
59586  w6=py4jtw(0,i4,i2,i3)
59587  w7=py4jtw(0,i1,i3,i4)
59588  w8=py4jtw(0,i2,i3,i4)
59589  wr=(w1+w2+w3+w4+w5+w6+w7+w8)*pyr(0)
59590  IF(w1.GT.wr) THEN
59591  CALL py4jts(i1,i3,i2,i4,0,qmax)
59592  ELSEIF(w1+w2.GT.wr) THEN
59593  CALL py4jts(i1,i4,i2,i3,0,qmax)
59594  ELSEIF(w1+w2+w3.GT.wr) THEN
59595  CALL py4jts(0,i3,i1,i4,i2,qmax)
59596  ELSEIF(w1+w2+w3+w4.GT.wr) THEN
59597  CALL py4jts(0,i4,i1,i3,i2,qmax)
59598  ELSEIF(w1+w2+w3+w4+w5.GT.wr) THEN
59599  CALL py4jts(0,i3,i2,i4,i1,qmax)
59600  ELSEIF(w1+w2+w3+w4+w5+w6.GT.wr) THEN
59601  CALL py4jts(0,i4,i2,i3,i1,qmax)
59602  ELSEIF(w1+w2+w3+w4+w5+w6+w7.GT.wr) THEN
59603  CALL py4jts(0,i1,i3,i4,i2,qmax)
59604  ELSE
59605  CALL py4jts(0,i2,i3,i4,i1,qmax)
59606  ENDIF
59607  ENDIF
59608 
59609 C...Boost back original partons and mark them as deleted.
59610  CALL pyrobo(i1,i1,0d0,0d0,beta(1),beta(2),beta(3))
59611  CALL pyrobo(i2,i2,0d0,0d0,beta(1),beta(2),beta(3))
59612  CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
59613  CALL pyrobo(i4,i4,0d0,0d0,beta(1),beta(2),beta(3))
59614  k(i1,1)=k(i1,1)+10
59615  k(i2,1)=k(i2,1)+10
59616  k(i3,1)=k(i3,1)+10
59617  k(i4,1)=k(i4,1)+10
59618 
59619 C...Rotate shower initiating partons to be along z axis.
59620  phi=pyangl(p(nsav+1,1),p(nsav+1,2))
59621  CALL pyrobo(nsav+1,nsav+6,0d0,-phi,0d0,0d0,0d0)
59622  the=pyangl(p(nsav+1,3),p(nsav+1,1))
59623  CALL pyrobo(nsav+1,nsav+6,-the,0d0,0d0,0d0,0d0)
59624 
59625 C...Set up copy of shower initiating partons as on mass shell.
59626  DO 140 i=n+1,n+2
59627  DO 130 j=1,5
59628  k(i,j)=0
59629  p(i,j)=0d0
59630  v(i,j)=v(i1,j)
59631  130 CONTINUE
59632  k(i,1)=1
59633  k(i,2)=k(i-6,2)
59634  140 CONTINUE
59635  IF(k(nsav+1,2).EQ.k(i1,2)) THEN
59636  k(n+1,3)=i1
59637  p(n+1,5)=p(i1,5)
59638  k(n+2,3)=i2
59639  p(n+2,5)=p(i2,5)
59640  ELSE
59641  k(n+1,3)=i2
59642  p(n+1,5)=p(i2,5)
59643  k(n+2,3)=i1
59644  p(n+2,5)=p(i1,5)
59645  ENDIF
59646  pabs=sqrt(max(0d0,(ecm**2-p(n+1,5)**2-p(n+2,5)**2)**2-
59647  &(2d0*p(n+1,5)*p(n+2,5))**2))/(2d0*ecm)
59648  p(n+1,3)=pabs
59649  p(n+1,4)=sqrt(pabs**2+p(n+1,5)**2)
59650  p(n+2,3)=-pabs
59651  p(n+2,4)=sqrt(pabs**2+p(n+2,5)**2)
59652  n=n+2
59653 
59654 C...Decide whether to allow or not photon radiation in showers.
59655 C...Connect up colours.
59656  mstj(41)=2
59657  IF(irad.EQ.0) mstj(41)=1
59658  ijoin(1)=n-1
59659  ijoin(2)=n
59660  CALL pyjoin(2,ijoin)
59661 
59662 C...Decide on maximum virtuality and do parton shower.
59663  IF(pmax.LT.parj(82)) THEN
59664  pqmax=qmax
59665  ELSE
59666  pqmax=pmax
59667  ENDIF
59668  CALL pyshow(nsav+1,-100,pqmax)
59669 
59670 C...Rotate and boost back system.
59671  CALL pyrobo(nsav+1,n,the,phi,beta(1),beta(2),beta(3))
59672 
59673 C...Do fragmentation and decays.
59674  CALL pyexec
59675 
59676 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59677  IF(icom.EQ.0) THEN
59678  mstu(28)=0
59679  CALL pyhepc(1)
59680  ENDIF
59681 
59682  RETURN
59683  END
59684 
59685 C*********************************************************************
59686 
59687 C...PY4JTW
59688 C...Auxiliary to PY4JET, to evaluate weight of configuration.
59689 
59690  FUNCTION py4jtw(IA1,IA2,IA3,IA4)
59691 
59692 C...Double precision and integer declarations.
59693  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59694  IMPLICIT INTEGER(I-N)
59695  INTEGER PYK,PYCHGE,PYCOMP
59696 C...Commonblocks.
59697  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59698  SAVE /pyjets/
59699 
59700 C...First case: when both original partons radiate.
59701 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59702  IF(ia1.NE.0) THEN
59703  DO 100 j=1,4
59704  p(n+1,j)=p(ia1,j)+p(ia2,j)
59705  p(n+2,j)=p(ia3,j)+p(ia4,j)
59706  100 CONTINUE
59707  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59708  & p(n+1,3)**2))
59709  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59710  & p(n+2,3)**2))
59711  z1=p(ia1,4)/p(n+1,4)
59712  wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-p(ia1,5)**2)
59713  z2=p(ia3,4)/p(n+2,4)
59714  wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-p(ia3,5)**2)
59715 
59716 C...Second case: when one original parton radiates to three.
59717 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59718  ELSE
59719  DO 110 j=1,4
59720  p(n+2,j)=p(ia3,j)+p(ia4,j)
59721  p(n+1,j)=p(n+2,j)+p(ia2,j)
59722  110 CONTINUE
59723  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59724  & p(n+1,3)**2))
59725  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59726  & p(n+2,3)**2))
59727  IF(k(ia2,2).EQ.21) THEN
59728  z1=p(n+2,4)/p(n+1,4)
59729  wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
59730  & p(ia3,5)**2)
59731  ELSE
59732  z1=p(ia2,4)/p(n+1,4)
59733  wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
59734  & p(ia2,5)**2)
59735  ENDIF
59736  z2=p(ia3,4)/p(n+2,4)
59737  IF(k(ia2,2).EQ.21) THEN
59738  wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-
59739  & p(ia3,5)**2)
59740  ELSEIF(k(ia3,2).EQ.21) THEN
59741  wt2=3d0*((1d0-z2*(1d0-z2))**2/(z2*(1d0-z2)))/p(n+2,5)**2
59742  ELSE
59743  wt2=0.5d0*(z2**2+(1d0-z2)**2)
59744  ENDIF
59745  ENDIF
59746 
59747 C...Total weight.
59748  py4jtw=wt1*wt2
59749 
59750  RETURN
59751  END
59752 
59753 C*********************************************************************
59754 
59755 C...PY4JTS
59756 C...Auxiliary to PY4JET, to set up chosen configuration.
59757 
59758  SUBROUTINE py4jts(IA1,IA2,IA3,IA4,IA5,QMAX)
59759 
59760 C...Double precision and integer declarations.
59761  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59762  IMPLICIT INTEGER(I-N)
59763  INTEGER PYK,PYCHGE,PYCOMP
59764 C...Commonblocks.
59765  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59766  SAVE /pyjets/
59767 
59768 C...Reset info.
59769  DO 110 i=n+1,n+6
59770  DO 100 j=1,5
59771  k(i,j)=0
59772  v(i,j)=v(ia2,j)
59773  100 CONTINUE
59774  k(i,1)=16
59775  110 CONTINUE
59776 
59777 C...First case: when both original partons radiate.
59778 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59779  IF(ia1.NE.0) THEN
59780 
59781 C...Set up flavour and history pointers for new partons.
59782  k(n+1,2)=k(ia1,2)
59783  k(n+2,2)=k(ia3,2)
59784  k(n+3,2)=k(ia1,2)
59785  k(n+4,2)=k(ia2,2)
59786  k(n+5,2)=k(ia3,2)
59787  k(n+6,2)=k(ia4,2)
59788  k(n+1,3)=ia1
59789  k(n+1,4)=n+3
59790  k(n+1,5)=n+4
59791  k(n+2,3)=ia3
59792  k(n+2,4)=n+5
59793  k(n+2,5)=n+6
59794  k(n+3,3)=n+1
59795  k(n+4,3)=n+1
59796  k(n+5,3)=n+2
59797  k(n+6,3)=n+2
59798 
59799 C...Set up momenta for new partons.
59800  DO 120 j=1,5
59801  p(n+1,j)=p(ia1,j)+p(ia2,j)
59802  p(n+2,j)=p(ia3,j)+p(ia4,j)
59803  p(n+3,j)=p(ia1,j)
59804  p(n+4,j)=p(ia2,j)
59805  p(n+5,j)=p(ia3,j)
59806  p(n+6,j)=p(ia4,j)
59807  120 CONTINUE
59808  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59809  & p(n+1,3)**2))
59810  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59811  & p(n+2,3)**2))
59812  qmax=min(p(n+1,5),p(n+2,5))
59813 
59814 C...Second case: q radiates twice.
59815 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59816 C...IA5=N+2 does not radiate.
59817  ELSEIF(k(ia2,2).EQ.21) THEN
59818 
59819 C...Set up flavour and history pointers for new partons.
59820  k(n+1,2)=k(ia3,2)
59821  k(n+2,2)=k(ia5,2)
59822  k(n+3,2)=k(ia3,2)
59823  k(n+4,2)=k(ia2,2)
59824  k(n+5,2)=k(ia3,2)
59825  k(n+6,2)=k(ia4,2)
59826  k(n+1,3)=ia3
59827  k(n+1,4)=n+3
59828  k(n+1,5)=n+4
59829  k(n+2,3)=ia5
59830  k(n+3,3)=n+1
59831  k(n+3,4)=n+5
59832  k(n+3,5)=n+6
59833  k(n+4,3)=n+1
59834  k(n+5,3)=n+3
59835  k(n+6,3)=n+3
59836 
59837 C...Set up momenta for new partons.
59838  DO 130 j=1,5
59839  p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
59840  p(n+2,j)=p(ia5,j)
59841  p(n+3,j)=p(ia3,j)+p(ia4,j)
59842  p(n+4,j)=p(ia2,j)
59843  p(n+5,j)=p(ia3,j)
59844  p(n+6,j)=p(ia4,j)
59845  130 CONTINUE
59846  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59847  & p(n+1,3)**2))
59848  p(n+3,5)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,1)**2-p(n+3,2)**2-
59849  & p(n+3,3)**2))
59850  qmax=p(n+3,5)
59851 
59852 C...Third case: q radiates g, g branches.
59853 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59854 C...IA5=N+2 does not radiate.
59855  ELSE
59856 
59857 C...Set up flavour and history pointers for new partons.
59858  k(n+1,2)=k(ia2,2)
59859  k(n+2,2)=k(ia5,2)
59860  k(n+3,2)=k(ia2,2)
59861  k(n+4,2)=21
59862  k(n+5,2)=k(ia3,2)
59863  k(n+6,2)=k(ia4,2)
59864  k(n+1,3)=ia2
59865  k(n+1,4)=n+3
59866  k(n+1,5)=n+4
59867  k(n+2,3)=ia5
59868  k(n+3,3)=n+1
59869  k(n+4,3)=n+1
59870  k(n+4,4)=n+5
59871  k(n+4,5)=n+6
59872  k(n+5,3)=n+4
59873  k(n+6,3)=n+4
59874 
59875 C...Set up momenta for new partons.
59876  DO 140 j=1,5
59877  p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
59878  p(n+2,j)=p(ia5,j)
59879  p(n+3,j)=p(ia2,j)
59880  p(n+4,j)=p(ia3,j)+p(ia4,j)
59881  p(n+5,j)=p(ia3,j)
59882  p(n+6,j)=p(ia4,j)
59883  140 CONTINUE
59884  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59885  & p(n+1,3)**2))
59886  p(n+4,5)=sqrt(max(0d0,p(n+4,4)**2-p(n+4,1)**2-p(n+4,2)**2-
59887  & p(n+4,3)**2))
59888  qmax=p(n+4,5)
59889 
59890  ENDIF
59891  n=n+6
59892 
59893  RETURN
59894  END
59895 
59896 C*********************************************************************
59897 
59898 C...PYJOIN
59899 C...Connects a sequence of partons with colour flow indices,
59900 C...as required for subsequent shower evolution (or other operations).
59901 
59902  SUBROUTINE pyjoin(NJOIN,IJOIN)
59903 
59904 C...Double precision and integer declarations.
59905  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59906  IMPLICIT INTEGER(I-N)
59907  INTEGER PYK,PYCHGE,PYCOMP
59908 C...Commonblocks.
59909  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59910  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59911  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59912  SAVE /pyjets/,/pydat1/,/pydat2/
59913 C...Local array.
59914  dimension ijoin(*)
59915 
59916 C...Check that partons are of right types to be connected.
59917  IF(njoin.LT.2) GOTO 120
59918  kqsum=0
59919  DO 100 ijn=1,njoin
59920  i=ijoin(ijn)
59921  IF(i.LE.0.OR.i.GT.n) GOTO 120
59922  IF(k(i,1).LT.1.OR.k(i,1).GT.3) GOTO 120
59923  kc=pycomp(k(i,2))
59924  IF(kc.EQ.0) GOTO 120
59925  kq=kchg(kc,2)*isign(1,k(i,2))
59926  IF(kq.EQ.0) GOTO 120
59927  IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) GOTO 120
59928  IF(kq.NE.2) kqsum=kqsum+kq
59929  IF(ijn.EQ.1) kqs=kq
59930  100 CONTINUE
59931  IF(kqsum.NE.0) GOTO 120
59932 
59933 C...Connect the partons sequentially (closing for gluon loop).
59934  kcs=(9-kqs)/2
59935  IF(kqs.EQ.2) kcs=int(4.5d0+pyr(0))
59936  DO 110 ijn=1,njoin
59937  i=ijoin(ijn)
59938  k(i,1)=3
59939  IF(ijn.NE.1) ip=ijoin(ijn-1)
59940  IF(ijn.EQ.1) ip=ijoin(njoin)
59941  IF(ijn.NE.njoin) in=ijoin(ijn+1)
59942  IF(ijn.EQ.njoin) in=ijoin(1)
59943  k(i,kcs)=mstu(5)*in
59944  k(i,9-kcs)=mstu(5)*ip
59945  IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
59946  IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
59947  110 CONTINUE
59948 
59949 C...Error exit: no action taken.
59950  RETURN
59951  120 CALL pyerrm(12,
59952  &'(PYJOIN:) given entries can not be joined by one string')
59953 
59954  RETURN
59955  END
59956 
59957 C*********************************************************************
59958 
59959 C...PYGIVE
59960 C...Sets values of commonblock variables.
59961 
59962  SUBROUTINE pygive(CHIN)
59963 
59964 C...Double precision and integer declarations.
59965  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59966  IMPLICIT INTEGER(I-N)
59967  INTEGER PYK,PYCHGE,PYCOMP
59968 C...Commonblocks.
59969  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59970  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59971  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59972  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
59973  common/pydat4/chaf(500,2)
59974  CHARACTER CHAF*16
59975  common/pydatr/mrpy(6),rrpy(100)
59976  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
59977  common/pypars/mstp(200),parp(200),msti(200),pari(200)
59978  common/pyint1/mint(400),vint(400)
59979  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
59980  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
59981  common/pyint4/mwid(500),wids(500,5)
59982  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
59983  common/pyint6/proc(0:500)
59984  CHARACTER PROC*28
59985  common/pyint7/sigt(0:6,0:6,0:5)
59986  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
59987  &xpdir(-6:6)
59988  common/pymssm/imss(0:99),rmss(0:99)
59989  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
59990  common/pytcsm/itcm(0:99),rtcm(0:99)
59991  common/pypued/iued(0:99),rued(0:99)
59992  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,
59993  &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,
59994  &/pyint6/,/pyint7/,/pyint8/,/pymssm/,/pymsrv/,/pytcsm/,/pypued/
59995 C...Local arrays and character variables.
59996  CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
59997  &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
59998  &CHINR*16,CHDIG*10
59999  DIMENSION MSVAR(56,8)
60000 
60001 C...For each variable to be translated give: name,
60002 C...integer/real/character, no. of indices, lower&upper index bounds.
60003  DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60004  &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60005  &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60006  &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60007  &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60008  &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60009  &'ITCM','RTCM','IUED','RUED'/
60010  DATA ((msvar(i,j),j=1,8),i=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60011  &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60012  &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60013  &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60014  &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60015  &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60016  &1,1,1,6,4*0, 2,1,1,100,4*0,
60017  &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60018  &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60019  &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60020  &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60021  &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60022  &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60023  &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60024  &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60025  &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60026  &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60027  &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60028  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
60029  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, chdig/'1234567890'/
60030 
60031 C...Length of character variable. Subdivide it into instructions.
60032  IF(mstu(12).NE.12345.AND.chin.NE.'mstu(12)=12345'.AND.
60033  &chin.NE.'MSTU(12)=12345') CALL pylist(0)
60034  chbit=chin//' '
60035  lbit=101
60036  100 lbit=lbit-1
60037  IF(chbit(lbit:lbit).EQ.' ') GOTO 100
60038  ltot=0
60039  DO 110 lcom=1,lbit
60040  IF(chbit(lcom:lcom).EQ.' ') GOTO 110
60041  ltot=ltot+1
60042  chfix(ltot:ltot)=chbit(lcom:lcom)
60043  110 CONTINUE
60044  llow=0
60045  120 lhig=llow+1
60046  130 lhig=lhig+1
60047  IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') GOTO 130
60048  lbit=lhig-llow-1
60049  chbit(1:lbit)=chfix(llow+1:lhig-1)
60050 
60051 C...Send off decay-mode on/off commands to PYONOF.
60052  ionof=0
60053  DO 135 ldig=1,10
60054  IF(chbit(1:1).EQ.chdig(ldig:ldig)) ionof=1
60055  135 CONTINUE
60056  IF(ionof.EQ.1) THEN
60057  CALL pyonof(chin)
60058  RETURN
60059  ENDIF
60060 
60061 C...Peel off any text following exclamation mark.
60062  lhig2=lbit
60063  DO 140 llow2=lhig2,1,-1
60064  IF(chbit(llow2:llow2).EQ.'!') lbit=llow2-1
60065  140 CONTINUE
60066  IF(lbit.EQ.0) RETURN
60067 
60068 C...Identify commonblock variable.
60069  lnam=1
60070  150 lnam=lnam+1
60071  IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
60072  &lnam.LE.6) GOTO 150
60073  chnam=chbit(1:lnam-1)//' '
60074  DO 170 lcom=1,lnam-1
60075  DO 160 lalp=1,26
60076  IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
60077  & chalp(2)(lalp:lalp)
60078  160 CONTINUE
60079  170 CONTINUE
60080  ivar=0
60081  DO 180 iv=1,56
60082  IF(chnam.EQ.chvar(iv)) ivar=iv
60083  180 CONTINUE
60084  IF(ivar.EQ.0) THEN
60085  CALL pyerrm(18,'(PYGIVE:) do not recognize variable '//chnam)
60086  llow=lhig
60087  IF(llow.LT.ltot) GOTO 120
60088  RETURN
60089  ENDIF
60090 
60091 C...Identify any indices.
60092  i1=0
60093  i2=0
60094  i3=0
60095  nindx=0
60096  IF(chbit(lnam:lnam).EQ.'(') THEN
60097  lind=lnam
60098  190 lind=lind+1
60099  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 190
60100  chind=' '
60101  IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c')
60102  & .AND.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17.OR.
60103  & ivar.EQ.37)) THEN
60104  chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
60105  READ(chind,'(I8)') kf
60106  i1=pycomp(kf)
60107  ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
60108  & 'c') THEN
60109  CALL pyerrm(18,'(PYGIVE:) not allowed to use C index for '//
60110  & chnam)
60111  llow=lhig
60112  IF(llow.LT.ltot) GOTO 120
60113  RETURN
60114  ELSE
60115  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
60116  READ(chind,'(I8)') i1
60117  ENDIF
60118  lnam=lind
60119  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
60120  nindx=1
60121  ENDIF
60122  IF(chbit(lnam:lnam).EQ.',') THEN
60123  lind=lnam
60124  200 lind=lind+1
60125  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 200
60126  chind=' '
60127  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
60128  READ(chind,'(I8)') i2
60129  lnam=lind
60130  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
60131  nindx=2
60132  ENDIF
60133  IF(chbit(lnam:lnam).EQ.',') THEN
60134  lind=lnam
60135  210 lind=lind+1
60136  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 210
60137  chind=' '
60138  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
60139  READ(chind,'(I8)') i3
60140  lnam=lind+1
60141  nindx=3
60142  ENDIF
60143 
60144 C...Check that indices allowed.
60145  ierr=0
60146  IF(nindx.NE.msvar(ivar,2)) ierr=1
60147  IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
60148  &ierr=2
60149  IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
60150  &ierr=3
60151  IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
60152  &ierr=4
60153  IF(chbit(lnam:lnam).NE.'=') ierr=5
60154  IF(ierr.GE.1) THEN
60155  CALL pyerrm(18,'(PYGIVE:) unallowed indices for '//
60156  & chbit(1:lnam-1))
60157  llow=lhig
60158  IF(llow.LT.ltot) GOTO 120
60159  RETURN
60160  ENDIF
60161 
60162 C...Save old value of variable.
60163  IF(ivar.EQ.1) THEN
60164  iold=n
60165  ELSEIF(ivar.EQ.2) THEN
60166  iold=k(i1,i2)
60167  ELSEIF(ivar.EQ.3) THEN
60168  rold=p(i1,i2)
60169  ELSEIF(ivar.EQ.4) THEN
60170  rold=v(i1,i2)
60171  ELSEIF(ivar.EQ.5) THEN
60172  iold=mstu(i1)
60173  ELSEIF(ivar.EQ.6) THEN
60174  rold=paru(i1)
60175  ELSEIF(ivar.EQ.7) THEN
60176  iold=mstj(i1)
60177  ELSEIF(ivar.EQ.8) THEN
60178  rold=parj(i1)
60179  ELSEIF(ivar.EQ.9) THEN
60180  iold=kchg(i1,i2)
60181  ELSEIF(ivar.EQ.10) THEN
60182  rold=pmas(i1,i2)
60183  ELSEIF(ivar.EQ.11) THEN
60184  rold=parf(i1)
60185  ELSEIF(ivar.EQ.12) THEN
60186  rold=vckm(i1,i2)
60187  ELSEIF(ivar.EQ.13) THEN
60188  iold=mdcy(i1,i2)
60189  ELSEIF(ivar.EQ.14) THEN
60190  iold=mdme(i1,i2)
60191  ELSEIF(ivar.EQ.15) THEN
60192  rold=brat(i1)
60193  ELSEIF(ivar.EQ.16) THEN
60194  iold=kfdp(i1,i2)
60195  ELSEIF(ivar.EQ.17) THEN
60196  chold=chaf(i1,i2)(1:8)
60197  ELSEIF(ivar.EQ.18) THEN
60198  iold=mrpy(i1)
60199  ELSEIF(ivar.EQ.19) THEN
60200  rold=rrpy(i1)
60201  ELSEIF(ivar.EQ.20) THEN
60202  iold=msel
60203  ELSEIF(ivar.EQ.21) THEN
60204  iold=msub(i1)
60205  ELSEIF(ivar.EQ.22) THEN
60206  iold=kfin(i1,i2)
60207  ELSEIF(ivar.EQ.23) THEN
60208  rold=ckin(i1)
60209  ELSEIF(ivar.EQ.24) THEN
60210  iold=mstp(i1)
60211  ELSEIF(ivar.EQ.25) THEN
60212  rold=parp(i1)
60213  ELSEIF(ivar.EQ.26) THEN
60214  iold=msti(i1)
60215  ELSEIF(ivar.EQ.27) THEN
60216  rold=pari(i1)
60217  ELSEIF(ivar.EQ.28) THEN
60218  iold=mint(i1)
60219  ELSEIF(ivar.EQ.29) THEN
60220  rold=vint(i1)
60221  ELSEIF(ivar.EQ.30) THEN
60222  iold=iset(i1)
60223  ELSEIF(ivar.EQ.31) THEN
60224  iold=kfpr(i1,i2)
60225  ELSEIF(ivar.EQ.32) THEN
60226  rold=coef(i1,i2)
60227  ELSEIF(ivar.EQ.33) THEN
60228  iold=icol(i1,i2,i3)
60229  ELSEIF(ivar.EQ.34) THEN
60230  rold=xsfx(i1,i2)
60231  ELSEIF(ivar.EQ.35) THEN
60232  iold=isig(i1,i2)
60233  ELSEIF(ivar.EQ.36) THEN
60234  rold=sigh(i1)
60235  ELSEIF(ivar.EQ.37) THEN
60236  iold=mwid(i1)
60237  ELSEIF(ivar.EQ.38) THEN
60238  rold=wids(i1,i2)
60239  ELSEIF(ivar.EQ.39) THEN
60240  iold=ngen(i1,i2)
60241  ELSEIF(ivar.EQ.40) THEN
60242  rold=xsec(i1,i2)
60243  ELSEIF(ivar.EQ.41) THEN
60244  chold2=proc(i1)
60245  ELSEIF(ivar.EQ.42) THEN
60246  rold=sigt(i1,i2,i3)
60247  ELSEIF(ivar.EQ.43) THEN
60248  rold=xpvmd(i1)
60249  ELSEIF(ivar.EQ.44) THEN
60250  rold=xpanl(i1)
60251  ELSEIF(ivar.EQ.45) THEN
60252  rold=xpanh(i1)
60253  ELSEIF(ivar.EQ.46) THEN
60254  rold=xpbeh(i1)
60255  ELSEIF(ivar.EQ.47) THEN
60256  rold=xpdir(i1)
60257  ELSEIF(ivar.EQ.48) THEN
60258  iold=imss(i1)
60259  ELSEIF(ivar.EQ.49) THEN
60260  rold=rmss(i1)
60261  ELSEIF(ivar.EQ.50) THEN
60262  rold=rvlam(i1,i2,i3)
60263  ELSEIF(ivar.EQ.51) THEN
60264  rold=rvlamp(i1,i2,i3)
60265  ELSEIF(ivar.EQ.52) THEN
60266  rold=rvlamb(i1,i2,i3)
60267  ELSEIF(ivar.EQ.53) THEN
60268  iold=itcm(i1)
60269  ELSEIF(ivar.EQ.54) THEN
60270  rold=rtcm(i1)
60271  ELSEIF(ivar.EQ.55) THEN
60272  iold=iued(i1)
60273  ELSEIF(ivar.EQ.56) THEN
60274  rold=rued(i1)
60275  ENDIF
60276 
60277 C...Print current value of variable. Loop back.
60278  IF(lnam.GE.lbit) THEN
60279  chbit(lnam:14)=' '
60280  chbit(15:60)=' has the value '
60281  IF(msvar(ivar,1).EQ.1) THEN
60282  WRITE(chbit(51:60),'(I10)') iold
60283  ELSEIF(msvar(ivar,1).EQ.2) THEN
60284  WRITE(chbit(47:60),'(F14.5)') rold
60285  ELSEIF(msvar(ivar,1).EQ.3) THEN
60286  chbit(53:60)=chold
60287  ELSE
60288  chbit(33:60)=chold
60289  ENDIF
60290  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60291  llow=lhig
60292  IF(llow.LT.ltot) GOTO 120
60293  RETURN
60294  ENDIF
60295 
60296 C...Read in new variable value.
60297  IF(msvar(ivar,1).EQ.1) THEN
60298  chini=' '
60299  chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
60300  READ(chini,'(I10)') inew
60301  ELSEIF(msvar(ivar,1).EQ.2) THEN
60302  chinr=' '
60303  chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
60304  READ(chinr,*) rnew
60305  ELSEIF(msvar(ivar,1).EQ.3) THEN
60306  chnew=chbit(lnam+1:lbit)//' '
60307  ELSE
60308  chnew2=chbit(lnam+1:lbit)//' '
60309  ENDIF
60310 
60311 C...Store new variable value.
60312  IF(ivar.EQ.1) THEN
60313  n=inew
60314  ELSEIF(ivar.EQ.2) THEN
60315  k(i1,i2)=inew
60316  ELSEIF(ivar.EQ.3) THEN
60317  p(i1,i2)=rnew
60318  ELSEIF(ivar.EQ.4) THEN
60319  v(i1,i2)=rnew
60320  ELSEIF(ivar.EQ.5) THEN
60321  mstu(i1)=inew
60322  ELSEIF(ivar.EQ.6) THEN
60323  paru(i1)=rnew
60324  ELSEIF(ivar.EQ.7) THEN
60325  mstj(i1)=inew
60326  ELSEIF(ivar.EQ.8) THEN
60327  parj(i1)=rnew
60328  ELSEIF(ivar.EQ.9) THEN
60329  kchg(i1,i2)=inew
60330  ELSEIF(ivar.EQ.10) THEN
60331  pmas(i1,i2)=rnew
60332  ELSEIF(ivar.EQ.11) THEN
60333  parf(i1)=rnew
60334  ELSEIF(ivar.EQ.12) THEN
60335  vckm(i1,i2)=rnew
60336  ELSEIF(ivar.EQ.13) THEN
60337  mdcy(i1,i2)=inew
60338  ELSEIF(ivar.EQ.14) THEN
60339  mdme(i1,i2)=inew
60340  ELSEIF(ivar.EQ.15) THEN
60341  brat(i1)=rnew
60342  ELSEIF(ivar.EQ.16) THEN
60343  kfdp(i1,i2)=inew
60344  ELSEIF(ivar.EQ.17) THEN
60345  chaf(i1,i2)=chnew
60346  ELSEIF(ivar.EQ.18) THEN
60347  mrpy(i1)=inew
60348  ELSEIF(ivar.EQ.19) THEN
60349  rrpy(i1)=rnew
60350  ELSEIF(ivar.EQ.20) THEN
60351  msel=inew
60352  ELSEIF(ivar.EQ.21) THEN
60353  msub(i1)=inew
60354  ELSEIF(ivar.EQ.22) THEN
60355  kfin(i1,i2)=inew
60356  ELSEIF(ivar.EQ.23) THEN
60357  ckin(i1)=rnew
60358  ELSEIF(ivar.EQ.24) THEN
60359  mstp(i1)=inew
60360  ELSEIF(ivar.EQ.25) THEN
60361  parp(i1)=rnew
60362  ELSEIF(ivar.EQ.26) THEN
60363  msti(i1)=inew
60364  ELSEIF(ivar.EQ.27) THEN
60365  pari(i1)=rnew
60366  ELSEIF(ivar.EQ.28) THEN
60367  mint(i1)=inew
60368  ELSEIF(ivar.EQ.29) THEN
60369  vint(i1)=rnew
60370  ELSEIF(ivar.EQ.30) THEN
60371  iset(i1)=inew
60372  ELSEIF(ivar.EQ.31) THEN
60373  kfpr(i1,i2)=inew
60374  ELSEIF(ivar.EQ.32) THEN
60375  coef(i1,i2)=rnew
60376  ELSEIF(ivar.EQ.33) THEN
60377  icol(i1,i2,i3)=inew
60378  ELSEIF(ivar.EQ.34) THEN
60379  xsfx(i1,i2)=rnew
60380  ELSEIF(ivar.EQ.35) THEN
60381  isig(i1,i2)=inew
60382  ELSEIF(ivar.EQ.36) THEN
60383  sigh(i1)=rnew
60384  ELSEIF(ivar.EQ.37) THEN
60385  mwid(i1)=inew
60386  ELSEIF(ivar.EQ.38) THEN
60387  wids(i1,i2)=rnew
60388  ELSEIF(ivar.EQ.39) THEN
60389  ngen(i1,i2)=inew
60390  ELSEIF(ivar.EQ.40) THEN
60391  xsec(i1,i2)=rnew
60392  ELSEIF(ivar.EQ.41) THEN
60393  proc(i1)=chnew2
60394  ELSEIF(ivar.EQ.42) THEN
60395  sigt(i1,i2,i3)=rnew
60396  ELSEIF(ivar.EQ.43) THEN
60397  xpvmd(i1)=rnew
60398  ELSEIF(ivar.EQ.44) THEN
60399  xpanl(i1)=rnew
60400  ELSEIF(ivar.EQ.45) THEN
60401  xpanh(i1)=rnew
60402  ELSEIF(ivar.EQ.46) THEN
60403  xpbeh(i1)=rnew
60404  ELSEIF(ivar.EQ.47) THEN
60405  xpdir(i1)=rnew
60406  ELSEIF(ivar.EQ.48) THEN
60407  imss(i1)=inew
60408  ELSEIF(ivar.EQ.49) THEN
60409  rmss(i1)=rnew
60410  ELSEIF(ivar.EQ.50) THEN
60411  rvlam(i1,i2,i3)=rnew
60412  ELSEIF(ivar.EQ.51) THEN
60413  rvlamp(i1,i2,i3)=rnew
60414  ELSEIF(ivar.EQ.52) THEN
60415  rvlamb(i1,i2,i3)=rnew
60416  ELSEIF(ivar.EQ.53) THEN
60417  itcm(i1)=inew
60418  ELSEIF(ivar.EQ.54) THEN
60419  rtcm(i1)=rnew
60420  ELSEIF(ivar.EQ.55) THEN
60421  iued(i1)=inew
60422  ELSEIF(ivar.EQ.56) THEN
60423  rued(i1)=rnew
60424  ENDIF
60425 
60426 C...Write old and new value. Loop back.
60427  chbit(lnam:14)=' '
60428  chbit(15:60)=' changed from to '
60429  IF(msvar(ivar,1).EQ.1) THEN
60430  WRITE(chbit(33:42),'(I10)') iold
60431  WRITE(chbit(51:60),'(I10)') inew
60432  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60433  ELSEIF(msvar(ivar,1).EQ.2) THEN
60434  WRITE(chbit(29:42),'(F14.5)') rold
60435  WRITE(chbit(47:60),'(F14.5)') rnew
60436  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60437  ELSEIF(msvar(ivar,1).EQ.3) THEN
60438  chbit(35:42)=chold
60439  chbit(53:60)=chnew
60440  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60441  ELSE
60442  chbit(15:88)=' changed from '//chold2//' to '//chnew2
60443  IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
60444  ENDIF
60445  llow=lhig
60446  IF(llow.LT.ltot) GOTO 120
60447 
60448 C...Format statement for output on unit MSTU(11) (by default 6).
60449  5000 FORMAT(5x,a60)
60450  5100 FORMAT(5x,a88)
60451 
60452  RETURN
60453  END
60454 
60455 C*********************************************************************
60456 
60457 C...PYONOF
60458 C...Switches on and off decay channel by search for match.
60459 
60460  SUBROUTINE pyonof(CHIN)
60461 
60462 C...Double precision and integer declarations.
60463  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60464  IMPLICIT INTEGER(I-N)
60465  INTEGER PYK,PYCHGE,PYCOMP
60466 C...Commonblocks.
60467  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60468  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
60469  SAVE /pydat1/,/pydat3/
60470 C...Local arrays and character variables.
60471  INTEGER KFCMP(10),KFTMP(10)
60472  CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60473  &chalp(2)*26
60474  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
60475  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60476 
60477 C...Determine length of character variable.
60478  chtmp=chin//' '
60479  lbeg=0
60480  100 lbeg=lbeg+1
60481  IF(chtmp(lbeg:lbeg).EQ.' ') GOTO 100
60482  lend=lbeg-1
60483  105 lend=lend+1
60484  IF(lend.LE.100.AND.chtmp(lend:lend).NE.'!') GOTO 105
60485  110 lend=lend-1
60486  IF(chtmp(lend:lend).EQ.' ') GOTO 110
60487  len=1+lend-lbeg
60488  chfix(1:len)=chtmp(lbeg:lend)
60489 
60490 C...Find colon separator and particle code.
60491  lcolon=0
60492  120 lcolon=lcolon+1
60493  IF(chfix(lcolon:lcolon).NE.':') GOTO 120
60494  chcode=' '
60495  chcode(10-lcolon:8)=chfix(1:lcolon-1)
60496  READ(chcode,'(I8)',err=300) kf
60497  kc=pycomp(kf)
60498 
60499 C...Done if unknown code or no decay channels.
60500  IF(kc.EQ.0) THEN
60501  CALL pyerrm(18,'(PYONOF:) unrecognized particle '//chcode)
60502  RETURN
60503  ENDIF
60504  idcbeg=mdcy(kc,2)
60505  idclen=mdcy(kc,3)
60506  IF(idcbeg.EQ.0.OR.idclen.EQ.0) THEN
60507  CALL pyerrm(18,'(PYONOF:) no decay channels for '//chcode)
60508  RETURN
60509  ENDIF
60510 
60511 C...Find command name up to blank or equal sign.
60512  lsep=lcolon
60513  130 lsep=lsep+1
60514  IF(lsep.LE.len.AND.chfix(lsep:lsep).NE.' '.AND.
60515  &chfix(lsep:lsep).NE.'=') GOTO 130
60516  chmode=' '
60517  lmode=lsep-lcolon-1
60518  chmode(1:lmode)=chfix(lcolon+1:lsep-1)
60519 
60520 C...Convert to uppercase.
60521  DO 150 lcom=1,lmode
60522  DO 140 lalp=1,26
60523  IF(chmode(lcom:lcom).EQ.chalp(1)(lalp:lalp))
60524  & chmode(lcom:lcom)=chalp(2)(lalp:lalp)
60525  140 CONTINUE
60526  150 CONTINUE
60527 
60528 C...Identify command. Failed if not identified.
60529  mode=0
60530  IF(chmode.EQ.'ALLOFF') mode=1
60531  IF(chmode.EQ.'ALLON') mode=2
60532  IF(chmode.EQ.'OFFIFANY') mode=3
60533  IF(chmode.EQ.'ONIFANY') mode=4
60534  IF(chmode.EQ.'OFFIFALL') mode=5
60535  IF(chmode.EQ.'ONIFALL') mode=6
60536  IF(chmode.EQ.'OFFIFMATCH') mode=7
60537  IF(chmode.EQ.'ONIFMATCH') mode=8
60538  IF(mode.EQ.0) THEN
60539  CALL pyerrm(18,'(PYONOF:) unknown command '//chmode)
60540  RETURN
60541  ENDIF
60542 
60543 C...Simple cases when all on or all off.
60544  IF(mode.EQ.1.OR.mode.EQ.2) THEN
60545  WRITE(mstu(11),1000) kf,chmode
60546  DO 160 idc=idcbeg,idcbeg+idclen-1
60547  IF(mdme(idc,1).LT.0) GOTO 160
60548  mdme(idc,1)=mode-1
60549  160 CONTINUE
60550  RETURN
60551  ENDIF
60552 
60553 C...Identify matching list.
60554  ncmp=0
60555  lbeg=lsep
60556  170 lbeg=lbeg+1
60557  IF(lbeg.GT.len) GOTO 190
60558  IF(lbeg.LT.len.AND.(chfix(lbeg:lbeg).EQ.' '.OR.
60559  &chfix(lbeg:lbeg).EQ.'='.OR.chfix(lbeg:lbeg).EQ.',')) GOTO 170
60560  lend=lbeg-1
60561  180 lend=lend+1
60562  IF(lend.LT.len.AND.chfix(lend:lend).NE.' '.AND.
60563  &chfix(lend:lend).NE.'='.AND.chfix(lend:lend).NE.',') GOTO 180
60564  IF(lend.LT.len) lend=lend-1
60565  chcode=' '
60566  chcode(8-lend+lbeg:8)=chfix(lbeg:lend)
60567  READ(chcode,'(I8)',err=300) kfread
60568  ncmp=ncmp+1
60569  kfcmp(ncmp)=iabs(kfread)
60570  lbeg=lend
60571  IF(ncmp.LT.10) GOTO 170
60572  190 CONTINUE
60573  WRITE(mstu(11),1100) kf,chmode,(kfcmp(icmp),icmp=1,ncmp)
60574 
60575 C...Only one matching required.
60576  IF(mode.EQ.3.OR.mode.EQ.4) THEN
60577  DO 220 idc=idcbeg,idcbeg+idclen-1
60578  IF(mdme(idc,1).LT.0) GOTO 220
60579  DO 210 ikf=1,5
60580  kfnow=iabs(kfdp(idc,ikf))
60581  IF(kfnow.EQ.0) GOTO 210
60582  DO 200 icmp=1,ncmp
60583  IF(kfcmp(icmp).EQ.kfnow) THEN
60584  mdme(idc,1)=mode-3
60585  GOTO 220
60586  ENDIF
60587  200 CONTINUE
60588  210 CONTINUE
60589  220 CONTINUE
60590  RETURN
60591  ENDIF
60592 
60593 C...Multiple matchings required.
60594  DO 260 idc=idcbeg,idcbeg+idclen-1
60595  IF(mdme(idc,1).LT.0) GOTO 260
60596  ntmp=ncmp
60597  DO 230 itmp=1,ntmp
60598  kftmp(itmp)=kfcmp(itmp)
60599  230 CONTINUE
60600  nfin=0
60601  DO 250 ikf=1,5
60602  kfnow=iabs(kfdp(idc,ikf))
60603  IF(kfnow.EQ.0) GOTO 250
60604  nfin=nfin+1
60605  DO 240 itmp=1,ntmp
60606  IF(kftmp(itmp).EQ.kfnow) THEN
60607  kftmp(itmp)=kftmp(ntmp)
60608  ntmp=ntmp-1
60609  GOTO 250
60610  ENDIF
60611  240 CONTINUE
60612  250 CONTINUE
60613  IF(ntmp.EQ.0.AND.mode.LE.6) mdme(idc,1)=mode-5
60614  IF(ntmp.EQ.0.AND.nfin.EQ.ncmp.AND.mode.GE.7)
60615  & mdme(idc,1)=mode-7
60616  260 CONTINUE
60617  RETURN
60618 
60619 C...Error exit for impossible read of particle code.
60620  300 CALL pyerrm(18,'(PYONOF:) could not interpret particle code '
60621  &//chcode)
60622 
60623 C...Formats for output.
60624  1000 FORMAT(' Decays for',i8,' set ',a10)
60625  1100 FORMAT(' Decays for',i8,' set ',a10,' if match',10i8)
60626 
60627  RETURN
60628  END
60629 C*********************************************************************
60630 
60631 C...PYTUNE
60632 C...Presets for a few specific underlying-event and min-bias tunes
60633 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60634 C...others require particular versions of pythia (e.g. the SCI and GAL
60635 C...models). See below for details.
60636  SUBROUTINE pytune(ITUNE)
60637 C
60638 C ITUNE NAME (detailed descriptions below)
60639 C 0 Default : No settings changed => defaults.
60640 C
60641 C ====== Old UE, Q2-ordered showers ====================================
60642 C 100 A : Rick Field's CDF Tune A (Oct 2002)
60643 C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60644 C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60645 C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60646 C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60647 C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60648 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60649 C 107 ACR : Tune A modified with new CR model (Mar 2007)
60650 C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60651 C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60652 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60653 C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60654 C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60655 C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60656 C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60657 C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60658 C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60659 C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60660 C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60661 C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60662 C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60663 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60664 C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60665 C
60666 C ====== Intermediate and Hybrid Models ================================
60667 C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60668 C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60669 C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60670 C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60671 C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60672 C
60673 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60674 C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60675 C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60676 C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60677 C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60678 C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60679 C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60680 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60681 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60682 C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60683 C 311 S1-Pro : S1 -"- (Oct 2008)
60684 C 312 S2-Pro : S2 -"- (Oct 2008)
60685 C 313 S0A-Pro : S0A -"- (Oct 2008)
60686 C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60687 C 315 Old-Pro : Old -"- (Oct 2008)
60688 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60689 C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60690 C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60691 C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60692 C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60693 C balance & different scaling to LHC & RHIC (Feb 2009)
60694 C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60695 C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60696 C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60697 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60698 C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60699 C
60700 C ======= The Uppsala models ===========================================
60701 C ( NB! must be run with special modified Pythia 6.215 version )
60702 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60703 C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60704 C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60705 C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60706 C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60707 C
60708 C More details;
60709 C
60710 C Quick Dictionary:
60711 C BE : Bose-Einstein
60712 C BR : Beam Remnants
60713 C CR : Colour Reconnections
60714 C HAD: Hadronization
60715 C ISR/FSR: Initial-State Radiation / Final-State Radiation
60716 C FSI: Final-State Interactions (=CR+BE)
60717 C MB : Minimum-bias
60718 C MI : Multiple Interactions
60719 C UE : Underlying Event
60720 C
60721 C=======================================================================
60722 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60723 C=======================================================================
60724 C
60725 C A (100) and AW (101). CTEQ5L parton distributions
60726 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60727 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60728 C...Key feature: extensively compared to CDF data (R.D. Field).
60729 C...* Large starting scale for ISR (PARP(67)=4)
60730 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60731 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60732 C
60733 C BW (102). CTEQ5L parton distributions
60734 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60735 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60736 C...Key feature: extensively compared to CDF data (R.D. Field).
60737 C...NB: Can also be run with Pythia 6.2 or 6.312+
60738 C...* Small starting scale for ISR (PARP(67)=1)
60739 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60740 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60741 C
60742 C DW (103) and DWT (104). CTEQ5L parton distributions
60743 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60744 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60745 C...Key feature: extensively compared to CDF data (R.D. Field).
60746 C...NB: Can also be run with Pythia 6.2 or 6.312+
60747 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60748 C...* DWT has a different reference energy, the same as the "S" models
60749 C... below, leading to more UE activity at the LHC, but less at RHIC.
60750 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60751 C
60752 C QW (105). CTEQ61 parton distributions
60753 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60754 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60755 C...Key feature: uses CTEQ61 (external pdf library must be linked)
60756 C
60757 C ATLAS-DC2 (106). CTEQ5L parton distributions
60758 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60759 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60760 C...Key feature: tune used by the ATLAS collaboration.
60761 C
60762 C ACR (107). CTEQ5L parton distributions
60763 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60764 C...Key feature: Tune A modified to use annealing CR.
60765 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60766 C
60767 C D6 (108) and D6T (109). CTEQ6L parton distributions
60768 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60769 C
60770 C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60771 C Old UE model, Q2-ordered showers.
60772 C...Key feature: Rick Field's family of tunes revamped with the
60773 C...Professor Q2-ordered final-state shower and fragmentation tunes
60774 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60775 C...Key feature: improved descriptions of LEP data.
60776 C
60777 C Pro-Q20 (129). CTEQ5L parton distributions
60778 C Old UE model, Q2-ordered showers.
60779 C...Key feature: Complete retune of old model by Professor, including
60780 C...large amounts of both LEP and Tevatron data.
60781 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60782 C...extreme in this tune, corresponding to using mu_R = pT/3 .
60783 C
60784 C=======================================================================
60785 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60786 C=======================================================================
60787 C
60788 C IM1 (200). Intermediate model, Q2-ordered showers,
60789 C CTEQ5L parton distributions
60790 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60791 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60792 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60793 C
60794 C APT (201). Old UE model, pT-ordered final-state showers,
60795 C CTEQ5L parton distributions
60796 C...Key feature: Rick Field's Tune A, but with new final-state showers
60797 C
60798 C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60799 C CTEQ5L parton distributions
60800 C...Key feature: APT revamped with the Professor pT-ordered final-state
60801 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60802 C...Perugia MPI workshop in October 2008.
60803 C
60804 C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60805 C CTEQ5L parton distributions
60806 C...Key feature: APT-Pro with final-state showers off the MPI,
60807 C...lower ISR renormalization scale to improve agreement with the
60808 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60809 C...to min-bias at 630 GeV.
60810 C
60811 C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60812 C CTEQ6L1 parton distributions.
60813 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60814 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60815 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60816 C
60817 C=======================================================================
60818 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60819 C=======================================================================
60820 C
60821 C S0 (300) and S0A (303). CTEQ5L parton distributions
60822 C...Key feature: large amount of multiple interactions
60823 C...* Somewhat faster than the other colour annealing scenarios.
60824 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60825 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60826 C...* Small amount of radiation.
60827 C...* Large amount of low-pT MI
60828 C...* Low degree of proton lumpiness (broad matter dist.)
60829 C...* CR Type S (driven by free triplets), of medium strength.
60830 C...* See: Pythia6402 update notes or later.
60831 C
60832 C S1 (301). CTEQ5L parton distributions
60833 C...Key feature: large amount of radiation.
60834 C...* Large amount of low-pT perturbative ISR
60835 C...* Large amount of FSR off ISR partons
60836 C...* Small amount of low-pT multiple interactions
60837 C...* Moderate degree of proton lumpiness
60838 C...* Least aggressive CR type (S+S Type I), but with large strength
60839 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60840 C
60841 C S2 (302). CTEQ5L parton distributions
60842 C...Key feature: very lumpy proton + gg string cluster formation allowed
60843 C...* Small amount of radiation
60844 C...* Moderate amount of low-pT MI
60845 C...* High degree of proton lumpiness (more spiky matter distribution)
60846 C...* Most aggressive CR type (S+S Type II), but with small strength
60847 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60848 C
60849 C NOCR (304). CTEQ5L parton distributions
60850 C...Key feature: no colour reconnections (NB: "Best fit" only).
60851 C...* NB: <pT>(Nch) problematic in this tune.
60852 C...* Small amount of radiation
60853 C...* Small amount of low-pT MI
60854 C...* Low degree of proton lumpiness
60855 C...* Large BR composite x enhancement factor
60856 C...* Most clever colour flow without CR ("Lambda ordering")
60857 C
60858 C ATLAS-CSC (306). CTEQ6L parton distributions
60859 C...Key feature: 11-parameter ATLAS tune of the new framework.
60860 C...* Old (pre-annealing) colour reconnections a la 305.
60861 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60862 C
60863 C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60864 C...Key feature: the S0 family of tunes revamped with the Professor
60865 C...pT-ordered final-state shower and fragmentation tunes presented by
60866 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60867 C...Key feature: improved descriptions of LEP data.
60868 C
60869 C Perugia-0 (320). CTEQ5L parton distributions.
60870 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60871 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60872 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60873 C...beam-remnant breakup (more baryon number transport), and suppression
60874 C...of CR in high-pT string pieces.
60875 C
60876 C Perugia-HARD (321). CTEQ5L parton distributions.
60877 C...Key feature: More ISR, More FSR, Less MPI, Less BR
60878 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60879 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60880 C...baryon number transport), and more fragmentation pT.
60881 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60882 C...DY pT spectrum is HARD.
60883 C
60884 C Perugia-SOFT (322). CTEQ5L parton distributions.
60885 C...Key feature: Less ISR, Less FSR, More MPI, More BR
60886 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60887 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
60888 C...number transport), and less fragmentation pT.
60889 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
60890 C...DY pT spectrum is SOFT
60891 C
60892 C Perugia-3 (323). CTEQ5L parton distributions.
60893 C...Key feature: variant of Perugia-0 with more extreme energy scaling
60894 C...properties while still agreeing with Tevatron data from 630 to 1960.
60895 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
60896 C...allows FSR off the active end of dipoles stretched to the remnant.
60897 C
60898 C Perugia-NOCR (324). CTEQ5L parton distributions.
60899 C...Key feature: Retune of NOCR-Pro with better scaling properties to
60900 C...lower energies and somewhat better agreement with Tevatron data
60901 C...at 1800/1960.
60902 C
60903 C Perugia-* (325). MRST LO* parton distributions for generators
60904 C...Key feature: first attempt at using the LO* distributions
60905 C...(external pdf library must be linked).
60906 C
60907 C Perugia-6 (326). CTEQ6L1 parton distributions
60908 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
60909 C
60910 C Pro-pT0 (329). CTEQ5L parton distributions
60911 C...Key feature: Complete retune of new model by Professor, including
60912 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
60913 C
60914 C=======================================================================
60915 C OTHER TUNES
60916 C=======================================================================
60917 C
60918 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
60919 C...with an unmodified Pythia distribution.
60920 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
60921 C
60922 C ::: + Future improvements?
60923 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
60924 C (problem: K-factor affects everything so only works as
60925 C intended for min-bias, not for UE ... probably need a
60926 C better long-term solution to handle UE as well. Anyway,
60927 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
60928 
60929 C...Global statements
60930  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60931  INTEGER PYK,PYCHGE,PYCOMP
60932 
60933 C...Commonblocks.
60934  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60935  common/pypars/mstp(200),parp(200),msti(200),pari(200)
60936 
60937 C...SCI and GAL Commonblocks
60938  COMMON /scipar/mswi(2),parsci(2)
60939 
60940 C...SAVE statements
60941  SAVE /pydat1/,/pypars/
60942  SAVE /scipar/
60943 
60944 C...Internal parameters
60945  parameter(mxtuns=500)
60946  CHARACTER*8 CHVERS, CHDOC
60947  PARAMETER (CHVERS='1.015 ',chdoc='Jan 2009')
60948  CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
60949  CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
60950  & chparj(1:100), ch40
60951  CHARACTER*60 CH60
60952  CHARACTER*70 CH70
60953  DATA (chnams(i),i=0,1)/'Default',' '/
60954  DATA (chnams(i),i=100,119)/
60955  & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
60956  & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
60957  1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
60958  1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
60959  1 'Tune D6-Pro','Tune D6T-Pro'/
60960  DATA (chnams(i),i=120,129)/
60961  & 9*' ','Pro-Q20'/
60962  DATA (chnams(i),i=300,309)/
60963  & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
60964  5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
60965  DATA (chnams(i),i=310,315)/
60966  & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
60967  & 'NOCR-Pro','Old-Pro'/
60968  DATA (chnams(i),i=320,329)/
60969  & 'Perugia 0','Perugia HARD','Perugia SOFT',
60970  & 'Perugia 3','Perugia NOCR','Perugia LO*',
60971  & 'Perugia 6',2*' ','Pro-pT0'/
60972  DATA (chnams(i),i=200,229)/
60973  & 'IM Tune 1','Tune APT',8*' ',
60974  & ' ','Tune APT-Pro',8*' ',
60975  & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
60976  DATA (chnams(i),i=400,409)/
60977  & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
60978  DATA (chmstj(i),i=11,20)/
60979  & 'HAD choice of fragmentation function(s)',4*' ',
60980  & 'HAD treatment of small-mass systems',4*' '/
60981  DATA (chmstj(i),i=41,50)/
60982  & 'FSR type (Q2 or pT) for old framework',9*' '/
60983  DATA (chmstp(i),i=51,100)/
60984  5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
60985  6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
60986  6 'ISR coherence option for 1st emission',
60987  6 'ISR phase space choice & ME corrections',' ',
60988  7 'ISR IR regularization scheme',' ',
60989  7 'ISR scheme for FSR off ISR',8*' ',
60990  8 'UE model',
60991  8 'UE hadron transverse mass distribution',5*' ',
60992  8 'BR composite scheme','BR colour scheme',
60993  9 'BR primordial kT compensation',
60994  9 'BR primordial kT distribution',
60995  9 'BR energy partitioning scheme',2*' ',
60996  9 'FSI colour (re-)connection model',5*' '/
60997  DATA (chparp(i),i=61,100)/
60998  6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
60999  6 2*' ','ISR Q2max factor',3*' ',
61000  7 'FSR Q2max factor for non-s-channel procs',5*' ',
61001  7 'FSI colour reco high-pT dampening strength',
61002  7 'FSI colour reconnection strength',
61003  7 'BR composite x enhancement','BR breakup suppression',
61004  8 2*'UE IR cutoff at reference ecm',
61005  8 2*'UE mass distribution parameter',
61006  8 'UE gg colour correlated fraction','UE total gg fraction',
61007  8 2*' ',
61008  8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61009  9 'BR primordial kT width <|kT|>',' ',
61010  9 'BR primordial kT UV cutoff',7*' '/
61011  DATA (chparj(i),i=1,30)/
61012  & 'HAD diquark suppression','HAD strangeness suppression',
61013  & 'HAD strange diquark suppression',
61014  & 'HAD vector diquark suppression',6*' ',
61015  1 'HAD P(vector meson), u and d only',
61016  1 'HAD P(vector meson), contains s',
61017  1 'HAD P(vector meson), heavy quarks',7*' ',
61018  2 'HAD fragmentation pT',' ',' ',' ',
61019  2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61020  DATA (chparj(i),i=41,90)/
61021  4 'HAD string parameter a','HAD string parameter b',3*' ',
61022  4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61023  4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61024  5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61025  6 10*' ',10*' ',
61026  8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61027 
61028 C...1) Shorthand notation
61029  m13=mstu(13)
61030  m11=mstu(11)
61031  IF (itune.LE.mxtuns.AND.itune.GE.0) THEN
61032  chname=chnams(itune)
61033  IF (itune.EQ.0) GOTO 9999
61034  ELSE
61035  CALL pyerrm(9,'(PYTUNE:) Tune number > max. Using defaults.')
61036  GOTO 9999
61037  ENDIF
61038 
61039 C...2) Hello World
61040  IF (m13.GE.1) WRITE(m11,5000) chvers, chdoc
61041 
61042 C...3) Tune parameters
61043 
61044 C=======================================================================
61045 C...S0, S1, S2, S0A, NOCR, Rap,
61046 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61047 C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61048 C...Pro-pT0
61049  IF ((itune.GE.300.AND.itune.LE.305)
61050  & .OR.(itune.GE.310.AND.itune.LE.315)
61051  & .OR.(itune.GE.320.AND.itune.LE.326).OR.itune.EQ.329) THEN
61052  IF (m13.GE.1) WRITE(m11,5010) itune, chname
61053  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
61054  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61055  & ' with tune.')
61056  ELSEIF(itune.GE.320.AND.itune.LE.326.AND.itune.NE.324.AND.
61057  & (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.419)))
61058  & THEN
61059  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61060  & ' with tune.')
61061  ENDIF
61062 
61063 C...Use Professor's LEP pars if ITUNE >= 310
61064 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61065  IF (itune.LT.310) THEN
61066 C...# Old default flavour parameters
61067 
61068  ELSEIF (itune.GE.310) THEN
61069 C...# Tuned flavour parameters:
61070  parj(1) = 0.073
61071  parj(2) = 0.2
61072  parj(3) = 0.94
61073  parj(4) = 0.032
61074  parj(11) = 0.31
61075  parj(12) = 0.4
61076  parj(13) = 0.54
61077  parj(25) = 0.63
61078  parj(26) = 0.12
61079 C...# Always use pT-ordered shower:
61080  mstj(41) = 12
61081 C...# Switch on Bowler:
61082  mstj(11) = 5
61083 C...# Fragmentation
61084  parj(21) = 0.313
61085  parj(41) = 0.49
61086  parj(42) = 1.2
61087  parj(47) = 1.0
61088  parj(81) = 0.257
61089  parj(82) = 0.8
61090  ENDIF
61091 
61092 C...Remove middle digit now for Professor variants, since identical pars
61093  ituneb=itune
61094  IF (itune.GE.310.AND.itune.LE.319) THEN
61095  ituneb=(itune/100)*100+mod(itune,10)
61096  ENDIF
61097 
61098 C...PDFs: all use CTEQ5L as starting point
61099  mstp(52)=1
61100  mstp(51)=7
61101  IF (itune.EQ.325) THEN
61102 C...MRST LO* for 325
61103  mstp(52)=2
61104  mstp(51)=20650
61105  ELSEIF (itune.EQ.326) THEN
61106 C...CTEQ6L1 for 326
61107  mstp(52)=2
61108  mstp(51)=10042
61109  ENDIF
61110 
61111 C...ISR: use Lambda_MSbar with default scale for S0(A)
61112  mstp(64)=2
61113  parp(64)=1d0
61114  IF (itune.EQ.320.OR.itune.EQ.323.OR.itune.EQ.324.OR.
61115  & itune.EQ.326) THEN
61116 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61117  mstp(64)=3
61118  parp(64)=1d0
61119  ELSEIF (itune.EQ.321) THEN
61120 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61121  mstp(64)=3
61122  parp(64)=0.25d0
61123  ELSEIF (itune.EQ.322) THEN
61124 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61125  mstp(64)=2
61126  parp(64)=2d0
61127  ELSEIF (itune.EQ.325) THEN
61128 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61129  mstp(64)=3
61130  parp(64)=2d0
61131  ELSEIF (itune.EQ.329) THEN
61132 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61133  mstp(64)=2
61134  parp(64)=1.3d0
61135  ENDIF
61136 
61137 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61138  mstp(67)=2
61139  parp(67)=4d0
61140 C...Perugia tunes have stronger suppression, except HARD
61141  IF (itune.GE.320.AND.itune.LE.326) THEN
61142  parp(67)=1d0
61143  IF (itune.EQ.321) parp(67)=4d0
61144  IF (itune.EQ.322) parp(67)=0.5d0
61145  ENDIF
61146 
61147 C...ISR IR cutoff type and FSR off ISR setting:
61148 C...Smooth ISR, low FSR-off-ISR
61149  mstp(70)=2
61150  mstp(72)=0
61151  IF (ituneb.EQ.301) THEN
61152 C...S1, S1-Pro: sharp ISR, high FSR
61153  mstp(70)=0
61154  mstp(72)=1
61155  ELSEIF (itune.EQ.320.OR.itune.EQ.324.OR.itune.EQ.326
61156  & .OR.itune.EQ.325) THEN
61157 C...Perugia default is smooth ISR, high FSR-off-ISR
61158  mstp(70)=2
61159  mstp(72)=1
61160  ELSEIF (itune.EQ.321) THEN
61161 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61162  mstp(70)=0
61163  parp(62)=1.25d0
61164  mstp(72)=1
61165  ELSEIF (itune.EQ.322) THEN
61166 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61167  mstp(70)=1
61168  parp(81)=1.5d0
61169  mstp(72)=0
61170  ELSEIF (itune.EQ.323) THEN
61171 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61172  mstp(70)=0
61173  parp(62)=1.25d0
61174  mstp(72)=2
61175  ENDIF
61176 
61177 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61178 C...by Professor tunes (with HARD and SOFT variations)
61179  parp(71)=4d0
61180  IF (itune.GE.320.AND.itune.LE.326) THEN
61181  parp(71)=2d0
61182  IF (itune.EQ.321) parp(71)=4d0
61183  IF (itune.EQ.322) parp(71)=1d0
61184  ENDIF
61185 
61186 C...FSR: Lambda_FSR scale (only if not using professor)
61187  IF (itune.LT.310) parj(81)=0.23d0
61188  IF (itune.EQ.321) parj(81)=0.30d0
61189  IF (itune.EQ.322) parj(81)=0.20d0
61190 
61191 C...UE on, new model
61192  mstp(81)=21
61193 
61194 C...UE: hadron-hadron overlap profile (expOfPow for all)
61195  mstp(82)=5
61196 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61197  parp(83)=1.6d0
61198  IF (ituneb.EQ.301) parp(83)=1.4d0
61199  IF (ituneb.EQ.302) parp(83)=1.2d0
61200 C...NOCR variants have very smooth distributions
61201  IF (ituneb.EQ.304) parp(83)=1.8d0
61202  IF (ituneb.EQ.305) parp(83)=2.0d0
61203  IF (itune.GE.320.AND.itune.LE.326) THEN
61204 C...Perugia variants have slightly smoother profiles by default
61205 C...(to compensate for more tail by added radiation)
61206 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61207  parp(83)=1.7d0
61208  IF (itune.EQ.322) parp(83)=1.5d0
61209  IF (itune.EQ.324) parp(83)=1.8d0
61210  ENDIF
61211 C...Professor-pT0 also has very smooth distribution
61212  IF (itune.EQ.329) parp(83)=1.8
61213 
61214 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61215  parp(82)=1.85d0
61216  IF (ituneb.EQ.301) parp(82)=2.1d0
61217  IF (ituneb.EQ.302) parp(82)=1.9d0
61218  IF (ituneb.EQ.304) parp(82)=2.05d0
61219  IF (ituneb.EQ.305) parp(82)=1.9d0
61220  IF (itune.GE.320.AND.itune.LE.326) THEN
61221 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61222 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61223 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61224 C...slightly higher, due to increased activity.
61225  parp(82)=2.0d0
61226  IF (itune.EQ.321) parp(82)=2.3d0
61227  IF (itune.EQ.322) parp(82)=1.9d0
61228  IF (itune.EQ.323) parp(82)=2.2d0
61229  IF (itune.EQ.324) parp(82)=1.95d0
61230  IF (itune.EQ.325) parp(82)=2.2d0
61231  IF (itune.EQ.326) parp(82)=1.95d0
61232  ENDIF
61233 C...Professor-pT0 maintains low pT0 vaue
61234  IF (itune.EQ.329) parp(82)=1.85d0
61235 
61236 C...UE: IR cutoff reference energy and default energy scaling pace
61237  parp(89)=1800d0
61238  parp(90)=0.16d0
61239 C...S0A, S0A-Pro have tune A energy scaling
61240  IF (ituneb.EQ.303) parp(90)=0.25d0
61241  IF (itune.GE.320.AND.itune.LE.326) THEN
61242 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61243  parp(90)=0.26
61244  IF (itune.EQ.321) parp(90)=0.30d0
61245  IF (itune.EQ.322) parp(90)=0.24d0
61246  IF (itune.EQ.323) parp(90)=0.32d0
61247  IF (itune.EQ.324) parp(90)=0.24d0
61248 C...LO* and CTEQ6L1 tunes have slower energy scaling
61249  IF (itune.EQ.325) parp(90)=0.23d0
61250  IF (itune.EQ.326) parp(90)=0.22d0
61251  ENDIF
61252 C...Professor-pT0 has intermediate scaling
61253  IF (itune.EQ.329) parp(90)=0.22d0
61254 
61255 C...BR: MPI initiator color connections rap-ordered by default
61256 C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61257  mstp(89)=1
61258  IF (ituneb.EQ.304.OR.itune.EQ.324) mstp(89)=2
61259  IF (itune.EQ.322) mstp(89)=0
61260 
61261 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61262  parp(80)=0.01d0
61263  IF (itune.GE.320.AND.itune.LE.326) THEN
61264 C...Perugia tunes have more beam blowup by default
61265  parp(80)=0.05d0
61266  IF (itune.EQ.321) parp(80)=0.01
61267  IF (itune.EQ.323) parp(80)=0.03
61268  IF (itune.EQ.324) parp(80)=0.01
61269  ENDIF
61270 
61271 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61272  mstp(88)=0
61273  parp(79)=2d0
61274  IF (ituneb.EQ.304) parp(79)=3d0
61275  IF (itune.EQ.329) parp(79)=1.18
61276 
61277 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61278  mstp(91)=1
61279  parp(91)=2d0
61280  parp(93)=10d0
61281 C...Perugia-HARD only uses 1.0 GeV
61282  IF (itune.EQ.321) parp(91)=1.0d0
61283 C...Perugia-3 only uses 1.5 GeV
61284  IF (itune.EQ.323) parp(91)=1.5d0
61285 C...Professor-pT0 uses 7-GeV cutoff
61286  IF (itune.EQ.329) parp(93)=7.0
61287 
61288 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61289  mstp(95)=6
61290 C...S1, S1-Pro: use S1
61291  IF (ituneb.EQ.301) mstp(95)=2
61292 C...S2, S2-Pro: use S2
61293  IF (ituneb.EQ.302) mstp(95)=4
61294 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61295  IF (itune.EQ.304.OR.itune.EQ.314.OR.itune.EQ.324) mstp(95)=0
61296 C..."Old" and "Old"-Pro: use old CR
61297  IF (ituneb.EQ.305) mstp(95)=1
61298 
61299 C...FSI: CR strength and high-pT dampening, default is S0
61300  IF (itune.LT.320.OR.itune.EQ.329) THEN
61301  parp(78)=0.2d0
61302  parp(77)=0d0
61303  IF (ituneb.EQ.301) parp(78)=0.35d0
61304  IF (ituneb.EQ.302) parp(78)=0.15d0
61305  IF (ituneb.EQ.304) parp(78)=0.0d0
61306  IF (ituneb.EQ.305) parp(78)=1.0d0
61307  IF (itune.EQ.329) parp(78)=0.17d0
61308  ELSE
61309 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61310  parp(78)=0.33
61311  parp(77)=0.9d0
61312  IF (itune.EQ.321) THEN
61313 C...HARD has HIGH amount of CR
61314  parp(78)=0.37d0
61315  parp(77)=0.4d0
61316  ELSEIF (itune.EQ.322) THEN
61317 C...SOFT has LOW amount of CR
61318  parp(78)=0.15d0
61319  parp(77)=0.5d0
61320  ELSEIF (itune.EQ.323) THEN
61321 C...Scaling variant appears to need slightly more than default
61322  parp(78)=0.35d0
61323  parp(77)=0.6d0
61324  ELSEIF (itune.EQ.324) THEN
61325 C...NOCR has no CR
61326  parp(78)=0d0
61327  parp(77)=0d0
61328  ENDIF
61329  ENDIF
61330 
61331 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61332  IF (itune.EQ.321) parj(21)=0.34d0
61333  IF (itune.EQ.322) parj(21)=0.28d0
61334 
61335 C...Switch off trial joinings
61336  mstp(96)=0
61337 
61338 C...S0 (300), S0A (303)
61339  IF (ituneb.EQ.300.OR.ituneb.EQ.303) THEN
61340  IF (m13.GE.1) THEN
61341  ch60='see P. Skands & D. Wicke, hep-ph/0703081'
61342  WRITE(m11,5030) ch60
61343  ch60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61344  WRITE(m11,5030) ch60
61345  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61346  WRITE(m11,5030) ch60
61347  IF (itune.GE.310) THEN
61348  ch60='LEP parameters tuned by Professor'
61349  WRITE(m11,5030) ch60
61350  ENDIF
61351  ENDIF
61352 
61353 C...S1 (301)
61354  ELSEIF(ituneb.EQ.301) THEN
61355  IF (m13.GE.1) THEN
61356  ch60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61357  WRITE(m11,5030) ch60
61358  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61359  WRITE(m11,5030) ch60
61360  IF (itune.GE.310) THEN
61361  ch60='LEP parameters tuned with Professor'
61362  WRITE(m11,5030) ch60
61363  ENDIF
61364  ENDIF
61365 
61366 C...S2 (302)
61367  ELSEIF(ituneb.EQ.302) THEN
61368  IF (m13.GE.1) THEN
61369  ch60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61370  WRITE(m11,5030) ch60
61371  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61372  WRITE(m11,5030) ch60
61373  IF (itune.GE.310) THEN
61374  ch60='LEP parameters tuned by Professor'
61375  WRITE(m11,5030) ch60
61376  ENDIF
61377  ENDIF
61378 
61379 C...NOCR (304)
61380  ELSEIF(ituneb.EQ.304) THEN
61381  IF (m13.GE.1) THEN
61382  ch60='"best try" without colour reconnections'
61383  WRITE(m11,5030) ch60
61384  ch60='see P. Skands & D. Wicke, hep-ph/0703081'
61385  WRITE(m11,5030) ch60
61386  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61387  WRITE(m11,5030) ch60
61388  IF (itune.GE.310) THEN
61389  ch60='LEP parameters tuned by Professor'
61390  WRITE(m11,5030) ch60
61391  ENDIF
61392  ENDIF
61393 
61394 C..."Lo FSR" retune (305)
61395  ELSEIF(ituneb.EQ.305) THEN
61396  IF (m13.GE.1) THEN
61397  ch60='"Lo FSR retune" with primitive colour reconnections'
61398  WRITE(m11,5030) ch60
61399  ch60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61400  WRITE(m11,5030) ch60
61401  IF (itune.GE.310) THEN
61402  ch60='LEP parameters tuned by Professor'
61403  WRITE(m11,5030) ch60
61404  ENDIF
61405  ENDIF
61406 
61407 C...Perugia Tunes (320-326)
61408  ELSEIF(itune.GE.320.AND.itune.LE.326) THEN
61409  IF (m13.GE.1) THEN
61410  ch60='P. Skands, Perugia MPI workshop October 2008'
61411  WRITE(m11,5030) ch60
61412  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61413  WRITE(m11,5030) ch60
61414  ch60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61415  WRITE(m11,5030) ch60
61416  ch60='LEP parameters tuned by Professor'
61417  WRITE(m11,5030) ch60
61418  IF (itune.EQ.325) THEN
61419  ch70='NB! This tune requires MRST LO* pdfs to be '//
61420  & 'externally linked'
61421  WRITE(m11,5035) ch70
61422  ELSEIF (itune.EQ.326) THEN
61423  ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
61424  & 'externally linked'
61425  WRITE(m11,5035) ch70
61426  ELSEIF (itune.EQ.321) THEN
61427  ch60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61428  WRITE(m11,5030) ch60
61429  ELSEIF (itune.EQ.322) THEN
61430  ch60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61431  WRITE(m11,5030) ch60
61432  ENDIF
61433  ENDIF
61434 
61435 C...Professor-pT0 (329)
61436  ELSEIF(itune.EQ.329) THEN
61437  IF (m13.GE.1) THEN
61438  ch60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61439  WRITE(m11,5030) ch60
61440  ch60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61441  WRITE(m11,5030) ch60
61442  ch60='LEP/Tevatron parameters tuned by Professor'
61443  WRITE(m11,5030) ch60
61444  ENDIF
61445 
61446  ENDIF
61447 
61448 C...Output
61449  IF (m13.GE.1) THEN
61450  WRITE(m11,5030) ' '
61451  WRITE(m11,5040) 51, mstp(51), chmstp(51)
61452  WRITE(m11,5040) 52, mstp(52), chmstp(52)
61453  IF (mstp(70).EQ.0) THEN
61454  WRITE(m11,5050) 62, parp(62), chparp(62)
61455  ELSEIF (mstp(70).EQ.1) THEN
61456  WRITE(m11,5050) 81, parp(81), chparp(62)
61457  ch60='(Note: PARP(81) replaces PARP(62).)'
61458  WRITE(m11,5030) ch60
61459  ENDIF
61460  WRITE(m11,5040) 64, mstp(64), chmstp(64)
61461  WRITE(m11,5050) 64, parp(64), chparp(64)
61462  WRITE(m11,5040) 67, mstp(67), chmstp(67)
61463  WRITE(m11,5050) 67, parp(67), chparp(67)
61464  WRITE(m11,5040) 68, mstp(68), chmstp(68)
61465  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61466  WRITE(m11,5030) ch60
61467  WRITE(m11,5040) 70, mstp(70), chmstp(70)
61468  WRITE(m11,5040) 72, mstp(72), chmstp(72)
61469  WRITE(m11,5050) 71, parp(71), chparp(71)
61470  WRITE(m11,5060) 81, parj(81), chparj(81)
61471  WRITE(m11,5060) 82, parj(82), chparj(82)
61472  WRITE(m11,5040) 81, mstp(81), chmstp(81)
61473  WRITE(m11,5050) 82, parp(82), chparp(82)
61474  IF (mstp(70).EQ.2) THEN
61475  ch60='(Note: PARP(82) replaces PARP(62).)'
61476  WRITE(m11,5030) ch60
61477  ENDIF
61478  WRITE(m11,5050) 89, parp(89), chparp(89)
61479  WRITE(m11,5050) 90, parp(90), chparp(90)
61480  WRITE(m11,5040) 82, mstp(82), chmstp(82)
61481  WRITE(m11,5050) 83, parp(83), chparp(83)
61482  WRITE(m11,5040) 88, mstp(88), chmstp(88)
61483  WRITE(m11,5040) 89, mstp(89), chmstp(89)
61484  WRITE(m11,5050) 79, parp(79), chparp(79)
61485  WRITE(m11,5050) 80, parp(80), chparp(80)
61486  WRITE(m11,5040) 91, mstp(91), chmstp(91)
61487  WRITE(m11,5050) 91, parp(91), chparp(91)
61488  WRITE(m11,5050) 93, parp(93), chparp(93)
61489  WRITE(m11,5040) 95, mstp(95), chmstp(95)
61490  IF (mstp(95).GE.1) THEN
61491  WRITE(m11,5050) 78, parp(78), chparp(78)
61492  IF (mstp(95).GE.2) WRITE(m11,5050) 77, parp(77), chparp(77)
61493  ENDIF
61494  WRITE(m11,5070) 11, mstj(11), chmstj(11)
61495  WRITE(m11,5060) 21, parj(21), chparj(21)
61496  WRITE(m11,5060) 41, parj(41), chparj(41)
61497  WRITE(m11,5060) 42, parj(42), chparj(42)
61498  IF (mstj(11).LE.3) THEN
61499  WRITE(m11,5060) 54, parj(54), chparj(54)
61500  WRITE(m11,5060) 55, parj(55), chparj(55)
61501  ELSE
61502  WRITE(m11,5060) 46, parj(46), chparj(46)
61503  ENDIF
61504  IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
61505  ENDIF
61506 
61507 C=======================================================================
61508 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61509  ELSEIF (itune.EQ.306) THEN
61510  IF (m13.GE.1) WRITE(m11,5010) itune, chname
61511  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
61512  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61513  & ' with tune.')
61514  ENDIF
61515 
61516 C...PDFs
61517  mstp(52)=2
61518  mstp(54)=2
61519  mstp(51)=10042
61520  mstp(53)=10042
61521 C...ISR
61522 C PARP(64)=1D0
61523 C...UE on, new model.
61524  mstp(81)=21
61525 C...Energy scaling
61526  parp(89)=1800d0
61527  parp(90)=0.22d0
61528 C...Switch off trial joinings
61529  mstp(96)=0
61530 C...Primordial kT cutoff
61531 
61532  IF (m13.GE.1) THEN
61533  ch60='see presentations by A. Moraes (ATLAS),'
61534  WRITE(m11,5030) ch60
61535  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61536  WRITE(m11,5030) ch60
61537  WRITE(m11,5030) ' '
61538  ch70='NB! This tune requires CTEQ6.1 pdfs to be '//
61539  & 'externally linked'
61540  WRITE(m11,5035) ch70
61541  ENDIF
61542 C...Smooth ISR, low FSR
61543  mstp(70)=2
61544  mstp(72)=0
61545 C...pT0
61546  parp(82)=1.9d0
61547 C...Transverse density profile.
61548  mstp(82)=4
61549  parp(83)=0.3d0
61550  parp(84)=0.5d0
61551 C...ISR & FSR in interactions after the first (default)
61552  mstp(84)=1
61553  mstp(85)=1
61554 C...No double-counting (default)
61555  mstp(86)=2
61556 C...Companion quark parent gluon (1-x) power
61557  mstp(87)=4
61558 C...Primordial kT compensation along chaings (default = 0 : uniform)
61559  mstp(90)=1
61560 C...Colour Reconnections
61561  mstp(95)=1
61562  parp(78)=0.2d0
61563 C...Lambda_FSR scale.
61564  parj(81)=0.23d0
61565 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61566  mstp(89)=1
61567  mstp(88)=0
61568 C PARP(79)=2D0
61569  parp(80)=0.01d0
61570 C...Peterson charm frag, and c and b hadr parameters
61571  mstj(11)=3
61572  parj(54)=-0.07
61573  parj(55)=-0.006
61574 C... Output
61575  IF (m13.GE.1) THEN
61576  WRITE(m11,5030) ' '
61577  WRITE(m11,5040) 51, mstp(51), chmstp(51)
61578  WRITE(m11,5040) 52, mstp(52), chmstp(52)
61579  WRITE(m11,5050) 64, parp(64), chparp(64)
61580  WRITE(m11,5040) 68, mstp(68), chmstp(68)
61581  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61582  WRITE(m11,5030) ch60
61583  WRITE(m11,5040) 70, mstp(70), chmstp(70)
61584  WRITE(m11,5040) 72, mstp(72), chmstp(72)
61585  WRITE(m11,5050) 71, parp(71), chparp(71)
61586  WRITE(m11,5060) 81, parj(81), chparj(81)
61587  ch60='(Note: PARJ(81) changed from 0.14! See update notes)'
61588  WRITE(m11,5030) ch60
61589  WRITE(m11,5040) 81, mstp(81), chmstp(81)
61590  WRITE(m11,5050) 82, parp(82), chparp(82)
61591  WRITE(m11,5050) 89, parp(89), chparp(89)
61592  WRITE(m11,5050) 90, parp(90), chparp(90)
61593  WRITE(m11,5040) 82, mstp(82), chmstp(82)
61594  WRITE(m11,5050) 83, parp(83), chparp(83)
61595  WRITE(m11,5050) 84, parp(84), chparp(84)
61596  WRITE(m11,5040) 88, mstp(88), chmstp(88)
61597  WRITE(m11,5040) 89, mstp(89), chmstp(89)
61598  WRITE(m11,5040) 90, mstp(90), chmstp(90)
61599  WRITE(m11,5050) 79, parp(79), chparp(79)
61600  WRITE(m11,5050) 80, parp(80), chparp(80)
61601  WRITE(m11,5050) 93, parp(93), chparp(93)
61602  WRITE(m11,5040) 95, mstp(95), chmstp(95)
61603  WRITE(m11,5050) 78, parp(78), chparp(78)
61604  WRITE(m11,5070) 11, mstj(11), chmstj(11)
61605  WRITE(m11,5060) 21, parj(21), chparj(21)
61606  WRITE(m11,5060) 41, parj(41), chparj(41)
61607  WRITE(m11,5060) 42, parj(42), chparj(42)
61608  IF (mstj(11).LE.3) THEN
61609  WRITE(m11,5060) 54, parj(54), chparj(54)
61610  WRITE(m11,5060) 55, parj(55), chparj(55)
61611  ELSE
61612  WRITE(m11,5060) 46, parj(46), chparj(46)
61613  ENDIF
61614  IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
61615  ENDIF
61616 
61617 C=======================================================================
61618 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61619 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61620 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61621  ELSEIF ((itune.GE.100.AND.itune.LE.106).OR.itune.EQ.108.OR.
61622  & itune.EQ.109.OR.(itune.GE.110.AND.itune.LE.116).OR.
61623  & itune.EQ.118.OR.itune.EQ.119.OR.itune.EQ.129) THEN
61624  IF (m13.GE.1.AND.itune.NE.106.AND.itune.NE.129) THEN
61625  WRITE(m11,5010) itune, chname
61626  ch60='see R.D. Field, in hep-ph/0610012'
61627  WRITE(m11,5030) ch60
61628  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61629  WRITE(m11,5030) ch60
61630  IF (itune.GE.110.AND.itune.LE.119) THEN
61631  ch60='LEP parameters tuned by Professor'
61632  WRITE(m11,5030) ch60
61633  ENDIF
61634  ELSEIF (m13.GE.1.AND.itune.EQ.129) THEN
61635  WRITE(m11,5010) itune, chname
61636  ch60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61637  WRITE(m11,5030) ch60
61638  ch60='LEP/Tevatron parameters tuned by Professor'
61639  WRITE(m11,5030) ch60
61640  ENDIF
61641 
61642 C...Make sure we start from old default fragmentation parameters
61643  parj(81) = 0.29
61644  parj(82) = 1.0
61645 
61646 C...Use Professor's LEP pars if ITUNE >= 110
61647 C...(i.e., for A-Pro, DW-Pro etc)
61648  IF (itune.GE.110) THEN
61649 C...# Tuned flavour parameters:
61650  parj(1) = 0.073
61651  parj(2) = 0.2
61652  parj(3) = 0.94
61653  parj(4) = 0.032
61654  parj(11) = 0.31
61655  parj(12) = 0.4
61656  parj(13) = 0.54
61657  parj(25) = 0.63
61658  parj(26) = 0.12
61659 C...# Switch on Bowler:
61660  mstj(11) = 5
61661 C...# Fragmentation
61662  parj(21) = 0.325
61663  parj(41) = 0.5
61664  parj(42) = 0.6
61665  parj(47) = 0.67
61666  parj(81) = 0.29
61667  parj(82) = 1.65
61668  ENDIF
61669 
61670 C...Remove middle digit now for Professor variants, since identical pars
61671  ituneb=itune
61672  IF (itune.GE.110.AND.itune.LE.119) THEN
61673  ituneb=(itune/100)*100+mod(itune,10)
61674  ENDIF
61675 
61676 C...Multiple interactions on, old framework
61677  mstp(81)=1
61678 C...Fast IR cutoff energy scaling by default
61679  parp(89)=1800d0
61680  parp(90)=0.25d0
61681 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61682  mstp(51)=7
61683  mstp(52)=1
61684  IF (ituneb.EQ.105) THEN
61685  mstp(51)=10150
61686  mstp(52)=2
61687  ELSEIF(ituneb.EQ.108.OR.ituneb.EQ.109) THEN
61688  mstp(52)=2
61689  mstp(54)=2
61690  mstp(51)=10042
61691  mstp(53)=10042
61692  ENDIF
61693 C...Double Gaussian matter distribution.
61694  mstp(82)=4
61695  parp(83)=0.5d0
61696  parp(84)=0.4d0
61697 C...FSR activity.
61698  parp(71)=4d0
61699 C...Fragmentation functions and c and b parameters
61700 C...(only if not using Professor)
61701  IF (itune.LE.109) THEN
61702  mstj(11)=4
61703  parj(54)=-0.05
61704  parj(55)=-0.005
61705  ENDIF
61706 
61707 C...Tune A and AW
61708  IF(ituneb.EQ.100.OR.ituneb.EQ.101) THEN
61709 C...pT0.
61710  parp(82)=2.0d0
61711 c...String drawing almost completely minimizes string length.
61712  parp(85)=0.9d0
61713  parp(86)=0.95d0
61714 C...ISR cutoff, muR scale factor, and phase space size
61715  parp(62)=1d0
61716  parp(64)=1d0
61717  parp(67)=4d0
61718 C...Intrinsic kT, size, and max
61719  mstp(91)=1
61720  parp(91)=1d0
61721  parp(93)=5d0
61722 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61723  IF (ituneb.EQ.101) THEN
61724  parp(62)=1.25d0
61725  parp(64)=0.2d0
61726  parp(91)=2.1d0
61727  parp(92)=15.0d0
61728  ENDIF
61729 
61730 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61731  ELSEIF (ituneb.EQ.102) THEN
61732 C...pT0.
61733  parp(82)=1.9d0
61734 c...String drawing completely minimizes string length.
61735  parp(85)=1.0d0
61736  parp(86)=1.0d0
61737 C...ISR cutoff, muR scale factor, and phase space size
61738  parp(62)=1.25d0
61739  parp(64)=0.2d0
61740  parp(67)=1d0
61741 C...Intrinsic kT, size, and max
61742  mstp(91)=1
61743  parp(91)=2.1d0
61744  parp(93)=15d0
61745 
61746 C...Tune DW
61747  ELSEIF (ituneb.EQ.103) THEN
61748 C...pT0.
61749  parp(82)=1.9d0
61750 c...String drawing completely minimizes string length.
61751  parp(85)=1.0d0
61752  parp(86)=1.0d0
61753 C...ISR cutoff, muR scale factor, and phase space size
61754  parp(62)=1.25d0
61755  parp(64)=0.2d0
61756  parp(67)=2.5d0
61757 C...Intrinsic kT, size, and max
61758  mstp(91)=1
61759  parp(91)=2.1d0
61760  parp(93)=15d0
61761 
61762 C...Tune DWT
61763  ELSEIF (ituneb.EQ.104) THEN
61764 C...pT0.
61765  parp(82)=1.9409d0
61766 C...Run II ref scale and slow scaling
61767  parp(89)=1960d0
61768  parp(90)=0.16d0
61769 c...String drawing completely minimizes string length.
61770  parp(85)=1.0d0
61771  parp(86)=1.0d0
61772 C...ISR cutoff, muR scale factor, and phase space size
61773  parp(62)=1.25d0
61774  parp(64)=0.2d0
61775  parp(67)=2.5d0
61776 C...Intrinsic kT, size, and max
61777  mstp(91)=1
61778  parp(91)=2.1d0
61779  parp(93)=15d0
61780 
61781 C...Tune QW
61782  ELSEIF(ituneb.EQ.105) THEN
61783  IF (m13.GE.1) THEN
61784  WRITE(m11,5030) ' '
61785  ch70='NB! This tune requires CTEQ6.1 pdfs to be '//
61786  & 'externally linked'
61787  WRITE(m11,5035) ch70
61788  ENDIF
61789 C...pT0.
61790  parp(82)=1.1d0
61791 c...String drawing completely minimizes string length.
61792  parp(85)=1.0d0
61793  parp(86)=1.0d0
61794 C...ISR cutoff, muR scale factor, and phase space size
61795  parp(62)=1.25d0
61796  parp(64)=0.2d0
61797  parp(67)=2.5d0
61798 C...Intrinsic kT, size, and max
61799  mstp(91)=1
61800  parp(91)=2.1d0
61801  parp(93)=15d0
61802 
61803 C...Tune D6 and D6T
61804  ELSEIF(ituneb.EQ.108.OR.ituneb.EQ.109) THEN
61805  IF (m13.GE.1) THEN
61806  WRITE(m11,5030) ' '
61807  ch70='NB! This tune requires CTEQ6L pdfs to be '//
61808  & 'externally linked'
61809  WRITE(m11,5035) ch70
61810  ENDIF
61811 C...The "Rick" proton, double gauss with 0.5/0.4
61812  mstp(82)=4
61813  parp(83)=0.5d0
61814  parp(84)=0.4d0
61815 c...String drawing completely minimizes string length.
61816  parp(85)=1.0d0
61817  parp(86)=1.0d0
61818  IF (ituneb.EQ.108) THEN
61819 C...D6: pT0, Run I ref scale, and fast energy scaling
61820  parp(82)=1.8d0
61821  parp(89)=1800d0
61822  parp(90)=0.25d0
61823  ELSE
61824 C...D6T: pT0, Run II ref scale, and slow energy scaling
61825  parp(82)=1.8387d0
61826  parp(89)=1960d0
61827  parp(90)=0.16d0
61828  ENDIF
61829 C...ISR cutoff, muR scale factor, and phase space size
61830  parp(62)=1.25d0
61831  parp(64)=0.2d0
61832  parp(67)=2.5d0
61833 C...Intrinsic kT, size, and max
61834  mstp(91)=1
61835  parp(91)=2.1d0
61836  parp(93)=15d0
61837 
61838 C...Old ATLAS-DC2 5-parameter tune
61839  ELSEIF(ituneb.EQ.106) THEN
61840  IF (m13.GE.1) THEN
61841  WRITE(m11,5010) itune, chname
61842  ch60='see A. Moraes et al., SN-ATLAS-2006-057,'
61843  WRITE(m11,5030) ch60
61844  ch60=' R. Field in hep-ph/0610012,'
61845  WRITE(m11,5030) ch60
61846  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61847  WRITE(m11,5030) ch60
61848  ENDIF
61849 C... pT0.
61850  parp(82)=1.8d0
61851 C... Different ref and rescaling pacee
61852  parp(89)=1000d0
61853  parp(90)=0.16d0
61854 C... Parameters of mass distribution
61855  parp(83)=0.5d0
61856  parp(84)=0.5d0
61857 C... Old default string drawing
61858  parp(85)=0.33d0
61859  parp(86)=0.66d0
61860 C... ISR, phase space equivalent to Tune B
61861  parp(62)=1d0
61862  parp(64)=1d0
61863  parp(67)=1d0
61864 C... FSR
61865  parp(71)=4d0
61866 C... Intrinsic kT
61867  mstp(91)=1
61868  parp(91)=1d0
61869  parp(93)=5d0
61870 
61871 C...Professor's Pro-Q20 Tune
61872  ELSEIF(itune.EQ.129) THEN
61873  IF (m13.GE.1) THEN
61874  ch60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
61875  WRITE(m11,5030) ch60
61876  ENDIF
61877  parp(62)=2.9
61878  parp(64)=0.14
61879  parp(67)=2.65
61880  parp(82)=1.9
61881  parp(83)=0.83
61882  parp(84)=0.6
61883  parp(85)=0.86
61884  parp(86)=0.93
61885  parp(89)=1800d0
61886  parp(90)=0.22
61887  mstp(91)=1
61888  parp(91)=2.1
61889  parp(93)=5.0
61890 
61891  ENDIF
61892 
61893 C... Output
61894  IF (m13.GE.1) THEN
61895  WRITE(m11,5030) ' '
61896  WRITE(m11,5040) 51, mstp(51), chmstp(51)
61897  WRITE(m11,5040) 52, mstp(52), chmstp(52)
61898  WRITE(m11,5050) 62, parp(62), chparp(62)
61899  WRITE(m11,5050) 64, parp(64), chparp(64)
61900  WRITE(m11,5050) 67, parp(67), chparp(67)
61901  WRITE(m11,5040) 68, mstp(68), chmstp(68)
61902  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61903  WRITE(m11,5030) ch60
61904  WRITE(m11,5050) 71, parp(71), chparp(71)
61905  WRITE(m11,5060) 81, parj(81), chparj(81)
61906  WRITE(m11,5060) 82, parj(82), chparj(82)
61907  WRITE(m11,5040) 81, mstp(81), chmstp(81)
61908  WRITE(m11,5050) 82, parp(82), chparp(82)
61909  WRITE(m11,5050) 89, parp(89), chparp(89)
61910  WRITE(m11,5050) 90, parp(90), chparp(90)
61911  WRITE(m11,5040) 82, mstp(82), chmstp(82)
61912  WRITE(m11,5050) 83, parp(83), chparp(83)
61913  WRITE(m11,5050) 84, parp(84), chparp(84)
61914  WRITE(m11,5050) 85, parp(85), chparp(85)
61915  WRITE(m11,5050) 86, parp(86), chparp(86)
61916  WRITE(m11,5040) 91, mstp(91), chmstp(91)
61917  WRITE(m11,5050) 91, parp(91), chparp(91)
61918  WRITE(m11,5050) 93, parp(93), chparp(93)
61919  WRITE(m11,5070) 11, mstj(11), chmstj(11)
61920  WRITE(m11,5060) 21, parj(21), chparj(21)
61921  WRITE(m11,5060) 41, parj(41), chparj(41)
61922  WRITE(m11,5060) 42, parj(42), chparj(42)
61923  IF (mstj(11).LE.3) THEN
61924  WRITE(m11,5060) 54, parj(54), chparj(54)
61925  WRITE(m11,5060) 55, parj(55), chparj(55)
61926  ELSE
61927  WRITE(m11,5060) 46, parj(46), chparj(46)
61928  ENDIF
61929  IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
61930  ENDIF
61931 
61932 C=======================================================================
61933 C... ACR, tune A with new CR (107)
61934  ELSEIF(itune.EQ.107.OR.itune.EQ.117) THEN
61935  IF (m13.GE.1) THEN
61936  WRITE(m11,5010) itune, chname
61937  ch60='Tune A modified with new colour reconnections'
61938  WRITE(m11,5030) ch60
61939  ch60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
61940  WRITE(m11,5030) ch60
61941  ch60='see P. Skands & D. Wicke, hep-ph/0703081,'
61942  WRITE(m11,5030) ch60
61943  ch60=' R. Field, in hep-ph/0610012 (Tune A),'
61944  WRITE(m11,5030) ch60
61945  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61946  WRITE(m11,5030) ch60
61947  IF (itune.EQ.117) THEN
61948  ch60='LEP parameters tuned by Professor'
61949  WRITE(m11,5030) ch60
61950  ENDIF
61951  ENDIF
61952  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.406))THEN
61953  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61954  & ' with tune. Using defaults.')
61955  GOTO 100
61956  ENDIF
61957 
61958 C...Make sure we start from old default fragmentation parameters
61959  parj(81) = 0.29
61960  parj(82) = 1.0
61961 
61962 C...Use Professor's LEP pars if ITUNE >= 110
61963 C...(i.e., for A-Pro, DW-Pro etc)
61964  IF (itune.GE.110) THEN
61965 C...# Tuned flavour parameters:
61966  parj(1) = 0.073
61967  parj(2) = 0.2
61968  parj(3) = 0.94
61969  parj(4) = 0.032
61970  parj(11) = 0.31
61971  parj(12) = 0.4
61972  parj(13) = 0.54
61973  parj(25) = 0.63
61974  parj(26) = 0.12
61975 C...# Switch on Bowler:
61976  mstj(11) = 5
61977 C...# Fragmentation
61978  parj(21) = 0.325
61979  parj(41) = 0.5
61980  parj(42) = 0.6
61981  parj(47) = 0.67
61982  parj(81) = 0.29
61983  parj(82) = 1.65
61984  ENDIF
61985 
61986  mstp(81)=1
61987  parp(89)=1800d0
61988  parp(90)=0.25d0
61989  mstp(82)=4
61990  parp(83)=0.5d0
61991  parp(84)=0.4d0
61992  mstp(51)=7
61993  mstp(52)=1
61994  parp(71)=4d0
61995  parp(82)=2.0d0
61996  parp(85)=0.0d0
61997  parp(86)=0.66d0
61998  parp(62)=1d0
61999  parp(64)=1d0
62000  parp(67)=4d0
62001  mstp(91)=1
62002  parp(91)=1d0
62003  parp(93)=5d0
62004  mstp(95)=6
62005 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62006  parp(78)=0.09d0
62007 C...Frag functions (only if not using Professor)
62008  IF (itune.LE.109) THEN
62009  mstj(11)=4
62010  parj(54)=-0.05
62011  parj(55)=-0.005
62012  ENDIF
62013 
62014 C...Output
62015  IF (m13.GE.1) THEN
62016  WRITE(m11,5030) ' '
62017  WRITE(m11,5040) 51, mstp(51), chmstp(51)
62018  WRITE(m11,5040) 52, mstp(52), chmstp(52)
62019  WRITE(m11,5050) 62, parp(62), chparp(62)
62020  WRITE(m11,5050) 64, parp(64), chparp(64)
62021  WRITE(m11,5050) 67, parp(67), chparp(67)
62022  WRITE(m11,5040) 68, mstp(68), chmstp(68)
62023  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62024  WRITE(m11,5030) ch60
62025  WRITE(m11,5050) 71, parp(71), chparp(71)
62026  WRITE(m11,5060) 81, parj(81), chparj(81)
62027  WRITE(m11,5060) 82, parj(82), chparj(82)
62028  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62029  WRITE(m11,5050) 82, parp(82), chparp(82)
62030  WRITE(m11,5050) 89, parp(89), chparp(89)
62031  WRITE(m11,5050) 90, parp(90), chparp(90)
62032  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62033  WRITE(m11,5050) 83, parp(83), chparp(83)
62034  WRITE(m11,5050) 84, parp(84), chparp(84)
62035  WRITE(m11,5050) 85, parp(85), chparp(85)
62036  WRITE(m11,5050) 86, parp(86), chparp(86)
62037  WRITE(m11,5040) 91, mstp(91), chmstp(91)
62038  WRITE(m11,5050) 91, parp(91), chparp(91)
62039  WRITE(m11,5050) 93, parp(93), chparp(93)
62040  WRITE(m11,5040) 95, mstp(95), chmstp(95)
62041  WRITE(m11,5050) 78, parp(78), chparp(78)
62042  WRITE(m11,5070) 11, mstj(11), chmstj(11)
62043  WRITE(m11,5060) 21, parj(21), chparj(21)
62044  WRITE(m11,5060) 41, parj(41), chparj(41)
62045  WRITE(m11,5060) 42, parj(42), chparj(42)
62046  IF (mstj(11).LE.3) THEN
62047  WRITE(m11,5060) 54, parj(54), chparj(54)
62048  WRITE(m11,5060) 55, parj(55), chparj(55)
62049  ELSE
62050  WRITE(m11,5060) 46, parj(46), chparj(46)
62051  ENDIF
62052  IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
62053  ENDIF
62054 
62055 C=======================================================================
62056 C...Intermediate model. Rap tune
62057 C...(retuned to post-6.406 IR factorization)
62058  ELSEIF(itune.EQ.200) THEN
62059  IF (m13.GE.1) THEN
62060  WRITE(m11,5010) itune, chname
62061  ch60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62062  WRITE(m11,5030) ch60
62063  ENDIF
62064  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
62065  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62066  & ' with tune.')
62067  ENDIF
62068 C...PDF
62069  mstp(51)=7
62070  mstp(52)=1
62071 C...ISR
62072  parp(62)=1d0
62073  parp(64)=1d0
62074  parp(67)=4d0
62075 C...FSR
62076  parp(71)=4d0
62077  parj(81)=0.29d0
62078 C...UE
62079  mstp(81)=11
62080  parp(82)=2.25d0
62081  parp(89)=1800d0
62082  parp(90)=0.25d0
62083 C... ExpOfPow(1.8) overlap profile
62084  mstp(82)=5
62085  parp(83)=1.8d0
62086 C... Valence qq
62087  mstp(88)=0
62088 C... Rap Tune
62089  mstp(89)=1
62090 C... Default diquark, BR-g-BR supp
62091  parp(79)=2d0
62092  parp(80)=0.01d0
62093 C... Final state reconnect.
62094  mstp(95)=1
62095  parp(78)=0.55d0
62096 C...Fragmentation functions and c and b parameters
62097  mstj(11)=4
62098  parj(54)=-0.05
62099  parj(55)=-0.005
62100 C... Output
62101  IF (m13.GE.1) THEN
62102  WRITE(m11,5030) ' '
62103  WRITE(m11,5040) 51, mstp(51), chmstp(51)
62104  WRITE(m11,5040) 52, mstp(52), chmstp(52)
62105  WRITE(m11,5050) 62, parp(62), chparp(62)
62106  WRITE(m11,5050) 64, parp(64), chparp(64)
62107  WRITE(m11,5050) 67, parp(67), chparp(67)
62108  WRITE(m11,5040) 68, mstp(68), chmstp(68)
62109  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62110  WRITE(m11,5030) ch60
62111  WRITE(m11,5050) 71, parp(71), chparp(71)
62112  WRITE(m11,5060) 81, parj(81), chparj(81)
62113  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62114  WRITE(m11,5050) 82, parp(82), chparp(82)
62115  WRITE(m11,5050) 89, parp(89), chparp(89)
62116  WRITE(m11,5050) 90, parp(90), chparp(90)
62117  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62118  WRITE(m11,5050) 83, parp(83), chparp(83)
62119  WRITE(m11,5040) 88, mstp(88), chmstp(88)
62120  WRITE(m11,5040) 89, mstp(89), chmstp(89)
62121  WRITE(m11,5050) 79, parp(79), chparp(79)
62122  WRITE(m11,5050) 80, parp(80), chparp(80)
62123  WRITE(m11,5050) 93, parp(93), chparp(93)
62124  WRITE(m11,5040) 95, mstp(95), chmstp(95)
62125  WRITE(m11,5050) 78, parp(78), chparp(78)
62126  WRITE(m11,5070) 11, mstj(11), chmstj(11)
62127  WRITE(m11,5060) 21, parj(21), chparj(21)
62128  WRITE(m11,5060) 41, parj(41), chparj(41)
62129  WRITE(m11,5060) 42, parj(42), chparj(42)
62130  IF (mstj(11).LE.3) THEN
62131  WRITE(m11,5060) 54, parj(54), chparj(54)
62132  WRITE(m11,5060) 55, parj(55), chparj(55)
62133  ELSE
62134  WRITE(m11,5060) 46, parj(46), chparj(46)
62135  ENDIF
62136  IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
62137  ENDIF
62138 
62139 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62140 C...Old model for ISR and UE, new pT-ordered model for FSR
62141  ELSEIF(itune.EQ.201.OR.itune.EQ.211.OR.itune.EQ.221.or
62142  & .itune.EQ.226) THEN
62143  IF (m13.GE.1) THEN
62144  WRITE(m11,5010) itune, chname
62145  ch60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62146  WRITE(m11,5030) ch60
62147  ch60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62148  WRITE(m11,5030) ch60
62149  ch60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62150  WRITE(m11,5030) ch60
62151  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62152  WRITE(m11,5030) ch60
62153  IF (itune.EQ.211.OR.itune.GE.221) THEN
62154  ch60='LEP parameters tuned by Professor'
62155  WRITE(m11,5030) ch60
62156  ENDIF
62157  ENDIF
62158  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.411))THEN
62159  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62160  & ' with tune.')
62161  ENDIF
62162 C...First set as if Pythia tune A
62163 C...Multiple interactions on, old framework
62164  mstp(81)=1
62165 C...Fast IR cutoff energy scaling by default
62166  parp(89)=1800d0
62167  parp(90)=0.25d0
62168 C...Default CTEQ5L (internal)
62169  mstp(51)=7
62170  mstp(52)=1
62171 C...Double Gaussian matter distribution.
62172  mstp(82)=4
62173  parp(83)=0.5d0
62174  parp(84)=0.4d0
62175 C...FSR activity.
62176  parp(71)=4d0
62177 c...String drawing almost completely minimizes string length.
62178  parp(85)=0.9d0
62179  parp(86)=0.95d0
62180 C...ISR cutoff, muR scale factor, and phase space size
62181  parp(62)=1d0
62182  parp(64)=1d0
62183  parp(67)=4d0
62184 C...Intrinsic kT, size, and max
62185  mstp(91)=1
62186  parp(91)=1d0
62187  parp(93)=5d0
62188 C...Use 2 GeV of primordial kT for "Perugia" version
62189  IF (itune.EQ.221) THEN
62190  parp(91)=2d0
62191  parp(93)=10d0
62192  ENDIF
62193 C...Use pT-ordered FSR
62194  mstj(41)=12
62195 C...Lambda_FSR scale for pT-ordering
62196  parj(81)=0.23d0
62197 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62198  parp(82)=2.05d0
62199 C...Fragmentation functions and c and b parameters
62200 C...(overwritten for 211, i.e., if using Professor pars)
62201  mstj(11)=4
62202  parj(54)=-0.05
62203  parj(55)=-0.005
62204 
62205 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62206  IF (itune.EQ.211.OR.itune.GE.221) THEN
62207 C...# Tuned flavour parameters:
62208  parj(1) = 0.073
62209  parj(2) = 0.2
62210  parj(3) = 0.94
62211  parj(4) = 0.032
62212  parj(11) = 0.31
62213  parj(12) = 0.4
62214  parj(13) = 0.54
62215  parj(25) = 0.63
62216  parj(26) = 0.12
62217 C...# Always use pT-ordered shower:
62218  mstj(41) = 12
62219 C...# Switch on Bowler:
62220  mstj(11) = 5
62221 C...# Fragmentation
62222  parj(21) = 3.1327e-01
62223  parj(41) = 4.8989e-01
62224  parj(42) = 1.2018e+00
62225  parj(47) = 1.0000e+00
62226  parj(81) = 2.5696e-01
62227  parj(82) = 8.0000e-01
62228  ENDIF
62229 
62230 C...221, 226 : Perugia-APT and Perugia-APT6
62231  IF (itune.EQ.221.OR.itune.EQ.226) THEN
62232 
62233  parp(64)=0.5d0
62234  parp(82)=2.05d0
62235  parp(90)=0.26d0
62236  parp(91)=2.0d0
62237 C...The Perugia variants use Steve's showers off the old MPI
62238  mstp(152)=1
62239 C...And use a lower PARP(71) as suggested by Professor tunings
62240 C...(although not certain that applies to Q2-pT2 hybrid)
62241  parp(71)=2.5d0
62242 
62243 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62244  IF (itune.EQ.226) THEN
62245  ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
62246  & 'externally linked'
62247  WRITE(m11,5035) ch70
62248  mstp(52)=2
62249  mstp(51)=10042
62250  parp(82)=1.95d0
62251  ENDIF
62252 
62253  ENDIF
62254 
62255 C... Output
62256  IF (m13.GE.1) THEN
62257  WRITE(m11,5030) ' '
62258  WRITE(m11,5040) 51, mstp(51), chmstp(51)
62259  WRITE(m11,5040) 52, mstp(52), chmstp(52)
62260  WRITE(m11,5050) 62, parp(62), chparp(62)
62261  WRITE(m11,5050) 64, parp(64), chparp(64)
62262  WRITE(m11,5050) 67, parp(67), chparp(67)
62263  WRITE(m11,5040) 68, mstp(68), chmstp(68)
62264  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62265  WRITE(m11,5030) ch60
62266  WRITE(m11,5070) 41, mstj(41), chmstj(41)
62267  WRITE(m11,5050) 71, parp(71), chparp(71)
62268  WRITE(m11,5060) 81, parj(81), chparj(81)
62269  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62270  WRITE(m11,5050) 82, parp(82), chparp(82)
62271  WRITE(m11,5050) 89, parp(89), chparp(89)
62272  WRITE(m11,5050) 90, parp(90), chparp(90)
62273  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62274  WRITE(m11,5050) 83, parp(83), chparp(83)
62275  WRITE(m11,5050) 84, parp(84), chparp(84)
62276  WRITE(m11,5050) 85, parp(85), chparp(85)
62277  WRITE(m11,5050) 86, parp(86), chparp(86)
62278  WRITE(m11,5040) 91, mstp(91), chmstp(91)
62279  WRITE(m11,5050) 91, parp(91), chparp(91)
62280  WRITE(m11,5050) 93, parp(93), chparp(93)
62281  WRITE(m11,5070) 11, mstj(11), chmstj(11)
62282  WRITE(m11,5060) 21, parj(21), chparj(21)
62283  WRITE(m11,5060) 41, parj(41), chparj(41)
62284  WRITE(m11,5060) 42, parj(42), chparj(42)
62285  IF (mstj(11).LE.3) THEN
62286  WRITE(m11,5060) 54, parj(54), chparj(54)
62287  WRITE(m11,5060) 55, parj(55), chparj(55)
62288  ELSE
62289  WRITE(m11,5060) 46, parj(46), chparj(46)
62290  ENDIF
62291  IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
62292  ENDIF
62293 
62294 C======================================================================
62295 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62296  ELSEIF(chname.EQ.'GAL Tune 0'.OR.chname.EQ.'GAL Tune 1') THEN
62297  IF (m13.GE.1) THEN
62298  WRITE(m11,5010) itune, chname
62299  ch60='see J. Rathsman, PLB452(1999)364'
62300  WRITE(m11,5030) ch60
62301 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62302 C ? WRITE(M11,5030)
62303  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62304  WRITE(m11,5030) ch60
62305  WRITE(m11,5030) ' '
62306  ch70='NB! The GAL model must be run with modified '//
62307  & 'Pythia v6.215:'
62308  WRITE(m11,5035) ch70
62309  ch70='available from http://www.isv.uu.se/thep/MC/scigal/'
62310  WRITE(m11,5035) ch70
62311  WRITE(m11,5030) ' '
62312  ENDIF
62313 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62314  mswi(2) = 3
62315  parsci(2) = 0.10
62316  mswi(1) = 2
62317  parsci(1) = 0.44
62318  mstj(16) = 0
62319  parj(42) = 0.45
62320  parj(82) = 2.0
62321  parp(62) = 2.0
62322  mstp(81) = 1
62323  mstp(82) = 1
62324  parp(81) = 1.9
62325  mstp(92) = 1
62326  IF(chname.EQ.'GAL Tune 1') THEN
62327 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62328  mstp(82)=4
62329  parp(83)=0.25d0
62330  parp(84)=0.5d0
62331  parp(82) = 1.75
62332  IF (m13.GE.1) THEN
62333  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62334  WRITE(m11,5050) 82, parp(82), chparp(82)
62335  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62336  WRITE(m11,5050) 83, parp(83), chparp(83)
62337  WRITE(m11,5050) 84, parp(84), chparp(84)
62338  ENDIF
62339  ELSE
62340  IF (m13.GE.1) THEN
62341  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62342  WRITE(m11,5050) 81, parp(81), chparp(81)
62343  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62344  ENDIF
62345  ENDIF
62346 C...Output
62347  IF (m13.GE.1) THEN
62348  WRITE(m11,5050) 62, parp(62), chparp(62)
62349  WRITE(m11,5060) 82, parj(82), chparj(82)
62350  WRITE(m11,5040) 92, mstp(92), chmstp(92)
62351  ch40='FSI SCI/GAL selection'
62352  WRITE(m11,6040) 1, mswi(1), ch40
62353  ch40='FSI SCI/GAL sea quark treatment'
62354  WRITE(m11,6040) 2, mswi(2), ch40
62355  ch40='FSI SCI/GAL sea quark treatment parm'
62356  WRITE(m11,6050) 1, parsci(1), ch40
62357  ch40='FSI SCI/GAL string reco probability R_0'
62358  WRITE(m11,6050) 2, parsci(2), ch40
62359  WRITE(m11,5060) 42, parj(42), chparj(42)
62360  WRITE(m11,5070) 16, mstj(16), chmstj(16)
62361  ENDIF
62362  ELSEIF(chname.EQ.'SCI Tune 0'.OR.chname.EQ.'SCI Tune 1') THEN
62363  IF (m13.GE.1) THEN
62364  WRITE(m11,5010) itune, chname
62365  ch60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62366  WRITE(m11,5030) ch60
62367  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62368  WRITE(m11,5030) ch60
62369  WRITE(m11,5030) ' '
62370  ch70='NB! The SCI model must be run with modified '//
62371  & 'Pythia v6.215:'
62372  WRITE(m11,5035) ch70
62373  ch70='available from http://www.isv.uu.se/thep/MC/scigal/'
62374  WRITE(m11,5035) ch70
62375  WRITE(m11,5030) ' '
62376  ENDIF
62377 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62378  mstp(81)=1
62379  mstp(82)=1
62380  parp(81)=2.2
62381  mstp(92)=1
62382  mswi(2)=2
62383  parsci(2)=0.50
62384  mswi(1)=2
62385  parsci(1)=0.44
62386  mstj(16)=0
62387  IF (chname.EQ.'SCI Tune 1') THEN
62388 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62389  mstp(81) = 1
62390  mstp(82) = 3
62391  parp(82) = 2.4
62392  parp(83) = 0.5d0
62393  parp(62) = 1.5
62394  parp(84)=0.25d0
62395  IF (m13.GE.1) THEN
62396  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62397  WRITE(m11,5050) 82, parp(82), chparp(82)
62398  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62399  WRITE(m11,5050) 83, parp(83), chparp(83)
62400  WRITE(m11,5050) 62, parp(62), chparp(62)
62401  ENDIF
62402  ELSE
62403  IF (m13.GE.1) THEN
62404  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62405  WRITE(m11,5050) 81, parp(81), chparp(81)
62406  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62407  ENDIF
62408  ENDIF
62409 C...Output
62410  IF (m13.GE.1) THEN
62411  WRITE(m11,5040) 92, mstp(92), chmstp(92)
62412  ch40='FSI SCI/GAL selection'
62413  WRITE(m11,6040) 1, mswi(1), ch40
62414  ch40='FSI SCI/GAL sea quark treatment'
62415  WRITE(m11,6040) 2, mswi(2), ch40
62416  ch40='FSI SCI/GAL sea quark treatment parm'
62417  WRITE(m11,6050) 1, parsci(1), ch40
62418  ch40='FSI SCI/GAL string reco probability R_0'
62419  WRITE(m11,6050) 2, parsci(2), ch40
62420  WRITE(m11,5070) 16, mstj(16), chmstj(16)
62421  ENDIF
62422 
62423  ELSE
62424  IF (mstu(13).GE.1) WRITE(m11,5020) itune
62425 
62426  ENDIF
62427 
62428  100 IF (mstu(13).GE.1) WRITE(m11,6000)
62429 
62430  9999 RETURN
62431 
62432  5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',a6,' : ',
62433  & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62434  & 20x,'Last Change : ',a8,' - P. Skands',22x,'*'/' *',76x,'*')
62435  5010 FORMAT(' *',3x,i4,1x,a16,52x,'*')
62436  5020 FORMAT(' *',3x,'Tune ',i4, ' not recognized. Using defaults.')
62437  5030 FORMAT(' *',3x,10x,a60,3x,'*')
62438  5035 FORMAT(' *',3x,a70,3x,'*')
62439  5040 FORMAT(' *',5x,'MSTP(',i2,') = ',i12,3x,a42,3x,'*')
62440  5050 FORMAT(' *',5x,'PARP(',i2,') = ',f12.4,3x,a40,5x,'*')
62441  5060 FORMAT(' *',5x,'PARJ(',i2,') = ',f12.4,3x,a40,5x,'*')
62442  5070 FORMAT(' *',5x,'MSTJ(',i2,') = ',i12,3x,a40,5x,'*')
62443  5140 FORMAT(' *',5x,'MSTP(',i3,')= ',i12,3x,a40,5x,'*')
62444  5150 FORMAT(' *',5x,'PARP(',i3,')= ',f12.4,3x,a40,5x,'*')
62445  6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62446  6040 FORMAT(' *',5x,'MSWI(',i1,') = ',i12,3x,a40,5x,'*')
62447  6050 FORMAT(' *',5x,'PARSCI(',i1,')= ',f12.4,3x,a40,5x,'*')
62448 
62449  END
62450 
62451 C*********************************************************************
62452 
62453 C...PYEXEC
62454 C...Administrates the fragmentation and decay chain.
62455 
62456  SUBROUTINE pyexec
62457 
62458 C...Double precision and integer declarations.
62459  IMPLICIT DOUBLE PRECISION(a-h, o-z)
62460  IMPLICIT INTEGER(I-N)
62461  INTEGER PYK,PYCHGE,PYCOMP
62462 C...Commonblocks.
62463  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
62464  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
62465  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
62466  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
62467  common/pyint1/mint(400),vint(400)
62468  common/pyint4/mwid(500),wids(500,5)
62469  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint1/,/pyint4/
62470 C...Local array.
62471  dimension ps(2,6),ijoin(100)
62472 
62473 C...Initialize and reset.
62474  mstu(24)=0
62475  IF(mstu(12).NE.12345) CALL pylist(0)
62476  mstu(29)=0
62477  mstu(31)=mstu(31)+1
62478  mstu(1)=0
62479  mstu(2)=0
62480  mstu(3)=0
62481  IF(mstu(17).LE.0) mstu(90)=0
62482  mcons=1
62483 
62484 C...Sum up momentum, energy and charge for starting entries.
62485  nsav=n
62486  DO 110 i=1,2
62487  DO 100 j=1,6
62488  ps(i,j)=0d0
62489  100 CONTINUE
62490  110 CONTINUE
62491  DO 130 i=1,n
62492  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 130
62493  DO 120 j=1,4
62494  ps(1,j)=ps(1,j)+p(i,j)
62495  120 CONTINUE
62496  ps(1,6)=ps(1,6)+pychge(k(i,2))
62497  130 CONTINUE
62498  paru(21)=ps(1,4)
62499 
62500 C...Start by all decays of coloured resonances involved in shower.
62501  norig=n
62502  DO 140 i=1,norig
62503  IF(k(i,1).EQ.3) THEN
62504  kc=pycomp(k(i,2))
62505  IF(mwid(kc).NE.0.AND.kchg(kc,2).NE.0) CALL pyresd(i)
62506  ENDIF
62507  140 CONTINUE
62508 
62509 C...Prepare system for subsequent fragmentation/decay.
62510  CALL pyprep(0)
62511  IF(mint(51).NE.0) RETURN
62512 
62513 C...Loop through jet fragmentation and particle decays.
62514  mbe=0
62515  150 mbe=mbe+1
62516  ip=0
62517  160 ip=ip+1
62518  kc=0
62519  IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=pycomp(k(ip,2))
62520  IF(kc.EQ.0) THEN
62521 
62522 C...Deal with any remaining undecayed resonance
62523 C...(normally the task of PYEVNT, so seldom used).
62524  ELSEIF(mwid(kc).NE.0) THEN
62525  ibeg=ip
62526  IF(kchg(kc,2).NE.0.AND.k(i,1).NE.3) THEN
62527  ibeg=ip+1
62528  170 ibeg=ibeg-1
62529  IF(ibeg.GE.2.AND.k(ibeg,1).EQ.2) GOTO 170
62530  IF(k(ibeg,1).NE.2) ibeg=ibeg+1
62531  iend=ip-1
62532  180 iend=iend+1
62533  IF(iend.LT.n.AND.k(iend,1).EQ.2) GOTO 180
62534  IF(iend.LT.n.AND.kchg(pycomp(k(iend,2)),2).EQ.0) GOTO 180
62535  njoin=0
62536  DO 190 i=ibeg,iend
62537  IF(kchg(pycomp(k(iend,2)),2).NE.0) THEN
62538  njoin=njoin+1
62539  ijoin(njoin)=i
62540  ENDIF
62541  190 CONTINUE
62542  ENDIF
62543  CALL pyresd(ip)
62544  CALL pyprep(ibeg)
62545  IF(mint(51).NE.0) RETURN
62546 
62547 C...Particle decay if unstable and allowed. Save long-lived particle
62548 C...decays until second pass after Bose-Einstein effects.
62549  ELSEIF(kchg(kc,2).EQ.0) THEN
62550  IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe
62551  & .EQ.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
62552  & CALL pydecy(ip)
62553 
62554 C...Decay products may develop a shower.
62555  IF(mstj(92).GT.0) THEN
62556  ip1=mstj(92)
62557  qmax=sqrt(max(0d0,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
62558  & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
62559  mint(33)=0
62560  CALL pyshow(ip1,ip1+1,qmax)
62561  CALL pyprep(ip1)
62562  IF(mint(51).NE.0) RETURN
62563  mstj(92)=0
62564  ELSEIF(mstj(92).LT.0) THEN
62565  ip1=-mstj(92)
62566  mint(33)=0
62567  CALL pyshow(ip1,-3,p(ip,5))
62568  CALL pyprep(ip1)
62569  IF(mint(51).NE.0) RETURN
62570  mstj(92)=0
62571  ENDIF
62572 
62573 C...Jet fragmentation: string or independent fragmentation.
62574  ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
62575  mfrag=mstj(1)
62576  IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
62577  IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
62578  IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
62579  & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
62580  IF(kchg(pycomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
62581  ENDIF
62582  ENDIF
62583  IF(mfrag.EQ.1) CALL pystrf(ip)
62584  IF(mfrag.EQ.2) CALL pyindf(ip)
62585  IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
62586  IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
62587  ENDIF
62588 
62589 C...Loop back if enough space left in PYJETS and no error abort.
62590  IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
62591  ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
62592  GOTO 160
62593  ELSEIF(ip.LT.n) THEN
62594  CALL pyerrm(11,'(PYEXEC:) no more memory left in PYJETS')
62595  ENDIF
62596 
62597 C...Include simple Bose-Einstein effect parametrization if desired.
62598  IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
62599  CALL pyboei(nsav)
62600  GOTO 150
62601  ENDIF
62602 
62603 C...Check that momentum, energy and charge were conserved.
62604  DO 210 i=1,n
62605  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 210
62606  DO 200 j=1,4
62607  ps(2,j)=ps(2,j)+p(i,j)
62608  200 CONTINUE
62609  ps(2,6)=ps(2,6)+pychge(k(i,2))
62610  210 CONTINUE
62611  pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
62612  &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1d0+abs(ps(2,4))+abs(ps(1,4)))
62613  IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL pyerrm(15,
62614  &'(PYEXEC:) four-momentum was not conserved')
62615  IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1d0) CALL pyerrm(15,
62616  &'(PYEXEC:) charge was not conserved')
62617 
62618  RETURN
62619  END
62620 
62621 C*********************************************************************
62622 
62623 C...PYPREP
62624 C...Rearranges partons along strings.
62625 C...Special considerations for systems with junctions, with
62626 C...possibility of junction-antijunction annihilation.
62627 C...Allows small systems to collapse into one or two particles.
62628 C...Checks flavours and colour singlet invariant masses.
62629 
62630  SUBROUTINE pyprep(IP)
62631 
62632 C...Double precision and integer declarations.
62633  IMPLICIT DOUBLE PRECISION(a-h, o-z)
62634  INTEGER PYK,PYCHGE,PYCOMP
62635 C...Commonblocks.
62636  COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62637  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
62638  common/pypars/mstp(200),parp(200),msti(200),pari(200)
62639  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
62640  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
62641  common/pyint1/mint(400),vint(400)
62642 C...The common block of colour tags.
62643  common/pyctag/nct,mct(4000,2)
62644  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint1/,/pyctag/,
62645  &/pypars/
62646  DATA nerrpr/0/
62647  SAVE nerrpr
62648 C...Local arrays.
62649  dimension dps(5),dpc(5),ue(3),pg(5),e1(3),e2(3),e3(3),e4(3),
62650  &ecl(3),ijunc(10,0:4),ipiece(30,0:4),kfend(4),kfq(4),
62651  &ijur(4),pju(4,6),irng(4,2),tjj(2,5),t(5),pul(3,5),
62652  &ijcp(0:6),tjuold(5)
62653  CHARACTER CHTMP*6
62654 
62655 C...Function to give four-product.
62656  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)
62657 
62658 C...Rearrange parton shower product listing along strings: begin loop.
62659  mstu(24)=0
62660  nold=n
62661  i1=n
62662  njunc=0
62663  npiece=0
62664  njjstr=0
62665  mstu32=mstu(32)+1
62666  DO 100 i=max(1,ip),n
62667 C...First store junction positions.
62668  IF(k(i,1).EQ.42) THEN
62669  njunc=njunc+1
62670  ijunc(njunc,0)=i
62671  ijunc(njunc,4)=0
62672  ENDIF
62673  100 CONTINUE
62674 
62675  DO 250 mqgst=1,3
62676  DO 240 i=max(1,ip),n
62677 C...Special treatment for junctions
62678  IF (k(i,1).LE.0) GOTO 240
62679  IF(k(i,1).EQ.42) THEN
62680 C...MQGST=2: Look for junction-junction strings (not detected in the
62681 C...main search below).
62682  IF (mqgst.EQ.2.AND.npiece.NE.3*njunc) THEN
62683  IF (njjstr.EQ.0) THEN
62684  njjstr = (3*njunc-npiece)/2
62685  ENDIF
62686 C...Check how many already identified strings end on this junction
62687  ilc=0
62688  DO 110 j=1,npiece
62689  IF (ipiece(j,4).EQ.i) ilc=ilc+1
62690  110 CONTINUE
62691 C...If less than 3, remaining must be to another junction
62692  IF (ilc.LT.3) THEN
62693  IF (ilc.NE.2) THEN
62694 C...Multiple j-j connections not handled yet.
62695  CALL pyerrm(2,
62696  & '(PYPREP:) Too many junction-junction strings.')
62697  mint(51)=1
62698  RETURN
62699  ENDIF
62700 C...The colour information in the junction is unreadable for the
62701 C...colour space search further down in this routine, so we must
62702 C...start on the colour mother of this junction and then "artificially"
62703 C...prevent the colour mother from connecting here again.
62704  itjunc=mod(k(i,4)/mstu(5),mstu(5))
62705  kcs=4
62706  IF (mod(itjunc,2).EQ.0) kcs=5
62707 C...Switch colour if the junction-junction leg is presumably a
62708 C...junction mother leg rather than a junction daughter leg.
62709  IF (itjunc.GE.3) kcs=9-kcs
62710  IF (mint(33).EQ.0) THEN
62711 C...Find the unconnected leg and reorder junction daughter pointers so
62712 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62713 C...piece.
62714  ia=mod(k(i,4),mstu(5))
62715  IF (k(ia,kcs)/mstu(5)**2.GE.2) THEN
62716  itmp=mod(k(i,5),mstu(5))
62717  IF (k(itmp,kcs)/mstu(5)**2.GE.2) THEN
62718  itmp=mod(k(i,5)/mstu(5),mstu(5))
62719  k(i,5)=k(i,5)+(ia-itmp)*mstu(5)
62720  ELSE
62721  k(i,5)=k(i,5)+(ia-itmp)
62722  ENDIF
62723  k(i,4)=k(i,4)+(itmp-ia)
62724  ia=itmp
62725  ENDIF
62726  IF (itjunc.LE.2) THEN
62727 C...Beam baryon junction
62728  k(ia,kcs) = k(ia,kcs) + 2*mstu(5)**2
62729  k(i,kcs) = k(i,kcs) + 1*mstu(5)**2
62730 C...Else 1 -> 2 decay junction
62731  ELSE
62732  k(ia,kcs) = k(ia,kcs) + mstu(5)**2
62733  k(i,kcs) = k(i,kcs) + 2*mstu(5)**2
62734  ENDIF
62735  i1beg = i1
62736  nstp = 0
62737  GOTO 170
62738 C...Alternatively use colour tag information.
62739  ELSE
62740 C...Find a final state parton with appropriate dangling colour tag.
62741  jct=0
62742  ia=0
62743  ijumo=k(i,3)
62744  DO 140 j1=max(1,ip),n
62745  IF (k(j1,1).NE.3) GOTO 140
62746 C...Check for matching final-state colour tag
62747  imatch=0
62748  DO 120 j2=max(1,ip),n
62749  IF (k(j2,1).NE.3) GOTO 120
62750  IF (mct(j1,kcs-3).EQ.mct(j2,6-kcs)) imatch=1
62751  120 CONTINUE
62752  IF (imatch.EQ.1) GOTO 140
62753 C...Check whether this colour tag belongs to the present junction
62754 C...by seeing whether any parton with this colour tag has the same
62755 C...mother as the junction.
62756  jct=mct(j1,kcs-3)
62757  imatch=0
62758  DO 130 j2=mint(84)+1,n
62759  imo2=k(j2,3)
62760 C...First scattering partons have IMO1 = 3 and 4.
62761  IF (imo2.EQ.mint(83)+3.OR.imo2.EQ.mint(83)+4)
62762  & imo2=imo2-2
62763  IF (mct(j2,kcs-3).EQ.jct.AND.imo2.EQ.ijumo)
62764  & imatch=1
62765  130 CONTINUE
62766  IF (imatch.EQ.0) GOTO 140
62767  ia=j1
62768  140 CONTINUE
62769 C...Check for junction-junction strings without intermediate final state
62770 C...glue (not detected above).
62771  IF (ia.EQ.0) THEN
62772  DO 160 mju=1,njunc
62773  iju2=ijunc(mju,0)
62774  IF (iju2.EQ.i) GOTO 160
62775  itju2=mod(k(iju2,4)/mstu(5),mstu(5))
62776 C...Only opposite types of junctions can connect to each other.
62777  IF (mod(itju2,2).EQ.mod(itjunc,2)) GOTO 160
62778  is=0
62779  DO 150 j=1,npiece
62780  IF (ipiece(j,4).EQ.iju2) is=is+1
62781  150 CONTINUE
62782  IF (is.EQ.3) GOTO 160
62783  ib=i
62784  ia=iju2
62785  160 CONTINUE
62786  ENDIF
62787 C...Switch to other side of adjacent parton and step from there.
62788  kcs=9-kcs
62789  i1beg = i1
62790  nstp = 0
62791  GOTO 170
62792  ENDIF
62793  ELSE IF (ilc.NE.3) THEN
62794  ENDIF
62795  ENDIF
62796  ENDIF
62797 
62798 C...Look for coloured string endpoint, or (later) leftover gluon.
62799  IF(k(i,1).NE.3) GOTO 240
62800  kc=pycomp(k(i,2))
62801  IF(kc.EQ.0) GOTO 240
62802  kq=kchg(kc,2)
62803  IF(kq.EQ.0.OR.(mqgst.LE.2.AND.kq.EQ.2)) GOTO 240
62804 
62805 C...Pick up loose string end.
62806  kcs=4
62807  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
62808  ia=i
62809  ib=i
62810  i1beg=i1
62811  nstp=0
62812  170 nstp=nstp+1
62813  IF(nstp.GT.4*n) THEN
62814  CALL pyerrm(14,'(PYPREP:) caught in infinite loop')
62815  mint(51)=1
62816  RETURN
62817  ENDIF
62818 
62819 C...Copy undecayed parton. Finished if reached string endpoint.
62820  IF(k(ia,1).EQ.3) THEN
62821  IF(i1.GE.mstu(4)-mstu32-5) THEN
62822  CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
62823  mint(51)=1
62824  mstu(24)=1
62825  RETURN
62826  ENDIF
62827  i1=i1+1
62828  k(i1,1)=2
62829  IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) k(i1,1)=1
62830  k(i1,2)=k(ia,2)
62831  k(i1,3)=ia
62832  k(i1,4)=0
62833  k(i1,5)=0
62834  DO 180 j=1,5
62835  p(i1,j)=p(ia,j)
62836  v(i1,j)=v(ia,j)
62837  180 CONTINUE
62838  k(ia,1)=k(ia,1)+10
62839  IF(k(i1,1).EQ.1) GOTO 240
62840  ENDIF
62841 
62842 C...Also finished (for now) if reached junction; then copy to end.
62843  IF(k(ia,1).EQ.42) THEN
62844  ncopy=i1-i1beg
62845  IF(i1.GE.mstu(4)-mstu32-ncopy-5) THEN
62846  CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
62847  mint(51)=1
62848  mstu(24)=1
62849  RETURN
62850  ENDIF
62851  IF (mqgst.LE.2.AND.ncopy.NE.0) THEN
62852  DO 200 icopy=1,ncopy
62853  DO 190 j=1,5
62854  k(mstu(4)-mstu32-icopy,j)=k(i1beg+icopy,j)
62855  p(mstu(4)-mstu32-icopy,j)=p(i1beg+icopy,j)
62856  v(mstu(4)-mstu32-icopy,j)=v(i1beg+icopy,j)
62857  190 CONTINUE
62858  200 CONTINUE
62859  ENDIF
62860 C...For junction-junction strings, find end leg and reorder junction
62861 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
62862 C...junction-junction string piece.
62863  IF (k(i,1).EQ.42.AND.mint(33).EQ.0) THEN
62864  itmp=mod(k(ia,4),mstu(5))
62865  IF (itmp.NE.ib) THEN
62866  IF (mod(k(ia,5),mstu(5)).EQ.ib) THEN
62867  k(ia,5)=k(ia,5)+(itmp-ib)
62868  ELSE
62869  k(ia,5)=k(ia,5)+(itmp-ib)*mstu(5)
62870  ENDIF
62871  k(ia,4)=k(ia,4)+(ib-itmp)
62872  ENDIF
62873  ENDIF
62874  npiece=npiece+1
62875 C...IPIECE:
62876 C...0: endpoint in original ER
62877 C...1:
62878 C...2:
62879 C...3: Parton immediately next to junction
62880 C...4: Junction
62881  ipiece(npiece,0)=i
62882  ipiece(npiece,1)=mstu32+1
62883  ipiece(npiece,2)=mstu32+ncopy
62884  ipiece(npiece,3)=ib
62885  ipiece(npiece,4)=ia
62886  mstu32=mstu32+ncopy
62887  i1=i1beg
62888  GOTO 240
62889  ENDIF
62890 
62891 C...GOTO next parton in colour space.
62892  ib=ia
62893  IF (mint(33).EQ.0) THEN
62894  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5
62895  & )).NE.0) THEN
62896  ia=mod(k(ib,kcs),mstu(5))
62897  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
62898  mrev=0
62899  ELSE
62900  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
62901  & mstu(5)).EQ.0) kcs=9-kcs
62902  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
62903  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
62904  mrev=1
62905  ENDIF
62906  IF(ia.LE.0.OR.ia.GT.n) THEN
62907  CALL pyerrm(12,'(PYPREP:) colour rearrangement failed')
62908  IF(nerrpr.LT.5) THEN
62909  nerrpr=nerrpr+1
62910  WRITE(mstu(11),*) 'started at:', i
62911  WRITE(mstu(11),*) 'ended going from',ib,' to',ia
62912  WRITE(mstu(11),*) 'MQGST =',mqgst
62913  CALL pylist(4)
62914  ENDIF
62915  mint(51)=1
62916  RETURN
62917  ENDIF
62918  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5)
62919  & ,mstu(5)).EQ.ib) THEN
62920  IF(mrev.EQ.1) kcs=9-kcs
62921  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
62922  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
62923  ELSE
62924  IF(mrev.EQ.0) kcs=9-kcs
62925  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
62926  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
62927  ENDIF
62928  IF(ia.NE.i) GOTO 170
62929 C...Use colour tag information
62930  ELSE
62931 C...First create colour tags starting on IB if none already present.
62932  IF (mct(ib,kcs-3).EQ.0) THEN
62933  CALL pycttr(ib,kcs,ib)
62934  IF(mint(51).NE.0) RETURN
62935  ENDIF
62936  jct=mct(ib,kcs-3)
62937  ifound=0
62938 C...Find final state tag partner
62939  DO 210 it=max(1,ip),n
62940  IF (it.EQ.ib) GOTO 210
62941  IF (mct(it,6-kcs).EQ.jct.AND.k(it,1).LT.10.AND.k(it,1).gt
62942  & .0) THEN
62943  ifound=ifound+1
62944  ia=it
62945  ENDIF
62946  210 CONTINUE
62947 C...Just copy and goto next if exactly one partner found.
62948  IF (ifound.EQ.1) THEN
62949  GOTO 170
62950 C...When no match found, match is presumably junction.
62951  ELSEIF (ifound.EQ.0.AND.mqgst.LE.2) THEN
62952 C...Check whether this colour tag matches a junction
62953 C...by seeing whether any parton with this colour tag has the same
62954 C...mother as a junction.
62955 C...NB: Only type 1 and 2 junctions handled presently.
62956  DO 230 iju=1,njunc
62957  ijumo=k(ijunc(iju,0),3)
62958  itjunc=mod(k(ijunc(iju,0),4)/mstu(5),mstu(5))
62959 C...Colours only connect to junctions, anti-colours to antijunctions:
62960  IF (mod(itjunc+1,2)+1.NE.kcs-3) GOTO 230
62961  imatch=0
62962  DO 220 j1=max(1,ip),n
62963  IF (k(j1,1).LE.0) GOTO 220
62964 C...First scattering partons have IMO1 = 3 and 4.
62965  imo=k(j1,3)
62966  IF (imo.EQ.mint(83)+3.OR.imo.EQ.mint(83)+4)
62967  & imo=imo-2
62968  IF (mct(j1,kcs-3).EQ.jct.AND.imo.EQ.ijumo.AND.mod(k(j1
62969  & ,3+itjunc)/mstu(5),mstu(5)).EQ.ijunc(iju,0))
62970  & imatch=1
62971 C...Attempt at handling type > 3 junctions also. Not tested.
62972  IF (itjunc.GE.3.AND.mct(j1,6-kcs).EQ.jct.AND.imo.eq
62973  & .ijumo) imatch=1
62974  220 CONTINUE
62975  IF (imatch.EQ.0) GOTO 230
62976  ia=ijunc(iju,0)
62977  ifound=ifound+1
62978  230 CONTINUE
62979 
62980  IF (ifound.EQ.1) THEN
62981  GOTO 170
62982  ELSEIF (ifound.EQ.0) THEN
62983  WRITE(chtmp,*) jct
62984  CALL pyerrm(12,'(PYPREP:) no matching colour tag: '
62985  & //chtmp)
62986  IF(nerrpr.LT.5) THEN
62987  nerrpr=nerrpr+1
62988  CALL pylist(4)
62989  ENDIF
62990  mint(51)=1
62991  RETURN
62992  ENDIF
62993  ELSEIF (ifound.GE.2) THEN
62994  WRITE(chtmp,*) jct
62995  CALL pyerrm(12
62996  & ,'(PYPREP:) too many occurences of colour line: '//
62997  & chtmp)
62998  IF(nerrpr.LT.5) THEN
62999  nerrpr=nerrpr+1
63000  CALL pylist(4)
63001  ENDIF
63002  mint(51)=1
63003  RETURN
63004  ENDIF
63005  ENDIF
63006  k(i1,1)=1
63007  240 CONTINUE
63008  250 CONTINUE
63009 
63010 C...Junction systems remain.
63011  iju=0
63012  ijus=0
63013  ijucnt=0
63014  mrev=0
63015  ijjstr=0
63016  260 ijucnt=ijucnt+1
63017  IF (ijucnt.LE.njunc) THEN
63018 C...If we are not processing a j-j string, treat this junction as new.
63019  IF (ijjstr.EQ.0) THEN
63020  iju=ijunc(ijucnt,0)
63021  mrev=0
63022 C...If junction has already been read, ignore it.
63023  IF (ijunc(ijucnt,4).EQ.1) GOTO 260
63024 C...If we are on a j-j string, goto second j-j junction.
63025  ELSE
63026  ijucnt=ijucnt-1
63027  iju=ijus
63028  ENDIF
63029 C...Mark selected junction read.
63030  DO 270 j=1,njunc
63031  IF (ijunc(j,0).EQ.iju) ijunc(j,4)=1
63032  270 CONTINUE
63033 C...Determine junction type
63034  itjunc = mod(k(iju,4)/mstu(5),mstu(5))
63035 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63036 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63037 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63038  IF (itjunc.GE.1.AND.itjunc.LE.6) THEN
63039  ihk=0
63040  280 ihk=ihk+1
63041 C...Find which quarks belong to given junction.
63042  ihf=0
63043  DO 290 ipc=1,npiece
63044  IF (ipiece(ipc,4).EQ.iju) THEN
63045  ihf=ihf+1
63046  IF (ihf.EQ.ihk) iend=ipiece(ipc,3)
63047  ENDIF
63048  IF (ihk.EQ.3.AND.ipiece(ipc,0).EQ.iju) iend=ipiece(ipc,3)
63049  290 CONTINUE
63050 C...IHK = 3 is special. Either normal string piece, or j-j string.
63051  IF(ihk.EQ.3) THEN
63052  IF (mrev.NE.1) THEN
63053  DO 300 ipc=1,npiece
63054 C...If there is a j-j string starting on the present junction which has
63055 C...zero length, insert next junction immediately.
63056  IF (ipiece(ipc,0).EQ.iju.AND.k(ipiece(ipc,4),1)
63057  & .EQ.42.AND.ipiece(ipc,1)-1-ipiece(ipc,2).EQ.0) THEN
63058  ijjstr = 1
63059  GOTO 340
63060  ENDIF
63061  300 CONTINUE
63062  mrev = 1
63063 C...If MREV is 1 and IHK is 3 we are finished with this system.
63064  ELSE
63065  mrev=0
63066  GOTO 260
63067  ENDIF
63068  ENDIF
63069 
63070 C...If we've gotten this far, then either IHK < 3, or
63071 C...an interjunction string exists, or just a third normal string.
63072  ijunc(ijucnt,ihk)=0
63073  ijjstr = 0
63074 C..Order pieces belonging to this junction. Also look for j-j.
63075  DO 310 ipc=1,npiece
63076  IF (ipiece(ipc,3).EQ.iend) ijunc(ijucnt,ihk)=ipc
63077  IF (ihk.EQ.3.AND.ipiece(ipc,0).EQ.ijunc(ijucnt,0)
63078  & .AND.k(ipiece(ipc,4),1).EQ.42) THEN
63079  ijunc(ijucnt,ihk)=ipc
63080  ijjstr = 1
63081  mrev = 0
63082  ENDIF
63083  310 CONTINUE
63084 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63085  ipc=ijunc(ijucnt,ihk)
63086 C...Temporary solution to cover for bug.
63087  IF(ipc.LE.0) THEN
63088  CALL pyerrm(12,'(PYPREP:) fails to hook up junctions')
63089  mint(51)=1
63090  RETURN
63091  ENDIF
63092  DO 330 icp=ipiece(ipc,1+mrev),ipiece(ipc,2-mrev),1-2*mrev
63093  i1=i1+1
63094  DO 320 j=1,5
63095  k(i1,j)=k(mstu(4)-icp,j)
63096  p(i1,j)=p(mstu(4)-icp,j)
63097  v(i1,j)=v(mstu(4)-icp,j)
63098  320 CONTINUE
63099  330 CONTINUE
63100  k(i1,1)=2
63101 C...Mark last quark.
63102  IF (mrev.EQ.1.AND.ihk.GE.2) k(i1,1)=1
63103 C...Do not insert junctions at wrong places.
63104  IF(ihk.LT.2.OR.mrev.NE.0) GOTO 360
63105 C...Insert junction.
63106  340 ijus = iju
63107  IF (ihk.EQ.3) THEN
63108 C...Shift to end junction if a j-j string has been processed.
63109  IF (ijjstr.NE.0) ijus = ipiece(ipc,4)
63110  mrev= 1
63111  ENDIF
63112  i1=i1+1
63113  DO 350 j=1,5
63114  k(i1,j)=0
63115  p(i1,j)=0.
63116  v(i1,j)=0.
63117  350 CONTINUE
63118  k(i1,1)=41
63119  k(ijus,1)=k(ijus,1)+10
63120  k(i1,2)=k(ijus,2)
63121  k(i1,3)=ijus
63122  360 IF (ihk.LT.3) GOTO 280
63123  ELSE
63124  CALL pyerrm(12,'(PYPREP:) Unknown junction type')
63125  mint(51)=1
63126  RETURN
63127  ENDIF
63128  IF (ijucnt.NE.njunc) GOTO 260
63129  ENDIF
63130  n=i1
63131 
63132 C...Rearrange three strings from junction, e.g. in case one has been
63133 C...shortened by shower, so the last is the largest-energy one.
63134  IF(njunc.GE.1) THEN
63135 C...Find systems with exactly one junction.
63136  mjun1=0
63137  nbeg=nold+1
63138  DO 470 i=nold+1,n
63139  IF(k(i,1).NE.1.AND.k(i,1).NE.41) THEN
63140  ELSEIF(k(i,1).EQ.41) THEN
63141  mjun1=mjun1+1
63142  ELSEIF(k(i,1).EQ.1.AND.mjun1.NE.1) THEN
63143  mjun1=0
63144  nbeg=i+1
63145  ELSE
63146  nend=i
63147 C...Sum up energy-momentum in each junction string.
63148  DO 370 j=1,5
63149  pju(1,j)=0d0
63150  pju(2,j)=0d0
63151  pju(3,j)=0d0
63152  370 CONTINUE
63153  nju=0
63154  DO 390 i1=nbeg,nend
63155  IF(k(i1,2).NE.21) THEN
63156  nju=nju+1
63157  ijur(nju)=i1
63158  ENDIF
63159  DO 380 j=1,5
63160  pju(min(nju,3),j)=pju(min(nju,3),j)+p(i1,j)
63161  380 CONTINUE
63162  390 CONTINUE
63163 C...Find which of them has highest energy (minus mass) in rest frame.
63164  DO 400 j=1,5
63165  pju(4,j)=pju(1,j)+pju(2,j)+pju(3,j)
63166  400 CONTINUE
63167  pmju=sqrt(max(0d0,pju(4,4)**2-pju(4,1)**2-pju(4,2)**2-
63168  & pju(4,3)**2))
63169  DO 410 i2=1,3
63170  pju(i2,6)=(pju(4,4)*pju(i2,4)-pju(4,1)*pju(i2,1)-
63171  & pju(4,2)*pju(i2,2)-pju(4,3)*pju(i2,3))/pmju-pju(i2,5)
63172  410 CONTINUE
63173  IF(pju(3,6).LT.min(pju(1,6),pju(2,6))) THEN
63174 C...Decide how to rearrange so that new last has highest energy.
63175  IF(pju(1,6).LT.pju(2,6)) THEN
63176  irng(1,1)=ijur(1)
63177  irng(1,2)=ijur(2)-1
63178  irng(2,1)=ijur(4)
63179  irng(2,2)=ijur(3)+1
63180  irng(4,1)=ijur(3)-1
63181  irng(4,2)=ijur(2)
63182  ELSE
63183  irng(1,1)=ijur(4)
63184  irng(1,2)=ijur(3)+1
63185  irng(2,1)=ijur(2)
63186  irng(2,2)=ijur(3)-1
63187  irng(4,1)=ijur(2)-1
63188  irng(4,2)=ijur(1)
63189  ENDIF
63190  irng(3,1)=ijur(3)
63191  irng(3,2)=ijur(3)
63192 C...Copy in correct order below bottom of current event record.
63193  i2=n
63194  DO 440 ii=1,4
63195  DO 430 i1=irng(ii,1),irng(ii,2),
63196  & isign(1,irng(ii,2)-irng(ii,1))
63197  i2=i2+1
63198  IF(i2.GE.mstu(4)-mstu32-5) THEN
63199  CALL pyerrm(11,
63200  & '(PYPREP:) no more memory left in PYJETS')
63201  mint(51)=1
63202  mstu(24)=1
63203  RETURN
63204  ENDIF
63205  DO 420 j=1,5
63206  k(i2,j)=k(i1,j)
63207  p(i2,j)=p(i1,j)
63208  v(i2,j)=v(i1,j)
63209  420 CONTINUE
63210  IF(k(i2,1).EQ.1) k(i2,1)=2
63211  430 CONTINUE
63212  440 CONTINUE
63213  k(i2,1)=1
63214 C...Copy back up, overwriting but now in correct order.
63215  DO 460 i1=nbeg,nend
63216  i2=i1-nbeg+n+1
63217  DO 450 j=1,5
63218  k(i1,j)=k(i2,j)
63219  p(i1,j)=p(i2,j)
63220  v(i1,j)=v(i2,j)
63221  450 CONTINUE
63222  460 CONTINUE
63223  ENDIF
63224  mjun1=0
63225  nbeg=i+1
63226  ENDIF
63227  470 CONTINUE
63228 
63229 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63230 C...to two q-qbar systems.
63231 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63232  IF (mstj(19).NE.1) THEN
63233  mjun1 = 0
63234  jjglue = 0
63235  nbeg = nold+1
63236 C...Force collapse when MSTJ(19)=2.
63237  IF (mstj(19).EQ.2) THEN
63238  delmjj = 1d9
63239  delmqq = 0d0
63240  ENDIF
63241 C...Find systems with exactly two junctions.
63242  DO 700 i=nold+1,n
63243 C...Count junctions
63244  IF (k(i,1).EQ.41) THEN
63245  mjun1 = mjun1+1
63246 C...Check for interjunction gluons
63247  IF (mjun1.EQ.2.AND.k(i-1,1).NE.41) THEN
63248  jjglue = 1
63249  ENDIF
63250  ELSEIF(k(i,1).EQ.1.AND.(mjun1.NE.2)) THEN
63251 C...If end of system reached with either zero or one junction, restart
63252 C...with next system.
63253  mjun1 = 0
63254  jjglue = 0
63255  nbeg = i+1
63256  ELSEIF(k(i,1).EQ.1) THEN
63257 C...If end of system reached with exactly two junctions, compute string
63258 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63259 C...length measure for the (q-qbar)(q-qbar) topology.
63260  nend=i
63261 C...Loop down through chain.
63262  isid=0
63263  DO 480 i1=nbeg,nend
63264 C...Store string piece division locations in event record
63265  IF (k(i1,2).NE.21) THEN
63266  isid = isid+1
63267  ijcp(isid) = i1
63268  ENDIF
63269  480 CONTINUE
63270 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63271  isw=0
63272  IF (pyr(0).LT.0.5d0) isw=1
63273 C...Randomly choose which qqbar string gets the jj gluons.
63274  igs=1
63275  IF (pyr(0).GT.0.5d0) igs=2
63276 C...Only compute string lengths when no topology forced.
63277  IF (mstj(19).EQ.0) THEN
63278 C...Repeat following for each junction
63279  DO 570 iju=1,2
63280 C...Initialize iterative procedure for finding JRF
63281  ijrfit=0
63282  DO 490 ix=1,3
63283  tjuold(ix)=0d0
63284  490 CONTINUE
63285  tjuold(4)=1d0
63286 C...Start iteration. Sum up momenta in string pieces
63287  500 DO 540 ijs=1,3
63288 C...JD=-1 for first junction, +1 for second junction.
63289 C...Find out where piece starts and ends and which direction to go.
63290  jd=2*iju-3
63291  IF (ijs.LE.2) THEN
63292  ia = ijcp((iju-1)*7 - jd*(ijs+1)) + jd
63293  ib = ijcp((iju-1)*7 - jd*ijs)
63294  ELSEIF (ijs.EQ.3) THEN
63295  jd =-jd
63296  ia = ijcp((iju-1)*7 + jd*(ijs)) + jd
63297  ib = ijcp((iju-1)*7 + jd*(ijs+3))
63298  ENDIF
63299 C...Initialize junction pull 4-vector.
63300  DO 510 j=1,5
63301  pul(ijs,j)=0d0
63302  510 CONTINUE
63303 C...Initialize weight
63304  pwt = 0d0
63305  pwtold = 0d0
63306 C...Sum up (weighted) momenta along each string piece
63307  DO 530 isp=ia,ib,jd
63308 C...If present parton not last in chain
63309  IF (isp.NE.ia.AND.isp.NE.ib) THEN
63310 C...If last parton was a junction, store present weight
63311  IF (k(isp-jd,2).EQ.88) THEN
63312  pwtold = pwt
63313 C...If last parton was a quark, reset to stored weight.
63314  ELSEIF (k(isp-jd,2).NE.21) THEN
63315  pwt = pwtold
63316  ENDIF
63317  ENDIF
63318 C...Skip next parton if weight already large
63319  IF (pwt.GT.10d0) GOTO 530
63320 C...Compute momentum in TJUOLD frame:
63321  tdp=tjuold(1)*p(isp,1)+tjuold(2)*p(isp,2)+tjuold(3
63322  & )*p(isp,3)
63323  bfc=tdp/(1d0+tjuold(4))+p(isp,4)
63324  DO 520 j=1,3
63325  tmp=p(isp,j)+tjuold(j)*bfc
63326  pul(ijs,j)=pul(ijs,j)+tmp*exp(-pwt)
63327  520 CONTINUE
63328 C...Boosted energy
63329  tmp=tjuold(4)*p(isp,4)+tdp
63330  pul(ijs,4)=pul(ijs,j)+tmp*exp(-pwt)
63331 C...Update weight
63332  pwt=pwt+tmp/parj(48)
63333 C...Put |p| rather than m in 5th slot
63334  pul(ijs,5)=sqrt(pul(ijs,1)**2+pul(ijs,2)**2
63335  & +pul(ijs,3)**2)
63336  530 CONTINUE
63337  540 CONTINUE
63338 C...Compute boost
63339  ijrfit=ijrfit+1
63340  CALL pyjurf(pul,t)
63341 C...Combine new boost (T) with old boost (TJUOLD)
63342  tmp=t(1)*tjuold(1)+t(2)*tjuold(2)+t(3)*tjuold(3)
63343  DO 550 ix=1,3
63344  tjuold(ix)=t(ix)+tjuold(ix)*(tmp/(1d0+tjuold(4))+t(4
63345  & ))
63346  550 CONTINUE
63347  tjuold(4)=sqrt(1d0+tjuold(1)**2+tjuold(2)**2+tjuold(3)
63348  & **2)
63349 C...If last boost small, accept JRF, else iterate.
63350 C...Also prevent possibility of infinite loop.
63351  IF (abs((t(4)-1d0)/tjuold(4)).GT.0.01d0.AND.
63352  & ijrfit.LT.mstj(18))THEN
63353  GOTO 500
63354  ELSEIF (ijrfit.GE.mstj(18)) THEN
63355  CALL pyerrm(1,'(PYPREP:) failed to converge on JRF')
63356  ENDIF
63357 C...Store final boost, with change of sign since TJJ motion vector.
63358  DO 560 ix=1,3
63359  tjj(iju,ix)=-tjuold(ix)
63360  560 CONTINUE
63361  tjj(iju,4)=sqrt(1d0+tjj(iju,1)**2+tjj(iju,2)**2
63362  & +tjj(iju,3)**2)
63363  570 CONTINUE
63364 C...String length measure for (q-qbar)(q-qbar) topology.
63365 C...Note only momenta of nearest partons used (since rest of system
63366 C...identical).
63367  IF (jjglue.EQ.0) THEN
63368  delmqq=4d0*four(ijcp(2)-1,ijcp(4+isw)+1)*four(ijcp(3)
63369  & -1,ijcp(5-isw)+1)
63370  ELSE
63371 C...Put jj gluons on selected string (IGS selected randomly above).
63372  IF (igs.EQ.1) THEN
63373  delmqq=8d0*four(ijcp(2)-1,ijcp(4)-1)*four(ijcp(3)+1
63374  & ,ijcp(4+isw)+1)*four(ijcp(3)-1,ijcp(5-isw)+1)
63375  ELSE
63376  delmqq=8d0*four(ijcp(2)-1,ijcp(4+isw)+1)
63377  & *four(ijcp(3)-1,ijcp(4)-1)*four(ijcp(3)+1
63378  & ,ijcp(5-isw)+1)
63379  ENDIF
63380  ENDIF
63381 C...String length measure for q-q-j-j-q-q topology.
63382  t1g1=0d0
63383  t2g2=0d0
63384  t1t2=0d0
63385  t1p1=0d0
63386  t1p2=0d0
63387  t2p3=0d0
63388  t2p4=0d0
63389  isgn=-1
63390 C...Note only momenta of nearest partons used (since rest of system
63391 C...identical).
63392  DO 580 ix=1,4
63393  IF (ix.EQ.4) isgn=1
63394  t1p1=t1p1+isgn*tjj(1,ix)*p(ijcp(2)-1,ix)
63395  t1p2=t1p2+isgn*tjj(1,ix)*p(ijcp(3)-1,ix)
63396  t2p3=t2p3+isgn*tjj(2,ix)*p(ijcp(4)+1,ix)
63397  t2p4=t2p4+isgn*tjj(2,ix)*p(ijcp(5)+1,ix)
63398  IF (jjglue.EQ.0) THEN
63399 C...Junction motion vector dot product gives length when inter-junction
63400 C...gluons absent.
63401  t1t2=t1t2+isgn*tjj(1,ix)*tjj(2,ix)
63402  ELSE
63403 C...Junction motion vector dot products with gluon momenta give length
63404 C...when inter-junction gluons present.
63405  t1g1=t1g1+isgn*tjj(1,ix)*p(ijcp(3)+1,ix)
63406  t2g2=t2g2+isgn*tjj(2,ix)*p(ijcp(4)-1,ix)
63407  ENDIF
63408  580 CONTINUE
63409  delmjj=16d0*t1p1*t1p2*t2p3*t2p4
63410  IF (jjglue.EQ.0) THEN
63411  delmjj=delmjj*(t1t2+sqrt(t1t2**2-1))
63412  ELSE
63413  delmjj=delmjj*4d0*t1g1*t2g2
63414  ENDIF
63415  ENDIF
63416 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63417 C...(Always the case for MSTJ(19)=2 due to initialization above)
63418  IF (delmjj.GT.delmqq) THEN
63419 C...Put new system at end of event record
63420  ncop=n
63421  DO 650 ist=1,2
63422  DO 600 icop=ijcp(ist),ijcp(ist+1)-1
63423  ncop=ncop+1
63424  DO 590 ix=1,5
63425  p(ncop,ix)=p(icop,ix)
63426  k(ncop,ix)=k(icop,ix)
63427  590 CONTINUE
63428  600 CONTINUE
63429  IF (jjglue.NE.0.AND.ist.EQ.igs) THEN
63430 C...Insert inter-junction gluon string piece (reversed)
63431  njjgl=0
63432  DO 620 icop=ijcp(4)-1,ijcp(3)+1,-1
63433  njjgl=njjgl+1
63434  ncop=ncop+1
63435  DO 610 ix=1,5
63436  p(ncop,ix)=p(icop,ix)
63437  k(ncop,ix)=k(icop,ix)
63438  610 CONTINUE
63439  620 CONTINUE
63440  ENDIF
63441  ifc=-2*ist+3
63442  DO 640 icop=ijcp(ist+ifc*isw+3)+1,ijcp(ist+ifc*isw+4)
63443  ncop=ncop+1
63444  DO 630 ix=1,5
63445  p(ncop,ix)=p(icop,ix)
63446  k(ncop,ix)=k(icop,ix)
63447  630 CONTINUE
63448  640 CONTINUE
63449  k(ncop,1)=1
63450  650 CONTINUE
63451 C...Copy system back in right order
63452  DO 670 icop=nbeg,nend-2
63453  DO 660 ix=1,5
63454  p(icop,ix)=p(n+icop-nbeg+1,ix)
63455  k(icop,ix)=k(n+icop-nbeg+1,ix)
63456  660 CONTINUE
63457  670 CONTINUE
63458 C...Shift down rest of event record
63459  DO 690 icop=nend+1,n
63460  DO 680 ix=1,5
63461  p(icop-2,ix)=p(icop,ix)
63462  k(icop-2,ix)=k(icop,ix)
63463  680 CONTINUE
63464  690 CONTINUE
63465 C...Update length of event record.
63466  n=n-2
63467  ENDIF
63468  mjun1=0
63469  nbeg=i+1
63470  ENDIF
63471  700 CONTINUE
63472  ENDIF
63473  ENDIF
63474 
63475 C...Done if no checks on small-mass systems.
63476  IF(mstj(14).LT.0) RETURN
63477  IF(mstj(14).EQ.0) GOTO 1140
63478 
63479 C...Find lowest-mass colour singlet jet system.
63480  ns=n
63481  710 nsin=n-ns
63482  pdmin=1d0+parj(32)
63483  ic=0
63484  DO 770 i=max(1,ip),n
63485  IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
63486  ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
63487  nsin=nsin+1
63488  ic=i
63489  DO 720 j=1,4
63490  dps(j)=p(i,j)
63491  720 CONTINUE
63492  mstj(93)=1
63493  dps(5)=pymass(k(i,2))
63494  ELSEIF(k(i,1).EQ.2.AND.k(i,2).NE.21) THEN
63495  DO 730 j=1,4
63496  dps(j)=dps(j)+p(i,j)
63497  730 CONTINUE
63498  mstj(93)=1
63499  dps(5)=dps(5)+pymass(k(i,2))
63500  ELSEIF(k(i,1).EQ.2) THEN
63501  DO 740 j=1,4
63502  dps(j)=dps(j)+p(i,j)
63503  740 CONTINUE
63504  ELSEIF(ic.NE.0.AND.kchg(pycomp(k(i,2)),2).NE.0) THEN
63505  DO 750 j=1,4
63506  dps(j)=dps(j)+p(i,j)
63507  750 CONTINUE
63508  mstj(93)=1
63509  dps(5)=dps(5)+pymass(k(i,2))
63510  pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-
63511  & dps(5)
63512  IF(pd.LT.pdmin) THEN
63513  pdmin=pd
63514  DO 760 j=1,5
63515  dpc(j)=dps(j)
63516  760 CONTINUE
63517  ic1=ic
63518  ic2=i
63519  ENDIF
63520  ic=0
63521  ELSE
63522  nsin=nsin+1
63523  ENDIF
63524  770 CONTINUE
63525 
63526 C...Done if lowest-mass system above threshold for string frag.
63527  IF(pdmin.GE.parj(32)) GOTO 1140
63528 
63529 C...Fill small-mass system as cluster.
63530  nsav=n
63531  pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
63532  k(n+1,1)=11
63533  k(n+1,2)=91
63534  k(n+1,3)=ic1
63535  p(n+1,1)=dpc(1)
63536  p(n+1,2)=dpc(2)
63537  p(n+1,3)=dpc(3)
63538  p(n+1,4)=dpc(4)
63539  p(n+1,5)=pecm
63540 
63541 C...Set up history, assuming cluster -> 2 hadrons.
63542  nbody=2
63543  k(n+1,4)=n+2
63544  k(n+1,5)=n+3
63545  k(n+2,1)=1
63546  k(n+3,1)=1
63547  IF(mstu(16).NE.2) THEN
63548  k(n+2,3)=n+1
63549  k(n+3,3)=n+1
63550  ELSE
63551  k(n+2,3)=ic1
63552  k(n+3,3)=ic2
63553  ENDIF
63554  k(n+2,4)=0
63555  k(n+3,4)=0
63556  k(n+2,5)=0
63557  k(n+3,5)=0
63558  v(n+1,5)=0d0
63559  v(n+2,5)=0d0
63560  v(n+3,5)=0d0
63561 
63562 C...Find total flavour content - complicated by presence of junctions.
63563  nq=0
63564  ndiq=0
63565  DO 780 i=ic1,ic2
63566  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.k(i,2).NE.21) THEN
63567  nq=nq+1
63568  kfq(nq)=k(i,2)
63569  IF(iabs(k(i,2)).GT.1000) ndiq=ndiq+1
63570  ENDIF
63571  780 CONTINUE
63572 
63573 C...If several diquarks, split up one to give even number of flavours.
63574  IF(nq.EQ.3.AND.ndiq.GE.2) THEN
63575  i1=3
63576  IF(iabs(kfq(3)).LT.1000) i1=1
63577  kfq(4)=isign(mod(iabs(kfq(i1))/100,10),kfq(i1))
63578  kfq(i1)=kfq(i1)/1000
63579  nq=4
63580  ndiq=ndiq-1
63581  ENDIF
63582 
63583 C...If four quark ends, join two to diquark.
63584  IF(nq.EQ.4.AND.ndiq.EQ.0) THEN
63585  i1=1
63586  i2=2
63587  IF(kfq(i1)*kfq(i2).LT.0) i2=3
63588  IF(i2.EQ.3.AND.kfq(i1)*kfq(i2).LT.0) i2=4
63589  kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
63590  IF(kfq(i1).EQ.kfq(i2)) kfls=3
63591  kfq(i1)=isign(1000*max(iabs(kfq(i1)),iabs(kfq(i2)))+
63592  & 100*min(iabs(kfq(i1)),iabs(kfq(i2)))+kfls,kfq(i1))
63593  kfq(i2)=kfq(4)
63594  nq=3
63595  ndiq=1
63596  ENDIF
63597 
63598 C...If two quark ends, plus quark or diquark, join quarks to diquark.
63599  IF(nq.EQ.3) THEN
63600  i1=1
63601  i2=2
63602  IF(iabs(kfq(i1)).GT.1000) i1=3
63603  IF(iabs(kfq(i2)).GT.1000) i2=3
63604  kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
63605  IF(kfq(i1).EQ.kfq(i2)) kfls=3
63606  kfq(i1)=isign(1000*max(iabs(kfq(i1)),iabs(kfq(i2)))+
63607  & 100*min(iabs(kfq(i1)),iabs(kfq(i2)))+kfls,kfq(i1))
63608  kfq(i2)=kfq(3)
63609  nq=2
63610  ndiq=ndiq+1
63611  ENDIF
63612 
63613 C...Form two particles from flavours of lowest-mass system, if feasible.
63614  ntry = 0
63615  790 ntry = ntry + 1
63616 
63617 C...Open string with two specified endpoint flavours.
63618  IF(nq.EQ.2) THEN
63619  kc1=pycomp(kfq(1))
63620  kc2=pycomp(kfq(2))
63621  IF(kc1.EQ.0.OR.kc2.EQ.0) GOTO 1140
63622  kq1=kchg(kc1,2)*isign(1,kfq(1))
63623  kq2=kchg(kc2,2)*isign(1,kfq(2))
63624  IF(kq1+kq2.NE.0) GOTO 1140
63625 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63626  800 k1=kfq(1)
63627  IF(iabs(kfq(2)).GT.1000) k1=kfq(2)
63628  mstu(125)=0
63629  CALL pydcyk(k1,0,kfln,k(n+2,2))
63630  CALL pydcyk(kfq(1)+kfq(2)-k1,-kfln,kfldmp,k(n+3,2))
63631  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 800
63632 
63633 C...Open string with four specified flavours.
63634  ELSEIF(nq.EQ.4) THEN
63635  kc1=pycomp(kfq(1))
63636  kc2=pycomp(kfq(2))
63637  kc3=pycomp(kfq(3))
63638  kc4=pycomp(kfq(4))
63639  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) GOTO 1140
63640  kq1=kchg(kc1,2)*isign(1,kfq(1))
63641  kq2=kchg(kc2,2)*isign(1,kfq(2))
63642  kq3=kchg(kc3,2)*isign(1,kfq(3))
63643  kq4=kchg(kc4,2)*isign(1,kfq(4))
63644  IF(kq1+kq2+kq3+kq4.NE.0) GOTO 1140
63645 C...Combine flavours pairwise to form two hadrons.
63646  810 i1=1
63647  i2=2
63648  IF(kq1*kq2.GT.0.OR.(iabs(kfq(1)).GT.1000.AND.
63649  & iabs(kfq(2)).GT.1000)) i2=3
63650  IF(i2.EQ.3.AND.(kq1*kq3.GT.0.OR.(iabs(kfq(1)).GT.1000.AND.
63651  & iabs(kfq(3)).GT.1000))) i2=4
63652  i3=3
63653  IF(i2.EQ.3) i3=2
63654  i4=10-i1-i2-i3
63655  CALL pydcyk(kfq(i1),kfq(i2),kfldmp,k(n+2,2))
63656  CALL pydcyk(kfq(i3),kfq(i4),kfldmp,k(n+3,2))
63657  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 810
63658 
63659 C...Closed string.
63660  ELSE
63661  IF(iabs(k(ic2,2)).NE.21) GOTO 1140
63662 C...No room for popcorn mesons in closed string -> 2 hadrons.
63663  mstu(125)=0
63664  820 CALL pydcyk(1+int((2d0+parj(2))*pyr(0)),0,kfln,kfdmp)
63665  CALL pydcyk(kfln,0,kflm,k(n+2,2))
63666  CALL pydcyk(-kfln,-kflm,kfldmp,k(n+3,2))
63667  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 820
63668  ENDIF
63669  p(n+2,5)=pymass(k(n+2,2))
63670  p(n+3,5)=pymass(k(n+3,2))
63671 
63672 C...If it does not work: try again (a number of times), give up (if no
63673 C...place to shuffle momentum or too many flavours), or form one hadron.
63674  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) THEN
63675  IF(ntry.LT.mstj(17).OR.(nq.EQ.4.AND.ntry.LT.5*mstj(17))) THEN
63676  GOTO 790
63677  ELSEIF(nsin.EQ.1.OR.nq.EQ.4) THEN
63678  GOTO 1140
63679  ELSE
63680  GOTO 890
63681  END IF
63682  END IF
63683 
63684 C...Perform two-particle decay of jet system.
63685 C...First step: find reference axis in decaying system rest frame.
63686 C...(Borrow slot N+2 for temporary direction.)
63687  DO 830 j=1,4
63688  p(n+2,j)=p(ic1,j)
63689  830 CONTINUE
63690  DO 850 i=ic1+1,ic2-1
63691  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
63692  & kchg(pycomp(k(i,2)),2).NE.0) THEN
63693  frac1=four(ic2,i)/(four(ic1,i)+four(ic2,i))
63694  DO 840 j=1,4
63695  p(n+2,j)=p(n+2,j)+frac1*p(i,j)
63696  840 CONTINUE
63697  ENDIF
63698  850 CONTINUE
63699  CALL pyrobo(n+2,n+2,0d0,0d0,-dpc(1)/dpc(4),-dpc(2)/dpc(4),
63700  &-dpc(3)/dpc(4))
63701  the1=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
63702  phi1=pyangl(p(n+2,1),p(n+2,2))
63703 
63704 C...Second step: generate isotropic/anisotropic decay.
63705  pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
63706  &(p(n+2,5)-p(n+3,5))**2))/(2d0*pecm)
63707  860 ue(3)=pyr(0)
63708  IF(parj(21).LE.0.01d0) ue(3)=1d0
63709  pt2=(1d0-ue(3)**2)*pa**2
63710  IF(mstj(16).LE.0) THEN
63711  prev=0.5d0
63712  ELSE
63713  IF(exp(-pt2/(2d0*max(0.01d0,parj(21))**2)).LT.pyr(0)) GOTO 860
63714  pr1=p(n+2,5)**2+pt2
63715  pr2=p(n+3,5)**2+pt2
63716  alambd=sqrt(max(0d0,(pecm**2-pr1-pr2)**2-4d0*pr1*pr2))
63717  prevcf=parj(42)
63718  IF(mstj(11).EQ.2) prevcf=parj(39)
63719  prev=1d0/(1d0+exp(min(50d0,prevcf*alambd*parj(40))))
63720  ENDIF
63721  IF(pyr(0).LT.prev) ue(3)=-ue(3)
63722  phi=paru(2)*pyr(0)
63723  ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
63724  ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
63725  DO 870 j=1,3
63726  p(n+2,j)=pa*ue(j)
63727  p(n+3,j)=-pa*ue(j)
63728  870 CONTINUE
63729  p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
63730  p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
63731 
63732 C...Third step: move back to event frame and set production vertex.
63733  CALL pyrobo(n+2,n+3,the1,phi1,dpc(1)/dpc(4),dpc(2)/dpc(4),
63734  &dpc(3)/dpc(4))
63735  DO 880 j=1,4
63736  v(n+1,j)=v(ic1,j)
63737  v(n+2,j)=v(ic1,j)
63738  v(n+3,j)=v(ic2,j)
63739  880 CONTINUE
63740  n=n+3
63741  GOTO 1120
63742 
63743 C...Else form one particle, if possible.
63744  890 nbody=1
63745  k(n+1,5)=n+2
63746  DO 900 j=1,4
63747  v(n+1,j)=v(ic1,j)
63748  v(n+2,j)=v(ic1,j)
63749  900 CONTINUE
63750 
63751 C...Select hadron flavour from available quark flavours.
63752  910 IF(nq.EQ.2.AND.iabs(kfq(1)).GT.100.AND.iabs(kfq(2)).GT.100) THEN
63753  GOTO 1140
63754  ELSEIF(nq.EQ.2) THEN
63755  CALL pykfdi(kfq(1),kfq(2),kfldmp,k(n+2,2))
63756  ELSE
63757  kfln=1+int((2d0+parj(2))*pyr(0))
63758  CALL pykfdi(kfln,-kfln,kfldmp,k(n+2,2))
63759  ENDIF
63760  IF(k(n+2,2).EQ.0) GOTO 910
63761  p(n+2,5)=pymass(k(n+2,2))
63762 
63763 C...Use old algorithm for E/p conservation? (EN)
63764  IF (mstj(16).LE.0) GOTO 1080
63765 
63766 C...Find the string piece closest to the cluster by a loop
63767 C...over the undecayed partons not in present cluster. (EN)
63768  dglomi=1d30
63769  ibeg=0
63770  i0=0
63771  njunc=0
63772  DO 940 i1=max(1,ip),n-1
63773  IF(k(i1,1).EQ.1) njunc=0
63774  IF(k(i1,1).EQ.41) njunc=njunc+1
63775  IF(k(i1,1).EQ.41) GOTO 940
63776  IF(i1.GE.ic1-1.AND.i1.LE.ic2) THEN
63777  i0=0
63778  ELSEIF(k(i1,1).EQ.2) THEN
63779  IF(i0.EQ.0) i0=i1
63780  i2=i1
63781  920 i2=i2+1
63782  IF(k(i2,1).EQ.41) GOTO 940
63783  IF(k(i2,1).GT.10) GOTO 920
63784  IF(kchg(pycomp(k(i2,2)),2).EQ.0) GOTO 920
63785  IF(k(i1,2).EQ.21.AND.k(i2,2).NE.21.AND.k(i2,1).NE.1.AND.
63786  & njunc.EQ.0) GOTO 940
63787  IF(k(i1,2).NE.21.AND.k(i2,2).EQ.21.AND.njunc.NE.0) GOTO 940
63788  IF(k(i1,2).NE.21.AND.k(i2,2).NE.21.AND.(i1.GT.i0.OR.
63789  & k(i2,1).NE.1)) GOTO 940
63790 
63791 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63792  DO 930 j=1,3
63793  e1(j)=p(i1,j)/p(i1,4)
63794  e2(j)=p(i2,j)/p(i2,4)
63795  ecl(j)=p(n+1,j)/p(n+1,4)
63796  e3(j)=e2(j)-e1(j)
63797  e4(j)=ecl(j)-e1(j)
63798  930 CONTINUE
63799 
63800 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63801  e3s=e3(1)**2+e3(2)**2+e3(3)**2
63802  e4s=e4(1)**2+e4(2)**2+e4(3)**2
63803  e34=e3(1)*e4(1)+e3(2)*e4(2)+e3(3)*e4(3)
63804  IF(e34.LE.0d0) THEN
63805  ddmin=e4s
63806  ELSEIF(e34.LT.e3s) THEN
63807  ddmin=e4s-e34**2/e3s
63808  ELSE
63809  ddmin=e4s-2d0*e34+e3s
63810  ENDIF
63811 
63812 C...Is this the smallest so far?
63813  IF(ddmin.LT.dglomi) THEN
63814  dglomi=ddmin
63815  ibeg=i0
63816  ipcs=i1
63817  ENDIF
63818  ELSEIF(k(i1,1).EQ.1.AND.kchg(pycomp(k(i1,2)),2).NE.0) THEN
63819  i0=0
63820  ENDIF
63821  940 CONTINUE
63822 
63823 C... Check if there are any strings to connect to the new gluon. (EN)
63824  IF (ibeg.EQ.0) GOTO 1080
63825 
63826 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63827  IF (p(n+1,5).GE.p(n+2,5)) THEN
63828 
63829 C...Construct 'gluon' that is needed to put hadron on the mass shell.
63830  frac=p(n+2,5)/p(n+1,5)
63831  DO 950 j=1,5
63832  p(n+2,j)=frac*p(n+1,j)
63833  pg(j)=(1d0-frac)*p(n+1,j)
63834  950 CONTINUE
63835 
63836 C... Copy string with new gluon put in.
63837  n=n+2
63838  i=ibeg-1
63839  960 i=i+1
63840  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 960
63841  IF(kchg(pycomp(k(i,2)),2).EQ.0.AND.k(i,1).NE.41) GOTO 960
63842  n=n+1
63843  DO 970 j=1,5
63844  k(n,j)=k(i,j)
63845  p(n,j)=p(i,j)
63846  v(n,j)=v(i,j)
63847  970 CONTINUE
63848  k(i,1)=k(i,1)+10
63849  k(i,4)=n
63850  k(i,5)=n
63851  k(n,3)=i
63852  IF(i.EQ.ipcs) THEN
63853  n=n+1
63854  DO 980 j=1,5
63855  k(n,j)=k(n-1,j)
63856  p(n,j)=pg(j)
63857  v(n,j)=v(n-1,j)
63858  980 CONTINUE
63859  k(n,2)=21
63860  k(n,3)=nsav+1
63861  ENDIF
63862  IF(k(i,1).EQ.12.OR.k(i,1).EQ.51) GOTO 960
63863  GOTO 1120
63864 
63865 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
63866 C...from string piece endpoints.
63867  ELSE
63868 
63869 C...Begin by copying string that should give energy to cluster.
63870  n=n+2
63871  i=ibeg-1
63872  990 i=i+1
63873  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 990
63874  IF(kchg(pycomp(k(i,2)),2).EQ.0.AND.k(i,1).NE.41) GOTO 990
63875  n=n+1
63876  DO 1000 j=1,5
63877  k(n,j)=k(i,j)
63878  p(n,j)=p(i,j)
63879  v(n,j)=v(i,j)
63880  1000 CONTINUE
63881  k(i,1)=k(i,1)+10
63882  k(i,4)=n
63883  k(i,5)=n
63884  k(n,3)=i
63885  IF(i.EQ.ipcs) i1=n
63886  IF(k(i,1).EQ.12.OR.k(i,1).EQ.51) GOTO 990
63887  i2=i1+1
63888 
63889 C...Set initial Phad.
63890  DO 1010 j=1,4
63891  p(nsav+2,j)=p(nsav+1,j)
63892  1010 CONTINUE
63893 
63894 C...Calculate Pg, a part of which will be added to Phad later. (EN)
63895  1020 IF(mstj(16).EQ.1) THEN
63896  alpha=1d0
63897  beta=1d0
63898  ELSE
63899  alpha=four(nsav+1,i2)/four(i1,i2)
63900  beta=four(nsav+1,i1)/four(i1,i2)
63901  ENDIF
63902  DO 1030 j=1,4
63903  pg(j)=alpha*p(i1,j)+beta*p(i2,j)
63904  1030 CONTINUE
63905  pg(5)=sqrt(max(1d-20,pg(4)**2-pg(1)**2-pg(2)**2-pg(3)**2))
63906 
63907 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
63908  pmscol=p(nsav+2,4)**2-p(nsav+2,1)**2-p(nsav+2,2)**2-
63909  & p(nsav+2,3)**2
63910  pclpg=(p(nsav+2,4)*pg(4)-p(nsav+2,1)*pg(1)-
63911  & p(nsav+2,2)*pg(2)-p(nsav+2,3)*pg(3))/pg(5)**2
63912  delta=sqrt(pclpg**2+(p(nsav+2,5)**2-pmscol)/pg(5)**2)-pclpg
63913 
63914 C...If all gluon energy eaten, zero it and take a step back.
63915  iter=0
63916  IF(delta*alpha.GT.1d0.AND.i1.GT.nsav+3.AND.k(i1,2).EQ.21) THEN
63917  iter=1
63918  DO 1040 j=1,4
63919  p(nsav+2,j)=p(nsav+2,j)+p(i1,j)
63920  p(i1,j)=0d0
63921  1040 CONTINUE
63922  p(i1,5)=0d0
63923  k(i1,1)=k(i1,1)+10
63924  i1=i1-1
63925  IF(k(i1,1).EQ.41) iter=-1
63926  ENDIF
63927  IF(delta*beta.GT.1d0.AND.i2.LT.n.AND.k(i2,2).EQ.21) THEN
63928  iter=1
63929  DO 1050 j=1,4
63930  p(nsav+2,j)=p(nsav+2,j)+p(i2,j)
63931  p(i2,j)=0d0
63932  1050 CONTINUE
63933  p(i2,5)=0d0
63934  k(i2,1)=k(i2,1)+10
63935  i2=i2+1
63936  IF(k(i2,1).EQ.41) iter=-1
63937  ENDIF
63938  IF(iter.EQ.1) GOTO 1020
63939 
63940 C...If also all endpoint energy eaten, revert to old procedure.
63941  IF((1d0-delta*alpha)*p(i1,4).LT.p(i1,5).OR.
63942  & (1d0-delta*beta)*p(i2,4).LT.p(i2,5).OR.iter.EQ.-1) THEN
63943  DO 1060 i=nsav+3,n
63944  im=k(i,3)
63945  k(im,1)=k(im,1)-10
63946  k(im,4)=0
63947  k(im,5)=0
63948  1060 CONTINUE
63949  n=nsav
63950  GOTO 1080
63951  ENDIF
63952 
63953 C... Construct the collapsed hadron and modified string partons.
63954  DO 1070 j=1,4
63955  p(nsav+2,j)=p(nsav+2,j)+delta*pg(j)
63956  p(i1,j)=(1d0-delta*alpha)*p(i1,j)
63957  p(i2,j)=(1d0-delta*beta)*p(i2,j)
63958  1070 CONTINUE
63959  p(i1,5)=(1d0-delta*alpha)*p(i1,5)
63960  p(i2,5)=(1d0-delta*beta)*p(i2,5)
63961 
63962 C...Finished with string collapse in new scheme.
63963  GOTO 1120
63964  ENDIF
63965 
63966 C... Use old algorithm; by choice or when in trouble.
63967  1080 CONTINUE
63968 C...Find parton/particle which combines to largest extra mass.
63969  ir=0
63970  ha=0d0
63971  hsm=0d0
63972  DO 1100 mcomb=1,3
63973  IF(ir.NE.0) GOTO 1100
63974  DO 1090 i=max(1,ip),n
63975  IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2
63976  & .AND.k(i,1).GE.1.AND.k(i,1).LE.2)) GOTO 1090
63977  IF(mcomb.EQ.1) kci=pycomp(k(i,2))
63978  IF(mcomb.EQ.1.AND.kci.EQ.0) GOTO 1090
63979  IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) GOTO 1090
63980  IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
63981  & GOTO 1090
63982  hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
63983  hsr=2d0*hcr+pecm**2-p(n+2,5)**2-2d0*p(n+2,5)*p(i,5)
63984  IF(hsr.GT.hsm) THEN
63985  ir=i
63986  ha=hcr
63987  hsm=hsr
63988  ENDIF
63989  1090 CONTINUE
63990  1100 CONTINUE
63991 
63992 C...Shuffle energy and momentum to put new particle on mass shell.
63993  IF(ir.NE.0) THEN
63994  hb=pecm**2+ha
63995  hc=p(n+2,5)**2+ha
63996  hd=p(ir,5)**2+ha
63997  hk2=0.5d0*(hb*sqrt(max(0d0,((hb+hc)**2-4d0*(hb+hd)*p(n+2,5)**2)/
63998  & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
63999  hk1=(0.5d0*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
64000  DO 1110 j=1,4
64001  p(n+2,j)=(1d0+hk1)*dpc(j)-hk2*p(ir,j)
64002  p(ir,j)=(1d0+hk2)*p(ir,j)-hk1*dpc(j)
64003  1110 CONTINUE
64004  n=n+2
64005  ELSE
64006  CALL pyerrm(3,'(PYPREP:) no match for collapsing cluster')
64007  RETURN
64008  ENDIF
64009 
64010 C...Mark collapsed system and store daughter pointers. Iterate.
64011  1120 DO 1130 i=ic1,ic2
64012  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
64013  & kchg(pycomp(k(i,2)),2).NE.0) THEN
64014  k(i,1)=k(i,1)+10
64015  IF(mstu(16).NE.2) THEN
64016  k(i,4)=nsav+1
64017  k(i,5)=nsav+1
64018  ELSE
64019  k(i,4)=nsav+2
64020  k(i,5)=nsav+1+nbody
64021  ENDIF
64022  ENDIF
64023  IF(k(i,1).EQ.41) k(i,1)=k(i,1)+10
64024  1130 CONTINUE
64025  IF(n.LT.mstu(4)-mstu(32)-5) GOTO 710
64026 
64027 C...Check flavours and invariant masses in parton systems.
64028  1140 np=0
64029  kfn=0
64030  kqs=0
64031  nju=0
64032  DO 1150 j=1,5
64033  dps(j)=0d0
64034  1150 CONTINUE
64035  DO 1180 i=max(1,ip),n
64036  IF(k(i,1).EQ.41) nju=nju+1
64037  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 1180
64038  kc=pycomp(k(i,2))
64039  IF(kc.EQ.0) GOTO 1180
64040  kq=kchg(kc,2)*isign(1,k(i,2))
64041  IF(kq.EQ.0) GOTO 1180
64042  np=np+1
64043  IF(kq.NE.2) THEN
64044  kfn=kfn+1
64045  kqs=kqs+kq
64046  mstj(93)=1
64047  dps(5)=dps(5)+pymass(k(i,2))
64048  ENDIF
64049  DO 1160 j=1,4
64050  dps(j)=dps(j)+p(i,j)
64051  1160 CONTINUE
64052  IF(k(i,1).EQ.1) THEN
64053  nferr=0
64054  IF(nju.EQ.0.AND.np.NE.1) THEN
64055  IF(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0) nferr=1
64056  ELSEIF(nju.EQ.1) THEN
64057  IF(kfn.NE.3.OR.iabs(kqs).NE.3) nferr=1
64058  ELSEIF(nju.EQ.2) THEN
64059  IF(kfn.NE.4.OR.kqs.NE.0) nferr=1
64060  ELSEIF(nju.GE.3) THEN
64061  nferr=1
64062  ENDIF
64063  IF(nferr.EQ.1) THEN
64064  CALL pyerrm(2,'(PYPREP:) unphysical flavour combination')
64065  mint(51)=1
64066  RETURN
64067  ENDIF
64068  IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
64069  & (0.9d0*parj(32)+dps(5))**2) CALL pyerrm(3,
64070  & '(PYPREP:) too small mass in jet system')
64071  np=0
64072  kfn=0
64073  kqs=0
64074  nju=0
64075  DO 1170 j=1,5
64076  dps(j)=0d0
64077  1170 CONTINUE
64078  ENDIF
64079  1180 CONTINUE
64080 
64081  RETURN
64082  END
64083 
64084 C*********************************************************************
64085 
64086 C...PYSTRF
64087 C...Handles the fragmentation of an arbitrary colour singlet
64088 C...jet system according to the Lund string fragmentation model.
64089 
64090  SUBROUTINE pystrf(IP)
64091 
64092 C...Double precision and integer declarations.
64093  IMPLICIT DOUBLE PRECISION(a-h, o-z)
64094  IMPLICIT INTEGER(I-N)
64095  INTEGER PYK,PYCHGE,PYCOMP
64096 C...Commonblocks.
64097  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
64098  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
64099  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
64100  SAVE /pyjets/,/pydat1/,/pydat2/
64101 C...Local arrays. All MOPS variables ends with MO
64102  dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
64103  &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(6),pju(5,5),
64104  &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8),
64105  &inmo(9),pm2qmo(2),xtmo(2),ejstr(2),ijuori(2),ibarrk(2),
64106  &pbst(3,5),tjuold(5)
64107 
64108 C...Function: four-product of two vectors.
64109  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)
64110  dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
64111  &dp(i,3)*dp(j,3)
64112 
64113 C...Reset counters.
64114  mstj(91)=0
64115  nsav=n
64116  mstu90=mstu(90)
64117  np=0
64118  kqsum=0
64119  DO 100 j=1,5
64120  dps(j)=0d0
64121  100 CONTINUE
64122  mju(1)=0
64123  mju(2)=0
64124  ntryfn=0
64125  ijuori(1)=0
64126  ijuori(2)=0
64127 
64128 C...Identify parton system.
64129  i=ip-1
64130  110 i=i+1
64131  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
64132  CALL pyerrm(12,'(PYSTRF:) failed to reconstruct jet system')
64133  IF(mstu(21).GE.1) RETURN
64134  ENDIF
64135  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 110
64136  kc=pycomp(k(i,2))
64137  IF(kc.EQ.0) GOTO 110
64138  kq=kchg(kc,2)*isign(1,k(i,2))
64139  IF(kq.EQ.0.AND.k(i,1).NE.41) GOTO 110
64140  IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
64141  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
64142  IF(mstu(21).GE.1) RETURN
64143  ENDIF
64144 
64145 C...Take copy of partons to be considered. Check flavour sum.
64146  np=np+1
64147  DO 120 j=1,5
64148  k(n+np,j)=k(i,j)
64149  p(n+np,j)=p(i,j)
64150  IF(j.NE.4) dps(j)=dps(j)+p(i,j)
64151  120 CONTINUE
64152  dps(4)=dps(4)+sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
64153  k(n+np,3)=i
64154  IF(kq.NE.2) kqsum=kqsum+kq
64155  IF(k(i,1).EQ.41) THEN
64156  IF(mod(kqsum,2).EQ.0.AND.mju(1).EQ.0) THEN
64157  mju(1)=n+np
64158  ijuori(1)=i
64159  ELSE
64160  mju(2)=n+np
64161  ijuori(2)=i
64162  ENDIF
64163  ENDIF
64164  IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) GOTO 110
64165  IF(mod(kqsum,3).NE.0) THEN
64166  CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')
64167  IF(mstu(21).GE.1) RETURN
64168  ENDIF
64169  IF(mju(1).GT.0.OR.mju(2).GT.0) mstu(29)=1
64170 
64171 C...Boost copied system to CM frame (for better numerical precision).
64172  IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
64173  mbst=0
64174  mstu(33)=1
64175  CALL pyrobo(n+1,n+np,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
64176  & -dps(3)/dps(4))
64177  ELSE
64178  mbst=1
64179  hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
64180  DO 130 i=n+1,n+np
64181  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
64182  IF(p(i,3).GT.0d0) THEN
64183  hhpez=max(1d-10,(p(i,4)+p(i,3))/hhbz)
64184  p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
64185  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
64186  ELSE
64187  hhpez=max(1d-10,(p(i,4)-p(i,3))*hhbz)
64188  p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
64189  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
64190  ENDIF
64191  130 CONTINUE
64192  ENDIF
64193 
64194 C...Search for very nearby partons that may be recombined.
64195  ntryr=0
64196  ntrywr=0
64197  paru12=paru(12)
64198  paru13=paru(13)
64199  mju(3)=mju(1)
64200  mju(4)=mju(2)
64201  nr=np
64202  nrmin=2
64203  IF(mju(1).GT.0) nrmin=nrmin+2
64204  IF(mju(2).GT.0) nrmin=nrmin+2
64205  140 IF(nr.GT.nrmin) THEN
64206  pdrmin=2d0*paru12
64207  DO 150 i=n+1,n+nr
64208  IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) GOTO 150
64209  i1=i+1
64210  IF(i.EQ.n+nr) i1=n+1
64211  IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) GOTO 150
64212  IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
64213  & GOTO 150
64214  IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21)
64215  & GOTO 150
64216  pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
64217  & p(i1,2)**2+p(i1,3)**2))
64218  pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
64219  pdr=4d0*(pap-pvp)**2/max(1d-6,paru13**2*pap+2d0*(pap-pvp))
64220  IF(pdr.LT.pdrmin) THEN
64221  ir=i
64222  pdrmin=pdr
64223  ENDIF
64224  150 CONTINUE
64225 
64226 C...Recombine very nearby partons to avoid machine precision problems.
64227  IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
64228  DO 160 j=1,4
64229  p(n+1,j)=p(n+1,j)+p(n+nr,j)
64230  160 CONTINUE
64231  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
64232  & p(n+1,3)**2))
64233  nr=nr-1
64234  GOTO 140
64235  ELSEIF(pdrmin.LT.paru12) THEN
64236  DO 170 j=1,4
64237  p(ir,j)=p(ir,j)+p(ir+1,j)
64238  170 CONTINUE
64239  p(ir,5)=sqrt(max(0d0,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
64240  & p(ir,3)**2))
64241  IF(mju(2).NE.0.AND.ir.GT.mju(2)) k(ir,2)=k(ir+1,2)
64242  DO 190 i=ir+1,n+nr-1
64243  k(i,1)=k(i+1,1)
64244  k(i,2)=k(i+1,2)
64245  DO 180 j=1,5
64246  p(i,j)=p(i+1,j)
64247  180 CONTINUE
64248  190 CONTINUE
64249  IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
64250  nr=nr-1
64251  IF(mju(1).GT.ir) mju(1)=mju(1)-1
64252  IF(mju(2).GT.ir) mju(2)=mju(2)-1
64253  GOTO 140
64254  ENDIF
64255  ENDIF
64256  ntryr=ntryr+1
64257 
64258 C...Reset particle counter. Skip ahead if no junctions are present;
64259 C...this is usually the case!
64260  nrs=max(5*nr+11,np)
64261  ntry=0
64262  200 ntry=ntry+1
64263  IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
64264  paru12=4d0*paru12
64265  paru13=2d0*paru13
64266  GOTO 140
64267  ELSEIF(ntry.GT.100.OR.ntryr.GT.100) THEN
64268  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
64269  IF(mstu(21).GE.1) RETURN
64270  ENDIF
64271  i=n+nrs
64272  mstu(90)=mstu90
64273  IF(mju(1).EQ.0.AND.mju(2).EQ.0) GOTO 650
64274  IF(mstj(12).GE.4) CALL pyerrm(29,'(PYSTRF:) sorry,'//
64275  & ' junction strings not handled by MSTJ(12)>3 options')
64276  DO 640 jt=1,2
64277  njs(jt)=0
64278  IF(mju(jt).EQ.0) GOTO 640
64279  js=3-2*jt
64280 
64281 C++SKANDS
64282 C...Find and sum up momentum on three sides of junction.
64283 C...Begin with previous boost = zero.
64284  ijrfit=0
64285  DO 210 ix=1,3
64286  tjuold(ix)=0d0
64287  210 CONTINUE
64288 C...Prevent IJU (specifically IJU(5)) from containing junk below
64289  DO 215 iu=1,6
64290  iju(iu)=0
64291  215 CONTINUE
64292  tjuold(4)=1d0
64293  220 iu=0
64294 C...Beginning and end of string system in event record.
64295  i1beg=n+1+(jt-1)*(nr-1)
64296  i1end=n+nr+(jt-1)*(1-nr)
64297 C...Look for junction string piece end points
64298  DO 230 i1=i1beg,i1end,js
64299  IF(k(i1,2).NE.21.AND.iu.LE.5.AND.ijrfit.EQ.0) THEN
64300 C...Store junction string piece end points.
64301 C 1-junction systems 2-junction systems
64302 C IU : 1 2 3 4 1 2 3 4 5 6
64303 C IJU(IU): q-g-g-q-g-g-j-g-q q-g-g-q-g-j-g-g-j-g-q-g-g-q
64304  iu=iu+1
64305  iju(iu)=i1
64306  ENDIF
64307 C...Sum over momenta, from junction outwards.
64308  230 CONTINUE
64309  DO 280 iu=1,3
64310  pwt=0d0
64311 C...Initialize junction drag and string piece 4-vectors.
64312  DO 240 j=1,5
64313  pbst(iu,j)=0d0
64314  pju(iu,j)=0d0
64315  240 CONTINUE
64316 C...First two branches. Inwards out means opposite direction to JS.
64317 C...(JS is 1 for JT=1, -1 for JT=2)
64318  IF (iu.LT.3) THEN
64319  i1a=iju(iu+1)-js
64320  i1b=iju(iu)
64321  idir=-js
64322 C...Last branch (gq or gjgqgq). Direction now reversed.
64323  ELSE
64324  i1a=iju(iu)+js
64325  i1b=i1end
64326  idir=js
64327  ENDIF
64328  DO 270 i1=i1a,i1b,idir
64329 C...Sum up momentum directions with exponential suppression
64330 C...for use in finding junction rest frame below.
64331  IF (k(i1,2).EQ.88) THEN
64332 C...gjgqgq type system encountered. Use current PWT as start
64333 C...for both strings.
64334  pwtold=pwt
64335  ELSE
64336  IF (i1.EQ.iju(5)+idir) pwt=pwtold
64337 C...Sum up string piece (boosted) 4-momenta.
64338  DO 250 j=1,4
64339  pju(iu,j)=pju(iu,j)+p(i1,j)
64340  250 CONTINUE
64341 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64342 C...boost is zero, see above). Skip parton if suppression factor large.
64343  IF (pwt.GT.10d0) GOTO 270
64344 C...Compute momentum in current frame:
64345  tdp=tjuold(1)*p(i1,1)+tjuold(2)*p(i1,2)+tjuold(3)*p(i1,3)
64346  bfc=tdp/(1d0+tjuold(4))+p(i1,4)
64347  DO 260 j=1,3
64348  ptmp=p(i1,j)+tjuold(j)*bfc
64349  pbst(iu,j)=pbst(iu,j)+ptmp*exp(-pwt)
64350  260 CONTINUE
64351 C...Boosted energy
64352  ptmp=tjuold(4)*p(i1,4)+tdp
64353  pbst(iu,4)=pbst(iu,j)+ptmp*exp(-pwt)
64354  pwt=pwt+ptmp/parj(48)
64355  ENDIF
64356  270 CONTINUE
64357 C...Put |p| rather than m in 5th slot.
64358  pbst(iu,5)=sqrt(pbst(iu,1)**2+pbst(iu,2)**2+pbst(iu,3)**2)
64359  pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
64360  280 CONTINUE
64361 
64362 C...Calculate boost from present frame to next JRF candidate.
64363  ijrfit=ijrfit+1
64364  CALL pyjurf(pbst,tju)
64365 
64366 C...After some iterations do not take full step in new direction.
64367  IF(ijrfit.GT.5) THEN
64368  reduce=0.8d0**(ijrfit-5)
64369  tju(1)=reduce*tju(1)
64370  tju(2)=reduce*tju(2)
64371  tju(3)=reduce*tju(3)
64372  tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
64373  ENDIF
64374 
64375 C...Combine new boost (TJU) with old boost (TJUOLD)
64376  tmp=tju(1)*tjuold(1)+tju(2)*tjuold(2)+tju(3)*tjuold(3)
64377  DO 290 ix=1,3
64378  tjuold(ix)=tju(ix)+tjuold(ix)*(tmp/(1d0+tjuold(4))+tju(4))
64379  290 CONTINUE
64380  tjuold(4)=sqrt(1d0+tjuold(1)**2+tjuold(2)**2+tjuold(3)**2)
64381 
64382 C...If last boost small, accept JRF, else iterate.
64383 C...Also prevent possibility of infinite loop.
64384  IF (abs((tju(4)-1d0)/tjuold(4)).GT.0.01d0.AND.
64385  & ijrfit.LT.mstj(18)) THEN
64386  GOTO 220
64387  ELSEIF (ijrfit.GE.mstj(18)) THEN
64388  CALL pyerrm(1,'(PYSTRF:) failed to converge on JRF')
64389  ENDIF
64390 
64391 C...Now store total boost in TJU and change perception.
64392 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64393 C...TJU = junction motion vector in string CM, so the sign changes.
64394  DO 300 j=1,3
64395  tju(j)=-tjuold(j)
64396  300 CONTINUE
64397  tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
64398 
64399 C--SKANDS
64400 
64401 C...Calculate string piece energies in junction rest frame.
64402  DO 310 iu=1,3
64403  pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
64404  & tju(3)*pju(iu,3)
64405  pbst(iu,5)=tju(4)*pbst(iu,4)-tju(1)*pbst(iu,1)-
64406  & tju(2)*pbst(iu,2)-tju(3)*pbst(iu,3)
64407  310 CONTINUE
64408 
64409 C...Start preparing for fragmentation of two strings from junction.
64410  ista=i
64411  ntryer=0
64412  320 ntryer=ntryer+1
64413  i=ista
64414  DO 620 iu=1,2
64415  ns=iabs(iju(iu+1)-iju(iu))
64416 
64417 C...Junction strings: find longitudinal string directions.
64418  DO 350 is=1,ns
64419  is1=iju(iu)+js*(is-1)
64420  is2=iju(iu)+js*is
64421  DO 330 j=1,5
64422  dp(1,j)=0.5d0*p(is1,j)
64423  IF(is.EQ.1) dp(1,j)=p(is1,j)
64424  dp(2,j)=0.5d0*p(is2,j)
64425  IF(is.EQ.ns) dp(2,j)=(-pbst(iu,j)+2d0*pbst(iu,5)*tju(j))*
64426  & (pju(iu,5)/pbst(iu,5))
64427  330 CONTINUE
64428  IF(is.EQ.ns) dp(2,5)=sqrt(max(0d0,pju(iu,4)**2-
64429  & pju(iu,1)**2-pju(iu,2)**2-pju(iu,3)**2))
64430  dp(3,5)=dfour(1,1)
64431  dp(4,5)=dfour(2,2)
64432  dhkc=dfour(1,2)
64433  IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN
64434  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64435  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64436  dp(3,5)=0d0
64437  dp(4,5)=0d0
64438  dhkc=dfour(1,2)
64439  ENDIF
64440  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
64441  dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
64442  dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
64443  in1=n+nr+4*is-3
64444  p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
64445  DO 340 j=1,4
64446  p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
64447  p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
64448  340 CONTINUE
64449  350 CONTINUE
64450 
64451 C...Junction strings: initialize flavour, momentum and starting pos.
64452  isav=i
64453  mstu91=mstu(90)
64454  360 ntry=ntry+1
64455  IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
64456  paru12=4d0*paru12
64457  paru13=2d0*paru13
64458  GOTO 140
64459  ELSEIF(ntry.GT.100) THEN
64460  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
64461  IF(mstu(21).GE.1) RETURN
64462  ENDIF
64463  i=isav
64464  mstu(90)=mstu91
64465  irankj=0
64466  ie(1)=k(n+1+(jt/2)*(np-1),3)
64467  IF (mod(jt+iu,2).NE.0) THEN
64468  ie(1)=k(iju(iu),3)
64469  IF (np-nr.NE.0) THEN
64470 C...If gluons have disappeared. Original IJU must be used.
64471  it=ip
64472  ne=1
64473  370 it=it+1
64474  IF (k(it,2).NE.21) THEN
64475  ne=ne+1
64476  ENDIF
64477  IF (ne.EQ.iu+4*(jt-1)) THEN
64478  ie(1)=it
64479  ELSEIF (it.LE.ip+np) THEN
64480  GOTO 370
64481  ELSE
64482  CALL pyerrm(14,'(PYSTRF:) '//
64483  & 'Original IJU could not be reconstructed!')
64484  ENDIF
64485  ENDIF
64486  ENDIF
64487  in(4)=n+nr+1
64488  in(5)=in(4)+1
64489  in(6)=n+nr+4*ns+1
64490  DO 390 jq=1,2
64491  DO 380 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
64492  p(in1,1)=2-jq
64493  p(in1,2)=jq-1
64494  p(in1,3)=1d0
64495  380 CONTINUE
64496  390 CONTINUE
64497  kfl(1)=k(iju(iu),2)
64498  px(1)=0d0
64499  py(1)=0d0
64500  gam(1)=0d0
64501  DO 400 j=1,5
64502  pju(iu+3,j)=0d0
64503  400 CONTINUE
64504 
64505 C...Junction strings: find initial transverse directions.
64506  DO 410 j=1,4
64507  dp(1,j)=p(in(4),j)
64508  dp(2,j)=p(in(4)+1,j)
64509  dp(3,j)=0d0
64510  dp(4,j)=0d0
64511  410 CONTINUE
64512  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64513  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64514  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
64515  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
64516  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
64517  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
64518  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
64519  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
64520  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
64521  dhc12=dfour(1,2)
64522  dhcx1=dfour(3,1)/dhc12
64523  dhcx2=dfour(3,2)/dhc12
64524  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
64525  dhcy1=dfour(4,1)/dhc12
64526  dhcy2=dfour(4,2)/dhc12
64527  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
64528  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
64529  DO 420 j=1,4
64530  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
64531  p(in(6),j)=dp(3,j)
64532  p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
64533  & dhcyx*dp(3,j))
64534  420 CONTINUE
64535 
64536 C...Junction strings: produce new particle, origin.
64537  430 i=i+1
64538  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
64539  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
64540  IF(mstu(21).GE.1) RETURN
64541  ENDIF
64542  irankj=irankj+1
64543  k(i,1)=1
64544  k(i,3)=ie(1)
64545  k(i,4)=0
64546  k(i,5)=0
64547 
64548 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64549  440 CALL pykfdi(kfl(1),0,kfl(3),k(i,2))
64550  IF(k(i,2).EQ.0) GOTO 360
64551  IF(irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
64552  & iabs(kfl(3)).GT.10) THEN
64553  IF(pyr(0).GT.parj(19)) GOTO 440
64554  ENDIF
64555  p(i,5)=pymass(k(i,2))
64556  CALL pyptdi(kfl(1),px(3),py(3))
64557  pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
64558  CALL pyzdis(kfl(1),kfl(3),pr(1),z)
64559  IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
64560  & mstu(90).LT.8) THEN
64561  mstu(90)=mstu(90)+1
64562  mstu(90+mstu(90))=i
64563  paru(90+mstu(90))=z
64564  ENDIF
64565  gam(3)=(1d0-z)*(gam(1)+pr(1)/z)
64566  DO 450 j=1,3
64567  in(j)=in(3+j)
64568  450 CONTINUE
64569 
64570 C...Junction strings: stepping within 'low' string region.
64571  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
64572  & p(in(1),5)**2.GE.pr(1)) THEN
64573  p(in(1)+2,4)=z*p(in(1)+2,3)
64574  p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
64575  DO 460 j=1,4
64576  p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
64577  460 CONTINUE
64578  GOTO 560
64579 C...Has used up energy of junction string, i.e. no more hadrons in it.
64580  ELSEIF(in(1)+1.EQ.in(2).AND.in(1).EQ.n+nr+4*ns-3) THEN
64581  DO 470 j=1,5
64582  p(i,j)=0d0
64583  470 CONTINUE
64584  GOTO 600
64585 C...Stepping from 'low' string region
64586  ELSEIF(in(1)+1.EQ.in(2)) THEN
64587  p(in(2)+2,4)=p(in(2)+2,3)
64588  p(in(2)+2,1)=1d0
64589  in(2)=in(2)+4
64590  IF(in(2).GT.n+nr+4*ns) GOTO 360
64591  IF(four(in(1),in(2)).LE.1d-2) THEN
64592  p(in(1)+2,4)=p(in(1)+2,3)
64593  p(in(1)+2,1)=0d0
64594  in(1)=in(1)+4
64595  ENDIF
64596  ENDIF
64597 
64598 C...Junction strings: find new transverse directions.
64599  480 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
64600  & in(1).GT.in(2)) GOTO 360
64601  IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
64602  DO 490 j=1,4
64603  dp(1,j)=p(in(1),j)
64604  dp(2,j)=p(in(2),j)
64605  dp(3,j)=0d0
64606  dp(4,j)=0d0
64607  490 CONTINUE
64608  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64609  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64610  dhc12=dfour(1,2)
64611  IF(dhc12.LE.1d-2) THEN
64612  p(in(1)+2,4)=p(in(1)+2,3)
64613  p(in(1)+2,1)=0d0
64614  in(1)=in(1)+4
64615  GOTO 480
64616  ENDIF
64617  in(3)=n+nr+4*ns+5
64618  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
64619  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
64620  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
64621  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
64622  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
64623  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
64624  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
64625  dhcx1=dfour(3,1)/dhc12
64626  dhcx2=dfour(3,2)/dhc12
64627  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
64628  dhcy1=dfour(4,1)/dhc12
64629  dhcy2=dfour(4,2)/dhc12
64630  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
64631  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
64632  DO 500 j=1,4
64633  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
64634  p(in(3),j)=dp(3,j)
64635  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
64636  & dhcyx*dp(3,j))
64637  500 CONTINUE
64638 C...Express pT with respect to new axes, if sensible.
64639  pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
64640  pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
64641  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
64642  px(3)=pxp
64643  py(3)=pyp
64644  ENDIF
64645  ENDIF
64646 
64647 C...Junction strings: sum up known four-momentum, coefficients for m2.
64648  DO 530 j=1,4
64649  dhg(j)=0d0
64650  p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
64651  & py(3)*p(in(3)+1,j)
64652  DO 510 in1=in(4),in(1)-4,4
64653  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
64654  510 CONTINUE
64655  DO 520 in2=in(5),in(2)-4,4
64656  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
64657  520 CONTINUE
64658  530 CONTINUE
64659  dhm(1)=four(i,i)
64660  dhm(2)=2d0*four(i,in(1))
64661  dhm(3)=2d0*four(i,in(2))
64662  dhm(4)=2d0*four(in(1),in(2))
64663 
64664 C...Junction strings: find coefficients for Gamma expression.
64665  DO 550 in2=in(1)+1,in(2),4
64666  DO 540 in1=in(1),in2-1,4
64667  dhc=2d0*four(in1,in2)
64668  dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
64669  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
64670  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
64671  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
64672  540 CONTINUE
64673  550 CONTINUE
64674 
64675 C...Junction strings: solve (m2, Gamma) equation system for energies.
64676  dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
64677  IF(abs(dhs1).LT.1d-4) GOTO 360
64678  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
64679  & (p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
64680  dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
64681  p(in(2)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
64682  & abs(dhs1)-dhs2/dhs1)
64683  IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0d0) GOTO 360
64684  p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
64685  & (dhm(2)+dhm(4)*p(in(2)+2,4))
64686 
64687 C...Junction strings: step to new region if necessary.
64688  IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
64689  p(in(2)+2,4)=p(in(2)+2,3)
64690  p(in(2)+2,1)=1d0
64691  in(2)=in(2)+4
64692  IF(in(2).GT.n+nr+4*ns) GOTO 360
64693  IF(four(in(1),in(2)).LE.1d-2) THEN
64694  p(in(1)+2,4)=p(in(1)+2,3)
64695  p(in(1)+2,1)=0d0
64696  in(1)=in(1)+4
64697  ENDIF
64698  GOTO 480
64699  ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
64700  p(in(1)+2,4)=p(in(1)+2,3)
64701  p(in(1)+2,1)=0d0
64702  in(1)=in(1)+4
64703  GOTO 480
64704  ENDIF
64705 
64706 C...Junction strings: particle four-momentum, remainder, loop back.
64707  560 DO 570 j=1,4
64708  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+
64709  & p(in(2)+2,4)*p(in(2),j)
64710  pju(iu+3,j)=pju(iu+3,j)+p(i,j)
64711  570 CONTINUE
64712  IF(p(i,4).LT.p(i,5)) GOTO 360
64713  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
64714  & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
64715  IF(pju(iu+3,5).LT.pju(iu,5)) THEN
64716  kfl(1)=-kfl(3)
64717  px(1)=-px(3)
64718  py(1)=-py(3)
64719  gam(1)=gam(3)
64720  IF(in(3).NE.in(6)) THEN
64721  DO 580 j=1,4
64722  p(in(6),j)=p(in(3),j)
64723  p(in(6)+1,j)=p(in(3)+1,j)
64724  580 CONTINUE
64725  ENDIF
64726  DO 590 jq=1,2
64727  in(3+jq)=in(jq)
64728  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
64729  p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
64730  590 CONTINUE
64731  GOTO 430
64732  ENDIF
64733 
64734 C...Junction strings: save quantities left after each string.
64735  IF(iabs(kfl(1)).GT.10) GOTO 360
64736  600 i=i-1
64737  kfjh(iu)=kfl(1)
64738  DO 610 j=1,4
64739  pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
64740  610 CONTINUE
64741 
64742 C...Junction strings: loopback if much unused energy in both strings.
64743  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
64744  & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
64745  ejstr(iu)=pju(iu,5)-pju(iu+3,5)
64746  620 CONTINUE
64747  IF((min(ejstr(1),ejstr(2)).GT.parj(49).OR.
64748  & ejstr(1).GT.parj(49)+pyr(0)*parj(50).OR.
64749  & ejstr(2).GT.parj(49)+pyr(0)*parj(50))
64750  & .AND.ntryer.LT.10) GOTO 320
64751 
64752 C...Junction strings: put together to new effective string endpoint.
64753  njs(jt)=i-ista
64754  kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
64755  IF(kfjh(1).EQ.kfjh(2)) kfls=3
64756  kfjs(jt)=isign(1000*max(iabs(kfjh(1)),iabs(kfjh(2)))+
64757  & 100*min(iabs(kfjh(1)),iabs(kfjh(2)))+kfls,kfjh(1))
64758  DO 630 j=1,4
64759  pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
64760  pjs(jt+2,j)=pju(4,j)+pju(5,j)
64761  630 CONTINUE
64762  pjs(jt,5)=sqrt(max(0d0,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
64763  & pjs(jt,3)**2))
64764  pjs(jt+2,5)=0d0
64765  640 CONTINUE
64766 
64767 C...Open versus closed strings. Choose breakup region for latter.
64768  650 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
64769  ns=mju(2)-mju(1)
64770  nb=mju(1)-n
64771  ELSEIF(mju(1).NE.0) THEN
64772  ns=n+nr-mju(1)
64773  nb=mju(1)-n
64774  ELSEIF(mju(2).NE.0) THEN
64775  ns=mju(2)-n
64776  nb=1
64777  ELSEIF(iabs(k(n+1,2)).NE.21) THEN
64778  ns=nr-1
64779  nb=1
64780  ELSE
64781  ns=nr+1
64782  w2sum=0d0
64783  DO 660 is=1,nr
64784  p(n+nr+is,1)=0.5d0*four(n+is,n+is+1-nr*(is/nr))
64785  w2sum=w2sum+p(n+nr+is,1)
64786  660 CONTINUE
64787  w2ran=pyr(0)*w2sum
64788  nb=0
64789  670 nb=nb+1
64790  w2sum=w2sum-p(n+nr+nb,1)
64791  IF(w2sum.GT.w2ran.AND.nb.LT.nr) GOTO 670
64792  ENDIF
64793 
64794 C...Find longitudinal string directions (i.e. lightlike four-vectors).
64795  DO 700 is=1,ns
64796  is1=n+is+nb-1-nr*((is+nb-2)/nr)
64797  is2=n+is+nb-nr*((is+nb-1)/nr)
64798  DO 680 j=1,5
64799  dp(1,j)=p(is1,j)
64800  IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5d0*dp(1,j)
64801  IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
64802  dp(2,j)=p(is2,j)
64803  IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5d0*dp(2,j)
64804  IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
64805  680 CONTINUE
64806  IF(is1.EQ.mju(1)) dp(1,5)=sqrt(max(0d0,dp(1,4)**2-dp(1,1)**2-
64807  & dp(1,2)**2-dp(1,3)**2))
64808  IF(is2.EQ.mju(2)) dp(2,5)=sqrt(max(0d0,dp(2,4)**2-dp(2,1)**2-
64809  & dp(2,2)**2-dp(2,3)**2))
64810  dp(3,5)=dfour(1,1)
64811  dp(4,5)=dfour(2,2)
64812  dhkc=dfour(1,2)
64813  IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) GOTO 200
64814  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
64815  dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
64816  dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
64817  in1=n+nr+4*is-3
64818  p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
64819  DO 690 j=1,4
64820  p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
64821  p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
64822  690 CONTINUE
64823  700 CONTINUE
64824 
64825 C...Begin initialization: sum up energy, set starting position.
64826  isav=i
64827  mstu91=mstu(90)
64828  710 ntry=ntry+1
64829  IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
64830  paru12=4d0*paru12
64831  paru13=2d0*paru13
64832  GOTO 140
64833  ELSEIF(ntry.GT.100) THEN
64834  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
64835  IF(mstu(21).GE.1) RETURN
64836  ENDIF
64837  i=isav
64838  mstu(90)=mstu91
64839  DO 730 j=1,4
64840  p(n+nrs,j)=0d0
64841  DO 720 is=1,nr
64842  p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
64843  720 CONTINUE
64844  730 CONTINUE
64845  DO 750 jt=1,2
64846  irank(jt)=0
64847  IF(mju(jt).NE.0) irank(jt)=njs(jt)
64848  IF(ns.GT.nr) irank(jt)=1
64849  ibarrk(jt)=0
64850  ie(jt)=k(n+1+(jt/2)*(np-1),3)
64851  in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
64852  in(3*jt+2)=in(3*jt+1)+1
64853  in(3*jt+3)=n+nr+4*ns+2*jt-1
64854  DO 740 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
64855  p(in1,1)=2-jt
64856  p(in1,2)=jt-1
64857  p(in1,3)=1d0
64858  740 CONTINUE
64859  750 CONTINUE
64860 
64861 C.. MOPS variables and switches
64862  nrvmo=0
64863  xbmo=1d0
64864  mstu(121)=0
64865  mstu(122)=0
64866 
64867 C...Initialize flavour and pT variables for open string.
64868  IF(ns.LT.nr) THEN
64869  px(1)=0d0
64870  py(1)=0d0
64871  IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL pyptdi(0,px(1),py(1))
64872  px(2)=-px(1)
64873  py(2)=-py(1)
64874  DO 760 jt=1,2
64875  kfl(jt)=k(ie(jt),2)
64876  IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
64877  IF(mju(jt).NE.0.AND.iabs(kfl(jt)).GT.1000) ibarrk(jt)=1
64878  mstj(93)=1
64879  pmq(jt)=pymass(kfl(jt))
64880  gam(jt)=0d0
64881  760 CONTINUE
64882 
64883 C...Closed string: random initial breakup flavour, pT and vertex.
64884  ELSE
64885  kfl(3)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
64886  ibmo=0
64887  770 CALL pykfdi(kfl(3),0,kfl(1),kdump)
64888 C.. Closed string: first vertex diq attempt => enforced second
64889 C.. vertex diq
64890  IF(iabs(kfl(1)).GT.10)THEN
64891  ibmo=1
64892  mstu(121)=0
64893  GOTO 770
64894  ENDIF
64895  IF(ibmo.EQ.1) mstu(121)=-1
64896  kfl(2)=-kfl(1)
64897  CALL pyptdi(kfl(1),px(1),py(1))
64898  px(2)=-px(1)
64899  py(2)=-py(1)
64900  pr3=min(25d0,0.1d0*p(n+nr+1,5)**2)
64901  780 CALL pyzdis(kfl(1),kfl(2),pr3,z)
64902  zr=pr3/(z*p(n+nr+1,5)**2)
64903  IF(zr.GE.1d0) GOTO 780
64904  DO 790 jt=1,2
64905  mstj(93)=1
64906  pmq(jt)=pymass(kfl(jt))
64907  gam(jt)=pr3*(1d0-z)/z
64908  in1=n+nr+3+4*(jt/2)*(ns-1)
64909  p(in1,jt)=1d0-z
64910  p(in1,3-jt)=jt-1
64911  p(in1,3)=(2-jt)*(1d0-z)+(jt-1)*z
64912  p(in1+1,jt)=zr
64913  p(in1+1,3-jt)=2-jt
64914  p(in1+1,3)=(2-jt)*(1d0-zr)+(jt-1)*zr
64915  790 CONTINUE
64916  ENDIF
64917 C.. MOPS variables
64918  DO 800 jt=1,2
64919  xtmo(jt)=1d0
64920  pm2qmo(jt)=pmq(jt)**2
64921  IF(iabs(kfl(jt)).GT.10) pm2qmo(jt)=0d0
64922  800 CONTINUE
64923 
64924 C...Find initial transverse directions (i.e. spacelike four-vectors).
64925  DO 840 jt=1,2
64926  IF(jt.EQ.1.OR.ns.EQ.nr-1.OR.mju(1)+mju(2).NE.0) THEN
64927  in1=in(3*jt+1)
64928  in3=in(3*jt+3)
64929  DO 810 j=1,4
64930  dp(1,j)=p(in1,j)
64931  dp(2,j)=p(in1+1,j)
64932  dp(3,j)=0d0
64933  dp(4,j)=0d0
64934  810 CONTINUE
64935  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64936  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64937  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
64938  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
64939  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
64940  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
64941  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
64942  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
64943  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
64944  dhc12=dfour(1,2)
64945  dhcx1=dfour(3,1)/dhc12
64946  dhcx2=dfour(3,2)/dhc12
64947  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
64948  dhcy1=dfour(4,1)/dhc12
64949  dhcy2=dfour(4,2)/dhc12
64950  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
64951  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
64952  DO 820 j=1,4
64953  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
64954  p(in3,j)=dp(3,j)
64955  p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
64956  & dhcyx*dp(3,j))
64957  820 CONTINUE
64958  ELSE
64959  DO 830 j=1,4
64960  p(in3+2,j)=p(in3,j)
64961  p(in3+3,j)=p(in3+1,j)
64962  830 CONTINUE
64963  ENDIF
64964  840 CONTINUE
64965 
64966 C...Remove energy used up in junction string fragmentation.
64967  IF(mju(1)+mju(2).GT.0) THEN
64968  DO 860 jt=1,2
64969  IF(njs(jt).EQ.0) GOTO 860
64970  DO 850 j=1,4
64971  p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
64972  850 CONTINUE
64973  860 CONTINUE
64974  parjst=parj(33)
64975  IF(mstj(11).EQ.2) parjst=parj(34)
64976  wmin=parjst+pmq(1)+pmq(2)
64977  wrem2=four(n+nrs,n+nrs)
64978  IF(p(n+nrs,4).LT.0d0.OR.wrem2.LT.wmin**2) THEN
64979  ntrywr=ntrywr+1
64980  IF(mod(ntrywr,20).NE.0) ntryr=ntryr-1
64981  GOTO 140
64982  ENDIF
64983  ENDIF
64984 
64985 C...Produce new particle: side, origin.
64986  870 i=i+1
64987  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
64988  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
64989  IF(mstu(21).GE.1) RETURN
64990  ENDIF
64991 C.. New side priority for popcorn systems
64992  IF(mstu(121).LE.0)THEN
64993  jt=1.5d0+pyr(0)
64994  IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
64995  IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
64996  ENDIF
64997  jr=3-jt
64998  js=3-2*jt
64999  irank(jt)=irank(jt)+1
65000  k(i,1)=1
65001  k(i,4)=0
65002  k(i,5)=0
65003 
65004 C...Generate flavour, hadron and pT.
65005  880 k(i,3)=ie(jt)
65006  CALL pykfdi(kfl(jt),0,kfl(3),k(i,2))
65007  IF(k(i,2).EQ.0) GOTO 710
65008  mu90mo=mstu(90)
65009  IF(mstu(121).EQ.-1) GOTO 910
65010  IF(irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
65011  &iabs(kfl(3)).GT.10) THEN
65012  IF(pyr(0).GT.parj(19)) GOTO 880
65013  ENDIF
65014  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65015  &k(i,3)=ijuori(jt)
65016  p(i,5)=pymass(k(i,2))
65017  CALL pyptdi(kfl(jt),px(3),py(3))
65018  pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
65019 
65020 C...Final hadrons for small invariant mass.
65021  mstj(93)=1
65022  pmq(3)=pymass(kfl(3))
65023  parjst=parj(33)
65024  IF(mstj(11).EQ.2) parjst=parj(34)
65025  wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
65026  IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
65027  &wmin-0.5d0*parj(36)*pmq(3)
65028  wrem2=four(n+nrs,n+nrs)
65029  IF(wrem2.LT.0.10d0) GOTO 710
65030  IF(wrem2.LT.max(wmin*(1d0+(2d0*pyr(0)-1d0)*parj(37)),
65031  &parj(32)+pmq(1)+pmq(2))**2) GOTO 1080
65032 
65033 C...Choose z, which gives Gamma. Shift z for heavy flavours.
65034  CALL pyzdis(kfl(jt),kfl(3),pr(jt),z)
65035  IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
65036  &mstu(90).LT.8) THEN
65037  mstu(90)=mstu(90)+1
65038  mstu(90+mstu(90))=i
65039  paru(90+mstu(90))=z
65040  ENDIF
65041  kfl1a=iabs(kfl(1))
65042  kfl2a=iabs(kfl(2))
65043  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
65044  &mod(kfl2a/1000,10)).GE.4) THEN
65045  pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
65046  pw12=sqrt(max(0d0,(wrem2-pr(1)-pr(2))**2-4d0*pr(1)*pr(2)))
65047  z=(wrem2+pr(jt)-pr(jr)+pw12*(2d0*z-1d0))/(2d0*wrem2)
65048  pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
65049  IF((1d0-z)*(wrem2-pr(jt)/z).LT.pr(jr)) GOTO 1080
65050  ENDIF
65051  gam(3)=(1d0-z)*(gam(jt)+pr(jt)/z)
65052 
65053 C.. MOPS baryon model modification
65054  xtmo3=(1d0-z)*xtmo(jt)
65055  IF(iabs(kfl(3)).LE.10) nrvmo=0
65056  IF(iabs(kfl(3)).GT.10.AND.mstj(12).GE.4) THEN
65057  gtstmo=1d0
65058  ptstmo=1d0
65059  rtstmo=pyr(0)
65060  IF(iabs(kfl(jt)).LE.10)THEN
65061  xbmo=min(xtmo3,1d0-(2d-10))
65062  gbmo=gam(3)
65063  pmmo=0d0
65064  pgmo=gbmo+log(1d0-xbmo)*pm2qmo(jt)
65065  gtstmo=1d0-parf(192)**pgmo
65066  ELSE
65067  IF(irank(jt).EQ.1) THEN
65068  gbmo=gam(jt)
65069  pmmo=0d0
65070  xbmo=1d0
65071  ENDIF
65072  IF(xbmo.LT.1d0-(1d-10))THEN
65073  pgnmo=gbmo*xtmo3/xbmo+pm2qmo(jt)*log(1d0-xtmo3)
65074  gtstmo=(1d0-parf(192)**pgnmo)/(1d0-parf(192)**pgmo)
65075  pgmo=pgnmo
65076  ENDIF
65077  IF(mstj(12).GE.5)THEN
65078  pmnmo=sqrt((xbmo-xtmo3)*(gam(3)/xtmo3-gbmo/xbmo))
65079  pmmo=pmmo+pmas(pycomp(k(i,2)),1)-pmas(pycomp(k(i,2)),3)
65080  ptstmo=exp((pmmo-pmnmo)*parf(193))
65081  pmmo=pmnmo
65082  ENDIF
65083  ENDIF
65084 
65085 C.. MOPS Accepting popcorn system hadron.
65086  IF(ptstmo*gtstmo.GT.rtstmo) THEN
65087  IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) THEN
65088  nrvmo=i-n-nr
65089  IF(i+nrvmo.GT.mstu(4)-mstu(32)-5) THEN
65090  CALL pyerrm(11,
65091  & '(PYSTRF:) no more memory left in PYJETS')
65092  IF(mstu(21).GE.1) RETURN
65093  ENDIF
65094  imo=i
65095  kflmo=kfl(jt)
65096  pmqmo=pmq(jt)
65097  pxmo=px(jt)
65098  pymo=py(jt)
65099  gammo=gam(jt)
65100  irmo=irank(jt)
65101  xmo=xtmo(jt)
65102  DO 900 j=1,9
65103  IF(j.LE.5) THEN
65104  DO 890 line=1,i-n-nr
65105  p(mstu(4)-mstu(32)-line,j)=p(n+nr+line,j)
65106  k(mstu(4)-mstu(32)-line,j)=k(n+nr+line,j)
65107  890 CONTINUE
65108  ENDIF
65109  inmo(j)=in(j)
65110  900 CONTINUE
65111  ENDIF
65112  ELSE
65113 C..Reject popcorn system, flag=-1 if enforcing new one
65114  mstu(121)=-1
65115  IF(ptstmo.GT.rtstmo) mstu(121)=-2
65116  ENDIF
65117  ENDIF
65118 
65119 
65120 C..Lift restoring string outside MOPS block
65121  910 IF(mstu(121).LT.0) THEN
65122  IF(mstu(121).EQ.-2) mstu(121)=0
65123  mstu(90)=mu90mo
65124  nrvmo=0
65125  IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) GOTO 880
65126  i=imo
65127  kfl(jt)=kflmo
65128  pmq(jt)=pmqmo
65129  px(jt)=pxmo
65130  py(jt)=pymo
65131  gam(jt)=gammo
65132  irank(jt)=irmo
65133  xtmo(jt)=xmo
65134  DO 930 j=1,9
65135  IF(j.LE.5) THEN
65136  DO 920 line=1,i-n-nr
65137  p(n+nr+line,j)=p(mstu(4)-mstu(32)-line,j)
65138  k(n+nr+line,j)=k(mstu(4)-mstu(32)-line,j)
65139  920 CONTINUE
65140  ENDIF
65141  in(j)=inmo(j)
65142  930 CONTINUE
65143  GOTO 880
65144  ENDIF
65145  xtmo(jt)=xtmo3
65146 C.. MOPS end of modification
65147 
65148  DO 940 j=1,3
65149  in(j)=in(3*jt+j)
65150  940 CONTINUE
65151 
65152 C...Stepping within or from 'low' string region easy.
65153  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
65154  &p(in(1),5)**2.GE.pr(jt)) THEN
65155  p(in(jt)+2,4)=z*p(in(jt)+2,3)
65156  p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
65157  DO 950 j=1,4
65158  p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
65159  950 CONTINUE
65160  GOTO 1040
65161  ELSEIF(in(1)+1.EQ.in(2)) THEN
65162  p(in(jr)+2,4)=p(in(jr)+2,3)
65163  p(in(jr)+2,jt)=1d0
65164  in(jr)=in(jr)+4*js
65165  IF(js*in(jr).GT.js*in(4*jr)) GOTO 710
65166  IF(four(in(1),in(2)).LE.1d-2) THEN
65167  p(in(jt)+2,4)=p(in(jt)+2,3)
65168  p(in(jt)+2,jt)=0d0
65169  in(jt)=in(jt)+4*js
65170  ENDIF
65171  ENDIF
65172 
65173 C...Find new transverse directions (i.e. spacelike string vectors).
65174  960 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
65175  &in(1).GT.in(2)) GOTO 710
65176  IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
65177  DO 970 j=1,4
65178  dp(1,j)=p(in(1),j)
65179  dp(2,j)=p(in(2),j)
65180  dp(3,j)=0d0
65181  dp(4,j)=0d0
65182  970 CONTINUE
65183  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
65184  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
65185  dhc12=dfour(1,2)
65186  IF(dhc12.LE.1d-2) THEN
65187  p(in(jt)+2,4)=p(in(jt)+2,3)
65188  p(in(jt)+2,jt)=0d0
65189  in(jt)=in(jt)+4*js
65190  GOTO 960
65191  ENDIF
65192  in(3)=n+nr+4*ns+5
65193  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
65194  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
65195  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
65196  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
65197  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
65198  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
65199  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
65200  dhcx1=dfour(3,1)/dhc12
65201  dhcx2=dfour(3,2)/dhc12
65202  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
65203  dhcy1=dfour(4,1)/dhc12
65204  dhcy2=dfour(4,2)/dhc12
65205  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
65206  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
65207  DO 980 j=1,4
65208  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
65209  p(in(3),j)=dp(3,j)
65210  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
65211  & dhcyx*dp(3,j))
65212  980 CONTINUE
65213 C...Express pT with respect to new axes, if sensible.
65214  pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
65215  & four(in(3*jt+3)+1,in(3)))
65216  pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
65217  & four(in(3*jt+3)+1,in(3)+1))
65218  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
65219  px(3)=pxp
65220  py(3)=pyp
65221  ENDIF
65222  ENDIF
65223 
65224 C...Sum up known four-momentum. Gives coefficients for m2 expression.
65225  DO 1010 j=1,4
65226  dhg(j)=0d0
65227  p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
65228  & px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
65229  DO 990 in1=in(3*jt+1),in(1)-4*js,4*js
65230  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
65231  990 CONTINUE
65232  DO 1000 in2=in(3*jt+2),in(2)-4*js,4*js
65233  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
65234  1000 CONTINUE
65235  1010 CONTINUE
65236  dhm(1)=four(i,i)
65237  dhm(2)=2d0*four(i,in(1))
65238  dhm(3)=2d0*four(i,in(2))
65239  dhm(4)=2d0*four(in(1),in(2))
65240 
65241 C...Find coefficients for Gamma expression.
65242  DO 1030 in2=in(1)+1,in(2),4
65243  DO 1020 in1=in(1),in2-1,4
65244  dhc=2d0*four(in1,in2)
65245  dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
65246  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
65247  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
65248  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
65249  1020 CONTINUE
65250  1030 CONTINUE
65251 
65252 C...Solve (m2, Gamma) equation system for energies taken.
65253  dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
65254  IF(abs(dhs1).LT.1d-4) GOTO 710
65255  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
65256  &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
65257  dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
65258  p(in(jr)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
65259  &abs(dhs1)-dhs2/dhs1)
65260  IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0d0) GOTO 710
65261  p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
65262  &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
65263 
65264 C...Step to new region if necessary.
65265  IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
65266  p(in(jr)+2,4)=p(in(jr)+2,3)
65267  p(in(jr)+2,jt)=1d0
65268  in(jr)=in(jr)+4*js
65269  IF(js*in(jr).GT.js*in(4*jr)) GOTO 710
65270  IF(four(in(1),in(2)).LE.1d-2) THEN
65271  p(in(jt)+2,4)=p(in(jt)+2,3)
65272  p(in(jt)+2,jt)=0d0
65273  in(jt)=in(jt)+4*js
65274  ENDIF
65275  GOTO 960
65276  ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
65277  p(in(jt)+2,4)=p(in(jt)+2,3)
65278  p(in(jt)+2,jt)=0d0
65279  in(jt)=in(jt)+4*js
65280  GOTO 960
65281  ENDIF
65282 
65283 C...Four-momentum of particle. Remaining quantities. Loop back.
65284  1040 DO 1050 j=1,4
65285  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
65286  p(n+nrs,j)=p(n+nrs,j)-p(i,j)
65287  1050 CONTINUE
65288  IF(p(in(1)+2,4).GT.1d0+paru(14).OR.p(in(1)+2,4).LT.-paru(14).OR.
65289  &p(in(2)+2,4).GT.1d0+paru(14).OR.p(in(2)+2,4).LT.-paru(14))
65290  &GOTO 200
65291  IF(p(i,4).LT.p(i,5)) GOTO 710
65292  kfl(jt)=-kfl(3)
65293  pmq(jt)=pmq(3)
65294  px(jt)=-px(3)
65295  py(jt)=-py(3)
65296  gam(jt)=gam(3)
65297  IF(in(3).NE.in(3*jt+3)) THEN
65298  DO 1060 j=1,4
65299  p(in(3*jt+3),j)=p(in(3),j)
65300  p(in(3*jt+3)+1,j)=p(in(3)+1,j)
65301  1060 CONTINUE
65302  ENDIF
65303  DO 1070 jq=1,2
65304  in(3*jt+jq)=in(jq)
65305  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
65306  p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
65307  1070 CONTINUE
65308  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65309  &ibarrk(jt)=0
65310  GOTO 870
65311 
65312 C...Final hadron: side, flavour, hadron, mass.
65313  1080 i=i+1
65314  k(i,1)=1
65315  k(i,3)=ie(jr)
65316  k(i,4)=0
65317  k(i,5)=0
65318  CALL pykfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
65319  IF(k(i,2).EQ.0) GOTO 710
65320  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i-1,2)),10000).GT.1000)
65321  &ibarrk(jt)=0
65322  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65323  &k(i,3)=ijuori(jt)
65324  IF(ibarrk(jr).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65325  &k(i,3)=ijuori(jr)
65326  p(i,5)=pymass(k(i,2))
65327  pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
65328 
65329 C...Final two hadrons: find common setup of four-vectors.
65330  jq=1
65331  IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.
65332  &p(in(7)+2,3)*p(in(8)+2,3)*four(in(7),in(8))) jq=2
65333  dhc12=four(in(3*jq+1),in(3*jq+2))
65334  dhr1=four(n+nrs,in(3*jq+2))/dhc12
65335  dhr2=four(n+nrs,in(3*jq+1))/dhc12
65336  IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
65337  px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
65338  py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
65339  pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
65340  & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
65341  ENDIF
65342 
65343 C...Solve kinematics for final two hadrons, if possible.
65344  wrem2=2d0*dhr1*dhr2*dhc12
65345  fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
65346  IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1d0) GOTO 200
65347  IF(fd.GE.1d0) GOTO 710
65348  fa=wrem2+pr(jt)-pr(jr)
65349  fb=sqrt(max(0d0,fa**2-4d0*wrem2*pr(jt)))
65350  prevcf=parj(42)
65351  IF(mstj(11).EQ.2) prevcf=parj(39)
65352  prev=1d0/(1d0+exp(min(50d0,prevcf*fb*parj(40))))
65353  fb=sign(fb,js*(pyr(0)-prev))
65354  kfl1a=iabs(kfl(1))
65355  kfl2a=iabs(kfl(2))
65356  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
65357  &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0d0,fa**2-
65358  &4d0*wrem2*pr(jt))),dble(js))
65359  DO 1090 j=1,4
65360  p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
65361  & p(in(3*jq+3)+1,j)+0.5d0*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
65362  & dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
65363  p(i,j)=p(n+nrs,j)-p(i-1,j)
65364  1090 CONTINUE
65365  IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) GOTO 710
65366  dm2f1=p(i-1,4)**2-p(i-1,1)**2-p(i-1,2)**2-p(i-1,3)**2-p(i-1,5)**2
65367  dm2f2=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
65368  IF(dm2f1.GT.1d-10*p(i-1,4)**2.OR.dm2f2.GT.1d-10*p(i,4)**2) THEN
65369  ntryfn=ntryfn+1
65370  IF(ntryfn.LT.100) GOTO 140
65371  CALL pyerrm(13,'(PYSTRF:) bad energies for final two hadrons')
65372  ENDIF
65373 
65374 C...Mark jets as fragmented and give daughter pointers.
65375  n=i-nrs+1
65376  DO 1100 i=nsav+1,nsav+np
65377  im=k(i,3)
65378  k(im,1)=k(im,1)+10
65379  IF(mstu(16).NE.2) THEN
65380  k(im,4)=nsav+1
65381  k(im,5)=nsav+1
65382  ELSE
65383  k(im,4)=nsav+2
65384  k(im,5)=n
65385  ENDIF
65386  1100 CONTINUE
65387 
65388 C...Document string system. Move up particles.
65389  nsav=nsav+1
65390  k(nsav,1)=11
65391  k(nsav,2)=92
65392  k(nsav,3)=ip
65393  k(nsav,4)=nsav+1
65394  k(nsav,5)=n
65395  DO 1110 j=1,4
65396  p(nsav,j)=dps(j)
65397  v(nsav,j)=v(ip,j)
65398  1110 CONTINUE
65399  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
65400  v(nsav,5)=0d0
65401  DO 1130 i=nsav+1,n
65402  DO 1120 j=1,5
65403  k(i,j)=k(i+nrs-1,j)
65404  p(i,j)=p(i+nrs-1,j)
65405  v(i,j)=0d0
65406  1120 CONTINUE
65407  1130 CONTINUE
65408  mstu91=mstu(90)
65409  DO 1140 iz=mstu90+1,mstu91
65410  mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
65411  paru9t(iz)=paru(90+iz)
65412  1140 CONTINUE
65413  mstu(90)=mstu90
65414 
65415 C...Order particles in rank along the chain. Update mother pointer.
65416  DO 1160 i=nsav+1,n
65417  DO 1150 j=1,5
65418  k(i-nsav+n,j)=k(i,j)
65419  p(i-nsav+n,j)=p(i,j)
65420  1150 CONTINUE
65421  1160 CONTINUE
65422  i1=nsav
65423  DO 1190 i=n+1,2*n-nsav
65424  IF(k(i,3).NE.ie(1).AND.k(i,3).NE.ijuori(1)) GOTO 1190
65425  i1=i1+1
65426  DO 1170 j=1,5
65427  k(i1,j)=k(i,j)
65428  p(i1,j)=p(i,j)
65429  1170 CONTINUE
65430  IF(mstu(16).NE.2) k(i1,3)=nsav
65431  DO 1180 iz=mstu90+1,mstu91
65432  IF(mstu9t(iz).EQ.i) THEN
65433  mstu(90)=mstu(90)+1
65434  mstu(90+mstu(90))=i1
65435  paru(90+mstu(90))=paru9t(iz)
65436  ENDIF
65437  1180 CONTINUE
65438  1190 CONTINUE
65439  DO 1220 i=2*n-nsav,n+1,-1
65440  IF(k(i,3).EQ.ie(1).OR.k(i,3).EQ.ijuori(1)) GOTO 1220
65441  i1=i1+1
65442  DO 1200 j=1,5
65443  k(i1,j)=k(i,j)
65444  p(i1,j)=p(i,j)
65445  1200 CONTINUE
65446  IF(mstu(16).NE.2) k(i1,3)=nsav
65447  DO 1210 iz=mstu90+1,mstu91
65448  IF(mstu9t(iz).EQ.i) THEN
65449  mstu(90)=mstu(90)+1
65450  mstu(90+mstu(90))=i1
65451  paru(90+mstu(90))=paru9t(iz)
65452  ENDIF
65453  1210 CONTINUE
65454  1220 CONTINUE
65455 
65456 C...Boost back particle system. Set production vertices.
65457  IF(mbst.EQ.0) THEN
65458  mstu(33)=1
65459  CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),
65460  & dps(3)/dps(4))
65461  ELSE
65462  DO 1230 i=nsav+1,n
65463  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
65464  IF(p(i,3).GT.0d0) THEN
65465  hhpez=(p(i,4)+p(i,3))*hhbz
65466  p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
65467  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
65468  ELSE
65469  hhpez=(p(i,4)-p(i,3))/hhbz
65470  p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
65471  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
65472  ENDIF
65473  1230 CONTINUE
65474  ENDIF
65475  DO 1250 i=nsav+1,n
65476  DO 1240 j=1,4
65477  v(i,j)=v(ip,j)
65478  1240 CONTINUE
65479  1250 CONTINUE
65480 
65481  RETURN
65482  END
65483 
65484 C*********************************************************************
65485 
65486 C...PYJURF
65487 C...From three given input vectors in PJU the boost VJU from
65488 C...the "lab frame" to the junction rest frame is constructed.
65489 
65490  SUBROUTINE pyjurf(PJU,VJU)
65491 
65492 C...Double precision and integer declarations.
65493  IMPLICIT DOUBLE PRECISION(a-h, o-z)
65494  IMPLICIT INTEGER(I-N)
65495 
65496 C...Input, output and local arrays.
65497  dimension pju(3,5),vju(5),psum(5),a(3,3),penew(3),pcm(5,5)
65498  DATA twopi/6.283186d0/
65499 
65500 C...Calculate masses and other invariants.
65501  DO 100 j=1,4
65502  psum(j)=pju(1,j)+pju(2,j)+pju(3,j)
65503  100 CONTINUE
65504  psum2=psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2
65505  psum(5)=sqrt(psum2)
65506  DO 120 i=1,3
65507  DO 110 j=1,3
65508  a(i,j)=pju(i,4)*pju(j,4)-pju(i,1)*pju(j,1)-
65509  & pju(i,2)*pju(j,2)-pju(i,3)*pju(j,3)
65510  110 CONTINUE
65511  120 CONTINUE
65512 
65513 C...Pick I to be most massive parton and J to be the one closest to I.
65514  itry=0
65515  i=1
65516  IF(a(2,2).GT.a(1,1)) i=2
65517  IF(a(3,3).GT.max(a(1,1),a(2,2))) i=3
65518  130 itry=itry+1
65519  j=1+mod(i,3)
65520  k=1+mod(j,3)
65521  IF(a(i,k)**2*a(j,j).LT.a(i,j)**2*a(k,k)) THEN
65522  k=1+mod(i,3)
65523  j=1+mod(k,3)
65524  ENDIF
65525  pmi2=a(i,i)
65526  pmj2=a(j,j)
65527  pmk2=a(k,k)
65528  aij=a(i,j)
65529  aik=a(i,k)
65530  ajk=a(j,k)
65531 
65532 C...Trivial find new parton energies if all three partons are massless.
65533  IF(pmi2.LT.1d-4) THEN
65534  pei=sqrt(2d0*aik*aij/(3d0*ajk))
65535  pej=sqrt(2d0*ajk*aij/(3d0*aik))
65536  pek=sqrt(2d0*aik*ajk/(3d0*aij))
65537 
65538 C...Else find momentum range for parton I and values at extremes.
65539  ELSE
65540  paimin=0d0
65541  peimin=sqrt(pmi2)
65542  pejmin=aij/peimin
65543  pekmin=aik/peimin
65544  pajmin=sqrt(max(0d0,pejmin**2-pmj2))
65545  pakmin=sqrt(max(0d0,pekmin**2-pmk2))
65546  fmin=pejmin*pekmin+0.5d0*pajmin*pakmin-ajk
65547  peimax=(aij+aik)/sqrt(pmj2+pmk2+2d0*ajk)
65548  IF(pmj2.GT.1d-4) peimax=aij/sqrt(pmj2)
65549  paimax=sqrt(max(0d0,peimax**2-pmi2))
65550  hi=peimax**2-0.25d0*paimax**2
65551  pajmax=(peimax*sqrt(max(0d0,aij**2-pmj2*hi))-
65552  & 0.5d0*paimax*aij)/hi
65553  pakmax=(peimax*sqrt(max(0d0,aik**2-pmk2*hi))-
65554  & 0.5d0*paimax*aik)/hi
65555  pejmax=sqrt(pajmax**2+pmj2)
65556  pekmax=sqrt(pakmax**2+pmk2)
65557  fmax=pejmax*pekmax+0.5d0*pajmax*pakmax-ajk
65558 
65559 C...If unexpected values at upper endpoint then pick another parton.
65560  IF(fmax.GT.0d0.AND.itry.LE.2) THEN
65561  i1=1+mod(i,3)
65562  IF(a(i1,i1).GE.1d-4) THEN
65563  i=i1
65564  GOTO 130
65565  ENDIF
65566  itry=itry+1
65567  i1=1+mod(i,3)
65568  IF(itry.LE.2.AND.a(i1,i1).GE.1d-4) THEN
65569  i=i1
65570  GOTO 130
65571  ENDIF
65572  ENDIF
65573 
65574 C..Start binary + linear search to find solution inside range.
65575  iter=0
65576  itmin=0
65577  itmax=0
65578  pai=0.5d0*(paimin+paimax)
65579  140 iter=iter+1
65580 
65581 C...Derive momentum of other two partons and distance to root.
65582  pei=sqrt(pai**2+pmi2)
65583  hi=pei**2-0.25d0*pai**2
65584  paj=(pei*sqrt(max(0d0,aij**2-pmj2*hi))-0.5d0*pai*aij)/hi
65585  pej=sqrt(paj**2+pmj2)
65586  pak=(pei*sqrt(max(0d0,aik**2-pmk2*hi))-0.5d0*pai*aik)/hi
65587  pek=sqrt(pak**2+pmk2)
65588  fnow=pej*pek+0.5d0*paj*pak-ajk
65589 
65590 C...Pick next I momentum to explore, hopefully closer to root.
65591  IF(fnow.GT.0d0) THEN
65592  paimin=pai
65593  fmin=fnow
65594  itmin=itmin+1
65595  ELSE
65596  paimax=pai
65597  fmax=fnow
65598  itmax=itmax+1
65599  ENDIF
65600  IF((iter.LT.10.OR.itmin.LE.1.OR.itmax.LE.1).AND.iter.LT.20)
65601  & THEN
65602  pai=0.5d0*(paimin+paimax)
65603  GOTO 140
65604  ELSEIF(iter.LT.40.AND.fmin.GT.0d0.AND.fmax.LT.0d0.AND.
65605  & abs(fnow).GT.1d-12*psum2) THEN
65606  pai=paimin+(paimax-paimin)*fmin/(fmin-fmax)
65607  GOTO 140
65608  ENDIF
65609  ENDIF
65610 
65611 C...Now know energies in junction rest frame.
65612  penew(i)=pei
65613  penew(j)=pej
65614  penew(k)=pek
65615 
65616 C...Boost (copy of) partons to their rest frame.
65617  vxcm=-psum(1)/psum(5)
65618  vycm=-psum(2)/psum(5)
65619  vzcm=-psum(3)/psum(5)
65620  gamcm=sqrt(1d0+vxcm**2+vycm**2+vzcm**2)
65621  DO 150 i=1,3
65622  fac1=pju(i,1)*vxcm+pju(i,2)*vycm+pju(i,3)*vzcm
65623  fac2=fac1/(1d0+gamcm)+pju(i,4)
65624  pcm(i,1)=pju(i,1)+fac2*vxcm
65625  pcm(i,2)=pju(i,2)+fac2*vycm
65626  pcm(i,3)=pju(i,3)+fac2*vzcm
65627  pcm(i,4)=pju(i,4)*gamcm+fac1
65628  pcm(i,5)=sqrt(pcm(i,1)**2+pcm(i,2)**2+pcm(i,3)**2)
65629  150 CONTINUE
65630 
65631 C...Construct difference vectors and boost to junction rest frame.
65632  DO 160 j=1,3
65633  pcm(4,j)=pcm(1,j)/pcm(1,4)-pcm(2,j)/pcm(2,4)
65634  pcm(5,j)=pcm(1,j)/pcm(1,4)-pcm(3,j)/pcm(3,4)
65635  160 CONTINUE
65636  pcm(4,4)=penew(1)/pcm(1,4)-penew(2)/pcm(2,4)
65637  pcm(5,4)=penew(1)/pcm(1,4)-penew(3)/pcm(3,4)
65638  pcm4s=pcm(4,1)**2+pcm(4,2)**2+pcm(4,3)**2
65639  pcm5s=pcm(5,1)**2+pcm(5,2)**2+pcm(5,3)**2
65640  pcm45=pcm(4,1)*pcm(5,1)+pcm(4,2)*pcm(5,2)+pcm(4,3)*pcm(5,3)
65641  c4=(pcm5s*pcm(4,4)-pcm45*pcm(5,4))/(pcm4s*pcm5s-pcm45**2)
65642  c5=(pcm4s*pcm(5,4)-pcm45*pcm(4,4))/(pcm4s*pcm5s-pcm45**2)
65643  vxju=c4*pcm(4,1)+c5*pcm(5,1)
65644  vyju=c4*pcm(4,2)+c5*pcm(5,2)
65645  vzju=c4*pcm(4,3)+c5*pcm(5,3)
65646  gamju=sqrt(1d0+vxju**2+vyju**2+vzju**2)
65647 
65648 C...Add two boosts, giving final result.
65649  fcm=(vxju*vxcm+vyju*vycm+vzju*vzcm)/(1+gamcm)+gamju
65650  vju(1)=vxju+fcm*vxcm
65651  vju(2)=vyju+fcm*vycm
65652  vju(3)=vzju+fcm*vzcm
65653  vju(4)=sqrt(1d0+vju(1)**2+vju(2)**2+vju(3)**2)
65654  vju(5)=1d0
65655 
65656 C...In case of error in reconstruction: revert to CM frame of system.
65657  cth12=(pcm(1,1)*pcm(2,1)+pcm(1,2)*pcm(2,2)+pcm(1,3)*pcm(2,3))/
65658  &(pcm(1,5)*pcm(2,5))
65659  cth13=(pcm(1,1)*pcm(3,1)+pcm(1,2)*pcm(3,2)+pcm(1,3)*pcm(3,3))/
65660  &(pcm(1,5)*pcm(3,5))
65661  cth23=(pcm(2,1)*pcm(3,1)+pcm(2,2)*pcm(3,2)+pcm(2,3)*pcm(3,3))/
65662  &(pcm(2,5)*pcm(3,5))
65663  errccm=(cth12+0.5d0)**2+(cth13+0.5d0)**2+(cth23+0.5d0)**2
65664  errtcm=twopi-acos(cth12)-acos(cth13)-acos(cth23)
65665  DO 170 i=1,3
65666  fac1=pju(i,1)*vju(1)+pju(i,2)*vju(2)+pju(i,3)*vju(3)
65667  fac2=fac1/(1d0+vju(4))+pju(i,4)
65668  pcm(i,1)=pju(i,1)+fac2*vju(1)
65669  pcm(i,2)=pju(i,2)+fac2*vju(2)
65670  pcm(i,3)=pju(i,3)+fac2*vju(3)
65671  pcm(i,4)=pju(i,4)*vju(4)+fac1
65672  pcm(i,5)=sqrt(pcm(i,1)**2+pcm(i,2)**2+pcm(i,3)**2)
65673  170 CONTINUE
65674  cth12=(pcm(1,1)*pcm(2,1)+pcm(1,2)*pcm(2,2)+pcm(1,3)*pcm(2,3))/
65675  &(pcm(1,5)*pcm(2,5))
65676  cth13=(pcm(1,1)*pcm(3,1)+pcm(1,2)*pcm(3,2)+pcm(1,3)*pcm(3,3))/
65677  &(pcm(1,5)*pcm(3,5))
65678  cth23=(pcm(2,1)*pcm(3,1)+pcm(2,2)*pcm(3,2)+pcm(2,3)*pcm(3,3))/
65679  &(pcm(2,5)*pcm(3,5))
65680  errcju=(cth12+0.5d0)**2+(cth13+0.5d0)**2+(cth23+0.5d0)**2
65681  errtju=twopi-acos(cth12)-acos(cth13)-acos(cth23)
65682  IF(errcju+errtju.GT.errccm+errtcm) THEN
65683  vju(1)=vxcm
65684  vju(2)=vycm
65685  vju(3)=vzcm
65686  vju(4)=gamcm
65687  ENDIF
65688 
65689  RETURN
65690  END
65691 
65692 C*********************************************************************
65693 
65694 C...PYINDF
65695 C...Handles the fragmentation of a jet system (or a single
65696 C...jet) according to independent fragmentation models.
65697 
65698  SUBROUTINE pyindf(IP)
65699 
65700 C...Double precision and integer declarations.
65701  IMPLICIT DOUBLE PRECISION(a-h, o-z)
65702  IMPLICIT INTEGER(I-N)
65703  INTEGER PYK,PYCHGE,PYCOMP
65704 C...Commonblocks.
65705  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
65706  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
65707  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
65708  SAVE /pyjets/,/pydat1/,/pydat2/
65709 C...Local arrays.
65710  dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
65711  &kflo(2),pxo(2),pyo(2),wo(2)
65712 
65713 C.. MOPS error message
65714  IF(mstj(12).GT.3) CALL pyerrm(9,'(PYINDF:) MSTJ(12)>3 options'//
65715  &' are not treated as expected in independent fragmentation')
65716 
65717 C...Reset counters. Identify parton system and take copy. Check flavour.
65718  nsav=n
65719  mstu90=mstu(90)
65720  njet=0
65721  kqsum=0
65722  DO 100 j=1,5
65723  dps(j)=0d0
65724  100 CONTINUE
65725  i=ip-1
65726  110 i=i+1
65727  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
65728  CALL pyerrm(12,'(PYINDF:) failed to reconstruct jet system')
65729  IF(mstu(21).GE.1) RETURN
65730  ENDIF
65731  IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 110
65732  kc=pycomp(k(i,2))
65733  IF(kc.EQ.0) GOTO 110
65734  kq=kchg(kc,2)*isign(1,k(i,2))
65735  IF(kq.EQ.0) GOTO 110
65736  njet=njet+1
65737  IF(kq.NE.2) kqsum=kqsum+kq
65738  DO 120 j=1,5
65739  k(nsav+njet,j)=k(i,j)
65740  p(nsav+njet,j)=p(i,j)
65741  dps(j)=dps(j)+p(i,j)
65742  120 CONTINUE
65743  k(nsav+njet,3)=i
65744  IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
65745  &k(i+1,1).EQ.2)) GOTO 110
65746  IF(njet.NE.1.AND.kqsum.NE.0) THEN
65747  CALL pyerrm(12,'(PYINDF:) unphysical flavour combination')
65748  IF(mstu(21).GE.1) RETURN
65749  ENDIF
65750 
65751 C...Boost copied system to CM frame. Find CM energy and sum flavours.
65752  IF(njet.NE.1) THEN
65753  mstu(33)=1
65754  CALL pyrobo(nsav+1,nsav+njet,0d0,0d0,-dps(1)/dps(4),
65755  & -dps(2)/dps(4),-dps(3)/dps(4))
65756  ENDIF
65757  pecm=0d0
65758  DO 130 j=1,3
65759  nfi(j)=0
65760  130 CONTINUE
65761  DO 140 i=nsav+1,nsav+njet
65762  pecm=pecm+p(i,4)
65763  kfa=iabs(k(i,2))
65764  IF(kfa.LE.3) THEN
65765  nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
65766  ELSEIF(kfa.GT.1000) THEN
65767  kfla=mod(kfa/1000,10)
65768  kflb=mod(kfa/100,10)
65769  IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
65770  IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
65771  ENDIF
65772  140 CONTINUE
65773 
65774 C...Loop over attempts made. Reset counters.
65775  ntry=0
65776  150 ntry=ntry+1
65777  IF(ntry.GT.200) THEN
65778  CALL pyerrm(14,'(PYINDF:) caught in infinite loop')
65779  IF(mstu(21).GE.1) RETURN
65780  ENDIF
65781  n=nsav+njet
65782  mstu(90)=mstu90
65783  DO 160 j=1,3
65784  nfl(j)=nfi(j)
65785  ifet(j)=0
65786  kflf(j)=0
65787  160 CONTINUE
65788 
65789 C...Loop over jets to be fragmented.
65790  DO 230 ip1=nsav+1,nsav+njet
65791  mstj(91)=0
65792  nsav1=n
65793  mstu91=mstu(90)
65794 
65795 C...Initial flavour and momentum values. Jet along +z axis.
65796  kflh=iabs(k(ip1,2))
65797  IF(kflh.GT.10) kflh=mod(kflh/1000,10)
65798  kflo(2)=0
65799  wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
65800 
65801 C...Initial values for quark or diquark jet.
65802  170 IF(iabs(k(ip1,2)).NE.21) THEN
65803  nstr=1
65804  kflo(1)=k(ip1,2)
65805  CALL pyptdi(0,pxo(1),pyo(1))
65806  wo(1)=wf
65807 
65808 C...Initial values for gluon treated like random quark jet.
65809  ELSEIF(mstj(2).LE.2) THEN
65810  nstr=1
65811  IF(mstj(2).EQ.2) mstj(91)=1
65812  kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
65813  CALL pyptdi(0,pxo(1),pyo(1))
65814  wo(1)=wf
65815 
65816 C...Initial values for gluon treated like quark-antiquark jet pair,
65817 C...sharing energy according to Altarelli-Parisi splitting function.
65818  ELSE
65819  nstr=2
65820  IF(mstj(2).EQ.4) mstj(91)=1
65821  kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
65822  kflo(2)=-kflo(1)
65823  CALL pyptdi(0,pxo(1),pyo(1))
65824  pxo(2)=-pxo(1)
65825  pyo(2)=-pyo(1)
65826  wo(1)=wf*pyr(0)**(1d0/3d0)
65827  wo(2)=wf-wo(1)
65828  ENDIF
65829 
65830 C...Initial values for rank, flavour, pT and W+.
65831  DO 220 istr=1,nstr
65832  180 i=n
65833  mstu(90)=mstu91
65834  irank=0
65835  kfl1=kflo(istr)
65836  px1=pxo(istr)
65837  py1=pyo(istr)
65838  w=wo(istr)
65839 
65840 C...New hadron. Generate flavour and hadron species.
65841  190 i=i+1
65842  IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
65843  CALL pyerrm(11,'(PYINDF:) no more memory left in PYJETS')
65844  IF(mstu(21).GE.1) RETURN
65845  ENDIF
65846  irank=irank+1
65847  k(i,1)=1
65848  k(i,3)=ip1
65849  k(i,4)=0
65850  k(i,5)=0
65851  200 CALL pykfdi(kfl1,0,kfl2,k(i,2))
65852  IF(k(i,2).EQ.0) GOTO 180
65853  IF(irank.EQ.1.AND.iabs(kfl1).LE.10.AND.iabs(kfl2).GT.10) THEN
65854  IF(pyr(0).GT.parj(19)) GOTO 200
65855  ENDIF
65856 
65857 C...Find hadron mass. Generate four-momentum.
65858  p(i,5)=pymass(k(i,2))
65859  CALL pyptdi(kfl1,px2,py2)
65860  p(i,1)=px1+px2
65861  p(i,2)=py1+py2
65862  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
65863  CALL pyzdis(kfl1,kfl2,pr,z)
65864  mzsav=0
65865  IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
65866  mzsav=1
65867  mstu(90)=mstu(90)+1
65868  mstu(90+mstu(90))=i
65869  paru(90+mstu(90))=z
65870  ENDIF
65871  p(i,3)=0.5d0*(z*w-pr/max(1d-4,z*w))
65872  p(i,4)=0.5d0*(z*w+pr/max(1d-4,z*w))
65873  IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
65874  & p(i,3).LE.0.001d0) THEN
65875  IF(w.GE.p(i,5)+0.5d0*parj(32)) GOTO 180
65876  p(i,3)=0.0001d0
65877  p(i,4)=sqrt(pr)
65878  z=p(i,4)/w
65879  ENDIF
65880 
65881 C...Remaining flavour and momentum.
65882  kfl1=-kfl2
65883  px1=-px2
65884  py1=-py2
65885  w=(1d0-z)*w
65886  DO 210 j=1,5
65887  v(i,j)=0d0
65888  210 CONTINUE
65889 
65890 C...Check if pL acceptable. Go back for new hadron if enough energy.
65891  IF(mstj(3).GE.0.AND.p(i,3).LT.0d0) THEN
65892  i=i-1
65893  IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
65894  ENDIF
65895  IF(w.GT.parj(31)) GOTO 190
65896  n=i
65897  220 CONTINUE
65898  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1d0*parj(32)
65899  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) GOTO 170
65900 
65901 C...Rotate jet to new direction.
65902  the=pyangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
65903  phi=pyangl(p(ip1,1),p(ip1,2))
65904  mstu(33)=1
65905  CALL pyrobo(nsav1+1,n,the,phi,0d0,0d0,0d0)
65906  k(k(ip1,3),4)=nsav1+1
65907  k(k(ip1,3),5)=n
65908 
65909 C...End of jet generation loop. Skip conservation in some cases.
65910  230 CONTINUE
65911  IF(njet.EQ.1.OR.mstj(3).LE.0) GOTO 490
65912  IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) GOTO 150
65913 
65914 C...Subtract off produced hadron flavours, finished if zero.
65915  DO 240 i=nsav+njet+1,n
65916  kfa=iabs(k(i,2))
65917  kfla=mod(kfa/1000,10)
65918  kflb=mod(kfa/100,10)
65919  kflc=mod(kfa/10,10)
65920  IF(kfla.EQ.0) THEN
65921  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
65922  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
65923  ELSE
65924  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
65925  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
65926  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
65927  ENDIF
65928  240 CONTINUE
65929  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
65930  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
65931  IF(nreq.EQ.0) GOTO 320
65932 
65933 C...Take away flavour of low-momentum particles until enough freedom.
65934  nrem=0
65935  250 irem=0
65936  p2min=pecm**2
65937  DO 260 i=nsav+njet+1,n
65938  p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
65939  IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
65940  IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
65941  260 CONTINUE
65942  IF(irem.EQ.0) GOTO 150
65943  k(irem,1)=7
65944  kfa=iabs(k(irem,2))
65945  kfla=mod(kfa/1000,10)
65946  kflb=mod(kfa/100,10)
65947  kflc=mod(kfa/10,10)
65948  IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
65949  IF(k(irem,1).EQ.8) GOTO 250
65950  IF(kfla.EQ.0) THEN
65951  isgn=isign(1,k(irem,2))*(-1)**kflb
65952  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
65953  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
65954  ELSE
65955  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
65956  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
65957  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
65958  ENDIF
65959  nrem=nrem+1
65960  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
65961  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
65962  IF(nreq.GT.nrem) GOTO 250
65963  DO 270 i=nsav+njet+1,n
65964  IF(k(i,1).EQ.8) k(i,1)=1
65965  270 CONTINUE
65966 
65967 C...Find combination of existing and new flavours for hadron.
65968  280 nfet=2
65969  IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
65970  IF(nreq.LT.nrem) nfet=1
65971  IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
65972  DO 290 j=1,nfet
65973  ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*pyr(0)
65974  kflf(j)=isign(1,nfl(1))
65975  IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
65976  IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
65977  290 CONTINUE
65978  IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
65979  &GOTO 280
65980  IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
65981  &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)
65982  &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) GOTO 280
65983  IF(nfet.EQ.0) kflf(1)=1+int((2d0+parj(2))*pyr(0))
65984  IF(nfet.EQ.0) kflf(2)=-kflf(1)
65985  IF(nfet.EQ.1) kflf(2)=isign(1+int((2d0+parj(2))*pyr(0)),-kflf(1))
65986  IF(nfet.LE.2) kflf(3)=0
65987  IF(kflf(3).NE.0) THEN
65988  kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
65989  & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
65990  IF(kflf(1).EQ.kflf(3).OR.(1d0+3d0*parj(4))*pyr(0).GT.1d0)
65991  & kflfc=kflfc+isign(2,kflfc)
65992  ELSE
65993  kflfc=kflf(1)
65994  ENDIF
65995  CALL pykfdi(kflfc,kflf(2),kfldmp,kf)
65996  IF(kf.EQ.0) GOTO 280
65997  DO 300 j=1,max(2,nfet)
65998  nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
65999  300 CONTINUE
66000 
66001 C...Store hadron at random among free positions.
66002  npos=min(1+int(pyr(0)*nrem),nrem)
66003  DO 310 i=nsav+njet+1,n
66004  IF(k(i,1).EQ.7) npos=npos-1
66005  IF(k(i,1).EQ.1.OR.npos.NE.0) GOTO 310
66006  k(i,1)=1
66007  k(i,2)=kf
66008  p(i,5)=pymass(k(i,2))
66009  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66010  310 CONTINUE
66011  nrem=nrem-1
66012  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
66013  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
66014  IF(nrem.GT.0) GOTO 280
66015 
66016 C...Compensate for missing momentum in global scheme (3 options).
66017  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
66018  DO 340 j=1,3
66019  psi(j)=0d0
66020  DO 330 i=nsav+njet+1,n
66021  psi(j)=psi(j)+p(i,j)
66022  330 CONTINUE
66023  340 CONTINUE
66024  psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
66025  pws=0d0
66026  DO 350 i=nsav+njet+1,n
66027  IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
66028  IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
66029  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
66030  IF(mod(mstj(3),5).EQ.3) pws=pws+1d0
66031  350 CONTINUE
66032  DO 370 i=nsav+njet+1,n
66033  IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
66034  IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
66035  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
66036  IF(mod(mstj(3),5).EQ.3) pw=1d0
66037  DO 360 j=1,3
66038  p(i,j)=p(i,j)-psi(j)*pw/pws
66039  360 CONTINUE
66040  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66041  370 CONTINUE
66042 
66043 C...Compensate for missing momentum withing each jet separately.
66044  ELSEIF(mod(mstj(3),5).EQ.4) THEN
66045  DO 390 i=n+1,n+njet
66046  k(i,1)=0
66047  DO 380 j=1,5
66048  p(i,j)=0d0
66049  380 CONTINUE
66050  390 CONTINUE
66051  DO 410 i=nsav+njet+1,n
66052  ir1=k(i,3)
66053  ir2=n+ir1-nsav
66054  k(ir2,1)=k(ir2,1)+1
66055  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
66056  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
66057  DO 400 j=1,3
66058  p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
66059  400 CONTINUE
66060  p(ir2,4)=p(ir2,4)+p(i,4)
66061  p(ir2,5)=p(ir2,5)+pls
66062  410 CONTINUE
66063  pss=0d0
66064  DO 420 i=n+1,n+njet
66065  IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8d0*p(i,5)+0.2d0))
66066  420 CONTINUE
66067  DO 440 i=nsav+njet+1,n
66068  ir1=k(i,3)
66069  ir2=n+ir1-nsav
66070  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
66071  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
66072  DO 430 j=1,3
66073  p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1d0/(p(ir2,5)*pss)-1d0)*
66074  & pls*p(ir1,j)
66075  430 CONTINUE
66076  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66077  440 CONTINUE
66078  ENDIF
66079 
66080 C...Scale momenta for energy conservation.
66081  IF(mod(mstj(3),5).NE.0) THEN
66082  pms=0d0
66083  pes=0d0
66084  pqs=0d0
66085  DO 450 i=nsav+njet+1,n
66086  pms=pms+p(i,5)
66087  pes=pes+p(i,4)
66088  pqs=pqs+p(i,5)**2/p(i,4)
66089  450 CONTINUE
66090  IF(pms.GE.pecm) GOTO 150
66091  neco=0
66092  460 neco=neco+1
66093  pfac=(pecm-pqs)/(pes-pqs)
66094  pes=0d0
66095  pqs=0d0
66096  DO 480 i=nsav+njet+1,n
66097  DO 470 j=1,3
66098  p(i,j)=pfac*p(i,j)
66099  470 CONTINUE
66100  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66101  pes=pes+p(i,4)
66102  pqs=pqs+p(i,5)**2/p(i,4)
66103  480 CONTINUE
66104  IF(neco.LT.10.AND.abs(pecm-pes).GT.2d-6*pecm) GOTO 460
66105  ENDIF
66106 
66107 C...Origin of produced particles and parton daughter pointers.
66108  490 DO 500 i=nsav+njet+1,n
66109  IF(mstu(16).NE.2) k(i,3)=nsav+1
66110  IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
66111  500 CONTINUE
66112  DO 510 i=nsav+1,nsav+njet
66113  i1=k(i,3)
66114  k(i1,1)=k(i1,1)+10
66115  IF(mstu(16).NE.2) THEN
66116  k(i1,4)=nsav+1
66117  k(i1,5)=nsav+1
66118  ELSE
66119  k(i1,4)=k(i1,4)-njet+1
66120  k(i1,5)=k(i1,5)-njet+1
66121  IF(k(i1,5).LT.k(i1,4)) THEN
66122  k(i1,4)=0
66123  k(i1,5)=0
66124  ENDIF
66125  ENDIF
66126  510 CONTINUE
66127 
66128 C...Document independent fragmentation system. Remove copy of jets.
66129  nsav=nsav+1
66130  k(nsav,1)=11
66131  k(nsav,2)=93
66132  k(nsav,3)=ip
66133  k(nsav,4)=nsav+1
66134  k(nsav,5)=n-njet+1
66135  DO 520 j=1,4
66136  p(nsav,j)=dps(j)
66137  v(nsav,j)=v(ip,j)
66138  520 CONTINUE
66139  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
66140  v(nsav,5)=0d0
66141  DO 540 i=nsav+njet,n
66142  DO 530 j=1,5
66143  k(i-njet+1,j)=k(i,j)
66144  p(i-njet+1,j)=p(i,j)
66145  v(i-njet+1,j)=v(i,j)
66146  530 CONTINUE
66147  540 CONTINUE
66148  n=n-njet+1
66149  DO 550 iz=mstu90+1,mstu(90)
66150  mstu(90+iz)=mstu(90+iz)-njet+1
66151  550 CONTINUE
66152 
66153 C...Boost back particle system. Set production vertices.
66154  IF(njet.NE.1) CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),
66155  &dps(2)/dps(4),dps(3)/dps(4))
66156  DO 570 i=nsav+1,n
66157  DO 560 j=1,4
66158  v(i,j)=v(ip,j)
66159  560 CONTINUE
66160  570 CONTINUE
66161 
66162  RETURN
66163  END
66164 
66165 C*********************************************************************
66166 
66167 C...PYDECY
66168 C...Handles the decay of unstable particles.
66169 
66170  SUBROUTINE pydecy(IP)
66171 
66172 C...Double precision and integer declarations.
66173  IMPLICIT DOUBLE PRECISION(a-h, o-z)
66174  IMPLICIT INTEGER(I-N)
66175  INTEGER PYK,PYCHGE,PYCOMP
66176 C...Commonblocks.
66177  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
66178  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
66179  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
66180  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
66181  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
66182 C...Local arrays.
66183  dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
66184  &wtcor(10),ptau(4),pcmtau(4),dbetau(3)
66185  CHARACTER CIDC*4
66186  DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66187 
66188 C...Functions: momentum in two-particle decays and four-product.
66189  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2d0*a)
66190  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)
66191 
66192 C...Initial values.
66193  ntry=0
66194  nsav=n
66195  kfa=iabs(k(ip,2))
66196  kfs=isign(1,k(ip,2))
66197  kc=pycomp(kfa)
66198  mstj(92)=0
66199 
66200 C...Choose lifetime and determine decay vertex.
66201  IF(k(ip,1).EQ.5) THEN
66202  v(ip,5)=0d0
66203  ELSEIF(k(ip,1).NE.4) THEN
66204  v(ip,5)=-pmas(kc,4)*log(pyr(0))
66205  ENDIF
66206  DO 100 j=1,4
66207  vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
66208  100 CONTINUE
66209 
66210 C...Determine whether decay allowed or not.
66211  mout=0
66212  IF(mstj(22).EQ.2) THEN
66213  IF(pmas(kc,4).GT.parj(71)) mout=1
66214  ELSEIF(mstj(22).EQ.3) THEN
66215  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
66216  ELSEIF(mstj(22).EQ.4) THEN
66217  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
66218  IF(abs(vdcy(3)).GT.parj(74)) mout=1
66219  ENDIF
66220  IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
66221  k(ip,1)=4
66222  RETURN
66223  ENDIF
66224 
66225 C...Interface to external tau decay library (for tau polarization).
66226  IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
66227 
66228 C...Starting values for pointers and momenta.
66229  itau=ip
66230  DO 110 j=1,4
66231  ptau(j)=p(itau,j)
66232  pcmtau(j)=p(itau,j)
66233  110 CONTINUE
66234 
66235 C...Iterate to find position and code of mother of tau.
66236  imtau=itau
66237  120 imtau=k(imtau,3)
66238 
66239  IF(imtau.EQ.0) THEN
66240 C...If no known origin then impossible to do anything further.
66241  kforig=0
66242  iorig=0
66243 
66244  ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN
66245 C...If tau -> tau + gamma then add gamma energy and loop.
66246  IF(k(k(imtau,4),2).EQ.22) THEN
66247  DO 130 j=1,4
66248  pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)
66249  130 CONTINUE
66250  ELSEIF(k(k(imtau,5),2).EQ.22) THEN
66251  DO 140 j=1,4
66252  pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)
66253  140 CONTINUE
66254  ENDIF
66255  GOTO 120
66256 
66257  ELSEIF(iabs(k(imtau,2)).GT.100) THEN
66258 C...If coming from weak decay of hadron then W is not stored in record,
66259 C...but can be reconstructed by adding neutrino momentum.
66260  kforig=-isign(24,k(itau,2))
66261  iorig=0
66262  DO 160 ii=k(imtau,4),k(imtau,5)
66263  IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN
66264  DO 150 j=1,4
66265  pcmtau(j)=pcmtau(j)+p(ii,j)
66266  150 CONTINUE
66267  ENDIF
66268  160 CONTINUE
66269 
66270  ELSE
66271 C...If coming from resonance decay then find latest copy of this
66272 C...resonance (may not completely agree).
66273  kforig=k(imtau,2)
66274  iorig=imtau
66275  DO 170 ii=imtau+1,ip-1
66276  IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.
66277  & abs(p(ii,5)-p(iorig,5)).LT.1d-5*p(iorig,5)) iorig=ii
66278  170 CONTINUE
66279  DO 180 j=1,4
66280  pcmtau(j)=p(iorig,j)
66281  180 CONTINUE
66282  ENDIF
66283 
66284 C...Boost tau to rest frame of production process (where known)
66285 C...and rotate it to sit along +z axis.
66286  DO 190 j=1,3
66287  dbetau(j)=pcmtau(j)/pcmtau(4)
66288  190 CONTINUE
66289  IF(kforig.NE.0) CALL pyrobo(itau,itau,0d0,0d0,-dbetau(1),
66290  & -dbetau(2),-dbetau(3))
66291  phitau=pyangl(p(itau,1),p(itau,2))
66292  CALL pyrobo(itau,itau,0d0,-phitau,0d0,0d0,0d0)
66293  thetau=pyangl(p(itau,3),p(itau,1))
66294  CALL pyrobo(itau,itau,-thetau,0d0,0d0,0d0,0d0)
66295 
66296 C...Call tau decay routine (if meaningful) and fill extra info.
66297  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
66298  CALL pytaud(itau,iorig,kforig,ndecay)
66299  DO 200 ii=nsav+1,nsav+ndecay
66300  k(ii,1)=1
66301  k(ii,3)=ip
66302  k(ii,4)=0
66303  k(ii,5)=0
66304  200 CONTINUE
66305  n=nsav+ndecay
66306  ENDIF
66307 
66308 C...Boost back decay tau and decay products.
66309  DO 210 j=1,4
66310  p(itau,j)=ptau(j)
66311  210 CONTINUE
66312  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
66313  CALL pyrobo(nsav+1,n,thetau,phitau,0d0,0d0,0d0)
66314  IF(kforig.NE.0) CALL pyrobo(nsav+1,n,0d0,0d0,dbetau(1),
66315  & dbetau(2),dbetau(3))
66316 
66317 C...Skip past ordinary tau decay treatment.
66318  mmat=0
66319  mbst=0
66320  nd=0
66321  GOTO 630
66322  ENDIF
66323  ENDIF
66324 
66325 C...B-Bbar mixing: flip sign of meson appropriately.
66326  mmix=0
66327  IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
66328  xbbmix=parj(76)
66329  IF(kfa.EQ.531) xbbmix=parj(77)
66330  IF(sin(0.5d0*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.pyr(0)) mmix=1
66331  IF(mmix.EQ.1) kfs=-kfs
66332  ENDIF
66333 
66334 C...Check existence of decay channels. Particle/antiparticle rules.
66335  kca=kc
66336  IF(mdcy(kc,2).GT.0) THEN
66337  mdmdcy=mdme(mdcy(kc,2),2)
66338  IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
66339  ENDIF
66340  IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
66341  CALL pyerrm(9,'(PYDECY:) no decay channel defined')
66342  RETURN
66343  ENDIF
66344  IF(mod(kfa/1000,10).EQ.0.AND.kca.EQ.85) kfs=-kfs
66345  IF(kchg(kc,3).EQ.0) THEN
66346  kfsp=1
66347  kfsn=0
66348  IF(pyr(0).GT.0.5d0) kfs=-kfs
66349  ELSEIF(kfs.GT.0) THEN
66350  kfsp=1
66351  kfsn=0
66352  ELSE
66353  kfsp=0
66354  kfsn=1
66355  ENDIF
66356 
66357 C...Sum branching ratios of allowed decay channels.
66358  220 nope=0
66359  brsu=0d0
66360  DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
66361  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
66362  & kfsn*mdme(idl,1).NE.3) GOTO 230
66363  IF(mdme(idl,2).GT.100) GOTO 230
66364  nope=nope+1
66365  brsu=brsu+brat(idl)
66366  230 CONTINUE
66367  IF(nope.EQ.0) THEN
66368  CALL pyerrm(2,'(PYDECY:) all decay channels closed by user')
66369  RETURN
66370  ENDIF
66371 
66372 C...Select decay channel among allowed ones.
66373  240 rbr=brsu*pyr(0)
66374  idl=mdcy(kca,2)-1
66375  250 idl=idl+1
66376  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
66377  &kfsn*mdme(idl,1).NE.3) THEN
66378  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 250
66379  ELSEIF(mdme(idl,2).GT.100) THEN
66380  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 250
66381  ELSE
66382  idc=idl
66383  rbr=rbr-brat(idl)
66384  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0d0) GOTO 250
66385  ENDIF
66386 
66387 C...Start readout of decay channel: matrix element, reset counters.
66388  mmat=mdme(idc,2)
66389  260 ntry=ntry+1
66390  IF(mod(ntry,200).EQ.0) THEN
66391  WRITE(cidc,'(I4)') idc
66392 C...Do not print warning for some well-known special cases.
66393  IF(kfa.NE.113.AND.kfa.NE.115.AND.kfa.NE.215)
66394  & CALL pyerrm(4,'(PYDECY:) caught in loop for decay channel'//
66395  & cidc)
66396  GOTO 240
66397  ENDIF
66398  IF(ntry.GT.1000) THEN
66399  CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
66400  IF(mstu(21).GE.1) RETURN
66401  ENDIF
66402  i=n
66403  np=0
66404  nq=0
66405  mbst=0
66406  IF(mmat.GE.11.AND.p(ip,4).GT.20d0*p(ip,5)) mbst=1
66407  DO 270 j=1,4
66408  pv(1,j)=0d0
66409  IF(mbst.EQ.0) pv(1,j)=p(ip,j)
66410  270 CONTINUE
66411  IF(mbst.EQ.1) pv(1,4)=p(ip,5)
66412  pv(1,5)=p(ip,5)
66413  ps=0d0
66414  psq=0d0
66415  mrem=0
66416  mhaddy=0
66417  IF(kfa.GT.80) mhaddy=1
66418 C.. Random flavour and popcorn system memory.
66419  irndmo=0
66420  jtmo=0
66421  mstu(121)=0
66422  mstu(125)=10
66423 
66424 C...Read out decay products. Convert to standard flavour code.
66425  jtmax=5
66426  IF(mdme(idc+1,2).EQ.101) jtmax=10
66427  DO 280 jt=1,jtmax
66428  IF(jt.LE.5) kp=kfdp(idc,jt)
66429  IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
66430  IF(kp.EQ.0) GOTO 280
66431  kpa=iabs(kp)
66432  kcp=pycomp(kpa)
66433  IF(kpa.GT.80) mhaddy=1
66434  IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
66435  kfp=kp
66436  ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
66437  kfp=kfs*kp
66438  ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
66439  kfp=-kfs*mod(kfa/10,10)
66440  ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
66441  kfp=kfs*(100*mod(kfa/10,100)+3)
66442  ELSEIF(kpa.EQ.81) THEN
66443  kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
66444  ELSEIF(kp.EQ.82) THEN
66445  CALL pydcyk(-kfs*int(1d0+(2d0+parj(2))*pyr(0)),0,kfp,kdump)
66446  IF(kfp.EQ.0) GOTO 260
66447  kfp=-kfp
66448  irndmo=1
66449  mstj(93)=1
66450  IF(pv(1,5).LT.parj(32)+2d0*pymass(kfp)) GOTO 260
66451  ELSEIF(kp.EQ.-82) THEN
66452  kfp=mstu(124)
66453  ENDIF
66454  IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=pycomp(kfp)
66455 
66456 C...Add decay product to event record or to quark flavour list.
66457  kfpa=iabs(kfp)
66458  kqp=kchg(kcp,2)
66459  IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
66460  nq=nq+1
66461  kflo(nq)=kfp
66462 C...set rndmflav popcorn system pointer
66463  IF(kp.EQ.82.AND.mstu(121).GT.0) jtmo=nq
66464  mstj(93)=2
66465  psq=psq+pymass(kflo(nq))
66466  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
66467  & mod(nq,2).EQ.1) THEN
66468  nq=nq-1
66469  ps=ps-p(i,5)
66470  k(i,1)=1
66471  kfi=k(i,2)
66472  CALL pykfdi(kfp,kfi,kfldmp,k(i,2))
66473  IF(k(i,2).EQ.0) GOTO 260
66474  mstj(93)=1
66475  p(i,5)=pymass(k(i,2))
66476  ps=ps+p(i,5)
66477  ELSE
66478  i=i+1
66479  np=np+1
66480  IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
66481  IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
66482  k(i,1)=1+mod(nq,2)
66483  IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
66484  IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
66485  k(i,2)=kfp
66486  k(i,3)=ip
66487  k(i,4)=0
66488  k(i,5)=0
66489  p(i,5)=pymass(kfp)
66490  ps=ps+p(i,5)
66491  ENDIF
66492  280 CONTINUE
66493 
66494 C...Check masses for resonance decays.
66495  IF(mhaddy.EQ.0) THEN
66496  IF(ps+parj(64).GT.pv(1,5)) GOTO 240
66497  ENDIF
66498 
66499 C...Choose decay multiplicity in phase space model.
66500  290 IF(mmat.GE.11.AND.mmat.LE.30) THEN
66501  psp=ps
66502  cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1d0))
66503  IF(mmat.EQ.12) cnde=cnde+parj(63)
66504  300 ntry=ntry+1
66505 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66506  IF(irndmo.EQ.0) THEN
66507  mstu(121)=0
66508  jtmo=0
66509  ELSEIF(irndmo.EQ.1) THEN
66510  irndmo=2
66511  ELSE
66512  GOTO 260
66513  ENDIF
66514  IF(ntry.GT.1000) THEN
66515  CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
66516  IF(mstu(21).GE.1) RETURN
66517  ENDIF
66518  IF(mmat.LE.20) THEN
66519  gauss=sqrt(-2d0*cnde*log(max(1d-10,pyr(0))))*
66520  & sin(paru(2)*pyr(0))
66521  nd=0.5d0+0.5d0*np+0.25d0*nq+cnde+gauss
66522  IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) GOTO 300
66523  IF(mmat.EQ.13.AND.nd.EQ.2) GOTO 300
66524  IF(mmat.EQ.14.AND.nd.LE.3) GOTO 300
66525  IF(mmat.EQ.15.AND.nd.LE.4) GOTO 300
66526  ELSE
66527  nd=mmat-20
66528  ENDIF
66529 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66530  mstu(125)=nd-nq/2
66531  IF(mstu(121).GT.mstu(125)) GOTO 300
66532 
66533 C...Form hadrons from flavour content.
66534  DO 310 jt=1,nq
66535  kfl1(jt)=kflo(jt)
66536  310 CONTINUE
66537  IF(nd.EQ.np+nq/2) GOTO 330
66538  DO 320 i=n+np+1,n+nd-nq/2
66539 C.. Stick to started popcorn system, else pick side at random
66540  jt=jtmo
66541  IF(jt.EQ.0) jt=1+int((nq-1)*pyr(0))
66542  CALL pydcyk(kfl1(jt),0,kfl2,k(i,2))
66543  IF(k(i,2).EQ.0) GOTO 300
66544  mstu(125)=mstu(125)-1
66545  jtmo=0
66546  IF(mstu(121).GT.0) jtmo=jt
66547  kfl1(jt)=-kfl2
66548  320 CONTINUE
66549  330 jt=2
66550  jt2=3
66551  jt3=4
66552  IF(nq.EQ.4.AND.pyr(0).LT.parj(66)) jt=4
66553  IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
66554  & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
66555  IF(jt.EQ.3) jt2=2
66556  IF(jt.EQ.4) jt3=2
66557  CALL pydcyk(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
66558  IF(k(n+nd-nq/2+1,2).EQ.0) GOTO 300
66559  IF(nq.EQ.4) CALL pydcyk(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
66560  IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) GOTO 300
66561 
66562 C...Check that sum of decay product masses not too large.
66563  ps=psp
66564  DO 340 i=n+np+1,n+nd
66565  k(i,1)=1
66566  k(i,3)=ip
66567  k(i,4)=0
66568  k(i,5)=0
66569  p(i,5)=pymass(k(i,2))
66570  ps=ps+p(i,5)
66571  340 CONTINUE
66572  IF(ps+parj(64).GT.pv(1,5)) GOTO 300
66573 
66574 C...Rescale energy to subtract off spectator quark mass.
66575  ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44)
66576  & .AND.np.GE.3) THEN
66577  ps=ps-p(n+np,5)
66578  pqt=(p(n+np,5)+parj(65))/pv(1,5)
66579  DO 350 j=1,5
66580  p(n+np,j)=pqt*pv(1,j)
66581  pv(1,j)=(1d0-pqt)*pv(1,j)
66582  350 CONTINUE
66583  IF(ps+parj(64).GT.pv(1,5)) GOTO 260
66584  nd=np-1
66585  mrem=1
66586 
66587 C...Fully specified final state: check mass broadening effects.
66588  ELSE
66589  IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) GOTO 260
66590  nd=np
66591  ENDIF
66592 
66593 C...Determine position of grandmother, number of sisters.
66594  nm=0
66595  kfas=0
66596  msgn=0
66597  IF(mmat.EQ.3) THEN
66598  im=k(ip,3)
66599  IF(im.LT.0.OR.im.GE.ip) im=0
66600  IF(im.NE.0) kfam=iabs(k(im,2))
66601  IF(im.NE.0) THEN
66602  DO 360 il=max(ip-2,im+1),min(ip+2,n)
66603  IF(k(il,3).EQ.im) nm=nm+1
66604  IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
66605  360 CONTINUE
66606  IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
66607  & mod(kfam/1000,10).NE.0) nm=0
66608  IF(nm.EQ.2) THEN
66609  kfas=iabs(k(isis,2))
66610  IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
66611  & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
66612  ENDIF
66613  ENDIF
66614  ENDIF
66615 
66616 C...Kinematics of one-particle decays.
66617  IF(nd.EQ.1) THEN
66618  DO 370 j=1,4
66619  p(n+1,j)=p(ip,j)
66620  370 CONTINUE
66621  GOTO 630
66622  ENDIF
66623 
66624 C...Calculate maximum weight ND-particle decay.
66625  pv(nd,5)=p(n+nd,5)
66626  IF(nd.GE.3) THEN
66627  wtmax=1d0/wtcor(nd-2)
66628  pmax=pv(1,5)-ps+p(n+nd,5)
66629  pmin=0d0
66630  DO 380 il=nd-1,1,-1
66631  pmax=pmax+p(n+il,5)
66632  pmin=pmin+p(n+il+1,5)
66633  wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
66634  380 CONTINUE
66635  ENDIF
66636 
66637 C...Find virtual gamma mass in Dalitz decay.
66638  390 IF(nd.EQ.2) THEN
66639  ELSEIF(mmat.EQ.2) THEN
66640  pmes=4d0*pmas(11,1)**2
66641  pmrho2=pmas(131,1)**2
66642  pgrho2=pmas(131,2)**2
66643  400 pmst=pmes*(p(ip,5)**2/pmes)**pyr(0)
66644  wt=(1+0.5d0*pmes/pmst)*sqrt(max(0d0,1d0-pmes/pmst))*
66645  & (1d0-pmst/p(ip,5)**2)**3*(1d0+pgrho2/pmrho2)/
66646  & ((1d0-pmst/pmrho2)**2+pgrho2/pmrho2)
66647  IF(wt.LT.pyr(0)) GOTO 400
66648  pv(2,5)=max(2.00001d0*pmas(11,1),sqrt(pmst))
66649 
66650 C...M-generator gives weight. If rejected, try again.
66651  ELSE
66652  410 rord(1)=1d0
66653  DO 440 il1=2,nd-1
66654  rsav=pyr(0)
66655  DO 420 il2=il1-1,1,-1
66656  IF(rsav.LE.rord(il2)) GOTO 430
66657  rord(il2+1)=rord(il2)
66658  420 CONTINUE
66659  430 rord(il2+1)=rsav
66660  440 CONTINUE
66661  rord(nd)=0d0
66662  wt=1d0
66663  DO 450 il=nd-1,1,-1
66664  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*
66665  & (pv(1,5)-ps)
66666  wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
66667  450 CONTINUE
66668  IF(wt.LT.pyr(0)*wtmax) GOTO 410
66669  ENDIF
66670 
66671 C...Perform two-particle decays in respective CM frame.
66672  460 DO 480 il=1,nd-1
66673  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
66674  ue(3)=2d0*pyr(0)-1d0
66675  phi=paru(2)*pyr(0)
66676  ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
66677  ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
66678  DO 470 j=1,3
66679  p(n+il,j)=pa*ue(j)
66680  pv(il+1,j)=-pa*ue(j)
66681  470 CONTINUE
66682  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
66683  pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
66684  480 CONTINUE
66685 
66686 C...Lorentz transform decay products to lab frame.
66687  DO 490 j=1,4
66688  p(n+nd,j)=pv(nd,j)
66689  490 CONTINUE
66690  DO 530 il=nd-1,1,-1
66691  DO 500 j=1,3
66692  be(j)=pv(il,j)/pv(il,4)
66693  500 CONTINUE
66694  ga=pv(il,4)/pv(il,5)
66695  DO 520 i=n+il,n+nd
66696  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
66697  DO 510 j=1,3
66698  p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
66699  510 CONTINUE
66700  p(i,4)=ga*(p(i,4)+bep)
66701  520 CONTINUE
66702  530 CONTINUE
66703 
66704 C...Check that no infinite loop in matrix element weight.
66705  ntry=ntry+1
66706  IF(ntry.GT.800) GOTO 560
66707 
66708 C...Matrix elements for omega and phi decays.
66709  IF(mmat.EQ.1) THEN
66710  wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
66711  & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
66712  & +2d0*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
66713  IF(max(wt*wtcor(9)/p(ip,5)**6,0.001d0).LT.pyr(0)) GOTO 390
66714 
66715 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66716  ELSEIF(mmat.EQ.2) THEN
66717  four12=four(n+1,n+2)
66718  four13=four(n+1,n+3)
66719  wt=(pmst-0.5d0*pmes)*(four12**2+four13**2)+
66720  & pmes*(four12*four13+four12**2+four13**2)
66721  IF(wt.LT.pyr(0)*0.25d0*pmst*(p(ip,5)**2-pmst)**2) GOTO 460
66722 
66723 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66724 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66725 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66726  ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
66727  four10=four(ip,im)
66728  four12=four(ip,n+1)
66729  four02=four(im,n+1)
66730  pms1=p(ip,5)**2
66731  pms0=p(im,5)**2
66732  pms2=p(n+1,5)**2
66733  IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
66734  IF(kfas.EQ.22) hnum=pms1*(2d0*four10*four12*four02-
66735  & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
66736  hnum=max(1d-6*pms1**2*pms0*pms2,hnum)
66737  hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
66738  IF(hnum.LT.pyr(0)*hden) GOTO 460
66739 
66740 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66741  ELSEIF(mmat.EQ.4) THEN
66742  hx1=2d0*four(ip,n+1)/p(ip,5)**2
66743  hx2=2d0*four(ip,n+2)/p(ip,5)**2
66744  hx3=2d0*four(ip,n+3)/p(ip,5)**2
66745  wt=((1d0-hx1)/(hx2*hx3))**2+((1d0-hx2)/(hx1*hx3))**2+
66746  & ((1d0-hx3)/(hx1*hx2))**2
66747  IF(wt.LT.2d0*pyr(0)) GOTO 390
66748  IF(k(ip+1,2).EQ.22.AND.(1d0-hx1)*p(ip,5)**2.LT.4d0*parj(32)**2)
66749  & GOTO 390
66750 
66751 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66752  ELSEIF(mmat.EQ.41) THEN
66753  IF(mbst.EQ.0) hx1=2d0*four(ip,n+1)/p(ip,5)**2
66754  IF(mbst.EQ.1) hx1=2d0*p(n+1,4)/p(ip,5)
66755  hxm=min(0.75d0,2d0*(1d0-ps/p(ip,5)))
66756  IF(hx1*(3d0-2d0*hx1).LT.pyr(0)*hxm*(3d0-2d0*hxm)) GOTO 390
66757 
66758 C...Matrix elements for weak decays (only semileptonic for c and b)
66759  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
66760  & .AND.nd.EQ.3) THEN
66761  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
66762  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
66763  IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 390
66764  ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
66765  DO 550 j=1,4
66766  p(n+np+1,j)=0d0
66767  DO 540 is=n+3,n+np
66768  p(n+np+1,j)=p(n+np+1,j)+p(is,j)
66769  540 CONTINUE
66770  550 CONTINUE
66771  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
66772  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
66773  IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 390
66774  ENDIF
66775 
66776 C...Scale back energy and reattach spectator.
66777  560 IF(mrem.EQ.1) THEN
66778  DO 570 j=1,5
66779  pv(1,j)=pv(1,j)/(1d0-pqt)
66780  570 CONTINUE
66781  nd=nd+1
66782  mrem=0
66783  ENDIF
66784 
66785 C...Low invariant mass for system with spectator quark gives particle,
66786 C...not two jets. Readjust momenta accordingly.
66787  IF(mmat.EQ.31.AND.nd.EQ.3) THEN
66788  mstj(93)=1
66789  pm2=pymass(k(n+2,2))
66790  mstj(93)=1
66791  pm3=pymass(k(n+3,2))
66792  IF(p(n+2,5)**2+p(n+3,5)**2+2d0*four(n+2,n+3).GE.
66793  & (parj(32)+pm2+pm3)**2) GOTO 630
66794  k(n+2,1)=1
66795  kftemp=k(n+2,2)
66796  CALL pykfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
66797  IF(k(n+2,2).EQ.0) GOTO 260
66798  p(n+2,5)=pymass(k(n+2,2))
66799  ps=p(n+1,5)+p(n+2,5)
66800  pv(2,5)=p(n+2,5)
66801  mmat=0
66802  nd=2
66803  GOTO 460
66804  ELSEIF(mmat.EQ.44) THEN
66805  mstj(93)=1
66806  pm3=pymass(k(n+3,2))
66807  mstj(93)=1
66808  pm4=pymass(k(n+4,2))
66809  IF(p(n+3,5)**2+p(n+4,5)**2+2d0*four(n+3,n+4).GE.
66810  & (parj(32)+pm3+pm4)**2) GOTO 600
66811  k(n+3,1)=1
66812  kftemp=k(n+3,2)
66813  CALL pykfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
66814  IF(k(n+3,2).EQ.0) GOTO 260
66815  p(n+3,5)=pymass(k(n+3,2))
66816  DO 580 j=1,3
66817  p(n+3,j)=p(n+3,j)+p(n+4,j)
66818  580 CONTINUE
66819  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)
66820  ha=p(n+1,4)**2-p(n+2,4)**2
66821  hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
66822  hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
66823  & (p(n+1,3)-p(n+2,3))**2
66824  hd=(pv(1,4)-p(n+3,4))**2
66825  he=ha**2-2d0*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
66826  hf=hd*hc-hb**2
66827  hg=hd*hc-ha*hb
66828  hh=(sqrt(hg**2+he*hf)-hg)/(2d0*hf)
66829  DO 590 j=1,3
66830  pcor=hh*(p(n+1,j)-p(n+2,j))
66831  p(n+1,j)=p(n+1,j)+pcor
66832  p(n+2,j)=p(n+2,j)-pcor
66833  590 CONTINUE
66834  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)
66835  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)
66836  nd=nd-1
66837  ENDIF
66838 
66839 C...Check invariant mass of W jets. May give one particle or start over.
66840  600 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
66841  &.AND.iabs(k(n+1,2)).LT.10) THEN
66842  pmr=sqrt(max(0d0,p(n+1,5)**2+p(n+2,5)**2+2d0*four(n+1,n+2)))
66843  mstj(93)=1
66844  pm1=pymass(k(n+1,2))
66845  mstj(93)=1
66846  pm2=pymass(k(n+2,2))
66847  IF(pmr.GT.parj(32)+pm1+pm2) GOTO 610
66848  kfldum=int(1.5d0+pyr(0))
66849  CALL pykfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
66850  CALL pykfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
66851  IF(kf1.EQ.0.OR.kf2.EQ.0) GOTO 260
66852  psm=pymass(kf1)+pymass(kf2)
66853  IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) GOTO 610
66854  IF(mmat.GE.43.AND.pmr.GT.0.2d0*parj(32)+psm) GOTO 610
66855  IF(mmat.EQ.48) GOTO 390
66856  IF(nd.EQ.4.OR.kfa.EQ.15) GOTO 260
66857  k(n+1,1)=1
66858  kftemp=k(n+1,2)
66859  CALL pykfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
66860  IF(k(n+1,2).EQ.0) GOTO 260
66861  p(n+1,5)=pymass(k(n+1,2))
66862  k(n+2,2)=k(n+3,2)
66863  p(n+2,5)=p(n+3,5)
66864  ps=p(n+1,5)+p(n+2,5)
66865  IF(ps+parj(64).GT.pv(1,5)) GOTO 260
66866  pv(2,5)=p(n+3,5)
66867  mmat=0
66868  nd=2
66869  GOTO 460
66870  ENDIF
66871 
66872 C...Phase space decay of partons from W decay.
66873  610 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
66874  kflo(1)=k(n+1,2)
66875  kflo(2)=k(n+2,2)
66876  k(n+1,1)=k(n+3,1)
66877  k(n+1,2)=k(n+3,2)
66878  DO 620 j=1,5
66879  pv(1,j)=p(n+1,j)+p(n+2,j)
66880  p(n+1,j)=p(n+3,j)
66881  620 CONTINUE
66882  pv(1,5)=pmr
66883  n=n+1
66884  np=0
66885  nq=2
66886  ps=0d0
66887  mstj(93)=2
66888  psq=pymass(kflo(1))
66889  mstj(93)=2
66890  psq=psq+pymass(kflo(2))
66891  mmat=11
66892  GOTO 290
66893  ENDIF
66894 
66895 C...Boost back for rapidly moving particle.
66896  630 n=n+nd
66897  IF(mbst.EQ.1) THEN
66898  DO 640 j=1,3
66899  be(j)=p(ip,j)/p(ip,4)
66900  640 CONTINUE
66901  ga=p(ip,4)/p(ip,5)
66902  DO 660 i=nsav+1,n
66903  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
66904  DO 650 j=1,3
66905  p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
66906  650 CONTINUE
66907  p(i,4)=ga*(p(i,4)+bep)
66908  660 CONTINUE
66909  ENDIF
66910 
66911 C...Fill in position of decay vertex.
66912  DO 680 i=nsav+1,n
66913  DO 670 j=1,4
66914  v(i,j)=vdcy(j)
66915  670 CONTINUE
66916  v(i,5)=0d0
66917  680 CONTINUE
66918 
66919 C...Set up for parton shower evolution from jets.
66920  IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
66921  k(nsav+1,1)=3
66922  k(nsav+2,1)=3
66923  k(nsav+3,1)=3
66924  k(nsav+1,4)=mstu(5)*(nsav+2)
66925  k(nsav+1,5)=mstu(5)*(nsav+3)
66926  k(nsav+2,4)=mstu(5)*(nsav+3)
66927  k(nsav+2,5)=mstu(5)*(nsav+1)
66928  k(nsav+3,4)=mstu(5)*(nsav+1)
66929  k(nsav+3,5)=mstu(5)*(nsav+2)
66930  mstj(92)=-(nsav+1)
66931  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
66932  k(nsav+2,1)=3
66933  k(nsav+3,1)=3
66934  k(nsav+2,4)=mstu(5)*(nsav+3)
66935  k(nsav+2,5)=mstu(5)*(nsav+3)
66936  k(nsav+3,4)=mstu(5)*(nsav+2)
66937  k(nsav+3,5)=mstu(5)*(nsav+2)
66938  mstj(92)=nsav+2
66939  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
66940  & iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
66941  k(nsav+1,1)=3
66942  k(nsav+2,1)=3
66943  k(nsav+1,4)=mstu(5)*(nsav+2)
66944  k(nsav+1,5)=mstu(5)*(nsav+2)
66945  k(nsav+2,4)=mstu(5)*(nsav+1)
66946  k(nsav+2,5)=mstu(5)*(nsav+1)
66947  mstj(92)=nsav+1
66948  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
66949  & iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
66950  mstj(92)=nsav+1
66951  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
66952  & THEN
66953  k(nsav+1,1)=3
66954  k(nsav+2,1)=3
66955  k(nsav+3,1)=3
66956  kcp=pycomp(k(nsav+1,2))
66957  kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
66958  jcon=4
66959  IF(kqp.LT.0) jcon=5
66960  k(nsav+1,jcon)=mstu(5)*(nsav+2)
66961  k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
66962  k(nsav+2,jcon)=mstu(5)*(nsav+3)
66963  k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
66964  mstj(92)=nsav+1
66965  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
66966  k(nsav+1,1)=3
66967  k(nsav+3,1)=3
66968  k(nsav+1,4)=mstu(5)*(nsav+3)
66969  k(nsav+1,5)=mstu(5)*(nsav+3)
66970  k(nsav+3,4)=mstu(5)*(nsav+1)
66971  k(nsav+3,5)=mstu(5)*(nsav+1)
66972  mstj(92)=nsav+1
66973  ENDIF
66974 
66975 C...Mark decayed particle; special option for B-Bbar mixing.
66976  IF(k(ip,1).EQ.5) k(ip,1)=15
66977  IF(k(ip,1).LE.10) k(ip,1)=11
66978  IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
66979  k(ip,4)=nsav+1
66980  k(ip,5)=n
66981 
66982  RETURN
66983  END
66984 
66985 
66986 C*********************************************************************
66987 
66988 C...PYDCYK
66989 C...Handles flavour production in the decay of unstable particles
66990 C...and small string clusters.
66991 
66992  SUBROUTINE pydcyk(KFL1,KFL2,KFL3,KF)
66993 
66994 C...Double precision and integer declarations.
66995  IMPLICIT DOUBLE PRECISION(a-h, o-z)
66996  IMPLICIT INTEGER(I-N)
66997  INTEGER PYK,PYCHGE,PYCOMP
66998 C...Commonblocks.
66999  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67000  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67001  SAVE /pydat1/,/pydat2/
67002 
67003 
67004 C.. Call PYKFDI directly if no popcorn option is on
67005  IF(mstj(12).LT.2) THEN
67006  CALL pykfdi(kfl1,kfl2,kfl3,kf)
67007  mstu(124)=kfl3
67008  RETURN
67009  ENDIF
67010 
67011  kfl3=0
67012  kf=0
67013  IF(kfl1.EQ.0) RETURN
67014  kf1a=iabs(kfl1)
67015  kf2a=iabs(kfl2)
67016 
67017  nsto=130
67018  nmax=min(mstu(125),10)
67019 
67020 C.. Identify rank 0 cluster qq
67021  irank=1
67022  IF(kf1a.GT.10.AND.kf1a.LT.10000) irank=0
67023 
67024  IF(kf2a.GT.0)THEN
67025 C.. Join jets: Fails if store not empty
67026  IF(mstu(121).GT.0) THEN
67027  mstu(121)=0
67028  RETURN
67029  ENDIF
67030  CALL pykfdi(kfl1,kfl2,kfl3,kf)
67031  ELSEIF(kf1a.GT.10.AND.mstu(121).GT.0)THEN
67032 C.. Pick popcorn meson from store, return same qq, decrease store
67033  kf=mstu(nsto+mstu(121))
67034  kfl3=-kfl1
67035  mstu(121)=mstu(121)-1
67036  ELSE
67037 C.. Generate new flavour. Then done if no diquark is generated
67038  100 CALL pykfdi(kfl1,0,kfl3,kf)
67039  IF(mstu(121).EQ.-1) GOTO 100
67040  mstu(124)=kfl3
67041  IF(kf.EQ.0.OR.iabs(kfl3).LE.10) RETURN
67042 
67043 C.. Simple case if no dynamical popcorn suppressions are considered
67044  IF(mstj(12).LT.4) THEN
67045  IF(mstu(121).EQ.0) RETURN
67046  nmes=1
67047  kfprev=-kfl3
67048  CALL pykfdi(kfprev,0,kfl3,kfm)
67049 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67050  IF(iabs(kfl3).LE.10)THEN
67051  kfl3=-kfprev
67052  RETURN
67053  ENDIF
67054  GOTO 120
67055  ENDIF
67056 
67057 C test output qq against fake Gamma, then return if no popcorn.
67058  gb=2d0
67059  IF(irank.NE.0)THEN
67060  CALL pyzdis(1,2103,5d0,z)
67061  gb=5d0*(1d0-z)/z
67062  IF(1d0-parf(192)**gb.LT.pyr(0)) THEN
67063  mstu(121)=0
67064  GOTO 100
67065  ENDIF
67066  ENDIF
67067  IF(mstu(121).EQ.0) RETURN
67068 
67069 C..Set store size memory. Pick fake dynamical variables of qq.
67070  nmes=mstu(121)
67071  CALL pyptdi(1,px3,py3)
67072  x=1d0
67073  popm=0d0
67074  g=gb
67075  popg=gb
67076 
67077 C.. Pick next popcorn meson, test with fake dynamical variables
67078  110 kfprev=-kfl3
67079  px1=-px3
67080  py1=-py3
67081  CALL pykfdi(kfprev,0,kfl3,kfm)
67082  IF(mstu(121).EQ.-1) GOTO 100
67083  CALL pyptdi(kfl3,px3,py3)
67084  pm=pymass(kfm)**2+(px1+px3)**2+(py1+py3)**2
67085  CALL pyzdis(kfprev,kfl3,pm,z)
67086  g=(1d0-z)*(g+pm/z)
67087  x=(1d0-z)*x
67088 
67089  ptst=1d0
67090  gtst=1d0
67091  rtst=pyr(0)
67092  IF(mstj(12).GT.4)THEN
67093  popmn=sqrt((1d0-x)*(g/x-gb))
67094  popm=popm+pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
67095  ptst=exp((popm-popmn)*parf(193))
67096  popm=popmn
67097  ENDIF
67098  IF(irank.NE.0)THEN
67099  popgn=x*gb
67100  gtst=(1d0-parf(192)**popgn)/(1d0-parf(192)**popg)
67101  popg=popgn
67102  ENDIF
67103  IF(rtst.GT.ptst*gtst)THEN
67104  mstu(121)=0
67105  IF(rtst.GT.ptst) mstu(121)=-1
67106  GOTO 100
67107  ENDIF
67108 
67109 C.. Store meson
67110  120 IF(nmes.LE.nmax) mstu(nsto+mstu(121)+1)=kfm
67111  IF(mstu(121).GT.0) GOTO 110
67112 
67113 C.. Test accepted system size. If OK set global popcorn size variable.
67114  IF(nmes.GT.nmax)THEN
67115  kf=0
67116  kfl3=0
67117  RETURN
67118  ENDIF
67119  mstu(121)=nmes
67120  ENDIF
67121 
67122  RETURN
67123  END
67124 
67125 C********************************************************************
67126 
67127 C...PYKFDI
67128 C...Generates a new flavour pair and combines off a hadron
67129 
67130  SUBROUTINE pykfdi(KFL1,KFL2,KFL3,KF)
67131 
67132 C...Double precision and integer declarations.
67133  IMPLICIT DOUBLE PRECISION(a-h, o-z)
67134  IMPLICIT INTEGER(I-N)
67135  INTEGER PYK,PYCHGE,PYCOMP
67136 C...Commonblocks.
67137  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67138  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67139  SAVE /pydat1/,/pydat2/
67140 C...Local arrays.
67141  dimension pd(7)
67142 
67143  IF(mstu(123).EQ.0.AND.mstj(12).GE.0) CALL pykfin
67144 
67145 C...Default flavour values. Input consistency checks.
67146  kf1a=iabs(kfl1)
67147  kf2a=iabs(kfl2)
67148  kfl3=0
67149  kf=0
67150  IF(kf1a.EQ.0) RETURN
67151  IF(kf2a.NE.0)THEN
67152  IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
67153  IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
67154  IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
67155  ENDIF
67156 
67157 C...Check if tabulated flavour probabilities are to be used.
67158  IF(mstj(15).EQ.1) THEN
67159  IF(mstj(12).GE.5) CALL pyerrm(29,
67160  & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67161  & ' together with MSTJ(12)>=5 modification')
67162  ktab1=-1
67163  IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
67164  kfl1a=mod(kf1a/1000,10)
67165  kfl1b=mod(kf1a/100,10)
67166  kfl1s=mod(kf1a,10)
67167  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
67168  & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
67169  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
67170  IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
67171  ktab2=0
67172  IF(kf2a.NE.0) THEN
67173  ktab2=-1
67174  IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
67175  kfl2a=mod(kf2a/1000,10)
67176  kfl2b=mod(kf2a/100,10)
67177  kfl2s=mod(kf2a,10)
67178  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
67179  & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
67180  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
67181  ENDIF
67182  IF(ktab1.GE.0.AND.ktab2.GE.0) GOTO 140
67183  ENDIF
67184 
67185 C.. Recognize rank 0 diquark case
67186  100 irank=1
67187  kfdiq=max(kf1a,kf2a)
67188  IF(kfdiq.GT.10.AND.kfdiq.LT.10000) irank=0
67189 
67190 C.. Join two flavours to meson or baryon. Test for popcorn.
67191  IF(kf2a.GT.0)THEN
67192  mbary=0
67193  IF(kfdiq.GT.10) THEN
67194  IF(irank.EQ.0.AND.mstj(12).LT.5)
67195  & CALL pynmes(kfdiq)
67196  IF(mstu(121).NE.0) THEN
67197  mstu(121)=0
67198  RETURN
67199  ENDIF
67200  mbary=2
67201  ENDIF
67202  kfqold=kf1a
67203  kfqver=kf2a
67204  GOTO 130
67205  ENDIF
67206 
67207 C.. Separate incoming flavours, curtain flavour consistency check
67208  kfin=kfl1
67209  kfqold=kf1a
67210  kfqpop=kf1a/10000
67211  IF(kf1a.GT.10)THEN
67212  kfin=-kfl1
67213  kfl1a=mod(kf1a/1000,10)
67214  kfl1b=mod(kf1a/100,10)
67215  IF(irank.EQ.0)THEN
67216  qawt=1d0
67217  IF(kfl1a.GE.3) qawt=parf(136+kfl1a/4)
67218  IF(kfl1b.GE.3) qawt=qawt/parf(136+kfl1b/4)
67219  kfqpop=kfl1a+(kfl1b-kfl1a)*int(1d0/(qawt+1d0)+pyr(0))
67220  ENDIF
67221  IF(kfqpop.NE.kfl1b.AND.kfqpop.NE.kfl1a) THEN
67222  mstu(121)=0
67223  RETURN
67224  ENDIF
67225  kfqold=kfl1a+kfl1b-kfqpop
67226  ENDIF
67227 
67228 C...Meson/baryon choice. Set number of mesons if starting a popcorn
67229 C...system.
67230  110 mbary=0
67231  IF(kf1a.LE.10.AND.mstj(12).GT.0)THEN
67232  IF(mstu(121).EQ.-1.OR.(1d0+parj(1))*pyr(0).GT.1d0)THEN
67233  mbary=1
67234  CALL pynmes(0)
67235  ENDIF
67236  ELSEIF(kf1a.GT.10)THEN
67237  mbary=2
67238  IF(irank.EQ.0) CALL pynmes(kf1a)
67239  IF(mstu(121).GT.0) mbary=-1
67240  ENDIF
67241 
67242 C..x->H+q: Choose single vertex quark. Jump to form hadron.
67243  IF(mbary.EQ.0.OR.mbary.EQ.2)THEN
67244  kfqver=1+int((2d0+parj(2))*pyr(0))
67245  kfl3=isign(kfqver,-kfin)
67246  GOTO 130
67247  ENDIF
67248 
67249 C..x->H+qq: (IDW=proper PARF position for diquark weights)
67250  idw=160
67251  IF(mbary.EQ.1)THEN
67252  IF(mstu(121).EQ.0) idw=150
67253  sqwt=parf(idw+1)
67254  IF(mstu(121).GT.0) sqwt=sqwt*parf(135)*parf(138)**mstu(121)
67255  kfqpop=1+int((2d0+sqwt)*pyr(0))
67256 C.. Shift to s-curtain parameters if needed
67257  IF(kfqpop.GE.3.AND.mstj(12).GE.5)THEN
67258  parf(194)=parf(138)*parf(139)
67259  parf(193)=parj(8)+parj(9)
67260  ENDIF
67261  ENDIF
67262 
67263 C.. x->H+qq: Get vertex quark
67264  IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
67265  idw=mstu(122)
67266  mstu(121)=mstu(121)-1
67267  IF(idw.EQ.170) THEN
67268  IF(mstu(121).EQ.0)THEN
67269  ipos=3*min(kfqpop-1,2)+min(kfqold-1,2)
67270  ELSE
67271  ipos=3*3+3*max(0,min(kfqpop-2,1))+min(kfqold-1,2)
67272  ENDIF
67273  ELSE
67274  IF(mstu(121).EQ.0)THEN
67275  ipos=3*5+5*min(kfqpop-1,3)+min(kfqold-1,4)
67276  ELSE
67277  ipos=3*5+5*4+min(kfqold-1,4)
67278  ENDIF
67279  ENDIF
67280  ipos=200+30*ipos+1
67281 
67282  imes=-1
67283  rmes=pyr(0)*parf(194)
67284  120 imes=imes+1
67285  rmes=rmes-parf(ipos+imes)
67286  IF(imes.EQ.30) THEN
67287  mstu(121)=-1
67288  kf=-111
67289  RETURN
67290  ENDIF
67291  IF(rmes.GT.0d0) GOTO 120
67292  kmul=imes/5
67293  kfj=2*kmul+1
67294  IF(kmul.EQ.2) kfj=10003
67295  IF(kmul.EQ.3) kfj=10001
67296  IF(kmul.EQ.4) kfj=20003
67297  IF(kmul.EQ.5) kfj=5
67298  idiag=0
67299  kfqver=mod(imes,5)+1
67300  IF(kfqver.GE.kfqold) kfqver=kfqver+1
67301  IF(kfqver.GT.3)THEN
67302  idiag=kfqver-3
67303  kfqver=kfqold
67304  ENDIF
67305  ELSE
67306  IF(mbary.EQ.-1) idw=170
67307  sqwt=parf(idw+2)
67308  IF(kfqpop.EQ.3) sqwt=parf(idw+3)
67309  IF(kfqpop.GT.3) sqwt=parf(idw+3)*(1d0/parf(idw+5)+1d0)/2d0
67310  kfqver=min(3,1+int((2d0+sqwt)*pyr(0)))
67311  IF(kfqpop.LT.3.AND.kfqver.LT.3)THEN
67312  kfqver=kfqpop
67313  IF(pyr(0).GT.parf(idw+4)) kfqver=3-kfqpop
67314  ENDIF
67315  ENDIF
67316 
67317 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67318  kflds=3
67319  IF(kfqpop.NE.kfqver)THEN
67320  swt=parf(idw+7)
67321  IF(kfqver.EQ.3) swt=parf(idw+6)
67322  IF(kfqpop.GE.3) swt=parf(idw+5)
67323  IF((1d0+swt)*pyr(0).LT.1d0) kflds=1
67324  ENDIF
67325  kfdiq=900*max(kfqver,kfqpop)+100*(kfqver+kfqpop)+kflds
67326  & +10000*kfqpop
67327  kfl3=isign(kfdiq,kfin)
67328 
67329 C..x->M+y: flavour for meson.
67330  130 IF(mbary.LE.0)THEN
67331  kfla=max(kfqold,kfqver)
67332  kflb=min(kfqold,kfqver)
67333  kfs=isign(1,kfl1)
67334  IF(kfla.NE.kfqold) kfs=-kfs
67335 C... Form meson, with spin and flavour mixing for diagonal states.
67336  IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
67337  IF(idiag.GT.0) kf=110*idiag+kfj
67338  IF(idiag.EQ.0) kf=(100*kfla+10*kflb+kfj)*kfs*(-1)**kfla
67339  RETURN
67340  ENDIF
67341  IF(kfla.LE.2) kmul=int(parj(11)+pyr(0))
67342  IF(kfla.EQ.3) kmul=int(parj(12)+pyr(0))
67343  IF(kfla.GE.4) kmul=int(parj(13)+pyr(0))
67344  IF(kmul.EQ.0.AND.parj(14).GT.0d0)THEN
67345  IF(pyr(0).LT.parj(14)) kmul=2
67346  ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0d0)THEN
67347  rmul=pyr(0)
67348  IF(rmul.LT.parj(15)) kmul=3
67349  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
67350  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
67351  ENDIF
67352  kfls=3
67353  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
67354  IF(kmul.EQ.5) kfls=5
67355  IF(kfla.NE.kflb)THEN
67356  kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
67357  ELSE
67358  rmix=pyr(0)
67359  imix=2*kfla+10*kmul
67360  IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
67361  & int(rmix+parf(imix)))+kfls
67362  IF(kfla.GE.4) kf=110*kfla+kfls
67363  ENDIF
67364  IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
67365  IF(kmul.EQ.4) kf=kf+isign(20000,kf)
67366 
67367 C..Optional extra suppression of eta and eta'.
67368 C..Allow shift to qq->B+q in old version (set IRANK to 0)
67369  IF(kf.EQ.221.OR.kf.EQ.331)THEN
67370  IF(pyr(0).GT.parj(25+kf/300))THEN
67371  IF(kf2a.GT.0) GOTO 130
67372  IF(mstj(12).LT.4) irank=0
67373  GOTO 110
67374  ENDIF
67375  ENDIF
67376  mstu(121)=0
67377 
67378 C.. x->B+y: Flavour for baryon
67379  ELSE
67380  kfla=kfqver
67381  IF(kf1a.LE.10) kfla=kfqold
67382  kflb=mod(kfdiq/1000,10)
67383  kflc=mod(kfdiq/100,10)
67384  kflds=mod(kfdiq,10)
67385  kfld=max(kfla,kflb,kflc)
67386  kflf=min(kfla,kflb,kflc)
67387  kfle=kfla+kflb+kflc-kfld-kflf
67388 
67389 C... SU(6) factors for formation of baryon.
67390  kbary=3
67391  kdmax=5
67392  kflg=kflb
67393  IF(kflb.NE.kflc)THEN
67394  kbary=2*kflds-1
67395  kdmax=1+kflds/2
67396  IF(kflb.GT.2) kdmax=kdmax+2
67397  ENDIF
67398  IF(kfla.NE.kflb.AND.kfla.NE.kflc)THEN
67399  kbary=kbary+1
67400  kflg=kfla
67401  ENDIF
67402 
67403  su6max=parf(140+kdmax)
67404  su6dec=parj(18)
67405  su6s =parf(146)
67406  IF(mstj(12).GE.5.AND.irank.EQ.0) THEN
67407  su6max=1d0
67408  su6dec=1d0
67409  su6s =1d0
67410  ENDIF
67411  su6oct=parf(60+kbary)
67412  IF(kflg.GT.max(kfla+kflb-kflg,2))THEN
67413  su6oct=su6oct*4*su6s/(3*su6s+1)
67414  IF(kbary.EQ.2) su6oct=parf(60+kbary)*4/(3*su6s+1)
67415  ELSE
67416  IF(kbary.EQ.6) su6oct=su6oct*(3+su6s)/(3*su6s+1)
67417  ENDIF
67418  su6wt=su6oct+su6dec*parf(70+kbary)
67419 
67420 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67421  IF(su6wt.LT.pyr(0)*su6max.AND.kf2a.EQ.0)THEN
67422  mstu(121)=0
67423  IF(mstj(12).LE.2.AND.mbary.EQ.1) mstu(121)=-1
67424  GOTO 110
67425  ENDIF
67426 
67427 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67428  ksig=1
67429  kfls=2
67430  IF(su6wt*pyr(0).GT.su6oct) kfls=4
67431  IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf)THEN
67432  ksig=kflds/3
67433  IF(kfla.NE.kfld) ksig=int(3*su6s/(3*su6s+kflds**2)+pyr(0))
67434  ENDIF
67435  kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
67436  IF(ksig.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
67437  ENDIF
67438  RETURN
67439 
67440 C...Use tabulated probabilities to select new flavour and hadron.
67441  140 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
67442  kt3l=1
67443  kt3u=6
67444  ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
67445  kt3l=1
67446  kt3u=6
67447  ELSEIF(ktab2.EQ.0) THEN
67448  kt3l=1
67449  kt3u=22
67450  ELSE
67451  kt3l=ktab2
67452  kt3u=ktab2
67453  ENDIF
67454  rfl=0d0
67455  DO 160 kts=0,2
67456  DO 150 kt3=kt3l,kt3u
67457  rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
67458  150 CONTINUE
67459  160 CONTINUE
67460  rfl=pyr(0)*rfl
67461  DO 180 kts=0,2
67462  ktabs=kts
67463  DO 170 kt3=kt3l,kt3u
67464  ktab3=kt3
67465  rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
67466  IF(rfl.LE.0d0) GOTO 190
67467  170 CONTINUE
67468  180 CONTINUE
67469  190 CONTINUE
67470 
67471 C...Reconstruct flavour of produced quark/diquark.
67472  IF(ktab3.LE.6) THEN
67473  kfl3a=ktab3
67474  kfl3b=0
67475  kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
67476  ELSE
67477  kfl3a=1
67478  IF(ktab3.GE.8) kfl3a=2
67479  IF(ktab3.GE.11) kfl3a=3
67480  IF(ktab3.GE.16) kfl3a=4
67481  kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
67482  kfl3=1000*kfl3a+100*kfl3b+1
67483  IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
67484  & kfl3+2
67485  kfl3=isign(kfl3,kfl1*(13-2*ktab1))
67486  ENDIF
67487 
67488 C...Reconstruct meson code.
67489  IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
67490  &kfl3b.NE.0)) THEN
67491  rfl=pyr(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
67492  & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
67493  kf=110+2*ktabs+1
67494  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
67495  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
67496  & 25*ktabs)) kf=330+2*ktabs+1
67497  ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
67498  kfla=max(ktab1,ktab3)
67499  kflb=min(ktab1,ktab3)
67500  kfs=isign(1,kfl1)
67501  IF(kfla.NE.kf1a) kfs=-kfs
67502  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
67503  ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
67504  kfs=isign(1,kfl1)
67505  IF(kfl1a.EQ.kfl3a) THEN
67506  kfla=max(kfl1b,kfl3b)
67507  kflb=min(kfl1b,kfl3b)
67508  IF(kfla.NE.kfl1b) kfs=-kfs
67509  ELSEIF(kfl1a.EQ.kfl3b) THEN
67510  kfla=kfl3a
67511  kflb=kfl1b
67512  kfs=-kfs
67513  ELSEIF(kfl1b.EQ.kfl3a) THEN
67514  kfla=kfl1a
67515  kflb=kfl3b
67516  ELSEIF(kfl1b.EQ.kfl3b) THEN
67517  kfla=max(kfl1a,kfl3a)
67518  kflb=min(kfl1a,kfl3a)
67519  IF(kfla.NE.kfl1a) kfs=-kfs
67520  ELSE
67521  CALL pyerrm(2,'(PYKFDI:) no matching flavours for qq -> qq')
67522  GOTO 100
67523  ENDIF
67524  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
67525 
67526 C...Reconstruct baryon code.
67527  ELSE
67528  IF(ktab1.GE.7) THEN
67529  kfla=kfl3a
67530  kflb=kfl1a
67531  kflc=kfl1b
67532  ELSE
67533  kfla=kfl1a
67534  kflb=kfl3a
67535  kflc=kfl3b
67536  ENDIF
67537  kfld=max(kfla,kflb,kflc)
67538  kflf=min(kfla,kflb,kflc)
67539  kfle=kfla+kflb+kflc-kfld-kflf
67540  IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
67541  IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
67542  ENDIF
67543 
67544 C...Check that constructed flavour code is an allowed one.
67545  IF(kfl2.NE.0) kfl3=0
67546  kc=pycomp(kf)
67547  IF(kc.EQ.0) THEN
67548  CALL pyerrm(2,'(PYKFDI:) user-defined flavour probabilities '//
67549  & 'failed')
67550  GOTO 100
67551  ENDIF
67552 
67553  RETURN
67554  END
67555 
67556 C*********************************************************************
67557 
67558 C...PYNMES
67559 C...Generates number of popcorn mesons and stores some relevant
67560 C...parameters.
67561 
67562  SUBROUTINE pynmes(KFDIQ)
67563 
67564 C...Double precision and integer declarations.
67565  IMPLICIT DOUBLE PRECISION(a-h, o-z)
67566  IMPLICIT INTEGER(I-N)
67567  INTEGER PYK,PYCHGE,PYCOMP
67568 C...Commonblocks.
67569  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67570  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67571  SAVE /pydat1/,/pydat2/
67572 
67573  mstu(121)=0
67574  IF(mstj(12).LT.2) RETURN
67575 
67576 C..Old version: Get 1 or 0 popcorn mesons
67577  IF(mstj(12).LT.5)THEN
67578  popwt=parf(131)
67579  IF(kfdiq.NE.0) THEN
67580  kfdiqa=iabs(kfdiq)
67581  kfa=mod(kfdiqa/1000,10)
67582  kfb=mod(kfdiqa/100,10)
67583  kfs=mod(kfdiqa,10)
67584  popwt=parf(132)
67585  IF(kfa.EQ.3) popwt=parf(133)
67586  IF(kfb.EQ.3) popwt=parf(134)
67587  IF(kfs.EQ.1) popwt=popwt*sqrt(parj(4))
67588  ENDIF
67589  mstu(121)=int(popwt/(1d0+popwt)+pyr(0))
67590  RETURN
67591  ENDIF
67592 
67593 C..New version: Store popcorn- or rank 0 diquark parameters
67594  mstu(122)=170
67595  parf(193)=parj(8)
67596  parf(194)=parf(139)
67597  IF(kfdiq.NE.0) THEN
67598  mstu(122)=180
67599  parf(193)=parj(10)
67600  parf(194)=parf(140)
67601  ENDIF
67602  IF(parf(194).LT.1d-5.OR.parf(194).GT.1d0-1d-5) THEN
67603  IF(parf(194).GT.1d0-1d-5) CALL pyerrm(9,
67604  & '(PYNMES:) Neglecting too large popcorn possibility')
67605  RETURN
67606  ENDIF
67607 
67608 C..New version: Get number of popcorn mesons
67609  100 rtst=pyr(0)
67610  mstu(121)=-1
67611  110 mstu(121)=mstu(121)+1
67612  rtst=rtst/parf(194)
67613  IF(rtst.LT.1d0) GOTO 110
67614  IF(kfdiq.EQ.0.AND.pyr(0)*(2d0+parf(135)*parf(161)).GT.
67615  & (2d0+parf(135)*parf(161)*parf(138)**mstu(121))) GOTO 100
67616  RETURN
67617  END
67618 
67619 C***************************************************************
67620 
67621 C...PYKFIN
67622 C...Precalculates a set of diquark and popcorn weights.
67623 
67624  SUBROUTINE pykfin
67625 
67626 C...Double precision and integer declarations.
67627  IMPLICIT DOUBLE PRECISION(a-h, o-z)
67628  IMPLICIT INTEGER(I-N)
67629  INTEGER PYK,PYCHGE,PYCOMP
67630 C...Commonblocks.
67631  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67632  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67633  SAVE /pydat1/,/pydat2/
67634 
67635  dimension su6(12),su6m(7),qbb(7),qbm(7),dmb(14)
67636 
67637 
67638  mstu(123)=1
67639 C..Diquark indices for dimensional variables
67640  iud1=1
67641  iuu1=2
67642  ius0=3
67643  isu0=4
67644  ius1=5
67645  isu1=6
67646  iss1=7
67647 
67648 C.. *** SU(6) factors **
67649 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67650  parf(146)=1d0
67651  IF(mstj(12).GE.5) parf(146)=3d0*parj(18)/(2d0*parj(18)+1d0)
67652  IF(parj(18).LT.1d0-1d-5.AND.mstj(12).LT.5) CALL pyerrm(9,
67653  & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67654  DO 100 i=1,6
67655  su6(i)=parf(60+i)
67656  su6(6+i)=su6(i)*4*parf(146)/(3*parf(146)+1)
67657  100 CONTINUE
67658  su6(8)=su6(2)*4/(3*parf(146)+1)
67659  su6(6)=su6(6)*(3+parf(146))/(3*parf(146)+1)
67660  DO 110 i=1,6
67661  su6(i)=su6(i)+parj(18)*parf(70+i)
67662  su6(6+i)=su6(6+i)+parj(18)*parf(70+i)
67663  110 CONTINUE
67664 
67665 C..SU(6)max q q' s,c,b
67666  su6mud =max(su6(1) , su6(8) )
67667  su6m(iud1)=max(su6(5) , su6(12))
67668  su6m(isu0)=max(su6(7) ,su6(2),su6mud )
67669  su6m(iuu1)=max(su6(3) ,su6(4),su6(10))
67670  su6m(isu1)=max(su6(11),su6(6),su6m(iud1))
67671  su6m(ius0)=su6m(isu0)
67672  su6m(iss1)=su6m(iuu1)
67673  su6m(ius1)=su6m(isu1)
67674 
67675 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67676  parf(141)=su6mud
67677  parf(142)=su6m(iud1)
67678  parf(143)=su6m(isu0)
67679  parf(144)=su6m(isu1)
67680  parf(145)=su6m(iss1)
67681 
67682 C..diquark SU(6) survival =
67683 C..sum over quark (quark tunnel weight)*(SU(6)).
67684  pud0=(2d0*su6(1)+parj(2)*su6(8))
67685  dmb(isu0)=(su6(7)+su6(2)+parj(2)*su6(1))/pud0
67686  dmb(ius0)=dmb(isu0)
67687  dmb(iss1)=(2d0*su6(4)+parj(2)*su6(3))/pud0
67688  dmb(iuu1)=(su6(3)+su6(4)+parj(2)*su6(10))/pud0
67689  dmb(isu1)=(su6(11)+su6(6)+parj(2)*su6(5))/pud0
67690  dmb(ius1)=dmb(isu1)
67691  dmb(iud1)=(2d0*su6(5)+parj(2)*su6(12))/pud0
67692 
67693 C.. *** Tunneling factors for Diquark production***
67694 C.. T: half a curtain pair = sqrt(curtain pair factor)
67695  IF(mstj(12).GE.5) THEN
67696  pmud0=pymass(2101)
67697  pmud1=pymass(2103)-pmud0
67698  pmus0=pymass(3201)-pmud0
67699  pmus1=pymass(3203)-pmus0-pmud0
67700  pmss1=pymass(3303)-pmus0-pmud0
67701  qbb(isu0)=exp(-(parj(9)+parj(8))*pmus0-parj(9)*parf(191))
67702  qbb(ius0)=exp(-parj(8)*pmus0)
67703  qbb(iss1)=exp(-(parj(9)+parj(8))*pmss1)*qbb(isu0)
67704  qbb(iuu1)=exp(-parj(8)*pmud1)
67705  qbb(isu1)=exp(-(parj(9)+parj(8))*pmus1)*qbb(isu0)
67706  qbb(ius1)=exp(-parj(8)*pmus1)*qbb(ius0)
67707  qbb(iud1)=qbb(iuu1)
67708  ELSE
67709  par2m=sqrt(parj(2))
67710  par3m=sqrt(parj(3))
67711  par4m=sqrt(parj(4))
67712  qbb(isu0)=par2m*par3m
67713  qbb(ius0)=par3m
67714  qbb(iss1)=par2m*parj(3)*par4m
67715  qbb(iuu1)=par4m
67716  qbb(isu1)=par4m*qbb(isu0)
67717  qbb(ius1)=par4m*qbb(ius0)
67718  qbb(iud1)=par4m
67719  ENDIF
67720 
67721 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67722  qbm(isu0)=qbb(isu0)
67723  qbm(ius0)=parj(2)*qbb(ius0)
67724  qbm(iss1)=parj(2)*6d0*qbb(iss1)
67725  qbm(iuu1)=6d0*qbb(iuu1)
67726  qbm(isu1)=3d0*qbb(isu1)
67727  qbm(ius1)=parj(2)*3d0*qbb(ius1)
67728  qbm(iud1)=3d0*qbb(iud1)
67729 
67730 C.. Combine T and tau to diquark weight for q-> B+B+..
67731  DO 120 i=1,7
67732  qbb(i)=qbb(i)*qbm(i)
67733  120 CONTINUE
67734 
67735  IF(mstj(12).GE.5)THEN
67736 C..New version: tau for rank 0 diquark.
67737  dmb(7+isu0)=exp(-parj(10)*pmus0)
67738  dmb(7+ius0)=parj(2)*dmb(7+isu0)
67739  dmb(7+iss1)=6d0*parj(2)*exp(-parj(10)*pmss1)*dmb(7+isu0)
67740  dmb(7+iuu1)=6d0*exp(-parj(10)*pmud1)
67741  dmb(7+isu1)=3d0*exp(-parj(10)*pmus1)*dmb(7+isu0)
67742  dmb(7+ius1)=parj(2)*dmb(7+isu1)
67743  dmb(7+iud1)=dmb(7+iuu1)/2d0
67744 
67745 C..New version: curtain flavour ratios.
67746 C.. s/u for q->B+M+...
67747 C.. s/u for rank 0 diquark: su -> ...M+B+...
67748 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67749  wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
67750  parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
67751  wu=1d0+dmb(7+iud1)+dmb(7+ius0)+dmb(7+ius1)+dmb(7+iuu1)
67752  parf(136)=(2d0*(dmb(7+isu0)+dmb(7+isu1))+dmb(7+iss1))/wu
67753  parf(137)=(dmb(7+isu0)+dmb(7+isu1))*
67754  & (2d0+dmb(7+iss1)/(2d0*dmb(7+isu1)))/wu
67755  ELSE
67756 C..Old version: reset unused rank 0 diquark weights and
67757 C.. unused diquark SU(6) survival weights
67758  DO 130 i=1,7
67759  IF(mstj(12).LT.3) dmb(i)=1d0
67760  dmb(7+i)=1d0
67761  130 CONTINUE
67762 
67763 C..Old version: Shuffle PARJ(7) into tau
67764  qbm(ius0)=qbm(ius0)*parj(7)
67765  qbm(iss1)=qbm(iss1)*parj(7)
67766  qbm(ius1)=qbm(ius1)*parj(7)
67767 
67768 C..Old version: curtain flavour ratios.
67769 C.. s/u for q->B+M+...
67770 C.. s/u for rank 0 diquark: su -> ...M+B+...
67771 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67772  wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
67773  parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
67774  parf(136)=parf(135)*parj(6)*qbm(isu0)/qbm(ius0)
67775  parf(137)=(1d0+qbm(iud1))*(2d0+qbm(ius0))/wu
67776  ENDIF
67777 
67778 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67779 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67780  DO 140 i=1,7
67781  dmb(7+i)=dmb(7+i)*dmb(i)
67782  dmb(i)=dmb(i)*qbm(i)
67783  qbm(i)=qbm(i)*su6m(i)/su6mud
67784  qbb(i)=qbb(i)*su6m(i)/su6mud
67785  140 CONTINUE
67786 
67787 C.. *** Popcorn factors ***
67788 
67789  IF(mstj(12).LT.5)THEN
67790 C.. Old version: Resulting popcorn weights.
67791  parf(138)=parj(6)
67792  ws=parf(135)*parf(138)
67793  wq=wu*parj(5)/3d0
67794  parf(132)=wq*qbm(iud1)/qbb(iud1)
67795  parf(133)=wq*
67796  & (qbm(ius1)/qbb(ius1)+ws*qbm(isu1)/qbb(isu1))/2d0
67797  parf(134)=wq*ws*qbm(iss1)/qbb(iss1)
67798  parf(131)=wq*(1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1)+
67799  & ws*(qbm(isu0)+qbm(isu1)+qbm(iss1)/2d0))/
67800  & (1d0+qbb(iud1)+qbb(iuu1)+
67801  & 2d0*(qbb(ius0)+qbb(ius1))+qbb(iss1)/2d0)
67802  ELSE
67803 C..New version: Store weights for popcorn mesons,
67804 C..get prel. popcorn weights.
67805  DO 150 ipos=201,1400
67806  parf(ipos)=0d0
67807  150 CONTINUE
67808  DO 160 i=138,140
67809  parf(i)=0d0
67810  160 CONTINUE
67811  ipos=200
67812  parf(193)=parj(8)
67813  DO 240 mr=0,7,7
67814  IF(mr.EQ.7) parf(193)=parj(10)
67815  sqwt=2d0*(dmb(mr+ius0)+dmb(mr+ius1))/
67816  & (1d0+dmb(mr+iud1)+dmb(mr+iuu1))
67817  qqwt=dmb(mr+iuu1)/(1d0+dmb(mr+iud1)+dmb(mr+iuu1))
67818  DO 230 nmes=0,1
67819  IF(nmes.EQ.1) sqwt=parj(2)
67820  DO 220 kfqpop=1,4
67821  IF(mr.EQ.0.AND.kfqpop.GT.3) GOTO 220
67822  IF(nmes.EQ.0.AND.kfqpop.GE.3)THEN
67823  sqwt=dmb(mr+iss1)/(dmb(mr+isu0)+dmb(mr+isu1))
67824  qqwt=0.5d0
67825  IF(mr.EQ.0) parf(193)=parj(8)+parj(9)
67826  IF(kfqpop.EQ.4) sqwt=sqwt*(1d0/dmb(7+isu1)+1d0)/2d0
67827  ENDIF
67828  DO 210 kfqold =1,5
67829  IF(mr.EQ.0.AND.kfqold.GT.3) GOTO 210
67830  IF(nmes.EQ.1) THEN
67831  IF(mr.EQ.0.AND.kfqpop.EQ.1) GOTO 210
67832  IF(mr.EQ.7.AND.kfqpop.NE.1) GOTO 210
67833  ENDIF
67834  wttot=0d0
67835  wtfail=0d0
67836  DO 190 kmul=0,5
67837  pjwt=parj(12+kmul)
67838  IF(kmul.EQ.0) pjwt=1d0-parj(14)
67839  IF(kmul.EQ.1) pjwt=1d0-parj(15)-parj(16)-parj(17)
67840  IF(pjwt.LE.0d0) GOTO 190
67841  IF(pjwt.GT.1d0) pjwt=1d0
67842  imes=5*kmul
67843  imix=2*kfqold+10*kmul
67844  kfj=2*kmul+1
67845  IF(kmul.EQ.2) kfj=10003
67846  IF(kmul.EQ.3) kfj=10001
67847  IF(kmul.EQ.4) kfj=20003
67848  IF(kmul.EQ.5) kfj=5
67849  DO 180 kfqver =1,3
67850  kfla=max(kfqold,kfqver)
67851  kflb=min(kfqold,kfqver)
67852  swt=parj(11+kfla/3+kfla/4)
67853  IF(kmul.EQ.0.OR.kmul.EQ.2) swt=1d0-swt
67854  swt=swt*pjwt
67855  qwt=sqwt/(2d0+sqwt)
67856  IF(kfqver.LT.3)THEN
67857  IF(kfqver.EQ.kfqpop) qwt=(1d0-qwt)*qqwt
67858  IF(kfqver.NE.kfqpop) qwt=(1d0-qwt)*(1d0-qqwt)
67859  ENDIF
67860  IF(kfqver.NE.kfqold)THEN
67861  imes=imes+1
67862  kfm=100*kfla+10*kflb+kfj
67863  pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
67864  parf(ipos+imes)=qwt*swt*exp(-parf(193)*pmm)
67865  wttot=wttot+parf(ipos+imes)
67866  ELSE
67867  DO 170 id=3,5
67868  IF(id.EQ.3) dwt=1d0-parf(imix-1)
67869  IF(id.EQ.4) dwt=parf(imix-1)-parf(imix)
67870  IF(id.EQ.5) dwt=parf(imix)
67871  kfm=110*(id-2)+kfj
67872  pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
67873  parf(ipos+5*kmul+id)=qwt*swt*dwt*exp(-parf(193)*pmm)
67874  IF(kmul.EQ.0.AND.id.GT.3) THEN
67875  wtfail=wtfail+qwt*swt*dwt*(1d0-parj(21+id))
67876  parf(ipos+5*kmul+id)=
67877  & parf(ipos+5*kmul+id)*parj(21+id)
67878  ENDIF
67879  wttot=wttot+parf(ipos+5*kmul+id)
67880  170 CONTINUE
67881  ENDIF
67882  180 CONTINUE
67883  190 CONTINUE
67884  DO 200 imes=1,30
67885  parf(ipos+imes)=parf(ipos+imes)/(1d0-wtfail)
67886  200 CONTINUE
67887  IF(mr.EQ.7) parf(140)=
67888  & max(parf(140),wttot/(1d0-wtfail))
67889  IF(mr.EQ.0) parf(139-kfqpop/3)=
67890  & max(parf(139-kfqpop/3),wttot/(1d0-wtfail))
67891  ipos=ipos+30
67892  210 CONTINUE
67893  220 CONTINUE
67894  230 CONTINUE
67895  240 CONTINUE
67896  IF(parf(139).GT.1d-10) parf(138)=parf(138)/parf(139)
67897  mstu(121)=0
67898 
67899  ENDIF
67900 
67901 C..Recombine diquark weights to flavour and spin ratios
67902  parf(151)=(2d0*(qbb(isu0)+qbb(isu1))+qbb(iss1))/
67903  & (1d0+qbb(iud1)+qbb(iuu1)+qbb(ius0)+qbb(ius1))
67904  parf(152)=2d0*(qbb(ius0)+qbb(ius1))/(1d0+qbb(iud1)+qbb(iuu1))
67905  parf(153)=qbb(iss1)/(qbb(isu0)+qbb(isu1))
67906  parf(154)=qbb(iuu1)/(1d0+qbb(iud1)+qbb(iuu1))
67907  parf(155)=qbb(isu1)/qbb(isu0)
67908  parf(156)=qbb(ius1)/qbb(ius0)
67909  parf(157)=qbb(iud1)
67910 
67911  parf(161)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/
67912  & (1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1))
67913  parf(162)=2d0*(qbm(ius0)+qbm(ius1))/(1d0+qbm(iud1)+qbm(iuu1))
67914  parf(163)=qbm(iss1)/(qbm(isu0)+qbm(isu1))
67915  parf(164)=qbm(iuu1)/(1d0+qbm(iud1)+qbm(iuu1))
67916  parf(165)=qbm(isu1)/qbm(isu0)
67917  parf(166)=qbm(ius1)/qbm(ius0)
67918  parf(167)=qbm(iud1)
67919 
67920  parf(171)=(2d0*(dmb(isu0)+dmb(isu1))+dmb(iss1))/
67921  & (1d0+dmb(iud1)+dmb(iuu1)+dmb(ius0)+dmb(ius1))
67922  parf(172)=2d0*(dmb(ius0)+dmb(ius1))/(1d0+dmb(iud1)+dmb(iuu1))
67923  parf(173)=dmb(iss1)/(dmb(isu0)+dmb(isu1))
67924  parf(174)=dmb(iuu1)/(1d0+dmb(iud1)+dmb(iuu1))
67925  parf(175)=dmb(isu1)/dmb(isu0)
67926  parf(176)=dmb(ius1)/dmb(ius0)
67927  parf(177)=dmb(iud1)
67928 
67929  parf(185)=dmb(7+isu1)/dmb(7+isu0)
67930  parf(186)=dmb(7+ius1)/dmb(7+ius0)
67931  parf(187)=dmb(7+iud1)
67932 
67933  RETURN
67934  END
67935 
67936 
67937 C*********************************************************************
67938 
67939 C...PYPTDI
67940 C...Generates transverse momentum according to a Gaussian.
67941 
67942  SUBROUTINE pyptdi(KFL,PX,PY)
67943 
67944 C...Double precision and integer declarations.
67945  IMPLICIT DOUBLE PRECISION(a-h, o-z)
67946  IMPLICIT INTEGER(I-N)
67947  INTEGER PYK,PYCHGE,PYCOMP
67948 C...Commonblocks.
67949  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67950  SAVE /pydat1/
67951 
67952 C...Generate p_T and azimuthal angle, gives p_x and p_y.
67953  kfla=iabs(kfl)
67954  pt=parj(21)*sqrt(-log(max(1d-10,pyr(0))))
67955  IF(parj(23).GT.pyr(0)) pt=parj(24)*pt
67956  IF(mstj(91).EQ.1) pt=parj(22)*pt
67957  IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0d0
67958  phi=paru(2)*pyr(0)
67959  px=pt*cos(phi)
67960  py=pt*sin(phi)
67961 
67962  RETURN
67963  END
67964 
67965 C*********************************************************************
67966 
67967 C...PYZDIS
67968 C...Generates the longitudinal splitting variable z.
67969 
67970  SUBROUTINE pyzdis(KFL1,KFL2,PR,Z)
67971 
67972 C...Double precision and integer declarations.
67973  IMPLICIT DOUBLE PRECISION(a-h, o-z)
67974  IMPLICIT INTEGER(I-N)
67975  INTEGER PYK,PYCHGE,PYCOMP
67976 C...Commonblocks.
67977  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67978  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67979  SAVE /pydat1/,/pydat2/
67980 
67981 C...Check if heavy flavour fragmentation.
67982  kfla=iabs(kfl1)
67983  kflb=iabs(kfl2)
67984  kflh=kfla
67985  IF(kfla.GE.10) kflh=mod(kfla/1000,10)
67986 
67987 C...Lund symmetric scaling function: determine parameters of shape.
67988  IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
67989  &mstj(11).GE.4) THEN
67990  fa=parj(41)
67991  IF(mstj(91).EQ.1) fa=parj(43)
67992  IF(kflb.GE.10) fa=fa+parj(45)
67993  fbb=parj(42)
67994  IF(mstj(91).EQ.1) fbb=parj(44)
67995  fb=fbb*pr
67996  fc=1d0
67997  IF(kfla.GE.10) fc=fc-parj(45)
67998  IF(kflb.GE.10) fc=fc+parj(45)
67999  IF(mstj(11).GE.4.AND.(kflh.EQ.4.OR.kflh.EQ.5)) THEN
68000  fred=parj(46)
68001  IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
68002  fc=fc+fred*fbb*parf(100+kflh)**2
68003  ENDIF
68004  mc=1
68005  IF(abs(fc-1d0).GT.0.01d0) mc=2
68006 
68007 C...Determine position of maximum. Special cases for a = 0 or a = c.
68008  IF(fa.LT.0.02d0) THEN
68009  ma=1
68010  zmax=1d0
68011  IF(fc.GT.fb) zmax=fb/fc
68012  ELSEIF(abs(fc-fa).LT.0.01d0) THEN
68013  ma=2
68014  zmax=fb/(fb+fc)
68015  ELSE
68016  ma=3
68017  zmax=0.5d0*(fb+fc-sqrt((fb-fc)**2+4d0*fa*fb))/(fc-fa)
68018  IF(zmax.GT.0.9999d0.AND.fb.GT.100d0) zmax=min(zmax,1d0-fa/fb)
68019  ENDIF
68020 
68021 C...Subdivide z range if distribution very peaked near endpoint.
68022  mmax=2
68023  IF(zmax.LT.0.1d0) THEN
68024  mmax=1
68025  zdiv=2.75d0*zmax
68026  IF(mc.EQ.1) THEN
68027  fint=1d0-log(zdiv)
68028  ELSE
68029  zdivc=zdiv**(1d0-fc)
68030  fint=1d0+(1d0-1d0/zdivc)/(fc-1d0)
68031  ENDIF
68032  ELSEIF(zmax.GT.0.85d0.AND.fb.GT.1d0) THEN
68033  mmax=3
68034  fscb=sqrt(4d0+(fc/fb)**2)
68035  zdiv=fscb-1d0/zmax-(fc/fb)*log(zmax*0.5d0*(fscb+fc/fb))
68036  IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1d0-zmax)
68037  zdiv=min(zmax,max(0d0,zdiv))
68038  fint=1d0+fb*(1d0-zdiv)
68039  ENDIF
68040 
68041 C...Choice of z, preweighted for peaks at low or high z.
68042  100 z=pyr(0)
68043  fpre=1d0
68044  IF(mmax.EQ.1) THEN
68045  IF(fint*pyr(0).LE.1d0) THEN
68046  z=zdiv*z
68047  ELSEIF(mc.EQ.1) THEN
68048  z=zdiv**z
68049  fpre=zdiv/z
68050  ELSE
68051  z=(zdivc+z*(1d0-zdivc))**(1d0/(1d0-fc))
68052  fpre=(zdiv/z)**fc
68053  ENDIF
68054  ELSEIF(mmax.EQ.3) THEN
68055  IF(fint*pyr(0).LE.1d0) THEN
68056  z=zdiv+log(z)/fb
68057  fpre=exp(fb*(z-zdiv))
68058  ELSE
68059  z=zdiv+z*(1d0-zdiv)
68060  ENDIF
68061  ENDIF
68062 
68063 C...Weighting according to correct formula.
68064  IF(z.LE.0d0.OR.z.GE.1d0) GOTO 100
68065  fexp=fc*log(zmax/z)+fb*(1d0/zmax-1d0/z)
68066  IF(ma.GE.2) fexp=fexp+fa*log((1d0-z)/(1d0-zmax))
68067  fval=exp(max(-50d0,min(50d0,fexp)))
68068  IF(fval.LT.pyr(0)*fpre) GOTO 100
68069 
68070 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68071  ELSE
68072  fc=parj(50+max(1,kflh))
68073  IF(mstj(91).EQ.1) fc=parj(59)
68074  110 z=pyr(0)
68075  IF(fc.GE.0d0.AND.fc.LE.1d0) THEN
68076  IF(fc.GT.pyr(0)) z=1d0-z**(1d0/3d0)
68077  ELSEIF(fc.GT.-1.AND.fc.LT.0d0) THEN
68078  IF(-4d0*fc*z*(1d0-z)**2.LT.pyr(0)*((1d0-z)**2-fc*z)**2)
68079  & GOTO 110
68080  ELSE
68081  IF(fc.GT.0d0) z=1d0-z**(1d0/fc)
68082  IF(fc.LT.0d0) z=z**(-1d0/fc)
68083  ENDIF
68084  ENDIF
68085 
68086  RETURN
68087  END
68088 
68089 C*********************************************************************
68090 
68091 C...PYSHOW
68092 C...Generates timelike parton showers from given partons.
68093 
68094  SUBROUTINE pyshow(IP1,IP2,QMAX)
68095 
68096 C...Double precision and integer declarations.
68097  IMPLICIT DOUBLE PRECISION(a-h, o-z)
68098  IMPLICIT INTEGER(I-N)
68099  INTEGER PYK,PYCHGE,PYCOMP
68100 C...Parameter statement to help give large particle numbers.
68101  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
68102  &kexcit=4000000,kdimen=5000000)
68103  parameter(maxnur=1000)
68104 C...Commonblocks.
68105  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
68106  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
68107  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
68108  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
68109  common/pypars/mstp(200),parp(200),msti(200),pari(200)
68110  common/pyint1/mint(400),vint(400)
68111  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
68112 C...Local arrays.
68113  dimension pmth(5,140),ps(5),pma(100),pmsd(100),iep(100),ipa(100),
68114  &kfla(100),kfld(100),kfl(100),itry(100),isi(100),isl(100),dp(100),
68115  &dpt(5,4),ksh(0:140),kcii(2),niis(2),iiis(2,2),theiis(2,2),
68116  &phiiis(2,2),isii(2),isset(2),iscol(0:140),ischg(0:140),
68117  &iref(1000)
68118 
68119 C...Check that QMAX not too low.
68120  IF(mstj(41).LE.0) THEN
68121  RETURN
68122  ELSEIF(mstj(41).EQ.1.OR.mstj(41).EQ.11) THEN
68123  IF(qmax.LE.parj(82).AND.ip2.GE.-80) RETURN
68124  ELSE
68125  IF(qmax.LE.min(parj(82),parj(83),parj(90)).AND.ip2.GE.-80)
68126  & RETURN
68127  ENDIF
68128 
68129 C...Store positions of shower initiating partons.
68130  mpspd=0
68131  IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
68132  npa=1
68133  ipa(1)=ip1
68134  ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
68135  & mstu(32))) THEN
68136  npa=2
68137  ipa(1)=ip1
68138  ipa(2)=ip2
68139  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0
68140  & .AND.ip2.GE.-80) THEN
68141  npa=iabs(ip2)
68142  DO 100 i=1,npa
68143  ipa(i)=ip1+i-1
68144  100 CONTINUE
68145  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.
68146  &ip2.EQ.-100) THEN
68147  mpspd=1
68148  npa=2
68149  ipa(1)=ip1+6
68150  ipa(2)=ip1+7
68151  ELSE
68152  CALL pyerrm(12,
68153  & '(PYSHOW:) failed to reconstruct showering system')
68154  IF(mstu(21).GE.1) RETURN
68155  ENDIF
68156 
68157 C...Send off to PYPTFS for pT-ordered evolution if requested,
68158 C...if at least 2 partons, and without predefined shower branchings.
68159  IF((mstj(41).EQ.11.OR.mstj(41).EQ.12).AND.npa.GE.2.AND.
68160  &mpspd.EQ.0) THEN
68161  npart=npa
68162  DO 110 ii=1,npart
68163  ipart(ii)=ipa(ii)
68164  ptpart(ii)=0.5d0*qmax
68165  110 CONTINUE
68166  CALL pyptfs(2,0.5d0*qmax,0d0,ptgen)
68167  RETURN
68168  ENDIF
68169 
68170 C...Initialization of cutoff masses etc.
68171  DO 120 ifl=0,40
68172  iscol(ifl)=0
68173  ischg(ifl)=0
68174  ksh(ifl)=0
68175  120 CONTINUE
68176  iscol(21)=1
68177  ksh(21)=1
68178  pmth(1,21)=pymass(21)
68179  pmth(2,21)=sqrt(pmth(1,21)**2+0.25d0*parj(82)**2)
68180  pmth(3,21)=2d0*pmth(2,21)
68181  pmth(4,21)=pmth(3,21)
68182  pmth(5,21)=pmth(3,21)
68183  pmth(1,22)=pymass(22)
68184  pmth(2,22)=sqrt(pmth(1,22)**2+0.25d0*parj(83)**2)
68185  pmth(3,22)=2d0*pmth(2,22)
68186  pmth(4,22)=pmth(3,22)
68187  pmth(5,22)=pmth(3,22)
68188  pmqth1=parj(82)
68189  IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
68190  pmqt1e=min(pmqth1,parj(90))
68191  pmqth2=pmth(2,21)
68192  IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
68193  pmqt2e=min(pmqth2,0.5d0*parj(90))
68194  DO 130 ifl=1,5
68195  iscol(ifl)=1
68196  IF(mstj(41).GE.2) ischg(ifl)=1
68197  ksh(ifl)=1
68198  pmth(1,ifl)=pymass(ifl)
68199  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*pmqth1**2)
68200  pmth(3,ifl)=pmth(2,ifl)+pmqth2
68201  pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(82)**2)+pmth(2,21)
68202  pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)+pmth(2,22)
68203  130 CONTINUE
68204  DO 140 ifl=11,15,2
68205  IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ischg(ifl)=1
68206  IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ksh(ifl)=1
68207  pmth(1,ifl)=pymass(ifl)
68208  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(90)**2)
68209  pmth(3,ifl)=pmth(2,ifl)+0.5d0*parj(90)
68210  pmth(4,ifl)=pmth(3,ifl)
68211  pmth(5,ifl)=pmth(3,ifl)
68212  140 CONTINUE
68213  pt2min=max(0.5d0*parj(82),1.1d0*parj(81))**2
68214  alams=parj(81)**2
68215  alfm=log(pt2min/alams)
68216 
68217 C...Check on phase space available for emission.
68218  irej=0
68219  DO 150 j=1,5
68220  ps(j)=0d0
68221  150 CONTINUE
68222  pm=0d0
68223  kfla(2)=0
68224  DO 170 i=1,npa
68225  kfla(i)=iabs(k(ipa(i),2))
68226  pma(i)=p(ipa(i),5)
68227 C...Special cutoff masses for initial partons (may be a heavy quark,
68228 C...squark, ..., and need not be on the mass shell).
68229  ir=30+i
68230  IF(npa.LE.1) iref(i)=ir
68231  IF(npa.GE.2) iref(i+1)=ir
68232  iscol(ir)=0
68233  ischg(ir)=0
68234  ksh(ir)=0
68235  IF(kfla(i).LE.8) THEN
68236  iscol(ir)=1
68237  IF(mstj(41).GE.2) ischg(ir)=1
68238  ELSEIF(kfla(i).EQ.11.OR.kfla(i).EQ.13.OR.kfla(i).EQ.15.OR.
68239  & kfla(i).EQ.17) THEN
68240  IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ischg(ir)=1
68241  ELSEIF(kfla(i).EQ.21) THEN
68242  iscol(ir)=1
68243  ELSEIF((kfla(i).GE.ksusy1+1.AND.kfla(i).LE.ksusy1+8).OR.
68244  & (kfla(i).GE.ksusy2+1.AND.kfla(i).LE.ksusy2+8)) THEN
68245  iscol(ir)=1
68246  ELSEIF(kfla(i).EQ.ksusy1+21) THEN
68247  iscol(ir)=1
68248 C...QUARKONIA+++
68249 C...same for QQ~[3S18]
68250  ELSEIF(mstp(148).GE.1.AND.(kfla(i).EQ.9900443.OR.
68251  & kfla(i).EQ.9900553)) THEN
68252  iscol(ir)=1
68253 C...QUARKONIA---
68254  ENDIF
68255 
68256 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68257 C...(only intended for studying the effects of switching such rad on/off)
68258  IF (mstj(39).GT.0.AND.kfla(i).EQ.mstj(39)) THEN
68259  iscol(ir)=0
68260  ischg(ir)=0
68261  ENDIF
68262 
68263  IF(iscol(ir).EQ.1.OR.ischg(ir).EQ.1) ksh(ir)=1
68264  pmth(1,ir)=pma(i)
68265  IF(iscol(ir).EQ.1.AND.ischg(ir).EQ.1) THEN
68266  pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*pmqth1**2)
68267  pmth(3,ir)=pmth(2,ir)+pmqth2
68268  pmth(4,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(82)**2)+pmth(2,21)
68269  pmth(5,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(83)**2)+pmth(2,22)
68270  ELSEIF(iscol(ir).EQ.1) THEN
68271  pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(82)**2)
68272  pmth(3,ir)=pmth(2,ir)+0.5d0*parj(82)
68273  pmth(4,ir)=pmth(3,ir)
68274  pmth(5,ir)=pmth(3,ir)
68275  ELSEIF(ischg(ir).EQ.1) THEN
68276  pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(90)**2)
68277  pmth(3,ir)=pmth(2,ir)+0.5d0*parj(90)
68278  pmth(4,ir)=pmth(3,ir)
68279  pmth(5,ir)=pmth(3,ir)
68280  ENDIF
68281  IF(ksh(ir).EQ.1) pma(i)=pmth(3,ir)
68282  pm=pm+pma(i)
68283  IF(ksh(ir).EQ.0.OR.pma(i).GT.10d0*qmax) irej=irej+1
68284  DO 160 j=1,4
68285  ps(j)=ps(j)+p(ipa(i),j)
68286  160 CONTINUE
68287  170 CONTINUE
68288  IF(irej.EQ.npa.AND.ip2.GE.-7) RETURN
68289  ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
68290  IF(npa.EQ.1) ps(5)=ps(4)
68291  IF(ps(5).LE.pm+pmqt1e) RETURN
68292 
68293 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68294  kfsrce=0
68295  IF(ip2.LE.0) THEN
68296  ELSEIF(k(ip1,3).EQ.k(ip2,3).AND.k(ip1,3).GT.0) THEN
68297  kfsrce=iabs(k(k(ip1,3),2))
68298  ELSE
68299  ipar1=max(1,k(ip1,3))
68300  ipar2=max(1,k(ip2,3))
68301  IF(k(ipar1,3).EQ.k(ipar2,3).AND.k(ipar1,3).GT.0)
68302  & kfsrce=iabs(k(k(ipar1,3),2))
68303  ENDIF
68304  itypes=0
68305  IF(kfsrce.GE.1.AND.kfsrce.LE.8) itypes=1
68306  IF(kfsrce.GE.ksusy1+1.AND.kfsrce.LE.ksusy1+8) itypes=2
68307  IF(kfsrce.GE.ksusy2+1.AND.kfsrce.LE.ksusy2+8) itypes=2
68308  IF(kfsrce.GE.21.AND.kfsrce.LE.24) itypes=3
68309  IF(kfsrce.GE.32.AND.kfsrce.LE.34) itypes=3
68310  IF(kfsrce.EQ.25.OR.(kfsrce.GE.35.AND.kfsrce.LE.37)) itypes=4
68311  IF(kfsrce.GE.ksusy1+22.AND.kfsrce.LE.ksusy1+37) itypes=5
68312  IF(kfsrce.EQ.ksusy1+21) itypes=6
68313 
68314 C...Identify two primary showerers.
68315  itype1=0
68316  IF(kfla(1).GE.1.AND.kfla(1).LE.8) itype1=1
68317  IF(kfla(1).GE.ksusy1+1.AND.kfla(1).LE.ksusy1+8) itype1=2
68318  IF(kfla(1).GE.ksusy2+1.AND.kfla(1).LE.ksusy2+8) itype1=2
68319  IF(kfla(1).GE.21.AND.kfla(1).LE.24) itype1=3
68320  IF(kfla(1).GE.32.AND.kfla(1).LE.34) itype1=3
68321  IF(kfla(1).EQ.25.OR.(kfla(1).GE.35.AND.kfla(1).LE.37)) itype1=4
68322  IF(kfla(1).GE.ksusy1+22.AND.kfla(1).LE.ksusy1+37) itype1=5
68323  IF(kfla(1).EQ.ksusy1+21) itype1=6
68324  itype2=0
68325  IF(kfla(2).GE.1.AND.kfla(2).LE.8) itype2=1
68326  IF(kfla(2).GE.ksusy1+1.AND.kfla(2).LE.ksusy1+8) itype2=2
68327  IF(kfla(2).GE.ksusy2+1.AND.kfla(2).LE.ksusy2+8) itype2=2
68328  IF(kfla(2).GE.21.AND.kfla(2).LE.24) itype2=3
68329  IF(kfla(2).GE.32.AND.kfla(2).LE.34) itype2=3
68330  IF(kfla(2).EQ.25.OR.(kfla(2).GE.35.AND.kfla(2).LE.37)) itype2=4
68331  IF(kfla(2).GE.ksusy1+22.AND.kfla(2).LE.ksusy1+37) itype2=5
68332  IF(kfla(2).EQ.ksusy1+21) itype2=6
68333 
68334 C...Order of showerers. Presence of gluino.
68335  itypmn=min(itype1,itype2)
68336  itypmx=max(itype1,itype2)
68337  iord=1
68338  IF(itype1.GT.itype2) iord=2
68339  iglui=0
68340  IF(itype1.EQ.6.OR.itype2.EQ.6) iglui=1
68341 
68342 C...Check if 3-jet matrix elements to be used.
68343  m3jc=0
68344  alpha=0.5d0
68345  IF(npa.EQ.2.AND.mstj(47).GE.1.AND.mpspd.EQ.0) THEN
68346  IF(mstj(38).NE.0) THEN
68347  m3jc=mstj(38)
68348  alpha=parj(80)
68349  mstj(38)=0
68350  ELSEIF(mstj(47).GE.6) THEN
68351  m3jc=mstj(47)
68352  ELSE
68353  iclass=1
68354  icombi=4
68355 
68356 C...Vector/axial vector -> q + qbar; q -> q + V.
68357  IF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.(itypes.EQ.0.OR.
68358  & itypes.EQ.3)) THEN
68359  iclass=2
68360  IF(kfsrce.EQ.21.OR.kfsrce.EQ.22) THEN
68361  icombi=1
68362  ELSEIF(kfsrce.EQ.23.OR.(kfsrce.EQ.0.AND.
68363  & k(ipa(1),2)+k(ipa(2),2).EQ.0)) THEN
68364 C...gamma*/Z0: assume e+e- initial state if unknown.
68365  ei=-1d0
68366  IF(kfsrce.EQ.23) THEN
68367  iannfl=k(k(ip1,3),3)
68368  IF(iannfl.NE.0) THEN
68369  kannfl=iabs(k(iannfl,2))
68370  IF(kannfl.GE.1.AND.kannfl.LE.18) ei=kchg(kannfl,1)/3d0
68371  ENDIF
68372  ENDIF
68373  ai=sign(1d0,ei+0.1d0)
68374  vi=ai-4d0*ei*paru(102)
68375  ef=kchg(kfla(1),1)/3d0
68376  af=sign(1d0,ef+0.1d0)
68377  vf=af-4d0*ef*paru(102)
68378  xwc=1d0/(16d0*paru(102)*(1d0-paru(102)))
68379  sh=ps(5)**2
68380  sqmz=pmas(23,1)**2
68381  sqwz=ps(5)*pmas(23,2)
68382  sbwz=1d0/((sh-sqmz)**2+sqwz**2)
68383  vect=ei**2*ef**2+2d0*ei*vi*ef*vf*xwc*sh*(sh-sqmz)*sbwz+
68384  & (vi**2+ai**2)*vf**2*xwc**2*sh**2*sbwz
68385  axiv=(vi**2+ai**2)*af**2*xwc**2*sh**2*sbwz
68386  icombi=3
68387  alpha=vect/(vect+axiv)
68388  ELSEIF(kfsrce.EQ.24.OR.kfsrce.EQ.0) THEN
68389  icombi=4
68390  ENDIF
68391 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68392  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.5) THEN
68393  iclass=2
68394  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
68395  & itypes.EQ.1)) THEN
68396  iclass=3
68397 
68398 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68399  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.4) THEN
68400  iclass=4
68401  IF(kfsrce.EQ.25.OR.kfsrce.EQ.35.OR.kfsrce.EQ.37) THEN
68402  icombi=1
68403  ELSEIF(kfsrce.EQ.36) THEN
68404  icombi=2
68405  ENDIF
68406  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
68407  & itypes.EQ.1)) THEN
68408  iclass=5
68409 
68410 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68411  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
68412  & itypes.EQ.3)) THEN
68413  iclass=6
68414  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
68415  & itypes.EQ.2)) THEN
68416  iclass=7
68417  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.itypes.EQ.4) THEN
68418  iclass=8
68419  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
68420  & itypes.EQ.2)) THEN
68421  iclass=9
68422 
68423 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68424  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
68425  & itypes.EQ.5)) THEN
68426  iclass=10
68427  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
68428  & itypes.EQ.2)) THEN
68429  iclass=11
68430  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
68431  & itypes.EQ.1)) THEN
68432  iclass=12
68433 
68434 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68435  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.itypes.EQ.6) THEN
68436  iclass=13
68437  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
68438  & itypes.EQ.2)) THEN
68439  iclass=14
68440  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
68441  & itypes.EQ.1)) THEN
68442  iclass=15
68443 
68444 C...g -> ~g + ~g (eikonal approximation).
68445  ELSEIF(itypmn.EQ.6.AND.itypmx.EQ.6.AND.itypes.EQ.0) THEN
68446  iclass=16
68447  ENDIF
68448  m3jc=5*iclass+icombi
68449  ENDIF
68450  ENDIF
68451 
68452 C...Find if interference with initial state partons.
68453  miis=0
68454  IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2.AND.kfsrce.EQ.0
68455  &.AND.mpspd.EQ.0) miis=mstj(50)
68456  IF(mstj(50).GE.4.AND.mstj(50).LE.6.AND.npa.EQ.2.AND.mpspd.EQ.0)
68457  &miis=mstj(50)-3
68458  IF(miis.NE.0) THEN
68459  DO 190 i=1,2
68460  kcii(i)=0
68461  kca=pycomp(kfla(i))
68462  IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
68463  niis(i)=0
68464  IF(kcii(i).NE.0) THEN
68465  DO 180 j=1,2
68466  icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
68467  IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
68468  & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
68469  niis(i)=niis(i)+1
68470  iiis(i,niis(i))=icsi
68471  ENDIF
68472  180 CONTINUE
68473  ENDIF
68474  190 CONTINUE
68475  IF(niis(1)+niis(2).EQ.0) miis=0
68476  ENDIF
68477 
68478 C...Boost interfering initial partons to rest frame
68479 C...and reconstruct their polar and azimuthal angles.
68480  IF(miis.NE.0) THEN
68481  DO 210 i=1,2
68482  DO 200 j=1,5
68483  k(n+i,j)=k(ipa(i),j)
68484  p(n+i,j)=p(ipa(i),j)
68485  v(n+i,j)=0d0
68486  200 CONTINUE
68487  210 CONTINUE
68488  DO 230 i=3,2+niis(1)
68489  DO 220 j=1,5
68490  k(n+i,j)=k(iiis(1,i-2),j)
68491  p(n+i,j)=p(iiis(1,i-2),j)
68492  v(n+i,j)=0d0
68493  220 CONTINUE
68494  230 CONTINUE
68495  DO 250 i=3+niis(1),2+niis(1)+niis(2)
68496  DO 240 j=1,5
68497  k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
68498  p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
68499  v(n+i,j)=0d0
68500  240 CONTINUE
68501  250 CONTINUE
68502  CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,0d0,-ps(1)/ps(4),
68503  & -ps(2)/ps(4),-ps(3)/ps(4))
68504  phi=pyangl(p(n+1,1),p(n+1,2))
68505  CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,-phi,0d0,0d0,0d0)
68506  the=pyangl(p(n+1,3),p(n+1,1))
68507  CALL pyrobo(n+1,n+2+niis(1)+niis(2),-the,0d0,0d0,0d0,0d0)
68508  DO 260 i=3,2+niis(1)
68509  theiis(1,i-2)=pyangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
68510  phiiis(1,i-2)=pyangl(p(n+i,1),p(n+i,2))
68511  260 CONTINUE
68512  DO 270 i=3+niis(1),2+niis(1)+niis(2)
68513  theiis(2,i-2-niis(1))=paru(1)-pyangl(p(n+i,3),
68514  & sqrt(p(n+i,1)**2+p(n+i,2)**2))
68515  phiiis(2,i-2-niis(1))=pyangl(p(n+i,1),p(n+i,2))
68516  270 CONTINUE
68517  ENDIF
68518 
68519 C...Boost 3 or more partons to their rest frame.
68520  IF(npa.GE.3) CALL pyrobo(ipa(1),ipa(npa),0d0,0d0,-ps(1)/ps(4),
68521  &-ps(2)/ps(4),-ps(3)/ps(4))
68522 
68523 C...Define imagined single initiator of shower for parton system.
68524  ns=n
68525  IF(n.GT.mstu(4)-mstu(32)-10) THEN
68526  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
68527  IF(mstu(21).GE.1) RETURN
68528  ENDIF
68529  280 n=ns
68530  IF(npa.GE.2) THEN
68531  k(n+1,1)=11
68532  k(n+1,2)=21
68533  k(n+1,3)=0
68534  k(n+1,4)=0
68535  k(n+1,5)=0
68536  p(n+1,1)=0d0
68537  p(n+1,2)=0d0
68538  p(n+1,3)=0d0
68539  p(n+1,4)=ps(5)
68540  p(n+1,5)=ps(5)
68541  v(n+1,5)=ps(5)**2
68542  n=n+1
68543  iref(1)=21
68544  ENDIF
68545 
68546 C...Loop over partons that may branch.
68547  nep=npa
68548  im=ns
68549  IF(npa.EQ.1) im=ns-1
68550  290 im=im+1
68551  IF(n.GT.ns) THEN
68552  IF(im.GT.n) GOTO 600
68553  kflm=iabs(k(im,2))
68554  ir=iref(im-ns)
68555  IF(ksh(ir).EQ.0) GOTO 290
68556  IF(p(im,5).LT.pmth(2,ir)) GOTO 290
68557  igm=k(im,3)
68558  ELSE
68559  igm=-1
68560  ENDIF
68561  IF(n+nep.GT.mstu(4)-mstu(32)-10) THEN
68562  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
68563  IF(mstu(21).GE.1) RETURN
68564  ENDIF
68565 
68566 C...Position of aunt (sister to branching parton).
68567 C...Origin and flavour of daughters.
68568  iau=0
68569  IF(igm.GT.0) THEN
68570  IF(k(im-1,3).EQ.igm) iau=im-1
68571  IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
68572  ENDIF
68573  IF(igm.GE.0) THEN
68574  k(im,4)=n+1
68575  DO 300 i=1,nep
68576  k(n+i,3)=im
68577  300 CONTINUE
68578  ELSE
68579  k(n+1,3)=ipa(1)
68580  ENDIF
68581  IF(igm.LE.0) THEN
68582  DO 310 i=1,nep
68583  k(n+i,2)=k(ipa(i),2)
68584  310 CONTINUE
68585  ELSEIF(kflm.NE.21) THEN
68586  k(n+1,2)=k(im,2)
68587  k(n+2,2)=k(im,5)
68588  iref(n+1-ns)=iref(im-ns)
68589  iref(n+2-ns)=iabs(k(n+2,2))
68590  ELSEIF(k(im,5).EQ.21) THEN
68591  k(n+1,2)=21
68592  k(n+2,2)=21
68593  iref(n+1-ns)=21
68594  iref(n+2-ns)=21
68595  ELSE
68596  k(n+1,2)=k(im,5)
68597  k(n+2,2)=-k(im,5)
68598  iref(n+1-ns)=iabs(k(n+1,2))
68599  iref(n+2-ns)=iabs(k(n+2,2))
68600  ENDIF
68601 
68602 C...Reset flags on daughters and tries made.
68603  DO 320 ip=1,nep
68604  k(n+ip,1)=3
68605  k(n+ip,4)=0
68606  k(n+ip,5)=0
68607  kfld(ip)=iabs(k(n+ip,2))
68608  IF(kchg(pycomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
68609  itry(ip)=0
68610  isl(ip)=0
68611  isi(ip)=0
68612  IF(ksh(iref(n+ip-ns)).EQ.1) isi(ip)=1
68613  320 CONTINUE
68614  islm=0
68615 
68616 C...Maximum virtuality of daughters.
68617  IF(igm.LE.0) THEN
68618  DO 330 i=1,npa
68619  IF(npa.GE.3) p(n+i,4)=p(ipa(i),4)
68620  p(n+i,5)=min(qmax,ps(5))
68621  ir=iref(n+i-ns)
68622  IF(ip2.LE.-8) p(n+i,5)=max(p(n+i,5),2d0*pmth(3,ir))
68623  IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
68624  330 CONTINUE
68625  ELSE
68626  IF(mstj(43).LE.2) pem=v(im,2)
68627  IF(mstj(43).GE.3) pem=p(im,4)
68628  p(n+1,5)=min(p(im,5),v(im,1)*pem)
68629  p(n+2,5)=min(p(im,5),(1d0-v(im,1))*pem)
68630  IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
68631  ENDIF
68632  DO 340 i=1,nep
68633  pmsd(i)=p(n+i,5)
68634  IF(isi(i).EQ.1) THEN
68635  ir=iref(n+i-ns)
68636  IF(p(n+i,5).LE.pmth(3,ir)) p(n+i,5)=pmth(1,ir)
68637  ENDIF
68638  v(n+i,5)=p(n+i,5)**2
68639  340 CONTINUE
68640 
68641 C...Choose one of the daughters for evolution.
68642  350 inum=0
68643  IF(nep.EQ.1) inum=1
68644  DO 360 i=1,nep
68645  IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
68646  360 CONTINUE
68647  DO 370 i=1,nep
68648  IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
68649  ir=iref(n+i-ns)
68650  IF(p(n+i,5).GE.pmth(2,ir)) inum=i
68651  ENDIF
68652  370 CONTINUE
68653  IF(inum.EQ.0) THEN
68654  rmax=0d0
68655  DO 380 i=1,nep
68656  IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqt2e) THEN
68657  rpm=p(n+i,5)/pmsd(i)
68658  ir=iref(n+i-ns)
68659  IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ir)) THEN
68660  rmax=rpm
68661  inum=i
68662  ENDIF
68663  ENDIF
68664  380 CONTINUE
68665  ENDIF
68666 
68667 C...Cancel choice of predetermined daughter already treated.
68668  inum=max(1,inum)
68669  inumt=inum
68670  IF(mpspd.EQ.1.AND.igm.EQ.0.AND.itry(inumt).GE.1) THEN
68671  IF(k(ip1-1+inum,4).GT.0) inum=3-inum
68672  ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2.AND.itry(inumt).GE.1) THEN
68673  IF(kfld(inumt).NE.21.AND.k(ip1+2,4).GT.0) inum=3-inum
68674  IF(kfld(inumt).EQ.21.AND.k(ip1+3,4).GT.0) inum=3-inum
68675  ENDIF
68676 
68677 C...Store information on choice of evolving daughter.
68678  iep(1)=n+inum
68679  DO 390 i=2,nep
68680  iep(i)=iep(i-1)+1
68681  IF(iep(i).GT.n+nep) iep(i)=n+1
68682  390 CONTINUE
68683  DO 400 i=1,nep
68684  kfl(i)=iabs(k(iep(i),2))
68685  400 CONTINUE
68686  itry(inum)=itry(inum)+1
68687  IF(itry(inum).GT.200) THEN
68688  CALL pyerrm(14,'(PYSHOW:) caught in infinite loop')
68689  IF(mstu(21).GE.1) RETURN
68690  ENDIF
68691  z=0.5d0
68692  ir=iref(iep(1)-ns)
68693  IF(ksh(ir).EQ.0) GOTO 450
68694  IF(p(iep(1),5).LT.pmth(2,ir)) GOTO 450
68695 
68696 C...Check if evolution already predetermined for daughter.
68697  ipspd=0
68698  IF(mpspd.EQ.1.AND.igm.EQ.0) THEN
68699  IF(k(ip1-1+inum,4).GT.0) ipspd=ip1-1+inum
68700  ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2) THEN
68701  IF(kfl(1).NE.21.AND.k(ip1+2,4).GT.0) ipspd=ip1+2
68702  IF(kfl(1).EQ.21.AND.k(ip1+3,4).GT.0) ipspd=ip1+3
68703  ENDIF
68704  IF(inum.EQ.1.OR.inum.EQ.2) THEN
68705  isset(inum)=0
68706  IF(ipspd.NE.0) isset(inum)=1
68707  ENDIF
68708 
68709 C...Select side for interference with initial state partons.
68710  IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
68711  iii=iep(1)-ns-1
68712  isii(iii)=0
68713  IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
68714  isii(iii)=1
68715  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
68716  IF(pyr(0).GT.0.5d0) isii(iii)=1
68717  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
68718  isii(iii)=1
68719  IF(pyr(0).GT.0.5d0) isii(iii)=2
68720  ENDIF
68721  ENDIF
68722 
68723 C...Calculate allowed z range.
68724  IF(nep.EQ.1) THEN
68725  pmed=ps(4)
68726  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
68727  pmed=p(im,5)
68728  ELSE
68729  IF(inum.EQ.1) pmed=v(im,1)*pem
68730  IF(inum.EQ.2) pmed=(1d0-v(im,1))*pem
68731  ENDIF
68732  IF(mod(mstj(43),2).EQ.1) THEN
68733  zc=pmth(2,21)/pmed
68734  zce=pmth(2,22)/pmed
68735  IF(iscol(ir).EQ.0) zce=0.5d0*parj(90)/pmed
68736  ELSE
68737  zc=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,21)/pmed)**2)))
68738  IF(zc.LT.1d-6) zc=(pmth(2,21)/pmed)**2
68739  pmtmpe=pmth(2,22)
68740  IF(iscol(ir).EQ.0) pmtmpe=0.5d0*parj(90)
68741  zce=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmtmpe/pmed)**2)))
68742  IF(zce.LT.1d-6) zce=(pmtmpe/pmed)**2
68743  ENDIF
68744  zc=min(zc,0.491d0)
68745  zce=min(zce,0.49991d0)
68746  IF(((mstj(41).EQ.1.AND.zc.GT.0.49d0).OR.(mstj(41).GE.2.AND.
68747  &min(zc,zce).GT.0.4999d0)).AND.ipspd.EQ.0) THEN
68748  p(iep(1),5)=pmth(1,ir)
68749  v(iep(1),5)=p(iep(1),5)**2
68750  GOTO 450
68751  ENDIF
68752 
68753 C...Integral of Altarelli-Parisi z kernel for QCD.
68754 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68755  IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
68756  fbr=6d0*log((1d0-zc)/zc)+mstj(45)*0.5d0
68757 C...QUARKONIA+++
68758 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68759  ELSEIF(mstj(49).EQ.0.AND.mstp(149).GE.0.AND.
68760  & (kfl(1).EQ.9900443.OR.kfl(1).EQ.9900553)) THEN
68761  fbr=6d0*log((1d0-zc)/zc)
68762 C...QUARKONIA---
68763  ELSEIF(mstj(49).EQ.0) THEN
68764  fbr=(8d0/3d0)*log((1d0-zc)/zc)
68765  IF(iglui.EQ.1.AND.ir.GE.31) fbr=fbr*(9d0/4d0)
68766 
68767 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68768  ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
68769  fbr=(parj(87)+mstj(45)*parj(88))*(1d0-2d0*zc)
68770  ELSEIF(mstj(49).EQ.1) THEN
68771  fbr=(1d0-2d0*zc)/3d0
68772  IF(igm.EQ.0.AND.m3jc.GE.1) fbr=4d0*fbr
68773 
68774 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68775  ELSEIF(kfl(1).EQ.21) THEN
68776  fbr=6d0*mstj(45)*(0.5d0-zc)
68777  ELSE
68778  fbr=2d0*log((1d0-zc)/zc)
68779  ENDIF
68780 
68781 C...Reset QCD probability for colourless.
68782  IF(iscol(ir).EQ.0) fbr=0d0
68783 
68784 C...Integral of Altarelli-Parisi kernel for photon emission.
68785  fbre=0d0
68786  IF(mstj(41).GE.2.AND.ischg(ir).EQ.1) THEN
68787  IF(kfl(1).LE.18) THEN
68788  fbre=(kchg(kfl(1),1)/3d0)**2*2d0*log((1d0-zce)/zce)
68789  ENDIF
68790  IF(mstj(41).EQ.10) fbre=parj(84)*fbre
68791  ENDIF
68792 
68793 C...Inner veto algorithm starts. Find maximum mass for evolution.
68794  410 pms=v(iep(1),5)
68795  IF(igm.GE.0) THEN
68796  pm2=0d0
68797  DO 420 i=2,nep
68798  pm=p(iep(i),5)
68799  iri=iref(iep(i)-ns)
68800  IF(ksh(iri).EQ.1) pm=pmth(2,iri)
68801  pm2=pm2+pm
68802  420 CONTINUE
68803  pms=min(pms,(p(im,5)-pm2)**2)
68804  ENDIF
68805 
68806 C...Select mass for daughter in QCD evolution.
68807  b0=27d0/6d0
68808  DO 430 iff=4,mstj(45)
68809  IF(pms.GT.4d0*pmth(2,iff)**2) b0=(33d0-2d0*iff)/6d0
68810  430 CONTINUE
68811 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68812  pmsc=max(0.5d0*parj(82),pms-pmth(1,ir)**2)
68813 C...Already predetermined choice.
68814  IF(ipspd.NE.0) THEN
68815  pmsqcd=p(ipspd,5)**2
68816  ELSEIF(fbr.LT.1d-3) THEN
68817  pmsqcd=0d0
68818  ELSEIF(mstj(44).LE.0) THEN
68819  pmsqcd=pmsc*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(111)*fbr)))
68820  ELSEIF(mstj(44).EQ.1) THEN
68821  pmsqcd=4d0*alams*(0.25d0*pmsc/alams)**(pyr(0)**(b0/fbr))
68822  ELSE
68823  pmsqcd=pmsc*exp(max(-50d0,alfm*b0*log(pyr(0))/fbr))
68824  ENDIF
68825 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68826  IF(ipspd.EQ.0) pmsqcd=pmsqcd+pmth(1,ir)**2
68827  IF(zc.GT.0.49d0.OR.pmsqcd.LE.pmth(4,ir)**2) pmsqcd=pmth(2,ir)**2
68828  v(iep(1),5)=pmsqcd
68829  mce=1
68830 
68831 C...Select mass for daughter in QED evolution.
68832  IF(mstj(41).GE.2.AND.ischg(ir).EQ.1.AND.ipspd.EQ.0) THEN
68833 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68834  pmse=max(0.5d0*parj(83),pms-pmth(1,ir)**2)
68835  IF(fbre.LT.1d-3) THEN
68836  pmsqed=0d0
68837  ELSE
68838  pmsqed=pmse*exp(max(-50d0,log(pyr(0))*paru(2)/
68839  & (paru(101)*fbre)))
68840  ENDIF
68841 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68842  pmsqed=pmsqed+pmth(1,ir)**2
68843  IF(zce.GT.0.4999d0.OR.pmsqed.LE.pmth(5,ir)**2) pmsqed=
68844  & pmth(2,ir)**2
68845  IF(pmsqed.GT.pmsqcd) THEN
68846  v(iep(1),5)=pmsqed
68847  mce=2
68848  ENDIF
68849  ENDIF
68850 
68851 C...Check whether daughter mass below cutoff.
68852  p(iep(1),5)=sqrt(v(iep(1),5))
68853  IF(p(iep(1),5).LE.pmth(3,ir)) THEN
68854  p(iep(1),5)=pmth(1,ir)
68855  v(iep(1),5)=p(iep(1),5)**2
68856  GOTO 450
68857  ENDIF
68858 
68859 C...Already predetermined choice of z, and flavour in g -> qqbar.
68860  IF(ipspd.NE.0) THEN
68861  ipsgd1=k(ipspd,4)
68862  ipsgd2=k(ipspd,5)
68863  pmsgd1=p(ipsgd1,5)**2
68864  pmsgd2=p(ipsgd2,5)**2
68865  alamps=sqrt(max(1d-10,(pmsqcd-pmsgd1-pmsgd2)**2-
68866  & 4d0*pmsgd1*pmsgd2))
68867  z=0.5d0*(pmsqcd*(2d0*p(ipsgd1,4)/p(ipspd,4)-1d0)+alamps-
68868  & pmsgd1+pmsgd2)/alamps
68869  z=max(0.00001d0,min(0.99999d0,z))
68870  IF(kfl(1).NE.21) THEN
68871  k(iep(1),5)=21
68872  ELSE
68873  k(iep(1),5)=iabs(k(ipsgd1,2))
68874  ENDIF
68875 
68876 C...Select z value of branching: q -> qgamma.
68877  ELSEIF(mce.EQ.2) THEN
68878  z=1d0-(1d0-zce)*(zce/(1d0-zce))**pyr(0)
68879  IF(1d0+z**2.LT.2d0*pyr(0)) GOTO 410
68880  k(iep(1),5)=22
68881 
68882 C...QUARKONIA+++
68883 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
68884  ELSEIF(mstj(49).EQ.0.AND.
68885  & (kfl(1).EQ.9900443.OR.kfl(1).EQ.9900553)) THEN
68886  z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
68887 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
68888  IF(mstp(149).LE.0.OR.pyr(0).GT.0.5d0) z=1d0-z
68889  IF((1d0-z*(1d0-z))**2.LT.pyr(0)) GOTO 410
68890  k(iep(1),5)=21
68891 C...QUARKONIA---
68892 
68893 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
68894  ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
68895  z=1d0-(1d0-zc)*(zc/(1d0-zc))**pyr(0)
68896 C...Only do z weighting when no ME correction afterwards.
68897  IF(m3jc.EQ.0.AND.1d0+z**2.LT.2d0*pyr(0)) GOTO 410
68898  k(iep(1),5)=21
68899  ELSEIF(mstj(49).EQ.0.AND.mstj(45)*0.5d0.LT.pyr(0)*fbr) THEN
68900  z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
68901  IF(pyr(0).GT.0.5d0) z=1d0-z
68902  IF((1d0-z*(1d0-z))**2.LT.pyr(0)) GOTO 410
68903  k(iep(1),5)=21
68904  ELSEIF(mstj(49).NE.1) THEN
68905  z=pyr(0)
68906  IF(z**2+(1d0-z)**2.LT.pyr(0)) GOTO 410
68907  kflb=1+int(mstj(45)*pyr(0))
68908  pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
68909  IF(pmq.GE.1d0) GOTO 410
68910  IF(mstj(44).LE.2.OR.mstj(44).EQ.4) THEN
68911  IF(z.LT.zc.OR.z.GT.1d0-zc) GOTO 410
68912  pmq0=4d0*pmth(2,21)**2/v(iep(1),5)
68913  IF(mod(mstj(43),2).EQ.0.AND.(1d0+0.5d0*pmq)*sqrt(1d0-pmq)
68914  & .LT.pyr(0)*(1d0+0.5d0*pmq0)*sqrt(1d0-pmq0)) GOTO 410
68915  ELSE
68916  IF((1d0+0.5d0*pmq)*sqrt(1d0-pmq).LT.pyr(0)) GOTO 410
68917  ENDIF
68918  k(iep(1),5)=kflb
68919 
68920 C...Ditto for scalar gluon model.
68921  ELSEIF(kfl(1).NE.21) THEN
68922  z=1d0-sqrt(zc**2+pyr(0)*(1d0-2d0*zc))
68923  k(iep(1),5)=21
68924  ELSEIF(pyr(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
68925  z=zc+(1d0-2d0*zc)*pyr(0)
68926  k(iep(1),5)=21
68927  ELSE
68928  z=zc+(1d0-2d0*zc)*pyr(0)
68929  kflb=1+int(mstj(45)*pyr(0))
68930  pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
68931  IF(pmq.GE.1d0) GOTO 410
68932  k(iep(1),5)=kflb
68933  ENDIF
68934 
68935 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
68936  IF(mce.EQ.1.AND.mstj(44).GE.2.AND.ipspd.EQ.0) THEN
68937  IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.
68938  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
68939  IF(alfm/log(v(iep(1),5)*0.25d0/alams).LT.pyr(0)) GOTO 410
68940  ELSE
68941  pt2app=z*(1d0-z)*v(iep(1),5)
68942  IF(mstj(44).GE.4) pt2app=pt2app*
68943  & (1d0-pmth(1,ir)**2/v(iep(1),5))**2
68944  IF(pt2app.LT.pt2min) GOTO 410
68945  IF(alfm/log(pt2app/alams).LT.pyr(0)) GOTO 410
68946  ENDIF
68947  ENDIF
68948 
68949 C...Check if z consistent with chosen m.
68950  IF(kfl(1).EQ.21) THEN
68951  irgd1=iabs(k(iep(1),5))
68952  irgd2=irgd1
68953  ELSE
68954  irgd1=ir
68955  irgd2=iabs(k(iep(1),5))
68956  ENDIF
68957  IF(nep.EQ.1) THEN
68958  ped=ps(4)
68959  ELSEIF(nep.GE.3) THEN
68960  ped=p(iep(1),4)
68961  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
68962  ped=0.5d0*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
68963  ELSE
68964  IF(iep(1).EQ.n+1) ped=v(im,1)*pem
68965  IF(iep(1).EQ.n+2) ped=(1d0-v(im,1))*pem
68966  ENDIF
68967  IF(mod(mstj(43),2).EQ.1) THEN
68968  pmqth3=0.5d0*parj(82)
68969  IF(irgd2.EQ.22) pmqth3=0.5d0*parj(83)
68970  IF(irgd2.EQ.22.AND.iscol(ir).EQ.0) pmqth3=0.5d0*parj(90)
68971  pmq1=(pmth(1,irgd1)**2+pmqth3**2)/v(iep(1),5)
68972  pmq2=(pmth(1,irgd2)**2+pmqth3**2)/v(iep(1),5)
68973  zd=sqrt(max(0d0,(1d0-v(iep(1),5)/ped**2)*((1d0-pmq1-pmq2)**2-
68974  & 4d0*pmq1*pmq2)))
68975  zh=1d0+pmq1-pmq2
68976  ELSE
68977  zd=sqrt(max(0d0,1d0-v(iep(1),5)/ped**2))
68978  zh=1d0
68979  ENDIF
68980  IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.
68981  &(mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
68982  ELSEIF(ipspd.NE.0) THEN
68983  ELSE
68984  zl=0.5d0*(zh-zd)
68985  zu=0.5d0*(zh+zd)
68986  IF(z.LT.zl.OR.z.GT.zu) GOTO 410
68987  ENDIF
68988  IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1d0-zl)/max(1d-20,zl*
68989  &(1d0-zu)))
68990  IF(kfl(1).NE.21) v(iep(1),3)=log((1d0-zl)/max(1d-10,1d0-zu))
68991 
68992 C...Width suppression for q -> q + g.
68993  IF(mstj(40).NE.0.AND.kfl(1).NE.21.AND.ipspd.EQ.0) THEN
68994  IF(igm.EQ.0) THEN
68995  eglu=0.5d0*ps(5)*(1d0-z)*(1d0+v(iep(1),5)/v(ns+1,5))
68996  ELSE
68997  eglu=pmed*(1d0-z)
68998  ENDIF
68999  chi=parj(89)**2/(parj(89)**2+eglu**2)
69000  IF(mstj(40).EQ.1) THEN
69001  IF(chi.LT.pyr(0)) GOTO 410
69002  ELSEIF(mstj(40).EQ.2) THEN
69003  IF(1d0-chi.LT.pyr(0)) GOTO 410
69004  ENDIF
69005  ENDIF
69006 
69007 C...Three-jet matrix element correction.
69008  IF(m3jc.GE.1) THEN
69009  wme=1d0
69010  wshow=1d0
69011 
69012 C...QED matrix elements: only for massless case so far.
69013  IF(mce.EQ.2.AND.igm.EQ.0) THEN
69014  x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
69015  x2=1d0-v(iep(1),5)/v(ns+1,5)
69016  x3=(1d0-x1)+(1d0-x2)
69017  ki1=k(ipa(inum),2)
69018  ki2=k(ipa(3-inum),2)
69019  qf1=kchg(pycomp(ki1),1)*isign(1,ki1)/3d0
69020  qf2=kchg(pycomp(ki2),1)*isign(1,ki2)/3d0
69021  wshow=qf1**2*(1d0-x1)/x3*(1d0+(x1/(2d0-x2))**2)+
69022  & qf2**2*(1d0-x2)/x3*(1d0+(x2/(2d0-x1))**2)
69023  wme=(qf1*(1d0-x1)/x3-qf2*(1d0-x2)/x3)**2*(x1**2+x2**2)
69024  ELSEIF(mce.EQ.2) THEN
69025 
69026 C...QCD matrix elements, including mass effects.
69027  ELSEIF(mstj(49).NE.1.AND.k(iep(1),2).NE.21) THEN
69028  ps1me=v(iep(1),5)
69029  pm1me=pmth(1,ir)
69030  m3jcc=m3jc
69031  IF(ir.GE.31.AND.igm.EQ.0) THEN
69032 C...QCD ME: original parton, first branching.
69033  pm2me=pmth(1,63-ir)
69034  ecmme=ps(5)
69035  ELSEIF(ir.GE.31) THEN
69036 C...QCD ME: original parton, subsequent branchings.
69037  pm2me=pmth(1,63-ir)
69038  pedme=pem*(v(im,1)+(1d0-v(im,1))*ps1me/v(im,5))
69039  ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
69040  ELSEIF(k(im,2).EQ.21) THEN
69041 C...QCD ME: secondary partons, first branching.
69042  pm2me=pm1me
69043  zmme=v(im,1)
69044  IF(iep(1).GT.iep(2)) zmme=1d0-zmme
69045  pmlme=sqrt(max(0d0,(v(im,5)-ps1me-pm2me**2)**2-
69046  & 4d0*ps1me*pm2me**2))
69047  pedme=pem*(0.5d0*(v(im,5)-pmlme+ps1me-pm2me**2)+pmlme*zmme)/
69048  & v(im,5)
69049  ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
69050  m3jcc=66
69051  ELSE
69052 C...QCD ME: secondary partons, subsequent branchings.
69053  pm2me=pm1me
69054  pedme=pem*(v(im,1)+(1d0-v(im,1))*ps1me/v(im,5))
69055  ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
69056  m3jcc=66
69057  ENDIF
69058 C...Construct ME variables.
69059  r1me=pm1me/ecmme
69060  r2me=pm2me/ecmme
69061  x1=(1d0+ps1me/ecmme**2-r2me**2)*(z+(1d0-z)*pm1me**2/ps1me)
69062  x2=1d0+r2me**2-ps1me/ecmme**2
69063 C...Call ME, with right order important for two inequivalent showerers.
69064  IF(ir.EQ.iord+30) THEN
69065  wme=pymael(m3jcc,x1,x2,r1me,r2me,alpha)
69066  ELSE
69067  wme=pymael(m3jcc,x2,x1,r2me,r1me,alpha)
69068  ENDIF
69069 C...Split up total ME when two radiating partons.
69070  isprad=1
69071  IF((m3jcc.GE.16.AND.m3jcc.LE.19).OR.
69072  & (m3jcc.GE.26.AND.m3jcc.LE.29).OR.
69073  & (m3jcc.GE.36.AND.m3jcc.LE.39).OR.
69074  & (m3jcc.GE.46.AND.m3jcc.LE.49).OR.
69075  & (m3jcc.GE.56.AND.m3jcc.LE.64)) isprad=0
69076  IF(isprad.EQ.1) wme=wme*max(1d-10,1d0+r1me**2-r2me**2-x1)/
69077  & max(1d-10,2d0-x1-x2)
69078 C...Evaluate shower rate to be compared with.
69079  wshow=2d0/(max(1d-10,2d0-x1-x2)*
69080  & max(1d-10,1d0+r2me**2-r1me**2-x2))
69081  IF(iglui.EQ.1.AND.ir.GE.31) wshow=(9d0/4d0)*wshow
69082  ELSEIF(mstj(49).NE.1) THEN
69083 
69084 C...Toy model scalar theory matrix elements; no mass effects.
69085  ELSE
69086  x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
69087  x2=1d0-v(iep(1),5)/v(ns+1,5)
69088  x3=(1d0-x1)+(1d0-x2)
69089  wshow=4d0*x3*((1d0-x1)/(2d0-x2)**2+(1d0-x2)/(2d0-x1)**2)
69090  wme=x3**2
69091  IF(mstj(102).GE.2) wme=x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*
69092  & parj(171)
69093  ENDIF
69094 
69095  IF(wme.LT.pyr(0)*wshow) GOTO 410
69096  ENDIF
69097 
69098 C...Impose angular ordering by rejection of nonordered emission.
69099  IF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2.AND.ipspd.EQ.0) THEN
69100  pemao=v(im,1)*p(im,4)
69101  IF(iep(1).EQ.n+2) pemao=(1d0-v(im,1))*p(im,4)
69102  IF(ir.GE.31.AND.mstj(42).GE.5) THEN
69103  maod=0
69104  ELSEIF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.(mstj(42).EQ.4
69105  & .OR.mstj(42).EQ.7)) THEN
69106  maod=0
69107  ELSEIF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.(mstj(42).EQ.3
69108  & .OR.mstj(42).EQ.6)) THEN
69109  maod=1
69110  pmdao=pmth(2,k(iep(1),5))
69111  the2id=z*(1d0-z)*pemao**2/(v(iep(1),5)-4d0*pmdao**2)
69112  ELSE
69113  maod=1
69114  the2id=z*(1d0-z)*pemao**2/v(iep(1),5)
69115  IF(mstj(42).GE.3.AND.mstj(42).NE.5) the2id=the2id*
69116  & (1d0+pmth(1,ir)**2*(1d0-z)/(v(iep(1),5)*z))**2
69117  ENDIF
69118  maom=1
69119  iaom=im
69120  440 IF(k(iaom,5).EQ.22) THEN
69121  iaom=k(iaom,3)
69122  IF(k(iaom,3).LE.ns) maom=0
69123  IF(maom.EQ.1) GOTO 440
69124  ENDIF
69125  IF(maom.EQ.1.AND.maod.EQ.1) THEN
69126  the2im=v(iaom,1)*(1d0-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
69127  IF(the2id.LT.the2im) GOTO 410
69128  ENDIF
69129  ENDIF
69130 
69131 C...Impose user-defined maximum angle at first branching.
69132  IF(mstj(48).EQ.1.AND.ipspd.EQ.0) THEN
69133  IF(nep.EQ.1.AND.im.EQ.ns) THEN
69134  the2id=z*(1d0-z)*ps(4)**2/v(iep(1),5)
69135  IF(parj(85)**2*the2id.LT.1d0) GOTO 410
69136  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
69137  the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
69138  IF(parj(85)**2*the2id.LT.1d0) GOTO 410
69139  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
69140  the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
69141  IF(parj(86)**2*the2id.LT.1d0) GOTO 410
69142  ENDIF
69143  ENDIF
69144 
69145 C...Impose angular constraint in first branching from interference
69146 C...with initial state partons.
69147  IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
69148  the2d=max((1d0-z)/z,z/(1d0-z))*v(iep(1),5)/(0.5d0*p(im,4))**2
69149  IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
69150  IF(the2d.GT.theiis(1,isii(1))**2) GOTO 410
69151  ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
69152  IF(the2d.GT.theiis(2,isii(2))**2) GOTO 410
69153  ENDIF
69154  ENDIF
69155 
69156 C...End of inner veto algorithm. Check if only one leg evolved so far.
69157  450 v(iep(1),1)=z
69158  isl(1)=0
69159  isl(2)=0
69160  IF(nep.EQ.1) GOTO 490
69161  IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) GOTO 350
69162  DO 460 i=1,nep
69163  ir=iref(n+i-ns)
69164  IF(itry(i).EQ.0.AND.ksh(ir).EQ.1) THEN
69165  IF(p(n+i,5).GE.pmth(2,ir)) GOTO 350
69166  ENDIF
69167  460 CONTINUE
69168 
69169 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69170  IF(nep.GE.3) THEN
69171  pmsum=0d0
69172  DO 470 i=1,nep
69173  pmsum=pmsum+p(n+i,5)
69174  470 CONTINUE
69175  IF(pmsum.GE.ps(5)) GOTO 350
69176  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
69177  DO 480 i1=n+1,n+2
69178  irda=iref(i1-ns)
69179  IF(ksh(irda).EQ.0) GOTO 480
69180  IF(p(i1,5).LT.pmth(2,irda)) GOTO 480
69181  IF(irda.EQ.21) THEN
69182  irgd1=iabs(k(i1,5))
69183  irgd2=irgd1
69184  ELSE
69185  irgd1=irda
69186  irgd2=iabs(k(i1,5))
69187  ENDIF
69188  i2=2*n+3-i1
69189  IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
69190  ped=0.5d0*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
69191  ELSE
69192  IF(i1.EQ.n+1) zm=v(im,1)
69193  IF(i1.EQ.n+2) zm=1d0-v(im,1)
69194  pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
69195  & 4d0*v(n+1,5)*v(n+2,5))
69196  ped=pem*(0.5d0*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/
69197  & v(im,5)
69198  ENDIF
69199  IF(mod(mstj(43),2).EQ.1) THEN
69200  pmqth3=0.5d0*parj(82)
69201  IF(irgd2.EQ.22) pmqth3=0.5d0*parj(83)
69202  IF(irgd2.EQ.22.AND.iscol(irda).EQ.0) pmqth3=0.5d0*parj(90)
69203  pmq1=(pmth(1,irgd1)**2+pmqth3**2)/v(i1,5)
69204  pmq2=(pmth(1,irgd2)**2+pmqth3**2)/v(i1,5)
69205  zd=sqrt(max(0d0,(1d0-v(i1,5)/ped**2)*((1d0-pmq1-pmq2)**2-
69206  & 4d0*pmq1*pmq2)))
69207  zh=1d0+pmq1-pmq2
69208  ELSE
69209  zd=sqrt(max(0d0,1d0-v(i1,5)/ped**2))
69210  zh=1d0
69211  ENDIF
69212  IF(irda.EQ.21.AND.irgd1.LT.10.AND.
69213  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69214  ELSE
69215  zl=0.5d0*(zh-zd)
69216  zu=0.5d0*(zh+zd)
69217  IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
69218  & isset(1).EQ.0) THEN
69219  isl(1)=1
69220  ELSEIF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
69221  & isset(2).EQ.0) THEN
69222  isl(2)=1
69223  ENDIF
69224  ENDIF
69225  IF(irda.EQ.21) v(i1,4)=log(zu*(1d0-zl)/max(1d-20,
69226  & zl*(1d0-zu)))
69227  IF(irda.NE.21) v(i1,4)=log((1d0-zl)/max(1d-10,1d0-zu))
69228  480 CONTINUE
69229  IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
69230  isl(3-islm)=0
69231  islm=3-islm
69232  ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
69233  zdr1=max(0d0,v(n+1,3)/max(1d-6,v(n+1,4))-1d0)
69234  zdr2=max(0d0,v(n+2,3)/max(1d-6,v(n+2,4))-1d0)
69235  IF(zdr2.GT.pyr(0)*(zdr1+zdr2)) isl(1)=0
69236  IF(isl(1).EQ.1) isl(2)=0
69237  IF(isl(1).EQ.0) islm=1
69238  IF(isl(2).EQ.0) islm=2
69239  ENDIF
69240  IF(isl(1).EQ.1.OR.isl(2).EQ.1) GOTO 350
69241  ENDIF
69242  ird1=iref(n+1-ns)
69243  ird2=iref(n+2-ns)
69244  IF(igm.GT.0) THEN
69245  IF(mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
69246  & pmth(2,ird1).OR.p(n+2,5).GE.pmth(2,ird2))) THEN
69247  pmq1=v(n+1,5)/v(im,5)
69248  pmq2=v(n+2,5)/v(im,5)
69249  zd=sqrt(max(0d0,(1d0-v(im,5)/pem**2)*((1d0-pmq1-pmq2)**2-
69250  & 4d0*pmq1*pmq2)))
69251  zh=1d0+pmq1-pmq2
69252  zl=0.5d0*(zh-zd)
69253  zu=0.5d0*(zh+zd)
69254  IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) GOTO 350
69255  ENDIF
69256  ENDIF
69257 
69258 C...Accepted branch. Construct four-momentum for initial partons.
69259  490 mazip=0
69260  mazic=0
69261  IF(nep.EQ.1) THEN
69262  p(n+1,1)=0d0
69263  p(n+1,2)=0d0
69264  p(n+1,3)=sqrt(max(0d0,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
69265  & p(n+1,5))))
69266  p(n+1,4)=p(ipa(1),4)
69267  v(n+1,2)=p(n+1,4)
69268  ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
69269  ped1=0.5d0*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
69270  p(n+1,1)=0d0
69271  p(n+1,2)=0d0
69272  p(n+1,3)=sqrt(max(0d0,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
69273  p(n+1,4)=ped1
69274  p(n+2,1)=0d0
69275  p(n+2,2)=0d0
69276  p(n+2,3)=-p(n+1,3)
69277  p(n+2,4)=p(im,5)-ped1
69278  v(n+1,2)=p(n+1,4)
69279  v(n+2,2)=p(n+2,4)
69280  ELSEIF(nep.GE.3) THEN
69281 C...Rescale all momenta for energy conservation.
69282  loop=0
69283  pes=0d0
69284  pqs=0d0
69285  DO 510 i=1,nep
69286  DO 500 j=1,4
69287  p(n+i,j)=p(ipa(i),j)
69288  500 CONTINUE
69289  pes=pes+p(n+i,4)
69290  pqs=pqs+p(n+i,5)**2/p(n+i,4)
69291  510 CONTINUE
69292  520 loop=loop+1
69293  fac=(ps(5)-pqs)/(pes-pqs)
69294  pes=0d0
69295  pqs=0d0
69296  DO 540 i=1,nep
69297  DO 530 j=1,3
69298  p(n+i,j)=fac*p(n+i,j)
69299  530 CONTINUE
69300  p(n+i,4)=sqrt(p(n+i,5)**2+p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
69301  v(n+i,2)=p(n+i,4)
69302  pes=pes+p(n+i,4)
69303  pqs=pqs+p(n+i,5)**2/p(n+i,4)
69304  540 CONTINUE
69305  IF(loop.LT.10.AND.abs(pes-ps(5)).GT.1d-12*ps(5)) GOTO 520
69306 
69307 C...Construct transverse momentum for ordinary branching in shower.
69308  ELSE
69309  zm=v(im,1)
69310  looppt=0
69311  550 looppt=looppt+1
69312  pzm=sqrt(max(0d0,(pem+p(im,5))*(pem-p(im,5))))
69313  pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4d0*v(n+1,5)*v(n+2,5)
69314  IF(pzm.LE.0d0) THEN
69315  pts=0d0
69316  ELSEIF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
69317  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69318  pts=pmls*zm*(1d0-zm)/v(im,5)
69319  ELSEIF(mod(mstj(43),2).EQ.1) THEN
69320  pts=(pem**2*(zm*(1d0-zm)*v(im,5)-(1d0-zm)*v(n+1,5)-
69321  & zm*v(n+2,5))-0.25d0*pmls)/pzm**2
69322  ELSE
69323  pts=pmls*(zm*(1d0-zm)*pem**2/v(im,5)-0.25d0)/pzm**2
69324  ENDIF
69325  IF(pts.LT.0d0.AND.looppt.LT.10) THEN
69326  zm=0.05d0+0.9d0*zm
69327  GOTO 550
69328  ELSEIF(pts.LT.0d0) THEN
69329  GOTO 280
69330  ENDIF
69331  pt=sqrt(max(0d0,pts))
69332 
69333 C...Global statistics.
69334  mint(353)=mint(353)+1
69335  vint(353)=vint(353)+pt
69336  IF (mint(353).EQ.1) vint(358)=pt
69337 
69338 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69339  hazip=0d0
69340  IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21
69341  & .AND.iau.NE.0) THEN
69342  IF(k(igm,3).NE.0) mazip=1
69343  zau=v(igm,1)
69344  IF(iau.EQ.im+1) zau=1d0-v(igm,1)
69345  IF(mazip.EQ.0) zau=0d0
69346  IF(k(igm,2).NE.21) THEN
69347  hazip=2d0*zau/(1d0+zau**2)
69348  ELSE
69349  hazip=(zau/(1d0-zau*(1d0-zau)))**2
69350  ENDIF
69351  IF(k(n+1,2).NE.21) THEN
69352  hazip=hazip*(-2d0*zm*(1d0-zm))/(1d0-2d0*zm*(1d0-zm))
69353  ELSE
69354  hazip=hazip*(zm*(1d0-zm)/(1d0-zm*(1d0-zm)))**2
69355  ENDIF
69356  ENDIF
69357 
69358 C...Find coefficient of azimuthal asymmetry due to soft gluon
69359 C...interference.
69360  hazic=0d0
69361  IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
69362  & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
69363  IF(k(igm,3).NE.0) mazic=n+1
69364  IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
69365  IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
69366  & zm.GT.0.5d0) mazic=n+2
69367  IF(k(iau,2).EQ.22) mazic=0
69368  zs=zm
69369  IF(mazic.EQ.n+2) zs=1d0-zm
69370  zgm=v(igm,1)
69371  IF(iau.EQ.im-1) zgm=1d0-v(igm,1)
69372  IF(mazic.EQ.0) zgm=1d0
69373  IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*
69374  & sqrt((1d0-zs)*(1d0-zgm)/(zs*zgm))
69375  hazic=min(0.95d0,hazic)
69376  ENDIF
69377  ENDIF
69378 
69379 C...Construct energies for ordinary branching in shower.
69380  560 IF(nep.EQ.2.AND.igm.GT.0) THEN
69381  IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
69382  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69383  p(n+1,4)=0.5d0*(pem*(v(im,5)+v(n+1,5)-v(n+2,5))+
69384  & pzm*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
69385  ELSEIF(mod(mstj(43),2).EQ.1) THEN
69386  p(n+1,4)=pem*v(im,1)
69387  ELSE
69388  p(n+1,4)=pem*(0.5d0*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
69389  & sqrt(pmls)*zm)/v(im,5)
69390  ENDIF
69391 
69392 C...Already predetermined choice of phi angle or not
69393  phi=paru(2)*pyr(0)
69394  IF(mpspd.EQ.1.AND.igm.EQ.ns+1) THEN
69395  ipspd=ip1+im-ns-2
69396  IF(k(ipspd,4).GT.0) THEN
69397  ipsgd1=k(ipspd,4)
69398  IF(im.EQ.ns+2) THEN
69399  phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
69400  ELSE
69401  phi=pyangl(-p(ipsgd1,1),p(ipsgd1,2))
69402  ENDIF
69403  ENDIF
69404  ELSEIF(mpspd.EQ.1.AND.igm.EQ.ns+2) THEN
69405  ipspd=ip1+im-ns-2
69406  IF(k(ipspd,4).GT.0) THEN
69407  ipsgd1=k(ipspd,4)
69408  phipsm=pyangl(p(ipspd,1),p(ipspd,2))
69409  thepsm=pyangl(p(ipspd,3),sqrt(p(ipspd,1)**2+p(ipspd,2)**2))
69410  CALL pyrobo(ipsgd1,ipsgd1,0d0,-phipsm,0d0,0d0,0d0)
69411  CALL pyrobo(ipsgd1,ipsgd1,-thepsm,0d0,0d0,0d0,0d0)
69412  phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
69413  CALL pyrobo(ipsgd1,ipsgd1,thepsm,phipsm,0d0,0d0,0d0)
69414  ENDIF
69415  ENDIF
69416 
69417 C...Construct momenta for ordinary branching in shower.
69418  p(n+1,1)=pt*cos(phi)
69419  p(n+1,2)=pt*sin(phi)
69420  IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
69421  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69422  p(n+1,3)=0.5d0*(pzm*(v(im,5)+v(n+1,5)-v(n+2,5))+
69423  & pem*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
69424  ELSEIF(pzm.GT.0d0) THEN
69425  p(n+1,3)=0.5d0*(v(n+2,5)-v(n+1,5)-v(im,5)+
69426  & 2d0*pem*p(n+1,4))/pzm
69427  ELSE
69428  p(n+1,3)=0d0
69429  ENDIF
69430  p(n+2,1)=-p(n+1,1)
69431  p(n+2,2)=-p(n+1,2)
69432  p(n+2,3)=pzm-p(n+1,3)
69433  p(n+2,4)=pem-p(n+1,4)
69434  IF(mstj(43).LE.2) THEN
69435  v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
69436  v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
69437  ENDIF
69438  ENDIF
69439 
69440 C...Rotate and boost daughters.
69441  IF(igm.GT.0) THEN
69442  IF(mstj(43).LE.2) THEN
69443  bex=p(igm,1)/p(igm,4)
69444  bey=p(igm,2)/p(igm,4)
69445  bez=p(igm,3)/p(igm,4)
69446  ga=p(igm,4)/p(igm,5)
69447  gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1d0+ga)-
69448  & p(im,4))
69449  ELSE
69450  bex=0d0
69451  bey=0d0
69452  bez=0d0
69453  ga=1d0
69454  gabep=0d0
69455  ENDIF
69456  ptimb=sqrt((p(im,1)+gabep*bex)**2+(p(im,2)+gabep*bey)**2)
69457  the=pyangl(p(im,3)+gabep*bez,ptimb)
69458  IF(ptimb.GT.1d-4) THEN
69459  phi=pyangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
69460  ELSE
69461  phi=0d0
69462  ENDIF
69463  DO 570 i=n+1,n+2
69464  dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
69465  & sin(the)*cos(phi)*p(i,3)
69466  dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
69467  & sin(the)*sin(phi)*p(i,3)
69468  dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
69469  dp(4)=p(i,4)
69470  dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
69471  dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
69472  p(i,1)=dp(1)+dgabp*bex
69473  p(i,2)=dp(2)+dgabp*bey
69474  p(i,3)=dp(3)+dgabp*bez
69475  p(i,4)=ga*(dp(4)+dbp)
69476  570 CONTINUE
69477  ENDIF
69478 
69479 C...Weight with azimuthal distribution, if required.
69480  IF(mazip.NE.0.OR.mazic.NE.0) THEN
69481  DO 580 j=1,3
69482  dpt(1,j)=p(im,j)
69483  dpt(2,j)=p(iau,j)
69484  dpt(3,j)=p(n+1,j)
69485  580 CONTINUE
69486  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
69487  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
69488  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
69489  DO 590 j=1,3
69490  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/max(1d-10,dpmm)
69491  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/max(1d-10,dpmm)
69492  590 CONTINUE
69493  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
69494  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
69495  IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
69496  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
69497  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
69498  IF(mazip.NE.0) THEN
69499  IF(1d0+hazip*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(hazip)))
69500  & GOTO 560
69501  ENDIF
69502  IF(mazic.NE.0) THEN
69503  IF(mazic.EQ.n+2) cad=-cad
69504  IF((1d0-hazic)*(1d0-hazic*cad)/(1d0+hazic**2-2d0*hazic*cad)
69505  & .LT.pyr(0)) GOTO 560
69506  ENDIF
69507  ENDIF
69508  ENDIF
69509 
69510 C...Azimuthal anisotropy due to interference with initial state partons.
69511  IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
69512  &k(n+2,2).EQ.21)) THEN
69513  iii=im-ns-1
69514  IF(isii(iii).GE.1) THEN
69515  iaziid=n+1
69516  IF(k(n+1,2).NE.21) iaziid=n+2
69517  IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
69518  & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
69519  theiid=pyangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
69520  IF(iii.EQ.2) theiid=paru(1)-theiid
69521  phiiid=pyangl(p(iaziid,1),p(iaziid,2))
69522  hazii=min(0.95d0,theiid/theiis(iii,isii(iii)))
69523  cad=cos(phiiid-phiiis(iii,isii(iii)))
69524  phirel=abs(phiiid-phiiis(iii,isii(iii)))
69525  IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
69526  IF((1d0-hazii)*(1d0-hazii*cad)/(1d0+hazii**2-2d0*hazii*cad)
69527  & .LT.pyr(0)) GOTO 560
69528  ENDIF
69529  ENDIF
69530 
69531 C...Continue loop over partons that may branch, until none left.
69532  IF(igm.GE.0) k(im,1)=14
69533  n=n+nep
69534  nep=2
69535  IF(n.GT.mstu(4)-mstu(32)-10) THEN
69536  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
69537  IF(mstu(21).GE.1) n=ns
69538  IF(mstu(21).GE.1) RETURN
69539  ENDIF
69540  GOTO 290
69541 
69542 C...Set information on imagined shower initiator.
69543  600 IF(npa.GE.2) THEN
69544  k(ns+1,1)=11
69545  k(ns+1,2)=94
69546  k(ns+1,3)=ip1
69547  IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
69548  k(ns+1,4)=ns+2
69549  k(ns+1,5)=ns+1+npa
69550  iim=1
69551  ELSE
69552  iim=0
69553  ENDIF
69554 
69555 C...Reconstruct string drawing information.
69556  DO 610 i=ns+1+iim,n
69557  kq=kchg(pycomp(k(i,2)),2)
69558  IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
69559  k(i,1)=1
69560  ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
69561  & iabs(k(i,2)).LE.18) THEN
69562  k(i,1)=1
69563  ELSEIF(k(i,1).LE.10) THEN
69564  k(i,4)=mstu(5)*(k(i,4)/mstu(5))
69565  k(i,5)=mstu(5)*(k(i,5)/mstu(5))
69566  ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
69567  id1=mod(k(i,4),mstu(5))
69568  IF(kq.EQ.1.AND.k(i,2).GT.0) id1=mod(k(i,4),mstu(5))+1
69569  IF(kq.EQ.2.AND.(k(id1,2).EQ.21.OR.k(id1+1,2).EQ.21).AND.
69570  & pyr(0).GT.0.5d0) id1=mod(k(i,4),mstu(5))+1
69571  id2=2*mod(k(i,4),mstu(5))+1-id1
69572  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
69573  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
69574  k(id1,4)=k(id1,4)+mstu(5)*i
69575  k(id1,5)=k(id1,5)+mstu(5)*id2
69576  k(id2,4)=k(id2,4)+mstu(5)*id1
69577  k(id2,5)=k(id2,5)+mstu(5)*i
69578  ELSE
69579  id1=mod(k(i,4),mstu(5))
69580  id2=id1+1
69581  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
69582  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
69583  IF(kq.EQ.1.OR.k(id1,1).GE.11) THEN
69584  k(id1,4)=k(id1,4)+mstu(5)*i
69585  k(id1,5)=k(id1,5)+mstu(5)*i
69586  ELSE
69587  k(id1,4)=0
69588  k(id1,5)=0
69589  ENDIF
69590  k(id2,4)=0
69591  k(id2,5)=0
69592  ENDIF
69593  610 CONTINUE
69594 
69595 C...Transformation from CM frame.
69596  IF(npa.EQ.1) THEN
69597  the=pyangl(p(ipa(1),3),sqrt(p(ipa(1),1)**2+p(ipa(1),2)**2))
69598  phi=pyangl(p(ipa(1),1),p(ipa(1),2))
69599  mstu(33)=1
69600  CALL pyrobo(ns+1,n,the,phi,0d0,0d0,0d0)
69601  ELSEIF(npa.EQ.2) THEN
69602  bex=ps(1)/ps(4)
69603  bey=ps(2)/ps(4)
69604  bez=ps(3)/ps(4)
69605  ga=ps(4)/ps(5)
69606  gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
69607  & /(1d0+ga)-p(ipa(1),4))
69608  the=pyangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
69609  & +gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
69610  phi=pyangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
69611  mstu(33)=1
69612  CALL pyrobo(ns+1,n,the,phi,bex,bey,bez)
69613  ELSE
69614  CALL pyrobo(ipa(1),ipa(npa),0d0,0d0,ps(1)/ps(4),ps(2)/ps(4),
69615  & ps(3)/ps(4))
69616  mstu(33)=1
69617  CALL pyrobo(ns+1,n,0d0,0d0,ps(1)/ps(4),ps(2)/ps(4),ps(3)/ps(4))
69618  ENDIF
69619 
69620 C...Decay vertex of shower.
69621  DO 630 i=ns+1,n
69622  DO 620 j=1,5
69623  v(i,j)=v(ip1,j)
69624  620 CONTINUE
69625  630 CONTINUE
69626 
69627 C...Delete trivial shower, else connect initiators.
69628  IF(n.LE.ns+npa+iim) THEN
69629  n=ns
69630  ELSE
69631  DO 640 ip=1,npa
69632  k(ipa(ip),1)=14
69633  k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
69634  k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
69635  k(ns+iim+ip,3)=ipa(ip)
69636  IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
69637  IF(k(ns+iim+ip,1).NE.1) THEN
69638  k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
69639  k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
69640  ENDIF
69641  640 CONTINUE
69642  ENDIF
69643 
69644  RETURN
69645  END
69646 
69647 C*********************************************************************
69648 
69649 C...PYPTFS
69650 C...Generates pT-ordered timelike final-state parton showers.
69651 
69652 C...MODE defines how to find radiators and recoilers.
69653 C... = 0 : based on colour flow between undecayed partons.
69654 C... = 1 : for IPART <= NPARTD only consider primary partons,
69655 C... whether decayed or not; else as above.
69656 C... = 2 : based on common history, whether decayed or not.
69657 C... = 3 : use (or create) MCT color information to shower partons
69658 
69659  SUBROUTINE pyptfs(MODE,PTMAX,PTMIN,PTGEN)
69660 
69661 C...Double precision and integer declarations.
69662  IMPLICIT DOUBLE PRECISION(a-h, o-z)
69663  IMPLICIT INTEGER(I-N)
69664  INTEGER PYK,PYCHGE,PYCOMP
69665 C...Parameter statement to help give large particle numbers.
69666  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
69667  &kexcit=4000000,kdimen=5000000)
69668 C...Parameter statement for maximum size of showers.
69669  parameter(maxnur=1000)
69670 C...Commonblocks.
69671  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
69672  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
69673  common/pyctag/nct,mct(4000,2)
69674  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
69675  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
69676  common/pypars/mstp(200),parp(200),msti(200),pari(200)
69677  common/pyint1/mint(400),vint(400)
69678  SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pydat2/,/pypars/,
69679  &/pyint1/
69680 C...Local arrays.
69681  dimension ipos(2*maxnur),irec(2*maxnur),iflg(2*maxnur),
69682  &iscol(2*maxnur),ischg(2*maxnur),ptsca(2*maxnur),imesav(2*maxnur),
69683  &pt2sav(2*maxnur),zsav(2*maxnur),shtsav(2*maxnur),
69684  &mesys(maxnur,0:2),psum(5),dpt(5,4)
69685 C...Statement functions.
69686  shat(i,j)=(p(i,4)+p(j,4))**2-(p(i,1)+p(j,1))**2-
69687  &(p(i,2)+p(j,2))**2-(p(i,3)+p(j,3))**2
69688 
69689 C...Initial values. Check that valid system.
69690  ptgen=0d0
69691  IF(mstj(41).NE.1.AND.mstj(41).NE.2.AND.mstj(41).NE.11.AND.
69692  &mstj(41).NE.12) RETURN
69693  IF(npart.LE.0) THEN
69694  CALL pyerrm(2,'(PYPTFS:) showering system too small')
69695  RETURN
69696  ENDIF
69697  pt2cmx=ptmax**2
69698  iord=1
69699 
69700 C...Mass thresholds and Lambda for QCD evolution.
69701  pmb=pmas(5,1)
69702  pmc=pmas(4,1)
69703  alam5=parj(81)
69704  alam4=alam5*(pmb/alam5)**(2d0/25d0)
69705  alam3=alam4*(pmc/alam4)**(2d0/27d0)
69706  pmbs=pmb**2
69707  pmcs=pmc**2
69708  alam5s=alam5**2
69709  alam4s=alam4**2
69710  alam3s=alam3**2
69711 
69712 C...Cutoff scale for QCD evolution. Starting pT2.
69713  nflav=max(0,min(5,mstj(45)))
69714  pt0c=0.5d0*parj(82)
69715  pt2cmn=max(ptmin,pt0c,1.1d0*alam3)**2
69716 
69717 C...Parameters for QED evolution.
69718  aem2pi=paru(101)/paru(2)
69719  pt0eq=0.5d0*parj(83)
69720  pt0el=0.5d0*parj(90)
69721 
69722 C...Reset. Remove irrelevant colour tags.
69723  nevol=0
69724  DO 100 j=1,4
69725  psum(j)=0d0
69726  100 CONTINUE
69727  DO 110 i=mint(84)+1,n
69728  IF(k(i,2).GT.0.AND.k(i,2).LT.6) THEN
69729  k(i,5)=0
69730  mct(i,2)=0
69731  ENDIF
69732  IF(k(i,2).LT.0.AND.k(i,2).GT.-6) THEN
69733  k(i,4)=0
69734  mct(i,1)=0
69735  ENDIF
69736  110 CONTINUE
69737  nparts=npart
69738 
69739 C...Begin loop to set up showering partons. Sum four-momenta.
69740  DO 230 ip=1,npart
69741  i=ipart(ip)
69742  IF(mode.NE.1.OR.i.GT.npartd) THEN
69743  IF(k(i,1).GT.10) GOTO 230
69744  ELSEIF(k(i,3).GT.mint(84)) THEN
69745  IF(k(i,3).GT.mint(84)+2) GOTO 230
69746  ELSE
69747  IF(k(k(i,3),3).GT.mint(83)+6) GOTO 230
69748  ENDIF
69749  DO 120 j=1,4
69750  psum(j)=psum(j)+p(i,j)
69751  120 CONTINUE
69752 
69753 C...Find colour and charge, but skip diquarks.
69754  IF(iabs(k(i,2)).GT.1000.AND.iabs(k(i,2)).LT.10000) GOTO 230
69755  kcol=isign(kchg(pycomp(k(i,2)),2),k(i,2))
69756  kcha=isign(kchg(pycomp(k(i,2)),1),k(i,2))
69757 
69758 C...QUARKONIA++
69759  IF (iabs(k(i,2)).GE.9900101.AND.iabs(k(i,2)).LE.9910555) THEN
69760  IF (mstp(148).GE.1) THEN
69761 C...Temporary: force no radiation from quarkonia since not yet treated
69762  CALL pyerrm(11,'(PYPTFS:) quarkonia showers not yet in'
69763  & //' PYPTFS, switched off')
69764  CALL pygive('MSTP(148)=0')
69765  ENDIF
69766  IF (mstp(148).EQ.0) THEN
69767 C...Skip quarkonia if radiation switched off
69768  GOTO 230
69769  ENDIF
69770  ENDIF
69771 C...QUARKONIA--
69772 
69773 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69774 C...(only intended for studying the effects of switching such rad on/off)
69775  IF (mstj(39).GT.0.AND.iabs(k(i,2)).EQ.mstj(39)) THEN
69776  GOTO 230
69777  ENDIF
69778 
69779 C...Either colour or anticolour charge radiates; for gluon both.
69780  DO 180 jsgcol=1,-1,-2
69781  IF(kcol.EQ.jsgcol.OR.kcol.EQ.2) THEN
69782  jcol=4+(1-jsgcol)/2
69783  jcolr=9-jcol
69784 
69785 C...Basic info about radiating parton.
69786  nevol=nevol+1
69787  ipos(nevol)=i
69788  iflg(nevol)=0
69789  iscol(nevol)=jsgcol
69790  ischg(nevol)=0
69791  ptsca(nevol)=ptpart(ip)
69792 
69793 C...Begin search for colour recoiler when MODE = 0 or 1.
69794  IF(mode.LE.1) THEN
69795 C...Find sister with matching anticolour to the radiating parton.
69796  irold=i
69797  irnew=k(irold,jcol)/mstu(5)
69798  move=1
69799 
69800 C...Skip radiation off loose colour ends.
69801  130 IF(irnew.EQ.0) THEN
69802  nevol=nevol-1
69803  GOTO 180
69804 
69805 C...Optionally skip radiation on dipole to beam remnant.
69806  ELSEIF(mstp(72).LE.1.AND.irnew.GT.mint(53)) THEN
69807  nevol=nevol-1
69808  GOTO 180
69809 
69810 C...For now always skip radiation on dipole to junction.
69811  ELSEIF(k(irnew,2).EQ.88) THEN
69812  nevol=nevol-1
69813  GOTO 180
69814 
69815 C...For MODE=1: if reached primary then done.
69816  ELSEIF(mode.EQ.1.AND.irnew.GT.mint(84)+2.AND.
69817  & irnew.LE.npartd) THEN
69818 
69819 C...If sister stable and points back then done.
69820  ELSEIF(move.EQ.1.AND.k(irnew,jcolr)/mstu(5).EQ.irold)
69821  & THEN
69822  IF(k(irnew,1).LT.10) THEN
69823 
69824 C...If sister unstable then go to her daughter.
69825  ELSE
69826  irold=irnew
69827  irnew=mod(k(irnew,jcolr),mstu(5))
69828  move=2
69829  GOTO 130
69830  ENDIF
69831 
69832 C...If found mother then look for aunt.
69833  ELSEIF(move.EQ.1.AND.mod(k(irnew,jcol),mstu(5)).EQ.
69834  & irold) THEN
69835  irold=irnew
69836  irnew=k(irold,jcol)/mstu(5)
69837  GOTO 130
69838 
69839 C...If daughter stable then done.
69840  ELSEIF(move.EQ.2.AND.k(irnew,jcolr)/mstu(5).EQ.irold)
69841  & THEN
69842  IF(k(irnew,1).LT.10) THEN
69843 
69844 C...If daughter unstable then go to granddaughter.
69845  ELSE
69846  irold=irnew
69847  irnew=mod(k(irnew,jcolr),mstu(5))
69848  move=2
69849  GOTO 130
69850  ENDIF
69851 
69852 C...If daughter points to another daughter then done or move up.
69853  ELSEIF(move.EQ.2.AND.mod(k(irnew,jcol),mstu(5)).EQ.
69854  & irold) THEN
69855  IF(k(irnew,1).LT.10) THEN
69856  ELSE
69857  irold=irnew
69858  irnew=k(irnew,jcol)/mstu(5)
69859  move=1
69860  GOTO 130
69861  ENDIF
69862  ENDIF
69863 
69864 C...Begin search for colour recoiler when MODE = 2.
69865  ELSEIF (mode.EQ.2) THEN
69866  irold=i
69867  irnew=k(irold,jcol)/mstu(5)
69868  140 IF (irnew.LE.0.OR.irnew.GT.n) THEN
69869 C...If no color partner found, pick at random among other primaries
69870 C...(e.g., when the color line is traced all the way to the beam)
69871  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
69872  irnew=ipart(1+mod(ip+istep-1,npart))
69873  ELSEIF(k(irnew,jcolr)/mstu(5).NE.irold) THEN
69874 C...Step up to mother if radiating parton already branched.
69875  IF(k(irnew,2).EQ.k(irold,2)) THEN
69876  irold=irnew
69877  irnew=k(irold,jcol)/mstu(5)
69878  GOTO 140
69879 C...Pick sister by history if no anticolour available.
69880  ELSE
69881  IF(irold.GT.1.AND.k(irold-1,3).EQ.k(irold,3)) THEN
69882  irnew=irold-1
69883  ELSEIF(irold.LT.n.AND.k(irold+1,3).EQ.k(irold,3))
69884  & THEN
69885  irnew=irold+1
69886 C...Last resort: pick at random among other primaries.
69887  ELSE
69888  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
69889  irnew=ipart(1+mod(ip+istep-1,npart))
69890  ENDIF
69891  ENDIF
69892  ENDIF
69893 C...Trace down if sister branched.
69894  150 IF(k(irnew,1).GT.10) THEN
69895  irtmp=mod(k(irnew,jcolr),mstu(5))
69896 C...If no correct color-daughter found, swap.
69897  IF (irtmp.EQ.0) THEN
69898  jcol=9-jcol
69899  jcolr=9-jcolr
69900  irtmp=mod(k(irnew,jcolr),mstu(5))
69901  ENDIF
69902  irnew=irtmp
69903  GOTO 150
69904  ENDIF
69905  ELSEIF (mode.EQ.3) THEN
69906 C...The following will add MCT colour tracing for unprepped events
69907 C...If not done, trace Les Houches colour tags for this dipole
69908  jcolsv=jcol
69909  IF (mct(i,jcol-3).EQ.0) THEN
69910 C...Special end code -1 : trace to color partner or 0, return in IEND
69911  iend=-1
69912  CALL pycttr(i,jcol,iend)
69913 C...Clean up mother/daughter 'read' tags set by PYCTTR
69914  jcol=jcolsv
69915  DO 160 ir=1,n
69916  k(ir,4)=mod(k(ir,4),mstu(5)**2)
69917  k(ir,5)=mod(k(ir,5),mstu(5)**2)
69918  mct(ir,1)=0
69919  mct(ir,2)=0
69920  160 CONTINUE
69921  ELSE
69922  iend=0
69923  DO 170 ir=1,n
69924  IF (k(ir,1).GT.0.AND.mct(ir,6-jcol).EQ.mct(i,jcol-3))
69925  & iend=ir
69926  170 CONTINUE
69927  ENDIF
69928 C...If no color partner, then we hit beam
69929  IF (iend.LE.0) THEN
69930 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
69931  IF (mstp(72).LE.1) THEN
69932  nevol=nevol-1
69933  GOTO 180
69934  ELSE
69935 C...Else try a random partner
69936  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
69937  irnew=ipart(1+mod(ip+istep-1,npart))
69938  ENDIF
69939  ELSE
69940 C...Else save recoiling colour partner
69941  irnew=iend
69942  ENDIF
69943 
69944  ENDIF
69945 
69946 C...Now found other end of colour dipole.
69947  irec(nevol)=irnew
69948  ENDIF
69949  180 CONTINUE
69950 
69951 C...Also electrical charge may radiate; so far only quarks and leptons.
69952  IF((mstj(41).EQ.2.OR.mstj(41).EQ.12).AND.kcha.NE.0.AND.
69953  & iabs(k(i,2)).LE.18) THEN
69954 
69955 C...Basic info about radiating parton.
69956  nevol=nevol+1
69957  ipos(nevol)=i
69958  iflg(nevol)=0
69959  iscol(nevol)=0
69960  ischg(nevol)=kcha
69961  ptsca(nevol)=ptpart(ip)
69962 
69963 C...Pick nearest (= smallest invariant mass) charged particle
69964 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
69965  IF(mode.LE.1) THEN
69966  irnew=0
69967  pm2min=vint(2)
69968  DO 190 ip2=1,npart+n-mint(53)
69969  IF(ip2.EQ.ip) GOTO 190
69970  IF(ip2.LE.npart) THEN
69971  i2=ipart(ip2)
69972  IF(mode.NE.1.OR.i2.GT.npartd) THEN
69973  IF(k(i2,1).GT.10) GOTO 190
69974  ELSEIF(k(i2,3).GT.mint(84)) THEN
69975  IF(k(i2,3).GT.mint(84)+2) GOTO 190
69976  ELSE
69977  IF(k(k(i2,3),3).GT.mint(83)+6) GOTO 190
69978  ENDIF
69979  ELSE
69980  i2=mint(53)+ip2-npart
69981  ENDIF
69982  IF(kchg(pycomp(k(i2,2)),1).EQ.0) GOTO 190
69983  pm2inv=(p(i,4)+p(i2,4))**2-(p(i,1)+p(i2,1))**2-
69984  & (p(i,2)+p(i2,2))**2-(p(i,3)+p(i2,3))**2
69985  IF(pm2inv.LT.pm2min) THEN
69986  irnew=i2
69987  pm2min=pm2inv
69988  ENDIF
69989  190 CONTINUE
69990  IF(irnew.EQ.0) THEN
69991  nevol=nevol-1
69992  GOTO 230
69993  ENDIF
69994 
69995 C...Begin search for charge recoiler when MODE = 2.
69996  ELSE
69997  irold=i
69998 C...Pick sister by history; step up if parton already branched.
69999  200 IF(k(irold,3).GT.0.AND.k(k(irold,3),2).EQ.k(irold,2)) THEN
70000  irold=k(irold,3)
70001  GOTO 200
70002  ENDIF
70003  IF(irold.GT.1.AND.k(irold-1,3).EQ.k(irold,3)) THEN
70004  irnew=irold-1
70005  ELSEIF(irold.LT.n.AND.k(irold+1,3).EQ.k(irold,3)) THEN
70006  irnew=irold+1
70007 C...Last resort: pick at random among other primaries.
70008  ELSE
70009  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
70010  irnew=ipart(1+mod(ip+istep-1,npart))
70011  ENDIF
70012 C...Trace down if sister branched.
70013  210 IF(k(irnew,1).GT.10) THEN
70014  DO 220 ir=irnew+1,n
70015  IF(k(ir,3).EQ.irnew.AND.k(ir,2).EQ.k(irnew,2)) THEN
70016  irnew=ir
70017  GOTO 210
70018  ENDIF
70019  220 CONTINUE
70020  ENDIF
70021  ENDIF
70022  irec(nevol)=irnew
70023  ENDIF
70024 
70025 C...End loop to set up showering partons. System invariant mass.
70026  230 CONTINUE
70027  IF(nevol.LE.0) RETURN
70028  IF (mode.EQ.3.AND.nevol.LE.1) RETURN
70029  psum(5)=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
70030 
70031 C...Check if 3-jet matrix elements to be used.
70032  m3jc=0
70033  alpha=0.5d0
70034  nmesys=0
70035  IF(mstj(47).GE.1) THEN
70036 
70037 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70038  kfsrce=0
70039  ipart1=k(ipart(1),3)
70040  ipart2=k(ipart(2),3)
70041  240 IF(ipart1.EQ.ipart2.AND.ipart1.GT.0) THEN
70042  kfsrce=iabs(k(ipart1,2))
70043  ELSEIF(ipart1.GT.ipart2.AND.ipart2.GT.0) THEN
70044  ipart1=k(ipart1,3)
70045  GOTO 240
70046  ELSEIF(ipart2.GT.ipart1.AND.ipart1.GT.0) THEN
70047  ipart2=k(ipart2,3)
70048  GOTO 240
70049  ENDIF
70050  itypes=0
70051  IF(kfsrce.GE.1.AND.kfsrce.LE.8) itypes=1
70052  IF(kfsrce.GE.ksusy1+1.AND.kfsrce.LE.ksusy1+8) itypes=2
70053  IF(kfsrce.GE.ksusy2+1.AND.kfsrce.LE.ksusy2+8) itypes=2
70054  IF(kfsrce.GE.21.AND.kfsrce.LE.24) itypes=3
70055  IF(kfsrce.GE.32.AND.kfsrce.LE.34) itypes=3
70056  IF(kfsrce.EQ.25.OR.(kfsrce.GE.35.AND.kfsrce.LE.37)) itypes=4
70057  IF(kfsrce.GE.ksusy1+22.AND.kfsrce.LE.ksusy1+37) itypes=5
70058  IF(kfsrce.EQ.ksusy1+21) itypes=6
70059 
70060 C...Identify two primary showerers.
70061  kfla1=iabs(k(ipart(1),2))
70062  itype1=0
70063  IF(kfla1.GE.1.AND.kfla1.LE.8) itype1=1
70064  IF(kfla1.GE.ksusy1+1.AND.kfla1.LE.ksusy1+8) itype1=2
70065  IF(kfla1.GE.ksusy2+1.AND.kfla1.LE.ksusy2+8) itype1=2
70066  IF(kfla1.GE.21.AND.kfla1.LE.24) itype1=3
70067  IF(kfla1.GE.32.AND.kfla1.LE.34) itype1=3
70068  IF(kfla1.EQ.25.OR.(kfla1.GE.35.AND.kfla1.LE.37)) itype1=4
70069  IF(kfla1.GE.ksusy1+22.AND.kfla1.LE.ksusy1+37) itype1=5
70070  IF(kfla1.EQ.ksusy1+21) itype1=6
70071  kfla2=iabs(k(ipart(2),2))
70072  itype2=0
70073  IF(kfla2.GE.1.AND.kfla2.LE.8) itype2=1
70074  IF(kfla2.GE.ksusy1+1.AND.kfla2.LE.ksusy1+8) itype2=2
70075  IF(kfla2.GE.ksusy2+1.AND.kfla2.LE.ksusy2+8) itype2=2
70076  IF(kfla2.GE.21.AND.kfla2.LE.24) itype2=3
70077  IF(kfla2.GE.32.AND.kfla2.LE.34) itype2=3
70078  IF(kfla2.EQ.25.OR.(kfla2.GE.35.AND.kfla2.LE.37)) itype2=4
70079  IF(kfla2.GE.ksusy1+22.AND.kfla2.LE.ksusy1+37) itype2=5
70080  IF(kfla2.EQ.ksusy1+21) itype2=6
70081 
70082 C...Order of showerers. Presence of gluino.
70083  itypmn=min(itype1,itype2)
70084  itypmx=max(itype1,itype2)
70085  iord=1
70086  IF(itype1.GT.itype2) iord=2
70087  iglui=0
70088  IF(itype1.EQ.6.OR.itype2.EQ.6) iglui=1
70089 
70090 C...Require exactly two primary showerers for ME corrections.
70091  nprim=0
70092  IF(ipart1.GT.0) THEN
70093  DO 250 i=1,n
70094  IF(k(i,3).EQ.ipart1.AND.k(i,2).NE.k(ipart1,2)) nprim=nprim+1
70095  250 CONTINUE
70096  ENDIF
70097  IF(nprim.NE.2) THEN
70098 
70099 C...Predetermined and default matrix element kinds.
70100  ELSEIF(mstj(38).NE.0) THEN
70101  m3jc=mstj(38)
70102  alpha=parj(80)
70103  mstj(38)=0
70104  ELSEIF(mstj(47).GE.6) THEN
70105  m3jc=mstj(47)
70106  ELSE
70107  iclass=1
70108  icombi=4
70109 
70110 C...Vector/axial vector -> q + qbar; q -> q + V.
70111  IF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.(itypes.EQ.0.OR.
70112  & itypes.EQ.3)) THEN
70113  iclass=2
70114  IF(kfsrce.EQ.21.OR.kfsrce.EQ.22) THEN
70115  icombi=1
70116  ELSEIF(kfsrce.EQ.23.OR.(kfsrce.EQ.0.AND.
70117  & k(ipart(1),2)+k(ipart(2),2).EQ.0)) THEN
70118 C...gamma*/Z0: assume e+e- initial state if unknown.
70119  ei=-1d0
70120  IF(kfsrce.EQ.23) THEN
70121  iannfl=ipart1
70122  IF(k(iannfl,2).EQ.23) iannfl=k(iannfl,3)
70123  IF(iannfl.GT.0) THEN
70124  IF(k(iannfl,2).EQ.23) iannfl=k(iannfl,3)
70125  ENDIF
70126  IF(iannfl.NE.0) THEN
70127  kannfl=iabs(k(iannfl,2))
70128  IF(kannfl.GE.1.AND.kannfl.LE.18) ei=kchg(kannfl,1)/3d0
70129  ENDIF
70130  ENDIF
70131  ai=sign(1d0,ei+0.1d0)
70132  vi=ai-4d0*ei*paru(102)
70133  ef=kchg(kfla1,1)/3d0
70134  af=sign(1d0,ef+0.1d0)
70135  vf=af-4d0*ef*paru(102)
70136  xwc=1d0/(16d0*paru(102)*(1d0-paru(102)))
70137  sh=psum(5)**2
70138  sqmz=pmas(23,1)**2
70139  sqwz=psum(5)*pmas(23,2)
70140  sbwz=1d0/((sh-sqmz)**2+sqwz**2)
70141  vect=ei**2*ef**2+2d0*ei*vi*ef*vf*xwc*sh*(sh-sqmz)*sbwz+
70142  & (vi**2+ai**2)*vf**2*xwc**2*sh**2*sbwz
70143  axiv=(vi**2+ai**2)*af**2*xwc**2*sh**2*sbwz
70144  icombi=3
70145  alpha=vect/(vect+axiv)
70146  ELSEIF(kfsrce.EQ.24.OR.kfsrce.EQ.0) THEN
70147  icombi=4
70148  ENDIF
70149 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70150  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.5) THEN
70151  iclass=2
70152  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
70153  & itypes.EQ.1)) THEN
70154  iclass=3
70155 
70156 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70157  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.4) THEN
70158  iclass=4
70159  IF(kfsrce.EQ.25.OR.kfsrce.EQ.35.OR.kfsrce.EQ.37) THEN
70160  icombi=1
70161  ELSEIF(kfsrce.EQ.36) THEN
70162  icombi=2
70163  ENDIF
70164  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
70165  & itypes.EQ.1)) THEN
70166  iclass=5
70167 
70168 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70169  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
70170  & itypes.EQ.3)) THEN
70171  iclass=6
70172  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
70173  & itypes.EQ.2)) THEN
70174  iclass=7
70175  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.itypes.EQ.4) THEN
70176  iclass=8
70177  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
70178  & itypes.EQ.2)) THEN
70179  iclass=9
70180 
70181 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70182  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
70183  & itypes.EQ.5)) THEN
70184  iclass=10
70185  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
70186  & itypes.EQ.2)) THEN
70187  iclass=11
70188  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
70189  & itypes.EQ.1)) THEN
70190  iclass=12
70191 
70192 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70193  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.itypes.EQ.6) THEN
70194  iclass=13
70195  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
70196  & itypes.EQ.2)) THEN
70197  iclass=14
70198  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
70199  & itypes.EQ.1)) THEN
70200  iclass=15
70201 
70202 C...g -> ~g + ~g (eikonal approximation).
70203  ELSEIF(itypmn.EQ.6.AND.itypmx.EQ.6.AND.itypes.EQ.0) THEN
70204  iclass=16
70205  ENDIF
70206  m3jc=5*iclass+icombi
70207  ENDIF
70208 
70209 C...Store pair that together define matrix element treatment.
70210  IF(m3jc.NE.0) THEN
70211  nmesys=1
70212  mesys(nmesys,0)=m3jc
70213  mesys(nmesys,1)=ipart(1)
70214  mesys(nmesys,2)=ipart(2)
70215  ENDIF
70216 
70217 C...Store qqbar or l+l- pairs for QED radiation.
70218  IF(kfla1.LE.18.AND.kfla2.LE.18) THEN
70219  nmesys=nmesys+1
70220  mesys(nmesys,0)=101
70221  IF(k(ipart(1),2)+k(ipart(2),2).EQ.0) mesys(nmesys,0)=102
70222  mesys(nmesys,1)=ipart(1)
70223  mesys(nmesys,2)=ipart(2)
70224  ENDIF
70225 
70226 C...Store other qqbar/l+l- pairs from g/gamma branchings.
70227  DO 290 i1=1,n
70228  IF(k(i1,1).GT.10.OR.iabs(k(i1,2)).GT.18) GOTO 290
70229  i1m=k(i1,3)
70230  260 IF(i1m.GT.0.AND.k(i1m,2).EQ.k(i1,2)) THEN
70231  i1m=k(i1m,3)
70232  GOTO 260
70233  ENDIF
70234 C...Move up this check to avoid out-of-bounds.
70235  IF(i1m.EQ.0) GOTO 290
70236  IF(k(i1m,2).NE.21.AND.k(i1m,2).NE.22) GOTO 290
70237  DO 280 i2=i1+1,n
70238  IF(k(i2,1).GT.10.OR.k(i2,2)+k(i1,2).NE.0) GOTO 280
70239  i2m=k(i2,3)
70240  270 IF(i2m.GT.0.AND.k(i2m,2).EQ.k(i2,2)) THEN
70241  i2m=k(i2m,3)
70242  GOTO 270
70243  ENDIF
70244  IF(i1m.EQ.i2m.AND.i1m.GT.0) THEN
70245  nmesys=nmesys+1
70246  mesys(nmesys,0)=66
70247  mesys(nmesys,1)=i1
70248  mesys(nmesys,2)=i2
70249  nmesys=nmesys+1
70250  mesys(nmesys,0)=102
70251  mesys(nmesys,1)=i1
70252  mesys(nmesys,2)=i2
70253  ENDIF
70254  280 CONTINUE
70255  290 CONTINUE
70256  ENDIF
70257 
70258 C..Loopback point for counting number of emissions.
70259  ngen=0
70260  300 ngen=ngen+1
70261 
70262 C...Begin loop to evolve all existing partons, if required.
70263  310 imx=0
70264  pt2mx=0d0
70265  DO 380 ievol=1,nevol
70266  IF(iflg(ievol).EQ.0) THEN
70267 
70268 C...Basic info on radiator and recoil.
70269  i=ipos(ievol)
70270  ir=irec(ievol)
70271  sht=shat(i,ir)
70272  pm2i=p(i,5)**2
70273  pm2r=p(ir,5)**2
70274 
70275 C...Invariant mass of "dipole".Starting value for pT evolution.
70276  shtcor=(sqrt(sht)-p(ir,5))**2-pm2i
70277  pt2=min(pt2cmx,0.25d0*shtcor,ptsca(ievol)**2)
70278 
70279 C...Case of evolution by QCD branching.
70280  IF(iscol(ievol).NE.0) THEN
70281 
70282 C...Parton-by-parton maximum scale from initial conditions.
70283  IF(mstp(72).EQ.0) THEN
70284  DO 320 iprt=1,nparts
70285  IF(ir.EQ.ipart(iprt)) pt2=min(pt2,ptpart(iprt)**2)
70286  320 CONTINUE
70287  ENDIF
70288 
70289 C...If kinematically impossible then do not evolve.
70290  IF(pt2.LT.pt2cmn) THEN
70291  iflg(ievol)=-1
70292  GOTO 380
70293  ENDIF
70294 
70295 C...Check if part of system for which ME corrections should be applied.
70296  imesys=0
70297  DO 330 ime=1,nmesys
70298  IF((i.EQ.mesys(ime,1).OR.i.EQ.mesys(ime,2)).AND.
70299  & mesys(ime,0).LT.100) imesys=ime
70300  330 CONTINUE
70301 
70302 C...Special flag for colour octet states.
70303 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70304  moct=0
70305  IF(k(i,2).EQ.21) moct=1
70306 C...SUSY gluino
70307  IF(k(i,2).EQ.ksusy1+21) moct=2
70308 C...UED KK gluon
70309  IF(k(i,2).EQ.5100021) moct=2
70310 C...QUARKONIA++
70311  IF(mstp(148).GE.1.AND.iabs(k(i,2)).EQ.9900101.AND.
70312  & iabs(k(i,2)).LE.9910555) moct=2
70313 C...QUARKONIA--
70314 
70315 
70316 C...Upper estimate for matrix element weighting and colour factor.
70317 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70318  wtpsgl=2d0
70319  colfac=4d0/3d0
70320  IF(moct.GE.1) colfac=3d0/2d0
70321  IF(iglui.EQ.1.AND.imesys.EQ.1.AND.moct.EQ.0) colfac=3d0
70322  wtpsqq=0.5d0*0.5d0*nflav
70323 
70324 C...Determine overestimated z range: switch at c and b masses.
70325  340 izrg=1
70326  pt2mne=pt2cmn
70327  b0=27d0/6d0
70328  alams=alam3s
70329  IF(pt2.GT.1.01d0*pmcs) THEN
70330  izrg=2
70331  pt2mne=pmcs
70332  b0=25d0/6d0
70333  alams=alam4s
70334  ENDIF
70335  IF(pt2.GT.1.01d0*pmbs) THEN
70336  izrg=3
70337  pt2mne=pmbs
70338  b0=23d0/6d0
70339  alams=alam5s
70340  ENDIF
70341  zmncut=0.5d0-sqrt(max(0d0,0.25d0-pt2mne/shtcor))
70342  IF(zmncut.LT.1d-8) zmncut=pt2mne/shtcor
70343 
70344 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70345  evemgl=wtpsgl*colfac*log(1d0/zmncut-1d0)/b0
70346  evcoef=evemgl
70347  IF(moct.EQ.1) THEN
70348  evemqq=wtpsqq*(1d0-2d0*zmncut)/b0
70349  evcoef=evcoef+evemqq
70350  ENDIF
70351 
70352 C...Pick pT2 (in overestimated z range).
70353  350 pt2=alams*(pt2/alams)**(pyr(0)**(1d0/evcoef))
70354 
70355 C...Loopback if crossed c/b mass thresholds.
70356  IF(izrg.EQ.3.AND.pt2.LT.pmbs) THEN
70357  pt2=pmbs
70358  GOTO 340
70359  ENDIF
70360  IF(izrg.EQ.2.AND.pt2.LT.pmcs) THEN
70361  pt2=pmcs
70362  GOTO 340
70363  ENDIF
70364 
70365 C...Finish if below lower cutoff.
70366  IF(pt2.LT.pt2cmn) THEN
70367  iflg(ievol)=-1
70368  GOTO 380
70369  ENDIF
70370 
70371 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70372 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70373  iflag=1
70374  IF(moct.EQ.1.AND.evemgl.LT.pyr(0)*evcoef) iflag=2
70375 
70376 C...Pick z: dz/(1-z) or dz.
70377  IF(iflag.EQ.1) THEN
70378  z=1d0-zmncut*(1d0/zmncut-1d0)**pyr(0)
70379  ELSE
70380  z=zmncut+pyr(0)*(1d0-2d0*zmncut)
70381  ENDIF
70382 
70383 C...Loopback if outside allowed range for given pT2.
70384  zmnnow=0.5d0-sqrt(max(0d0,0.25d0-pt2/shtcor))
70385  IF(zmnnow.LT.1d-8) zmnnow=pt2/shtcor
70386  IF(z.LE.zmnnow.OR.z.GE.1d0-zmnnow) GOTO 350
70387  pm2=pm2i+pt2/(z*(1d0-z))
70388  IF(z*(1d0-z).LE.pm2*sht/(sht+pm2-pm2r)**2) GOTO 350
70389 
70390 C...No weighting for primary partons; to be done later on.
70391  IF(imesys.GT.0) THEN
70392 
70393 C...Weighting of q->qg/X->Xg branching.
70394  ELSEIF(iflag.EQ.1.AND.moct.NE.1) THEN
70395  IF(1d0+z**2.LT.wtpsgl*pyr(0)) GOTO 350
70396 
70397 C...Weighting of g->gg branching.
70398  ELSEIF(iflag.EQ.1) THEN
70399  IF(1d0+z**3.LT.wtpsgl*pyr(0)) GOTO 350
70400 
70401 C...Flavour choice and weighting of g->qqbar branching.
70402  ELSE
70403  kfq=min(5,1+int(nflav*pyr(0)))
70404  pmq=pmas(kfq,1)
70405  rootqq=sqrt(max(0d0,1d0-4d0*pmq**2/pm2))
70406  wtme=rootqq*(z**2+(1d0-z)**2)
70407  IF(wtme.LT.pyr(0)) GOTO 350
70408  iflag=10+kfq
70409  ENDIF
70410 
70411 C...Case of evolution by QED branching.
70412  ELSEIF(ischg(ievol).NE.0) THEN
70413 
70414 C...If kinematically impossible then do not evolve.
70415  pt2emn=pt0eq**2
70416  IF(iabs(k(i,2)).GT.10) pt2emn=pt0el**2
70417  IF(pt2.LT.pt2emn) THEN
70418  iflg(ievol)=-1
70419  GOTO 380
70420  ENDIF
70421 
70422 C...Check if part of system for which ME corrections should be applied.
70423  imesys=0
70424  DO 360 ime=1,nmesys
70425  IF((i.EQ.mesys(ime,1).OR.i.EQ.mesys(ime,2)).AND.
70426  & mesys(ime,0).GT.100) imesys=ime
70427  360 CONTINUE
70428 
70429 C...Charge. Matrix element weighting factor.
70430  chg=ischg(ievol)/3d0
70431  wtpsga=2d0
70432 
70433 C...Determine overestimated z range. Find evolution coefficient.
70434  zmncut=0.5d0-sqrt(max(0d0,0.25d0-pt2emn/shtcor))
70435  IF(zmncut.LT.1d-8) zmncut=pt2emn/shtcor
70436  evcoef=aem2pi*chg**2*wtpsga*log(1d0/zmncut-1d0)
70437 
70438 C...Pick pT2 (in overestimated z range).
70439  370 pt2=pt2*pyr(0)**(1d0/evcoef)
70440 
70441 C...Finish if below lower cutoff.
70442  IF(pt2.LT.pt2emn) THEN
70443  iflg(ievol)=-1
70444  GOTO 380
70445  ENDIF
70446 
70447 C...Pick z: dz/(1-z).
70448  z=1d0-zmncut*(1d0/zmncut-1d0)**pyr(0)
70449 
70450 C...Loopback if outside allowed range for given pT2.
70451  zmnnow=0.5d0-sqrt(max(0d0,0.25d0-pt2/shtcor))
70452  IF(zmnnow.LT.1d-8) zmnnow=pt2/shtcor
70453  IF(z.LE.zmnnow.OR.z.GE.1d0-zmnnow) GOTO 370
70454  pm2=pm2i+pt2/(z*(1d0-z))
70455  IF(z*(1d0-z).LE.pm2*sht/(sht+pm2-pm2r)**2) GOTO 370
70456 
70457 C...Weighting by branching kernel, except if ME weighting later.
70458  IF(imesys.EQ.0) THEN
70459  IF(1d0+z**2.LT.wtpsga*pyr(0)) GOTO 370
70460  ENDIF
70461  iflag=3
70462  ENDIF
70463 
70464 C...Save acceptable branching.
70465  iflg(ievol)=iflag
70466  imesav(ievol)=imesys
70467  pt2sav(ievol)=pt2
70468  zsav(ievol)=z
70469  shtsav(ievol)=sht
70470  ENDIF
70471 
70472 C...Check if branching has highest pT.
70473  IF(iflg(ievol).GE.1.AND.pt2sav(ievol).GT.pt2mx) THEN
70474  imx=ievol
70475  pt2mx=pt2sav(ievol)
70476  ENDIF
70477  380 CONTINUE
70478 
70479 C...Finished if no more branchings to be done.
70480  IF(imx.EQ.0) GOTO 500
70481 
70482 C...Restore info on hardest branching to be processed.
70483  i=ipos(imx)
70484  ir=irec(imx)
70485  kcol=iscol(imx)
70486  kcha=ischg(imx)
70487  imesys=imesav(imx)
70488  pt2=pt2sav(imx)
70489  z=zsav(imx)
70490  sht=shtsav(imx)
70491  pm2i=p(i,5)**2
70492  pm2r=p(ir,5)**2
70493  pm2=pm2i+pt2/(z*(1d0-z))
70494 
70495 C...Special flag for colour octet states.
70496  moct=0
70497  IF(k(i,2).EQ.21) moct=1
70498  IF(k(i,2).EQ.ksusy1+21) moct=2
70499  IF(k(i,2).EQ.5100021) moct=2
70500 C...QUARKONIA++
70501  IF(mstp(148).GE.1.AND.iabs(k(i,2)).GE.9900101.AND.
70502  & iabs(k(i,2)).LE.9910555) moct=2
70503 C...QUARKONIA--
70504 
70505 C...Restore further info for g->qqbar branching.
70506  kfq=0
70507  IF(iflg(imx).GT.10) THEN
70508  kfq=iflg(imx)-10
70509  pmq=pmas(kfq,1)
70510  rootqq=sqrt(max(0d0,1d0-4d0*pmq**2/pm2))
70511  ENDIF
70512 
70513 C...For branching g include azimuthal asymmetries from polarization.
70514  asypol=0d0
70515  IF(moct.EQ.1.AND.mod(mstj(46),2).EQ.1) THEN
70516 C...Trace grandmother via intermediate recoil copies.
70517  kfgm=0
70518  im=i
70519  390 IF(k(im,3).NE.k(im-1,3).AND.k(im,3).NE.k(im+1,3).AND.
70520  & k(im,3).GT.0) THEN
70521  im=k(im,3)
70522  IF(im.GT.mint(84)) GOTO 390
70523  ENDIF
70524  igm=k(im,3)
70525  IF(igm.GT.mint(84).AND.igm.LT.im.AND.im.LE.i)
70526  & kfgm=iabs(k(igm,2))
70527 C...Define approximate energy sharing by identifying aunt.
70528  iau=im+1
70529  IF(iau.GT.n-3.OR.k(iau,3).NE.igm) iau=im-1
70530  IF(kfgm.NE.0.AND.(kfgm.LE.6.OR.kfgm.EQ.21)) THEN
70531  zold=p(im,4)/(p(im,4)+p(iau,4))
70532 C...Coefficient from gluon production.
70533  IF(kfgm.LE.6) THEN
70534  asypol=2d0*(1d0-zold)/(1d0+(1d0-zold)**2)
70535  ELSE
70536  asypol=((1d0-zold)/(1d0-zold*(1d0-zold)))**2
70537  ENDIF
70538 C...Coefficient from gluon decay.
70539  IF(kfq.EQ.0) THEN
70540  asypol=asypol*(z*(1d0-z)/(1d0-z*(1d0-z)))**2
70541  ELSE
70542  asypol=-asypol*2d0*z*(1d0-z)/(1d0-2d0*z*(1d0-z))
70543  ENDIF
70544  ENDIF
70545  ENDIF
70546 
70547 C...Create new slots for branching products and recoil.
70548  inew=n+1
70549  ignew=n+2
70550  irnew=n+3
70551  n=n+3
70552 
70553 C...Set status, flavour and mother of new ones.
70554  k(inew,1)=k(i,1)
70555  k(ignew,1)=3
70556  IF(kcha.NE.0) k(ignew,1)=1
70557  k(irnew,1)=k(ir,1)
70558  IF(kfq.EQ.0) THEN
70559  k(inew,2)=k(i,2)
70560  k(ignew,2)=21
70561  IF(kcha.NE.0) k(ignew,2)=22
70562  ELSE
70563  k(inew,2)=-isign(kfq,kcol)
70564  k(ignew,2)=-k(inew,2)
70565  ENDIF
70566  k(irnew,2)=k(ir,2)
70567  k(inew,3)=i
70568  k(ignew,3)=i
70569  k(irnew,3)=ir
70570 
70571 C...Find rest frame and angles of branching+recoil.
70572  DO 400 j=1,5
70573  p(inew,j)=p(i,j)
70574  p(ignew,j)=0d0
70575  p(irnew,j)=p(ir,j)
70576  400 CONTINUE
70577  betax=(p(inew,1)+p(irnew,1))/(p(inew,4)+p(irnew,4))
70578  betay=(p(inew,2)+p(irnew,2))/(p(inew,4)+p(irnew,4))
70579  betaz=(p(inew,3)+p(irnew,3))/(p(inew,4)+p(irnew,4))
70580  CALL pyrobo(inew,irnew,0d0,0d0,-betax,-betay,-betaz)
70581  phi=pyangl(p(inew,1),p(inew,2))
70582  theta=pyangl(p(inew,3),sqrt(p(inew,1)**2+p(inew,2)**2))
70583 
70584 C...Derive kinematics of branching: generics (like g->gg).
70585  DO 410 j=1,4
70586  p(inew,j)=0d0
70587  p(irnew,j)=0d0
70588  410 CONTINUE
70589  pem=0.5d0*(sht+pm2-pm2r)/sqrt(sht)
70590  pzm=0.5d0*sqrt(max(0d0,(sht-pm2-pm2r)**2-4d0*pm2*pm2r)/sht)
70591  pt2cor=pm2*(pem**2*z*(1d0-z)-0.25d0*pm2)/pzm**2
70592  ptcor=sqrt(max(0d0,pt2cor))
70593  pzn=(pem**2*z-0.5d0*pm2)/pzm
70594  pzg=(pem**2*(1d0-z)-0.5d0*pm2)/pzm
70595 C...Specific kinematics reduction for q->qg with m_q > 0.
70596  IF(moct.NE.1) THEN
70597  ptcor=(1d0-pm2i/pm2)*ptcor
70598  pzn=pzn+pm2i*pzg/pm2
70599  pzg=(1d0-pm2i/pm2)*pzg
70600 C...Specific kinematics reduction for g->qqbar with m_q > 0.
70601  ELSEIF(kfq.NE.0) THEN
70602  p(inew,5)=pmq
70603  p(ignew,5)=pmq
70604  ptcor=rootqq*ptcor
70605  pzn=0.5d0*((1d0+rootqq)*pzn+(1d0-rootqq)*pzg)
70606  pzg=pzm-pzn
70607  ENDIF
70608 
70609 C...Pick phi and construct kinematics of branching.
70610  420 phirot=paru(2)*pyr(0)
70611  p(inew,1)=ptcor*cos(phirot)
70612  p(inew,2)=ptcor*sin(phirot)
70613  p(inew,3)=pzn
70614  p(inew,4)=sqrt(ptcor**2+p(inew,3)**2+p(inew,5)**2)
70615  p(ignew,1)=-p(inew,1)
70616  p(ignew,2)=-p(inew,2)
70617  p(ignew,3)=pzg
70618  p(ignew,4)=sqrt(ptcor**2+p(ignew,3)**2+p(ignew,5)**2)
70619  p(irnew,1)=0d0
70620  p(irnew,2)=0d0
70621  p(irnew,3)=-pzm
70622  p(irnew,4)=0.5d0*(sht+pm2r-pm2)/sqrt(sht)
70623 
70624 C...Boost branching system to lab frame.
70625  CALL pyrobo(inew,irnew,theta,phi,betax,betay,betaz)
70626 
70627 C...Renew choice of phi angle according to polarization asymmetry.
70628  IF(abs(asypol).GT.1d-3) THEN
70629  DO 430 j=1,3
70630  dpt(1,j)=p(i,j)
70631  dpt(2,j)=p(iau,j)
70632  dpt(3,j)=p(inew,j)
70633  430 CONTINUE
70634  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
70635  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
70636  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
70637  DO 440 j=1,3
70638  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/max(1d-10,dpmm)
70639  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/max(1d-10,dpmm)
70640  440 CONTINUE
70641  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
70642  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
70643  IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
70644  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
70645  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
70646  IF(1d0+asypol*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(asypol)))
70647  & GOTO 420
70648  ENDIF
70649  ENDIF
70650 
70651 C...Matrix element corrections for primary partons when requested.
70652  IF(imesys.GT.0) THEN
70653  m3jc=mesys(imesys,0)
70654 
70655 C...Identify recoiling partner and set up three-body kinematics.
70656  irp=mesys(imesys,1)
70657  IF(irp.EQ.i) irp=mesys(imesys,2)
70658  IF(irp.EQ.ir) irp=irnew
70659  DO 450 j=1,4
70660  psum(j)=p(inew,j)+p(irp,j)+p(ignew,j)
70661  450 CONTINUE
70662  psum(5)=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-
70663  & psum(3)**2))
70664  x1=2d0*(psum(4)*p(inew,4)-psum(1)*p(inew,1)-psum(2)*p(inew,2)-
70665  & psum(3)*p(inew,3))/psum(5)**2
70666  x2=2d0*(psum(4)*p(irp,4)-psum(1)*p(irp,1)-psum(2)*p(irp,2)-
70667  & psum(3)*p(irp,3))/psum(5)**2
70668  x3=2d0-x1-x2
70669  r1me=p(inew,5)/psum(5)
70670  r2me=p(irp,5)/psum(5)
70671 
70672 C...Matrix elements for gluon emission.
70673  IF(m3jc.LT.100) THEN
70674 
70675 C...Call ME, with right order important for two inequivalent showerers.
70676  IF(mesys(imesys,iord).EQ.i) THEN
70677  wme=pymael(m3jc,x1,x2,r1me,r2me,alpha)
70678  ELSE
70679  wme=pymael(m3jc,x2,x1,r2me,r1me,alpha)
70680  ENDIF
70681 
70682 C...Split up total ME when two radiating partons.
70683  isprad=1
70684  IF((m3jc.GE.16.AND.m3jc.LE.19).OR.(m3jc.GE.26.AND.m3jc.LE.29)
70685  & .OR.(m3jc.GE.36.AND.m3jc.LE.39).OR.(m3jc.GE.46.AND.m3jc.LE.49)
70686  & .OR.(m3jc.GE.56.AND.m3jc.LE.64)) isprad=0
70687  IF(isprad.EQ.1) wme=wme*max(1d-10,1d0+r1me**2-r2me**2-x1)/
70688  & max(1d-10,2d0-x1-x2)
70689 
70690 C...Evaluate shower rate.
70691  wps=2d0/(max(1d-10,2d0-x1-x2)*
70692  & max(1d-10,1d0+r2me**2-r1me**2-x2))
70693  IF(iglui.EQ.1) wps=(9d0/4d0)*wps
70694 
70695 C...Matrix elements for photon emission: still rather primitive.
70696  ELSE
70697 
70698 C...For generic charge combination currently only massless expression.
70699  IF(m3jc.EQ.101) THEN
70700  chg1=kchg(pycomp(k(i,2)),1)*isign(1,k(i,2))/3d0
70701  chg2=kchg(pycomp(k(irp,2)),1)*isign(1,k(irp,2))/3d0
70702  wme=(chg1*(1d0-x1)/x3-chg2*(1d0-x2)/x3)**2*(x1**2+x2**2)
70703  wps=2d0*(chg1**2*(1d0-x1)/x3+chg2**2*(1d0-x2)/x3)
70704 
70705 C...For flavour neutral system assume vector source and include masses.
70706  ELSE
70707  wme=pymael(11,x1,x2,r1me,r2me,0d0)*max(1d-10,
70708  & 1d0+r1me**2-r2me**2-x1)/max(1d-10,2d0-x1-x2)
70709  wps=2d0/(max(1d-10,2d0-x1-x2)*
70710  & max(1d-10,1d0+r2me**2-r1me**2-x2))
70711  ENDIF
70712  ENDIF
70713 
70714 C...Perform weighting with W_ME/W_PS.
70715  IF(wme.LT.pyr(0)*wps) THEN
70716  n=n-3
70717  iflg(imx)=0
70718  pt2cmx=pt2
70719  GOTO 310
70720  ENDIF
70721  ENDIF
70722 
70723 C...Now for sure accepted branching. Save highest pT.
70724  IF(ngen.EQ.1) ptgen=sqrt(pt2)
70725 
70726 C...Update status for obsolete ones. Bookkkep the moved original parton
70727 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70728 C...Do not bookkeep radiated photon, since it cannot radiate further.
70729  k(i,1)=k(i,1)+10
70730  k(ir,1)=k(ir,1)+10
70731  DO 460 ip=1,npart
70732  IF(ipart(ip).EQ.i) ipart(ip)=inew
70733  IF(ipart(ip).EQ.ir) ipart(ip)=irnew
70734  460 CONTINUE
70735  IF(kcha.EQ.0) THEN
70736  npart=npart+1
70737  ipart(npart)=ignew
70738  ENDIF
70739 
70740 C...Initialize colour flow of branching.
70741 C...Use both old and new style colour tags for flexibility.
70742  k(inew,4)=0
70743  k(ignew,4)=0
70744  k(inew,5)=0
70745  k(ignew,5)=0
70746  jcolp=4+(1-kcol)/2
70747  jcoln=9-jcolp
70748  mct(inew,1)=0
70749  mct(inew,2)=0
70750  mct(ignew,1)=0
70751  mct(ignew,2)=0
70752  mct(irnew,1)=0
70753  mct(irnew,2)=0
70754 
70755 C...Trivial colour flow for l->lgamma and q->qgamma.
70756  IF(iabs(kcha).EQ.3) THEN
70757  k(i,4)=inew
70758  k(i,5)=ignew
70759  ELSEIF(kcha.NE.0) THEN
70760  IF(k(i,4).NE.0) THEN
70761  k(i,4)=k(i,4)+inew
70762  k(inew,4)=mstu(5)*i
70763  mct(inew,1)=mct(i,1)
70764  ENDIF
70765  IF(k(i,5).NE.0) THEN
70766  k(i,5)=k(i,5)+inew
70767  k(inew,5)=mstu(5)*i
70768  mct(inew,2)=mct(i,2)
70769  ENDIF
70770 
70771 C...Set colour flow for q->qg and g->gg.
70772  ELSEIF(kfq.EQ.0) THEN
70773  k(i,jcolp)=k(i,jcolp)+ignew
70774  k(ignew,jcolp)=mstu(5)*i
70775  k(inew,jcolp)=mstu(5)*ignew
70776  k(ignew,jcoln)=mstu(5)*inew
70777  mct(ignew,jcolp-3)=mct(i,jcolp-3)
70778  nct=nct+1
70779  mct(inew,jcolp-3)=nct
70780  mct(ignew,jcoln-3)=nct
70781  IF(moct.GE.1) THEN
70782  k(i,jcoln)=k(i,jcoln)+inew
70783  k(inew,jcoln)=mstu(5)*i
70784  mct(inew,jcoln-3)=mct(i,jcoln-3)
70785  ENDIF
70786 
70787 C...Set colour flow for g->qqbar.
70788  ELSE
70789  k(i,jcoln)=k(i,jcoln)+inew
70790  k(inew,jcoln)=mstu(5)*i
70791  k(i,jcolp)=k(i,jcolp)+ignew
70792  k(ignew,jcolp)=mstu(5)*i
70793  mct(inew,jcoln-3)=mct(i,jcoln-3)
70794  mct(ignew,jcolp-3)=mct(i,jcolp-3)
70795  ENDIF
70796 
70797 C...Daughter info for colourless recoiling parton.
70798  IF(k(ir,4).EQ.0.AND.k(ir,5).EQ.0) THEN
70799  k(ir,4)=irnew
70800  k(ir,5)=irnew
70801  k(irnew,4)=0
70802  k(irnew,5)=0
70803 
70804 C...Colour of recoiling parton sails through unchanged.
70805  ELSE
70806  IF(k(ir,4).NE.0) THEN
70807  k(ir,4)=k(ir,4)+irnew
70808  k(irnew,4)=mstu(5)*ir
70809  mct(irnew,1)=mct(ir,1)
70810  ENDIF
70811  IF(k(ir,5).NE.0) THEN
70812  k(ir,5)=k(ir,5)+irnew
70813  k(irnew,5)=mstu(5)*ir
70814  mct(irnew,2)=mct(ir,2)
70815  ENDIF
70816  ENDIF
70817 
70818 C...Vertex information trivial.
70819  DO 470 j=1,5
70820  v(inew,j)=v(i,j)
70821  v(ignew,j)=v(i,j)
70822  v(irnew,j)=v(ir,j)
70823  470 CONTINUE
70824 
70825 C...Update list of old radiators.
70826  DO 480 ievol=1,nevol
70827  IF(ipos(ievol).EQ.i.AND.irec(ievol).EQ.ir) THEN
70828  ipos(ievol)=inew
70829  IF(kcol.NE.0.AND.iscol(ievol).EQ.kcol) ipos(ievol)=ignew
70830  irec(ievol)=irnew
70831  iflg(ievol)=0
70832  ELSEIF(ipos(ievol).EQ.i) THEN
70833  ipos(ievol)=inew
70834  iflg(ievol)=0
70835  ELSEIF(ipos(ievol).EQ.ir.AND.irec(ievol).EQ.i) THEN
70836  ipos(ievol)=irnew
70837  irec(ievol)=inew
70838  IF(kcol.NE.0.AND.iscol(ievol).NE.kcol) irec(ievol)=ignew
70839  iflg(ievol)=0
70840  ELSEIF(ipos(ievol).EQ.ir) THEN
70841  ipos(ievol)=irnew
70842  iflg(ievol)=0
70843  ENDIF
70844 C...Update links of old connected partons.
70845  IF(irec(ievol).EQ.i) THEN
70846  irec(ievol)=inew
70847  iflg(ievol)=0
70848  ELSEIF(irec(ievol).EQ.ir) THEN
70849  irec(ievol)=irnew
70850  iflg(ievol)=0
70851  ENDIF
70852  480 CONTINUE
70853 
70854 C...q->qg or g->gg: create new gluon radiators.
70855  IF(kcol.NE.0.AND.kfq.EQ.0) THEN
70856  nevol=nevol+1
70857  ipos(nevol)=inew
70858  irec(nevol)=ignew
70859  iflg(nevol)=0
70860  iscol(nevol)=kcol
70861  ischg(nevol)=0
70862  ptsca(nevol)=sqrt(pt2)
70863  nevol=nevol+1
70864  ipos(nevol)=ignew
70865  irec(nevol)=inew
70866  iflg(nevol)=0
70867  iscol(nevol)=-kcol
70868  ischg(nevol)=0
70869  ptsca(nevol)=ptsca(nevol-1)
70870  ENDIF
70871 
70872 C...Update matrix elements parton list and add new for g/gamma->qqbar.
70873  DO 490 ime=1,nmesys
70874  IF(mesys(ime,1).EQ.i) mesys(ime,1)=inew
70875  IF(mesys(ime,2).EQ.i) mesys(ime,2)=inew
70876  IF(mesys(ime,1).EQ.ir) mesys(ime,1)=irnew
70877  IF(mesys(ime,2).EQ.ir) mesys(ime,2)=irnew
70878  490 CONTINUE
70879  IF(kfq.NE.0) THEN
70880  nmesys=nmesys+1
70881  mesys(nmesys,0)=66
70882  mesys(nmesys,1)=inew
70883  mesys(nmesys,2)=ignew
70884  nmesys=nmesys+1
70885  mesys(nmesys,0)=102
70886  mesys(nmesys,1)=inew
70887  mesys(nmesys,2)=ignew
70888  ENDIF
70889 
70890 C...Global statistics.
70891  mint(353)=mint(353)+1
70892  vint(353)=vint(353)+ptcor
70893  IF (mint(353).EQ.1) vint(358)=ptcor
70894 
70895 C...Loopback for more emissions if enough space.
70896  pt2cmx=pt2
70897  IF(npart.LT.maxnur-1.AND.nevol.LT.2*maxnur-2.AND.
70898  &nmesys.LT.maxnur-2.AND.n.LT.mstu(4)-mstu(32)-5) THEN
70899  GOTO 300
70900  ELSE
70901  CALL pyerrm(11,'(PYPTFS:) no more memory left for shower')
70902  ENDIF
70903 
70904 C...Done.
70905  500 CONTINUE
70906 
70907  RETURN
70908  END
70909 
70910 C*********************************************************************
70911 
70912 C...PYMAEL
70913 C...Auxiliary to PYSHOW and PYPTFS.
70914 C...Matrix elements for gluon (or photon) emission from
70915 C...a two-body state; to be used by the parton shower routine.
70916 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
70917 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
70918 C... = (alpha-strong/2 pi) * CF * PYMAEL,
70919 C...i.e. normalization is such that one recovers the familiar
70920 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
70921 C...Coupling structure:
70922 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
70923 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
70924 C... = 16-19 : q -> q V
70925 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
70926 C... = 26-29 : q -> q S
70927 C... = 31-34 : V -> ~q ~qbar (~q = squark)
70928 C... = 36-39 : ~q -> ~q V
70929 C... = 41-44 : S -> ~q ~qbar
70930 C... = 46-49 : ~q -> ~q S
70931 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
70932 C... = 56-59 : ~q -> q chi
70933 C... = 61-64 : q -> ~q chi
70934 C... = 66-69 : ~g -> q ~qbar
70935 C... = 71-74 : ~q -> q ~g
70936 C... = 76-79 : q -> ~q ~g
70937 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
70938 C...Note that the order of the decay products is important.
70939 C...In each set of four, the variants are ordered as:
70940 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
70941 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
70942 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
70943 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
70944 
70945  FUNCTION pymael(NI,X1,X2,R1,R2,ALPHA)
70946 
70947 C...Double precision and integer declarations.
70948  IMPLICIT DOUBLE PRECISION(a-h, o-z)
70949  IMPLICIT INTEGER(I-N)
70950 
70951 C...Check input values. Return zero outside allowed phase space.
70952  pymael=0d0
70953  IF(x1.LE.2d0*r1.OR.x1.GE.1d0+r1**2-r2**2) RETURN
70954  IF(x2.LE.2d0*r2.OR.x2.GE.1d0+r2**2-r1**2) RETURN
70955  IF(x1+x2.LE.1d0+(r1+r2)**2) RETURN
70956  IF((2d0-2d0*x1-2d0*x2+x1*x2+2d0*r1**2+2d0*r2**2)**2.GE.
70957  &(x1**2-4d0*r1**2)*(x2**2-4d0*r2**2)) RETURN
70958  alpcor=max(0d0,min(1d0,alpha))
70959 
70960 C...Initial values and flags.
70961  iclass=ni/5
70962  icombi=ni-5*iclass
70963  isset1=0
70964  isset2=0
70965  isset4=0
70966 
70967 C... Phase space.
70968  ps=sqrt((1d0-(r1+r2)**2)*(1d0-(r1-r2)**2))
70969 
70970 C...Eikonal expression; also acts as default.
70971  IF(iclass.LE.1.OR.iclass.GE.17.OR.icombi.EQ.0) THEN
70972  rlo=ps
70973  IF(icombi.EQ.0.OR.icombi.EQ.1) THEN
70974  anum=0d0
70975  ELSEIF(icombi.EQ.2) THEN
70976  anum=(2d0-x1-x2)**2
70977  ELSEIF(icombi.EQ.3) THEN
70978  anum=alpcor*(2d0-x1-x2)**2
70979  ELSE
70980  anum=0.5d0*(2d0-x1-x2)**2
70981  ENDIF
70982  rfo=ps*2d0*((x1+x2-1d0+anum-r1**2-r2**2)/
70983  & ((1d0+r1**2-r2**2-x1)*(1d0+r2**2-r1**2-x2))-
70984  & r1**2/(1d0+r2**2-r1**2-x2)**2-
70985  & r2**2/(1d0+r1**2-r2**2-x1)**2)
70986  icombi=0
70987 
70988 C...V -> q qbar (V = gamma*/Z0/W+-/...).
70989  ELSEIF(iclass.EQ.2) THEN
70990  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
70991  rlo1=ps*(2-r1**2-r1**4+6*r1*r2-r2**2+2*r1**2*r2**2-r2**4)/2.d0
70992  rfo1=-1.d0*(3+6*r1**2+r1**4-6*r1*r2+6*r1**3*r2-2*r2**2
70993  & -6*r1**2*r2**2+6*r1*r2**3+r2**4-3*x1+6*r1*r2*x1
70994  & +2*r2**2*x1+x1**2-2*r1**2*x1**2+3*r1**2*(2-x1-x2)
70995  & +6*r1*r2*(2-x1-x2)-r2**2*(2-x1-x2)-2*x1*(2-x1-x2)
70996  & -5*r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)
70997  & -3*(2-x1-x2)**2-3*r1**2*(2-x1-x2)**2+r2**2*(2-x1-x2)**2
70998  & +2*x1*(2-x1-x2)**2+(2-x1-x2)**3-x2)/
70999  & (-1+r1**2-r2**2+x2)**2
71000  rfo1=rfo1-2*(-3+r1**2-6*r1*r2+6*r1**3*r2+3*r2**2-4*r1**2*r2**2
71001  & +6*r1*r2**3+2*x1+3*r1**2*x1+r2**2*x1-x1**2-r1**2*x1**2
71002  & -r2**2*x1**2+4*(2-x1-x2)+2*r1**2*(2-x1-x2)+3*r1*r2*(2-x1
71003  & -x2)-r2**2*(2-x1-x2)-3*x1*(2-x1-x2)-2*r1**2*x1*(2-x1-x2)
71004  & +x1**2*(2-x1-x2)-(2-x1-x2)**2-r1**2*(2-x1-x2)**2+r1*r2*(2
71005  & -x1-x2)**2+x1*(2-x1-x2)**2)/
71006  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71007  rfo1=rfo1-1.d0*(-1+2*r1**2+r1**4+6*r1*r2+6*r1**3*r2-2*r2**2
71008  & -6*r1**2*r2**2+6*r1*r2**3+r2**4-x1-2*r1**2*x1-6*r1*r2*x1
71009  & +8*r2**2*x1+x1**2-2*r2**2*x1**2-r1**2*(2-x1-x2)+r2**2*(2
71010  & -x1-x2)-r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*
71011  & (2-x1-x2)+x2)/(-1-r1**2+r2**2+x1)**2
71012  rfo1=rfo1/2.d0
71013  isset1=1
71014  ENDIF
71015  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71016  rlo2=ps*(2-r1**2-r1**4-6*r1*r2-r2**2+2*r1**2*r2**2-r2**4)/2.d0
71017  rfo2=-1*(3+6*r1**2+r1**4+6*r1*r2-6*r1**3*r2-2*r2**2
71018  & -6*r1**2*r2**2-6*r1*r2**3+r2**4-3*x1-6*r1*r2*x1+2*r2**2*x1
71019  & +x1**2-2*r1**2*x1**2+3*r1**2*(2-x1-x2)-6*r1*r2*(2-x1-x2)
71020  & -r2**2*(2-x1-x2)-2*x1*(2-x1-x2)-5*r1**2*x1*(2-x1-x2)
71021  & +r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)-3*(2-x1-x2)**2
71022  & -3*r1**2*(2-x1-x2)**2+r2**2*(2-x1-x2)**2+2*x1*(2-x1-x2)**2
71023  & +(2-x1-x2)**3-x2)/(-1+r1**2-r2**2+x2)**2
71024  rfo2=rfo2-2*(-3+r1**2+6*r1*r2-6*r1**3*r2+3*r2**2-4*r1**2*r2**2
71025  & -6*r1*r2**3+2*x1+3*r1**2*x1+r2**2*x1-x1**2-r1**2*x1**2
71026  & -r2**2*x1**2+4*(2-x1-x2)+2*r1**2*(2-x1-x2)-3*r1*r2*(2-x1
71027  & -x2)-r2**2*(2-x1-x2)-3*x1*(2-x1-x2)-2*r1**2*x1*(2-x1-x2)
71028  & +x1**2*(2-x1-x2)-(2-x1-x2)**2-r1**2*(2-x1-x2)**2-r1*r2*(2
71029  & -x1-x2)**2+x1*(2-x1-x2)**2)/
71030  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71031  rfo2=rfo2-1*(-1+2*r1**2+r1**4-6*r1*r2-6*r1**3*r2-2*r2**2
71032  & -6*r1**2*r2**2-6*r1*r2**3+r2**4-x1-2*r1**2*x1+6*r1*r2*x1
71033  & +8*r2**2*x1+x1**2-2*r2**2*x1**2-r1**2*(2-x1-x2)+r2**2*(2-x1
71034  & -x2)-r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)
71035  & +x2)/(-1-r1**2+r2**2+x1)**2
71036  rfo2=rfo2/2.d0
71037  isset2=1
71038  ENDIF
71039  IF(icombi.EQ.4) THEN
71040  rlo4=ps*(2d0-r1**2-r1**4-r2**2+2d0*r1**2*r2**2-r2**4)/2d0
71041  rfo4=(1-r1**4+6*r1**2*r2**2-r2**4+x1+3*r1**2*x1-9*r2**2*x1
71042  & -3*x1**2-r1**2*x1**2+3*r2**2*x1**2+x1**3-x2-r1**2*x2
71043  & +r2**2*x2-r1**2*x1*x2+r2**2*x1*x2+x1**2*x2)/
71044  & (-1-r1**2+r2**2+x1)**2
71045  rfo4=rfo4
71046  & -2*(1+r1**2+r2**2-4*r1**2*r2**2+r1**2*x1+2*r2**2*x1-x1**2
71047  & -r2**2*x1**2+2*r1**2*x2+r2**2*x2-3*x1*x2+x1**2*x2-x2**2
71048  & -r1**2*x2**2+x1*x2**2)/
71049  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71050  rfo4=rfo4+(1-r1**4+6*r1**2*r2**2-r2**4-x1+r1**2*x1-r2**2*x1+x2
71051  & -9*r1**2*x2+3*r2**2*x2+r1**2*x1*x2-r2**2*x1*x2-3*x2**2
71052  & +3*r1**2*x2**2-r2**2*x2**2+x1*x2**2+x2**3)/
71053  & (-1+r1**2-r2**2+x2)**2
71054  rfo4=rfo4/2.d0
71055  isset4=1
71056  ENDIF
71057 
71058 C...q -> q V.
71059  ELSEIF(iclass.EQ.3) THEN
71060  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71061  rlo1=ps*(1d0-2d0*r1**2+r1**4+r2**2-6d0*r1*r2**2
71062  & +r1**2*r2**2-2d0*r2**4)
71063  rfo1=2*(-1+r1-2*r1**2+2*r1**3-r1**4+r1**5-r2**2+r1*r2**2
71064  & -5*r1**2*r2**2+r1**3*r2**2-2*r1*r2**4+2*x1-2*r1*x1
71065  & +2*r1**2*x1-2*r1**3*x1+2*r2**2*x1+5*r1*r2**2*x1
71066  & +r1**2*r2**2*x1+2*r2**4*x1-x1**2+r1*x1**2-r2**2*x1**2+3*x2
71067  & +4*r1**2*x2+r1**4*x2+2*r2**2*x2+2*r1**2*r2**2*x2-4*x1*x2
71068  & -2*r1**2*x1*x2-r2**2*x1*x2+x1**2*x2-2*x2**2
71069  & -2*r1**2*x2**2+x1*x2**2)/(1-r1**2+r2**2-x2)/(-2+x1+x2)
71070  rfo1=rfo1+(2*r2**2+6*r1*r2**2-6*r1**2*r2**2+6*r1**3*r2**2
71071  & +2*r2**4+6*r1*r2**4-r2**2*x1+r1**2*r2**2*x1-r2**4*x1+x2
71072  & -r1**4*x2-3*r2**2*x2-6*r1*r2**2*x2+9*r1**2*r2**2*x2
71073  & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
71074  & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
71075  rfo1=rfo1+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4
71076  & +9*x1+10*r1**2*x1+r1**4*x1-3*r2**2*x1+6*r1*r2**2*x1
71077  & +r1**2*r2**2*x1-2*r2**4*x1-6*x1**2-2*r1**2*x1**2+x1**3
71078  & +7*x2+8*r1**2*x2+r1**4*x2-7*r2**2*x2+6*r1*r2**2*x2
71079  & +r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
71080  & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2
71081  & +2*r2**2*x2**2+x1*x2**2)/(-2+x1+x2)**2
71082  isset1=1
71083  ENDIF
71084  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71085  rlo2=ps*(1d0-2d0*r1**2+r1**4+r2**2+6d0*r1*r2**2
71086  & +r1**2*r2**2-2d0*r2**4)
71087  rfo2=2*(1+r1+2*r1**2+2*r1**3+r1**4+r1**5+r2**2+r1*r2**2
71088  & +5*r1**2*r2**2+r1**3*r2**2-2*r1*r2**4-2*x1-2*r1*x1
71089  & -2*r1**2*x1-2*r1**3*x1-2*r2**2*x1+5*r1*r2**2*x1
71090  & -r1**2*r2**2*x1-2*r2**4*x1+x1**2+r1*x1**2+r2**2*x1**2-3*x2
71091  & -4*r1**2*x2-r1**4*x2-2*r2**2*x2-2*r1**2*r2**2*x2+4*x1*x2
71092  & +2*r1**2*x1*x2+r2**2*x1*x2-x1**2*x2+2*x2**2+2*r1**2*x2**2
71093  & -x1*x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71094  rfo2=rfo2+(2*r2**2-6*r1*r2**2-6*r1**2*r2**2-6*r1**3*r2**2
71095  & +2*r2**4-6*r1*r2**4-r2**2*x1+r1**2*r2**2*x1-r2**4*x1+x2
71096  & -r1**4*x2-3*r2**2*x2+6*r1*r2**2*x2+9*r1**2*r2**2*x2
71097  & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
71098  & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
71099  rfo2=rfo2+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4+9*x1
71100  & +10*r1**2*x1+r1**4*x1-3*r2**2*x1-6*r1*r2**2*x1
71101  & +r1**2*r2**2*x1-2*r2**4*x1-6*x1**2-2*r1**2*x1**2+x1**3
71102  & +7*x2+8*r1**2*x2+r1**4*x2-7*r2**2*x2-6*r1*r2**2*x2
71103  & +r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
71104  & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2+2*r2**2*x2**2
71105  & +x1*x2**2)/(-2+x1+x2)**2
71106  isset2=1
71107  ENDIF
71108  IF(icombi.EQ.4) THEN
71109  rlo4=ps*(1.d0-2.d0*r1**2+r1**4+r2**2+r1**2*r2**2-2.d0*r2**4)
71110  rfo4=2*(1+2*r1**2+r1**4+r2**2+5*r1**2*r2**2-2*x1-2*r1**2*x1
71111  & -2*r2**2*x1-r1**2*r2**2*x1-2*r2**4*x1+x1**2+r2**2*x1**2
71112  & -3*x2-4*r1**2*x2-r1**4*x2-2*r2**2*x2-2*r1**2*r2**2*x2
71113  & +4*x1*x2+2*r1**2*x1*x2+r2**2*x1*x2-x1**2*x2+2*x2**2
71114  & +2*r1**2*x2**2-x1*x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71115  rfo4=rfo4+(2*r2**2-6*r1**2*r2**2+2*r2**4-r2**2*x1+r1**2*r2**2*x1
71116  & -r2**4*x1+x2-r1**4*x2-3*r2**2*x2+9*r1**2*r2**2*x2
71117  & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
71118  & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
71119  rfo4=rfo4+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4+9*x1
71120  & +10*r1**2*x1+r1**4*x1-3*r2**2*x1+r1**2*r2**2*x1-2*r2**4*x1
71121  & -6*x1**2-2*r1**2*x1**2+x1**3+7*x2+8*r1**2*x2+r1**4*x2
71122  & -7*r2**2*x2+r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
71123  & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2+2*r2**2*x2**2
71124  & +x1*x2**2)/(2-x1-x2)**2
71125  isset4=1
71126  ENDIF
71127 
71128 C...S -> q qbar (S = h0/H0/A0/H+-/...).
71129  ELSEIF(iclass.EQ.4) THEN
71130  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71131  rlo1=ps*(1d0-r1**2-r2**2-2d0*r1*r2)
71132  rfo1=-(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71133  & +r2**4+x1-r1**2*x1+2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71134  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71135  & -2*(r1**2+r1**4-2*r1**3*r2+r2**2-6*r1**2*r2**2-2*r1*r2**3
71136  & +r2**4-r1**2*x1+r1*r2*x1+2*r2**2*x1+2*r1**2*x2+r1*r2*x2
71137  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71138  & -(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71139  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
71140  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71141  isset1=1
71142  ENDIF
71143  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71144  rlo2=ps*(1d0-r1**2-r2**2+2d0*r1*r2)
71145  rfo2=-(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71146  & +r2**4+x1-r1**2*x1-2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71147  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71148  & -(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71149  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2
71150  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71151  & +2*(-r1**2-r1**4-2*r1**3*r2-r2**2+6*r1**2*r2**2
71152  & -2*r1*r2**3-r2**4+r1**2*x1+r1*r2*x1-2*r2**2*x1
71153  & -2*r1**2*x2+r1*r2*x2+r2**2*x2+x1*x2)/
71154  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71155  isset2=1
71156  ENDIF
71157  IF(icombi.EQ.4) THEN
71158  rlo4=ps*(1d0-r1**2-r2**2)
71159  rfo4=-(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+3*r2**2*x1+x2
71160  & +r1**2*x2-r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71161  & -2*(r1**2+r1**4+r2**2-6*r1**2*r2**2+r2**4-r1**2*x1
71162  & +2*r2**2*x1+2*r1**2*x2-r2**2*x2-x1*x2)/
71163  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71164  & -(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1
71165  & +x2+3*r1**2*x2-r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71166  isset4=1
71167  ENDIF
71168 
71169 C...q -> q S.
71170  ELSEIF(iclass.EQ.5) THEN
71171  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71172  rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
71173  rfo1=(4-4*r1**2+4*r2**2-3*x1-2*r1*x1+r1**2*x1-r2**2*x1-5*x2
71174  & -2*r1*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
71175  & +2*(3-r1-5*r1**2-r1**3+3*r2**2+r1*r2**2-2*x1-r1*x1
71176  & +r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71177  & (1-r1**2+r2**2-x2)/(-2+x1+x2)
71178  & +(2-2*r1-6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1
71179  & -r2**2*x1-3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71180  & (-1+r1**2-r2**2+x2)**2
71181  isset1=1
71182  ENDIF
71183  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71184  rlo2=ps*(1d0+r1**2-r2**2-2d0*r1)
71185  rfo2=(4-4*r1**2+4*r2**2-3*x1+2*r1*x1+r1**2*x1-r2**2*x1-5*x2
71186  & +2*r1*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
71187  & +2*(3+r1-5*r1**2+r1**3+3*r2**2-r1*r2**2-2*x1+r1*x1
71188  & +r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71189  & (1-r1**2+r2**2-x2)/(-2+x1+x2)
71190  & +(2+2*r1-6*r1**2+2*r1**3+2*r2**2+2*r1*r2**2-x1+r1**2*x1
71191  & -r2**2*x1-3*x2-2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71192  & (-1+r1**2-r2**2+x2)**2
71193  isset2=1
71194  ENDIF
71195  IF(icombi.EQ.4) THEN
71196  rlo4=ps*(1d0+r1**2-r2**2)
71197  rfo4=(4-4*r1**2+4*r2**2-3*x1+r1**2*x1-r2**2*x1-5*x2+r1**2*x2
71198  & -r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
71199  & +2*(3-5*r1**2+3*r2**2-2*x1+r1**2*x1-4*x2+2*r1**2*x2
71200  & -r2**2*x2+x1*x2+x2**2)/(1-r1**2+r2**2-x2)/(-2+x1+x2)
71201  & +(2-6*r1**2+2*r2**2-x1+r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2
71202  & -r2**2*x2+x1*x2+x2**2)/(-1+r1**2-r2**2+x2)**2
71203  isset4=1
71204  ENDIF
71205 
71206 C...V -> ~q ~qbar (~q = squark).
71207  ELSEIF(iclass.EQ.6) THEN
71208  rlo1=ps*(1d0-2d0*r1**2+r1**4-2d0*r2**2-2d0*r1**2*r2**2+r2**4)
71209  rfo1=2d0*3d0+(1+r1**2+r2**2-x1)*(4*r1**2-x1**2)/
71210  & (-1-r1**2+r2**2+x1)**2
71211  & -2d0*(-1-3*r1**2-r2**2+x1+x1**2/2+x2-x1*x2/2)/
71212  & (-1-r1**2+r2**2+x1)
71213  & +(1+r1**2+r2**2-x2)*(4*r2**2-x2**2)
71214  & /(-1+r1**2-r2**2+x2)**2
71215  & -2d0*(-1-r1**2-3*r2**2+x1+x2-x1*x2/2+x2**2/2)/
71216  & (-1+r1**2-r2**2+x2)
71217  & -(-4*r1**2-4*r1**4-4*r2**2-8*r1**2*r2**2-4*r2**4+2*x1
71218  & +6*r1**2*x1+6*r2**2*x1-2*x1**2+2*x2+6*r1**2*x2+6*r2**2*x2
71219  & -4*x1*x2-2*r1**2*x1*x2-2*r2**2*x1*x2+x1**2*x2-2*x2**2
71220  & +x1*x2**2)/(-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71221  isset1=1
71222 
71223 C...~q -> ~q V.
71224  ELSEIF(iclass.EQ.7) THEN
71225  rlo1=ps*(1d0-2d0*r1**2+r1**4-2d0*r2**2-2d0*r1**2*r2**2+r2**4)
71226  rfo1=16*r2**2+8*(4*r2**2+2*r2**2*x1+x2+r1**2*x2+r2**2*x2-x1*x2
71227  & -2*x2**2)/(3*(-1+r1**2-r2**2+x2))+8*(1+r1**2+r2**2-x2)*
71228  & (4*r2**2-x2**2)/(3*(-1+r1**2-r2**2+x2)**2)+8*(x1+x2)*
71229  & (-1-2*r1**2-r1**4-2*r2**2+2*r1**2*r2**2-r2**4+2*x1
71230  & +2*r1**2*x1+2*r2**2*x1-x1**2+2*x2+2*r1**2*x2+2*r2**2*x2
71231  & -2*x1*x2-x2**2)/(3*(-2+x1+x2)**2)+8*(-1-r1**2+r2**2-x1)*
71232  & (2*r2**2*x1+x2+r1**2*x2+r2**2*x2-x1*x2-x2**2)/
71233  & (3*(-1+r1**2-r2**2+x2)*(-2+x1+x2))+8*(1+2*r1**2+r1**4
71234  & +2*r2**2-2*r1**2*r2**2+r2**4-2*x1-2*r1**2*x1-4*r2**2*x1
71235  & +x1**2-3*x2-3*r1**2*x2-3*r2**2*x2+3*x1*x2+2*x2**2)/
71236  & (3*(-2+x1+x2))
71237  rfo1=3d0*rfo1/8d0
71238  isset1=1
71239 
71240 C...S -> ~q ~qbar.
71241  ELSEIF(iclass.EQ.8) THEN
71242  rlo1=ps
71243  rfo1=(-1-2*r1**2-r1**4-2*r2**2+2*r1**2*r2**2-r2**4+2*x1
71244  & +2*r1**2*x1+2*r2**2*x1-x1**2-r2**2*x1**2+2*x2+2*r1**2*x2
71245  & +2*r2**2*x2-3*x1*x2-r1**2*x1*x2-r2**2*x1*x2+x1**2*x2-x2**2
71246  & -r1**2*x2**2+x1*x2**2)/
71247  & (1+r1**2-r2**2-x1)**2/(-1+r1**2-r2**2+x2)**2
71248  rfo1=2d0*rfo1
71249  isset1=1
71250 
71251 C...~q -> ~q S.
71252  ELSEIF(iclass.EQ.9) THEN
71253  rlo1=ps
71254  rfo1=(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
71255  & +(1+r1**2-r2**2+x1)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71256  & -(x1+x2)/(-2+x1+x2)**2
71257  isset1=1
71258 
71259 C...chi -> q ~qbar (chi = neutralino/chargino).
71260  ELSEIF(iclass.EQ.10) THEN
71261  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71262  rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
71263  rfo1=(2*r1+x1)*(-1-r1**2-r2**2+x1)/(-1-r1**2+r2**2+x1)**2
71264  & +2*(-1-r1**2-2*r1**3-r2**2-2*r1*r2**2+3*x1/2+r1*x1
71265  & -r1**2*x1/2-r2**2*x1/2+x2+r1*x2+r1**2*x2-x1*x2/2)/
71266  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71267  & +(2-2*r1-6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1
71268  & -r2**2*x1-3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71269  & (-1+r1**2-r2**2+x2)**2
71270  isset1=1
71271  ENDIF
71272  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71273  rlo2=ps*(1d0-2d0*r1+r1**2-r2**2)
71274  rfo2=(2*r1-x1)*(1+r1**2+r2**2-x1)/(-1-r1**2+r2**2+x1)**2
71275  & +2*(-1-r1**2+2*r1**3-r2**2+2*r1*r2**2+3*x1/2-r1*x1
71276  & -r1**2*x1/2-r2**2*x1/2+x2-r1*x2+r1**2*x2-x1*x2/2)/
71277  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71278  & +(2+2*r1-6*r1**2+2*r1**3+2*r2**2+2*r1*r2**2-x1+r1**2*x1
71279  & -r2**2*x1-3*x2-2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71280  & (-1+r1**2-r2**2+x2)**2
71281  isset2=1
71282  ENDIF
71283  IF(icombi.EQ.4) THEN
71284  rlo4=ps*(1+r1**2-r2**2)
71285  rfo4=x1*(-1-r1**2-r2**2+x1)/(-1-r1**2+r2**2+x1)**2
71286  & +2d0*(-1-r1**2-r2**2+3*x1/2-r1**2*x1/2-r2**2*x1/2
71287  & +x2+r1**2*x2-x1*x2/2)/
71288  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71289  & +(2-6*r1**2+2*r2**2-x1+r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2
71290  & -r2**2*x2+x1*x2+x2**2)/(-1+r1**2-r2**2+x2)**2
71291  isset4=1
71292  ENDIF
71293 
71294 C...~q -> q chi.
71295  ELSEIF(iclass.EQ.11) THEN
71296  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71297  rlo1=ps*(1d0-(r1+r2)**2)
71298  rfo1=(1+r1**2+2*r1*r2+r2**2-x1-x2)*(x1+x2)/(-2+x1+x2)**2
71299  & -(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71300  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
71301  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71302  & +(-1-2*r1**2-r1**4-2*r1*r2-2*r1**3*r2+2*r1*r2**3+r2**4
71303  & +x1+r1**2*x1-2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
71304  & +x1*x2+x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71305  isset1=1
71306  ENDIF
71307  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71308  rlo2=ps*(1d0-(r1-r2)**2)
71309  rfo2=(1+r1**2-2*r1*r2+r2**2-x1-x2)*(x1+x2)/
71310  & (-2+x1+x2)**2
71311  & -(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71312  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2
71313  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71314  & +(-1-2*r1**2-r1**4+2*r1*r2+2*r1**3*r2-2*r1*r2**3+r2**4
71315  & +x1+r1**2*x1+2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
71316  & +x1*x2+x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71317  isset2=1
71318  ENDIF
71319  IF(icombi.EQ.4) THEN
71320  rlo4=ps*(1d0-r1**2-r2**2)
71321  rfo4=(1+r1**2+r2**2-x1-x2)*(x1+x2)/(-2+x1+x2)**2
71322  & -(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1+x2
71323  & +3*r1**2*x2-r2**2*x2-x1*x2)/
71324  & (-1+r1**2-r2**2+x2)**2
71325  & -(-1-2*r1**2-r1**4+r2**4+x1+r1**2*x1-3*r2**2*x1
71326  & +2*r1**2*x2-2*r2**2*x2+x1*x2+x2**2)/
71327  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71328  isset4=1
71329  ENDIF
71330 
71331 C...q -> ~q chi.
71332  ELSEIF(iclass.EQ.12) THEN
71333  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71334  rlo1=ps*(1d0-r1**2+r2**2+2d0*r2)
71335  rfo1=(2*r2+x2)*(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
71336  & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1-2*r2*x1+r2**2*x1+x1**2
71337  & -3*x2-r1**2*x2-2*r2*x2+r2**2*x2+x1*x2)/
71338  & (-2+x1+x2)**2-2*(-1-r1**2+r2+r1**2*r2-r2**2-r2**3+x1
71339  & +r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
71340  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71341  isset1=1
71342  END IF
71343  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71344  rlo2=ps*(1d0-r1**2+r2**2-2d0*r2)
71345  rfo2=(2*r2-x2)*(1+r1**2+r2**2-x2)/(-1+r1**2-r2**2+x2)**2
71346  & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+2*r2*x1+r2**2*x1+x1**2
71347  & -3*x2-r1**2*x2+2*r2*x2+r2**2*x2+x1*x2)/
71348  & (-2+x1+x2)**2-2*(-1-r1**2-r2-r1**2*r2-r2**2+r2**3+x1
71349  & -r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
71350  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71351  isset2=1
71352  END IF
71353  IF(icombi.EQ.4) THEN
71354  rlo4=ps*(1d0-r1**2+r2**2)
71355  rfo4=x2*(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
71356  & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+r2**2*x1+x1**2
71357  & -3*x2-r1**2*x2+r2**2*x2+x1*x2)/
71358  & (-2+x1+x2)**2-2*(-1-r1**2-r2**2+x1+r2**2*x1+2*x2
71359  & +r1**2*x2-x1*x2/2-x2**2/2)/
71360  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71361  isset4=1
71362  END IF
71363 
71364 C...~g -> q ~qbar.
71365  ELSEIF(iclass.EQ.13) THEN
71366  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71367  rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
71368  rfo1=4*(2*r1+x1)*(-1-r1**2-r2**2+x1)/(3*(-1-r1**2+r2**2+x1)**2)
71369  & -(-1-r1**2-2*r1**3-r2**2-2*r1*r2**2+3*x1/2+r1*x1-r1**2*x1/2
71370  & -r2**2*x1/2+x2+r1*x2+r1**2*x2-x1*x2/2)/(3*(-1-r1**2+r2**2
71371  & +x1)*(-1+r1**2-r2**2+x2))-3*(-1+r1-r1**2-r1**3-r2**2
71372  & +r1*r2**2+2*x1+r2**2*x1-x1**2/2+x2+r1*x2+r1**2*x2-x1*x2/2)/
71373  & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+3*(4-4*r1**2+4*r2**2-3*x1
71374  & -2*r1*x1+r1**2*x1-r2**2*x1-5*x2-2*r1*x2+r1**2*x2-r2**2*x2
71375  & +x1*x2+x2**2)/(-2+x1+x2)**2+3*(3-r1-5*r1**2-r1**3+3*r2**2
71376  & +r1*r2**2-2*x1-r1*x1+r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2
71377  & +x1*x2+x2**2)/((1-r1**2+r2**2-x2)*(-2+x1+x2))+4*(2-2*r1
71378  & -6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1-r2**2*x1
71379  & -3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71380  & (3*(-1+r1**2-r2**2+x2)**2)
71381  rfo1=3d0*rfo1/4d0
71382  isset1=1
71383  ENDIF
71384  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71385  rlo2=ps*(1d0+r1**2-r2**2-2d0*r1)
71386  rfo2=4*(2*r1-x1)*(1+r1**2+r2**2-x1)/(3*(-1-r1**2+r2**2+x1)**2)
71387  & -3*(-1-r1-r1**2+r1**3-r2**2-r1*r2**2+2*x1+r2**2*x1-x1**2/2
71388  & +x2-r1*x2+r1**2*x2-x1*x2/2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
71389  & +(2+2*r1**2-4*r1**3+2*r2**2-4*r1*r2**2-3*x1+2*r1*x1
71390  & +r1**2*x1+r2**2*x1-2*x2+2*r1*x2-2*r1**2*x2+x1*x2)/
71391  & (6*(-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+3*(4-4*r1**2
71392  & +4*r2**2-3*x1+2*r1*x1+r1**2*x1-r2**2*x1-5*x2+2*r1*x2
71393  & +r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2+3*(3+r1
71394  & -5*r1**2+r1**3+3*r2**2-r1*r2**2-2*x1+r1*x1+r1**2*x1-4*x2
71395  & +2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71396  & ((1-r1**2+r2**2-x2)*(-2+x1+x2))+4*(2+2*r1-6*r1**2+2*r1**3
71397  & +2*r2**2+2*r1*r2**2-x1+r1**2*x1-r2**2*x1-3*x2-2*r1*x2
71398  & +3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71399  & (3*(-1+r1**2-r2**2+x2)**2)
71400  rfo2=3d0*rfo2/4d0
71401  isset2=1
71402  ENDIF
71403  IF(icombi.EQ.4) THEN
71404  rlo4=ps*(1d0+r1**2-r2**2)
71405  rfo4=8*x1*(-1-r1**2-r2**2+x1)/(3*(-1-r1**2+r2**2+x1)**2)-6*(-1
71406  & -r1**2-r2**2+2*x1+r2**2*x1-x1**2/2+x2+r1**2*x2-x1*x2/2)/
71407  & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+(2+2*r1**2+2*r2**2-3*x1
71408  & +r1**2*x1+r2**2*x1-2*x2-2*r1**2*x2+x1*x2)/(3*(-1-r1**2
71409  & +r2**2+x1)*(-1+r1**2-r2**2+x2))+6*(4-4*r1**2+4*r2**2-3*x1
71410  & +r1**2*x1-r2**2*x1-5*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71411  & (-2+x1+x2)**2+6*(3-5*r1**2+3*r2**2-2*x1+r1**2*x1-4*x2
71412  & +2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71413  & ((1-r1**2+r2**2-x2)*(-2+x1+x2))+8*(2-6*r1**2+2*r2**2-x1
71414  & +r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71415  & (3*(-1+r1**2-r2**2+x2)**2)
71416  rfo4=3d0*rfo4/8d0
71417  isset4=1
71418  ENDIF
71419 
71420 C...~q -> q ~g.
71421  ELSEIF(iclass.EQ.14) THEN
71422  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71423  rlo1=ps*(1-r1**2-r2**2-2d0*r1*r2)
71424  rfo1=64*(1+r1**2+2*r1*r2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)
71425  & -16*(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71426  & +r2**4+x1-r1**2*x1+2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71427  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2-16*(r1**2+r1**4
71428  & -2*r1**3*r2+r2**2-6*r1**2*r2**2-2*r1*r2**3+r2**4
71429  & -r1**2*x1+r1*r2*x1+2*r2**2*x1+2*r1**2*x2+r1*r2*x2-r2**2*x2
71430  & -x1*x2)/((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))
71431  & -64*(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71432  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
71433  & -r2**2*x2-x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)
71434  & +8*(-1+r1**4-2*r1*r2+2*r1**3*r2-2*r2**2-2*r1*r2**3-r2**4
71435  & -2*r1**2*x1+2*r2**2*x1+x1**2+x2-3*r1**2*x2-2*r1*r2*x2
71436  & +r2**2*x2+x1*x2)/((-1-r1**2+r2**2+x1)*(-2+x1+x2))
71437  rfo1=rfo1
71438  & +8*(-1-2*r1**2-r1**4-2*r1*r2-2*r1**3*r2+2*r1*r2**3+r2**4
71439  & +x1+r1**2*x1-2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
71440  & +x1*x2+x2**2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71441  rfo1=9d0*rfo1/64d0
71442  isset1=1
71443  ENDIF
71444  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71445  rlo2=ps*(1-r1**2-r2**2+2d0*r1*r2)
71446  rfo2=64*(1+r1**2-2*r1*r2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)
71447  & -16*(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71448  & +r2**4+x1-r1**2*x1-2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71449  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2-64*(-1+r1**4
71450  & +2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3+r2**4+x1
71451  & -r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2-r2**2*x2
71452  & -x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)+16*(-r1**2-r1**4
71453  & -2*r1**3*r2-r2**2+6*r1**2*r2**2-2*r1*r2**3-r2**4+r1**2*x1
71454  & +r1*r2*x1-2*r2**2*x1-2*r1**2*x2+r1*r2*x2+r2**2*x2+x1*x2)/
71455  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))
71456  rfo2=rfo2
71457  & +8*(-1+r1**4+2*r1*r2-2*r1**3*r2-2*r2**2+2*r1*r2**3-r2**4
71458  & -2*r1**2*x1+2*r2**2*x1+x1**2+x2-3*r1**2*x2+2*r1*r2*x2
71459  & +r2**2*x2+x1*x2)/((-1-r1**2+r2**2+x1)*(-2+x1+x2))
71460  & +8*(-1-2*r1**2-r1**4+2*r1*r2+2*r1**3*r2-2*r1*r2**3
71461  & +r2**4+x1+r1**2*x1+2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2
71462  & -2*r2**2*x2+x1*x2+x2**2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71463  rfo2=9d0*rfo2/64d0
71464  isset2=1
71465  ENDIF
71466  IF(icombi.EQ.4) THEN
71467  rlo4=ps*(1-r1**2-r2**2)
71468  rfo4=128*(1+r1**2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)-32*(-1
71469  & +r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+3*r2**2*x1+x2
71470  & +r1**2*x2-r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71471  & -32*(r1**2+r1**4+r2**2-6*r1**2*r2**2+r2**4-r1**2*x1
71472  & +2*r2**2*x1+2*r1**2*x2-r2**2*x2-x1*x2)/
71473  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))-128*(-1+r1**4
71474  & -6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2
71475  & -r2**2*x2-x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)
71476  & +16*(-1+r1**4-2*r2**2-r2**4-2*r1**2*x1+2*r2**2*x1+x1**2
71477  & +x2-3*r1**2*x2+r2**2*x2+x1*x2)/
71478  & ((-1-r1**2+r2**2+x1)*(-2+x1+ x2))
71479  rfo4=rfo4+16*(-1-2*r1**2-r1**4+r2**4+x1+r1**2*x1-3*r2**2*x1
71480  & +2*r1**2*x2-2*r2**2*x2+x1*x2+x2**2)/
71481  & (9*(1-r1**2+r2**2-x2)*(-2+x1+x2))
71482  rfo4=9d0*rfo4/128d0
71483  isset4=1
71484  ENDIF
71485 
71486 C...q -> ~q ~g.
71487  ELSEIF(iclass.EQ.15) THEN
71488  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71489  rlo1=ps*(1d0-r1**2+r2**2+2d0*r2)
71490  rfo1=32*(2*r2+x2)*(-1-r1**2-r2**2+x2)/(9*(-1+r1**2-r2**2+x2)**2)
71491  & +8*(-1-r1**2-2*r1**2*r2-r2**2-2*r2**3+x1+r2*x1+r2**2*x1
71492  & +3*x2/2-r1**2*x2/2+r2*x2-r2**2*x2/2-x1*x2/2)/
71493  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+8*(2+2*r1**2-2*r2
71494  & -2*r1**2*r2-6*r2**2-2*r2**3-3*x1-r1**2*x1+2*r2*x1
71495  & +3*r2**2*x1+x1**2-x2-r1**2*x2+r2**2*x2+x1*x2)/
71496  & (-1-r1**2+r2**2+x1)**2+32*(4+4*r1**2-4*r2**2-5*x1
71497  & -r1**2*x1-2*r2*x1+r2**2*x1+x1**2-3*x2-r1**2*x2-2*r2*x2
71498  & +r2**2*x2+x1*x2)/(9*(-2+x1+x2)**2)
71499  rfo1=rfo1+8*(3+3*r1**2-r2+r1**2*r2-5*r2**2-r2**3-4*x1-r1**2*x1
71500  & +2*r2**2*x1+x1**2-2*x2-r2*x2+r2**2*x2+x1*x2)/
71501  & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+8*(-1-r1**2+r2+r1**2*r2
71502  & -r2**2-r2**3+x1+r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2
71503  & -x2**2/2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71504  rfo1=9d0*rfo1/32d0
71505  isset1=1
71506  END IF
71507  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71508  rlo2=ps*(1d0-r1**2+r2**2-2d0*r2)
71509  rfo2=32*(2*r2-x2)*(1+r1**2+r2**2-x2)/(9*(-1+r1**2-r2**2+x2)**2)
71510  & +8*(-1-r1**2+2*r1**2*r2-r2**2+2*r2**3+x1-r2*x1+r2**2*x1
71511  & +3*x2/2-r1**2*x2/2-r2*x2-r2**2*x2/2-x1*x2/2)/
71512  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+8*(2+2*r1**2+2*r2
71513  & +2*r1**2*r2-6*r2**2+2*r2**3-3*x1-r1**2*x1-2*r2*x1
71514  & +3*r2**2*x1+x1**2-x2-r1**2*x2+r2**2*x2+x1*x2)/
71515  & (-1-r1**2+r2**2+x1)**2+8*(3+3*r1**2+r2-r1**2*r2-5*r2**2
71516  & +r2**3-4*x1-r1**2*x1+2*r2**2*x1+x1**2-2*x2+r2*x2+r2**2*x2
71517  & +x1*x2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
71518  rfo2=rfo2+32*(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+2*r2*x1+r2**2*x1
71519  & +x1**2-3*x2-r1**2*x2+2*r2*x2+r2**2*x2+x1*x2)/
71520  & (9*(-2+x1+x2)**2)+8*(-1-r1**2-r2-r1**2*r2-r2**2+r2**3+x1
71521  & -r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
71522  & (9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71523  rfo2=9d0*rfo2/32d0
71524  isset2=1
71525  END IF
71526  IF(icombi.EQ.4) THEN
71527  rlo4=ps*(1d0-r1**2+r2**2)
71528  rfo4=64*x2*(-1-r1**2-r2**2+x2)/(9*(-1+r1**2-r2**2+x2)**2)
71529  & +16*(-1-r1**2-r2**2+x1+r2**2*x1+3*x2/2-r1**2*x2/2
71530  & -r2**2*x2/2-x1*x2/2)/
71531  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+16*(3+3*r1**2
71532  & -5*r2**2-4*x1-r1**2*x1+2*r2**2*x1+x1**2-2*x2+r2**2*x2
71533  & +x1*x2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
71534  & +64*(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+r2**2*x1+x1**2-3*x2
71535  & -r1**2*x2+r2**2*x2+x1*x2)/(9*(-2+x1+x2)**2)
71536  rfo4=rfo4+16*(2+2*r1**2-6*r2**2-3*x1-r1**2*x1+3*r2**2*x1+x1**2
71537  & -x2-r1**2*x2+r2**2*x2+x1*x2)/(-1-r1**2+r2**2+x1)**2
71538  & +16*(-1-r1**2-r2**2+x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2
71539  & -x2**2/2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71540  rfo4=9d0*rfo4/64d0
71541  isset4=1
71542  END IF
71543 
71544 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71545  ELSEIF(iclass.EQ.16) THEN
71546  rlo=ps
71547  IF(icombi.EQ.0.OR.icombi.EQ.1) THEN
71548  anum=0d0
71549  ELSEIF(icombi.EQ.2) THEN
71550  anum=(2d0-x1-x2)**2
71551  ELSEIF(icombi.EQ.3) THEN
71552  anum=alpcor*(2d0-x1-x2)**2
71553  ELSE
71554  anum=0.5d0*(2d0-x1-x2)**2
71555  ENDIF
71556  rfo=ps*2d0*((x1+x2-1d0+anum-r1**2-r2**2)/
71557  & ((1d0+r1**2-r2**2-x1)*(1d0+r2**2-r1**2-x2))-
71558  & r1**2/(1d0+r2**2-r1**2-x2)**2-
71559  & r2**2/(1d0+r1**2-r2**2-x1)**2)
71560  rfo=9d0*rfo/4d0
71561  icombi=0
71562  ENDIF
71563 
71564 C...Find relevant LO and FO expression.
71565  IF(icombi.EQ.0) THEN
71566  ELSEIF(icombi.EQ.1.AND.isset1.EQ.1) THEN
71567  rlo=rlo1
71568  rfo=rfo1
71569  ELSEIF(icombi.EQ.2.AND.isset2.EQ.1) THEN
71570  rlo=rlo2
71571  rfo=rfo2
71572  ELSEIF(icombi.EQ.3.AND.isset1.EQ.1.AND.isset2.EQ.1) THEN
71573  rlo=alpcor*rlo1+(1d0-alpcor)*rlo2
71574  rfo=alpcor*rfo1+(1d0-alpcor)*rfo2
71575  ELSEIF(isset4.EQ.1) THEN
71576  rlo=rlo4
71577  rfo=rfo4
71578  ELSEIF(icombi.EQ.4.AND.isset1.EQ.1.AND.isset2.EQ.1) THEN
71579  rlo=0.5d0*(rlo1+rlo2)
71580  rfo=0.5d0*(rfo1+rfo2)
71581  ELSEIF(isset1.EQ.1) THEN
71582  rlo=rlo1
71583  rfo=rfo1
71584  ELSE
71585  CALL pyerrm(16,'(PYMAEL:) not implemented ME code')
71586  rlo=1d0
71587  rfo=0d0
71588  ENDIF
71589 
71590 C...Output.
71591  pymael=rfo/rlo
71592 
71593  RETURN
71594  END
71595 
71596 C*********************************************************************
71597 
71598 C...PYBOEI
71599 C...Modifies an event so as to approximately take into account
71600 C...Bose-Einstein effects according to a simple phenomenological
71601 C...parametrization.
71602 
71603  SUBROUTINE pyboei(NSAV)
71604 
71605 C...Double precision and integer declarations.
71606  IMPLICIT DOUBLE PRECISION(a-h, o-z)
71607  IMPLICIT INTEGER(I-N)
71608  INTEGER PYK,PYCHGE,PYCOMP
71609 C...Parameter statement to help give large particle numbers.
71610  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
71611  &kexcit=4000000,kdimen=5000000)
71612 C...Commonblocks.
71613  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
71614  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
71615  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
71616  common/pyint1/mint(400),vint(400)
71617  SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/
71618 C...Local arrays and data.
71619  dimension dps(4),kfbe(9),nbe(0:10),bei(100),bei3(100),
71620  &beiw(100),bei3w(100)
71621  DATA kfbe/211,-211,111,321,-321,130,310,221,331/
71622 C...Statement function: squared invariant mass.
71623  sdip(i,j)=((p(i,4)+p(j,4))**2-(p(i,3)+p(j,3))**2-
71624  &(p(i,2)+p(j,2))**2-(p(i,1)+p(j,1))**2)
71625 
71626 C...Boost event to overall CM frame. Calculate CM energy.
71627  IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
71628  DO 100 j=1,4
71629  dps(j)=0d0
71630  100 CONTINUE
71631  DO 120 i=1,n
71632  kfa=iabs(k(i,2))
71633  IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22)
71634  & .AND.k(i,3).GT.0) THEN
71635  kfma=iabs(k(k(i,3),2))
71636  IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)
71637  ENDIF
71638  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120
71639  DO 110 j=1,4
71640  dps(j)=dps(j)+p(i,j)
71641  110 CONTINUE
71642  120 CONTINUE
71643  CALL pyrobo(0,0,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
71644  &-dps(3)/dps(4))
71645  pecm=0d0
71646  DO 130 i=1,n
71647  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
71648  130 CONTINUE
71649 
71650 C...Check if we have separated strings
71651 
71652 C...Reserve copy of particles by species at end of record.
71653  iwp=0
71654  iwn=0
71655  nbe(0)=n+mstu(3)
71656  nmax=nbe(0)
71657  smmin=pecm
71658  DO 190 ibe=1,min(10,mstj(52)+1)
71659  nbe(ibe)=nbe(ibe-1)
71660  DO 180 i=nsav+1,n
71661  IF(ibe.EQ.min(10,mstj(52)+1)) THEN
71662  DO 140 iibe=1,ibe-1
71663  IF(k(i,2).EQ.kfbe(iibe)) GOTO 180
71664  140 CONTINUE
71665  ELSE
71666  IF(k(i,2).NE.kfbe(ibe)) GOTO 180
71667  ENDIF
71668  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 180
71669  IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
71670  CALL pyerrm(11,'(PYBOEI:) no more memory left in PYJETS')
71671  RETURN
71672  ENDIF
71673  nbe(ibe)=nbe(ibe)+1
71674  nmax=nbe(ibe)
71675  k(nbe(ibe),1)=i
71676  k(nbe(ibe),2)=0
71677  k(nbe(ibe),3)=0
71678  k(nbe(ibe),4)=0
71679  k(nbe(ibe),5)=0
71680  p(nbe(ibe),1)=0.0d0
71681  p(nbe(ibe),2)=0.0d0
71682  p(nbe(ibe),3)=0.0d0
71683  p(nbe(ibe),4)=0.0d0
71684  p(nbe(ibe),5)=0.0d0
71685  smmin=min(smmin,p(i,5))
71686 C...Check if particles comes from different W's or Z's
71687  IF((mstj(53).NE.0.OR.mstj(56).GT.0).AND.mint(32).EQ.0) THEN
71688  im=i
71689  150 IF(k(im,3).GT.0) THEN
71690  im=k(im,3)
71691  IF(abs(k(im,2)).NE.24.AND.k(im,2).NE.23) GOTO 150
71692  k(nbe(ibe),5)=im
71693  IF(iwp.EQ.0.AND.k(im,2).EQ.24) iwp=im
71694  IF(iwn.EQ.0.AND.k(im,2).EQ.-24) iwn=im
71695  IF(iwp.EQ.0.AND.k(im,2).EQ.23) iwp=im
71696  IF(iwn.EQ.0.AND.k(im,2).EQ.23.AND.im.NE.iwp) iwn=im
71697  ENDIF
71698  ENDIF
71699 C...Check if particles comes from different strings.
71700  IF(parj(94).GT.0.0d0) THEN
71701  im=i
71702  160 IF(k(im,3).GT.0) THEN
71703  im=k(im,3)
71704  IF(k(im,2).NE.92.AND.k(im,2).NE.91) GOTO 160
71705  k(nbe(ibe),5)=im
71706  ENDIF
71707  ENDIF
71708  DO 170 j=1,3
71709  p(nbe(ibe),j)=0d0
71710  v(nbe(ibe),j)=0d0
71711  170 CONTINUE
71712  p(nbe(ibe),5)=-1.0d0
71713  180 CONTINUE
71714  190 CONTINUE
71715  IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) GOTO 510
71716 
71717 C...Calculate separation between W+ and W- or between two Z0's.
71718 C...No separation if there has been re-connections.
71719  sigw=parj(93)
71720  IF(iwp.GT.0.AND.iwn.GT.0.AND.mstj(56).GT.0.AND.mint(32).EQ.0) THEN
71721  IF(k(iwp,2).EQ.23) THEN
71722  dmw=pmas(23,1)
71723  dgw=pmas(23,2)
71724  ELSE
71725  dmw=pmas(24,1)
71726  dgw=pmas(24,2)
71727  ENDIF
71728  dmp=p(iwp,5)
71729  dmn=p(iwn,5)
71730  taupd=dmp/sqrt((dmp**2-dmw**2)**2+(dgw*(dmp**2)/dmw)**2)
71731  taund=dmn/sqrt((dmn**2-dmw**2)**2+(dgw*(dmn**2)/dmw)**2)
71732  taup=-taupd*log(pyr(idum))
71733  taun=-taund*log(pyr(idum))
71734  dxp=taup*pyp(iwp,8)/dmp
71735  dxn=taun*pyp(iwn,8)/dmn
71736  dx=dxp+dxn
71737  sigw=1.0d0/(1.0d0/parj(93)+real(mstj(56))*dx)
71738  IF(parj(94).LT.0.0d0) sigw=1.0d0/(1.0d0/sigw-1.0d0/parj(94))
71739  ENDIF
71740 
71741 C...Add separation between strings.
71742  IF(parj(94).GT.0.0d0) THEN
71743  sigw=1.0d0/(1.0d0/sigw+1.0d0/parj(94))
71744  iwp=-1
71745  iwn=-1
71746  ENDIF
71747 
71748  IF(mstj(57).EQ.1.AND.mstj(54).LT.0) THEN
71749  DO 220 ibe=1,min(9,mstj(52))
71750  DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)
71751  q2min=pecm**2
71752  i1=k(i1m,1)
71753  DO 200 i2m=nbe(ibe-1)+1,nbe(ibe)
71754  IF(i2m.EQ.i1m) GOTO 200
71755  i2=k(i2m,1)
71756  q2=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-
71757  & (p(i1,2)+p(i2,2))**2-(p(i1,3)+p(i2,3))**2-
71758  & (p(i1,5)+p(i2,5))**2
71759  IF(q2.GT.0.0d0.AND.q2.LT.q2min) THEN
71760  q2min=q2
71761  ENDIF
71762  200 CONTINUE
71763  p(i1m,5)=q2min
71764  210 CONTINUE
71765  220 CONTINUE
71766  ENDIF
71767 
71768 C...Tabulate integral for subsequent momentum shift.
71769  DO 400 ibe=1,min(9,mstj(52))
71770  IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) GOTO 270
71771  IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))
71772  & .LE.1) GOTO 270
71773  IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
71774  & nbe(7)-nbe(6)).LE.1) GOTO 270
71775  IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) GOTO 270
71776  IF(ibe.EQ.1) pmhq=2d0*pymass(211)
71777  IF(ibe.EQ.4) pmhq=2d0*pymass(321)
71778  IF(ibe.EQ.8) pmhq=2d0*pymass(221)
71779  IF(ibe.EQ.9) pmhq=2d0*pymass(331)
71780  qdel=0.1d0*min(pmhq,parj(93))
71781  qdel3=0.1d0*min(pmhq,parj(93)*3.0d0)
71782  qdelw=0.1d0*min(pmhq,sigw)
71783  qdel3w=0.1d0*min(pmhq,sigw*3.0d0)
71784  IF(mstj(51).EQ.1) THEN
71785  nbin=min(100,nint(9d0*parj(93)/qdel))
71786  nbin3=min(100,nint(27d0*parj(93)/qdel3))
71787  nbinw=min(100,nint(9d0*sigw/qdelw))
71788  nbin3w=min(100,nint(27d0*sigw/qdel3w))
71789  beex=exp(0.5d0*qdel/parj(93))
71790  beex3=exp(0.5d0*qdel3/(3.0d0*parj(93)))
71791  beexw=exp(0.5d0*qdelw/sigw)
71792  beex3w=exp(0.5d0*qdel3w/(3.0d0*sigw))
71793  bert=exp(-qdel/parj(93))
71794  bert3=exp(-qdel3/(3.0d0*parj(93)))
71795  bertw=exp(-qdelw/sigw)
71796  bert3w=exp(-qdel3w/(3.0d0*sigw))
71797  ELSE
71798  nbin=min(100,nint(3d0*parj(93)/qdel))
71799  nbin3=min(100,nint(9d0*parj(93)/qdel3))
71800  nbinw=min(100,nint(3d0*sigw/qdelw))
71801  nbin3w=min(100,nint(9d0*sigw/qdel3w))
71802  ENDIF
71803  DO 230 ibin=1,nbin
71804  qbin=qdel*(ibin-0.5d0)
71805  bei(ibin)=qdel*(qbin**2+qdel**2/12d0)/sqrt(qbin**2+pmhq**2)
71806  IF(mstj(51).EQ.1) THEN
71807  beex=beex*bert
71808  bei(ibin)=bei(ibin)*beex
71809  ELSE
71810  bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
71811  ENDIF
71812  IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
71813  230 CONTINUE
71814  DO 240 ibin=1,nbin3
71815  qbin=qdel3*(ibin-0.5d0)
71816  bei3(ibin)=qdel3*(qbin**2+qdel3**2/12d0)/sqrt(qbin**2+pmhq**2)
71817  IF(mstj(51).EQ.1) THEN
71818  beex3=beex3*bert3
71819  bei3(ibin)=bei3(ibin)*beex3
71820  ELSE
71821  bei3(ibin)=bei3(ibin)*exp(-(qbin/(3.0d0*parj(93)))**2)
71822  ENDIF
71823  IF(ibin.GE.2) bei3(ibin)=bei3(ibin)+bei3(ibin-1)
71824  240 CONTINUE
71825  DO 250 ibin=1,nbinw
71826  qbin=qdelw*(ibin-0.5d0)
71827  beiw(ibin)=qdelw*(qbin**2+qdelw**2/12d0)/sqrt(qbin**2+pmhq**2)
71828  IF(mstj(51).EQ.1) THEN
71829  beexw=beexw*bertw
71830  beiw(ibin)=beiw(ibin)*beexw
71831  ELSE
71832  beiw(ibin)=beiw(ibin)*exp(-(qbin/sigw)**2)
71833  ENDIF
71834  IF(ibin.GE.2) beiw(ibin)=beiw(ibin)+beiw(ibin-1)
71835  250 CONTINUE
71836  DO 260 ibin=1,nbin3w
71837  qbin=qdel3w*(ibin-0.5d0)
71838  bei3w(ibin)=qdel3w*(qbin**2+qdel3w**2/12d0)/
71839  & sqrt(qbin**2+pmhq**2)
71840  IF(mstj(51).EQ.1) THEN
71841  beex3w=beex3w*bert3w
71842  bei3w(ibin)=bei3w(ibin)*beex3w
71843  ELSE
71844  bei3w(ibin)=bei3w(ibin)*exp(-(qbin/(3.0d0*sigw))**2)
71845  ENDIF
71846  IF(ibin.GE.2) bei3w(ibin)=bei3w(ibin)+bei3w(ibin-1)
71847  260 CONTINUE
71848 
71849 C...Loop through particle pairs and find old relative momentum.
71850  270 DO 390 i1m=nbe(ibe-1)+1,nbe(ibe)-1
71851  i1=k(i1m,1)
71852  DO 380 i2m=i1m+1,nbe(ibe)
71853  IF(mstj(53).EQ.1.AND.k(i1m,5).NE.k(i2m,5)) GOTO 380
71854  IF(mstj(53).EQ.2.AND.k(i1m,5).EQ.k(i2m,5)) GOTO 380
71855  i2=k(i2m,1)
71856  q2old=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
71857  & p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2
71858  IF(q2old.LE.0.0d0) GOTO 380
71859  qold=sqrt(q2old)
71860 
71861 C...Calculate new relative momentum.
71862  qmov=0.0d0
71863  qmov3=0.0d0
71864  qmovw=0.0d0
71865  qmov3w=0.0d0
71866  IF(qold.LT.1d-3*qdel) THEN
71867  GOTO 280
71868  ELSEIF(qold.LE.qdel) THEN
71869  qmov=qold/3d0
71870  ELSEIF(qold.LT.(nbin-0.1d0)*qdel) THEN
71871  rbin=qold/qdel
71872  ibin=rbin
71873  rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
71874  qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
71875  & sqrt(q2old+pmhq**2)/q2old
71876  ELSE
71877  qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
71878  ENDIF
71879  280 q2new=q2old*(qold/(qold+3d0*parj(92)*qmov))**(2d0/3d0)
71880  IF(qold.LT.1d-3*qdel3) THEN
71881  GOTO 290
71882  ELSEIF(qold.LE.qdel3) THEN
71883  qmov3=qold/3d0
71884  ELSEIF(qold.LT.(nbin3-0.1d0)*qdel3) THEN
71885  rbin3=qold/qdel3
71886  ibin3=rbin3
71887  rinp3=(rbin3**3-ibin3**3)/(3*ibin3*(ibin3+1)+1)
71888  qmov3=(bei3(ibin3)+rinp3*(bei3(ibin3+1)-bei3(ibin3)))*
71889  & sqrt(q2old+pmhq**2)/q2old
71890  ELSE
71891  qmov3=bei3(nbin3)*sqrt(q2old+pmhq**2)/q2old
71892  ENDIF
71893  290 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3))**(2d0/3d0)
71894  rscale=1.0d0
71895  IF(mstj(54).EQ.2)
71896  & rscale=1.0d0-exp(-(qold/(2d0*parj(93)))**2)
71897  IF((iwp.NE.-1.AND.mstj(56).LE.0).OR.iwp.EQ.0.OR.iwn.EQ.0.OR.
71898  & k(i1m,5).EQ.k(i2m,5)) GOTO 320
71899 
71900  IF(qold.LT.1d-3*qdelw) THEN
71901  GOTO 300
71902  ELSEIF(qold.LE.qdelw) THEN
71903  qmovw=qold/3d0
71904  ELSEIF(qold.LT.(nbinw-0.1d0)*qdelw) THEN
71905  rbinw=qold/qdelw
71906  ibinw=rbinw
71907  rinpw=(rbinw**3-ibinw**3)/(3*ibinw*(ibinw+1)+1)
71908  qmovw=(beiw(ibinw)+rinpw*(beiw(ibinw+1)-beiw(ibinw)))*
71909  & sqrt(q2old+pmhq**2)/q2old
71910  ELSE
71911  qmovw=beiw(nbinw)*sqrt(q2old+pmhq**2)/q2old
71912  ENDIF
71913  300 q2new=q2old*(qold/(qold+3d0*parj(92)*qmovw))**(2d0/3d0)
71914  IF(qold.LT.1d-3*qdel3w) THEN
71915  GOTO 310
71916  ELSEIF(qold.LE.qdel3w) THEN
71917  qmov3w=qold/3d0
71918  ELSEIF(qold.LT.(nbin3w-0.1d0)*qdel3w) THEN
71919  rbin3w=qold/qdel3w
71920  ibin3w=rbin3w
71921  rinp3w=(rbin3w**3-ibin3w**3)/(3*ibin3w*(ibin3w+1)+1)
71922  qmov3w=(bei3w(ibin3w)+rinp3w*(bei3w(ibin3w+1)-
71923  & bei3w(ibin3w)))*sqrt(q2old+pmhq**2)/q2old
71924  ELSE
71925  qmov3w=bei3w(nbin3w)*sqrt(q2old+pmhq**2)/q2old
71926  ENDIF
71927  310 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3w))**(2d0/3d0)
71928  IF(mstj(54).EQ.2)
71929  & rscale=1.0d0-exp(-(qold/(2d0*sigw))**2)
71930 
71931  320 CALL pybesq(i1,i2,nmax,q2old,q2new)
71932  DO 330 j=1,3
71933  p(i1m,j)=p(i1m,j)+p(nmax+1,j)
71934  p(i2m,j)=p(i2m,j)+p(nmax+2,j)
71935  330 CONTINUE
71936  IF(mstj(54).GE.1) THEN
71937  CALL pybesq(i1,i2,nmax,q2old,q2new3)
71938  DO 340 j=1,3
71939  v(i1m,j)=v(i1m,j)+p(nmax+1,j)*rscale
71940  v(i2m,j)=v(i2m,j)+p(nmax+2,j)*rscale
71941  340 CONTINUE
71942  ELSEIF(mstj(54).LE.-1) THEN
71943  edel=p(i1,4)+p(i2,4)-
71944  & sqrt(max(q2new-q2old+(p(i1,4)+p(i2,4))**2,0.0d0))
71945  a2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
71946  & (p(i1,3)-p(i2,3))**2
71947  wmax=-1.0d20
71948  mi3=0
71949  mi4=0
71950  s12=sdip(i1,i2)
71951  sm1=(p(i1,5)+smmin)**2
71952  DO 360 i3m=nbe(0)+1,nbe(min(10,mstj(52)+1))
71953  IF(i3m.EQ.i1m.OR.i3m.EQ.i2m) GOTO 360
71954  IF(mstj(53).EQ.1.AND.k(i3m,5).NE.k(i1m,5)) GOTO 360
71955  IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
71956  & k(i3m,5).NE.k(i1m,5)) GOTO 360
71957  i3=k(i3m,1)
71958  IF(k(i3,2).EQ.k(i1,2)) GOTO 360
71959  s13=sdip(i1,i3)
71960  s23=sdip(i2,i3)
71961  sm3=(p(i3,5)+smmin)**2
71962  IF(mstj(54).EQ.-2) THEN
71963  wi=(min(s12*sm3,s13*min(sm1,sm3),
71964  & s23*min(sm1,sm3))*sm1)
71965  ELSE
71966  wi=((p(i1,4)+p(i2,4)+p(i3,4))**2-
71967  & (p(i1,3)+p(i2,3)+p(i3,3))**2-
71968  & (p(i1,2)+p(i2,2)+p(i3,2))**2-
71969  & (p(i1,1)+p(i2,1)+p(i3,1))**2)
71970  ENDIF
71971  IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0) THEN
71972  IF (wmax*wi.GE.(1.0d0-exp(-p(i3m,5)/(parj(93)**2))))
71973  & GOTO 360
71974  ELSE
71975  IF(wmax*wi.GE.1.0) GOTO 360
71976  ENDIF
71977  DO 350 i4m=i3m+1,nbe(min(10,mstj(52)+1))
71978  IF(i4m.EQ.i1m.OR.i4m.EQ.i2m) GOTO 350
71979  IF(mstj(53).EQ.1.AND.k(i4m,5).NE.k(i1m,5)) GOTO 350
71980  IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
71981  & k(i4m,5).NE.k(i1m,5)) GOTO 350
71982  i4=k(i4m,1)
71983  IF(k(i3,2).EQ.k(i4,2).OR.k(i4,2).EQ.k(i1,2))
71984  & GOTO 350
71985  IF((p(i3,4)+p(i4,4)+edel)**2.LT.
71986  & (p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
71987  & (p(i3,3)+p(i4,3))**2+(p(i3,5)+p(i4,5))**2)
71988  & GOTO 350
71989  IF(mstj(54).EQ.-2) THEN
71990  s14=sdip(i1,i4)
71991  s24=sdip(i2,i4)
71992  s34=sdip(i3,i4)
71993  w=s12*min(min(s23,s24),min(s13,s14))*s34
71994  w=min(w,s13*min(min(s23,s34),s12)*s24)
71995  w=min(w,s14*min(min(s24,s34),s12)*s23)
71996  w=min(w,min(s23,s24)*s13*s14)
71997  w=1.0d0/w
71998  ELSE
71999 C...weight=1-cos(theta)/mtot2
72000  s1234=(p(i1,4)+p(i2,4)+p(i3,4)+p(i4,4))**2-
72001  & (p(i1,3)+p(i2,3)+p(i3,3)+p(i4,3))**2-
72002  & (p(i1,2)+p(i2,2)+p(i3,2)+p(i4,2))**2-
72003  & (p(i1,1)+p(i2,1)+p(i3,1)+p(i4,1))**2
72004  w=1.0d0/s1234
72005  IF(w.LE.wmax) GOTO 350
72006  ENDIF
72007  IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0)
72008  & w=w*(1.0d0-exp(-p(i3m,5)/(parj(93)**2)))
72009  IF(mstj(57).EQ.1.AND.p(i4m,5).GT.0)
72010  & w=w*(1.0d0-exp(-p(i4m,5)/(parj(93)**2)))
72011  IF(w.LE.wmax) GOTO 350
72012  mi3=i3m
72013  mi4=i4m
72014  wmax=w
72015  350 CONTINUE
72016  360 CONTINUE
72017  IF(mi4.EQ.0) GOTO 380
72018  i3=k(mi3,1)
72019  i4=k(mi4,1)
72020  eold=p(i3,4)+p(i4,4)
72021  enew=eold+edel
72022  p2=(p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
72023  & (p(i3,3)+p(i4,3))**2
72024  q2newp=max(0.0d0,enew**2-p2-(p(i3,5)+p(i4,5))**2)
72025  q2oldp=max(0.0d0,eold**2-p2-(p(i3,5)+p(i4,5))**2)
72026  CALL pybesq(i3,i4,nmax,q2oldp,q2newp)
72027  DO 370 j=1,3
72028  v(mi3,j)=v(mi3,j)+p(nmax+1,j)
72029  v(mi4,j)=v(mi4,j)+p(nmax+2,j)
72030  370 CONTINUE
72031  ENDIF
72032  380 CONTINUE
72033  390 CONTINUE
72034  400 CONTINUE
72035 
72036 C...Shift momenta and recalculate energies.
72037  esump=0.0d0
72038  esum=0.0d0
72039  prod=0.0d0
72040  DO 430 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
72041  i=k(im,1)
72042  esump=esump+p(i,4)
72043  DO 410 j=1,3
72044  p(i,j)=p(i,j)+p(im,j)
72045  410 CONTINUE
72046  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
72047  esum=esum+p(i,4)
72048  DO 420 j=1,3
72049  prod=prod+v(im,j)*p(i,j)/p(i,4)
72050  420 CONTINUE
72051  430 CONTINUE
72052 
72053  parj(96)=0.0d0
72054  IF(mstj(54).NE.0.AND.prod.NE.0.0d0) THEN
72055  440 alpha=(esump-esum)/prod
72056  parj(96)=parj(96)+alpha
72057  prod=0.0d0
72058  esum=0.0d0
72059  DO 470 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
72060  i=k(im,1)
72061  DO 450 j=1,3
72062  p(i,j)=p(i,j)+alpha*v(im,j)
72063  450 CONTINUE
72064  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
72065  esum=esum+p(i,4)
72066  DO 460 j=1,3
72067  prod=prod+v(im,j)*p(i,j)/p(i,4)
72068  460 CONTINUE
72069  470 CONTINUE
72070  IF(prod.NE.0.0d0.AND.abs(esump-esum)/pecm.GT.0.00001d0)
72071  & GOTO 440
72072  ENDIF
72073 
72074 C...Rescale all momenta for energy conservation.
72075  pes=0d0
72076  pqs=0d0
72077  DO 480 i=1,n
72078  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 480
72079  pes=pes+p(i,4)
72080  pqs=pqs+p(i,5)**2/p(i,4)
72081  480 CONTINUE
72082  parj(95)=pes-pecm
72083  fac=(pecm-pqs)/(pes-pqs)
72084  DO 500 i=1,n
72085  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 500
72086  DO 490 j=1,3
72087  p(i,j)=fac*p(i,j)
72088  490 CONTINUE
72089  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
72090  500 CONTINUE
72091 
72092 C...Boost back to correct reference frame.
72093  510 CALL pyrobo(0,0,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
72094  DO 520 i=1,n
72095  IF(k(i,1).LT.0) k(i,1)=-k(i,1)
72096  520 CONTINUE
72097 
72098  RETURN
72099  END
72100 
72101 C*********************************************************************
72102 
72103 C...PYBESQ
72104 C...Calculates the momentum shift in a system of two particles assuming
72105 C...the relative momentum squared should be shifted to Q2NEW. NI is the
72106 C...last position occupied in /PYJETS/.
72107 
72108  SUBROUTINE pybesq(I1,I2,NI,Q2OLD,Q2NEW)
72109 
72110 C...Double precision and integer declarations.
72111  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72112  IMPLICIT INTEGER(I-N)
72113  INTEGER PYK,PYCHGE,PYCOMP
72114 C...Parameter statement to help give large particle numbers.
72115  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
72116  &kexcit=4000000,kdimen=5000000)
72117 C...Commonblocks.
72118  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72119  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72120  SAVE /pyjets/,/pydat1/
72121 C...Local arrays and data.
72122  dimension dp(5)
72123  SAVE hc1
72124 
72125  IF(mstj(55).EQ.0) THEN
72126  dq2=q2new-q2old
72127  dp2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
72128  & (p(i1,3)-p(i2,3))**2
72129  dp12=p(i1,1)**2+p(i1,2)**2+p(i1,3)**2
72130  & -p(i2,1)**2-p(i2,2)**2-p(i2,3)**2
72131  se=p(i1,4)+p(i2,4)
72132  de=p(i1,4)-p(i2,4)
72133  dq2se=dq2+se**2
72134  da=se*de*dp12-dp2*dq2se
72135  db=dp2*dq2se-dp12**2
72136  ha=(da+sqrt(max(da**2+dq2*(dq2+se**2-de**2)*db,0d0)))/(2d0*db)
72137  DO 100 j=1,3
72138  pd=ha*(p(i1,j)-p(i2,j))
72139  p(ni+1,j)=pd
72140  p(ni+2,j)=-pd
72141  100 CONTINUE
72142  RETURN
72143  ENDIF
72144 
72145  k(ni+1,1)=1
72146  k(ni+2,1)=1
72147  DO 110 j=1,5
72148  p(ni+1,j)=p(i1,j)
72149  p(ni+2,j)=p(i2,j)
72150  dp(j)=p(i1,j)+p(i2,j)
72151  110 CONTINUE
72152 
72153 C...Boost to cms and rotate first particle to z-axis
72154  CALL pyrobo(ni+1,ni+2,0.0d0,0.0d0,
72155  &-dp(1)/dp(4),-dp(2)/dp(4),-dp(3)/dp(4))
72156  phi=pyangl(p(ni+1,1),p(ni+1,2))
72157  the=pyangl(p(ni+1,3),sqrt(p(ni+1,1)**2+p(ni+1,2)**2))
72158  s=q2new+(p(i1,5)+p(i2,5))**2
72159  pz=0.5d0*sqrt(q2new*(s-(p(i1,5)-p(i2,5))**2)/s)
72160  p(ni+1,1)=0.0d0
72161  p(ni+1,2)=0.0d0
72162  p(ni+1,3)=pz
72163  p(ni+1,4)=sqrt(pz**2+p(i1,5)**2)
72164  p(ni+2,1)=0.0d0
72165  p(ni+2,2)=0.0d0
72166  p(ni+2,3)=-pz
72167  p(ni+2,4)=sqrt(pz**2+p(i2,5)**2)
72168  dp(4)=sqrt(dp(1)**2+dp(2)**2+dp(3)**2+s)
72169  CALL pyrobo(ni+1,ni+2,the,phi,
72170  &dp(1)/dp(4),dp(2)/dp(4),dp(3)/dp(4))
72171 
72172  DO 120 j=1,3
72173  p(ni+1,j)=p(ni+1,j)-p(i1,j)
72174  p(ni+2,j)=p(ni+2,j)-p(i2,j)
72175  120 CONTINUE
72176 
72177  RETURN
72178  END
72179 
72180 C*********************************************************************
72181 
72182 C...PYMASS
72183 C...Gives the mass of a particle/parton.
72184 
72185  FUNCTION pymass(KF)
72186 
72187 C...Double precision and integer declarations.
72188  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72189  IMPLICIT INTEGER(I-N)
72190  INTEGER PYK,PYCHGE,PYCOMP
72191 C...Commonblocks.
72192  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72193  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72194  SAVE /pydat1/,/pydat2/
72195 
72196 C...Reset variables. Compressed code. Special case for popcorn diquarks.
72197  pymass=0d0
72198  kfa=iabs(kf)
72199  kc=pycomp(kf)
72200  IF(kc.EQ.0) THEN
72201  mstj(93)=0
72202  RETURN
72203  ENDIF
72204 
72205 C...Guarantee use of constituent masses for internal checks.
72206  IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.
72207  &(kfa.LE.10.OR.mod(kfa/10,10).EQ.0)) THEN
72208  IF(kfa.LE.5) THEN
72209  pymass=parf(100+kfa)
72210  IF(mstj(93).EQ.2) pymass=max(0d0,pymass-parf(121))
72211  ELSEIF(kfa.LE.10) THEN
72212  pymass=pmas(kfa,1)
72213  ELSEIF(mstj(93).EQ.1) THEN
72214  pymass=parf(100+mod(kfa/1000,10))+parf(100+mod(kfa/100,10))
72215  ELSE
72216  pymass=max(0d0,pmas(kc,1)-parf(122)-2d0*parf(112)/3d0)
72217  ENDIF
72218 
72219 C...Other masses can be read directly off table.
72220  ELSE
72221  pymass=pmas(kc,1)
72222  ENDIF
72223 
72224 C...Optional mass broadening according to truncated Breit-Wigner
72225 C...(either in m or in m^2).
72226  IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1d-4) THEN
72227  IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
72228  pymass=pymass+0.5d0*pmas(kc,2)*tan((2d0*pyr(0)-1d0)*
72229  & atan(2d0*pmas(kc,3)/pmas(kc,2)))
72230  ELSE
72231  pm0=pymass
72232  pmlow=atan((max(0d0,pm0-pmas(kc,3))**2-pm0**2)/
72233  & (pm0*pmas(kc,2)))
72234  pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
72235  pymass=sqrt(max(0d0,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
72236  & (pmupp-pmlow)*pyr(0))))
72237  ENDIF
72238  ENDIF
72239  mstj(93)=0
72240 
72241  RETURN
72242  END
72243 
72244 C*********************************************************************
72245 
72246 C...PYMRUN
72247 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72248 C...for Higgs couplings. Everything else sent on to PYMASS.
72249 
72250  FUNCTION pymrun(KF,Q2)
72251 
72252 C...Double precision and integer declarations.
72253  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72254  IMPLICIT INTEGER(I-N)
72255  INTEGER PYK,PYCHGE,PYCOMP
72256 C...Commonblocks.
72257  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72258  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72259  common/pypars/mstp(200),parp(200),msti(200),pari(200)
72260  SAVE /pydat1/,/pydat2/,/pypars/
72261 
72262 C...Most masses not handled here.
72263  kfa=iabs(kf)
72264  IF(kfa.EQ.0.OR.kfa.GT.6) THEN
72265  pymrun=pymass(kf)
72266 
72267 C...Current-algebra masses, but no Q2 dependence.
72268  ELSEIF(mstp(37).NE.1.OR.mstp(2).LE.0) THEN
72269  pymrun=parf(90+kfa)
72270 
72271 C...Running current-algebra masses.
72272  ELSE
72273  as=pyalps(q2)
72274  pymrun=parf(90+kfa)*
72275  & (log(max(4d0,parp(37)**2*parf(90+kfa)**2/paru(117)**2))/
72276  & log(max(4d0,q2/paru(117)**2)))**(12d0/(33d0-2d0*mstu(118)))
72277  ENDIF
72278 
72279  RETURN
72280  END
72281 
72282 C*********************************************************************
72283 
72284 C...PYNAME
72285 C...Gives the particle/parton name as a character string.
72286 
72287  SUBROUTINE pyname(KF,CHAU)
72288 
72289 C...Double precision and integer declarations.
72290  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72291  IMPLICIT INTEGER(I-N)
72292  INTEGER PYK,PYCHGE,PYCOMP
72293 C...Commonblocks.
72294  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72295  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72296  common/pydat4/chaf(500,2)
72297  CHARACTER CHAF*16
72298  SAVE /pydat1/,/pydat2/,/pydat4/
72299 C...Local character variable.
72300  CHARACTER CHAU*16
72301 
72302 C...Read out code with distinction particle/antiparticle.
72303  chau=' '
72304  kc=pycomp(kf)
72305  IF(kc.NE.0) chau=chaf(kc,(3-isign(1,kf))/2)
72306 
72307 
72308  RETURN
72309  END
72310 
72311 C*********************************************************************
72312 
72313 C...PYCHGE
72314 C...Gives three times the charge for a particle/parton.
72315 
72316  FUNCTION pychge(KF)
72317 
72318 C...Double precision and integer declarations.
72319  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72320  IMPLICIT INTEGER(I-N)
72321  INTEGER PYK,PYCHGE,PYCOMP
72322 C...Commonblocks.
72323  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72324  SAVE /pydat2/
72325 
72326 C...Read out charge and change sign for antiparticle.
72327  pychge=0
72328  kc=pycomp(kf)
72329  IF(kc.NE.0) pychge=kchg(kc,1)*isign(1,kf)
72330 
72331  RETURN
72332  END
72333 
72334 C*********************************************************************
72335 
72336 C...PYCOMP
72337 C...Compress the standard KF codes for use in mass and decay arrays;
72338 C...also checks whether a given code actually is defined.
72339 
72340  FUNCTION pycomp(KF)
72341 
72342 C...Double precision and integer declarations.
72343  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72344  IMPLICIT INTEGER(I-N)
72345  INTEGER PYK,PYCHGE,PYCOMP
72346 C...Commonblocks.
72347  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72348  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72349  SAVE /pydat1/,/pydat2/
72350 C...Local arrays and saved data.
72351  dimension kford(100:500),kcord(101:500)
72352  SAVE kford,kcord,nford,kflast,kclast
72353 
72354 C...Whenever necessary reorder codes for faster search.
72355  IF(mstu(20).EQ.0) THEN
72356  nford=100
72357  kford(100)=0
72358  DO 120 i=101,500
72359  kfa=kchg(i,4)
72360  IF(kfa.LE.100) GOTO 120
72361  nford=nford+1
72362  DO 100 i1=nford-1,0,-1
72363  IF(kfa.GE.kford(i1)) GOTO 110
72364  kford(i1+1)=kford(i1)
72365  kcord(i1+1)=kcord(i1)
72366  100 CONTINUE
72367  110 kford(i1+1)=kfa
72368  kcord(i1+1)=i
72369  120 CONTINUE
72370  mstu(20)=1
72371  kflast=0
72372  kclast=0
72373  ENDIF
72374 
72375 C...Fast action if same code as in latest call.
72376  IF(kf.EQ.kflast) THEN
72377  pycomp=kclast
72378  RETURN
72379  ENDIF
72380 
72381 C...Starting values. Remove internal diquark flags.
72382  pycomp=0
72383  kfa=iabs(kf)
72384  IF(mod(kfa/10,10).EQ.0.AND.kfa.LT.100000
72385  & .AND.mod(kfa/1000,10).GT.0) kfa=mod(kfa,10000)
72386 
72387 C...Simple cases: direct translation.
72388  IF(kfa.GT.kford(nford)) THEN
72389  ELSEIF(kfa.LE.100) THEN
72390  pycomp=kfa
72391 
72392 C...Else binary search.
72393  ELSE
72394  imin=100
72395  imax=nford+1
72396  130 iavg=(imin+imax)/2
72397  IF(kford(iavg).GT.kfa) THEN
72398  imax=iavg
72399  IF(imax.GT.imin+1) GOTO 130
72400  ELSEIF(kford(iavg).LT.kfa) THEN
72401  imin=iavg
72402  IF(imax.GT.imin+1) GOTO 130
72403  ELSE
72404  pycomp=kcord(iavg)
72405  ENDIF
72406  ENDIF
72407 
72408 C...Check if antiparticle allowed.
72409  IF(pycomp.NE.0.AND.kf.LT.0) THEN
72410  IF(kchg(pycomp,3).EQ.0) pycomp=0
72411  ENDIF
72412 
72413 C...Save codes for possible future fast action.
72414  kflast=kf
72415  kclast=pycomp
72416 
72417  RETURN
72418  END
72419 
72420 C*********************************************************************
72421 
72422 C...PYERRM
72423 C...Informs user of errors in program execution.
72424 
72425  SUBROUTINE pyerrm(MERR,CHMESS)
72426 
72427 C...Double precision and integer declarations.
72428  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72429  IMPLICIT INTEGER(I-N)
72430  INTEGER PYK,PYCHGE,PYCOMP
72431 C...Commonblocks.
72432  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72433  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72434  SAVE /pyjets/,/pydat1/
72435 C...Local character variable.
72436  CHARACTER CHMESS*(*)
72437 
72438 C...Write first few warnings, then be silent.
72439  IF(merr.LE.10) THEN
72440  mstu(27)=mstu(27)+1
72441  mstu(28)=merr
72442  IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
72443  & merr,mstu(31),chmess
72444 
72445 C...Write first few errors, then be silent or stop program.
72446  ELSEIF(merr.LE.20) THEN
72447  IF(mstu(29).EQ.0) mstu(23)=mstu(23)+1
72448  mstu(30)=mstu(30)+1
72449  mstu(24)=merr-10
72450  IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
72451  & merr-10,mstu(31),chmess
72452  IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
72453  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
72454  WRITE(mstu(11),5200)
72455  IF(merr.NE.17) CALL pylist(2)
72456  CALL pystop(3)
72457  ENDIF
72458 
72459 C...Stop program in case of irreparable error.
72460  ELSE
72461  WRITE(mstu(11),5300) merr-20,mstu(31),chmess
72462  CALL pystop(3)
72463  ENDIF
72464 
72465 C...Formats for output.
72466  5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i9,
72467  &' PYEXEC calls:'/5x,a)
72468  5100 FORMAT(/5x,'Error type',i2,' has occured after',i9,
72469  &' PYEXEC calls:'/5x,a)
72470  5200 FORMAT(5x,'Execution will be stopped after listing of last ',
72471  &'event!')
72472  5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i9,
72473  &' PYEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
72474 
72475  RETURN
72476  END
72477 
72478 C*********************************************************************
72479 
72480 C...PYALEM
72481 C...Calculates the running alpha_electromagnetic.
72482 
72483  FUNCTION pyalem(Q2)
72484 
72485 C...Double precision and integer declarations.
72486  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72487  IMPLICIT INTEGER(I-N)
72488  INTEGER PYK,PYCHGE,PYCOMP
72489 C...Commonblocks.
72490  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72491  SAVE /pydat1/
72492 
72493 C...Calculate real part of photon vacuum polarization.
72494 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72495 C...For hadrons use parametrization of H. Burkhardt et al.
72496 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72497  aempi=paru(101)/(3d0*paru(1))
72498  IF(mstu(101).LE.0.OR.q2.LT.2d-6) THEN
72499  rpigg=0d0
72500  ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN
72501  rpigg=0d0
72502  ELSEIF(mstu(101).EQ.2) THEN
72503  rpigg=1d0-paru(101)/paru(103)
72504  ELSEIF(q2.LT.0.09d0) THEN
72505  rpigg=aempi*(13.4916d0+log(q2))+0.00835d0*log(1d0+q2)
72506  ELSEIF(q2.LT.9d0) THEN
72507  rpigg=aempi*(16.3200d0+2d0*log(q2))+
72508  & 0.00238d0*log(1d0+3.927d0*q2)
72509  ELSEIF(q2.LT.1d4) THEN
72510  rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00165d0+
72511  & 0.00299d0*log(1d0+q2)
72512  ELSE
72513  rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00221d0+
72514  & 0.00293d0*log(1d0+q2)
72515  ENDIF
72516 
72517 C...Calculate running alpha_em.
72518  pyalem=paru(101)/(1d0-rpigg)
72519  paru(108)=pyalem
72520 
72521  RETURN
72522  END
72523 
72524 C*********************************************************************
72525 
72526 C...PYALPS
72527 C...Gives the value of alpha_strong.
72528 
72529  FUNCTION pyalps(Q2)
72530 
72531 C...Double precision and integer declarations.
72532  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72533  IMPLICIT INTEGER(I-N)
72534  INTEGER PYK,PYCHGE,PYCOMP
72535 C...Commonblocks.
72536  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72537  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72538  SAVE /pydat1/,/pydat2/
72539 C...Coefficients for second-order threshold matching.
72540 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72541  dimension stepdn(6),stepup(6)
72542 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72543 c &(2D0*321D0/3703D0),0D0/
72544 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72545 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72546  DATA stepdn/0d0,0d0,0.10568d0,0.13398d0,0.17337d0,0d0/
72547  DATA stepup/0d0,0d0,0d0,-0.11413d0,-0.14563d0,-0.18988d0/
72548 
72549 C...Constant alpha_strong trivial. Pick artificial Lambda.
72550  IF(mstu(111).LE.0) THEN
72551  pyalps=paru(111)
72552  mstu(118)=mstu(112)
72553  paru(117)=0.2d0
72554  IF(q2.GT.0.04d0) paru(117)=sqrt(q2)*exp(-6d0*paru(1)/
72555  & ((33d0-2d0*mstu(112))*paru(111)))
72556  paru(118)=paru(111)
72557  RETURN
72558  ENDIF
72559 
72560 C...Find effective Q2, number of flavours and Lambda.
72561  q2eff=q2
72562  IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
72563  nf=mstu(112)
72564  alam2=paru(112)**2
72565  100 IF(nf.GT.max(3,mstu(113))) THEN
72566  q2thr=paru(113)*pmas(nf,1)**2
72567  IF(q2eff.LT.q2thr) THEN
72568  nf=nf-1
72569  q2rat=q2thr/alam2
72570  alam2=alam2*q2rat**(2d0/(33d0-2d0*nf))
72571  IF(mstu(111).EQ.2) alam2=alam2*log(q2rat)**stepdn(nf)
72572  GOTO 100
72573  ENDIF
72574  ENDIF
72575  110 IF(nf.LT.min(6,mstu(114))) THEN
72576  q2thr=paru(113)*pmas(nf+1,1)**2
72577  IF(q2eff.GT.q2thr) THEN
72578  nf=nf+1
72579  q2rat=q2thr/alam2
72580  alam2=alam2*q2rat**(-2d0/(33d0-2d0*nf))
72581  IF(mstu(111).EQ.2) alam2=alam2*log(q2rat)**stepup(nf)
72582  GOTO 110
72583  ENDIF
72584  ENDIF
72585  IF(mstu(115).EQ.1) q2eff=q2eff+alam2
72586  paru(117)=sqrt(alam2)
72587 
72588 C...Evaluate first or second order alpha_strong.
72589  b0=(33d0-2d0*nf)/6d0
72590  algq=log(max(1.0001d0,q2eff/alam2))
72591  IF(mstu(111).EQ.1) THEN
72592  pyalps=min(paru(115),paru(2)/(b0*algq))
72593  ELSE
72594  b1=(153d0-19d0*nf)/6d0
72595  pyalps=min(paru(115),paru(2)/(b0*algq)*(1d0-b1*log(algq)/
72596  & (b0**2*algq)))
72597  ENDIF
72598  mstu(118)=nf
72599  paru(118)=pyalps
72600 
72601  RETURN
72602  END
72603 
72604 C*********************************************************************
72605 
72606 C...PYANGL
72607 C...Reconstructs an angle from given x and y coordinates.
72608 
72609  FUNCTION pyangl(X,Y)
72610 
72611 C...Double precision and integer declarations.
72612  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72613  IMPLICIT INTEGER(I-N)
72614  INTEGER PYK,PYCHGE,PYCOMP
72615 C...Commonblocks.
72616  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72617  SAVE /pydat1/
72618 
72619  pyangl=0d0
72620  r=sqrt(x**2+y**2)
72621  IF(r.LT.1d-20) RETURN
72622  IF(abs(x)/r.LT.0.8d0) THEN
72623  pyangl=sign(acos(x/r),y)
72624  ELSE
72625  pyangl=asin(y/r)
72626  IF(x.LT.0d0.AND.pyangl.GE.0d0) THEN
72627  pyangl=paru(1)-pyangl
72628  ELSEIF(x.LT.0d0) THEN
72629  pyangl=-paru(1)-pyangl
72630  ENDIF
72631  ENDIF
72632 
72633  RETURN
72634  END
72635 
72636 C*********************************************************************
72637 
72638 C...PYR
72639 C...Generates random numbers uniformly distributed between
72640 C...0 and 1, excluding the endpoints.
72641 
72642  FUNCTION pyr(IDUMMY)
72643 
72644 C...Double precision and integer declarations.
72645  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72646  IMPLICIT INTEGER(I-N)
72647  INTEGER PYK,PYCHGE,PYCOMP
72648 C...Commonblocks.
72649  common/pydatr/mrpy(6),rrpy(100)
72650  SAVE /pydatr/
72651 C...Equivalence between commonblock and local variables.
72652  equivalence(mrpy1,mrpy(1)),(mrpy2,mrpy(2)),(mrpy3,mrpy(3)),
72653  &(mrpy4,mrpy(4)),(mrpy5,mrpy(5)),(mrpy6,mrpy(6)),
72654  &(rrpy98,rrpy(98)),(rrpy99,rrpy(99)),(rrpy00,rrpy(100))
72655 
72656 C...Initialize generation from given seed.
72657  IF(mrpy2.EQ.0) THEN
72658  ij=mod(mrpy1/30082,31329)
72659  kl=mod(mrpy1,30082)
72660  i=mod(ij/177,177)+2
72661  j=mod(ij,177)+2
72662  k=mod(kl/169,178)+1
72663  l=mod(kl,169)
72664  DO 110 ii=1,97
72665  s=0d0
72666  t=0.5d0
72667  DO 100 jj=1,48
72668  m=mod(mod(i*j,179)*k,179)
72669  i=j
72670  j=k
72671  k=m
72672  l=mod(53*l+1,169)
72673  IF(mod(l*m,64).GE.32) s=s+t
72674  t=0.5d0*t
72675  100 CONTINUE
72676  rrpy(ii)=s
72677  110 CONTINUE
72678  twom24=1d0
72679  DO 120 i24=1,24
72680  twom24=0.5d0*twom24
72681  120 CONTINUE
72682  rrpy98=362436d0*twom24
72683  rrpy99=7654321d0*twom24
72684  rrpy00=16777213d0*twom24
72685  mrpy2=1
72686  mrpy3=0
72687  mrpy4=97
72688  mrpy5=33
72689  ENDIF
72690 
72691 C...Generate next random number.
72692  130 runi=rrpy(mrpy4)-rrpy(mrpy5)
72693  IF(runi.LT.0d0) runi=runi+1d0
72694  rrpy(mrpy4)=runi
72695  mrpy4=mrpy4-1
72696  IF(mrpy4.EQ.0) mrpy4=97
72697  mrpy5=mrpy5-1
72698  IF(mrpy5.EQ.0) mrpy5=97
72699  rrpy98=rrpy98-rrpy99
72700  IF(rrpy98.LT.0d0) rrpy98=rrpy98+rrpy00
72701  runi=runi-rrpy98
72702  IF(runi.LT.0d0) runi=runi+1d0
72703  IF(runi.LE.0d0.OR.runi.GE.1d0) GOTO 130
72704 
72705 C...Update counters. Random number to output.
72706  mrpy3=mrpy3+1
72707  IF(mrpy3.EQ.1000000000) THEN
72708  mrpy2=mrpy2+1
72709  mrpy3=0
72710  ENDIF
72711  pyr=runi
72712 
72713  RETURN
72714  END
72715 
72716 C*********************************************************************
72717 
72718 C...PYRGET
72719 C...Dumps the state of the random number generator on a file
72720 C...for subsequent startup from this state onwards.
72721 
72722  SUBROUTINE pyrget(LFN,MOVE)
72723 
72724 C...Double precision and integer declarations.
72725  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72726  IMPLICIT INTEGER(I-N)
72727  INTEGER PYK,PYCHGE,PYCOMP
72728 C...Commonblocks.
72729  common/pydatr/mrpy(6),rrpy(100)
72730  SAVE /pydatr/
72731 C...Local character variable.
72732  CHARACTER CHERR*8
72733 
72734 C...Backspace required number of records (or as many as there are).
72735  IF(move.LT.0) THEN
72736  nbck=min(mrpy(6),-move)
72737  DO 100 ibck=1,nbck
72738  backspace(lfn,err=110,iostat=ierr)
72739  100 CONTINUE
72740  mrpy(6)=mrpy(6)-nbck
72741  ENDIF
72742 
72743 C...Unformatted write on unit LFN.
72744  WRITE(lfn,err=110,iostat=ierr) (mrpy(i1),i1=1,5),
72745  &(rrpy(i2),i2=1,100)
72746  mrpy(6)=mrpy(6)+1
72747  RETURN
72748 
72749 C...Write error.
72750  110 WRITE(cherr,'(I8)') ierr
72751  CALL pyerrm(18,'(PYRGET:) error when accessing file, IOSTAT ='//
72752  &cherr)
72753 
72754  RETURN
72755  END
72756 
72757 C*********************************************************************
72758 
72759 C...PYRSET
72760 C...Reads a state of the random number generator from a file
72761 C...for subsequent generation from this state onwards.
72762 
72763  SUBROUTINE pyrset(LFN,MOVE)
72764 
72765 C...Double precision and integer declarations.
72766  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72767  IMPLICIT INTEGER(I-N)
72768  INTEGER PYK,PYCHGE,PYCOMP
72769 C...Commonblocks.
72770  common/pydatr/mrpy(6),rrpy(100)
72771  SAVE /pydatr/
72772 C...Local character variable.
72773  CHARACTER CHERR*8
72774 
72775 C...Backspace required number of records (or as many as there are).
72776  IF(move.LT.0) THEN
72777  nbck=min(mrpy(6),-move)
72778  DO 100 ibck=1,nbck
72779  backspace(lfn,err=120,iostat=ierr)
72780  100 CONTINUE
72781  mrpy(6)=mrpy(6)-nbck
72782  ENDIF
72783 
72784 C...Unformatted read from unit LFN.
72785  nfor=1+max(0,move)
72786  DO 110 ifor=1,nfor
72787  READ(lfn,err=120,iostat=ierr) (mrpy(i1),i1=1,5),
72788  & (rrpy(i2),i2=1,100)
72789  110 CONTINUE
72790  mrpy(6)=mrpy(6)+nfor
72791  RETURN
72792 
72793 C...Write error.
72794  120 WRITE(cherr,'(I8)') ierr
72795  CALL pyerrm(18,'(PYRSET:) error when accessing file, IOSTAT ='//
72796  &cherr)
72797 
72798  RETURN
72799  END
72800 
72801 C*********************************************************************
72802 
72803 C...PYROBO
72804 C...Performs rotations and boosts.
72805 
72806  SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72807 
72808 C...Double precision and integer declarations.
72809  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72810  IMPLICIT INTEGER(I-N)
72811  INTEGER PYK,PYCHGE,PYCOMP
72812 C...Commonblocks.
72813  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72814  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72815  SAVE /pyjets/,/pydat1/
72816 C...Local arrays.
72817  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
72818 
72819 C...Find and check range of rotation/boost.
72820  imin=imi
72821  IF(imin.LE.0) imin=1
72822  IF(mstu(1).GT.0) imin=mstu(1)
72823  imax=ima
72824  IF(imax.LE.0) imax=n
72825  IF(mstu(2).GT.0) imax=mstu(2)
72826  IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
72827  CALL pyerrm(11,'(PYROBO:) range outside PYJETS memory')
72828  RETURN
72829  ENDIF
72830 
72831 C...Optional resetting of V (when not set before.)
72832  IF(mstu(33).NE.0) THEN
72833  DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
72834  DO 100 j=1,5
72835  v(i,j)=0d0
72836  100 CONTINUE
72837  110 CONTINUE
72838  mstu(33)=0
72839  ENDIF
72840 
72841 C...Rotate, typically from z axis to direction (theta,phi).
72842  IF(the**2+phi**2.GT.1d-20) THEN
72843  rot(1,1)=cos(the)*cos(phi)
72844  rot(1,2)=-sin(phi)
72845  rot(1,3)=sin(the)*cos(phi)
72846  rot(2,1)=cos(the)*sin(phi)
72847  rot(2,2)=cos(phi)
72848  rot(2,3)=sin(the)*sin(phi)
72849  rot(3,1)=-sin(the)
72850  rot(3,2)=0d0
72851  rot(3,3)=cos(the)
72852  DO 140 i=imin,imax
72853  IF(k(i,1).LE.0) GOTO 140
72854  DO 120 j=1,3
72855  pr(j)=p(i,j)
72856  vr(j)=v(i,j)
72857  120 CONTINUE
72858  DO 130 j=1,3
72859  p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
72860  v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
72861  130 CONTINUE
72862  140 CONTINUE
72863  ENDIF
72864 
72865 C...Boost, typically from rest to momentum/energy=beta.
72866  IF(bex**2+bey**2+bez**2.GT.1d-20) THEN
72867  dbx=bex
72868  dby=bey
72869  dbz=bez
72870  db=sqrt(dbx**2+dby**2+dbz**2)
72871  eps1=1d0-1d-12
72872  IF(db.GT.eps1) THEN
72873 C...Rescale boost vector if too close to unity.
72874  CALL pyerrm(3,'(PYROBO:) boost vector too large')
72875  dbx=dbx*(eps1/db)
72876  dby=dby*(eps1/db)
72877  dbz=dbz*(eps1/db)
72878  db=eps1
72879  ENDIF
72880  dga=1d0/sqrt(1d0-db**2)
72881  DO 160 i=imin,imax
72882  IF(k(i,1).LE.0) GOTO 160
72883  DO 150 j=1,4
72884  dp(j)=p(i,j)
72885  dv(j)=v(i,j)
72886  150 CONTINUE
72887  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
72888  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
72889  p(i,1)=dp(1)+dgabp*dbx
72890  p(i,2)=dp(2)+dgabp*dby
72891  p(i,3)=dp(3)+dgabp*dbz
72892  p(i,4)=dga*(dp(4)+dbp)
72893  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
72894  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
72895  v(i,1)=dv(1)+dgabv*dbx
72896  v(i,2)=dv(2)+dgabv*dby
72897  v(i,3)=dv(3)+dgabv*dbz
72898  v(i,4)=dga*(dv(4)+dbv)
72899  160 CONTINUE
72900  ENDIF
72901 
72902  RETURN
72903  END
72904 
72905 C*********************************************************************
72906 
72907 C...PYEDIT
72908 C...Performs global manipulations on the event record, in particular
72909 C...to exclude unstable or undetectable partons/particles.
72910 
72911  SUBROUTINE pyedit(MEDIT)
72912 
72913 C...Double precision and integer declarations.
72914  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72915  IMPLICIT INTEGER(I-N)
72916  INTEGER PYK,PYCHGE,PYCOMP
72917 C...Parameter statement to help give large particle numbers.
72918  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
72919  &kexcit=4000000,kdimen=5000000)
72920 C...Commonblocks.
72921  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72922  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72923  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72924  common/pyctag/nct,mct(4000,2)
72925  SAVE /pyjets/,/pydat1/,/pydat2/,/pyctag/
72926 C...Local arrays.
72927  dimension ns(2),pts(2),pls(2)
72928 
72929 C...Remove unwanted partons/particles.
72930  IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
72931  imax=n
72932  IF(mstu(2).GT.0) imax=mstu(2)
72933  i1=max(1,mstu(1))-1
72934  DO 110 i=max(1,mstu(1)),imax
72935  IF(k(i,1).EQ.0.OR.(k(i,1).GE.21.AND.k(i,1).LE.40)) GOTO 110
72936  IF(medit.EQ.1) THEN
72937  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) GOTO 110
72938  ELSEIF(medit.EQ.2) THEN
72939  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) GOTO 110
72940  kc=pycomp(k(i,2))
72941  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
72942  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
72943  & k(i,2).EQ.ksusy1+39) GOTO 110
72944  ELSEIF(medit.EQ.3) THEN
72945  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) GOTO 110
72946  kc=pycomp(k(i,2))
72947  IF(kc.EQ.0) GOTO 110
72948  IF(kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0) GOTO 110
72949  ELSEIF(medit.EQ.5) THEN
72950  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.k(i,1).EQ.52) GOTO 110
72951  kc=pycomp(k(i,2))
72952  IF(kc.EQ.0) GOTO 110
72953  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42.AND.
72954  & kchg(kc,2).EQ.0) GOTO 110
72955  ENDIF
72956 
72957 C...Pack remaining partons/particles. Origin no longer known.
72958  i1=i1+1
72959  DO 100 j=1,5
72960  k(i1,j)=k(i,j)
72961  p(i1,j)=p(i,j)
72962  v(i1,j)=v(i,j)
72963  100 CONTINUE
72964  k(i1,3)=0
72965  110 CONTINUE
72966  IF(i1.LT.n) mstu(3)=0
72967  IF(i1.LT.n) mstu(70)=0
72968  n=i1
72969 
72970 C...Selective removal of class of entries. New position of retained.
72971  ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
72972  i1=0
72973  DO 120 i=1,n
72974  k(i,3)=mod(k(i,3),mstu(5))
72975  IF(medit.EQ.11.AND.k(i,1).LT.0) GOTO 120
72976  IF(medit.EQ.12.AND.k(i,1).EQ.0) GOTO 120
72977  IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
72978  & k(i,1).EQ.15.OR.k(i,1).EQ.51).AND.k(i,2).NE.94) GOTO 120
72979  IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
72980  & k(i,1).EQ.52.OR.k(i,2).EQ.94)) GOTO 120
72981  IF(medit.EQ.15.AND.k(i,1).GE.21.AND.k(i,1).LE.40) GOTO 120
72982  i1=i1+1
72983  k(i,3)=k(i,3)+mstu(5)*i1
72984  120 CONTINUE
72985 
72986 C...Find new event history information and replace old.
72987  DO 140 i=1,n
72988  IF(k(i,1).LE.0.OR.(k(i,1).GE.21.AND.k(i,1).LE.40).OR.
72989  & k(i,3)/mstu(5).EQ.0) GOTO 140
72990  id=i
72991  130 im=mod(k(id,3),mstu(5))
72992  IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
72993  IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15.OR.
72994  & k(im,1).EQ.51).AND.k(im,2).NE.94) THEN
72995  id=im
72996  GOTO 130
72997  ENDIF
72998  ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
72999  IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,1).EQ.52.OR.
73000  & k(im,2).EQ.94) THEN
73001  id=im
73002  GOTO 130
73003  ENDIF
73004  ENDIF
73005  k(i,3)=mstu(5)*(k(i,3)/mstu(5))
73006  IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
73007  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14.AND.
73008  & k(i,1).NE.42.AND.k(i,1).NE.52) THEN
73009  IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
73010  & k(k(i,4),3)/mstu(5)
73011  IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
73012  & k(k(i,5),3)/mstu(5)
73013  ELSE
73014  kcm=mod(k(i,4)/mstu(5),mstu(5))
73015  IF(kcm.GT.0.AND.kcm.LE.mstu(4).AND.k(i,1).NE.42.AND.
73016  & k(i,1).NE.52) kcm=k(kcm,3)/mstu(5)
73017  kcd=mod(k(i,4),mstu(5))
73018  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
73019  k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
73020  kcm=mod(k(i,5)/mstu(5),mstu(5))
73021  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
73022  kcd=mod(k(i,5),mstu(5))
73023  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
73024  k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
73025  ENDIF
73026  140 CONTINUE
73027 
73028 C...Pack remaining entries.
73029  i1=0
73030  mstu90=mstu(90)
73031  mstu(90)=0
73032  DO 170 i=1,n
73033  IF(k(i,3)/mstu(5).EQ.0) GOTO 170
73034  i1=i1+1
73035  DO 150 j=1,5
73036  k(i1,j)=k(i,j)
73037  p(i1,j)=p(i,j)
73038  v(i1,j)=v(i,j)
73039  150 CONTINUE
73040 C...Also update LHA1 colour tags
73041  mct(i1,1)=mct(i,1)
73042  mct(i1,2)=mct(i,2)
73043  k(i1,3)=mod(k(i1,3),mstu(5))
73044  DO 160 iz=1,mstu90
73045  IF(i.EQ.mstu(90+iz)) THEN
73046  mstu(90)=mstu(90)+1
73047  mstu(90+mstu(90))=i1
73048  paru(90+mstu(90))=paru(90+iz)
73049  ENDIF
73050  160 CONTINUE
73051  170 CONTINUE
73052  IF(i1.LT.n) mstu(3)=0
73053  IF(i1.LT.n) mstu(70)=0
73054  n=i1
73055 
73056 C...Fill in some missing daughter pointers (lost in colour flow).
73057  ELSEIF(medit.EQ.16) THEN
73058  DO 220 i=1,n
73059  IF(k(i,1).LE.10.OR.(k(i,1).GE.21.AND.k(i,1).LE.50)) GOTO 220
73060  IF(k(i,4).NE.0.OR.k(i,5).NE.0) GOTO 220
73061 C...Find daughters who point to mother.
73062  DO 180 i1=i+1,n
73063  IF(k(i1,3).NE.i) THEN
73064  ELSEIF(k(i,4).EQ.0) THEN
73065  k(i,4)=i1
73066  ELSE
73067  k(i,5)=i1
73068  ENDIF
73069  180 CONTINUE
73070  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
73071  IF(k(i,4).NE.0) GOTO 220
73072 C...Find daughters who point to documentation version of mother.
73073  im=k(i,3)
73074  IF(im.LE.0.OR.im.GE.i) GOTO 220
73075  IF(k(im,1).LE.20.OR.k(im,1).GT.30) GOTO 220
73076  IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1d-2) GOTO 220
73077  DO 190 i1=i+1,n
73078  IF(k(i1,3).NE.im) THEN
73079  ELSEIF(k(i,4).EQ.0) THEN
73080  k(i,4)=i1
73081  ELSE
73082  k(i,5)=i1
73083  ENDIF
73084  190 CONTINUE
73085  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
73086  IF(k(i,4).NE.0) GOTO 220
73087 C...Find daughters who point to documentation daughters who,
73088 C...in their turn, point to documentation mother.
73089  id1=im
73090  id2=im
73091  DO 200 i1=im+1,i-1
73092  IF(k(i1,3).EQ.im.AND.k(i1,1).GE.21.AND.k(i1,1).LE.30) THEN
73093  id2=i1
73094  IF(id1.EQ.im) id1=i1
73095  ENDIF
73096  200 CONTINUE
73097  DO 210 i1=i+1,n
73098  IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN
73099  ELSEIF(k(i,4).EQ.0) THEN
73100  k(i,4)=i1
73101  ELSE
73102  k(i,5)=i1
73103  ENDIF
73104  210 CONTINUE
73105  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
73106  220 CONTINUE
73107 
73108 C...Save top entries at bottom of PYJETS commonblock.
73109  ELSEIF(medit.EQ.21) THEN
73110  IF(2*n.GE.mstu(4)) THEN
73111  CALL pyerrm(11,'(PYEDIT:) no more memory left in PYJETS')
73112  RETURN
73113  ENDIF
73114  DO 240 i=1,n
73115  DO 230 j=1,5
73116  k(mstu(4)-i,j)=k(i,j)
73117  p(mstu(4)-i,j)=p(i,j)
73118  v(mstu(4)-i,j)=v(i,j)
73119  230 CONTINUE
73120  240 CONTINUE
73121  mstu(32)=n
73122 
73123 C...Restore bottom entries of commonblock PYJETS to top.
73124  ELSEIF(medit.EQ.22) THEN
73125  DO 260 i=1,mstu(32)
73126  DO 250 j=1,5
73127  k(i,j)=k(mstu(4)-i,j)
73128  p(i,j)=p(mstu(4)-i,j)
73129  v(i,j)=v(mstu(4)-i,j)
73130  250 CONTINUE
73131  260 CONTINUE
73132  n=mstu(32)
73133 
73134 C...Mark primary entries at top of commonblock PYJETS as untreated.
73135  ELSEIF(medit.EQ.23) THEN
73136  i1=0
73137  DO 270 i=1,n
73138  kh=k(i,3)
73139  IF(kh.GE.1) THEN
73140  IF(k(kh,1).GE.21.AND.k(kh,1).LE.30) kh=0
73141  ENDIF
73142  IF(kh.NE.0) GOTO 280
73143  i1=i1+1
73144  IF(k(i,1).GE.11.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
73145  IF(k(i,1).GE.51.AND.k(i,1).LE.60) k(i,1)=k(i,1)-10
73146  270 CONTINUE
73147  280 n=i1
73148 
73149 C...Place largest axis along z axis and second largest in xy plane.
73150  ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
73151  CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61),1),
73152  & p(mstu(61),2)),0d0,0d0,0d0)
73153  CALL pyrobo(1,n+mstu(3),-pyangl(p(mstu(61),3),
73154  & p(mstu(61),1)),0d0,0d0,0d0,0d0)
73155  CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61)+1,1),
73156  & p(mstu(61)+1,2)),0d0,0d0,0d0)
73157  IF(medit.EQ.31) RETURN
73158 
73159 C...Rotate to put slim jet along +z axis.
73160  DO 290 is=1,2
73161  ns(is)=0
73162  pts(is)=0d0
73163  pls(is)=0d0
73164  290 CONTINUE
73165  DO 300 i=1,n
73166  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 300
73167  IF(mstu(41).GE.2) THEN
73168  kc=pycomp(k(i,2))
73169  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
73170  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
73171  & k(i,2).EQ.ksusy1+39) GOTO 300
73172  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
73173  & .EQ.0) GOTO 300
73174  ENDIF
73175  is=2d0-sign(0.5d0,p(i,3))
73176  ns(is)=ns(is)+1
73177  pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
73178  300 CONTINUE
73179  IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
73180  & CALL pyrobo(1,n+mstu(3),paru(1),0d0,0d0,0d0,0d0)
73181 
73182 C...Rotate to put second largest jet into -z,+x quadrant.
73183  DO 310 i=1,n
73184  IF(p(i,3).GE.0d0) GOTO 310
73185  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 310
73186  IF(mstu(41).GE.2) THEN
73187  kc=pycomp(k(i,2))
73188  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
73189  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
73190  & k(i,2).EQ.ksusy1+39) GOTO 310
73191  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
73192  & .EQ.0) GOTO 310
73193  ENDIF
73194  is=2d0-sign(0.5d0,p(i,1))
73195  pls(is)=pls(is)-p(i,3)
73196  310 CONTINUE
73197  IF(pls(2).GT.pls(1)) CALL pyrobo(1,n+mstu(3),0d0,paru(1),
73198  & 0d0,0d0,0d0)
73199  ENDIF
73200 
73201  RETURN
73202  END
73203 
73204 C*********************************************************************
73205 
73206 C...PYLIST
73207 C...Gives program heading, or lists an event, or particle
73208 C...data, or current parameter values.
73209 
73210  SUBROUTINE pylist(MLIST)
73211 
73212 C...Double precision and integer declarations.
73213  IMPLICIT DOUBLE PRECISION(a-h, o-z)
73214  IMPLICIT INTEGER(I-N)
73215  INTEGER PYK,PYCHGE,PYCOMP
73216 C...Parameter statement to help give large particle numbers.
73217  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
73218  &kexcit=4000000,kdimen=5000000)
73219 
73220 C...HEPEVT commonblock.
73221  parameter(nmxhep=4000)
73222  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
73223  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
73224  DOUBLE PRECISION PHEP,VHEP
73225  SAVE /hepevt/
73226 
73227 C...User process event common block.
73228  INTEGER MAXNUP
73229  parameter(maxnup=500)
73230  INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73231  DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73232  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
73233  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
73234  &vtimup(maxnup),spinup(maxnup)
73235  SAVE /hepeup/
73236 
73237 C...Commonblocks.
73238  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
73239  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
73240  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
73241  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
73242  common/pyctag/nct,mct(4000,2)
73243  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyctag/
73244 C...Local arrays, character variables and data.
73245  CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73246  dimension ps(6)
73247  DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
73248 
73249 C...Initialization printout: version number and date of last change.
73250  IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
73251  CALL pylogo
73252  mstu(12)=12345
73253  IF(mlist.EQ.0) RETURN
73254  ENDIF
73255 
73256 C...List event data, including additional lines after N.
73257  IF(mlist.GE.1.AND.mlist.LE.4) THEN
73258  IF(mlist.EQ.1) WRITE(mstu(11),5100)
73259  IF(mlist.EQ.2) WRITE(mstu(11),5200)
73260  IF(mlist.EQ.3) WRITE(mstu(11),5300)
73261  IF(mlist.EQ.4) WRITE(mstu(11),5400)
73262  lmx=12
73263  IF(mlist.GE.2) lmx=16
73264  istr=0
73265  imax=n
73266  IF(mstu(2).GT.0) imax=mstu(2)
73267  DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
73268  IF(i.GT.imax.AND.i.LE.n) GOTO 120
73269  IF(mstu(15).EQ.0.AND.k(i,1).LE.0) GOTO 120
73270  IF(mstu(15).EQ.1.AND.k(i,1).LT.0) GOTO 120
73271 
73272 C...Get particle name, pad it and check it is not too long.
73273  CALL pyname(k(i,2),chap)
73274  len=0
73275  DO 100 lem=1,16
73276  IF(chap(lem:lem).NE.' ') len=lem
73277  100 CONTINUE
73278  mdl=(k(i,1)+19)/10
73279  ldl=0
73280  IF(mdl.EQ.2.OR.mdl.GE.8) THEN
73281  chac=chap
73282  IF(len.GT.lmx) chac(lmx:lmx)='?'
73283  ELSE
73284  ldl=1
73285  IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
73286  IF(len.EQ.0) THEN
73287  chac=chdl(mdl)(1:2*ldl)//' '
73288  ELSE
73289  chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
73290  & chdl(mdl)(ldl+1:2*ldl)//' '
73291  IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
73292  ENDIF
73293  ENDIF
73294 
73295 C...Add information on string connection.
73296  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
73297  & THEN
73298  kc=pycomp(k(i,2))
73299  kcc=0
73300  IF(kc.NE.0) kcc=kchg(kc,2)
73301  IF(iabs(k(i,2)).EQ.39) THEN
73302  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
73303  ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
73304  istr=1
73305  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
73306  ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
73307  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
73308  ELSEIF(kcc.NE.0) THEN
73309  istr=0
73310  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
73311  ENDIF
73312  ENDIF
73313  IF((k(i,1).EQ.41.OR.k(i,1).EQ.51).AND.len+2*ldl+3.LE.lmx)
73314  & chac(lmx-1:lmx-1)='I'
73315 
73316 C...Write data for particle/jet.
73317  IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999d0) THEN
73318  WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
73319  & (p(i,j2),j2=1,5)
73320  ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999d0) THEN
73321  WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
73322  & (p(i,j2),j2=1,5)
73323  ELSEIF(mlist.EQ.1) THEN
73324  WRITE(mstu(11),5700) i,chac(1:12),(k(i,j1),j1=1,3),
73325  & (p(i,j2),j2=1,5)
73326  ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
73327  & k(i,1).EQ.14.OR.k(i,1).EQ.42.OR.k(i,1).EQ.52)) THEN
73328  IF(mlist.NE.4) WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,3),
73329  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
73330  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
73331  & (p(i,j2),j2=1,5)
73332  IF(mlist.EQ.4) WRITE(mstu(11),5900) i,chac,(k(i,j1),j1=1,3),
73333  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
73334  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5)
73335  & ,10000),mct(i,1),mct(i,2)
73336  ELSE
73337  IF(mlist.NE.4) WRITE(mstu(11),6000) i,chac,(k(i,j1),j1=1,5),
73338  & (p(i,j2),j2=1,5)
73339  IF(mlist.EQ.4) WRITE(mstu(11),6100) i,chac,(k(i,j1),j1=1,5)
73340  & ,mct(i,1),mct(i,2)
73341  ENDIF
73342  IF(mlist.EQ.3) WRITE(mstu(11),6200) (v(i,j),j=1,5)
73343 
73344 C...Insert extra separator lines specified by user.
73345  IF(mstu(70).GE.1) THEN
73346  isep=0
73347  DO 110 j=1,min(10,mstu(70))
73348  IF(i.EQ.mstu(70+j)) isep=1
73349  110 CONTINUE
73350  IF(isep.EQ.1) THEN
73351  IF(mlist.EQ.1) WRITE(mstu(11),6300)
73352  IF(mlist.EQ.2.OR.mlist.EQ.3) WRITE(mstu(11),6400)
73353  IF(mlist.EQ.4) WRITE(mstu(11),6500)
73354  ENDIF
73355  ENDIF
73356  120 CONTINUE
73357 
73358 C...Sum of charges and momenta.
73359  DO 130 j=1,6
73360  ps(j)=pyp(0,j)
73361  130 CONTINUE
73362  IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999d0) THEN
73363  WRITE(mstu(11),6600) ps(6),(ps(j),j=1,5)
73364  ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999d0) THEN
73365  WRITE(mstu(11),6700) ps(6),(ps(j),j=1,5)
73366  ELSEIF(mlist.EQ.1) THEN
73367  WRITE(mstu(11),6800) ps(6),(ps(j),j=1,5)
73368  ELSEIF(mlist.LE.3) THEN
73369  WRITE(mstu(11),6900) ps(6),(ps(j),j=1,5)
73370  ELSE
73371  WRITE(mstu(11),7000) ps(6)
73372  ENDIF
73373 
73374 C...Simple listing of HEPEVT entries (mainly for test purposes).
73375  ELSEIF(mlist.EQ.5) THEN
73376  WRITE(mstu(11),7100)
73377  DO 140 i=1,nhep
73378  IF(isthep(i).EQ.0) GOTO 140
73379  WRITE(mstu(11),7200) i,isthep(i),idhep(i),jmohep(1,i),
73380  & jmohep(2,i),jdahep(1,i),jdahep(2,i),(phep(j,i),j=1,5)
73381  140 CONTINUE
73382 
73383 
73384 C...Simple listing of user-process entries (mainly for test purposes).
73385  ELSEIF(mlist.EQ.7) THEN
73386  WRITE(mstu(11),7300)
73387  DO 150 i=1,nup
73388  WRITE(mstu(11),7400) i,istup(i),idup(i),mothup(1,i),
73389  & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5)
73390  150 CONTINUE
73391 
73392 C...Give simple list of KF codes defined in program.
73393  ELSEIF(mlist.EQ.11) THEN
73394  WRITE(mstu(11),7500)
73395  DO 160 kf=1,80
73396  CALL pyname(kf,chap)
73397  CALL pyname(-kf,chan)
73398  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),7600) kf,chap
73399  IF(chan.NE.' ') WRITE(mstu(11),7600) kf,chap,-kf,chan
73400  160 CONTINUE
73401  DO 190 kfls=1,3,2
73402  DO 180 kfla=1,5
73403  DO 170 kflb=1,kfla-(3-kfls)/2
73404  kf=1000*kfla+100*kflb+kfls
73405  CALL pyname(kf,chap)
73406  CALL pyname(-kf,chan)
73407  WRITE(mstu(11),7600) kf,chap,-kf,chan
73408  170 CONTINUE
73409  180 CONTINUE
73410  190 CONTINUE
73411  DO 220 kmul=0,5
73412  kfls=3
73413  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
73414  IF(kmul.EQ.5) kfls=5
73415  kflr=0
73416  IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
73417  IF(kmul.EQ.4) kflr=2
73418  DO 210 kflb=1,5
73419  DO 200 kflc=1,kflb-1
73420  kf=10000*kflr+100*kflb+10*kflc+kfls
73421  CALL pyname(kf,chap)
73422  CALL pyname(-kf,chan)
73423  WRITE(mstu(11),7600) kf,chap,-kf,chan
73424  IF(kf.EQ.311) THEN
73425  kfk=130
73426  CALL pyname(kfk,chap)
73427  WRITE(mstu(11),7600) kfk,chap
73428  kfk=310
73429  CALL pyname(kfk,chap)
73430  WRITE(mstu(11),7600) kfk,chap
73431  ENDIF
73432  200 CONTINUE
73433  kf=10000*kflr+110*kflb+kfls
73434  CALL pyname(kf,chap)
73435  WRITE(mstu(11),7600) kf,chap
73436  210 CONTINUE
73437  220 CONTINUE
73438  kf=100443
73439  CALL pyname(kf,chap)
73440  WRITE(mstu(11),7600) kf,chap
73441  kf=100553
73442  CALL pyname(kf,chap)
73443  WRITE(mstu(11),7600) kf,chap
73444  DO 260 kflsp=1,3
73445  kfls=2+2*(kflsp/3)
73446  DO 250 kfla=1,5
73447  DO 240 kflb=1,kfla
73448  DO 230 kflc=1,kflb
73449  IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc))
73450  & GOTO 230
73451  IF(kflsp.EQ.2.AND.kfla.EQ.kflc) GOTO 230
73452  IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
73453  IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
73454  CALL pyname(kf,chap)
73455  CALL pyname(-kf,chan)
73456  WRITE(mstu(11),7600) kf,chap,-kf,chan
73457  230 CONTINUE
73458  240 CONTINUE
73459  250 CONTINUE
73460  260 CONTINUE
73461  DO 270 kc=1,500
73462  kf=kchg(kc,4)
73463  IF(kf.LT.1000000) GOTO 270
73464  CALL pyname(kf,chap)
73465  CALL pyname(-kf,chan)
73466  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),7600) kf,chap
73467  IF(chan.NE.' ') WRITE(mstu(11),7600) kf,chap,-kf,chan
73468  270 CONTINUE
73469 
73470 C...List parton/particle data table. Check whether to be listed.
73471  ELSEIF(mlist.EQ.12) THEN
73472  WRITE(mstu(11),7700)
73473  DO 300 kc=1,mstu(6)
73474  kf=kchg(kc,4)
73475  IF(kf.EQ.0) GOTO 300
73476  IF(kf.LT.mstu(1).OR.(mstu(2).GT.0.AND.kf.GT.mstu(2)))
73477  & GOTO 300
73478 
73479 C...Find particle name and mass. Print information.
73480  CALL pyname(kf,chap)
73481  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) GOTO 300
73482  CALL pyname(-kf,chan)
73483  WRITE(mstu(11),7800) kf,kc,chap,chan,(kchg(kc,j1),j1=1,3),
73484  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
73485 
73486 C...Particle decay: channel number, branching ratios, matrix element,
73487 C...decay products.
73488  DO 290 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
73489  DO 280 j=1,5
73490  CALL pyname(kfdp(idc,j),chad(j))
73491  280 CONTINUE
73492  WRITE(mstu(11),7900) idc,mdme(idc,1),mdme(idc,2),brat(idc),
73493  & (chad(j),j=1,5)
73494  290 CONTINUE
73495  300 CONTINUE
73496 
73497 C...List parameter value table.
73498  ELSEIF(mlist.EQ.13) THEN
73499  WRITE(mstu(11),8000)
73500  DO 310 i=1,200
73501  WRITE(mstu(11),8100) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
73502  310 CONTINUE
73503  ENDIF
73504 
73505 C...Format statements for output on unit MSTU(11) (by default 6).
73506  5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
73507  &5x,'KF orig p_x p_y p_z E m'/)
73508  5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
73509  &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73510  &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73511  5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
73512  &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73513  &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
73514  &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73515  5400 FORMAT(///28x,'Event listing (no momenta)'//4x,'I particle/jet',
73516  & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1x
73517  & ,' C tag AC tag'/)
73518  5500 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.3)
73519  5600 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.2)
73520  5700 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.1)
73521  5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),5f13.5)
73522  5900 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),1x,2i8)
73523  6000 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),5f13.5)
73524  6100 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),1x,2i8)
73525  6200 FORMAT(66x,5(1x,f12.3))
73526  6300 FORMAT(1x,78('='))
73527  6400 FORMAT(1x,130('='))
73528  6500 FORMAT(1x,65('='))
73529  6600 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
73530  6700 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
73531  6800 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
73532  6900 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
73533  &5f13.5)
73534  7000 FORMAT(19x,'sum charge:',f6.2)
73535  7100 FORMAT(/10x,'Event listing of HEPEVT common block (simplified)'
73536  &//' I IST ID Mothers Daughters p_x p_y p_z',
73537  &' E m')
73538  7200 FORMAT(1x,i4,i2,i8,4i5,5f9.3)
73539  7300 FORMAT(/10x,'Event listing of user process at input (simplified)'
73540  &//' I IST ID Mothers Colours p_x p_y p_z',
73541  &' E m')
73542  7400 FORMAT(1x,i3,i3,i8,2i4,2i5,5f9.3)
73543  7500 FORMAT(///20x,'List of KF codes in program'/)
73544  7600 FORMAT(4x,i9,4x,a16,6x,i9,4x,a16)
73545  7700 FORMAT(///30x,'Particle/parton data table'//8x,'KF',5x,'KC',4x,
73546  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
73547  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
73548  &1x,'ME',3x,'Br.rat.',4x,'decay products')
73549  7800 FORMAT(/1x,i9,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
73550  &1x,1p,e13.5,3x,i2)
73551  7900 FORMAT(10x,i4,2x,i3,2x,i3,2x,f10.6,4x,5a16)
73552  8000 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
73553  &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
73554  8100 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
73555 
73556  RETURN
73557  END
73558 
73559 C*********************************************************************
73560 
73561 C...PYLOGO
73562 C...Writes a logo for the program.
73563 
73564  SUBROUTINE pylogo
73565 
73566 C...Double precision and integer declarations.
73567  IMPLICIT DOUBLE PRECISION(a-h, o-z)
73568  IMPLICIT INTEGER(I-N)
73569  INTEGER PYK,PYCHGE,PYCOMP
73570 C...Parameter for length of information block.
73571  parameter(irefer=21)
73572 C...Commonblocks.
73573  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
73574  common/pypars/mstp(200),parp(200),msti(200),pari(200)
73575  SAVE /pydat1/,/pypars/
73576 C...Local arrays and character variables.
73577  INTEGER IDATI(6)
73578  CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73579  &vers*1, subv*3, date*2, year*4, hour*2, minu*2, seco*2
73580 
73581 C...Data on months, logo, titles, and references.
73582  DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73583  &'Oct','Nov','Dec'/
73584  DATA (logo(j),j=1,19)/
73585  &' *......* ',
73586  &' *:::!!:::::::::::* ',
73587  &' *::::::!!::::::::::::::* ',
73588  &' *::::::::!!::::::::::::::::* ',
73589  &' *:::::::::!!:::::::::::::::::* ',
73590  &' *:::::::::!!:::::::::::::::::* ',
73591  &' *::::::::!!::::::::::::::::*! ',
73592  &' *::::::!!::::::::::::::* !! ',
73593  &' !! *:::!!:::::::::::* !! ',
73594  &' !! !* -><- * !! ',
73595  &' !! !! !! ',
73596  &' !! !! !! ',
73597  &' !! !! ',
73598  &' !! lh !! ',
73599  &' !! !! ',
73600  &' !! hh !! ',
73601  &' !! ll !! ',
73602  &' !! !! ',
73603  &' !! '/
73604  DATA (logo(j),j=20,38)/
73605  &'Welcome to the Lund Monte Carlo!',
73606  &' ',
73607  &'PPP Y Y TTTTT H H III A ',
73608  &'P P Y Y T H H I A A ',
73609  &'PPP Y T HHHHH I AAAAA',
73610  &'P Y T H H I A A',
73611  &'P Y T H H III A A',
73612  &' ',
73613  &'This is PYTHIA version x.xxx ',
73614  &'Last date of change: xx xxx 200x',
73615  &' ',
73616  &'Now is xx xxx 200x at xx:xx:xx ',
73617  &' ',
73618  &'Disclaimer: this program comes ',
73619  &'without any guarantees. Beware ',
73620  &'of errors and use common sense ',
73621  &'when interpreting results. ',
73622  &' ',
73623  &'Copyright T. Sjostrand (2008) '/
73624  DATA (refer(j),j=1,14)/
73625  &'An archive of program versions and d',
73626  &'ocumentation is found on the web: ',
73627  &'http://www.thep.lu.se/~torbjorn/Pyth',
73628  &'ia.html ',
73629  &' ',
73630  &' ',
73631  &'When you cite this program, the offi',
73632  &'cial reference is to the 6.4 manual:',
73633  &'T. Sjostrand, S. Mrenna and P. Skand',
73634  &'s, JHEP05 (2006) 026 ',
73635  &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73636  &'-T) [hep-ph/0603175]. ',
73637  &' ',
73638  &' '/
73639  DATA (refer(j),j=15,32)/
73640  &'Also remember that the program, to a',
73641  &' large extent, represents original ',
73642  &'physics research. Other publications',
73643  &' of special relevance to your ',
73644  &'studies may therefore deserve separa',
73645  &'te mention. ',
73646  &' ',
73647  &' ',
73648  &'Main author: Torbjorn Sjostrand; Dep',
73649  &'artment of Theoretical Physics, ',
73650  &' Lund University, Solvegatan 14A, S',
73651  &'-223 62 Lund, Sweden; ',
73652  &' phone: + 46 - 46 - 222 48 16; e-ma',
73653  &'il: torbjorn@thep.lu.se ',
73654  &'Author: Stephen Mrenna; Computing Di',
73655  &'vision, GDS Group, ',
73656  &' Fermi National Accelerator Laborat',
73657  &'ory, MS 234, Batavia, IL 60510, USA;'/
73658  DATA (refer(j),j=33,2*irefer)/
73659  &' phone: + 1 - 630 - 840 - 2556; e-m',
73660  &'ail: mrenna@fnal.gov ',
73661  &'Author: Peter Skands; Theoretical Ph',
73662  &'ysics Department, ',
73663  &' Fermi National Accelerator Laborat',
73664  &'ory, MS 106, Batavia, IL 60510, USA;',
73665  &' and CERN/PH, CH-1211 Geneva, Switz',
73666  &'erland; ',
73667  &' phone: + 41 - 22 - 767 24 59; e-ma',
73668  &'il: skands@fnal.gov '/
73669 
73670 C...Check that PYDATA linked.
73671  IF(mstp(183)/10.NE.199.AND.mstp(183)/10.NE.200) THEN
73672  WRITE(*,'(1X,A)')
73673  & 'Error: PYDATA has not been linked.'
73674  WRITE(*,'(1X,A)') 'Execution stopped!'
73675  CALL pystop(8)
73676 
73677 C...Write current version number and current date+time.
73678  ELSE
73679  WRITE(vers,'(I1)') mstp(181)
73680  logo(28)(24:24)=vers
73681  WRITE(subv,'(I3)') mstp(182)
73682  logo(28)(26:28)=subv
73683  IF(mstp(182).LT.100) logo(28)(26:26)='0'
73684  WRITE(date,'(I2)') mstp(185)
73685  logo(29)(22:23)=date
73686  logo(29)(25:27)=month(mstp(184))
73687  WRITE(year,'(I4)') mstp(183)
73688  logo(29)(29:32)=year
73689  CALL pytime(idati)
73690  IF(idati(1).LE.0) THEN
73691  logo(31)=' '
73692  ELSE
73693  WRITE(date,'(I2)') idati(3)
73694  logo(31)(8:9)=date
73695  logo(31)(11:13)=month(max(1,min(12,idati(2))))
73696  WRITE(year,'(I4)') idati(1)
73697  logo(31)(15:18)=year
73698  WRITE(hour,'(I2)') idati(4)
73699  logo(31)(23:24)=hour
73700  WRITE(minu,'(I2)') idati(5)
73701  logo(31)(26:27)=minu
73702  IF(idati(5).LT.10) logo(31)(26:26)='0'
73703  WRITE(seco,'(I2)') idati(6)
73704  logo(31)(29:30)=seco
73705  IF(idati(6).LT.10) logo(31)(29:29)='0'
73706  ENDIF
73707  ENDIF
73708 
73709 C...Loop over lines in header. Define page feed and side borders.
73710  DO 100 ilin=1,29+irefer
73711  line=' '
73712  IF(ilin.EQ.1) THEN
73713  line(1:1)='1'
73714  ELSE
73715  line(2:3)='**'
73716  line(78:79)='**'
73717  ENDIF
73718 
73719 C...Separator lines and logos.
73720  IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.GE.28+irefer) THEN
73721  line(4:77)='***********************************************'//
73722  & '***************************'
73723  ELSEIF(ilin.GE.6.AND.ilin.LE.24) THEN
73724  line(6:37)=logo(ilin-5)
73725  line(44:75)=logo(ilin+14)
73726  ELSEIF(ilin.GE.26.AND.ilin.LE.25+irefer) THEN
73727  line(5:40)=refer(2*ilin-51)
73728  line(41:76)=refer(2*ilin-50)
73729  ENDIF
73730 
73731 C...Write lines to appropriate unit.
73732  WRITE(mstu(11),'(A79)') line
73733  100 CONTINUE
73734 
73735  RETURN
73736  END
73737 
73738 C*********************************************************************
73739 
73740 C...PYUPDA
73741 C...Facilitates the updating of particle and decay data
73742 C...by allowing it to be done in an external file.
73743 
73744  SUBROUTINE pyupda(MUPDA,LFN)
73745 
73746 C...Double precision and integer declarations.
73747  IMPLICIT DOUBLE PRECISION(a-h, o-z)
73748  IMPLICIT INTEGER(I-N)
73749  INTEGER PYK,PYCHGE,PYCOMP
73750 C...Commonblocks.
73751  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
73752  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
73753  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
73754  common/pydat4/chaf(500,2)
73755  CHARACTER CHAF*16
73756  common/pyint4/mwid(500),wids(500,5)
73757  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pyint4/
73758 C...Local arrays, character variables and data.
73759  CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73760  &chblk(20)*72,chold*16,chtmp*16,chnew*16,chcom*24
73761  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73762  &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73763  &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73764  &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73765  &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73766 
73767 C...Write header if not yet done.
73768  IF(mstu(12).NE.12345) CALL pylist(0)
73769 
73770 C...Write information on file for editing.
73771  IF(mupda.EQ.1) THEN
73772  DO 110 kc=1,500
73773  WRITE(lfn,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
73774  & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
73775  & mwid(kc),mdcy(kc,1)
73776  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
73777  WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
73778  & (kfdp(idc,j),j=1,5)
73779  100 CONTINUE
73780  110 CONTINUE
73781 
73782 C...Read complete set of information from edited file or
73783 C...read partial set of new or updated information from edited file.
73784  ELSEIF(mupda.EQ.2.OR.mupda.EQ.3) THEN
73785 
73786 C...Reset counters.
73787  kcc=100
73788  ndc=0
73789  chkf=' '
73790  IF(mupda.EQ.2) THEN
73791  DO 120 i=1,mstu(6)
73792  kchg(i,4)=0
73793  120 CONTINUE
73794  ELSE
73795  DO 130 kc=1,mstu(6)
73796  IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
73797  ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
73798  130 CONTINUE
73799  ENDIF
73800 
73801 C...Begin of loop: read new line; unknown whether particle or
73802 C...decay data.
73803  140 READ(lfn,5200,END=190) chinl
73804 
73805 C...Identify particle code and whether already defined (for MUPDA=3).
73806  IF(chinl(2:10).NE.' ') THEN
73807  chkf=chinl(2:10)
73808  READ(chkf,5300) kf
73809  IF(mupda.EQ.2) THEN
73810  IF(kf.LE.100) THEN
73811  kc=kf
73812  ELSE
73813  kcc=kcc+1
73814  kc=kcc
73815  ENDIF
73816  ELSE
73817  kcrep=0
73818  IF(kf.LE.100) THEN
73819  kcrep=kf
73820  ELSE
73821  DO 150 kcr=101,kcc
73822  IF(kchg(kcr,4).EQ.kf) kcrep=kcr
73823  150 CONTINUE
73824  ENDIF
73825 C...Remove duplicate old decay data.
73826  IF(kcrep.NE.0.AND.mdcy(kcrep,3).GT.0) THEN
73827  idcrep=mdcy(kcrep,2)
73828  ndcrep=mdcy(kcrep,3)
73829  DO 160 i=1,kcc
73830  IF(mdcy(i,2).GT.idcrep) mdcy(i,2)=mdcy(i,2)-ndcrep
73831  160 CONTINUE
73832  DO 180 i=idcrep,ndc-ndcrep
73833  mdme(i,1)=mdme(i+ndcrep,1)
73834  mdme(i,2)=mdme(i+ndcrep,2)
73835  brat(i)=brat(i+ndcrep)
73836  DO 170 j=1,5
73837  kfdp(i,j)=kfdp(i+ndcrep,j)
73838  170 CONTINUE
73839  180 CONTINUE
73840  ndc=ndc-ndcrep
73841  kc=kcrep
73842  ELSEIF(kcrep.NE.0) THEN
73843  kc=kcrep
73844  ELSE
73845  kcc=kcc+1
73846  kc=kcc
73847  ENDIF
73848  ENDIF
73849 
73850 C...Study line with particle data.
73851  IF(kc.GT.mstu(6)) CALL pyerrm(27,
73852  & '(PYUPDA:) Particle arrays full by KF ='//chkf)
73853  READ(chinl,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
73854  & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
73855  & mwid(kc),mdcy(kc,1)
73856  mdcy(kc,2)=0
73857  mdcy(kc,3)=0
73858 
73859 C...Study line with decay data.
73860  ELSE
73861  ndc=ndc+1
73862  IF(ndc.GT.mstu(7)) CALL pyerrm(27,
73863  & '(PYUPDA:) Decay data arrays full by KF ='//chkf)
73864  IF(mdcy(kc,2).EQ.0) mdcy(kc,2)=ndc
73865  mdcy(kc,3)=mdcy(kc,3)+1
73866  READ(chinl,5100) mdme(ndc,1),mdme(ndc,2),brat(ndc),
73867  & (kfdp(ndc,j),j=1,5)
73868  ENDIF
73869 
73870 C...End of loop; ensure that PYCOMP tables are updated.
73871  GOTO 140
73872  190 CONTINUE
73873  mstu(20)=0
73874 
73875 C...Perform possible tests that new information is consistent.
73876  DO 220 kc=1,mstu(6)
73877  kf=kchg(kc,4)
73878  IF(kf.EQ.0) GOTO 220
73879  WRITE(chkf,5300) kf
73880  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
73881  & pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0) CALL pyerrm(17,
73882  & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//chkf)
73883  brsum=0d0
73884  DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
73885  IF(mdme(idc,2).GT.80) GOTO 210
73886  kq=kchg(kc,1)
73887  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
73888  merr=0
73889  DO 200 j=1,5
73890  kp=kfdp(idc,j)
73891  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
73892  IF(kp.EQ.81) kq=0
73893  ELSEIF(pycomp(kp).EQ.0) THEN
73894  merr=3
73895  ELSE
73896  kq=kq-pychge(kp)
73897  kpc=pycomp(kp)
73898  pms=pms-pmas(kpc,1)
73899  IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
73900  & pmas(kpc,3))
73901  ENDIF
73902  200 CONTINUE
73903  IF(kq.NE.0) merr=max(2,merr)
73904  IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
73905  & merr=max(1,merr)
73906  IF(merr.EQ.3) CALL pyerrm(17,
73907  & '(PYUPDA:) Unknown particle code in decay of KF ='//chkf)
73908  IF(merr.EQ.2) CALL pyerrm(17,
73909  & '(PYUPDA:) Charge not conserved in decay of KF ='//chkf)
73910  IF(merr.EQ.1) CALL pyerrm(7,
73911  & '(PYUPDA:) Kinematically unallowed decay of KF ='//chkf)
73912  brsum=brsum+brat(idc)
73913  210 CONTINUE
73914  WRITE(chtmp,5500) brsum
73915  IF(abs(brsum).GT.0.0005d0.AND.abs(brsum-1d0).GT.0.0005d0)
73916  & CALL pyerrm(7,'(PYUPDA:) Sum of branching ratios is '//
73917  & chtmp(9:16)//' for KF ='//chkf)
73918  220 CONTINUE
73919 
73920 C...Write DATA statements for inclusion in program.
73921  ELSEIF(mupda.EQ.4) THEN
73922 
73923 C...Find out how many codes and decay channels are actually used.
73924  kcc=0
73925  ndc=0
73926  DO 230 i=1,mstu(6)
73927  IF(kchg(i,4).NE.0) THEN
73928  kcc=i
73929  ndc=max(ndc,mdcy(i,2)+mdcy(i,3)-1)
73930  ENDIF
73931  230 CONTINUE
73932 
73933 C...Initialize writing of DATA statements for inclusion in program.
73934  DO 300 ivar=1,22
73935  ndim=mstu(6)
73936  IF(ivar.GE.12.AND.ivar.LE.19) ndim=mstu(7)
73937  nlin=1
73938  chlin=' '
73939  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
73940  llin=35
73941  chold='START'
73942 
73943 C...Loop through variables for conversion to characters.
73944  DO 280 idim=1,ndim
73945  IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
73946  IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
73947  IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
73948  IF(ivar.EQ.4) WRITE(chtmp,5400) kchg(idim,4)
73949  IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,1)
73950  IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,2)
73951  IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,3)
73952  IF(ivar.EQ.8) WRITE(chtmp,5500) pmas(idim,4)
73953  IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,1)
73954  IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,2)
73955  IF(ivar.EQ.11) WRITE(chtmp,5400) mdcy(idim,3)
73956  IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,1)
73957  IF(ivar.EQ.13) WRITE(chtmp,5400) mdme(idim,2)
73958  IF(ivar.EQ.14) WRITE(chtmp,5600) brat(idim)
73959  IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,1)
73960  IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,2)
73961  IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,3)
73962  IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,4)
73963  IF(ivar.EQ.19) WRITE(chtmp,5400) kfdp(idim,5)
73964  IF(ivar.EQ.20) chtmp=chaf(idim,1)
73965  IF(ivar.EQ.21) chtmp=chaf(idim,2)
73966  IF(ivar.EQ.22) WRITE(chtmp,5400) mwid(idim)
73967 
73968 C...Replace variables beyond what is properly defined.
73969  IF(ivar.LE.4) THEN
73970  IF(idim.GT.kcc) chtmp=' 0'
73971  ELSEIF(ivar.LE.8) THEN
73972  IF(idim.GT.kcc) chtmp=' 0.0'
73973  ELSEIF(ivar.LE.11) THEN
73974  IF(idim.GT.kcc) chtmp=' 0'
73975  ELSEIF(ivar.LE.13) THEN
73976  IF(idim.GT.ndc) chtmp=' 0'
73977  ELSEIF(ivar.LE.14) THEN
73978  IF(idim.GT.ndc) chtmp=' 0.0'
73979  ELSEIF(ivar.LE.19) THEN
73980  IF(idim.GT.ndc) chtmp=' 0'
73981  ELSEIF(ivar.LE.21) THEN
73982  IF(idim.GT.kcc) chtmp=' '
73983  ELSE
73984  IF(idim.GT.kcc) chtmp=' 0'
73985  ENDIF
73986 
73987 C...Length of variable, trailing decimal zeros, quotation marks.
73988  llow=1
73989  lhig=1
73990  DO 240 ll=1,16
73991  IF(chtmp(17-ll:17-ll).NE.' ') llow=17-ll
73992  IF(chtmp(ll:ll).NE.' ') lhig=ll
73993  240 CONTINUE
73994  chnew=chtmp(llow:lhig)//' '
73995  lnew=1+lhig-llow
73996  IF((ivar.GE.5.AND.ivar.LE.8).OR.ivar.EQ.14) THEN
73997  lnew=lnew+1
73998  250 lnew=lnew-1
73999  IF(lnew.GE.2.AND.chnew(lnew:lnew).EQ.'0') GOTO 250
74000  IF(chnew(lnew:lnew).EQ.'.') lnew=lnew-1
74001  IF(lnew.EQ.0) THEN
74002  chnew(1:3)='0D0'
74003  lnew=3
74004  ELSE
74005  chnew(lnew+1:lnew+2)='D0'
74006  lnew=lnew+2
74007  ENDIF
74008  ELSEIF(ivar.EQ.20.OR.ivar.EQ.21) THEN
74009  DO 260 ll=lnew,1,-1
74010  IF(chnew(ll:ll).EQ.'''') THEN
74011  chtmp=chnew
74012  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
74013  lnew=lnew+1
74014  ENDIF
74015  260 CONTINUE
74016  lnew=min(14,lnew)
74017  chtmp=chnew
74018  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
74019  lnew=lnew+2
74020  ENDIF
74021 
74022 C...Form composite character string, often including repetition counter.
74023  IF(chnew.NE.chold) THEN
74024  nrpt=1
74025  chold=chnew
74026  chcom=chnew
74027  lcom=lnew
74028  ELSE
74029  lrpt=lnew+1
74030  IF(nrpt.GE.2) lrpt=lnew+3
74031  IF(nrpt.GE.10) lrpt=lnew+4
74032  IF(nrpt.GE.100) lrpt=lnew+5
74033  IF(nrpt.GE.1000) lrpt=lnew+6
74034  llin=llin-lrpt
74035  nrpt=nrpt+1
74036  WRITE(chtmp,5400) nrpt
74037  lrpt=1
74038  IF(nrpt.GE.10) lrpt=2
74039  IF(nrpt.GE.100) lrpt=3
74040  IF(nrpt.GE.1000) lrpt=4
74041  chcom(1:lrpt+1+lnew)=chtmp(17-lrpt:16)//'*'//chnew(1:lnew)
74042  lcom=lrpt+1+lnew
74043  ENDIF
74044 
74045 C...Add characters to end of line, to new line (after storing old line),
74046 C...or to new block of lines (after writing old block).
74047  IF(llin+lcom.LE.70) THEN
74048  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
74049  llin=llin+lcom+1
74050  ELSEIF(nlin.LE.19) THEN
74051  chlin(llin+1:72)=' '
74052  chblk(nlin)=chlin
74053  nlin=nlin+1
74054  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
74055  llin=6+lcom+1
74056  ELSE
74057  chlin(llin:72)='/'//' '
74058  chblk(nlin)=chlin
74059  WRITE(chtmp,5400) idim-nrpt
74060  chblk(1)(30:33)=chtmp(13:16)
74061  DO 270 ilin=1,nlin
74062  WRITE(lfn,5700) chblk(ilin)
74063  270 CONTINUE
74064  nlin=1
74065  chlin=' '
74066  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//
74067  & ',I= , )/'//chcom(1:lcom)//','
74068  WRITE(chtmp,5400) idim-nrpt+1
74069  chlin(25:28)=chtmp(13:16)
74070  llin=35+lcom+1
74071  ENDIF
74072  280 CONTINUE
74073 
74074 C...Write final block of lines.
74075  chlin(llin:72)='/'//' '
74076  chblk(nlin)=chlin
74077  WRITE(chtmp,5400) ndim
74078  chblk(1)(30:33)=chtmp(13:16)
74079  DO 290 ilin=1,nlin
74080  WRITE(lfn,5700) chblk(ilin)
74081  290 CONTINUE
74082  300 CONTINUE
74083  ENDIF
74084 
74085 C...Formats for reading and writing particle data.
74086  5000 FORMAT(1x,i9,2x,a16,2x,a16,3i3,3f12.5,1p,e13.5,2i3)
74087  5100 FORMAT(10x,2i5,f12.6,5i10)
74088  5200 FORMAT(a120)
74089  5300 FORMAT(i9)
74090  5400 FORMAT(i16)
74091  5500 FORMAT(f16.5)
74092  5600 FORMAT(f16.6)
74093  5700 FORMAT(a72)
74094 
74095  RETURN
74096  END
74097 
74098 C*********************************************************************
74099 
74100 C...PYK
74101 C...Provides various integer-valued event related data.
74102 
74103  FUNCTION pyk(I,J)
74104 
74105 C...Double precision and integer declarations.
74106  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74107  IMPLICIT INTEGER(I-N)
74108  INTEGER PYK,PYCHGE,PYCOMP
74109 C...Commonblocks.
74110  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74111  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74112  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74113  SAVE /pyjets/,/pydat1/,/pydat2/
74114 
74115 C...Default value. For I=0 number of entries, number of stable entries
74116 C...or 3 times total charge.
74117  pyk=0
74118  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
74119  ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
74120  pyk=n
74121  ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
74122  DO 100 i1=1,n
74123  IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+1
74124  IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+
74125  & pychge(k(i1,2))
74126  100 CONTINUE
74127  ELSEIF(i.EQ.0) THEN
74128 
74129 C...For I > 0 direct readout of K matrix or charge.
74130  ELSEIF(j.LE.5) THEN
74131  pyk=k(i,j)
74132  ELSEIF(j.EQ.6) THEN
74133  pyk=pychge(k(i,2))
74134 
74135 C...Status (existing/fragmented/decayed), parton/hadron separation.
74136  ELSEIF(j.LE.8) THEN
74137  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pyk=1
74138  IF(j.EQ.8) pyk=pyk*k(i,2)
74139  ELSEIF(j.LE.12) THEN
74140  kfa=iabs(k(i,2))
74141  kc=pycomp(kfa)
74142  kq=0
74143  IF(kc.NE.0) kq=kchg(kc,2)
74144  IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) pyk=k(i,2)
74145  IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) pyk=k(i,2)
74146  IF(j.EQ.11) pyk=kc
74147  IF(j.EQ.12) pyk=kq*isign(1,k(i,2))
74148 
74149 C...Heaviest flavour in hadron/diquark.
74150  ELSEIF(j.EQ.13) THEN
74151  kfa=iabs(k(i,2))
74152  pyk=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
74153  IF(kfa.LT.10) pyk=kfa
74154  IF(mod(kfa/1000,10).NE.0) pyk=mod(kfa/1000,10)
74155  pyk=pyk*isign(1,k(i,2))
74156 
74157 C...Particle history: generation, ancestor, rank.
74158  ELSEIF(j.LE.15) THEN
74159  i2=i
74160  i1=i
74161  110 pyk=pyk+1
74162  i2=i1
74163  i1=k(i1,3)
74164  IF(i1.GT.0) THEN
74165  IF(k(i1,1).GT.0.AND.k(i1,1).LE.20) GOTO 110
74166  ENDIF
74167  IF(j.EQ.15) pyk=i2
74168  ELSEIF(j.EQ.16) THEN
74169  kfa=iabs(k(i,2))
74170  IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.
74171  & (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN
74172  i1=i
74173  120 i2=i1
74174  i1=k(i1,3)
74175  IF(i1.GT.0) THEN
74176  kfam=iabs(k(i1,2))
74177  ilp=1
74178  IF(kfam.NE.0.AND.kfam.LE.10) ilp=0
74179  IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)
74180  & ilp=0
74181  IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0
74182  IF(ilp.EQ.1) GOTO 120
74183  ENDIF
74184  IF(k(i1,1).EQ.12) THEN
74185  DO 130 i3=i1+1,i2
74186  IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92
74187  & .AND.k(i3,2).NE.93) pyk=pyk+1
74188  130 CONTINUE
74189  ELSE
74190  i3=i2
74191  140 pyk=pyk+1
74192  i3=i3+1
74193  IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) GOTO 140
74194  ENDIF
74195  ENDIF
74196 
74197 C...Particle coming from collapsing jet system or not.
74198  ELSEIF(j.EQ.17) THEN
74199  i1=i
74200  150 pyk=pyk+1
74201  i3=i1
74202  i1=k(i1,3)
74203  i0=max(1,i1)
74204  kc=pycomp(k(i0,2))
74205  IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
74206  IF(pyk.EQ.1) pyk=-1
74207  IF(pyk.GT.1) pyk=0
74208  RETURN
74209  ENDIF
74210  IF(kchg(kc,2).EQ.0) GOTO 150
74211  IF(k(i1,1).NE.12) pyk=0
74212  IF(k(i1,1).NE.12) RETURN
74213  i2=i1
74214  160 i2=i2+1
74215  IF(i2.LT.n.AND.k(i2,1).NE.11) GOTO 160
74216  k3m=k(i3-1,3)
74217  IF(k3m.GE.i1.AND.k3m.LE.i2) pyk=0
74218  k3p=k(i3+1,3)
74219  IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) pyk=0
74220 
74221 C...Number of decay products. Colour flow.
74222  ELSEIF(j.EQ.18) THEN
74223  IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) pyk=max(0,k(i,5)-k(i,4)+1)
74224  IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) pyk=0
74225  ELSEIF(j.LE.22) THEN
74226  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
74227  IF(j.EQ.19) pyk=mod(k(i,4)/mstu(5),mstu(5))
74228  IF(j.EQ.20) pyk=mod(k(i,5)/mstu(5),mstu(5))
74229  IF(j.EQ.21) pyk=mod(k(i,4),mstu(5))
74230  IF(j.EQ.22) pyk=mod(k(i,5),mstu(5))
74231  ELSE
74232  ENDIF
74233 
74234  RETURN
74235  END
74236 
74237 C*********************************************************************
74238 
74239 C...PYP
74240 C...Provides various real-valued event related data.
74241 
74242  FUNCTION pyp(I,J)
74243 
74244 C...Double precision and integer declarations.
74245  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74246  IMPLICIT INTEGER(I-N)
74247  INTEGER PYK,PYCHGE,PYCOMP
74248 C...Commonblocks.
74249  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74250  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74251  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74252  SAVE /pyjets/,/pydat1/,/pydat2/
74253 C...Local array.
74254  dimension psum(4)
74255 
74256 C...Set default value. For I = 0 sum of momenta or charges,
74257 C...or invariant mass of system.
74258  pyp=0d0
74259  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
74260  ELSEIF(i.EQ.0.AND.j.LE.4) THEN
74261  DO 100 i1=1,n
74262  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+p(i1,j)
74263  100 CONTINUE
74264  ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
74265  DO 120 j1=1,4
74266  psum(j1)=0d0
74267  DO 110 i1=1,n
74268  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+
74269  & p(i1,j1)
74270  110 CONTINUE
74271  120 CONTINUE
74272  pyp=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
74273  ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
74274  DO 130 i1=1,n
74275  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+pychge(k(i1,2))/3d0
74276  130 CONTINUE
74277  ELSEIF(i.EQ.0) THEN
74278 
74279 C...Direct readout of P matrix.
74280  ELSEIF(j.LE.5) THEN
74281  pyp=p(i,j)
74282 
74283 C...Charge, total momentum, transverse momentum, transverse mass.
74284  ELSEIF(j.LE.12) THEN
74285  IF(j.EQ.6) pyp=pychge(k(i,2))/3d0
74286  IF(j.EQ.7.OR.j.EQ.8) pyp=p(i,1)**2+p(i,2)**2+p(i,3)**2
74287  IF(j.EQ.9.OR.j.EQ.10) pyp=p(i,1)**2+p(i,2)**2
74288  IF(j.EQ.11.OR.j.EQ.12) pyp=p(i,5)**2+p(i,1)**2+p(i,2)**2
74289  IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) pyp=sqrt(pyp)
74290 
74291 C...Theta and phi angle in radians or degrees.
74292  ELSEIF(j.LE.16) THEN
74293  IF(j.LE.14) pyp=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
74294  IF(j.GE.15) pyp=pyangl(p(i,1),p(i,2))
74295  IF(j.EQ.14.OR.j.EQ.16) pyp=pyp*180d0/paru(1)
74296 
74297 C...True rapidity, rapidity with pion mass, pseudorapidity.
74298  ELSEIF(j.LE.19) THEN
74299  pmr=0d0
74300  IF(j.EQ.17) pmr=p(i,5)
74301  IF(j.EQ.18) pmr=pymass(211)
74302  pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
74303  pyp=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
74304  & 1d20)),p(i,3))
74305 
74306 C...Energy and momentum fractions (only to be used in CM frame).
74307  ELSEIF(j.LE.25) THEN
74308  IF(j.EQ.20) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
74309  IF(j.EQ.21) pyp=2d0*p(i,3)/paru(21)
74310  IF(j.EQ.22) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
74311  IF(j.EQ.23) pyp=2d0*p(i,4)/paru(21)
74312  IF(j.EQ.24) pyp=(p(i,4)+p(i,3))/paru(21)
74313  IF(j.EQ.25) pyp=(p(i,4)-p(i,3))/paru(21)
74314  ENDIF
74315 
74316  RETURN
74317  END
74318 
74319 C*********************************************************************
74320 
74321 C...PYSPHE
74322 C...Performs sphericity tensor analysis to give sphericity,
74323 C...aplanarity and the related event axes.
74324 
74325  SUBROUTINE pysphe(SPH,APL)
74326 
74327 C...Double precision and integer declarations.
74328  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74329  IMPLICIT INTEGER(I-N)
74330  INTEGER PYK,PYCHGE,PYCOMP
74331 C...Parameter statement to help give large particle numbers.
74332  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74333  &kexcit=4000000,kdimen=5000000)
74334 C...Commonblocks.
74335  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74336  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74337  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74338  SAVE /pyjets/,/pydat1/,/pydat2/
74339 C...Local arrays.
74340  dimension sm(3,3),sv(3,3)
74341 
74342 C...Calculate matrix to be diagonalized.
74343  np=0
74344  DO 110 j1=1,3
74345  DO 100 j2=j1,3
74346  sm(j1,j2)=0d0
74347  100 CONTINUE
74348  110 CONTINUE
74349  ps=0d0
74350  DO 140 i=1,n
74351  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
74352  IF(mstu(41).GE.2) THEN
74353  kc=pycomp(k(i,2))
74354  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
74355  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
74356  & k(i,2).EQ.ksusy1+39) GOTO 140
74357  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
74358  & GOTO 140
74359  ENDIF
74360  np=np+1
74361  pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74362  pwt=1d0
74363  IF(abs(paru(41)-2d0).GT.0.001d0) pwt=
74364  & max(1d-10,pa)**(paru(41)-2d0)
74365  DO 130 j1=1,3
74366  DO 120 j2=j1,3
74367  sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
74368  120 CONTINUE
74369  130 CONTINUE
74370  ps=ps+pwt*pa**2
74371  140 CONTINUE
74372 
74373 C...Very low multiplicities (0 or 1) not considered.
74374  IF(np.LE.1) THEN
74375  CALL pyerrm(8,'(PYSPHE:) too few particles for analysis')
74376  sph=-1d0
74377  apl=-1d0
74378  RETURN
74379  ENDIF
74380  DO 160 j1=1,3
74381  DO 150 j2=j1,3
74382  sm(j1,j2)=sm(j1,j2)/ps
74383  150 CONTINUE
74384  160 CONTINUE
74385 
74386 C...Find eigenvalues to matrix (third degree equation).
74387  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
74388  &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
74389  sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
74390  &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
74391  &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
74392  sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
74393  p(n+1,4)=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
74394  p(n+3,4)=1d0/3d0+sqrt(-sq)*min(2d0*sp,-sqrt(3d0*(1d0-sp**2))-sp)
74395  p(n+2,4)=1d0-p(n+1,4)-p(n+3,4)
74396  IF(p(n+2,4).LT.1d-5) THEN
74397  CALL pyerrm(8,'(PYSPHE:) all particles back-to-back')
74398  sph=-1d0
74399  apl=-1d0
74400  RETURN
74401  ENDIF
74402 
74403 C...Find first and last eigenvector by solving equation system.
74404  DO 240 i=1,3,2
74405  DO 180 j1=1,3
74406  sv(j1,j1)=sm(j1,j1)-p(n+i,4)
74407  DO 170 j2=j1+1,3
74408  sv(j1,j2)=sm(j1,j2)
74409  sv(j2,j1)=sm(j1,j2)
74410  170 CONTINUE
74411  180 CONTINUE
74412  smax=0d0
74413  DO 200 j1=1,3
74414  DO 190 j2=1,3
74415  IF(abs(sv(j1,j2)).LE.smax) GOTO 190
74416  ja=j1
74417  jb=j2
74418  smax=abs(sv(j1,j2))
74419  190 CONTINUE
74420  200 CONTINUE
74421  smax=0d0
74422  DO 220 j3=ja+1,ja+2
74423  j1=j3-3*((j3-1)/3)
74424  rl=sv(j1,jb)/sv(ja,jb)
74425  DO 210 j2=1,3
74426  sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
74427  IF(abs(sv(j1,j2)).LE.smax) GOTO 210
74428  jc=j1
74429  smax=abs(sv(j1,j2))
74430  210 CONTINUE
74431  220 CONTINUE
74432  jb1=jb+1-3*(jb/3)
74433  jb2=jb+2-3*((jb+1)/3)
74434  p(n+i,jb1)=-sv(jc,jb2)
74435  p(n+i,jb2)=sv(jc,jb1)
74436  p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
74437  & sv(ja,jb)
74438  pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
74439  sgn=(-1d0)**int(pyr(0)+0.5d0)
74440  DO 230 j=1,3
74441  p(n+i,j)=sgn*p(n+i,j)/pa
74442  230 CONTINUE
74443  240 CONTINUE
74444 
74445 C...Middle axis orthogonal to other two. Fill other codes.
74446  sgn=(-1d0)**int(pyr(0)+0.5d0)
74447  p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
74448  p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
74449  p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
74450  DO 260 i=1,3
74451  k(n+i,1)=31
74452  k(n+i,2)=95
74453  k(n+i,3)=i
74454  k(n+i,4)=0
74455  k(n+i,5)=0
74456  p(n+i,5)=0d0
74457  DO 250 j=1,5
74458  v(i,j)=0d0
74459  250 CONTINUE
74460  260 CONTINUE
74461 
74462 C...Calculate sphericity and aplanarity. Select storing option.
74463  sph=1.5d0*(p(n+2,4)+p(n+3,4))
74464  apl=1.5d0*p(n+3,4)
74465  mstu(61)=n+1
74466  mstu(62)=np
74467  IF(mstu(43).LE.1) mstu(3)=3
74468  IF(mstu(43).GE.2) n=n+3
74469 
74470  RETURN
74471  END
74472 
74473 C*********************************************************************
74474 
74475 C...PYTHRU
74476 C...Performs thrust analysis to give thrust, oblateness
74477 C...and the related event axes.
74478 
74479  SUBROUTINE pythru(THR,OBL)
74480 
74481 C...Double precision and integer declarations.
74482  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74483  IMPLICIT INTEGER(I-N)
74484  INTEGER PYK,PYCHGE,PYCOMP
74485 C...Parameter statement to help give large particle numbers.
74486  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74487  &kexcit=4000000,kdimen=5000000)
74488 C...Commonblocks.
74489  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74490  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74491  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74492  SAVE /pyjets/,/pydat1/,/pydat2/
74493 C...Local arrays.
74494  dimension tdi(3),tpr(3)
74495 
74496 C...Take copy of particles that are to be considered in thrust analysis.
74497  np=0
74498  ps=0d0
74499  DO 100 i=1,n
74500  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
74501  IF(mstu(41).GE.2) THEN
74502  kc=pycomp(k(i,2))
74503  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
74504  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
74505  & k(i,2).EQ.ksusy1+39) GOTO 100
74506  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
74507  & GOTO 100
74508  ENDIF
74509  IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
74510  CALL pyerrm(11,'(PYTHRU:) no more memory left in PYJETS')
74511  thr=-2d0
74512  obl=-2d0
74513  RETURN
74514  ENDIF
74515  np=np+1
74516  k(n+np,1)=23
74517  p(n+np,1)=p(i,1)
74518  p(n+np,2)=p(i,2)
74519  p(n+np,3)=p(i,3)
74520  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74521  p(n+np,5)=1d0
74522  IF(abs(paru(42)-1d0).GT.0.001d0) p(n+np,5)=
74523  & p(n+np,4)**(paru(42)-1d0)
74524  ps=ps+p(n+np,4)*p(n+np,5)
74525  100 CONTINUE
74526 
74527 C...Very low multiplicities (0 or 1) not considered.
74528  IF(np.LE.1) THEN
74529  CALL pyerrm(8,'(PYTHRU:) too few particles for analysis')
74530  thr=-1d0
74531  obl=-1d0
74532  RETURN
74533  ENDIF
74534 
74535 C...Loop over thrust and major. T axis along z direction in latter case.
74536  DO 320 ild=1,2
74537  IF(ild.EQ.2) THEN
74538  k(n+np+1,1)=31
74539  phi=pyangl(p(n+np+1,1),p(n+np+1,2))
74540  mstu(33)=1
74541  CALL pyrobo(n+1,n+np+1,0d0,-phi,0d0,0d0,0d0)
74542  the=pyangl(p(n+np+1,3),p(n+np+1,1))
74543  CALL pyrobo(n+1,n+np+1,-the,0d0,0d0,0d0,0d0)
74544  ENDIF
74545 
74546 C...Find and order particles with highest p (pT for major).
74547  DO 110 ilf=n+np+4,n+np+mstu(44)+4
74548  p(ilf,4)=0d0
74549  110 CONTINUE
74550  DO 160 i=n+1,n+np
74551  IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
74552  DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
74553  IF(p(i,4).LE.p(ilf,4)) GOTO 140
74554  DO 120 j=1,5
74555  p(ilf+1,j)=p(ilf,j)
74556  120 CONTINUE
74557  130 CONTINUE
74558  ilf=n+np+3
74559  140 DO 150 j=1,5
74560  p(ilf+1,j)=p(i,j)
74561  150 CONTINUE
74562  160 CONTINUE
74563 
74564 C...Find and order initial axes with highest thrust (major).
74565  DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
74566  p(ilg,4)=0d0
74567  170 CONTINUE
74568  nc=2**(min(mstu(44),np)-1)
74569  DO 250 ilc=1,nc
74570  DO 180 j=1,3
74571  tdi(j)=0d0
74572  180 CONTINUE
74573  DO 200 ilf=1,min(mstu(44),np)
74574  sgn=p(n+np+ilf+3,5)
74575  IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
74576  DO 190 j=1,4-ild
74577  tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
74578  190 CONTINUE
74579  200 CONTINUE
74580  tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
74581  DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
74582  IF(tds.LE.p(ilg,4)) GOTO 230
74583  DO 210 j=1,4
74584  p(ilg+1,j)=p(ilg,j)
74585  210 CONTINUE
74586  220 CONTINUE
74587  ilg=n+np+mstu(44)+4
74588  230 DO 240 j=1,3
74589  p(ilg+1,j)=tdi(j)
74590  240 CONTINUE
74591  p(ilg+1,4)=tds
74592  250 CONTINUE
74593 
74594 C...Iterate direction of axis until stable maximum.
74595  p(n+np+ild,4)=0d0
74596  ilg=0
74597  260 ilg=ilg+1
74598  thp=0d0
74599  270 thps=thp
74600  DO 280 j=1,3
74601  IF(thp.LE.1d-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
74602  IF(thp.GT.1d-10) tdi(j)=tpr(j)
74603  tpr(j)=0d0
74604  280 CONTINUE
74605  DO 300 i=n+1,n+np
74606  sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
74607  DO 290 j=1,4-ild
74608  tpr(j)=tpr(j)+sgn*p(i,j)
74609  290 CONTINUE
74610  300 CONTINUE
74611  thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
74612  IF(thp.GE.thps+paru(48)) GOTO 270
74613 
74614 C...Save good axis. Try new initial axis until a number of tries agree.
74615  IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) GOTO 260
74616  IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
74617  iagr=0
74618  sgn=(-1d0)**int(pyr(0)+0.5d0)
74619  DO 310 j=1,3
74620  p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
74621  310 CONTINUE
74622  p(n+np+ild,4)=thp
74623  p(n+np+ild,5)=0d0
74624  ENDIF
74625  iagr=iagr+1
74626  IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) GOTO 260
74627  320 CONTINUE
74628 
74629 C...Find minor axis and value by orthogonality.
74630  sgn=(-1d0)**int(pyr(0)+0.5d0)
74631  p(n+np+3,1)=-sgn*p(n+np+2,2)
74632  p(n+np+3,2)=sgn*p(n+np+2,1)
74633  p(n+np+3,3)=0d0
74634  thp=0d0
74635  DO 330 i=n+1,n+np
74636  thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
74637  330 CONTINUE
74638  p(n+np+3,4)=thp/ps
74639  p(n+np+3,5)=0d0
74640 
74641 C...Fill axis information. Rotate back to original coordinate system.
74642  DO 350 ild=1,3
74643  k(n+ild,1)=31
74644  k(n+ild,2)=96
74645  k(n+ild,3)=ild
74646  k(n+ild,4)=0
74647  k(n+ild,5)=0
74648  DO 340 j=1,5
74649  p(n+ild,j)=p(n+np+ild,j)
74650  v(n+ild,j)=0d0
74651  340 CONTINUE
74652  350 CONTINUE
74653  CALL pyrobo(n+1,n+3,the,phi,0d0,0d0,0d0)
74654 
74655 C...Calculate thrust and oblateness. Select storing option.
74656  thr=p(n+1,4)
74657  obl=p(n+2,4)-p(n+3,4)
74658  mstu(61)=n+1
74659  mstu(62)=np
74660  IF(mstu(43).LE.1) mstu(3)=3
74661  IF(mstu(43).GE.2) n=n+3
74662 
74663  RETURN
74664  END
74665 
74666 C*********************************************************************
74667 
74668 C...PYCLUS
74669 C...Subdivides the particle content of an event into jets/clusters.
74670 
74671  SUBROUTINE pyclus(NJET)
74672 
74673 C...Double precision and integer declarations.
74674  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74675  IMPLICIT INTEGER(I-N)
74676  INTEGER PYK,PYCHGE,PYCOMP
74677 C...Parameter statement to help give large particle numbers.
74678  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74679  &kexcit=4000000,kdimen=5000000)
74680 C...Commonblocks.
74681  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74682  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74683  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74684  SAVE /pyjets/,/pydat1/,/pydat2/
74685 C...Local arrays and saved variables.
74686  dimension ps(5)
74687  SAVE nsav,np,ps,pss,rinit,npre,nrem
74688 
74689 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74690  r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
74691  &p(i1,3)*p(i2,3))*2d0*p(i1,5)*p(i2,5)/(0.0001d0+p(i1,5)+p(i2,5))**2
74692  r2m(i1,i2)=2d0*p(i1,4)*p(i2,4)*(1d0-(p(i1,1)*p(i2,1)+p(i1,2)*
74693  &p(i2,2)+p(i1,3)*p(i2,3))/max(1d-10,p(i1,5)*p(i2,5)))
74694  r2d(i1,i2)=2d0*min(p(i1,4),p(i2,4))**2*(1d0-(p(i1,1)*p(i2,1)+
74695  &p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/max(1d-10,p(i1,5)*p(i2,5)))
74696 
74697 C...If first time, reset. If reentering, skip preliminaries.
74698  IF(mstu(48).LE.0) THEN
74699  np=0
74700  DO 100 j=1,5
74701  ps(j)=0d0
74702  100 CONTINUE
74703  pss=0d0
74704  pimass=pmas(pycomp(211),1)
74705  ELSE
74706  njet=nsav
74707  IF(mstu(43).GE.2) n=n-njet
74708  DO 110 i=n+1,n+njet
74709  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74710  110 CONTINUE
74711  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
74712  r2acc=paru(44)**2
74713  ELSE
74714  r2acc=paru(45)*ps(5)**2
74715  ENDIF
74716  nloop=0
74717  GOTO 300
74718  ENDIF
74719 
74720 C...Find which particles are to be considered in cluster search.
74721  DO 140 i=1,n
74722  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
74723  IF(mstu(41).GE.2) THEN
74724  kc=pycomp(k(i,2))
74725  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
74726  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
74727  & k(i,2).EQ.ksusy1+39) GOTO 140
74728  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
74729  & GOTO 140
74730  ENDIF
74731  IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
74732  CALL pyerrm(11,'(PYCLUS:) no more memory left in PYJETS')
74733  njet=-1
74734  RETURN
74735  ENDIF
74736 
74737 C...Take copy of these particles, with space left for jets later on.
74738  np=np+1
74739  k(n+np,3)=i
74740  DO 120 j=1,5
74741  p(n+np,j)=p(i,j)
74742  120 CONTINUE
74743  IF(mstu(42).EQ.0) p(n+np,5)=0d0
74744  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
74745  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
74746  p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74747  DO 130 j=1,4
74748  ps(j)=ps(j)+p(n+np,j)
74749  130 CONTINUE
74750  pss=pss+p(n+np,5)
74751  140 CONTINUE
74752  DO 160 i=n+1,n+np
74753  k(i+np,3)=k(i,3)
74754  DO 150 j=1,5
74755  p(i+np,j)=p(i,j)
74756  150 CONTINUE
74757  160 CONTINUE
74758  ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
74759 
74760 C...Very low multiplicities not considered.
74761  IF(np.LT.mstu(47)) THEN
74762  CALL pyerrm(8,'(PYCLUS:) too few particles for analysis')
74763  njet=-1
74764  RETURN
74765  ENDIF
74766 
74767 C...Find precluster configuration. If too few jets, make harder cuts.
74768  nloop=0
74769  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
74770  r2acc=paru(44)**2
74771  ELSE
74772  r2acc=paru(45)*ps(5)**2
74773  ENDIF
74774  rinit=1.25d0*paru(43)
74775  IF(np.LE.mstu(47)+2) rinit=0d0
74776  170 rinit=0.8d0*rinit
74777  npre=0
74778  nrem=np
74779  DO 180 i=n+np+1,n+2*np
74780  k(i,4)=0
74781  180 CONTINUE
74782 
74783 C...Sum up small momentum region. Jet if enough absolute momentum.
74784  IF(mstu(46).LE.2) THEN
74785  DO 190 j=1,4
74786  p(n+1,j)=0d0
74787  190 CONTINUE
74788  DO 210 i=n+np+1,n+2*np
74789  IF(p(i,5).GT.2d0*rinit) GOTO 210
74790  nrem=nrem-1
74791  k(i,4)=1
74792  DO 200 j=1,4
74793  p(n+1,j)=p(n+1,j)+p(i,j)
74794  200 CONTINUE
74795  210 CONTINUE
74796  p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
74797  IF(p(n+1,5).GT.2d0*rinit) npre=1
74798  IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
74799  IF(nrem.EQ.0) GOTO 170
74800  ENDIF
74801 
74802 C...Find fastest remaining particle.
74803  220 npre=npre+1
74804  pmax=0d0
74805  DO 230 i=n+np+1,n+2*np
74806  IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) GOTO 230
74807  imax=i
74808  pmax=p(i,5)
74809  230 CONTINUE
74810  DO 240 j=1,5
74811  p(n+npre,j)=p(imax,j)
74812  240 CONTINUE
74813  nrem=nrem-1
74814  k(imax,4)=npre
74815 
74816 C...Sum up precluster around it according to pT separation.
74817  IF(mstu(46).LE.2) THEN
74818  DO 260 i=n+np+1,n+2*np
74819  IF(k(i,4).NE.0) GOTO 260
74820  r2=r2t(i,imax)
74821  IF(r2.GT.rinit**2) GOTO 260
74822  nrem=nrem-1
74823  k(i,4)=npre
74824  DO 250 j=1,4
74825  p(n+npre,j)=p(n+npre,j)+p(i,j)
74826  250 CONTINUE
74827  260 CONTINUE
74828  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
74829 
74830 C...Sum up precluster around it according to mass or
74831 C...Durham pT separation.
74832  ELSE
74833  270 imin=0
74834  r2min=rinit**2
74835  DO 280 i=n+np+1,n+2*np
74836  IF(k(i,4).NE.0) GOTO 280
74837  IF(mstu(46).LE.4) THEN
74838  r2=r2m(i,n+npre)
74839  ELSE
74840  r2=r2d(i,n+npre)
74841  ENDIF
74842  IF(r2.GE.r2min) GOTO 280
74843  imin=i
74844  r2min=r2
74845  280 CONTINUE
74846  IF(imin.NE.0) THEN
74847  DO 290 j=1,4
74848  p(n+npre,j)=p(n+npre,j)+p(imin,j)
74849  290 CONTINUE
74850  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
74851  nrem=nrem-1
74852  k(imin,4)=npre
74853  GOTO 270
74854  ENDIF
74855  ENDIF
74856 
74857 C...Check if more preclusters to be found. Start over if too few.
74858  IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
74859  IF(nrem.GT.0) GOTO 220
74860  njet=npre
74861 
74862 C...Reassign all particles to nearest jet. Sum up new jet momenta.
74863  300 tsav=0d0
74864  psjt=0d0
74865  310 IF(mstu(46).LE.1) THEN
74866  DO 330 i=n+1,n+njet
74867  DO 320 j=1,4
74868  v(i,j)=0d0
74869  320 CONTINUE
74870  330 CONTINUE
74871  DO 360 i=n+np+1,n+2*np
74872  r2min=pss**2
74873  DO 340 ijet=n+1,n+njet
74874  IF(p(ijet,5).LT.rinit) GOTO 340
74875  r2=r2t(i,ijet)
74876  IF(r2.GE.r2min) GOTO 340
74877  imin=ijet
74878  r2min=r2
74879  340 CONTINUE
74880  k(i,4)=imin-n
74881  DO 350 j=1,4
74882  v(imin,j)=v(imin,j)+p(i,j)
74883  350 CONTINUE
74884  360 CONTINUE
74885  psjt=0d0
74886  DO 380 i=n+1,n+njet
74887  DO 370 j=1,4
74888  p(i,j)=v(i,j)
74889  370 CONTINUE
74890  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74891  psjt=psjt+p(i,5)
74892  380 CONTINUE
74893  ENDIF
74894 
74895 C...Find two closest jets.
74896  r2min=2d0*max(r2acc,ps(5)**2)
74897  DO 400 itry1=n+1,n+njet-1
74898  DO 390 itry2=itry1+1,n+njet
74899  IF(mstu(46).LE.2) THEN
74900  r2=r2t(itry1,itry2)
74901  ELSEIF(mstu(46).LE.4) THEN
74902  r2=r2m(itry1,itry2)
74903  ELSE
74904  r2=r2d(itry1,itry2)
74905  ENDIF
74906  IF(r2.GE.r2min) GOTO 390
74907  imin1=itry1
74908  imin2=itry2
74909  r2min=r2
74910  390 CONTINUE
74911  400 CONTINUE
74912 
74913 C...If allowed, join two closest jets and start over.
74914  IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
74915  irec=min(imin1,imin2)
74916  idel=max(imin1,imin2)
74917  DO 410 j=1,4
74918  p(irec,j)=p(imin1,j)+p(imin2,j)
74919  410 CONTINUE
74920  p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
74921  DO 430 i=idel+1,n+njet
74922  DO 420 j=1,5
74923  p(i-1,j)=p(i,j)
74924  420 CONTINUE
74925  430 CONTINUE
74926  IF(mstu(46).GE.2) THEN
74927  DO 440 i=n+np+1,n+2*np
74928  iori=n+k(i,4)
74929  IF(iori.EQ.idel) k(i,4)=irec-n
74930  IF(iori.GT.idel) k(i,4)=k(i,4)-1
74931  440 CONTINUE
74932  ENDIF
74933  njet=njet-1
74934  GOTO 300
74935 
74936 C...Divide up broad jet if empty cluster in list of final ones.
74937  ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
74938  DO 450 i=n+1,n+njet
74939  k(i,5)=0
74940  450 CONTINUE
74941  DO 460 i=n+np+1,n+2*np
74942  k(n+k(i,4),5)=k(n+k(i,4),5)+1
74943  460 CONTINUE
74944  iemp=0
74945  DO 470 i=n+1,n+njet
74946  IF(k(i,5).EQ.0) iemp=i
74947  470 CONTINUE
74948  IF(iemp.NE.0) THEN
74949  nloop=nloop+1
74950  ispl=0
74951  r2max=0d0
74952  DO 480 i=n+np+1,n+2*np
74953  IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) GOTO 480
74954  ijet=n+k(i,4)
74955  r2=r2t(i,ijet)
74956  IF(r2.LE.r2max) GOTO 480
74957  ispl=i
74958  r2max=r2
74959  480 CONTINUE
74960  IF(ispl.NE.0) THEN
74961  ijet=n+k(ispl,4)
74962  DO 490 j=1,4
74963  p(iemp,j)=p(ispl,j)
74964  p(ijet,j)=p(ijet,j)-p(ispl,j)
74965  490 CONTINUE
74966  p(iemp,5)=p(ispl,5)
74967  p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
74968  IF(nloop.LE.2) GOTO 300
74969  ENDIF
74970  ENDIF
74971  ENDIF
74972 
74973 C...If generalized thrust has not yet converged, continue iteration.
74974  IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
74975  &THEN
74976  tsav=psjt/pss
74977  GOTO 310
74978  ENDIF
74979 
74980 C...Reorder jets according to energy.
74981  DO 510 i=n+1,n+njet
74982  DO 500 j=1,5
74983  v(i,j)=p(i,j)
74984  500 CONTINUE
74985  510 CONTINUE
74986  DO 540 inew=n+1,n+njet
74987  pemax=0d0
74988  DO 520 itry=n+1,n+njet
74989  IF(v(itry,4).LE.pemax) GOTO 520
74990  imax=itry
74991  pemax=v(itry,4)
74992  520 CONTINUE
74993  k(inew,1)=31
74994  k(inew,2)=97
74995  k(inew,3)=inew-n
74996  k(inew,4)=0
74997  DO 530 j=1,5
74998  p(inew,j)=v(imax,j)
74999  530 CONTINUE
75000  v(imax,4)=-1d0
75001  k(imax,5)=inew
75002  540 CONTINUE
75003 
75004 C...Clean up particle-jet assignments and jet information.
75005  DO 550 i=n+np+1,n+2*np
75006  iori=k(n+k(i,4),5)
75007  k(i,4)=iori-n
75008  IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
75009  k(iori,4)=k(iori,4)+1
75010  550 CONTINUE
75011  iemp=0
75012  psjt=0d0
75013  DO 570 i=n+1,n+njet
75014  k(i,5)=0
75015  psjt=psjt+p(i,5)
75016  p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0d0))
75017  DO 560 j=1,5
75018  v(i,j)=0d0
75019  560 CONTINUE
75020  IF(k(i,4).EQ.0) iemp=i
75021  570 CONTINUE
75022 
75023 C...Select storing option. Output variables. Check for failure.
75024  mstu(61)=n+1
75025  mstu(62)=np
75026  mstu(63)=npre
75027  paru(61)=ps(5)
75028  paru(62)=psjt/pss
75029  paru(63)=sqrt(r2min)
75030  IF(njet.LE.1) paru(63)=0d0
75031  IF(iemp.NE.0) THEN
75032  CALL pyerrm(8,'(PYCLUS:) failed to reconstruct as requested')
75033  njet=-1
75034  RETURN
75035  ENDIF
75036  IF(mstu(43).LE.1) mstu(3)=max(0,njet)
75037  IF(mstu(43).GE.2) n=n+max(0,njet)
75038  nsav=njet
75039 
75040  RETURN
75041  END
75042 
75043 C*********************************************************************
75044 
75045 C...PYCELL
75046 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75047 C...as used for calorimeters at hadron colliders.
75048 
75049  SUBROUTINE pycell(NJET)
75050 
75051 C...Double precision and integer declarations.
75052  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75053  IMPLICIT INTEGER(I-N)
75054  INTEGER PYK,PYCHGE,PYCOMP
75055 C...Parameter statement to help give large particle numbers.
75056  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75057  &kexcit=4000000,kdimen=5000000)
75058 C...Commonblocks.
75059  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75060  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75061  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75062  SAVE /pyjets/,/pydat1/,/pydat2/
75063 
75064 C...Loop over all particles. Find cell that was hit by given particle.
75065  ptlrat=1d0/sinh(paru(51))**2
75066  np=0
75067  nc=n
75068  DO 110 i=1,n
75069  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
75070  IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) GOTO 110
75071  IF(mstu(41).GE.2) THEN
75072  kc=pycomp(k(i,2))
75073  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75074  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75075  & k(i,2).EQ.ksusy1+39) GOTO 110
75076  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
75077  & GOTO 110
75078  ENDIF
75079  np=np+1
75080  pt=sqrt(p(i,1)**2+p(i,2)**2)
75081  eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
75082  ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5d0*
75083  & (eta/paru(51)+1d0))))
75084  phi=pyangl(p(i,1),p(i,2))
75085  iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5d0*
75086  & (phi/paru(1)+1d0))))
75087  ietph=mstu(52)*ieta+iphi
75088 
75089 C...Add to cell already hit, or book new cell.
75090  DO 100 ic=n+1,nc
75091  IF(ietph.EQ.k(ic,3)) THEN
75092  k(ic,4)=k(ic,4)+1
75093  p(ic,5)=p(ic,5)+pt
75094  GOTO 110
75095  ENDIF
75096  100 CONTINUE
75097  IF(nc.GE.mstu(4)-mstu(32)-5) THEN
75098  CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
75099  njet=-2
75100  RETURN
75101  ENDIF
75102  nc=nc+1
75103  k(nc,3)=ietph
75104  k(nc,4)=1
75105  k(nc,5)=2
75106  p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
75107  p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
75108  p(nc,5)=pt
75109  110 CONTINUE
75110 
75111 C...Smear true bin content by calorimeter resolution.
75112  IF(mstu(53).GE.1) THEN
75113  DO 130 ic=n+1,nc
75114  pei=p(ic,5)
75115  IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))
75116  120 pef=pei+paru(55)*sqrt(-2d0*log(max(1d-10,pyr(0)))*pei)*
75117  & cos(paru(2)*pyr(0))
75118  IF(pef.LT.0d0.OR.pef.GT.paru(56)*pei) GOTO 120
75119  p(ic,5)=pef
75120  IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))
75121  130 CONTINUE
75122  ENDIF
75123 
75124 C...Remove cells below threshold.
75125  IF(paru(58).GT.0d0) THEN
75126  ncc=nc
75127  nc=n
75128  DO 140 ic=n+1,ncc
75129  IF(p(ic,5).GT.paru(58)) THEN
75130  nc=nc+1
75131  k(nc,3)=k(ic,3)
75132  k(nc,4)=k(ic,4)
75133  k(nc,5)=k(ic,5)
75134  p(nc,1)=p(ic,1)
75135  p(nc,2)=p(ic,2)
75136  p(nc,5)=p(ic,5)
75137  ENDIF
75138  140 CONTINUE
75139  ENDIF
75140 
75141 C...Find initiator cell: the one with highest pT of not yet used ones.
75142  nj=nc
75143  150 etmax=0d0
75144  DO 160 ic=n+1,nc
75145  IF(k(ic,5).NE.2) GOTO 160
75146  IF(p(ic,5).LE.etmax) GOTO 160
75147  icmax=ic
75148  eta=p(ic,1)
75149  phi=p(ic,2)
75150  etmax=p(ic,5)
75151  160 CONTINUE
75152  IF(etmax.LT.paru(52)) GOTO 220
75153  IF(nj.GE.mstu(4)-mstu(32)-5) THEN
75154  CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
75155  njet=-2
75156  RETURN
75157  ENDIF
75158  k(icmax,5)=1
75159  nj=nj+1
75160  k(nj,4)=0
75161  k(nj,5)=1
75162  p(nj,1)=eta
75163  p(nj,2)=phi
75164  p(nj,3)=0d0
75165  p(nj,4)=0d0
75166  p(nj,5)=0d0
75167 
75168 C...Sum up unused cells within required distance of initiator.
75169  DO 170 ic=n+1,nc
75170  IF(k(ic,5).EQ.0) GOTO 170
75171  IF(abs(p(ic,1)-eta).GT.paru(54)) GOTO 170
75172  dphia=abs(p(ic,2)-phi)
75173  IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) GOTO 170
75174  phic=p(ic,2)
75175  IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
75176  IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) GOTO 170
75177  k(ic,5)=-k(ic,5)
75178  k(nj,4)=k(nj,4)+k(ic,4)
75179  p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
75180  p(nj,4)=p(nj,4)+p(ic,5)*phic
75181  p(nj,5)=p(nj,5)+p(ic,5)
75182  170 CONTINUE
75183 
75184 C...Reject cluster below minimum ET, else accept.
75185  IF(p(nj,5).LT.paru(53)) THEN
75186  nj=nj-1
75187  DO 180 ic=n+1,nc
75188  IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
75189  180 CONTINUE
75190  ELSEIF(mstu(54).LE.2) THEN
75191  p(nj,3)=p(nj,3)/p(nj,5)
75192  p(nj,4)=p(nj,4)/p(nj,5)
75193  IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
75194  & p(nj,4))
75195  DO 190 ic=n+1,nc
75196  IF(k(ic,5).LT.0) k(ic,5)=0
75197  190 CONTINUE
75198  ELSE
75199  DO 200 j=1,4
75200  p(nj,j)=0d0
75201  200 CONTINUE
75202  DO 210 ic=n+1,nc
75203  IF(k(ic,5).GE.0) GOTO 210
75204  p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
75205  p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
75206  p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
75207  p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
75208  k(ic,5)=0
75209  210 CONTINUE
75210  ENDIF
75211  GOTO 150
75212 
75213 C...Arrange clusters in falling ET sequence.
75214  220 DO 250 i=1,nj-nc
75215  etmax=0d0
75216  DO 230 ij=nc+1,nj
75217  IF(k(ij,5).EQ.0) GOTO 230
75218  IF(p(ij,5).LT.etmax) GOTO 230
75219  ijmax=ij
75220  etmax=p(ij,5)
75221  230 CONTINUE
75222  k(ijmax,5)=0
75223  k(n+i,1)=31
75224  k(n+i,2)=98
75225  k(n+i,3)=i
75226  k(n+i,4)=k(ijmax,4)
75227  k(n+i,5)=0
75228  DO 240 j=1,5
75229  p(n+i,j)=p(ijmax,j)
75230  v(n+i,j)=0d0
75231  240 CONTINUE
75232  250 CONTINUE
75233  njet=nj-nc
75234 
75235 C...Convert to massless or massive four-vectors.
75236  IF(mstu(54).EQ.2) THEN
75237  DO 260 i=n+1,n+njet
75238  eta=p(i,3)
75239  p(i,1)=p(i,5)*cos(p(i,4))
75240  p(i,2)=p(i,5)*sin(p(i,4))
75241  p(i,3)=p(i,5)*sinh(eta)
75242  p(i,4)=p(i,5)*cosh(eta)
75243  p(i,5)=0d0
75244  260 CONTINUE
75245  ELSEIF(mstu(54).GE.3) THEN
75246  DO 270 i=n+1,n+njet
75247  p(i,5)=sqrt(max(0d0,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
75248  270 CONTINUE
75249  ENDIF
75250 
75251 C...Information about storage.
75252  mstu(61)=n+1
75253  mstu(62)=np
75254  mstu(63)=nc-n
75255  IF(mstu(43).LE.1) mstu(3)=max(0,njet)
75256  IF(mstu(43).GE.2) n=n+max(0,njet)
75257 
75258  RETURN
75259  END
75260 
75261 C*********************************************************************
75262 
75263 C...PYJMAS
75264 C...Determines, approximately, the two jet masses that minimize
75265 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75266 
75267  SUBROUTINE pyjmas(PMH,PML)
75268 
75269 C...Double precision and integer declarations.
75270  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75271  IMPLICIT INTEGER(I-N)
75272  INTEGER PYK,PYCHGE,PYCOMP
75273 C...Parameter statement to help give large particle numbers.
75274  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75275  &kexcit=4000000,kdimen=5000000)
75276 C...Commonblocks.
75277  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75278  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75279  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75280  SAVE /pyjets/,/pydat1/,/pydat2/
75281 C...Local arrays.
75282  dimension sm(3,3),sax(3),ps(3,5)
75283 
75284 C...Reset.
75285  np=0
75286  DO 120 j1=1,3
75287  DO 100 j2=j1,3
75288  sm(j1,j2)=0d0
75289  100 CONTINUE
75290  DO 110 j2=1,4
75291  ps(j1,j2)=0d0
75292  110 CONTINUE
75293  120 CONTINUE
75294  pss=0d0
75295  pimass=pmas(pycomp(211),1)
75296 
75297 C...Take copy of particles that are to be considered in mass analysis.
75298  DO 170 i=1,n
75299  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 170
75300  IF(mstu(41).GE.2) THEN
75301  kc=pycomp(k(i,2))
75302  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75303  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75304  & k(i,2).EQ.ksusy1+39) GOTO 170
75305  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
75306  & GOTO 170
75307  ENDIF
75308  IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
75309  CALL pyerrm(11,'(PYJMAS:) no more memory left in PYJETS')
75310  pmh=-2d0
75311  pml=-2d0
75312  RETURN
75313  ENDIF
75314  np=np+1
75315  DO 130 j=1,5
75316  p(n+np,j)=p(i,j)
75317  130 CONTINUE
75318  IF(mstu(42).EQ.0) p(n+np,5)=0d0
75319  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
75320  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
75321 
75322 C...Fill information in sphericity tensor and total momentum vector.
75323  DO 150 j1=1,3
75324  DO 140 j2=j1,3
75325  sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
75326  140 CONTINUE
75327  150 CONTINUE
75328  pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
75329  DO 160 j=1,4
75330  ps(3,j)=ps(3,j)+p(n+np,j)
75331  160 CONTINUE
75332  170 CONTINUE
75333 
75334 C...Very low multiplicities (0 or 1) not considered.
75335  IF(np.LE.1) THEN
75336  CALL pyerrm(8,'(PYJMAS:) too few particles for analysis')
75337  pmh=-1d0
75338  pml=-1d0
75339  RETURN
75340  ENDIF
75341  paru(61)=sqrt(max(0d0,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-
75342  &ps(3,3)**2))
75343 
75344 C...Find largest eigenvalue to matrix (third degree equation).
75345  DO 190 j1=1,3
75346  DO 180 j2=j1,3
75347  sm(j1,j2)=sm(j1,j2)/pss
75348  180 CONTINUE
75349  190 CONTINUE
75350  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
75351  &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
75352  sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
75353  &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
75354  &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
75355  sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
75356  sma=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
75357 
75358 C...Find largest eigenvector by solving equation system.
75359  DO 210 j1=1,3
75360  sm(j1,j1)=sm(j1,j1)-sma
75361  DO 200 j2=j1+1,3
75362  sm(j2,j1)=sm(j1,j2)
75363  200 CONTINUE
75364  210 CONTINUE
75365  smax=0d0
75366  DO 230 j1=1,3
75367  DO 220 j2=1,3
75368  IF(abs(sm(j1,j2)).LE.smax) GOTO 220
75369  ja=j1
75370  jb=j2
75371  smax=abs(sm(j1,j2))
75372  220 CONTINUE
75373  230 CONTINUE
75374  smax=0d0
75375  DO 250 j3=ja+1,ja+2
75376  j1=j3-3*((j3-1)/3)
75377  rl=sm(j1,jb)/sm(ja,jb)
75378  DO 240 j2=1,3
75379  sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
75380  IF(abs(sm(j1,j2)).LE.smax) GOTO 240
75381  jc=j1
75382  smax=abs(sm(j1,j2))
75383  240 CONTINUE
75384  250 CONTINUE
75385  jb1=jb+1-3*(jb/3)
75386  jb2=jb+2-3*((jb+1)/3)
75387  sax(jb1)=-sm(jc,jb2)
75388  sax(jb2)=sm(jc,jb1)
75389  sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
75390 
75391 C...Divide particles into two initial clusters by hemisphere.
75392  DO 270 i=n+1,n+np
75393  psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
75394  is=1
75395  IF(psax.LT.0d0) is=2
75396  k(i,3)=is
75397  DO 260 j=1,4
75398  ps(is,j)=ps(is,j)+p(i,j)
75399  260 CONTINUE
75400  270 CONTINUE
75401  pms=max(1d-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
75402  &max(1d-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
75403 
75404 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75405  280 pmd=0d0
75406  im=0
75407  DO 290 j=1,4
75408  ps(3,j)=ps(1,j)-ps(2,j)
75409  290 CONTINUE
75410  DO 300 i=n+1,n+np
75411  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)
75412  IF(k(i,3).EQ.1) pmdi=2d0*(p(i,5)**2-pps)
75413  IF(k(i,3).EQ.2) pmdi=2d0*(p(i,5)**2+pps)
75414  IF(pmdi.LT.pmd) THEN
75415  pmd=pmdi
75416  im=i
75417  ENDIF
75418  300 CONTINUE
75419 
75420 C...Loop back if significant reduction in sum of m^2.
75421  IF(pmd.LT.-paru(48)*pms) THEN
75422  pms=pms+pmd
75423  is=k(im,3)
75424  DO 310 j=1,4
75425  ps(is,j)=ps(is,j)-p(im,j)
75426  ps(3-is,j)=ps(3-is,j)+p(im,j)
75427  310 CONTINUE
75428  k(im,3)=3-is
75429  GOTO 280
75430  ENDIF
75431 
75432 C...Final masses and output.
75433  mstu(61)=n+1
75434  mstu(62)=np
75435  ps(1,5)=sqrt(max(0d0,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
75436  ps(2,5)=sqrt(max(0d0,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
75437  pmh=max(ps(1,5),ps(2,5))
75438  pml=min(ps(1,5),ps(2,5))
75439 
75440  RETURN
75441  END
75442 
75443 C*********************************************************************
75444 
75445 C...PYFOWO
75446 C...Calculates the first few Fox-Wolfram moments.
75447 
75448  SUBROUTINE pyfowo(H10,H20,H30,H40)
75449 
75450 C...Double precision and integer declarations.
75451  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75452  IMPLICIT INTEGER(I-N)
75453  INTEGER PYK,PYCHGE,PYCOMP
75454 C...Parameter statement to help give large particle numbers.
75455  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75456  &kexcit=4000000,kdimen=5000000)
75457 C...Commonblocks.
75458  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75459  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75460  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75461  SAVE /pyjets/,/pydat1/,/pydat2/
75462 
75463 C...Copy momenta for particles and calculate H0.
75464  np=0
75465  h0=0d0
75466  hd=0d0
75467  DO 110 i=1,n
75468  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
75469  IF(mstu(41).GE.2) THEN
75470  kc=pycomp(k(i,2))
75471  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75472  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75473  & k(i,2).EQ.ksusy1+39) GOTO 110
75474  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
75475  & GOTO 110
75476  ENDIF
75477  IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
75478  CALL pyerrm(11,'(PYFOWO:) no more memory left in PYJETS')
75479  h10=-1d0
75480  h20=-1d0
75481  h30=-1d0
75482  h40=-1d0
75483  RETURN
75484  ENDIF
75485  np=np+1
75486  DO 100 j=1,3
75487  p(n+np,j)=p(i,j)
75488  100 CONTINUE
75489  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
75490  h0=h0+p(n+np,4)
75491  hd=hd+p(n+np,4)**2
75492  110 CONTINUE
75493  h0=h0**2
75494 
75495 C...Very low multiplicities (0 or 1) not considered.
75496  IF(np.LE.1) THEN
75497  CALL pyerrm(8,'(PYFOWO:) too few particles for analysis')
75498  h10=-1d0
75499  h20=-1d0
75500  h30=-1d0
75501  h40=-1d0
75502  RETURN
75503  ENDIF
75504 
75505 C...Calculate H1 - H4.
75506  h10=0d0
75507  h20=0d0
75508  h30=0d0
75509  h40=0d0
75510  DO 130 i1=n+1,n+np
75511  DO 120 i2=i1+1,n+np
75512  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
75513  & (p(i1,4)*p(i2,4))
75514  h10=h10+p(i1,4)*p(i2,4)*cthe
75515  h20=h20+p(i1,4)*p(i2,4)*(1.5d0*cthe**2-0.5d0)
75516  h30=h30+p(i1,4)*p(i2,4)*(2.5d0*cthe**3-1.5d0*cthe)
75517  h40=h40+p(i1,4)*p(i2,4)*(4.375d0*cthe**4-3.75d0*cthe**2+
75518  & 0.375d0)
75519  120 CONTINUE
75520  130 CONTINUE
75521 
75522 C...Calculate H1/H0 - H4/H0. Output.
75523  mstu(61)=n+1
75524  mstu(62)=np
75525  h10=(hd+2d0*h10)/h0
75526  h20=(hd+2d0*h20)/h0
75527  h30=(hd+2d0*h30)/h0
75528  h40=(hd+2d0*h40)/h0
75529 
75530  RETURN
75531  END
75532 
75533 C*********************************************************************
75534 
75535 C...PYTABU
75536 C...Evaluates various properties of an event, with statistics
75537 C...accumulated during the course of the run and
75538 C...printed at the end.
75539 
75540  SUBROUTINE pytabu(MTABU)
75541 
75542 C...Double precision and integer declarations.
75543  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75544  IMPLICIT INTEGER(I-N)
75545  INTEGER PYK,PYCHGE,PYCOMP
75546 C...Parameter statement to help give large particle numbers.
75547  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75548  &kexcit=4000000,kdimen=5000000)
75549 C...Commonblocks.
75550  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75551  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75552  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75553  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
75554  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
75555 C...Local arrays, character variables, saved variables and data.
75556  dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
75557  &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
75558  &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
75559  &kfdm(8),kfdc(200,0:8),npdc(200)
75560  SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
75561  &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
75562  &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
75563  CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75564  DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
75565  &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0d0/,fm2fm/120*0d0/,
75566  &nevee/0/,fe1ec/50*0d0/,fe2ec/50*0d0/,fe1ea/25*0d0/,fe2ea/25*0d0/,
75567  &nevdc/0/,nkfdc/0/,nredc/0/
75568 
75569 C...Reset statistics on initial parton state.
75570  IF(mtabu.EQ.10) THEN
75571  nevis=0
75572  nkfis=0
75573 
75574 C...Identify and order flavour content of initial state.
75575  ELSEIF(mtabu.EQ.11) THEN
75576  nevis=nevis+1
75577  kfm1=2*iabs(mstu(161))
75578  IF(mstu(161).GT.0) kfm1=kfm1-1
75579  kfm2=2*iabs(mstu(162))
75580  IF(mstu(162).GT.0) kfm2=kfm2-1
75581  kfmn=min(kfm1,kfm2)
75582  kfmx=max(kfm1,kfm2)
75583  DO 100 i=1,nkfis
75584  IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
75585  ikfis=-i
75586  GOTO 110
75587  ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
75588  & kfmx.LT.kfis(i,2))) THEN
75589  ikfis=i
75590  GOTO 110
75591  ENDIF
75592  100 CONTINUE
75593  ikfis=nkfis+1
75594  110 IF(ikfis.LT.0) THEN
75595  ikfis=-ikfis
75596  ELSE
75597  IF(nkfis.GE.100) RETURN
75598  DO 130 i=nkfis,ikfis,-1
75599  kfis(i+1,1)=kfis(i,1)
75600  kfis(i+1,2)=kfis(i,2)
75601  DO 120 j=0,10
75602  npis(i+1,j)=npis(i,j)
75603  120 CONTINUE
75604  130 CONTINUE
75605  nkfis=nkfis+1
75606  kfis(ikfis,1)=kfmn
75607  kfis(ikfis,2)=kfmx
75608  DO 140 j=0,10
75609  npis(ikfis,j)=0
75610  140 CONTINUE
75611  ENDIF
75612  npis(ikfis,0)=npis(ikfis,0)+1
75613 
75614 C...Count number of partons in initial state.
75615  np=0
75616  DO 160 i=1,n
75617  IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
75618  ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
75619  ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
75620  & THEN
75621  ELSE
75622  im=i
75623  150 im=k(im,3)
75624  IF(im.LE.0.OR.im.GT.n) THEN
75625  np=np+1
75626  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
75627  np=np+1
75628  ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
75629  ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10)
75630  & .NE.0) THEN
75631  ELSE
75632  GOTO 150
75633  ENDIF
75634  ENDIF
75635  160 CONTINUE
75636  npco=max(np,1)
75637  IF(np.GE.6) npco=6
75638  IF(np.GE.8) npco=7
75639  IF(np.GE.11) npco=8
75640  IF(np.GE.16) npco=9
75641  IF(np.GE.26) npco=10
75642  npis(ikfis,npco)=npis(ikfis,npco)+1
75643  mstu(62)=np
75644 
75645 C...Write statistics on initial parton state.
75646  ELSEIF(mtabu.EQ.12) THEN
75647  fac=1d0/max(1,nevis)
75648  WRITE(mstu(11),5000) nevis
75649  DO 170 i=1,nkfis
75650  kfmn=kfis(i,1)
75651  IF(kfmn.EQ.0) kfmn=kfis(i,2)
75652  kfm1=(kfmn+1)/2
75653  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
75654  CALL pyname(kfm1,chau)
75655  chis(1)=chau(1:12)
75656  IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
75657  kfmx=kfis(i,2)
75658  IF(kfis(i,1).EQ.0) kfmx=0
75659  kfm2=(kfmx+1)/2
75660  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
75661  CALL pyname(kfm2,chau)
75662  chis(2)=chau(1:12)
75663  IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
75664  WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
75665  & (npis(i,j)/dble(npis(i,0)),j=1,10)
75666  170 CONTINUE
75667 
75668 C...Copy statistics on initial parton state into /PYJETS/.
75669  ELSEIF(mtabu.EQ.13) THEN
75670  fac=1d0/max(1,nevis)
75671  DO 190 i=1,nkfis
75672  kfmn=kfis(i,1)
75673  IF(kfmn.EQ.0) kfmn=kfis(i,2)
75674  kfm1=(kfmn+1)/2
75675  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
75676  kfmx=kfis(i,2)
75677  IF(kfis(i,1).EQ.0) kfmx=0
75678  kfm2=(kfmx+1)/2
75679  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
75680  k(i,1)=32
75681  k(i,2)=99
75682  k(i,3)=kfm1
75683  k(i,4)=kfm2
75684  k(i,5)=npis(i,0)
75685  DO 180 j=1,5
75686  p(i,j)=fac*npis(i,j)
75687  v(i,j)=fac*npis(i,j+5)
75688  180 CONTINUE
75689  190 CONTINUE
75690  n=nkfis
75691  DO 200 j=1,5
75692  k(n+1,j)=0
75693  p(n+1,j)=0d0
75694  v(n+1,j)=0d0
75695  200 CONTINUE
75696  k(n+1,1)=32
75697  k(n+1,2)=99
75698  k(n+1,5)=nevis
75699  mstu(3)=1
75700 
75701 C...Reset statistics on number of particles/partons.
75702  ELSEIF(mtabu.EQ.20) THEN
75703  nevfs=0
75704  nprfs=0
75705  nfifs=0
75706  nchfs=0
75707  nkffs=0
75708 
75709 C...Identify whether particle/parton is primary or not.
75710  ELSEIF(mtabu.EQ.21) THEN
75711  nevfs=nevfs+1
75712  mstu(62)=0
75713  DO 260 i=1,n
75714  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) GOTO 260
75715  mstu(62)=mstu(62)+1
75716  kc=pycomp(k(i,2))
75717  mpri=0
75718  IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
75719  mpri=1
75720  ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
75721  mpri=1
75722  ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
75723  mpri=1
75724  ELSEIF(kc.EQ.0) THEN
75725  ELSEIF(k(k(i,3),1).EQ.13) THEN
75726  im=k(k(i,3),3)
75727  IF(im.LE.0.OR.im.GT.n) THEN
75728  mpri=1
75729  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
75730  mpri=1
75731  ENDIF
75732  ELSEIF(kchg(kc,2).EQ.0) THEN
75733  kcm=pycomp(k(k(i,3),2))
75734  IF(kcm.NE.0) THEN
75735  IF(kchg(kcm,2).NE.0) mpri=1
75736  ENDIF
75737  ENDIF
75738  IF(kc.NE.0.AND.mpri.EQ.1) THEN
75739  IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
75740  ENDIF
75741  IF(k(i,1).LE.10) THEN
75742  nfifs=nfifs+1
75743  IF(pychge(k(i,2)).NE.0) nchfs=nchfs+1
75744  ENDIF
75745 
75746 C...Fill statistics on number of particles/partons in event.
75747  kfa=iabs(k(i,2))
75748  kfs=3-isign(1,k(i,2))-mpri
75749  DO 210 ip=1,nkffs
75750  IF(kfa.EQ.kffs(ip)) THEN
75751  ikffs=-ip
75752  GOTO 220
75753  ELSEIF(kfa.LT.kffs(ip)) THEN
75754  ikffs=ip
75755  GOTO 220
75756  ENDIF
75757  210 CONTINUE
75758  ikffs=nkffs+1
75759  220 IF(ikffs.LT.0) THEN
75760  ikffs=-ikffs
75761  ELSE
75762  IF(nkffs.GE.400) RETURN
75763  DO 240 ip=nkffs,ikffs,-1
75764  kffs(ip+1)=kffs(ip)
75765  DO 230 j=1,4
75766  npfs(ip+1,j)=npfs(ip,j)
75767  230 CONTINUE
75768  240 CONTINUE
75769  nkffs=nkffs+1
75770  kffs(ikffs)=kfa
75771  DO 250 j=1,4
75772  npfs(ikffs,j)=0
75773  250 CONTINUE
75774  ENDIF
75775  npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
75776  260 CONTINUE
75777 
75778 C...Write statistics on particle/parton composition of events.
75779  ELSEIF(mtabu.EQ.22) THEN
75780  fac=1d0/max(1,nevfs)
75781  WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
75782  DO 270 i=1,nkffs
75783  CALL pyname(kffs(i),chau)
75784  kc=pycomp(kffs(i))
75785  mdcyf=0
75786  IF(kc.NE.0) mdcyf=mdcy(kc,1)
75787  WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
75788  & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
75789  270 CONTINUE
75790 
75791 C...Copy particle/parton composition information into /PYJETS/.
75792  ELSEIF(mtabu.EQ.23) THEN
75793  fac=1d0/max(1,nevfs)
75794  DO 290 i=1,nkffs
75795  k(i,1)=32
75796  k(i,2)=99
75797  k(i,3)=kffs(i)
75798  k(i,4)=0
75799  k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
75800  DO 280 j=1,4
75801  p(i,j)=fac*npfs(i,j)
75802  v(i,j)=0d0
75803  280 CONTINUE
75804  p(i,5)=fac*k(i,5)
75805  v(i,5)=0d0
75806  290 CONTINUE
75807  n=nkffs
75808  DO 300 j=1,5
75809  k(n+1,j)=0
75810  p(n+1,j)=0d0
75811  v(n+1,j)=0d0
75812  300 CONTINUE
75813  k(n+1,1)=32
75814  k(n+1,2)=99
75815  k(n+1,5)=nevfs
75816  p(n+1,1)=fac*nprfs
75817  p(n+1,2)=fac*nfifs
75818  p(n+1,3)=fac*nchfs
75819  mstu(3)=1
75820 
75821 C...Reset factorial moments statistics.
75822  ELSEIF(mtabu.EQ.30) THEN
75823  nevfm=0
75824  nmufm=0
75825  DO 330 im=1,3
75826  DO 320 ib=1,10
75827  DO 310 ip=1,4
75828  fm1fm(im,ib,ip)=0d0
75829  fm2fm(im,ib,ip)=0d0
75830  310 CONTINUE
75831  320 CONTINUE
75832  330 CONTINUE
75833 
75834 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75835  ELSEIF(mtabu.EQ.31) THEN
75836  nevfm=nevfm+1
75837  nlow=n+mstu(3)
75838  nupp=nlow
75839  DO 410 i=1,n
75840  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 410
75841  IF(mstu(41).GE.2) THEN
75842  kc=pycomp(k(i,2))
75843  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75844  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75845  & k(i,2).EQ.ksusy1+39) GOTO 410
75846  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
75847  & pychge(k(i,2)).EQ.0) GOTO 410
75848  ENDIF
75849  pmr=0d0
75850  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
75851  IF(mstu(42).GE.2) pmr=p(i,5)
75852  pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
75853  yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
75854  & 1d20)),p(i,3))
75855  IF(abs(yeta).GT.paru(57)) GOTO 410
75856  phi=pyangl(p(i,1),p(i,2))
75857  iyeta=512d0*(yeta+paru(57))/(2d0*paru(57))
75858  iyeta=max(0,min(511,iyeta))
75859  iphi=512d0*(phi+paru(1))/paru(2)
75860  iphi=max(0,min(511,iphi))
75861  iyep=0
75862  DO 340 ib=0,9
75863  iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
75864  340 CONTINUE
75865 
75866 C...Order particles in (pseudo)rapidity and/or azimuth.
75867  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
75868  CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
75869  RETURN
75870  ENDIF
75871  nupp=nupp+1
75872  IF(nupp.EQ.nlow+1) THEN
75873  k(nupp,1)=iyeta
75874  k(nupp,2)=iphi
75875  k(nupp,3)=iyep
75876  ELSE
75877  DO 350 i1=nupp-1,nlow+1,-1
75878  IF(iyeta.GE.k(i1,1)) GOTO 360
75879  k(i1+1,1)=k(i1,1)
75880  350 CONTINUE
75881  360 k(i1+1,1)=iyeta
75882  DO 370 i1=nupp-1,nlow+1,-1
75883  IF(iphi.GE.k(i1,2)) GOTO 380
75884  k(i1+1,2)=k(i1,2)
75885  370 CONTINUE
75886  380 k(i1+1,2)=iphi
75887  DO 390 i1=nupp-1,nlow+1,-1
75888  IF(iyep.GE.k(i1,3)) GOTO 400
75889  k(i1+1,3)=k(i1,3)
75890  390 CONTINUE
75891  400 k(i1+1,3)=iyep
75892  ENDIF
75893  410 CONTINUE
75894  k(nupp+1,1)=2**10
75895  k(nupp+1,2)=2**10
75896  k(nupp+1,3)=4**10
75897 
75898 C...Calculate sum of factorial moments in event.
75899  DO 480 im=1,3
75900  DO 430 ib=1,10
75901  DO 420 ip=1,4
75902  fevfm(ib,ip)=0d0
75903  420 CONTINUE
75904  430 CONTINUE
75905  DO 450 ib=1,10
75906  IF(im.LE.2) ibin=2**(10-ib)
75907  IF(im.EQ.3) ibin=4**(10-ib)
75908  iagr=k(nlow+1,im)/ibin
75909  nagr=1
75910  DO 440 i=nlow+2,nupp+1
75911  icut=k(i,im)/ibin
75912  IF(icut.EQ.iagr) THEN
75913  nagr=nagr+1
75914  ELSE
75915  IF(nagr.EQ.1) THEN
75916  ELSEIF(nagr.EQ.2) THEN
75917  fevfm(ib,1)=fevfm(ib,1)+2d0
75918  ELSEIF(nagr.EQ.3) THEN
75919  fevfm(ib,1)=fevfm(ib,1)+6d0
75920  fevfm(ib,2)=fevfm(ib,2)+6d0
75921  ELSEIF(nagr.EQ.4) THEN
75922  fevfm(ib,1)=fevfm(ib,1)+12d0
75923  fevfm(ib,2)=fevfm(ib,2)+24d0
75924  fevfm(ib,3)=fevfm(ib,3)+24d0
75925  ELSE
75926  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1d0)
75927  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1d0)*(nagr-2d0)
75928  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1d0)*(nagr-2d0)*
75929  & (nagr-3d0)
75930  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1d0)*(nagr-2d0)*
75931  & (nagr-3d0)*(nagr-4d0)
75932  ENDIF
75933  iagr=icut
75934  nagr=1
75935  ENDIF
75936  440 CONTINUE
75937  450 CONTINUE
75938 
75939 C...Add results to total statistics.
75940  DO 470 ib=10,1,-1
75941  DO 460 ip=1,4
75942  IF(fevfm(1,ip).LT.0.5d0) THEN
75943  fevfm(ib,ip)=0d0
75944  ELSEIF(im.LE.2) THEN
75945  fevfm(ib,ip)=2d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
75946  ELSE
75947  fevfm(ib,ip)=4d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
75948  ENDIF
75949  fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
75950  fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
75951  460 CONTINUE
75952  470 CONTINUE
75953  480 CONTINUE
75954  nmufm=nmufm+(nupp-nlow)
75955  mstu(62)=nupp-nlow
75956 
75957 C...Write accumulated statistics on factorial moments.
75958  ELSEIF(mtabu.EQ.32) THEN
75959  fac=1d0/max(1,nevfm)
75960  IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
75961  IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
75962  IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
75963  DO 510 im=1,3
75964  WRITE(mstu(11),5500)
75965  DO 500 ib=1,10
75966  byeta=2d0*paru(57)
75967  IF(im.NE.2) byeta=byeta/2**(ib-1)
75968  bphi=paru(2)
75969  IF(im.NE.1) bphi=bphi/2**(ib-1)
75970  IF(im.LE.2) bnave=fac*nmufm/dble(2**(ib-1))
75971  IF(im.EQ.3) bnave=fac*nmufm/dble(4**(ib-1))
75972  DO 490 ip=1,4
75973  fmoma(ip)=fac*fm1fm(im,ib,ip)
75974  fmoms(ip)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
75975  & fmoma(ip)**2)))
75976  490 CONTINUE
75977  WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
75978  & ip=1,4)
75979  500 CONTINUE
75980  510 CONTINUE
75981 
75982 C...Copy statistics on factorial moments into /PYJETS/.
75983  ELSEIF(mtabu.EQ.33) THEN
75984  fac=1d0/max(1,nevfm)
75985  DO 540 im=1,3
75986  DO 530 ib=1,10
75987  i=10*(im-1)+ib
75988  k(i,1)=32
75989  k(i,2)=99
75990  k(i,3)=1
75991  IF(im.NE.2) k(i,3)=2**(ib-1)
75992  k(i,4)=1
75993  IF(im.NE.1) k(i,4)=2**(ib-1)
75994  k(i,5)=0
75995  p(i,1)=2d0*paru(57)/k(i,3)
75996  v(i,1)=paru(2)/k(i,4)
75997  DO 520 ip=1,4
75998  p(i,ip+1)=fac*fm1fm(im,ib,ip)
75999  v(i,ip+1)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
76000  & p(i,ip+1)**2)))
76001  520 CONTINUE
76002  530 CONTINUE
76003  540 CONTINUE
76004  n=30
76005  DO 550 j=1,5
76006  k(n+1,j)=0
76007  p(n+1,j)=0d0
76008  v(n+1,j)=0d0
76009  550 CONTINUE
76010  k(n+1,1)=32
76011  k(n+1,2)=99
76012  k(n+1,5)=nevfm
76013  mstu(3)=1
76014 
76015 C...Reset statistics on Energy-Energy Correlation.
76016  ELSEIF(mtabu.EQ.40) THEN
76017  nevee=0
76018  DO 560 j=1,25
76019  fe1ec(j)=0d0
76020  fe2ec(j)=0d0
76021  fe1ec(51-j)=0d0
76022  fe2ec(51-j)=0d0
76023  fe1ea(j)=0d0
76024  fe2ea(j)=0d0
76025  560 CONTINUE
76026 
76027 C...Find particles to include, with proper assumed mass.
76028  ELSEIF(mtabu.EQ.41) THEN
76029  nevee=nevee+1
76030  nlow=n+mstu(3)
76031  nupp=nlow
76032  ecm=0d0
76033  DO 570 i=1,n
76034  IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 570
76035  IF(mstu(41).GE.2) THEN
76036  kc=pycomp(k(i,2))
76037  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
76038  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
76039  & k(i,2).EQ.ksusy1+39) GOTO 570
76040  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
76041  & pychge(k(i,2)).EQ.0) GOTO 570
76042  ENDIF
76043  pmr=0d0
76044  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
76045  IF(mstu(42).GE.2) pmr=p(i,5)
76046  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
76047  CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
76048  RETURN
76049  ENDIF
76050  nupp=nupp+1
76051  p(nupp,1)=p(i,1)
76052  p(nupp,2)=p(i,2)
76053  p(nupp,3)=p(i,3)
76054  p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
76055  p(nupp,5)=max(1d-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
76056  ecm=ecm+p(nupp,4)
76057  570 CONTINUE
76058  IF(nupp.EQ.nlow) RETURN
76059 
76060 C...Analyze Energy-Energy Correlation in event.
76061  fac=(2d0/ecm**2)*50d0/paru(1)
76062  DO 580 j=1,50
76063  fevee(j)=0d0
76064  580 CONTINUE
76065  DO 600 i1=nlow+2,nupp
76066  DO 590 i2=nlow+1,i1-1
76067  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
76068  & (p(i1,5)*p(i2,5))
76069  the=acos(max(-1d0,min(1d0,cthe)))
76070  ithe=max(1,min(50,1+int(50d0*the/paru(1))))
76071  fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
76072  590 CONTINUE
76073  600 CONTINUE
76074  DO 610 j=1,25
76075  fe1ec(j)=fe1ec(j)+fevee(j)
76076  fe2ec(j)=fe2ec(j)+fevee(j)**2
76077  fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
76078  fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
76079  fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
76080  fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
76081  610 CONTINUE
76082  mstu(62)=nupp-nlow
76083 
76084 C...Write statistics on Energy-Energy Correlation.
76085  ELSEIF(mtabu.EQ.42) THEN
76086  fac=1d0/max(1,nevee)
76087  WRITE(mstu(11),5700) nevee
76088  DO 620 j=1,25
76089  feec1=fac*fe1ec(j)
76090  fees1=sqrt(max(0d0,fac*(fac*fe2ec(j)-feec1**2)))
76091  feec2=fac*fe1ec(51-j)
76092  fees2=sqrt(max(0d0,fac*(fac*fe2ec(51-j)-feec2**2)))
76093  feeca=fac*fe1ea(j)
76094  feesa=sqrt(max(0d0,fac*(fac*fe2ea(j)-feeca**2)))
76095  WRITE(mstu(11),5800) 3.6d0*(j-1),3.6d0*j,feec1,fees1,
76096  & feec2,fees2,feeca,feesa
76097  620 CONTINUE
76098 
76099 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76100  ELSEIF(mtabu.EQ.43) THEN
76101  fac=1d0/max(1,nevee)
76102  DO 630 i=1,25
76103  k(i,1)=32
76104  k(i,2)=99
76105  k(i,3)=0
76106  k(i,4)=0
76107  k(i,5)=0
76108  p(i,1)=fac*fe1ec(i)
76109  v(i,1)=sqrt(max(0d0,fac*(fac*fe2ec(i)-p(i,1)**2)))
76110  p(i,2)=fac*fe1ec(51-i)
76111  v(i,2)=sqrt(max(0d0,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
76112  p(i,3)=fac*fe1ea(i)
76113  v(i,3)=sqrt(max(0d0,fac*(fac*fe2ea(i)-p(i,3)**2)))
76114  p(i,4)=paru(1)*(i-1)/50d0
76115  p(i,5)=paru(1)*i/50d0
76116  v(i,4)=3.6d0*(i-1)
76117  v(i,5)=3.6d0*i
76118  630 CONTINUE
76119  n=25
76120  DO 640 j=1,5
76121  k(n+1,j)=0
76122  p(n+1,j)=0d0
76123  v(n+1,j)=0d0
76124  640 CONTINUE
76125  k(n+1,1)=32
76126  k(n+1,2)=99
76127  k(n+1,5)=nevee
76128  mstu(3)=1
76129 
76130 C...Reset statistics on decay channels.
76131  ELSEIF(mtabu.EQ.50) THEN
76132  nevdc=0
76133  nkfdc=0
76134  nredc=0
76135 
76136 C...Identify and order flavour content of final state.
76137  ELSEIF(mtabu.EQ.51) THEN
76138  nevdc=nevdc+1
76139  nds=0
76140  DO 670 i=1,n
76141  IF(k(i,1).LE.0.OR.k(i,1).GE.6) GOTO 670
76142  nds=nds+1
76143  IF(nds.GT.8) THEN
76144  nredc=nredc+1
76145  RETURN
76146  ENDIF
76147  kfm=2*iabs(k(i,2))
76148  IF(k(i,2).LT.0) kfm=kfm-1
76149  DO 650 ids=nds-1,1,-1
76150  iin=ids+1
76151  IF(kfm.LT.kfdm(ids)) GOTO 660
76152  kfdm(ids+1)=kfdm(ids)
76153  650 CONTINUE
76154  iin=1
76155  660 kfdm(iin)=kfm
76156  670 CONTINUE
76157 
76158 C...Find whether old or new final state.
76159  DO 690 idc=1,nkfdc
76160  IF(nds.LT.kfdc(idc,0)) THEN
76161  ikfdc=idc
76162  GOTO 700
76163  ELSEIF(nds.EQ.kfdc(idc,0)) THEN
76164  DO 680 i=1,nds
76165  IF(kfdm(i).LT.kfdc(idc,i)) THEN
76166  ikfdc=idc
76167  GOTO 700
76168  ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
76169  GOTO 690
76170  ENDIF
76171  680 CONTINUE
76172  ikfdc=-idc
76173  GOTO 700
76174  ENDIF
76175  690 CONTINUE
76176  ikfdc=nkfdc+1
76177  700 IF(ikfdc.LT.0) THEN
76178  ikfdc=-ikfdc
76179  ELSEIF(nkfdc.GE.200) THEN
76180  nredc=nredc+1
76181  RETURN
76182  ELSE
76183  DO 720 idc=nkfdc,ikfdc,-1
76184  npdc(idc+1)=npdc(idc)
76185  DO 710 i=0,8
76186  kfdc(idc+1,i)=kfdc(idc,i)
76187  710 CONTINUE
76188  720 CONTINUE
76189  nkfdc=nkfdc+1
76190  kfdc(ikfdc,0)=nds
76191  DO 730 i=1,nds
76192  kfdc(ikfdc,i)=kfdm(i)
76193  730 CONTINUE
76194  npdc(ikfdc)=0
76195  ENDIF
76196  npdc(ikfdc)=npdc(ikfdc)+1
76197 
76198 C...Write statistics on decay channels.
76199  ELSEIF(mtabu.EQ.52) THEN
76200  fac=1d0/max(1,nevdc)
76201  WRITE(mstu(11),5900) nevdc
76202  DO 750 idc=1,nkfdc
76203  DO 740 i=1,kfdc(idc,0)
76204  kfm=kfdc(idc,i)
76205  kf=(kfm+1)/2
76206  IF(2*kf.NE.kfm) kf=-kf
76207  CALL pyname(kf,chau)
76208  chdc(i)=chau(1:12)
76209  IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
76210  740 CONTINUE
76211  WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
76212  750 CONTINUE
76213  IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
76214 
76215 C...Copy statistics on decay channels into /PYJETS/.
76216  ELSEIF(mtabu.EQ.53) THEN
76217  fac=1d0/max(1,nevdc)
76218  DO 780 idc=1,nkfdc
76219  k(idc,1)=32
76220  k(idc,2)=99
76221  k(idc,3)=0
76222  k(idc,4)=0
76223  k(idc,5)=kfdc(idc,0)
76224  DO 760 j=1,5
76225  p(idc,j)=0d0
76226  v(idc,j)=0d0
76227  760 CONTINUE
76228  DO 770 i=1,kfdc(idc,0)
76229  kfm=kfdc(idc,i)
76230  kf=(kfm+1)/2
76231  IF(2*kf.NE.kfm) kf=-kf
76232  IF(i.LE.5) p(idc,i)=kf
76233  IF(i.GE.6) v(idc,i-5)=kf
76234  770 CONTINUE
76235  v(idc,5)=fac*npdc(idc)
76236  780 CONTINUE
76237  n=nkfdc
76238  DO 790 j=1,5
76239  k(n+1,j)=0
76240  p(n+1,j)=0d0
76241  v(n+1,j)=0d0
76242  790 CONTINUE
76243  k(n+1,1)=32
76244  k(n+1,2)=99
76245  k(n+1,5)=nevdc
76246  v(n+1,5)=fac*nredc
76247  mstu(3)=1
76248  ENDIF
76249 
76250 C...Format statements for output on unit MSTU(11) (default 6).
76251  5000 FORMAT(///20x,'Event statistics - initial state'/
76252  &20x,'based on an analysis of ',i6,' events'//
76253  &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
76254  &'according to fragmenting system multiplicity'/
76255  &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
76256  &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
76257  5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
76258  5200 FORMAT(///20x,'Event statistics - final state'/
76259  &20x,'based on an analysis of ',i7,' events'//
76260  &5x,'Mean primary multiplicity =',f10.4/
76261  &5x,'Mean final multiplicity =',f10.4/
76262  &5x,'Mean charged multiplicity =',f10.4//
76263  &5x,'Number of particles produced per event (directly and via ',
76264  &'decays/branchings)'/
76265  &8x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
76266  &8x,'Total'/35x,'prim seco prim seco'/)
76267  5300 FORMAT(1x,i9,4x,a16,i2,5(1x,f11.6))
76268  5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
76269  &20x,'based on an analysis of ',i6,' events'//
76270  &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
76271  &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
76272  5500 FORMAT(10x)
76273  5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
76274  5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
76275  &20x,'based on an analysis of ',i6,' events'//
76276  &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
76277  &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
76278  5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
76279  5900 FORMAT(///20x,'Decay channel analysis - final state'/
76280  &20x,'based on an analysis of ',i6,' events'//
76281  &2x,'Probability',10x,'Complete final state'/)
76282  6000 FORMAT(2x,f9.5,5x,8(a12,1x))
76283  6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
76284  &'or table overflow)')
76285 
76286  RETURN
76287  END
76288 
76289 C*********************************************************************
76290 
76291 C...PYEEVT
76292 C...Handles the generation of an e+e- annihilation jet event.
76293 
76294  SUBROUTINE pyeevt(KFL,ECM)
76295 
76296 C...Double precision and integer declarations.
76297  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76298  IMPLICIT INTEGER(I-N)
76299  INTEGER PYK,PYCHGE,PYCOMP
76300 C...Commonblocks.
76301  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
76302  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76303  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76304  SAVE /pyjets/,/pydat1/,/pydat2/
76305 
76306 C...Check input parameters.
76307  IF(mstu(12).NE.12345) CALL pylist(0)
76308  IF(kfl.LT.0.OR.kfl.GT.8) THEN
76309  CALL pyerrm(16,'(PYEEVT:) called with unknown flavour code')
76310  IF(mstu(21).GE.1) RETURN
76311  ENDIF
76312  IF(kfl.LE.5) ecmmin=parj(127)+2.02d0*parf(100+max(1,kfl))
76313  IF(kfl.GE.6) ecmmin=parj(127)+2.02d0*pmas(kfl,1)
76314  IF(ecm.LT.ecmmin) THEN
76315  CALL pyerrm(16,'(PYEEVT:) called with too small CM energy')
76316  IF(mstu(21).GE.1) RETURN
76317  ENDIF
76318 
76319 C...Check consistency of MSTJ options set.
76320  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
76321  CALL pyerrm(6,
76322  & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76323  mstj(110)=1
76324  ENDIF
76325  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
76326  CALL pyerrm(6,
76327  & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76328  mstj(111)=0
76329  ENDIF
76330 
76331 C...Initialize alpha_strong and total cross-section.
76332  mstu(111)=mstj(108)
76333  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
76334  &mstu(111)=1
76335  paru(112)=parj(121)
76336  IF(mstu(111).EQ.2) paru(112)=parj(122)
76337  IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
76338  &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL pyxtee(kfl,ecm,
76339  &xtot)
76340  IF(mstj(116).GE.3) mstj(116)=1
76341  parj(171)=0d0
76342 
76343 C...Add initial e+e- to event record (documentation only).
76344  ntry=0
76345  100 ntry=ntry+1
76346  IF(ntry.GT.100) THEN
76347  CALL pyerrm(14,'(PYEEVT:) caught in an infinite loop')
76348  RETURN
76349  ENDIF
76350  mstu(24)=0
76351  nc=0
76352  IF(mstj(115).GE.2) THEN
76353  nc=nc+2
76354  CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
76355  k(nc-1,1)=21
76356  CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
76357  k(nc,1)=21
76358  ENDIF
76359 
76360 C...Radiative photon (in initial state).
76361  mk=0
76362  ecmc=ecm
76363  IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL pyradk(ecm,mk,pak,
76364  &thek,phik,alpk)
76365  IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2d0*pak))
76366  IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
76367  nc=nc+1
76368  CALL py1ent(nc,22,pak,thek,phik)
76369  k(nc,3)=min(mstj(115)/2,1)
76370  ENDIF
76371 
76372 C...Virtual exchange boson (gamma or Z0).
76373  IF(mstj(115).GE.3) THEN
76374  nc=nc+1
76375  kf=22
76376  IF(mstj(102).EQ.2) kf=23
76377  mstu10=mstu(10)
76378  mstu(10)=1
76379  p(nc,5)=ecmc
76380  CALL py1ent(nc,kf,ecmc,0d0,0d0)
76381  k(nc,1)=21
76382  k(nc,3)=1
76383  mstu(10)=mstu10
76384  ENDIF
76385 
76386 C...Choice of flavour and jet configuration.
76387  CALL pyxkfl(kfl,ecm,ecmc,kflc)
76388  IF(kflc.EQ.0) GOTO 100
76389  CALL pyxjet(ecmc,njet,cut)
76390  kfln=21
76391  IF(njet.EQ.4) CALL pyx4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
76392  &x12,x14)
76393  IF(njet.EQ.3) CALL pyx3jt(njet,cut,kflc,ecmc,x1,x3)
76394  IF(njet.EQ.2) mstj(120)=1
76395 
76396 C...Fill jet configuration and origin.
76397  IF(njet.EQ.2.AND.mstj(101).NE.5) CALL py2ent(nc+1,kflc,-kflc,ecmc)
76398  IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL py2ent(-(nc+1),kflc,-kflc,
76399  &ecmc)
76400  IF(njet.EQ.3) CALL py3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
76401  IF(njet.EQ.4.AND.kfln.EQ.21) CALL py4ent(nc+1,kflc,kfln,kfln,
76402  &-kflc,ecmc,x1,x2,x4,x12,x14)
76403  IF(njet.EQ.4.AND.kfln.NE.21) CALL py4ent(nc+1,kflc,-kfln,kfln,
76404  &-kflc,ecmc,x1,x2,x4,x12,x14)
76405  IF(mstu(24).NE.0) GOTO 100
76406  DO 110 ip=nc+1,n
76407  k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
76408  110 CONTINUE
76409 
76410 C...Angular orientation according to matrix element.
76411  IF(mstj(106).EQ.1) THEN
76412  CALL pyxdif(nc,njet,kflc,ecmc,chi,the,phi)
76413  CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
76414  CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
76415  ENDIF
76416 
76417 C...Rotation and boost from radiative photon.
76418  IF(mk.EQ.1) THEN
76419  dbek=-pak/(ecm-pak)
76420  nmin=nc+1-mstj(115)/3
76421  CALL pyrobo(nmin,n,0d0,-phik,0d0,0d0,0d0)
76422  CALL pyrobo(nmin,n,alpk,0d0,dbek*sin(thek),0d0,dbek*cos(thek))
76423  CALL pyrobo(nmin,n,0d0,phik,0d0,0d0,0d0)
76424  ENDIF
76425 
76426 C...Generate parton shower. Rearrange along strings and check.
76427  IF(mstj(101).EQ.5) THEN
76428  CALL pyshow(n-1,n,ecmc)
76429  mstj14=mstj(14)
76430  IF(mstj(105).EQ.-1) mstj(14)=-1
76431  IF(mstj(105).GE.0) mstu(28)=0
76432  CALL pyprep(0)
76433  mstj(14)=mstj14
76434  IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
76435  ENDIF
76436 
76437 C...Fragmentation/decay generation. Information for PYTABU.
76438  IF(mstj(105).EQ.1) CALL pyexec
76439  mstu(161)=kflc
76440  mstu(162)=-kflc
76441 
76442  RETURN
76443  END
76444 
76445 C*********************************************************************
76446 
76447 C...PYXTEE
76448 C...Calculates total cross-section, including initial state
76449 C...radiation effects.
76450 
76451  SUBROUTINE pyxtee(KFL,ECM,XTOT)
76452 
76453 C...Double precision and integer declarations.
76454  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76455  IMPLICIT INTEGER(I-N)
76456  INTEGER PYK,PYCHGE,PYCOMP
76457 C...Commonblocks.
76458  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76459  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76460  SAVE /pydat1/,/pydat2/
76461 
76462 C...Status, (optimized) Q^2 scale, alpha_strong.
76463  parj(151)=ecm
76464  mstj(119)=10*mstj(102)+kfl
76465  IF(mstj(111).EQ.0) THEN
76466  q2r=ecm**2
76467  ELSEIF(mstu(111).EQ.0) THEN
76468  parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
76469  & ((33d0-2d0*mstu(112))*paru(111)))))
76470  q2r=parj(168)*ecm**2
76471  ELSE
76472  parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
76473  & (2d0*paru(112)/ecm)**2))
76474  q2r=parj(168)*ecm**2
76475  ENDIF
76476  alspi=pyalps(q2r)/paru(1)
76477 
76478 C...QCD corrections factor in R.
76479  IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
76480  rqcd=1d0
76481  ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
76482  rqcd=1d0+alspi
76483  ELSEIF(mstj(109).EQ.0) THEN
76484  rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
76485  IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+(33d0-2d0*mstu(112))/12d0*
76486  & log(parj(168))*alspi**2)
76487  ELSEIF(iabs(mstj(101)).EQ.1) THEN
76488  rqcd=1d0+(3d0/4d0)*alspi
76489  ELSE
76490  rqcd=1d0+(3d0/4d0)*alspi-(3d0/32d0+0.519d0*mstu(118))*alspi**2
76491  ENDIF
76492 
76493 C...Calculate Z0 width if default value not acceptable.
76494  IF(mstj(102).GE.3) THEN
76495  rva=3d0*(3d0+(4d0*paru(102)-1d0)**2)+6d0*rqcd*(2d0+
76496  & (1d0-8d0*paru(102)/3d0)**2+(4d0*paru(102)/3d0-1d0)**2)
76497  DO 100 kflc=5,6
76498  vq=1d0
76499  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-
76500  & (2d0*pymass(kflc)/ ecm)**2))
76501  IF(kflc.EQ.5) vf=4d0*paru(102)/3d0-1d0
76502  IF(kflc.EQ.6) vf=1d0-8d0*paru(102)/3d0
76503  rva=rva+3d0*rqcd*(0.5d0*vq*(3d0-vq**2)*vf**2+vq**3)
76504  100 CONTINUE
76505  parj(124)=paru(101)*parj(123)*rva/(48d0*paru(102)*
76506  & (1d0-paru(102)))
76507  ENDIF
76508 
76509 C...Calculate propagator and related constants for QFD case.
76510  poll=1d0-parj(131)*parj(132)
76511  IF(mstj(102).GE.2) THEN
76512  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
76513  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
76514  sfi=sfw*(1d0-(parj(123)/ecm)**2)
76515  ve=4d0*paru(102)-1d0
76516  sf1i=sff*(ve*poll+parj(132)-parj(131))
76517  sf1w=sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
76518  hf1i=sfi*sf1i
76519  hf1w=sfw*sf1w
76520  ENDIF
76521 
76522 C...Loop over different flavours: charge, velocity.
76523  rtot=0d0
76524  rqq=0d0
76525  rqv=0d0
76526  rva=0d0
76527  DO 110 kflc=1,max(mstj(104),kfl)
76528  IF(kfl.GT.0.AND.kflc.NE.kfl) GOTO 110
76529  mstj(93)=1
76530  pmq=pymass(kflc)
76531  IF(ecm.LT.2d0*pmq+parj(127)) GOTO 110
76532  qf=kchg(kflc,1)/3d0
76533  vq=1d0
76534  IF(mod(mstj(103),2).EQ.1) vq=sqrt(1d0-(2d0*pmq/ecm)**2)
76535 
76536 C...Calculate R and sum of charges for QED or QFD case.
76537  rqq=rqq+3d0*qf**2*poll
76538  IF(mstj(102).LE.1) THEN
76539  rtot=rtot+3d0*0.5d0*vq*(3d0-vq**2)*qf**2*poll
76540  ELSE
76541  vf=sign(1d0,qf)-4d0*qf*paru(102)
76542  rqv=rqv-6d0*qf*vf*sf1i
76543  rva=rva+3d0*(vf**2+1d0)*sf1w
76544  rtot=rtot+3d0*(0.5d0*vq*(3d0-vq**2)*(qf**2*poll-
76545  & 2d0*qf*vf*hf1i+vf**2*hf1w)+vq**3*hf1w)
76546  ENDIF
76547  110 CONTINUE
76548  rsum=rqq
76549  IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
76550 
76551 C...Calculate cross-section, including QCD corrections.
76552  parj(141)=rqq
76553  parj(142)=rtot
76554  parj(143)=rtot*rqcd
76555  parj(144)=parj(143)
76556  parj(145)=parj(141)*86.8d0/ecm**2
76557  parj(146)=parj(142)*86.8d0/ecm**2
76558  parj(147)=parj(143)*86.8d0/ecm**2
76559  parj(148)=parj(147)
76560  parj(157)=rsum*rqcd
76561  parj(158)=0d0
76562  parj(159)=0d0
76563  xtot=parj(147)
76564  IF(mstj(107).LE.0) RETURN
76565 
76566 C...Virtual cross-section.
76567  xkl=parj(135)
76568  xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
76569  ale=2d0*log(ecm/pymass(11))-1d0
76570  sigv=ale/3d0+2d0*log(ecm**2/(pymass(13)*pymass(15)))/3d0-4d0/3d0+
76571  &1.526d0*log(ecm**2/0.932d0)
76572 
76573 C...Soft and hard radiative cross-section in QED case.
76574  IF(mstj(102).LE.1) THEN
76575  sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+2d0*sigv
76576  sigs=ale*(2d0*log(xkl)-log(1d0-xkl)-xkl)
76577  sigh=ale*(2d0*log(xku/xkl)-log((1d0-xku)/(1d0-xkl))-(xku-xkl))
76578 
76579 C...Soft and hard radiative cross-section in QFD case.
76580  ELSE
76581  szm=1d0-(parj(123)/ecm)**2
76582  szw=parj(123)*parj(124)/ecm**2
76583  parj(161)=-rqq/rsum
76584  parj(162)=-(rqq+rqv+rva)/rsum
76585  parj(163)=(rqv*(1d0-0.5d0*szm-sfi)+rva*(1.5d0-szm-sfw))/rsum
76586  parj(164)=(rqv*szw**2*(1d0-2d0*sfw)+rva*(2d0*sfi+szw**2-
76587  & 4d0+3d0*szm-szm**2))/(szw*rsum)
76588  sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+((2d0*rqq+sfi*rqv)/
76589  & rsum)*sigv+(szw*sfw*rqv/rsum)*paru(1)*20d0/9d0
76590  sigs=ale*(2d0*log(xkl)+parj(161)*log(1d0-xkl)+parj(162)*xkl+
76591  & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
76592  & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
76593  sigh=ale*(2d0*log(xku/xkl)+parj(161)*log((1d0-xku)/
76594  & (1d0-xkl))+parj(162)*(xku-xkl)+parj(163)*
76595  & log(((xku-szm)**2+szw**2)/((xkl-szm)**2+szw**2))+
76596  & parj(164)*(atan((xku-szm)/szw)-atan((xkl-szm)/szw)))
76597  ENDIF
76598 
76599 C...Total cross-section and fraction of hard photon events.
76600  parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
76601  parj(157)=rsum*(1d0+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
76602  parj(144)=parj(157)
76603  parj(148)=parj(144)*86.8d0/ecm**2
76604  xtot=parj(148)
76605 
76606  RETURN
76607  END
76608 
76609 C*********************************************************************
76610 
76611 C...PYRADK
76612 C...Generates initial state photon radiation.
76613 
76614  SUBROUTINE pyradk(ECM,MK,PAK,THEK,PHIK,ALPK)
76615 
76616 C...Double precision and integer declarations.
76617  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76618  IMPLICIT INTEGER(I-N)
76619  INTEGER PYK,PYCHGE,PYCOMP
76620 C...Commonblocks.
76621  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76622  SAVE /pydat1/
76623 
76624 C...Function: cumulative hard photon spectrum in QFD case.
76625  fxk(xx)=2d0*log(xx)+parj(161)*log(1d0-xx)+parj(162)*xx+
76626  &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
76627 
76628 C...Determine whether radiative photon or not.
76629  mk=0
76630  pak=0d0
76631  IF(parj(160).LT.pyr(0)) RETURN
76632  mk=1
76633 
76634 C...Photon energy range. Find photon momentum in QED case.
76635  xkl=parj(135)
76636  xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
76637  IF(mstj(102).LE.1) THEN
76638  100 xk=1d0/(1d0+(1d0/xkl-1d0)*((1d0/xku-1d0)/(1d0/xkl-1d0))**pyr(0))
76639  IF(1d0+(1d0-xk)**2.LT.2d0*pyr(0)) GOTO 100
76640 
76641 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76642  ELSE
76643  szm=1d0-(parj(123)/ecm)**2
76644  szw=parj(123)*parj(124)/ecm**2
76645  fxkl=fxk(xkl)
76646  fxku=fxk(xku)
76647  fxkd=1d-4*(fxku-fxkl)
76648  fxkr=fxkl+pyr(0)*(fxku-fxkl)
76649  nxk=0
76650  110 nxk=nxk+1
76651  xk=0.5d0*(xkl+xku)
76652  fxkv=fxk(xk)
76653  IF(fxkv.GT.fxkr) THEN
76654  xku=xk
76655  fxku=fxkv
76656  ELSE
76657  xkl=xk
76658  fxkl=fxkv
76659  ENDIF
76660  IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) GOTO 110
76661  xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
76662  ENDIF
76663  pak=0.5d0*ecm*xk
76664 
76665 C...Photon polar and azimuthal angle.
76666  pme=2d0*(pymass(11)/ecm)**2
76667  120 cthm=pme*(2d0/pme)**pyr(0)
76668  IF(1d0-(xk**2*cthm*(1d0-0.5d0*cthm)+2d0*(1d0-xk)*pme/max(pme,
76669  &cthm*(1d0-0.5d0*cthm)))/(1d0+(1d0-xk)**2).LT.pyr(0)) GOTO 120
76670  cthe=1d0-cthm
76671  IF(pyr(0).GT.0.5d0) cthe=-cthe
76672  sthe=sqrt(max(0d0,(cthm-pme)*(2d0-cthm)))
76673  thek=pyangl(cthe,sthe)
76674  phik=paru(2)*pyr(0)
76675 
76676 C...Rotation angle for hadronic system.
76677  sgn=1d0
76678  IF(0.5d0*(2d0-xk*(1d0-cthe))**2/((2d0-xk)**2+(xk*cthe)**2).GT.
76679  &pyr(0)) sgn=-1d0
76680  alpk=asin(sgn*sthe*(xk-sgn*(2d0*sqrt(1d0-xk)-2d0+xk)*cthe)/
76681  &(2d0-xk*(1d0-sgn*cthe)))
76682 
76683  RETURN
76684  END
76685 
76686 C*********************************************************************
76687 
76688 C...PYXKFL
76689 C...Selects flavour for produced qqbar pair.
76690 
76691  SUBROUTINE pyxkfl(KFL,ECM,ECMC,KFLC)
76692 
76693 C...Double precision and integer declarations.
76694  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76695  IMPLICIT INTEGER(I-N)
76696  INTEGER PYK,PYCHGE,PYCOMP
76697 C...Commonblocks.
76698  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76699  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76700  SAVE /pydat1/,/pydat2/
76701 
76702 C...Calculate maximum weight in QED or QFD case.
76703  IF(mstj(102).LE.1) THEN
76704  rfmax=4d0/9d0
76705  ELSE
76706  poll=1d0-parj(131)*parj(132)
76707  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
76708  sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
76709  sfi=sfw*(1d0-(parj(123)/ecmc)**2)
76710  ve=4d0*paru(102)-1d0
76711  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
76712  hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
76713  rfmax=max(4d0/9d0*poll-4d0/3d0*(1d0-8d0*paru(102)/3d0)*hf1i+
76714  & ((1d0-8d0*paru(102)/3d0)**2+1d0)*hf1w,1d0/9d0*poll+2d0/3d0*
76715  & (-1d0+4d0*paru(102)/3d0)*hf1i+((-1d0+4d0*paru(102)/3d0)**2+
76716  & 1d0)*hf1w)
76717  ENDIF
76718 
76719 C...Choose flavour. Gives charge and velocity.
76720  ntry=0
76721  100 ntry=ntry+1
76722  IF(ntry.GT.100) THEN
76723  CALL pyerrm(14,'(PYXKFL:) caught in an infinite loop')
76724  kflc=0
76725  RETURN
76726  ENDIF
76727  kflc=kfl
76728  IF(kfl.LE.0) kflc=1+int(mstj(104)*pyr(0))
76729  mstj(93)=1
76730  pmq=pymass(kflc)
76731  IF(ecm.LT.2d0*pmq+parj(127)) GOTO 100
76732  qf=kchg(kflc,1)/3d0
76733  vq=1d0
76734  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-(2d0*pmq/ecmc)**2))
76735 
76736 C...Calculate weight in QED or QFD case.
76737  IF(mstj(102).LE.1) THEN
76738  rf=qf**2
76739  rfv=0.5d0*vq*(3d0-vq**2)*qf**2
76740  ELSE
76741  vf=sign(1d0,qf)-4d0*qf*paru(102)
76742  rf=qf**2*poll-2d0*qf*vf*hf1i+(vf**2+1d0)*hf1w
76743  rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+vf**2*hf1w)+
76744  & vq**3*hf1w
76745  IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
76746  ENDIF
76747 
76748 C...Weighting or new event (radiative photon). Cross-section update.
76749  IF(kfl.LE.0.AND.rf.LT.pyr(0)*rfmax) GOTO 100
76750  parj(158)=parj(158)+1d0
76751  IF(ecmc.LT.2d0*pmq+parj(127).OR.rfv.LT.pyr(0)*rf) kflc=0
76752  IF(mstj(107).LE.0.AND.kflc.EQ.0) GOTO 100
76753  IF(kflc.NE.0) parj(159)=parj(159)+1d0
76754  parj(144)=parj(157)*parj(159)/parj(158)
76755  parj(148)=parj(144)*86.8d0/ecm**2
76756 
76757  RETURN
76758  END
76759 
76760 C*********************************************************************
76761 
76762 C...PYXJET
76763 C...Selects number of jets in matrix element approach.
76764 
76765  SUBROUTINE pyxjet(ECM,NJET,CUT)
76766 
76767 C...Double precision and integer declarations.
76768  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76769  IMPLICIT INTEGER(I-N)
76770  INTEGER PYK,PYCHGE,PYCOMP
76771 C...Commonblocks.
76772  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76773  SAVE /pydat1/
76774 C...Local array and data.
76775  dimension zhut(5)
76776  DATA zhut/3.0922d0, 6.2291d0, 7.4782d0, 7.8440d0, 8.2560d0/
76777 
76778 C...Trivial result for two-jets only, including parton shower.
76779  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
76780  cut=0d0
76781 
76782 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76783  ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
76784  cf=4d0/3d0
76785  IF(mstj(109).EQ.2) cf=1d0
76786  IF(mstj(111).EQ.0) THEN
76787  q2=ecm**2
76788  q2r=ecm**2
76789  ELSEIF(mstu(111).EQ.0) THEN
76790  parj(169)=min(1d0,parj(129))
76791  q2=parj(169)*ecm**2
76792  parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
76793  & ((33d0-2d0*mstu(112))*paru(111)))))
76794  q2r=parj(168)*ecm**2
76795  ELSE
76796  parj(169)=min(1d0,max(parj(129),(2d0*paru(112)/ecm)**2))
76797  q2=parj(169)*ecm**2
76798  parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
76799  & (2d0*paru(112)/ecm)**2))
76800  q2r=parj(168)*ecm**2
76801  ENDIF
76802 
76803 C...alpha_strong for R and R itself.
76804  alspi=(3d0/4d0)*cf*pyalps(q2r)/paru(1)
76805  IF(iabs(mstj(101)).EQ.1) THEN
76806  rqcd=1d0+alspi
76807  ELSEIF(mstj(109).EQ.0) THEN
76808  rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
76809  IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+
76810  & (33d0-2d0*mstu(112))/12d0*log(parj(168))*alspi**2)
76811  ELSE
76812  rqcd=1d0+alspi-(3d0/32d0+0.519d0*mstu(118))*(4d0*alspi/3d0)**2
76813  ENDIF
76814 
76815 C...alpha_strong for jet rate. Initial value for y cut.
76816  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
76817  cut=max(0.001d0,parj(125),(parj(126)/ecm)**2)
76818  IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
76819  & cut=max(cut,exp(-sqrt(0.75d0/alspi))/2d0)
76820  IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
76821 
76822 C...Parametrization of first order three-jet cross-section.
76823  100 IF(mstj(101).EQ.0.OR.cut.GE.0.25d0) THEN
76824  parj(152)=0d0
76825  ELSE
76826  parj(152)=(2d0*alspi/3d0)*((3d0-6d0*cut+2d0*log(cut))*
76827  & log(cut/(1d0-2d0*cut))+(2.5d0+1.5d0*cut-6.571d0)*
76828  & (1d0-3d0*cut)+5.833d0*(1d0-3d0*cut)**2-3.894d0*
76829  & (1d0-3d0*cut)**3+1.342d0*(1d0-3d0*cut)**4)/rqcd
76830  IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
76831  & parj(152)=0d0
76832  ENDIF
76833 
76834 C...Parametrization of second order three-jet cross-section.
76835  IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
76836  & cut.GE.0.25d0) THEN
76837  parj(153)=0d0
76838  ELSEIF(mstj(110).LE.1) THEN
76839  ct=log(1d0/cut-2d0)
76840  parj(153)=alspi**2*ct**2*(2.419d0+0.5989d0*ct+0.6782d0*ct**2-
76841  & 0.2661d0*ct**3+0.01159d0*ct**4)/rqcd
76842 
76843 C...Interpolation in second/first order ratio for Zhu parametrization.
76844  ELSEIF(mstj(110).EQ.2) THEN
76845  iza=0
76846  DO 110 iy=1,5
76847  IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
76848  110 CONTINUE
76849  IF(iza.NE.0) THEN
76850  zhurat=zhut(iza)
76851  ELSE
76852  iz=100d0*cut
76853  zhurat=zhut(iz)+(100d0*cut-iz)*(zhut(iz+1)-zhut(iz))
76854  ENDIF
76855  parj(153)=alspi*parj(152)*zhurat
76856  ENDIF
76857 
76858 C...Shift in second order three-jet cross-section with optimized Q^2.
76859  IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3
76860  & .AND.cut.LT.0.25d0) parj(153)=parj(153)+
76861  & (33d0-2d0*mstu(112))/12d0*log(parj(169))*alspi*parj(152)
76862 
76863 C...Parametrization of second order four-jet cross-section.
76864  IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125d0) THEN
76865  parj(154)=0d0
76866  ELSE
76867  ct=log(1d0/cut-5d0)
76868  IF(cut.LE.0.018d0) THEN
76869  xqqgg=6.349d0-4.330d0*ct+0.8304d0*ct**2
76870  IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(3.035d0-2.091d0*ct+
76871  & 0.4059d0*ct**2)
76872  xqqqq=1.25d0*(-0.1080d0+0.01486d0*ct+0.009364d0*ct**2)
76873  IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
76874  ELSE
76875  xqqgg=-0.09773d0+0.2959d0*ct-0.2764d0*ct**2+0.08832d0*ct**3
76876  IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(-0.04079d0+
76877  & 0.1340d0*ct-0.1326d0*ct**2+0.04365d0*ct**3)
76878  xqqqq=1.25d0*(0.003661d0-0.004888d0*ct-0.001081d0*ct**2+
76879  & 0.002093d0*ct**3)
76880  IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
76881  ENDIF
76882  parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
76883  parj(155)=xqqqq/(xqqgg+xqqqq)
76884  ENDIF
76885 
76886 C...If negative three-jet rate, change y' optimization parameter.
76887  IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0d0.AND.
76888  & parj(169).LT.0.99d0) THEN
76889  parj(169)=min(1d0,1.2d0*parj(169))
76890  q2=parj(169)*ecm**2
76891  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
76892  GOTO 100
76893  ENDIF
76894 
76895 C...If too high cross-section, use harder cuts, or fail.
76896  IF(parj(152)+parj(153)+parj(154).GE.1) THEN
76897  IF(mstj(110).EQ.2.AND.cut.GT.0.0499d0.AND.mstj(111).EQ.1.AND.
76898  & parj(169).LT.0.99d0) THEN
76899  parj(169)=min(1d0,1.2d0*parj(169))
76900  q2=parj(169)*ecm**2
76901  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
76902  GOTO 100
76903  ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499d0) THEN
76904  CALL pyerrm(26,
76905  & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76906  ENDIF
76907  cut=0.26d0*(4d0*cut)**(parj(152)+parj(153)+
76908  & parj(154))**(-1d0/3d0)
76909  IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
76910  GOTO 100
76911  ENDIF
76912 
76913 C...Scalar gluon (first order only).
76914  ELSE
76915  alspi=pyalps(ecm**2)/paru(1)
76916  cut=max(0.001d0,parj(125),(parj(126)/ecm)**2,exp(-3d0/alspi))
76917  parj(152)=0d0
76918  IF(cut.LT.0.25d0) parj(152)=(alspi/3d0)*((1d0-2d0*cut)*
76919  & log((1d0-2d0*cut)/cut)+0.5d0*(9d0*cut**2-1d0))
76920  parj(153)=0d0
76921  parj(154)=0d0
76922  ENDIF
76923 
76924 C...Select number of jets.
76925  parj(150)=cut
76926  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
76927  njet=2
76928  ELSEIF(mstj(101).LE.0) THEN
76929  njet=min(4,2-mstj(101))
76930  ELSE
76931  rnj=pyr(0)
76932  njet=2
76933  IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
76934  IF(parj(154).GT.rnj) njet=4
76935  ENDIF
76936 
76937  RETURN
76938  END
76939 
76940 C*********************************************************************
76941 
76942 C...PYX3JT
76943 C...Selects the kinematical variables of three-jet events.
76944 
76945  SUBROUTINE pyx3jt(NJET,CUT,KFL,ECM,X1,X2)
76946 
76947 C...Double precision and integer declarations.
76948  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76949  IMPLICIT INTEGER(I-N)
76950  INTEGER PYK,PYCHGE,PYCOMP
76951 C...Commonblocks.
76952  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76953  SAVE /pydat1/
76954 C...Local array.
76955  dimension zhup(5,12)
76956 
76957 C...Coefficients of Zhu second order parametrization.
76958  DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
76959  &18.29d0, 89.56d0, 4.541d0, -52.09d0, -109.8d0, 24.90d0,
76960  &11.63d0, 3.683d0, 17.50d0,0.002440d0, -1.362d0,-0.3537d0,
76961  &11.42d0, 6.299d0, -22.55d0, -8.915d0, 59.25d0, -5.855d0,
76962  &-32.85d0, -1.054d0, -16.90d0,0.006489d0,-0.8156d0,0.01095d0,
76963  &7.847d0, -3.964d0, -35.83d0, 1.178d0, 29.39d0, 0.2806d0,
76964  &47.82d0, -12.36d0, -56.72d0, 0.04054d0,-0.4365d0, 0.6062d0,
76965  &5.441d0, -56.89d0, -50.27d0, 15.13d0, 114.3d0, -18.19d0,
76966  &97.05d0, -1.890d0, -139.9d0, 0.08153d0,-0.4984d0, 0.9439d0,
76967  &-17.65d0, 51.44d0, -58.32d0, 70.95d0, -255.7d0, -78.99d0,
76968  &476.9d0, 29.65d0, -239.3d0, 0.4745d0, -1.174d0, 6.081d0/
76969 
76970 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76971  dilog(x)=x+x**2/4d0+x**3/9d0+x**4/16d0+x**5/25d0+x**6/36d0+
76972  &x**7/49d0
76973 
76974 C...Event type. Mass effect factors and other common constants.
76975  mstj(120)=2
76976  mstj(121)=0
76977  pmq=pymass(kfl)
76978  qme=(2d0*pmq/ecm)**2
76979  IF(mstj(109).NE.1) THEN
76980  cutl=log(cut)
76981  cutd=log(1d0/cut-2d0)
76982  IF(mstj(109).EQ.0) THEN
76983  cf=4d0/3d0
76984  cn=3d0
76985  tr=2d0
76986  wtmx=min(20d0,37d0-6d0*cutd)
76987  IF(mstj(110).EQ.2) wtmx=2d0*(7.5d0+80d0*cut)
76988  ELSE
76989  cf=1d0
76990  cn=0d0
76991  tr=12d0
76992  wtmx=0d0
76993  ENDIF
76994 
76995 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
76996  als2pi=paru(118)/paru(2)
76997  wtopt=0d0
76998  IF(mstj(111).EQ.1) wtopt=(33d0-2d0*mstu(112))/6d0*
76999  & log(parj(169))*als2pi
77000  wtmax=max(0d0,1d0+wtopt+als2pi*wtmx)
77001 
77002 C...Choose three-jet events in allowed region.
77003  100 njet=3
77004  110 y13l=cutl+cutd*pyr(0)
77005  y23l=cutl+cutd*pyr(0)
77006  y13=exp(y13l)
77007  y23=exp(y23l)
77008  y12=1d0-y13-y23
77009  IF(y12.LE.cut) GOTO 110
77010  IF(y13**2+y23**2+2d0*y12.LE.2d0*pyr(0)) GOTO 110
77011 
77012 C...Second order corrections.
77013  IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
77014  y12l=log(y12)
77015  y13m=log(1d0-y13)
77016  y23m=log(1d0-y23)
77017  y12m=log(1d0-y12)
77018  IF(y13.LE.0.5d0) y13i=dilog(y13)
77019  IF(y13.GE.0.5d0) y13i=1.644934d0-y13l*y13m-dilog(1d0-y13)
77020  IF(y23.LE.0.5d0) y23i=dilog(y23)
77021  IF(y23.GE.0.5d0) y23i=1.644934d0-y23l*y23m-dilog(1d0-y23)
77022  IF(y12.LE.0.5d0) y12i=dilog(y12)
77023  IF(y12.GE.0.5d0) y12i=1.644934d0-y12l*y12m-dilog(1d0-y12)
77024  wt1=(y13**2+y23**2+2d0*y12)/(y13*y23)
77025  wt2=cf*(-2d0*(cutl-y12l)**2-3d0*cutl-1d0+3.289868d0+
77026  & 2d0*(2d0*cutl-y12l)*cut/y12)+
77027  & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-
77028  & 11d0*cutl/6d0+67d0/18d0+1.644934d0-(2d0*cutl-y12l)*cut/y12+
77029  & (2d0*cutl-y13l)*cut/y13+(2d0*cutl-y23l)*cut/y23)+
77030  & tr*(2d0*cutl/3d0-10d0/9d0)+
77031  & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
77032  & y13l*(4d0*y12**2+2d0*y12*y13+4d0*y12*y23+y13*y23)/
77033  & (y12+y23)**2+y23l*(4d0*y12**2+2d0*y12*y23+4d0*y12*y13+
77034  & y13*y23)/(y12+y13)**2)/wt1+
77035  & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+(cn-2d0*cf)*
77036  & ((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
77037  & y23m+1.644934d0-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
77038  & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934d0-y12i-y13i)/
77039  & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
77040  & 2d0*y12l*y12**2/(y13+y23)**2-4d0*y12l*y12/(y13+y23))/wt1-
77041  & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934d0-y13i-y23i)
77042  IF(1d0+wtopt+als2pi*wt2.LE.0d0) mstj(121)=1
77043  IF(1d0+wtopt+als2pi*wt2.LE.wtmax*pyr(0)) GOTO 110
77044  parj(156)=(wtopt+als2pi*wt2)/(1d0+wtopt+als2pi*wt2)
77045 
77046  ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
77047 C...Second order corrections; Zhu parametrization of ERT.
77048  zx=(y23-y13)**2
77049  zy=1d0-y12
77050  iza=0
77051  DO 120 iy=1,5
77052  IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
77053  120 CONTINUE
77054  IF(iza.NE.0) THEN
77055  iz=iza
77056  wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
77057  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
77058  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
77059  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
77060  ELSE
77061  iz=100d0*cut
77062  wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
77063  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
77064  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
77065  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
77066  iz=iz+1
77067  wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
77068  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
77069  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
77070  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
77071  wt2=wtl+(wtu-wtl)*(100d0*cut+1d0-iz)
77072  ENDIF
77073  IF(1d0+wtopt+2d0*als2pi*wt2.LE.0d0) mstj(121)=1
77074  IF(1d0+wtopt+2d0*als2pi*wt2.LE.wtmax*pyr(0)) GOTO 110
77075  parj(156)=(wtopt+2d0*als2pi*wt2)/(1d0+wtopt+2d0*als2pi*wt2)
77076  ENDIF
77077 
77078 C...Impose mass cuts (gives two jets). For fixed jet number new try.
77079  x1=1d0-y23
77080  x2=1d0-y13
77081  x3=1d0-y12
77082  IF(4d0*y23*y13*y12/x3**2.LE.qme) njet=2
77083  IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
77084  & 0.5d0*qme**2+(0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/(1d0-x1)+
77085  & (1d0-x1)/(1d0-x2)).GT.(x1**2+x2**2)*pyr(0)) njet=2
77086  IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 100
77087 
77088 C...Scalar gluon model (first order only, no mass effects).
77089  ELSE
77090  130 njet=3
77091  140 x3=sqrt(4d0*cut**2+pyr(0)*((1d0-cut)**2-4d0*cut**2))
77092  IF(log((x3-cut)/cut).LE.pyr(0)*log((1d0-2d0*cut)/cut)) GOTO 140
77093  yd=sign(2d0*cut*((x3-cut)/cut)**pyr(0)-x3,pyr(0)-0.5d0)
77094  x1=1d0-0.5d0*(x3+yd)
77095  x2=1d0-0.5d0*(x3-yd)
77096  IF(4d0*(1d0-x1)*(1d0-x2)*(1d0-x3)/x3**2.LE.qme) njet=2
77097  IF(mstj(102).GE.2) THEN
77098  IF(x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*parj(171).LT.
77099  & x3**2*pyr(0)) njet=2
77100  ENDIF
77101  IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 130
77102  ENDIF
77103 
77104  RETURN
77105  END
77106 
77107 C*********************************************************************
77108 
77109 C...PYX4JT
77110 C...Selects the kinematical variables of four-jet events.
77111 
77112  SUBROUTINE pyx4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77113 
77114 C...Double precision and integer declarations.
77115  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77116  IMPLICIT INTEGER(I-N)
77117  INTEGER PYK,PYCHGE,PYCOMP
77118 C...Commonblocks.
77119  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77120  SAVE /pydat1/
77121 C...Local arrays.
77122  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
77123 
77124 C...Common constants. Colour factors for QCD and Abelian gluon theory.
77125  pmq=pymass(kfl)
77126  qme=(2d0*pmq/ecm)**2
77127  ct=log(1d0/cut-5d0)
77128  IF(mstj(109).EQ.0) THEN
77129  cf=4d0/3d0
77130  cn=3d0
77131  tr=2.5d0
77132  ELSE
77133  cf=1d0
77134  cn=0d0
77135  tr=15d0
77136  ENDIF
77137 
77138 C...Choice of process (qqbargg or qqbarqqbar).
77139  100 njet=4
77140  it=1
77141  IF(parj(155).GT.pyr(0)) it=2
77142  IF(mstj(101).LE.-3) it=-mstj(101)-2
77143  IF(it.EQ.1) wtmx=0.7d0/cut**2
77144  IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6d0/cut**2
77145  IF(it.EQ.2) wtmx=0.1125d0*cf*tr/cut**2
77146  id=1
77147 
77148 C...Sample the five kinematical variables (for qqgg preweighted in y34).
77149  110 y134=3d0*cut+(1d0-6d0*cut)*pyr(0)
77150  y234=3d0*cut+(1d0-6d0*cut)*pyr(0)
77151  IF(it.EQ.1) y34=(1d0-5d0*cut)*exp(-ct*pyr(0))
77152  IF(it.EQ.2) y34=cut+(1d0-6d0*cut)*pyr(0)
77153  IF(y34.LE.y134+y234-1d0.OR.y34.GE.y134*y234) GOTO 110
77154  vt=pyr(0)
77155  cp=cos(paru(1)*pyr(0))
77156  y14=(y134-y34)*vt
77157  y13=y134-y14-y34
77158  vb=y34*(1d0-y134-y234+y34)/((y134-y34)*(y234-y34))
77159  y24=0.5d0*(y234-y34)*(1d0-4d0*sqrt(max(0d0,vt*(1d0-vt)*
77160  &vb*(1d0-vb)))*cp-(1d0-2d0*vt)*(1d0-2d0*vb))
77161  y23=y234-y34-y24
77162  y12=1d0-y134-y23-y24
77163  IF(min(y12,y13,y14,y23,y24).LE.cut) GOTO 110
77164  y123=y12+y13+y23
77165  y124=y12+y14+y24
77166 
77167 C...Calculate matrix elements for qqgg or qqqq process.
77168  ic=0
77169  wttot=0d0
77170  120 ic=ic+1
77171  IF(it.EQ.1) THEN
77172  wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3d0*y12*y23*y34+
77173  & 3d0*y12*y14*y34+4d0*y12**2*y34-y13*y23*y24+2d0*y12*y23*y24-
77174  & y13*y14*y24-2d0*y12*y13*y24+2d0*y12**2*y24+y14*y23**2+2d0*y12*
77175  & y23**2+y14**2*y23+4d0*y12*y14*y23+4d0*y12**2*y23+2d0*y12*y14**2+
77176  & 2d0*y12*y13*y14+4d0*y12**2*y14+2d0*y12**2*y13+2d0*y12**3)/
77177  & (2d0*y13*y134*y234*y24)+(y24*y34+y12*y34+y13*y24-
77178  & y14*y23+y12*y13)/(y13*y134**2)+2d0*y23*(1d0-y13)/
77179  & (y13*y134*y24)+y34/(2d0*y13*y24)
77180  wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2d0*y12*
77181  & y14*y24)/(y13*y134*y23*y14)+y12*(1d0+y34)*y124/(y134*y234*y14*
77182  & y24)-(2d0*y13*y24+y14**2+y13*y23+2d0*y12*y13)/(y13*y134*y14)+
77183  & y12*y123*y124/(2d0*y13*y14*y23*y24)
77184  wtc(ic)=-(5d0*y12*y34**2+2d0*y12*y24*y34+2d0*y12*y23*y34+
77185  & 2d0*y12*y14*y34+2d0*y12*y13*y34+4d0*y12**2*y34-y13*y24**2+
77186  & y14*y23*y24+y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-
77187  & 3d0*y12*y13*y24-y14*y23**2-y14**2*y23+y13*y14*y23-
77188  & 3d0*y12*y14*y23-y12*y13*y23)/(4d0*y134*y234*y34**2)+
77189  & (3d0*y12*y34**2-3d0*y13*y24*y34+3d0*y12*y24*y34+
77190  & 3d0*y14*y23*y34-y13*y24**2-y12*y23*y34+6d0*y12*y14*y34+
77191  & 2d0*y12*y13*y34-2d0*y12**2*y34+y14*y23*y24-3d0*y13*y23*y24-
77192  & 2d0*y13*y14*y24+4d0*y12*y14*y24+2d0*y12*y13*y24+
77193  & 3d0*y14*y23**2+2d0*y14**2*y23+2d0*y14**2*y12+
77194  & 2d0*y12**2*y14+6d0*y12*y14*y23-2d0*y12*y13**2-
77195  & 2d0*y12**2*y13)/(4d0*y13*y134*y234*y34)
77196  wtc(ic)=wtc(ic)+(2d0*y12*y34**2-2d0*y13*y24*y34+y12*y24*y34+
77197  & 4d0*y13*y23*y34+4d0*y12*y14*y34+2d0*y12*y13*y34+2d0*y12**2*y34-
77198  & y13*y24**2+3d0*y14*y23*y24+4d0*y13*y23*y24-2d0*y13*y14*y24+
77199  & 4d0*y12*y14*y24+2d0*y12*y13*y24+2d0*y14*y23**2+4d0*y13*y23**2+
77200  & 2d0*y13*y14*y23+2d0*y12*y14*y23+4d0*y12*y13*y23+2d0*y12*y14**2+
77201  & 4d0*y12**2*y13+4d0*y12*y13*y14+2d0*y12**2*y14)/
77202  & (4d0*y13*y134*y24*y34)-(y12*y34**2-2d0*y14*y24*y34-
77203  & 2d0*y13*y24*y34-y14*y23*y34+y13*y23*y34+y12*y14*y34+
77204  & 2d0*y12*y13*y34-2d0*y14**2*y24-4d0*y13*y14*y24-
77205  & 4d0*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-
77206  & y12*y13**2)/(2d0*y13*y34*y134**2)+(y12*y34**2-
77207  & 4d0*y14*y24*y34-2d0*y13*y24*y34-2d0*y14*y23*y34-
77208  & 4d0*y13*y23*y34-4d0*y12*y14*y34-4d0*y12*y13*y34-
77209  & 2d0*y13*y14*y24+2d0*y13**2*y24+2d0*y14**2*y23-
77210  & 2d0*y13*y14*y23-y12*y14**2-6d0*y12*y13*y14-
77211  & y12*y13**2)/(4d0*y34**2*y134**2)
77212  wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5d0*cn)*wtb(ic)+
77213  & cn*wtc(ic))/8d0
77214  ELSE
77215  wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2d0*y12*
77216  & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
77217  & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
77218  & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
77219  & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
77220  & y13*y14*y24+2d0*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
77221  & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
77222  & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
77223  & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
77224  wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
77225  & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
77226  & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
77227  & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
77228  & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
77229  & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
77230  & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
77231  & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
77232  wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5d0*cn)*wte(ic))/16d0
77233  ENDIF
77234 
77235 C...Permutations of momenta in matrix element. Weighting.
77236  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
77237  ysav=y13
77238  y13=y14
77239  y14=ysav
77240  ysav=y23
77241  y23=y24
77242  y24=ysav
77243  ysav=y123
77244  y123=y124
77245  y124=ysav
77246  ENDIF
77247  IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
77248  ysav=y13
77249  y13=y23
77250  y23=ysav
77251  ysav=y14
77252  y14=y24
77253  y24=ysav
77254  ysav=y134
77255  y134=y234
77256  y234=ysav
77257  ENDIF
77258  IF(ic.LE.3) GOTO 120
77259  IF(id.EQ.1.AND.wttot.LT.pyr(0)*wtmx) GOTO 110
77260  ic=5
77261 
77262 C...qqgg events: string configuration and event type.
77263  IF(it.EQ.1) THEN
77264  IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
77265  parj(156)=y34*(2d0*(wta(1)+wta(2)+wta(3)+wta(4))+4d0*(wtc(1)+
77266  & wtc(2)+wtc(3)+wtc(4)))/(9d0*wttot)
77267  IF(wta(2)+wta(4)+2d0*(wtc(2)+wtc(4)).GT.pyr(0)*(wta(1)+wta(2)+
77268  & wta(3)+wta(4)+2d0*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
77269  IF(id.EQ.2) GOTO 130
77270  ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
77271  parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8d0*wttot)
77272  IF(wta(2)+wta(4).GT.pyr(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
77273  IF(id.EQ.2) GOTO 130
77274  ENDIF
77275  mstj(120)=3
77276  IF(mstj(109).EQ.0.AND.0.5d0*y34*(wtc(1)+wtc(2)+wtc(3)+
77277  & wtc(4)).GT.pyr(0)*wttot) mstj(120)=4
77278  kfln=21
77279 
77280 C...Mass cuts. Kinematical variables out.
77281  IF(y12.LE.cut+qme) njet=2
77282  IF(njet.EQ.2) GOTO 150
77283  q12=0.5d0*(1d0-sqrt(1d0-qme/y12))
77284  x1=1d0-(1d0-q12)*y234-q12*y134
77285  x4=1d0-(1d0-q12)*y134-q12*y234
77286  x2=1d0-y124
77287  x12=(1d0-q12)*y13+q12*y23
77288  x14=y12-0.5d0*qme
77289  IF(y134*y234/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
77290 
77291 C...qqbarqqbar events: string configuration, choose new flavour.
77292  ELSE
77293  IF(id.EQ.1) THEN
77294  wtr=pyr(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
77295  IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
77296  IF(wtr.LT.wtd(3)+wtd(4)) id=3
77297  IF(wtr.LT.wtd(4)) id=4
77298  IF(id.GE.2) GOTO 130
77299  ENDIF
77300  mstj(120)=5
77301  parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16d0*wttot)
77302  140 kfln=1+int(5d0*pyr(0))
77303  IF(kfln.NE.kfl.AND.0.2d0*parj(156).LE.pyr(0)) GOTO 140
77304  IF(kfln.EQ.kfl.AND.1d0-0.8d0*parj(156).LE.pyr(0)) GOTO 140
77305  IF(kfln.GT.mstj(104)) njet=2
77306  pmqn=pymass(kfln)
77307  qmen=(2d0*pmqn/ecm)**2
77308 
77309 C...Mass cuts. Kinematical variables out.
77310  IF(y24.LE.cut+qme.OR.y13.LE.1.1d0*qmen) njet=2
77311  IF(njet.EQ.2) GOTO 150
77312  q24=0.5d0*(1d0-sqrt(1d0-qme/y24))
77313  q13=0.5d0*(1d0-sqrt(1d0-qmen/y13))
77314  x1=1d0-(1d0-q24)*y123-q24*y134
77315  x4=1d0-(1d0-q24)*y134-q24*y123
77316  x2=1d0-(1d0-q13)*y234-q13*y124
77317  x12=(1d0-q24)*((1d0-q13)*y14+q13*y34)+q24*((1d0-q13)*y12+
77318  & q13*y23)
77319  x14=y24-0.5d0*qme
77320  x34=(1d0-q24)*((1d0-q13)*y23+q13*y12)+q24*((1d0-q13)*y34+
77321  & q13*y14)
77322  IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
77323  & (parj(127)+pmq+pmqn)**2) njet=2
77324  IF(y123*y134/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
77325  ENDIF
77326  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) GOTO 100
77327 
77328  RETURN
77329  END
77330 
77331 C*********************************************************************
77332 
77333 C...PYXDIF
77334 C...Gives the angular orientation of events.
77335 
77336  SUBROUTINE pyxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
77337 
77338 C...Double precision and integer declarations.
77339  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77340  IMPLICIT INTEGER(I-N)
77341  INTEGER PYK,PYCHGE,PYCOMP
77342 C...Commonblocks.
77343  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77344  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77345  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77346  SAVE /pyjets/,/pydat1/,/pydat2/
77347 
77348 C...Charge. Factors depending on polarization for QED case.
77349  qf=kchg(kfl,1)/3d0
77350  poll=1d0-parj(131)*parj(132)
77351  pold=parj(132)-parj(131)
77352  IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
77353  hf1=poll
77354  hf2=0d0
77355  hf3=parj(133)**2
77356  hf4=0d0
77357 
77358 C...Factors depending on flavour, energy and polarization for QFD case.
77359  ELSE
77360  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
77361  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
77362  sfi=sfw*(1d0-(parj(123)/ecm)**2)
77363  ae=-1d0
77364  ve=4d0*paru(102)-1d0
77365  af=sign(1d0,qf)
77366  vf=af-4d0*qf*paru(102)
77367  hf1=qf**2*poll-2d0*qf*vf*sfi*sff*(ve*poll-ae*pold)+
77368  & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2d0*ve*ae*pold)
77369  hf2=-2d0*qf*af*sfi*sff*(ae*poll-ve*pold)+2d0*vf*af*sfw*sff**2*
77370  & (2d0*ve*ae*poll-(ve**2+ae**2)*pold)
77371  hf3=parj(133)**2*(qf**2-2d0*qf*vf*sfi*sff*ve+(vf**2+af**2)*
77372  & sfw*sff**2*(ve**2-ae**2))
77373  hf4=-parj(133)**2*2d0*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
77374  & sff*ae
77375  ENDIF
77376 
77377 C...Mass factor. Differential cross-sections for two-jet events.
77378  sq2=sqrt(2d0)
77379  qme=0d0
77380  IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
77381  &mstj(109).NE.1) qme=(2d0*pymass(kfl)/ecm)**2
77382  IF(njet.EQ.2) THEN
77383  sigu=4d0*sqrt(1d0-qme)
77384  sigl=2d0*qme*sqrt(1d0-qme)
77385  sigt=0d0
77386  sigi=0d0
77387  siga=0d0
77388  sigp=4d0
77389 
77390 C...Kinematical variables. Reduce four-jet event to three-jet one.
77391  ELSE
77392  IF(njet.EQ.3) THEN
77393  x1=2d0*p(nc+1,4)/ecm
77394  x2=2d0*p(nc+3,4)/ecm
77395  ELSE
77396  ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
77397  & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
77398  x1=2d0*p(nc+1,4)/ecmr
77399  x2=2d0*p(nc+4,4)/ecmr
77400  ENDIF
77401 
77402 C...Differential cross-sections for three-jet (or reduced four-jet).
77403  xq=(1d0-x1)/(1d0-x2)
77404  ct12=(x1*x2-2d0*x1-2d0*x2+2d0+qme)/sqrt((x1**2-qme)*(x2**2-qme))
77405  st12=sqrt(1d0-ct12**2)
77406  IF(mstj(109).NE.1) THEN
77407  sigu=2d0*x1**2+x2**2*(1d0+ct12**2)-qme*(3d0+ct12**2-x1-x2)-
77408  & qme*x1/xq+0.5d0*qme*((x2**2-qme)*st12**2-2d0*x2)*xq
77409  sigl=(x2*st12)**2-qme*(3d0-ct12**2-2.5d0*(x1+x2)+x1*x2+qme)+
77410  & 0.5d0*qme*(x1**2-x1-qme)/xq+0.5d0*qme*((x2**2-qme)*ct12**2-
77411  & x2)*xq
77412  sigt=0.5d0*(x2**2-qme-0.5d0*qme*(x2**2-qme)/xq)*st12**2
77413  sigi=((1d0-0.5d0*qme*xq)*(x2**2-qme)*st12*ct12+
77414  & qme*(1d0-x1-x2+0.5d0*x1*x2+0.5d0*qme)*st12/ct12)/sq2
77415  siga=x2**2*st12/sq2
77416  sigp=2d0*(x1**2-x2**2*ct12)
77417 
77418 C...Differential cross-sect for scalar gluons (no mass effects).
77419  ELSE
77420  x3=2d0-x1-x2
77421  xt=x2*st12
77422  ct13=sqrt(max(0d0,1d0-(xt/x3)**2))
77423  sigu=(1d0-parj(171))*(x3**2-0.5d0*xt**2)+
77424  & parj(171)*(x3**2-0.5d0*xt**2-4d0*(1d0-x1)*(1d0-x2)**2/x1)
77425  sigl=(1d0-parj(171))*0.5d0*xt**2+
77426  & parj(171)*0.5d0*(1d0-x1)**2*xt**2
77427  sigt=(1d0-parj(171))*0.25d0*xt**2+
77428  & parj(171)*0.25d0*xt**2*(1d0-2d0*x1)
77429  sigi=-(0.5d0/sq2)*((1d0-parj(171))*xt*x3*ct13+
77430  & parj(171)*xt*((1d0-2d0*x1)*x3*ct13-x1*(x1-x2)))
77431  siga=(0.25d0/sq2)*xt*(2d0*(1d0-x1)-x1*x3)
77432  sigp=x3**2-2d0*(1d0-x1)*(1d0-x2)/x1
77433  ENDIF
77434  ENDIF
77435 
77436 C...Upper bounds for differential cross-section.
77437  hf1a=abs(hf1)
77438  hf2a=abs(hf2)
77439  hf3a=abs(hf3)
77440  hf4a=abs(hf4)
77441  sigmax=(2d0*hf1a+hf3a+hf4a)*abs(sigu)+2d0*(hf1a+hf3a+hf4a)*
77442  &abs(sigl)+2d0*(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigt)+2d0*sq2*
77443  &(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigi)+4d0*sq2*hf2a*abs(siga)+
77444  &2d0*hf2a*abs(sigp)
77445 
77446 C...Generate angular orientation according to differential cross-sect.
77447  100 chi=paru(2)*pyr(0)
77448  cthe=2d0*pyr(0)-1d0
77449  phi=paru(2)*pyr(0)
77450  cchi=cos(chi)
77451  schi=sin(chi)
77452  c2chi=cos(2d0*chi)
77453  s2chi=sin(2d0*chi)
77454  the=acos(cthe)
77455  sthe=sin(the)
77456  c2phi=cos(2d0*(phi-parj(134)))
77457  s2phi=sin(2d0*(phi-parj(134)))
77458  sig=((1d0+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
77459  &2d0*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
77460  &2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*c2chi*c2phi-2d0*cthe*s2chi*
77461  &s2phi)*hf3-((1d0+cthe**2)*c2chi*s2phi+2d0*cthe*s2chi*c2phi)*hf4)*
77462  &sigt-2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*(cthe*cchi*c2phi-
77463  &schi*s2phi)*hf3+2d0*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
77464  &4d0*sq2*sthe*cchi*hf2*siga+2d0*cthe*hf2*sigp
77465  IF(sig.LT.sigmax*pyr(0)) GOTO 100
77466 
77467  RETURN
77468  END
77469 
77470 C*********************************************************************
77471 
77472 C...PYONIA
77473 C...Generates Upsilon and toponium decays into three gluons
77474 C...or two gluons and a photon.
77475 
77476  SUBROUTINE pyonia(KFL,ECM)
77477 
77478 C...Double precision and integer declarations.
77479  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77480  IMPLICIT INTEGER(I-N)
77481  INTEGER PYK,PYCHGE,PYCOMP
77482 C...Commonblocks.
77483  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77484  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77485  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77486  SAVE /pyjets/,/pydat1/,/pydat2/
77487 
77488 C...Printout. Check input parameters.
77489  IF(mstu(12).NE.12345) CALL pylist(0)
77490  IF(kfl.LT.0.OR.kfl.GT.8) THEN
77491  CALL pyerrm(16,'(PYONIA:) called with unknown flavour code')
77492  IF(mstu(21).GE.1) RETURN
77493  ENDIF
77494  IF(ecm.LT.parj(127)+2.02d0*parf(101)) THEN
77495  CALL pyerrm(16,'(PYONIA:) called with too small CM energy')
77496  IF(mstu(21).GE.1) RETURN
77497  ENDIF
77498 
77499 C...Initial e+e- and onium state (optional).
77500  nc=0
77501  IF(mstj(115).GE.2) THEN
77502  nc=nc+2
77503  CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
77504  k(nc-1,1)=21
77505  CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
77506  k(nc,1)=21
77507  ENDIF
77508  kflc=iabs(kfl)
77509  IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
77510  nc=nc+1
77511  kf=110*kflc+3
77512  mstu10=mstu(10)
77513  mstu(10)=1
77514  p(nc,5)=ecm
77515  CALL py1ent(nc,kf,ecm,0d0,0d0)
77516  k(nc,1)=21
77517  k(nc,3)=1
77518  mstu(10)=mstu10
77519  ENDIF
77520 
77521 C...Choose x1 and x2 according to matrix element.
77522  ntry=0
77523  100 x1=pyr(0)
77524  x2=pyr(0)
77525  x3=2d0-x1-x2
77526  IF(x3.GE.1d0.OR.((1d0-x1)/(x2*x3))**2+((1d0-x2)/(x1*x3))**2+
77527  &((1d0-x3)/(x1*x2))**2.LE.2d0*pyr(0)) GOTO 100
77528  ntry=ntry+1
77529  njet=3
77530  IF(mstj(101).LE.4) CALL py3ent(nc+1,21,21,21,ecm,x1,x3)
77531  IF(mstj(101).GE.5) CALL py3ent(-(nc+1),21,21,21,ecm,x1,x3)
77532 
77533 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77534  mstu(111)=mstj(108)
77535  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
77536  &mstu(111)=1
77537  paru(112)=parj(121)
77538  IF(mstu(111).EQ.2) paru(112)=parj(122)
77539  qf=0d0
77540  IF(kflc.NE.0) qf=kchg(kflc,1)/3d0
77541  rgam=7.2d0*qf**2*paru(101)/pyalps(ecm**2)
77542  mk=0
77543  ecmc=ecm
77544  IF(pyr(0).GT.rgam/(1d0+rgam)) THEN
77545  IF(1d0-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
77546  & njet=2
77547  IF(njet.EQ.2.AND.mstj(101).LE.4) CALL py2ent(nc+1,21,21,ecm)
77548  IF(njet.EQ.2.AND.mstj(101).GE.5) CALL py2ent(-(nc+1),21,21,ecm)
77549  ELSE
77550  mk=1
77551  ecmc=sqrt(1d0-x1)*ecm
77552  IF(ecmc.LT.2d0*parj(127)) GOTO 100
77553  k(nc+1,1)=1
77554  k(nc+1,2)=22
77555  k(nc+1,4)=0
77556  k(nc+1,5)=0
77557  IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
77558  IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
77559  IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
77560  IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
77561  njet=2
77562  IF(ecmc.LT.4d0*parj(127)) THEN
77563  mstu10=mstu(10)
77564  mstu(10)=1
77565  p(nc+2,5)=ecmc
77566  CALL py1ent(nc+2,83,0.5d0*(x2+x3)*ecm,paru(1),0d0)
77567  mstu(10)=mstu10
77568  njet=0
77569  ENDIF
77570  ENDIF
77571  DO 110 ip=nc+1,n
77572  k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
77573  110 CONTINUE
77574 
77575 C...Differential cross-sections. Upper limit for cross-section.
77576  IF(mstj(106).EQ.1) THEN
77577  sq2=sqrt(2d0)
77578  hf1=1d0-parj(131)*parj(132)
77579  hf3=parj(133)**2
77580  ct13=(x1*x3-2d0*x1-2d0*x3+2d0)/(x1*x3)
77581  st13=sqrt(1d0-ct13**2)
77582  sigl=0.5d0*x3**2*((1d0-x2)**2+(1d0-x3)**2)*st13**2
77583  sigu=(x1*(1d0-x1))**2+(x2*(1d0-x2))**2+(x3*(1d0-x3))**2-sigl
77584  sigt=0.5d0*sigl
77585  sigi=(sigl*ct13/st13+0.5d0*x1*x3*(1d0-x2)**2*st13)/sq2
77586  sigmax=(2d0*hf1+hf3)*abs(sigu)+2d0*(hf1+hf3)*abs(sigl)+2d0*(hf1+
77587  & 2d0*hf3)*abs(sigt)+2d0*sq2*(hf1+2d0*hf3)*abs(sigi)
77588 
77589 C...Angular orientation of event.
77590  120 chi=paru(2)*pyr(0)
77591  cthe=2d0*pyr(0)-1d0
77592  phi=paru(2)*pyr(0)
77593  cchi=cos(chi)
77594  schi=sin(chi)
77595  c2chi=cos(2d0*chi)
77596  s2chi=sin(2d0*chi)
77597  the=acos(cthe)
77598  sthe=sin(the)
77599  c2phi=cos(2d0*(phi-parj(134)))
77600  s2phi=sin(2d0*(phi-parj(134)))
77601  sig=((1d0+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2d0*(sthe**2*hf1-
77602  & sthe**2*c2phi*hf3)*sigl+2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*
77603  & c2chi*c2phi-2d0*cthe*s2chi*s2phi)*hf3)*sigt-
77604  & 2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*
77605  & (cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
77606  IF(sig.LT.sigmax*pyr(0)) GOTO 120
77607  CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
77608  CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
77609  ENDIF
77610 
77611 C...Generate parton shower. Rearrange along strings and check.
77612  IF(mstj(101).GE.5.AND.njet.GE.2) THEN
77613  CALL pyshow(nc+mk+1,-njet,ecmc)
77614  mstj14=mstj(14)
77615  IF(mstj(105).EQ.-1) mstj(14)=-1
77616  IF(mstj(105).GE.0) mstu(28)=0
77617  CALL pyprep(0)
77618  mstj(14)=mstj14
77619  IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
77620  ENDIF
77621 
77622 C...Generate fragmentation. Information for PYTABU:
77623  IF(mstj(105).EQ.1) CALL pyexec
77624  mstu(161)=110*kflc+3
77625  mstu(162)=0
77626 
77627  RETURN
77628  END
77629 
77630 C*********************************************************************
77631 
77632 C...PYBOOK
77633 C...Books a histogram.
77634 
77635  SUBROUTINE pybook(ID,TITLE,NX,XL,XU)
77636 
77637 C...Double precision declaration.
77638  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77639  IMPLICIT INTEGER(I-N)
77640 C...Commonblock.
77641  common/pybins/ihist(4),indx(1000),bin(20000)
77642  SAVE /pybins/
77643 C...Local character variables.
77644  CHARACTER TITLE*(*), TITFX*60
77645 
77646 C...Check that input is sensible. Find initial address in memory.
77647  IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
77648  &'(PYBOOK:) not allowed histogram number')
77649  IF(nx.LE.0.OR.nx.GT.100) CALL pyerrm(28,
77650  &'(PYBOOK:) not allowed number of bins')
77651  IF(xl.GE.xu) CALL pyerrm(28,
77652  &'(PYBOOK:) x limits in wrong order')
77653  indx(id)=ihist(4)
77654  ihist(4)=ihist(4)+28+nx
77655  IF(ihist(4).GT.ihist(2)) CALL pyerrm(28,
77656  &'(PYBOOK:) out of histogram space')
77657  is=indx(id)
77658 
77659 C...Store histogram size and reset contents.
77660  bin(is+1)=nx
77661  bin(is+2)=xl
77662  bin(is+3)=xu
77663  bin(is+4)=(xu-xl)/nx
77664  CALL pynull(id)
77665 
77666 C...Store title by conversion to integer to double precision.
77667  titfx=title//' '
77668  DO 100 it=1,20
77669  bin(is+8+nx+it)=256**2*ichar(titfx(3*it-2:3*it-2))+
77670  & 256*ichar(titfx(3*it-1:3*it-1))+ichar(titfx(3*it:3*it))
77671  100 CONTINUE
77672 
77673  RETURN
77674  END
77675 
77676 C*********************************************************************
77677 
77678 C...PYFILL
77679 C...Fills entry in histogram.
77680 
77681  SUBROUTINE pyfill(ID,X,W)
77682 
77683 C...Double precision declaration.
77684  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77685  IMPLICIT INTEGER(I-N)
77686 C...Commonblock.
77687  common/pybins/ihist(4),indx(1000),bin(20000)
77688  SAVE /pybins/
77689 
77690 C...Find initial address in memory. Increase number of entries.
77691  IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
77692  &'(PYFILL:) not allowed histogram number')
77693  is=indx(id)
77694  IF(is.EQ.0) CALL pyerrm(28,
77695  &'(PYFILL:) filling unbooked histogram')
77696  bin(is+5)=bin(is+5)+1d0
77697 
77698 C...Find bin in x, including under/overflow, and fill.
77699  IF(x.LT.bin(is+2)) THEN
77700  bin(is+6)=bin(is+6)+w
77701  ELSEIF(x.GE.bin(is+3)) THEN
77702  bin(is+8)=bin(is+8)+w
77703  ELSE
77704  bin(is+7)=bin(is+7)+w
77705  ix=(x-bin(is+2))/bin(is+4)
77706  ix=max(0,min(nint(bin(is+1))-1,ix))
77707  bin(is+9+ix)=bin(is+9+ix)+w
77708  ENDIF
77709 
77710  RETURN
77711  END
77712 
77713 C*********************************************************************
77714 
77715 C...PYFACT
77716 C...Multiplies histogram contents by factor.
77717 
77718  SUBROUTINE pyfact(ID,F)
77719 
77720 C...Double precision declaration.
77721  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77722  IMPLICIT INTEGER(I-N)
77723 C...Commonblock.
77724  common/pybins/ihist(4),indx(1000),bin(20000)
77725  SAVE /pybins/
77726 
77727 C...Find initial address in memory. Multiply all contents bins.
77728  IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
77729  &'(PYFACT:) not allowed histogram number')
77730  is=indx(id)
77731  IF(is.EQ.0) CALL pyerrm(28,
77732  &'(PYFACT:) scaling unbooked histogram')
77733  DO 100 ix=is+6,is+8+nint(bin(is+1))
77734  bin(ix)=f*bin(ix)
77735  100 CONTINUE
77736 
77737  RETURN
77738  END
77739 
77740 C*********************************************************************
77741 
77742 C...PYOPER
77743 C...Performs operations between histograms.
77744 
77745  SUBROUTINE pyoper(ID1,OPER,ID2,ID3,F1,F2)
77746 
77747 C...Double precision declaration.
77748  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77749  IMPLICIT INTEGER(I-N)
77750 C...Commonblock.
77751  common/pybins/ihist(4),indx(1000),bin(20000)
77752  SAVE /pybins/
77753 C...Character variable.
77754  CHARACTER OPER*(*)
77755 
77756 C...Find initial addresses in memory, and histogram size.
77757  IF(id1.LE.0.OR.id1.GT.ihist(1)) CALL pyerrm(28,
77758  &'(PYFACT:) not allowed histogram number')
77759  is1=indx(id1)
77760  is2=indx(min(ihist(1),max(1,id2)))
77761  is3=indx(min(ihist(1),max(1,id3)))
77762  nx=nint(bin(is3+1))
77763  IF(oper.EQ.'M'.AND.id3.EQ.0) nx=nint(bin(is2+1))
77764 
77765 C...Update info on number of histogram entries.
77766  IF(oper.EQ.'+'.OR.oper.EQ.'-'.OR.oper.EQ.'*'.OR.oper.EQ.'/') THEN
77767  bin(is3+5)=bin(is1+5)+bin(is2+5)
77768  ELSEIF(oper.EQ.'A'.OR.oper.EQ.'S'.OR.oper.EQ.'L') THEN
77769  bin(is3+5)=bin(is1+5)
77770  ENDIF
77771 
77772 C...Operations on pair of histograms: addition, subtraction,
77773 C...multiplication, division.
77774  IF(oper.EQ.'+') THEN
77775  DO 100 ix=6,8+nx
77776  bin(is3+ix)=f1*bin(is1+ix)+f2*bin(is2+ix)
77777  100 CONTINUE
77778  ELSEIF(oper.EQ.'-') THEN
77779  DO 110 ix=6,8+nx
77780  bin(is3+ix)=f1*bin(is1+ix)-f2*bin(is2+ix)
77781  110 CONTINUE
77782  ELSEIF(oper.EQ.'*') THEN
77783  DO 120 ix=6,8+nx
77784  bin(is3+ix)=f1*bin(is1+ix)*f2*bin(is2+ix)
77785  120 CONTINUE
77786  ELSEIF(oper.EQ.'/') THEN
77787  DO 130 ix=6,8+nx
77788  fa2=f2*bin(is2+ix)
77789  IF(abs(fa2).LE.1d-20) THEN
77790  bin(is3+ix)=0d0
77791  ELSE
77792  bin(is3+ix)=f1*bin(is1+ix)/fa2
77793  ENDIF
77794  130 CONTINUE
77795 
77796 C...Operations on single histogram: multiplication+addition,
77797 C...square root+addition, logarithm+addition.
77798  ELSEIF(oper.EQ.'A') THEN
77799  DO 140 ix=6,8+nx
77800  bin(is3+ix)=f1*bin(is1+ix)+f2
77801  140 CONTINUE
77802  ELSEIF(oper.EQ.'S') THEN
77803  DO 150 ix=6,8+nx
77804  bin(is3+ix)=f1*sqrt(max(0d0,bin(is1+ix)))+f2
77805  150 CONTINUE
77806  ELSEIF(oper.EQ.'L') THEN
77807  zmin=1d20
77808  DO 160 ix=9,8+nx
77809  IF(bin(is1+ix).LT.zmin.AND.bin(is1+ix).GT.1d-20)
77810  & zmin=0.8d0*bin(is1+ix)
77811  160 CONTINUE
77812  DO 170 ix=6,8+nx
77813  bin(is3+ix)=f1*log10(max(zmin,bin(is1+ix)))+f2
77814  170 CONTINUE
77815 
77816 C...Operation on two or three histograms: average and
77817 C...standard deviation.
77818  ELSEIF(oper.EQ.'M') THEN
77819  DO 180 ix=6,8+nx
77820  IF(abs(bin(is1+ix)).LE.1d-20) THEN
77821  bin(is2+ix)=0d0
77822  ELSE
77823  bin(is2+ix)=bin(is2+ix)/bin(is1+ix)
77824  ENDIF
77825  IF(id3.NE.0) THEN
77826  IF(abs(bin(is1+ix)).LE.1d-20) THEN
77827  bin(is3+ix)=0d0
77828  ELSE
77829  bin(is3+ix)=sqrt(max(0d0,bin(is3+ix)/bin(is1+ix)-
77830  & bin(is2+ix)**2))
77831  ENDIF
77832  ENDIF
77833  bin(is1+ix)=f1*bin(is1+ix)
77834  180 CONTINUE
77835  ENDIF
77836 
77837  RETURN
77838  END
77839 
77840 C*********************************************************************
77841 
77842 C...PYHIST
77843 C...Prints and resets all histograms.
77844 
77845  SUBROUTINE pyhist
77846 
77847 C...Double precision declaration.
77848  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77849  IMPLICIT INTEGER(I-N)
77850 C...Commonblock.
77851  common/pybins/ihist(4),indx(1000),bin(20000)
77852  SAVE /pybins/
77853 
77854 C...Loop over histograms, print and reset used ones.
77855  DO 100 id=1,ihist(1)
77856  is=indx(id)
77857  IF(is.NE.0.AND.nint(bin(is+5)).GT.0) THEN
77858  CALL pyplot(id)
77859  CALL pynull(id)
77860  ENDIF
77861  100 CONTINUE
77862 
77863  RETURN
77864  END
77865 
77866 C*********************************************************************
77867 
77868 C...PYPLOT
77869 C...Prints a histogram (but does not reset it).
77870 
77871  SUBROUTINE pyplot(ID)
77872 
77873 C...Double precision declaration.
77874  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77875  IMPLICIT INTEGER(I-N)
77876 C...Commonblocks.
77877  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77878  common/pybins/ihist(4),indx(1000),bin(20000)
77879  SAVE /pydat1/,/pybins/
77880 C...Local arrays and character variables.
77881  dimension idati(6), irow(100), ifra(100), dyac(10)
77882  CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77883 
77884 C...Steps in histogram scale. Character sequence.
77885  DATA dyac/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77886  DATA cha/'0','1','2','3','4','5','6','7','8','9','X','-'/
77887 
77888 C...Find initial address in memory; skip if empty histogram.
77889  IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
77890  is=indx(id)
77891  IF(is.EQ.0) RETURN
77892  IF(nint(bin(is+5)).LE.0) THEN
77893  WRITE(mstu(11),5000) id
77894  RETURN
77895  ENDIF
77896 
77897 C...Number of histogram lines and x bins.
77898  lin=ihist(3)-18
77899  nx=nint(bin(is+1))
77900 
77901 C...Extract title by conversion from double precision via integer.
77902  DO 100 it=1,20
77903  ieq=nint(bin(is+8+nx+it))
77904  title(3*it-2:3*it)=char(ieq/256**2)//char(mod(ieq,256**2)/256)
77905  & //char(mod(ieq,256))
77906  100 CONTINUE
77907 
77908 C...Find time; print title.
77909  CALL pytime(idati)
77910  IF(idati(1).GT.0) THEN
77911  WRITE(mstu(11),5100) id, title, (idati(j),j=1,5)
77912  ELSE
77913  WRITE(mstu(11),5200) id, title
77914  ENDIF
77915 
77916 C...Find minimum and maximum bin content.
77917  ymin=bin(is+9)
77918  ymax=bin(is+9)
77919  DO 110 ix=is+10,is+8+nx
77920  IF(bin(ix).LT.ymin) ymin=bin(ix)
77921  IF(bin(ix).GT.ymax) ymax=bin(ix)
77922  110 CONTINUE
77923 
77924 C...Determine scale and step size for y axis.
77925  IF(ymax-ymin.GT.lin*dyac(1)*1d-9) THEN
77926  IF(ymin.GT.0d0.AND.ymin.LT.0.1d0*ymax) ymin=0d0
77927  IF(ymax.LT.0d0.AND.ymax.GT.0.1d0*ymin) ymax=0d0
77928  ipot=int(log10(ymax-ymin)+10d0)-10
77929  IF(ymax-ymin.LT.lin*dyac(1)*10d0**ipot) ipot=ipot-1
77930  IF(ymax-ymin.GT.lin*dyac(10)*10d0**ipot) ipot=ipot+1
77931  dely=dyac(1)
77932  DO 120 idel=1,9
77933  IF(ymax-ymin.GE.lin*dyac(idel)*10d0**ipot) dely=dyac(idel+1)
77934  120 CONTINUE
77935  dy=dely*10d0**ipot
77936 
77937 C...Convert bin contents to integer form; fractional fill in top row.
77938  DO 130 ix=1,nx
77939  cta=abs(bin(is+8+ix))/dy
77940  irow(ix)=sign(cta+0.95d0,bin(is+8+ix))
77941  ifra(ix)=10d0*(cta+1.05d0-dble(int(cta+0.95d0)))
77942  130 CONTINUE
77943  irmi=sign(abs(ymin)/dy+0.95d0,ymin)
77944  irma=sign(abs(ymax)/dy+0.95d0,ymax)
77945 
77946 C...Print histogram row by row.
77947  DO 150 ir=irma,irmi,-1
77948  IF(ir.EQ.0) GOTO 150
77949  out=' '
77950  DO 140 ix=1,nx
77951  IF(ir.EQ.irow(ix)) out(ix:ix)=cha(ifra(ix))
77952  IF(ir*(irow(ix)-ir).GT.0) out(ix:ix)=cha(10)
77953  140 CONTINUE
77954  WRITE(mstu(11),5300) ir*dely, ipot, out
77955  150 CONTINUE
77956 
77957 C...Print sign and value of bin contents.
77958  ipot=int(log10(max(ymax,-ymin))+10.0001d0)-10
77959  out=' '
77960  DO 160 ix=1,nx
77961  IF(bin(is+8+ix).LT.-10d0**(ipot-4)) out(ix:ix)=cha(11)
77962  irow(ix)=nint(10d0**(3-ipot)*abs(bin(is+8+ix)))
77963  160 CONTINUE
77964  WRITE(mstu(11),5400) out
77965  DO 180 ir=4,1,-1
77966  DO 170 ix=1,nx
77967  out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
77968  170 CONTINUE
77969  WRITE(mstu(11),5500) ipot+ir-4, out
77970  180 CONTINUE
77971 
77972 C...Print sign and value of lower bin edge.
77973  ipot=int(log10(max(-bin(is+2),bin(is+3)-bin(is+4)))+
77974  & 10.0001d0)-10
77975  out=' '
77976  DO 190 ix=1,nx
77977  IF(bin(is+2)+(ix-1)*bin(is+4).LT.-10d0**(ipot-3))
77978  & out(ix:ix)=cha(11)
77979  irow(ix)=nint(10d0**(2-ipot)*abs(bin(is+2)+(ix-1)*bin(is+4)))
77980  190 CONTINUE
77981  WRITE(mstu(11),5600) out
77982  DO 210 ir=3,1,-1
77983  DO 200 ix=1,nx
77984  out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
77985  200 CONTINUE
77986  WRITE(mstu(11),5500) ipot+ir-3, out
77987  210 CONTINUE
77988  ENDIF
77989 
77990 C...Calculate and print statistics.
77991  csum=0d0
77992  cxsum=0d0
77993  cxxsum=0d0
77994  DO 220 ix=1,nx
77995  cta=abs(bin(is+8+ix))
77996  x=bin(is+2)+(ix-0.5d0)*bin(is+4)
77997  csum=csum+cta
77998  cxsum=cxsum+cta*x
77999  cxxsum=cxxsum+cta*x**2
78000  220 CONTINUE
78001  xmean=cxsum/max(csum,1d-20)
78002  xrms=sqrt(max(0d0,cxxsum/max(csum,1d-20)-xmean**2))
78003  WRITE(mstu(11),5700) nint(bin(is+5)),xmean,bin(is+6),
78004  &bin(is+2),bin(is+7),xrms,bin(is+8),bin(is+3)
78005 
78006 C...Formats for output.
78007  5000 FORMAT(/5x,'Histogram no',i5,' : no entries')
78008  5100 FORMAT('1'/5x,'Histogram no',i5,6x,a60,5x,i4,'-',i2,'-',i2,1x,
78009  &i2,':',i2/)
78010  5200 FORMAT('1'/5x,'Histogram no',i5,6x,a60/)
78011  5300 FORMAT(2x,f7.2,'*10**',i2,3x,a100)
78012  5400 FORMAT(/8x,'Contents',3x,a100)
78013  5500 FORMAT(9x,'*10**',i2,3x,a100)
78014  5600 FORMAT(/8x,'Low edge',3x,a100)
78015  5700 FORMAT(/5x,'Entries =',i12,1p,6x,'Mean =',d12.4,6x,'Underflow ='
78016  &,d12.4,6x,'Low edge =',d12.4/5x,'All chan =',d12.4,6x,
78017  &'Rms =',d12.4,6x,'Overflow =',d12.4,6x,'High edge =',d12.4)
78018 
78019  RETURN
78020  END
78021 
78022 C*********************************************************************
78023 
78024 C...PYNULL
78025 C...Resets bin contents of a histogram.
78026 
78027  SUBROUTINE pynull(ID)
78028 
78029 C...Double precision declaration.
78030  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78031  IMPLICIT INTEGER(I-N)
78032 C...Commonblock.
78033  common/pybins/ihist(4),indx(1000),bin(20000)
78034  SAVE /pybins/
78035 
78036  IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
78037  is=indx(id)
78038  IF(is.EQ.0) RETURN
78039  DO 100 ix=is+5,is+8+nint(bin(is+1))
78040  bin(ix)=0d0
78041  100 CONTINUE
78042 
78043  RETURN
78044  END
78045 
78046 C*********************************************************************
78047 
78048 C...PYDUMP
78049 C...Dumps histogram contents on file for reading by other program.
78050 C...Can also read back own dump.
78051 
78052  SUBROUTINE pydump(MDUMP,LFN,NHI,IHI)
78053 
78054 C...Double precision declaration.
78055  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78056  IMPLICIT INTEGER(I-N)
78057 C...Commonblock.
78058  common/pybins/ihist(4),indx(1000),bin(20000)
78059  SAVE /pybins/
78060 C...Local arrays and character variables.
78061  dimension ihi(*),iss(100),val(5)
78062  CHARACTER TITLE*60,FORMAT*13
78063 
78064 C...Dump all histograms that have been booked,
78065 C...including titles and ranges, one after the other.
78066  IF(mdump.EQ.1) THEN
78067 
78068 C...Loop over histograms and find which are wanted and booked.
78069  IF(nhi.LE.0) THEN
78070  nw=ihist(1)
78071  ELSE
78072  nw=nhi
78073  ENDIF
78074  DO 130 iw=1,nw
78075  IF(nhi.EQ.0) THEN
78076  id=iw
78077  ELSE
78078  id=ihi(iw)
78079  ENDIF
78080  is=indx(id)
78081  IF(is.NE.0) THEN
78082 
78083 C...Write title, histogram size, filling statistics.
78084  nx=nint(bin(is+1))
78085  DO 100 it=1,20
78086  ieq=nint(bin(is+8+nx+it))
78087  title(3*it-2:3*it)=char(ieq/256**2)//
78088  & char(mod(ieq,256**2)/256)//char(mod(ieq,256))
78089  100 CONTINUE
78090  WRITE(lfn,5100) id,title
78091  WRITE(lfn,5200) nx,bin(is+2),bin(is+3)
78092  WRITE(lfn,5300) nint(bin(is+5)),bin(is+6),bin(is+7),
78093  & bin(is+8)
78094 
78095 
78096 C...Write histogram contents, in groups of five.
78097  DO 120 ixg=1,(nx+4)/5
78098  DO 110 ixv=1,5
78099  ix=5*ixg+ixv-5
78100  IF(ix.LE.nx) THEN
78101  val(ixv)=bin(is+8+ix)
78102  ELSE
78103  val(ixv)=0d0
78104  ENDIF
78105  110 CONTINUE
78106  WRITE(lfn,5400) (val(ixv),ixv=1,5)
78107  120 CONTINUE
78108 
78109 C...Go to next histogram; finish.
78110  ELSEIF(nhi.GT.0) THEN
78111  CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
78112  ENDIF
78113  130 CONTINUE
78114 
78115 C...Read back in histograms dumped MDUMP=1.
78116  ELSEIF(mdump.EQ.2) THEN
78117 
78118 C...Read histogram number, title and range, and book.
78119  140 READ(lfn,5100,END=170) ID,title
78120  READ(lfn,5200) nx,xl,xu
78121  CALL pybook(id,title,nx,xl,xu)
78122  is=indx(id)
78123 
78124 C...Read filling statistics.
78125  READ(lfn,5300) nentry,bin(is+6),bin(is+7),bin(is+8)
78126  bin(is+5)=dble(nentry)
78127 
78128 C...Read histogram contents, in groups of five.
78129  DO 160 ixg=1,(nx+4)/5
78130  READ(lfn,5400) (val(ixv),ixv=1,5)
78131  DO 150 ixv=1,5
78132  ix=5*ixg+ixv-5
78133  IF(ix.LE.nx) bin(is+8+ix)=val(ixv)
78134  150 CONTINUE
78135  160 CONTINUE
78136 
78137 C...Go to next histogram; finish.
78138  GOTO 140
78139  170 CONTINUE
78140 
78141 C...Write histogram contents in column format,
78142 C...convenient e.g. for GNUPLOT input.
78143  ELSEIF(mdump.EQ.3) THEN
78144 
78145 C...Find addresses to wanted histograms.
78146  nss=0
78147  IF(nhi.LE.0) THEN
78148  nw=ihist(1)
78149  ELSE
78150  nw=nhi
78151  ENDIF
78152  DO 180 iw=1,nw
78153  IF(nhi.EQ.0) THEN
78154  id=iw
78155  ELSE
78156  id=ihi(iw)
78157  ENDIF
78158  is=indx(id)
78159  IF(is.NE.0.AND.nss.LT.100) THEN
78160  nss=nss+1
78161  iss(nss)=is
78162  ELSEIF(nss.GE.100) THEN
78163  CALL pyerrm(8,'(PYDUMP:) too many histograms requested')
78164  ELSEIF(nhi.GT.0) THEN
78165  CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
78166  ENDIF
78167  180 CONTINUE
78168 
78169 C...Check that they have common number of x bins. Fix format.
78170  nx=nint(bin(iss(1)+1))
78171  DO 190 iw=2,nss
78172  IF(nint(bin(iss(iw)+1)).NE.nx) THEN
78173  CALL pyerrm(8,'(PYDUMP:) different number of bins')
78174  RETURN
78175  ENDIF
78176  190 CONTINUE
78177  format='(1P,000E12.4)'
78178  WRITE(FORMAT(5:7),'(I3)') nss+1
78179 
78180 C...Write histogram contents; first column x values.
78181  DO 200 ix=1,nx
78182  x=bin(iss(1)+2)+(ix-0.5d0)*bin(iss(1)+4)
78183  WRITE(lfn,format) x, (bin(iss(iw)+8+ix),iw=1,nss)
78184  200 CONTINUE
78185 
78186  ENDIF
78187 
78188 C...Formats for output.
78189  5100 FORMAT(i5,5x,a60)
78190  5200 FORMAT(i5,1p,2d12.4)
78191  5300 FORMAT(i12,1p,3d12.4)
78192  5400 FORMAT(1p,5d12.4)
78193 
78194  RETURN
78195  END
78196 
78197 C*********************************************************************
78198 
78199 C...PYSTOP
78200 C...Allows users to handle STOP statemens
78201 
78202  SUBROUTINE pystop(MCOD)
78203 
78204 C...Double precision and integer declarations.
78205  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78206  IMPLICIT INTEGER(I-N)
78207  INTEGER PYK,PYCHGE,PYCOMP
78208 C...Commonblocks.
78209  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78210  SAVE /pydat1/
78211 
78212 
78213 C...Write message, then stop
78214  WRITE(mstu(11),5000) mcod
78215  stop
78216 
78217 
78218 C...Formats for output.
78219  5000 FORMAT(/5x,'PYSTOP called with code: ',i4)
78220  END
78221 
78222 C*********************************************************************
78223 
78224 C...PYKCUT
78225 C...Dummy routine, which the user can replace in order to make cuts on
78226 C...the kinematics on the parton level before the matrix elements are
78227 C...evaluated and the event is generated. The cross-section estimates
78228 C...will automatically take these cuts into account, so the given
78229 C...values are for the allowed phase space region only. MCUT=0 means
78230 C...that the event has passed the cuts, MCUT=1 that it has failed.
78231 
78232  SUBROUTINE pykcut(MCUT)
78233 
78234 C...Double precision and integer declarations.
78235  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78236  IMPLICIT INTEGER(I-N)
78237  INTEGER PYK,PYCHGE,PYCOMP
78238 C...Commonblocks.
78239  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78240  common/pyint1/mint(400),vint(400)
78241  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
78242  SAVE /pydat1/,/pyint1/,/pyint2/
78243 
78244 C...Set default value (accepting event) for MCUT.
78245  mcut=0
78246 
78247 C...Read out subprocess number.
78248  isub=mint(1)
78249  istsb=iset(isub)
78250 
78251 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78252  tau=vint(21)
78253  yst=vint(22)
78254  cth=0d0
78255  IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
78256  taup=0d0
78257  IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
78258 
78259 C...Calculate x_1, x_2, x_F.
78260  IF(istsb.LE.2.OR.istsb.GE.5) THEN
78261  x1=sqrt(tau)*exp(yst)
78262  x2=sqrt(tau)*exp(-yst)
78263  ELSE
78264  x1=sqrt(taup)*exp(yst)
78265  x2=sqrt(taup)*exp(-yst)
78266  ENDIF
78267  xf=x1-x2
78268 
78269 C...Calculate shat, that, uhat, p_T^2.
78270  shat=tau*vint(2)
78271  sqm3=vint(63)
78272  sqm4=vint(64)
78273  rm3=sqm3/shat
78274  rm4=sqm4/shat
78275  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
78276  rpts=4d0*vint(71)**2/shat
78277  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
78278  rm34=2d0*rm3*rm4
78279  rsqm=1d0+rm34
78280  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
78281  that=-0.5d0*shat*max(rthm,1d0-rm3-rm4-be34*cth)
78282  uhat=-0.5d0*shat*max(rthm,1d0-rm3-rm4+be34*cth)
78283  pt2=max(vint(71)**2,0.25d0*shat*be34**2*(1d0-cth**2))
78284 
78285 C...Decisions by user to be put here.
78286 
78287 C...Stop program if this routine is ever called.
78288 C...You should not copy these lines to your own routine.
78289  WRITE(mstu(11),5000)
78290  CALL pystop(6)
78291 
78292 C...Format for error printout.
78293  5000 FORMAT(1x,'Error: you did not link your PYKCUT routine ',
78294  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
78295  &1x,'Execution stopped!')
78296 
78297  RETURN
78298  END
78299 
78300 C*********************************************************************
78301 
78302 C...PYEVWT
78303 C...Dummy routine, which the user can replace in order to multiply the
78304 C...standard PYTHIA differential cross-section by a process- and
78305 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78306 C...to generation of weighted events, with weight 1/WTXS, while for
78307 C...MSTP(142)=2 it corresponds to a modification of the underlying
78308 C...physics.
78309 
78310  SUBROUTINE pyevwt(WTXS)
78311 
78312 C...Double precision and integer declarations.
78313  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78314  IMPLICIT INTEGER(I-N)
78315  INTEGER PYK,PYCHGE,PYCOMP
78316 C...Commonblocks.
78317  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78318  common/pyint1/mint(400),vint(400)
78319  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
78320  SAVE /pydat1/,/pyint1/,/pyint2/
78321 
78322 C...Set default weight for WTXS.
78323  wtxs=1d0
78324 
78325 C...Read out subprocess number.
78326  isub=mint(1)
78327  istsb=iset(isub)
78328 
78329 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78330  tau=vint(21)
78331  yst=vint(22)
78332  cth=0d0
78333  IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
78334  taup=0d0
78335  IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
78336 
78337 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78338  x1=vint(41)
78339  x2=vint(42)
78340  xf=x1-x2
78341  shat=vint(44)
78342  that=vint(45)
78343  uhat=vint(46)
78344  pt2=vint(48)
78345 
78346 C...Modifications by user to be put here.
78347 
78348 C...Stop program if this routine is ever called.
78349 C...You should not copy these lines to your own routine.
78350  WRITE(mstu(11),5000)
78351  CALL pystop(4)
78352 
78353 C...Format for error printout.
78354  5000 FORMAT(1x,'Error: you did not link your PYEVWT routine ',
78355  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
78356  &1x,'Execution stopped!')
78357 
78358  RETURN
78359  END
78360 
78361 C*********************************************************************
78362 
78363 C...UPINIT
78364 C...Dummy routine, to be replaced by a user implementing external
78365 C...processes. Is supposed to fill the HEPRUP commonblock with info
78366 C...on incoming beams and allowed processes.
78367 
78368 C...New example: handles a standard Les Houches Events File.
78369 
78370  SUBROUTINE upinit
78371 
78372 C...Double precision and integer declarations.
78373  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78374  IMPLICIT INTEGER(I-N)
78375 
78376 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78377  common/pypars/mstp(200),parp(200),msti(200),pari(200)
78378  SAVE /pypars/
78379 
78380 C...User process initialization commonblock.
78381  INTEGER MAXPUP
78382  parameter(maxpup=100)
78383  INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78384  DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78385  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
78386  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
78387  &lprup(maxpup)
78388  SAVE /heprup/
78389 
78390 C...Lines to read in assumed never longer than 200 characters.
78391  parameter(maxlen=200)
78392  CHARACTER*(MAXLEN) STRING
78393 
78394 C...Format for reading lines.
78395  CHARACTER*6 STRFMT
78396  strfmt='(A000)'
78397  WRITE(strfmt(3:5),'(I3)') maxlen
78398 
78399 C...Loop until finds line beginning with "<init>" or "<init ".
78400  100 READ(mstp(161),strfmt,END=130,ERR=130) string
78401  ibeg=0
78402  110 ibeg=ibeg+1
78403 C...Allow indentation.
78404  IF(string(ibeg:ibeg).EQ.' '.AND.ibeg.LT.maxlen-5) GOTO 110
78405  IF(string(ibeg:ibeg+5).NE.'<init>'.AND.
78406  &string(ibeg:ibeg+5).NE.'<init ') GOTO 100
78407 
78408 C...Read first line of initialization info.
78409  READ(mstp(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78410  &ebmup(2),pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
78411 
78412 C...Read NPRUP subsequent lines with information on each process.
78413  DO 120 ipr=1,nprup
78414  READ(mstp(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78415  & xmaxup(ipr),lprup(ipr)
78416  120 CONTINUE
78417  RETURN
78418 
78419 C...Error exit: give up if initalization does not work.
78420  130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78421  WRITE(*,*) ' Event generation will be stopped.'
78422  CALL pystop(12)
78423 
78424  RETURN
78425  END
78426 
78427 C...Old example: handles a simple Pythia 6.4 initialization file.
78428 
78429 c SUBROUTINE UPINIT
78430 
78431 C...Double precision and integer declarations.
78432 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78433 c IMPLICIT INTEGER(I-N)
78434 
78435 C...Commonblocks.
78436 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78437 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78438 c SAVE /PYDAT1/,/PYPARS/
78439 
78440 C...User process initialization commonblock.
78441 c INTEGER MAXPUP
78442 c PARAMETER (MAXPUP=100)
78443 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78444 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78445 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78446 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78447 c &LPRUP(MAXPUP)
78448 c SAVE /HEPRUP/
78449 
78450 C...Read info from file.
78451 c IF(MSTP(161).GT.0) THEN
78452 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78453 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78454 c DO 100 IPR=1,NPRUP
78455 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78456 c & XMAXUP(IPR),LPRUP(IPR)
78457 c 100 CONTINUE
78458 c RETURN
78459 C...Error or prematurely reached end of file.
78460 c 110 WRITE(MSTU(11),5000)
78461 c STOP
78462 
78463 C...Else not implemented.
78464 c ELSE
78465 c WRITE(MSTU(11),5100)
78466 c STOP
78467 c ENDIF
78468 
78469 C...Format for error printout.
78470 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78471 c &1X,'Execution stopped!')
78472 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78473 c &1X,'Dummy routine in PYTHIA file called instead.'/
78474 c &1X,'Execution stopped!')
78475 
78476 c RETURN
78477 c END
78478 
78479 C*********************************************************************
78480 
78481 C...UPEVNT
78482 C...Dummy routine, to be replaced by a user implementing external
78483 C...processes. Depending on cross section model chosen, it either has
78484 C...to generate a process of the type IDPRUP requested, or pick a type
78485 C...itself and generate this event. The event is to be stored in the
78486 C...HEPEUP commonblock, including (often) an event weight.
78487 
78488 C...New example: handles a standard Les Houches Events File.
78489 
78490  SUBROUTINE upevnt
78491 
78492 C...Double precision and integer declarations.
78493  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78494  IMPLICIT INTEGER(I-N)
78495 
78496 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78497  common/pypars/mstp(200),parp(200),msti(200),pari(200)
78498  SAVE /pypars/
78499 
78500 C...User process event common block.
78501  INTEGER MAXNUP
78502  parameter(maxnup=500)
78503  INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78504  DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78505  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
78506  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
78507  &vtimup(maxnup),spinup(maxnup)
78508  SAVE /hepeup/
78509 
78510 C...Lines to read in assumed never longer than 200 characters.
78511  parameter(maxlen=200)
78512  CHARACTER*(MAXLEN) STRING
78513 
78514 C...Format for reading lines.
78515  CHARACTER*6 STRFMT
78516  strfmt='(A000)'
78517  WRITE(strfmt(3:5),'(I3)') maxlen
78518 
78519 C...Loop until finds line beginning with "<event>" or "<event ".
78520  100 READ(mstp(162),strfmt,END=130,ERR=130) string
78521  ibeg=0
78522  110 ibeg=ibeg+1
78523 C...Allow indentation.
78524  IF(string(ibeg:ibeg).EQ.' '.AND.ibeg.LT.maxlen-6) GOTO 110
78525  IF(string(ibeg:ibeg+6).NE.'<event>'.AND.
78526  &string(ibeg:ibeg+6).NE.'<event ') GOTO 100
78527 
78528 C...Read first line of event info.
78529  READ(mstp(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78530  &aqedup,aqcdup
78531 
78532 C...Read NUP subsequent lines with information on each particle.
78533  DO 120 i=1,nup
78534  READ(mstp(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78535  & mothup(1,i),mothup(2,i),icolup(1,i),icolup(2,i),
78536  & (pup(j,i),j=1,5),vtimup(i),spinup(i)
78537  120 CONTINUE
78538  RETURN
78539 
78540 C...Error exit, typically when no more events.
78541  130 WRITE(*,*) ' Failed to read LHEF event information.'
78542  WRITE(*,*) ' Will assume end of file has been reached.'
78543  nup=0
78544  msti(51)=1
78545 
78546  RETURN
78547  END
78548 
78549 C...Old example: handles a simple Pythia 6.4 event file.
78550 
78551 c SUBROUTINE UPEVNT
78552 
78553 C...Double precision and integer declarations.
78554 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78555 c IMPLICIT INTEGER(I-N)
78556 
78557 C...Commonblocks.
78558 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78559 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78560 c SAVE /PYDAT1/,/PYPARS/
78561 
78562 C...User process event common block.
78563 c INTEGER MAXNUP
78564 c PARAMETER (MAXNUP=500)
78565 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78566 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78567 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78568 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78569 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78570 c SAVE /HEPEUP/
78571 
78572 C...Read info from file.
78573 c IF(MSTP(162).GT.0) THEN
78574 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78575 c & AQEDUP,AQCDUP
78576 c DO 100 I=1,NUP
78577 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78578 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78579 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78580 c 100 CONTINUE
78581 c RETURN
78582 C...Special when reached end of file or other error.
78583 c 110 NUP=0
78584 
78585 C...Else not implemented.
78586 c ELSE
78587 c WRITE(MSTU(11),5000)
78588 c STOP
78589 c ENDIF
78590 
78591 C...Format for error printout.
78592 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78593 c &1X,'Dummy routine in PYTHIA file called instead.'/
78594 c &1X,'Execution stopped!')
78595 
78596 c RETURN
78597 c END
78598 
78599 C*********************************************************************
78600 
78601 C...UPVETO
78602 C...Dummy routine, to be replaced by user, to veto event generation
78603 C...on the parton level, after parton showers but before multiple
78604 C...interactions, beam remnants and hadronization is added.
78605 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78606 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78607 C...be undecayed at this stage; if decayed their decay products will
78608 C...have been allowed to shower.
78609 
78610 C...All partons at the end of the shower phase are stored in the
78611 C...HEPEVT commonblock. The interesting information is
78612 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78613 C...IDHEP(I) = the particle ID code according to PDG conventions,
78614 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78615 C...All ISTHEP entries are 1, while the rest is zeroed.
78616 
78617 C...The user decision is to be conveyed by the IVETO value.
78618 C...IVETO = 0 : retain current event and generate in full;
78619 C... = 1 : abort generation of current event and move to next.
78620 
78621  SUBROUTINE upveto(IVETO)
78622 
78623 C...HEPEVT commonblock.
78624  parameter(nmxhep=4000)
78625  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
78626  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
78627  DOUBLE PRECISION PHEP,VHEP
78628  SAVE /hepevt/
78629 
78630 C...Next few lines allow you to see what info PYVETO extracted from
78631 C...the full event record for the first two events.
78632 C...Delete if you don't want it.
78633  DATA nlist/0/
78634  SAVE nlist
78635  IF(nlist.LE.2) THEN
78636  WRITE(*,*) ' Full event record at time of UPVETO call:'
78637  CALL pylist(1)
78638  WRITE(*,*) ' Part of event record made available to UPVETO:'
78639  CALL pylist(5)
78640  nlist=nlist+1
78641  ENDIF
78642 
78643 C...Make decision here.
78644  iveto = 0
78645 
78646  RETURN
78647  END
78648 
78649 C*********************************************************************
78650 
78651 C...PDFSET
78652 C...Dummy routine, to be removed when PDFLIB is to be linked.
78653 
78654  SUBROUTINE pdfset(PARM,VALUE)
78655 
78656 C...Double precision and integer declarations.
78657  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78658  IMPLICIT INTEGER(I-N)
78659  INTEGER PYK,PYCHGE,PYCOMP
78660 C...Commonblocks.
78661  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78662  SAVE /pydat1/
78663 C...Local arrays and character variables.
78664  CHARACTER*20 PARM(20)
78665  DOUBLE PRECISION VALUE(20)
78666 
78667 C...Stop program if this routine is ever called.
78668  WRITE(mstu(11),5000)
78669  CALL pystop(5)
78670  parm(20)=parm(1)
78671  value(20)=value(1)
78672 
78673 C...Format for error printout.
78674  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
78675  &1x,'Dummy routine PDFSET in PYTHIA file called instead.'/
78676  &1x,'Execution stopped!')
78677 
78678  RETURN
78679  END
78680 
78681 C*********************************************************************
78682 
78683 C...STRUCTM
78684 C...Dummy routine, to be removed when PDFLIB is to be linked.
78685 
78686  SUBROUTINE structm(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
78687 
78688 C...Double precision and integer declarations.
78689  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78690  IMPLICIT INTEGER(I-N)
78691  INTEGER PYK,PYCHGE,PYCOMP
78692 C...Commonblocks.
78693  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78694  SAVE /pydat1/
78695 C...Local variables
78696  DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
78697 
78698 C...Stop program if this routine is ever called.
78699  WRITE(mstu(11),5000)
78700  CALL pystop(5)
78701  upv=xx+qq
78702  dnv=xx+2d0*qq
78703  usea=xx+3d0*qq
78704  dsea=xx+4d0*qq
78705  str=xx+5d0*qq
78706  chm=xx+6d0*qq
78707  bot=xx+7d0*qq
78708  top=xx+8d0*qq
78709  glu=xx+9d0*qq
78710 
78711 C...Format for error printout.
78712  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
78713  &1x,'Dummy routine STRUCTM in PYTHIA file called instead.'/
78714  &1x,'Execution stopped!')
78715 
78716  RETURN
78717  END
78718 
78719 C*********************************************************************
78720 
78721 C...STRUCTP
78722 C...Dummy routine, to be removed when PDFLIB is to be linked.
78723 
78724  SUBROUTINE structp(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
78725  &BOT,TOP,GLU)
78726 
78727 C...Double precision and integer declarations.
78728  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78729  IMPLICIT INTEGER(I-N)
78730  INTEGER PYK,PYCHGE,PYCOMP
78731 C...Commonblocks.
78732  COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78733  SAVE /pydat1/
78734 C...Local variables
78735  DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
78736  &TOP,GLU
78737 
78738 C...Stop program if this routine is ever called.
78739  WRITE(mstu(11),5000)
78740  CALL pystop(5)
78741  upv=xx+qq2
78742  dnv=xx+2d0*qq2
78743  usea=xx+3d0*qq2
78744  dsea=xx+4d0*qq2
78745  str=xx+5d0*qq2
78746  chm=xx+6d0*qq2
78747  bot=xx+7d0*qq2
78748  top=xx+8d0*qq2
78749  glu=xx+9d0*qq2
78750 
78751 C...Format for error printout.
78752  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
78753  &1x,'Dummy routine STRUCTP in PYTHIA file called instead.'/
78754  &1x,'Execution stopped!')
78755 
78756  RETURN
78757  END
78758 
78759 C*********************************************************************
78760 
78761 C...SUGRA
78762 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78763 
78764  SUBROUTINE sugra(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78765  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78766  IMPLICIT INTEGER(I-N)
78767  REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78768  INTEGER IMODL
78769 C...Commonblocks.
78770  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78771  SAVE /pydat1/
78772 
78773 C...Stop program if this routine is ever called.
78774  WRITE(mstu(11),5000)
78775  CALL pystop(110)
78776 
78777 C...Format for error printout.
78778  5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
78779  &1x,'Dummy routine SUGRA in PYTHIA file called instead.'/
78780  &1x,'Execution stopped!')
78781 
78782  RETURN
78783  END
78784 
78785 C*********************************************************************
78786 
78787 C...VISAJE
78788 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78789 
78790  FUNCTION visaje()
78791  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78792  IMPLICIT INTEGER(I-N)
78793  CHARACTER*40 VISAJE
78794 
78795 C...Commonblocks.
78796  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78797  SAVE /pydat1/
78798 
78799 C...Assign default value.
78800  visaje='Undefined'
78801 
78802 C...Stop program if this routine is ever called.
78803  WRITE(mstu(11),5000)
78804  CALL pystop(110)
78805 
78806 C...Format for error printout.
78807  5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
78808  &1x,'Dummy function VISAJE in PYTHIA file called instead.'/
78809  &1x,'Execution stopped!')
78810 
78811  RETURN
78812  END
78813 
78814 C*********************************************************************
78815 
78816 C...SSMSSM
78817 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78818 
78819  SUBROUTINE ssmssm(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78820  &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78821  &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78822  &IDUM1,IDUM2)
78823  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78824  IMPLICIT INTEGER(I-N)
78825  REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78826  &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78827  &rdum19,rdum20,rdum21,rdum22,rdum23,rdum24,rdum25
78828 C...Commonblocks.
78829  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78830  SAVE /pydat1/
78831 
78832 C...Stop program if this routine is ever called.
78833  WRITE(mstu(11),5000)
78834  CALL pystop(110)
78835 
78836 C...Format for error printout.
78837  5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
78838  &1x,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78839  &1x,'Execution stopped!')
78840  RETURN
78841  END
78842 
78843 C*********************************************************************
78844 
78845 C...FHSETFLAGS
78846 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78847 
78848  SUBROUTINE fhsetflags(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78849  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78850  IMPLICIT INTEGER(I-N)
78851 Cmssmpart = 4 # full MSSM [recommended]
78852 Cfieldren = 0 # MSbar field ren. [strongly recommended]
78853 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78854 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78855 Cp2approx = 0 # no approximation [recommended]
78856 Clooplevel= 2 # include 2-loop corrections
78857 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78858 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78859 
78860 C...Commonblocks.
78861  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78862  SAVE /pydat1/
78863 
78864 C...Stop program if this routine is ever called.
78865  WRITE(mstu(11),5000)
78866  CALL pystop(103)
78867 
78868 C...Format for error printout.
78869  5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
78870  &1x,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78871  &1x,'Execution stopped!')
78872  RETURN
78873  END
78874 
78875 C*********************************************************************
78876 
78877 C...FHSETPARA
78878 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78879 
78880  SUBROUTINE fhsetpara(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78881  & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78882  & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78883  & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78884  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78885  IMPLICIT INTEGER(I-N)
78886 
78887  DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78888  DOUBLE COMPLEX DMU,
78889  & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78890  & DM1, DM2, DM3
78891 
78892 C...Commonblocks.
78893  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78894  SAVE /pydat1/
78895 
78896 C...Stop program if this routine is ever called.
78897  WRITE(mstu(11),5000)
78898  CALL pystop(103)
78899 
78900 C...Format for error printout.
78901  5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
78902  &1x,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78903  &1x,'Execution stopped!')
78904  RETURN
78905  END
78906 
78907 C*********************************************************************
78908 
78909 C...FHHIGGSCORR
78910 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78911 
78912  SUBROUTINE fhhiggscorr(IERR, RMHIGG, SAEFF, UHIGGS)
78913  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78914  IMPLICIT INTEGER(I-N)
78915 
78916 C...FeynHiggs variables
78917  DOUBLE PRECISION RMHIGG(4)
78918  DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78919  DOUBLE COMPLEX DMU,
78920  & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78921  & DM1, DM2, DM3
78922 
78923 C...Commonblocks.
78924  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78925  SAVE /pydat1/
78926 
78927 C...Stop program if this routine is ever called.
78928  WRITE(mstu(11),5000)
78929  CALL pystop(103)
78930 
78931 C...Format for error printout.
78932  5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
78933  &1x,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78934  &1x,'Execution stopped!')
78935  RETURN
78936  END
78937 
78938 C*********************************************************************
78939 
78940 C...PYTAUD
78941 C...Dummy routine, to be replaced by user, to handle the decay of a
78942 C...polarized tau lepton.
78943 C...Input:
78944 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78945 C...IORIG is the position where the mother of the tau is stored;
78946 C... is 0 when the mother is not stored.
78947 C...KFORIG is the flavour of the mother of the tau;
78948 C... is 0 when the mother is not known.
78949 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78950 C... e.g. in B hadron semileptonic decays the W propagator
78951 C... is not explicitly stored but the W code is still unambiguous.
78952 C...Output:
78953 C...NDECAY is the number of decay products in the current tau decay.
78954 C...These decay products should be added to the /PYJETS/ common block,
78955 C...in positions N+1 through N+NDECAY. For each product I you must
78956 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78957 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78958 
78959  SUBROUTINE pytaud(ITAU,IORIG,KFORIG,NDECAY)
78960 
78961 C...Double precision and integer declarations.
78962  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78963  IMPLICIT INTEGER(I-N)
78964  INTEGER PYK,PYCHGE,PYCOMP
78965 C...Commonblocks.
78966  COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78967  COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78968  SAVE /PYJETS/,/PYDAT1/
78969 
78970 C...Stop program if this routine is ever called.
78971 C...You should not copy these lines to your own routine.
78972  ndecay=itau+iorig+kforig
78973  WRITE(mstu(11),5000)
78974  CALL pystop(10)
78975 
78976 C...Format for error printout.
78977  5000 FORMAT(1x,'Error: you did not link your PYTAUD routine ',
78978  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
78979  &1x,'Execution stopped!')
78980 
78981  RETURN
78982  END
78983 
78984 C*********************************************************************
78985 
78986 C...PYTIME
78987 C...Finds current date and time.
78988 C...Since this task is not standardized in Fortran 77, the routine
78989 C...is dummy, to be replaced by the user. Examples are given for
78990 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78991 C...you do not have access to suitable routines.
78992 
78993  SUBROUTINE pytime(IDATI)
78994 
78995 C...Double precision and integer declarations.
78996  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78997  IMPLICIT INTEGER(I-N)
78998  INTEGER PYK,PYCHGE,PYCOMP
78999  CHARACTER*8 ATIME
79000 C...Local array.
79001  INTEGER IDATI(6),IDTEMP(3),IVAL(8)
79002 
79003 C...Example 0: if you do not have suitable routines.
79004  DO 100 j=1,6
79005  idati(j)=0
79006  100 CONTINUE
79007 
79008 C...Example 1: Fortran 90 routine.
79009 C CALL DATE_AND_TIME(VALUES=IVAL)
79010 C IDATI(1)=IVAL(1)
79011 C IDATI(2)=IVAL(2)
79012 C IDATI(3)=IVAL(3)
79013 C IDATI(4)=IVAL(5)
79014 C IDATI(5)=IVAL(6)
79015 C IDATI(6)=IVAL(7)
79016 
79017 C...Example 2: DEC Fortran 77. AIX.
79018 C CALL IDATE(IMON,IDAY,IYEAR)
79019 C IDATI(1)=IYEAR
79020 C IDATI(2)=IMON
79021 C IDATI(3)=IDAY
79022 C CALL ITIME(IHOUR,IMIN,ISEC)
79023 C IDATI(4)=IHOUR
79024 C IDATI(5)=IMIN
79025 C IDATI(6)=ISEC
79026 
79027 C...Example 3: DEC Fortran, IRIX, IRIX64.
79028 C CALL IDATE(IMON,IDAY,IYEAR)
79029 C IDATI(1)=IYEAR
79030 C IDATI(2)=IMON
79031 C IDATI(3)=IDAY
79032 C CALL TIME(ATIME)
79033 C IHOUR=0
79034 C IMIN=0
79035 C ISEC=0
79036 C READ(ATIME(1:2),'(I2)') IHOUR
79037 C READ(ATIME(4:5),'(I2)') IMIN
79038 C READ(ATIME(7:8),'(I2)') ISEC
79039 C IDATI(4)=IHOUR
79040 C IDATI(5)=IMIN
79041 C IDATI(6)=ISEC
79042 
79043 C...Example 4: GNU LINUX libU77, SunOS.
79044 C CALL IDATE(IDTEMP)
79045 C IDATI(1)=IDTEMP(3)
79046 C IDATI(2)=IDTEMP(2)
79047 C IDATI(3)=IDTEMP(1)
79048 C CALL ITIME(IDTEMP)
79049 C IDATI(4)=IDTEMP(1)
79050 C IDATI(5)=IDTEMP(2)
79051 C IDATI(6)=IDTEMP(3)
79052 
79053 C...Common code to ensure right century.
79054  idati(1)=2000+mod(idati(1),100)
79055 
79056  RETURN
79057  END