Analysis Software
Documentation for sPHENIX simulation software
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
pythia-6.4.28.f
Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file pythia-6.4.28.f
1 C*********************************************************************
2 C*********************************************************************
3 C* **
4 C* September 2013 **
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* CERN/PH, CH-1211 Geneva, Switzerland **
28 C* phone +41 - 22 - 767 2447 **
29 C* E-mail peter.skands@cern.ch **
30 C* **
31 C* Several parts are written by Hans-Uno Bengtsson **
32 C* PYSHOW is written together with Mats Bengtsson **
33 C* PYMAEL is written by Emanuel Norrbin **
34 C* advanced popcorn baryon production written by Patrik Eden **
35 C* code for virtual photons mainly written by Christer Friberg **
36 C* code for low-mass strings mainly written by Emanuel Norrbin **
37 C* Bose-Einstein code mainly written by Leif Lonnblad **
38 C* CTEQ parton distributions are by the CTEQ collaboration **
39 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
40 C* SaS photon parton distributions together with Gerhard Schuler **
41 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
42 C* MSSM Higgs mass calculation code by M. Carena, **
43 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
44 C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
45 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
46 C* NRQCD/colour octet production of onium by S. Wolf **
47 C* **
48 C* The latest program version and documentation is found on WWW **
49 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
50 C* **
51 C* Copyright Torbjorn Sjostrand, Lund 2010 **
52 C* **
53 C*********************************************************************
54 C*********************************************************************
55 C *
56 C List of subprograms in order of appearance, with main purpose *
57 C (S = subroutine, F = function, B = block data) *
58 C *
59 C B PYDATA to contain all default values *
60 C S PYCKBD to check that BLOCK DATA has been correctly loaded *
61 C S PYTEST to test the proper functioning of the package *
62 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
63 C *
64 C S PYINIT to administer the initialization procedure *
65 C S PYEVNT to administer the generation of an event *
66 C S PYEVNW ditto, for new multiple interactions scenario *
67 C S PYSTAT to print cross-section and other information *
68 C S PYUPEV to administer the generation of an LHA hard process *
69 C S PYUPIN to provide initialization needed for LHA input *
70 C S PYLHEF to produce a Les Houches Event File from run *
71 C S PYINRE to initialize treatment of resonances *
72 C S PYINBM to read in beam, target and frame choices *
73 C S PYINKI to initialize kinematics of incoming particles *
74 C S PYINPR to set up the selection of included processes *
75 C S PYXTOT to give total, elastic and diffractive cross-sect. *
76 C S PYMAXI to find differential cross-section maxima *
77 C S PYPILE to select multiplicity of pileup events *
78 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
79 C S PYGAGA to handle lepton -> lepton + gamma branchings *
80 C S PYRAND to select subprocess and kinematics for event *
81 C S PYSCAT to set up kinematics and colour flow of event *
82 C S PYEVOL handler for pT-ordered ISR and multiple interactions *
83 C S PYSSPA to simulate initial state spacelike showers *
84 C S PYPTIS to do pT-ordered initial state spacelike showers *
85 C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
86 C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
87 C S PYPTMI to do pT-ordered multiple interactions *
88 C F PYFCMP to give companion quark x*f distribution *
89 C F PYPCMP to calculate momentum integral for companion quarks *
90 C S PYUPRE to rearranges contents of the HEPEUP commonblock *
91 C S PYADSH to administrate sequential final-state showers *
92 C S PYVETO to allow the generation of an event to be aborted *
93 C S PYRESD to perform resonance decays *
94 C S PYMULT to generate multiple interactions - old scheme *
95 C S PYREMN to add on target remnants - old scheme *
96 C S PYMIGN to generate multiple interactions - new scheme *
97 C S PYMIHK to connect colours in mult. int. - new scheme *
98 C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
99 C S PYMIHG to collapse two pairs of LHA1 colour tags. *
100 C S PYMIRM to add on target remnants in mult. int.- new scheme *
101 C S PYFSCR to perform final state colour reconnections - -"- *
102 C S PYDIFF to set up kinematics for diffractive events *
103 C S PYDISG to set up kinematics, remnant and showers for DIS *
104 C S PYDOCU to compute cross-sections and handle documentation *
105 C S PYFRAM to perform boosts between different frames *
106 C S PYWIDT to calculate full and partial widths of resonances *
107 C S PYOFSH to calculate partial width into off-shell channels *
108 C S PYRECO to handle colour reconnection in W+W- events *
109 C S PYKLIM to calculate borders of allowed kinematical region *
110 C S PYKMAP to construct value of kinematical variable *
111 C S PYSIGH to calculate differential cross-sections *
112 C S PYSGQC auxiliary to PYSIGH for QCD processes *
113 C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
114 C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
115 C S PYSGHG auxiliary to PYSIGH for Higgs processes *
116 C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
117 C S PYSGTC auxiliary to PYSIGH for technicolor processes *
118 C S PYSGEX auxiliary to PYSIGH for various exotic processes *
119 C S PYPDFU to evaluate parton distributions *
120 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
121 C S PYPDEL to evaluate electron parton distributions *
122 C S PYPDGA to evaluate photon parton distributions (generic) *
123 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
124 C S PYGVMD to evaluate VMD part of photon parton distributions *
125 C S PYGANO to evaluate anomalous part of photon PDFs *
126 C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
127 C S PYGDIR to evaluate direct contribution to photon PDFs *
128 C S PYPDPI to evaluate pion parton distributions *
129 C S PYPDPR to evaluate proton parton distributions *
130 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
131 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
132 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
133 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
134 C F PYGRVV auxiliary to the PYGRV* routines *
135 C F PYGRVW auxiliary to the PYGRV* routines *
136 C F PYGRVS auxiliary to the PYGRV* routines *
137 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
138 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
139 C S PYPDPO to evaluate old proton parton distributions *
140 C F PYHFTH to evaluate threshold factor for heavy flavour *
141 C S PYSPLI to find flavours left in hadron when one removed *
142 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
143 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
144 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
145 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
146 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
147 C S PYSTBH to evaluate matrix element for t + b + H processes *
148 C S PYTBHB auxiliary to PYSTBH *
149 C S PYTBHG auxiliary to PYSTBH *
150 C S PYTBHQ auxiliary to PYSTBH *
151 C F PYTBHS auxiliary to PYSTBH *
152 C *
153 C S PYMSIN to initialize the supersymmetry simulation *
154 C S PYSLHA to interface to SUSY spectrum and decay calculators *
155 C S PYAPPS to determine MSSM parameters from SUGRA input *
156 C S PYSUGI to determine MSSM parameters using ISASUSY *
157 C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
158 C F PYRNMQ to determine running squark masses *
159 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
160 C S PYINOM to calculate neutralino/chargino mass eigenstates *
161 C F PYRNM3 to determine running M3, gluino mass *
162 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
163 C S PYHGGM to determine Higgs mass spectrum *
164 C S PYSUBH to determine Higgs masses in the MSSM *
165 C S PYPOLE to determine Higgs masses in the MSSM *
166 C S PYRGHM auxiliary to PYPOLE *
167 C S PYGFXX auxiliary to PYRGHM *
168 C F PYFINT auxiliary to PYPOLE *
169 C F PYFISB auxiliary to PYFINT *
170 C S PYSFDC to calculate sfermion decay partial widths *
171 C S PYGLUI to calculate gluino decay partial widths *
172 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
173 C S PYTBBC to calculate 3-body decay of gluino to chargino *
174 C S PYNJDC to calculate neutralino decay partial widths *
175 C S PYCJDC to calculate chargino decay partial widths *
176 C F PYXXZ6 auxiliary for ino 3-body decays *
177 C F PYXXGA auxiliary for ino -> ino + gamma decay *
178 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
179 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
180 C S PYHEXT to calculate non-SM Higgs decay partial widths *
181 C F PYH2XX auxiliary for H -> ino + ino decay *
182 C F PYGAUS to perform Gaussian integration *
183 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
184 C F PYSIMP to perform Simpson integration *
185 C F PYLAMF to evaluate the lambda kinematics function *
186 C S PYTBDY to perform 3-body decay of gauginos *
187 C S PYTECM to calculate techni_rho/omega masses *
188 C S PYXDIN to initialize Universal Extra Dimensions *
189 C S PYUEDC to compute UED mass radiative corrections *
190 C S PYXUED to compute UED cross sections *
191 C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
192 C F PYGRAW to compute UED partial widths to G* *
193 C F PYWDKK to compute UED differential partial widths to G* *
194 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
195 C S PYCMQR auxiliary to PYEICG *
196 C S PYCMQ2 auxiliary to PYEICG *
197 C S PYCDIV auxiliary to PYCMQR *
198 C S PYCSRT auxiliary to PYCMQR *
199 C S PYTHAG auxiliary to PYCMQR *
200 C S PYCBAL auxiliary to PYEICG *
201 C S PYCBA2 auxiliary to PYEICG *
202 C S PYCRTH auxiliary to PYEICG *
203 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
204 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
205 C S PYWIDX to calculate decay widths from within PYWIDT *
206 C S PYRVSF to calculate R-violating sfermion decay widths *
207 C S PYRVNE to calculate R-violating neutralino decay widths *
208 C S PYRVCH to calculate R-violating chargino decay widths *
209 C S PYRVGL to calculate R-violating gluino decay widths *
210 C F PYRVSB auxiliary to PYRVSF *
211 C S PYRVGW to calculate R-Violating 3-body widths *
212 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
213 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
214 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
215 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
216 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
217 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
218 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
219 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
220 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
221 C *
222 C S PY1ENT to fill one entry (= parton or particle) *
223 C S PY2ENT to fill two entries *
224 C S PY3ENT to fill three entries *
225 C S PY4ENT to fill four entries *
226 C S PY2FRM to interface to generic two-fermion generator *
227 C S PY4FRM to interface to generic four-fermion generator *
228 C S PY6FRM to interface to generic six-fermion generator *
229 C S PY4JET to generate a shower from a given 4-parton config *
230 C S PY4JTW to evaluate the weight od a shower history for above *
231 C S PY4JTS to set up the parton configuration for above *
232 C S PYJOIN to connect entries with colour flow information *
233 C S PYGIVE to fill (or query) commonblock variables *
234 C S PYONOF to allow easy control of particle decay modes *
235 C S PYTUNE to select a predefined 'tune' for min-bias and UE *
236 C S PYEXEC to administrate fragmentation and decay chain *
237 C S PYPREP to rearrange showered partons along strings *
238 C S PYSTRF to do string fragmentation of jet system *
239 C S PYJURF to find boost to string junction rest frame *
240 C S PYINDF to do independent fragmentation of one or many jets *
241 C S PYDECY to do the decay of a particle *
242 C S PYDCYK to select parton and hadron flavours in decays *
243 C S PYKFDI to select parton and hadron flavours in fragm *
244 C S PYNMES to select number of popcorn mesons *
245 C S PYKFIN to calculate falvour prod. ratios from input params. *
246 C S PYPTDI to select transverse momenta in fragm *
247 C S PYZDIS to select longitudinal scaling variable in fragm *
248 C S PYSHOW to do m-ordered timelike parton shower evolution *
249 C S PYPTFS to do pT-ordered timelike parton shower evolution *
250 C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
251 C S PYBOEI to include Bose-Einstein effects (crudely) *
252 C S PYBESQ auxiliary to PYBOEI *
253 C F PYMASS to give the mass of a particle or parton *
254 C F PYMRUN to give the running MSbar mass of a quark *
255 C S PYNAME to give the name of a particle or parton *
256 C F PYCHGE to give three times the electric charge *
257 C F PYCOMP to compress standard KF flavour code to internal KC *
258 C S PYERRM to write error messages and abort faulty run *
259 C F PYALEM to give the alpha_electromagnetic value *
260 C F PYALPS to give the alpha_strong value *
261 C F PYANGL to give the angle from known x and y components *
262 C F PYR to provide a random number generator *
263 C S PYRGET to save the state of the random number generator *
264 C S PYRSET to set the state of the random number generator *
265 C S PYROBO to rotate and/or boost an event *
266 C S PYEDIT to remove unwanted entries from record *
267 C S PYLIST to list event record or particle data *
268 C S PYLOGO to write a logo *
269 C S PYUPDA to update particle data *
270 C F PYK to provide integer-valued event information *
271 C F PYP to provide real-valued event information *
272 C S PYSPHE to perform sphericity analysis *
273 C S PYTHRU to perform thrust analysis *
274 C S PYCLUS to perform three-dimensional cluster analysis *
275 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
276 C S PYJMAS to give high and low jet mass of event *
277 C S PYFOWO to give Fox-Wolfram moments *
278 C S PYTABU to analyze events, with tabular output *
279 C *
280 C S PYEEVT to administrate the generation of an e+e- event *
281 C S PYXTEE to give the total cross-section at given CM energy *
282 C S PYRADK to generate initial state photon radiation *
283 C S PYXKFL to select flavour of primary qqbar pair *
284 C S PYXJET to select (matrix element) jet multiplicity *
285 C S PYX3JT to select kinematics of three-jet event *
286 C S PYX4JT to select kinematics of four-jet event *
287 C S PYXDIF to select angular orientation of event *
288 C S PYONIA to perform generation of onium decay to gluons *
289 C *
290 C S PYBOOK to book a histogram *
291 C S PYFILL to fill an entry in a histogram *
292 C S PYFACT to multiply histogram contents by a factor *
293 C S PYOPER to perform operations between histograms *
294 C S PYHIST to print and reset all histograms *
295 C S PYPLOT to print a single histogram *
296 C S PYNULL to reset contents of a single histogram *
297 C S PYDUMP to dump histogram contents onto a file *
298 C *
299 C S PYSTOP routine to handle Fortran STOP condition *
300 C *
301 C S PYKCUT dummy routine for user kinematical cuts *
302 C S PYEVWT dummy routine for weighting events *
303 C S UPINIT dummy routine to initialize user processes *
304 C S UPEVNT dummy routine to generate a user process event *
305 C S UPVETO dummy routine to abort event at parton level *
306 C S PDFSET dummy routine to be removed when using PDFLIB *
307 C S STRUCTM dummy routine to be removed when using PDFLIB *
308 C S STRUCTP dummy routine to be removed when using PDFLIB *
309 C S SUGRA dummy routine to be removed when linking with ISAJET *
310 C F VISAJE dummy functn. to be removed when linking with ISAJET *
311 C S SSMSSM dummy routine to be removed when linking with ISAJET *
312 C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
313 C S FHSETPARA dummy routine -"- FEYNHIGGS *
314 C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
315 C S PYTAUD dummy routine for interface to tau decay libraries *
316 C S PYTIME dummy routine for giving date and time *
317 C *
318 C*********************************************************************
319 
320 C...PYDATA
321 C...Default values for switches and parameters,
322 C...and particle, decay and process data.
323 
324  BLOCK DATA pydata
325 
326 C...Double precision and integer declarations.
327  IMPLICIT DOUBLE PRECISION(a-h, o-z)
328  IMPLICIT INTEGER(i-n)
329  INTEGER pyk,pychge,pycomp
330 C...Commonblocks.
331  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
332  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
333  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
334  common/pydat4/chaf(500,2)
335  CHARACTER chaf*16
336  common/pydatr/mrpy(6),rrpy(100)
337  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
338  common/pypars/mstp(200),parp(200),msti(200),pari(200)
339  common/pyint1/mint(400),vint(400)
340  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
341  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
342  common/pyint4/mwid(500),wids(500,5)
343  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
344  common/pyint6/proc(0:500)
345  CHARACTER proc*28
346  common/pyint7/sigt(0:6,0:6,0:5)
347  common/pymssm/imss(0:99),rmss(0:99)
348  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
349  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
350  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
351  common/pytcsm/itcm(0:99),rtcm(0:99)
352  common/pypued/iued(0:99),rued(0:99)
353  common/pybins/ihist(4),indx(1000),bin(20000)
354  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
355  & au(3,3),ad(3,3),ae(3,3)
356  common/pylh3c/cpro(2),cver(2)
357  CHARACTER cpro*12,cver*12
358  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,/pysubs/,
359  &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,
360  &/pyint6/,/pyint7/,/pymssm/,/pyssmt/,/pymsrv/,/pytcsm/,/pypued/,
361  &/pybins/,/pylh3p/,/pylh3c/
362 
363 C...PYDAT1, containing status codes and most parameters.
364  DATA mstu/
365  & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
366  1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
367  2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
368  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
369  4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
370  5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
371  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
372  7 30*0,
373  1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
374  2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
375  & 80*0/
376  DATA (paru(i),i=1,100)/
377  & 3.141592653589793d0, 6.283185307179586d0,
378  & 0.197327d0, 5.06773d0, 0.389380d0, 2.56819d0, 4*0d0,
379  1 0.001d0, 0.09d0, 0.01d0, 2d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
380  2 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
381  3 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
382  4 2.0d0, 1.0d0, 0.25d0, 2.5d0, 0.05d0,
383  4 0d0, 0d0, 0.0001d0, 0d0, 0d0,
384  5 2.5d0,1.5d0,7.0d0,1.0d0,0.5d0,2.0d0,3.2d0, 0d0, 0d0, 0d0,
385  6 40*0d0/
386  DATA (paru(i),i=101,200)/
387  & 0.00729735d0, 0.232d0, 0.007764d0, 1.0d0, 1.16639d-5,
388  & 0d0, 0d0, 0d0, 0d0, 0d0,
389  1 0.20d0, 0.25d0, 1.0d0, 4.0d0, 10d0, 0d0, 0d0, 0d0, 0d0, 0d0,
390  2 -0.693d0, -1.0d0, 0.387d0, 1.0d0, -0.08d0,
391  2 -1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,
392  3 1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
393  4 5.0d0, 1.0d0, 1.0d0, 0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0,
394  5 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
395  6 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
396  7 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
397  8 1.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,
398  9 0d0, 0d0, 0d0, 0d0, 1.0d0, 0d0, 0d0, 0d0, 0d0, 0d0/
399  DATA mstj/
400  & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
401  1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
402  2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
403  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
404  4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
405  5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
406  6 40*0,
407  & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
408  1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
409  2 80*0/
410  DATA parj/
411  & 0.10d0, 0.30d0, 0.40d0, 0.05d0, 0.50d0,
412  & 0.50d0, 0.50d0, 0.6d0, 1.2d0, 0.6d0,
413  1 0.50d0,0.60d0,0.75d0, 0d0, 0d0, 0d0, 0d0, 1.0d0, 1.0d0, 0d0,
414  2 0.36d0, 1.0d0,0.01d0, 2.0d0,1.0d0,0.4d0, 0d0, 0d0, 0d0, 0d0,
415  3 0.10d0, 1.0d0, 0.8d0, 1.5d0,0d0,2.0d0,0.2d0, 0d0,0.08d0,1d0,
416  4 0.3d0, 0.58d0, 0.5d0, 0.9d0,0.5d0,1.0d0,1.0d0,1.5d0,1d0,10d0,
417  5 0.77d0, 0.77d0, 0.77d0, -0.05d0, -0.005d0,
418  5 0d0, 0d0, 0d0, 1.0d0, 0d0,
419  6 4.5d0, 0.7d0, 0d0,0.003d0, 0.5d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
420  7 10d0, 1000d0, 100d0, 1000d0, 0d0, 0.7d0,10d0, 0d0,0d0,0.5d0,
421  8 0.29d0, 1.0d0, 1.0d0, 0d0, 10d0, 10d0, 0d0, 0d0, 0d0,1d-4,
422  9 0.02d0, 1.0d0, 0.2d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
423  & 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
424  1 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
425  2 1.0d0, 0.25d0,91.187d0,2.489d0, 0.01d0,
426  2 2.0d0, 1.0d0, 0.25d0,0.002d0, 0d0,
427  3 0d0, 0d0, 0d0, 0d0, 0.01d0, 0.99d0, 0d0, 0d0, 0.2d0, 0d0,
428  4 10*0d0,
429  5 10*0d0,
430  6 10*0d0,
431  7 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, -0.693d0,
432  8 -1.0d0, 0.387d0, 1.0d0, -0.08d0, -1.0d0,
433  8 1.0d0, 1.0d0, -0.693d0, -1.0d0, 0.387d0,
434  9 1.0d0, -0.08d0, -1.0d0, 1.0d0, 1.0d0,
435  9 5*0d0/
436 
437 C...PYDAT2, with particle data and flavour treatment parameters.
438  DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
439  &-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,
440  &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,
441  &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,
442  &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,
443  &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,
444  &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,
445  &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,
446  &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,
447  &7*0,3,
448 C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
449  &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
450  &3*-3,0,-3,0,-3,0,-3,
451  &3*0,3,
452  &25*0/
453  DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
454  &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,
455  &-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,
456  &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
457  &83*0,12*1,9*0,2,3*0,25*0/
458  DATA (kchg(i,3),i= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
459  &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,
460  &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,
461  &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,
462  &81*0,21*1,3*0,1,25*0/
463  DATA (kchg(i,4),i= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
464  &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
465  &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
466  &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
467  &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
468  &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
469  &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
470  &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
471  &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
472  &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
473  &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
474  &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
475  &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
476  &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
477  &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
478  &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
479  &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
480  &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
481  &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
482  &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
483  DATA (kchg(i,4),i= 291, 500)/20523,20533,20543,20553,100443,
484  &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
485  &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
486  &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
487  &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
488  &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
489  &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
490  &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
491  &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
492  &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
493  &3000115,3000215,
494  &81*0,
495 C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
496  &6100001,6100002,6100003,6100004,6100005,6100006,
497  &5100001,5100002,5100003,5100004,5100005,5100006,
498  &6100011,6100013,6100015,
499  &5100012,5100011,5100014,5100013,5100016,5100015,
500  &5100021,5100022,5100023,5100024,
501  &25*0/
502  DATA (pmas(i,1),i= 1, 217)/2*0.33d0,0.5d0,1.5d0,4.8d0,175d0,
503  &2*400d0,2*0d0,0.00051d0,0d0,0.10566d0,0d0,1.777d0,0d0,400d0,
504  &5*0d0,91.188d0,80.45d0,115d0,6*0d0,500d0,900d0,500d0,3*300d0,
505  &3*0d0,5000d0,200d0,40*0d0,1d0,2d0,5d0,16*0d0,0.13498d0,0.7685d0,
506  &1.318d0,0.49767d0,0.13957d0,0.7669d0,1.318d0,0.54745d0,0.78194d0,
507  &1.275d0,2*0.49767d0,0.8961d0,1.432d0,0.4936d0,0.8916d0,1.425d0,
508  &0.95777d0,1.0194d0,1.525d0,1.8693d0,2.01d0,2.46d0,1.8645d0,
509  &2.0067d0,2.46d0,1.9685d0,2.1124d0,2.5735d0,2.9798d0,3.09688d0,
510  &3.5562d0,5.2792d0,5.3248d0,5.83d0,5.2789d0,5.3248d0,5.83d0,
511  &5.3693d0,5.4163d0,6.07d0,6.594d0,6.602d0,7.35d0,9.4d0,9.4603d0,
512  &9.9132d0,0d0,0.77133d0,1.234d0,0.57933d0,0.77133d0,0.93957d0,
513  &1.233d0,0.77133d0,0.93827d0,1.232d0,1.231d0,0.80473d0,0.92953d0,
514  &1.19744d0,1.3872d0,1.11568d0,0.80473d0,0.92953d0,1.19255d0,
515  &1.3837d0,1.18937d0,1.3828d0,1.09361d0,1.3213d0,1.535d0,1.3149d0,
516  &1.5318d0,1.67245d0,1.96908d0,2.00808d0,2.4521d0,2.5d0,2.2849d0,
517  &2.4703d0,1.96908d0,2.00808d0,2.4535d0,2.5d0,2.4529d0,2.5d0,
518  &2.4656d0,2.15432d0,2.17967d0,2.55d0,2.63d0,2.55d0,2.63d0,2.704d0,
519  &2.8d0,3.27531d0,3.59798d0,3.65648d0,3.59798d0,3.65648d0,
520  &3.78663d0,3.82466d0,4.91594d0,5.38897d0,5.40145d0,5.8d0,5.81d0,
521  &5.641d0,5.84d0,7.00575d0,5.38897d0,5.40145d0,5.8d0,5.81d0,5.8d0/
522  DATA (pmas(i,1),i= 218, 500)/5.81d0,5.84d0,7.00575d0,5.56725d0,
523  &5.57536d0,5.96d0,5.97d0,5.96d0,5.97d0,6.12d0,6.13d0,7.19099d0,
524  &6.67143d0,6.67397d0,7.03724d0,7.0485d0,7.03724d0,7.0485d0,
525  &7.21101d0,7.219d0,8.30945d0,8.31325d0,10.07354d0,10.42272d0,
526  &10.44144d0,10.42272d0,10.44144d0,10.60209d0,10.61426d0,
527  &11.70767d0,11.71147d0,15.11061d0,0.9835d0,1.231d0,0.9835d0,
528  &1.231d0,1d0,1.17d0,1.429d0,1.29d0,1.429d0,1.29d0,2*1.4d0,2.272d0,
529  &2.424d0,2.272d0,2.424d0,2.5d0,2.536d0,3.4151d0,3.46d0,5.68d0,
530  &5.73d0,5.68d0,5.73d0,5.92d0,5.97d0,7.25d0,7.3d0,9.8598d0,9.875d0,
531  &2*1.23d0,1.282d0,2*1.402d0,1.427d0,2*2.372d0,2.56d0,3.5106d0,
532  &2*5.78d0,6.02d0,7.3d0,9.8919d0,3.686d0,10.0233d0,32*500d0,
533  &3*110d0,350d0,3*210d0,500d0,125d0,250d0,400d0,2*350d0,300d0,
534  &4*400d0,1000d0,3*500d0,1200d0,750d0,2*200d0,7*0d0,3*3.1d0,
535  &3*9.5d0,2*250d0,
536  &81*0,
537 C...UED
538  &586.,588.,586.,588.,586.,586.,6*598.,
539  &3*505.,6*516.,640.,501.,536.,536.,25*0.d0/
540  DATA (pmas(i,2),i= 1, 500)/5*0d0,1.39816d0,16*0d0,2.47813d0,
541  &2.07115d0,0.00367d0,6*0d0,14.54029d0,0d0,16.66099d0,8.38842d0,
542  &3.3752d0,4.17669d0,3*0d0,417.29147d0,0.39162d0,60*0d0,0.151d0,
543  &0.107d0,2*0d0,0.149d0,0.107d0,0d0,0.00843d0,0.185d0,2*0d0,
544  &0.0505d0,0.109d0,0d0,0.0498d0,0.098d0,0.0002d0,0.00443d0,0.076d0,
545  &2*0d0,0.023d0,2*0d0,0.023d0,2*0d0,0.015d0,0.0013d0,0d0,0.002d0,
546  &2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,5*0d0,0.12d0,
547  &3*0d0,0.12d0,2*0d0,2*0.12d0,3*0d0,0.0394d0,4*0d0,0.036d0,0d0,
548  &0.0358d0,2*0d0,0.0099d0,0d0,0.0091d0,74*0d0,0.06d0,0.142d0,
549  &0.06d0,0.142d0,0d0,0.36d0,0.287d0,0.09d0,0.287d0,0.09d0,0.25d0,
550  &0.08d0,0.05d0,0.02d0,0.05d0,0.02d0,0.05d0,0d0,0.014d0,0.01d0,
551  &8*0.05d0,0d0,0.01d0,2*0.4d0,0.025d0,2*0.174d0,0.053d0,3*0.05d0,
552  &0.0009d0,4*0.05d0,3*0d0,19*1d0,0d0,7*1d0,0d0,1d0,0d0,1d0,0d0,
553  &0.0208d0,0.01195d0,0.03705d0,0.09511d0,1.89978d0,1.60746d0,
554  &0.13396d0,200.47294d0,0.02296d0,0.18886d0,94.66794d0,6.08718d0,
555  &0d0,2.17482d0,2.59359d0,2.59687d0,0.42896d0,0.41912d0,0.14153d0,
556  &2*0.00098d0,0.00097d0,26.7245d0,21.74916d0,0.88159d0,0.88001d0,
557  &7*0d0,6*0.01d0,0.25499d0,0.28446d0,131*0d0/
558  DATA (pmas(i,3),i= 1, 500)/5*0d0,13.98156d0,16*0d0,24.78129d0,
559  &20.71149d0,0.03669d0,6*0d0,145.40294d0,0d0,166.60993d0,
560  &83.88423d0,33.75195d0,41.76694d0,3*0d0,4172.91467d0,3.91621d0,
561  &60*0d0,0.4d0,0.25d0,2*0d0,0.4d0,0.25d0,0d0,0.1d0,0.17d0,2*0d0,
562  &0.2d0,0.12d0,0d0,0.2d0,0.12d0,0.002d0,0.015d0,0.2d0,2*0d0,0.12d0,
563  &2*0d0,0.12d0,2*0d0,0.05d0,0.005d0,0d0,0.01d0,2*0d0,0.05d0,2*0d0,
564  &0.05d0,2*0d0,0.05d0,2*0d0,0.05d0,5*0d0,0.14d0,3*0d0,0.14d0,2*0d0,
565  &2*0.14d0,3*0d0,0.04d0,4*0d0,0.035d0,0d0,0.035d0,2*0d0,0.05d0,0d0,
566  &0.05d0,74*0d0,0.05d0,0.25d0,0.05d0,0.25d0,0d0,0.2d0,0.4d0,
567  &0.005d0,0.4d0,0.01d0,0.35d0,0.001d0,0.1d0,0.08d0,0.1d0,0.08d0,
568  &0.1d0,0d0,0.05d0,0.02d0,6*0.1d0,0.05d0,0.1d0,0d0,0.02d0,2*0.3d0,
569  &0.05d0,2*0.3d0,0.02d0,2*0.1d0,0.03d0,0.001d0,4*0.1d0,3*0d0,
570  &19*10d0,0.00001d0,7*10d0,0.00001d0,10d0,0.00001d0,10d0,0.00001d0,
571  &0.20797d0,0.11949d0,0.37048d0,0.95114d0,18.99785d0,16.07463d0,
572  &1.33964d0,450d0,0.22959d0,1.88863d0,360d0,60.8718d0,0d0,
573  &21.74824d0,25.93594d0,25.96873d0,4.28961d0,4.19124d0,1.41528d0,
574  &0.00977d0,0.00976d0,0.00973d0,267.24501d0,217.49162d0,8.81592d0,
575  &8.80013d0,13*0d0,2.54987d0,2.84456d0,
576  &81*0,
577 C...UED
578  &12*0.2d0,9*0.1d0,0.2,10.,0.07,0.3,25*0.d0/
579  DATA (pmas(i,4),i= 1, 500)/12*0d0,658654d0,0d0,0.0872d0,68*0d0,
580  &0.1d0,0.387d0,16*0d0,0.00003d0,2*0d0,15500d0,7804.5d0,5*0d0,
581  &26.762d0,3*0d0,3709d0,5*0d0,0.317d0,2*0d0,0.1244d0,2*0d0,0.14d0,
582  &5*0d0,0.468d0,2*0d0,0.462d0,2*0d0,0.483d0,2*0d0,0.15d0,18*0d0,
583  &44.34d0,0d0,78.88d0,4*0d0,23.96d0,2*0d0,49.1d0,0d0,87.1d0,0d0,
584  &24.6d0,4*0d0,0.0618d0,0.029d0,6*0d0,0.106d0,6*0d0,0.019d0,2*0d0,
585  &7*0.1d0,4*0d0,0.342d0,2*0.387d0,6*0d0,2*0.387d0,6*0d0,0.387d0,
586  &0d0,0.387d0,2*0d0,8*0.387d0,0d0,9*0.387d0,120*0d0,131*0d0/
587 
588  DATA parf/
589  & 0.5d0,0.25d0, 0.5d0,0.25d0, 1d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,
590  1 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
591  2 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
592  3 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
593  4 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
594  5 0.5d0, 0d0, 0.5d0, 0d0, 1d0, 1d0, 0d0, 0d0, 0d0, 0d0,
595  6 0.75d0, 0.5d0, 0d0,0.1667d0,0.0833d0,0.1667d0,0d0,0d0,0d0, 0d0,
596  7 0d0, 0d0, 1d0,0.3333d0,0.6667d0,0.3333d0,0d0,0d0,0d0, 0d0,
597  8 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
598  9 0.0099d0, 0.0056d0, 0.199d0, 1.23d0, 4.17d0, 165d0, 4*0d0,
599  & 0.325d0,0.325d0,0.5d0,1.6d0, 5.0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
600  1 0d0,0.11d0,0.16d0,0.048d0,0.50d0,0.45d0,0.55d0,0.60d0,0d0,0d0,
601  2 0.2d0, 0.1d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
602  3 60*0d0,
603  4 0.2d0, 0.5d0, 8*0d0,
604  5 1800*0d0/
605  DATA ((vckm(i,j),j=1,4),i=1,4)/
606  & 0.95113d0, 0.04884d0, 0.00003d0, 0.00000d0,
607  & 0.04884d0, 0.94940d0, 0.00176d0, 0.00000d0,
608  & 0.00003d0, 0.00176d0, 0.99821d0, 0.00000d0,
609  & 0.00000d0, 0.00000d0, 0.00000d0, 1.00000d0/
610 
611 C...PYDAT3, with particle decay parameters and data.
612  DATA (mdcy(i,1),i= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
613  &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,
614  &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,
615  &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,
616  &81*0,
617 C...UED
618  &5*1,0,5*1,0,13*1,25*0/
619  DATA (mdcy(i,2),i= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
620  &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
621  &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
622  &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
623  &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
624  &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
625  &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
626  &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
627  &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
628  &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
629  &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
630  &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
631  &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
632  &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
633  &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
634  &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
635  &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
636  &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
637  &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
638  &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
639  DATA (mdcy(i,2),i= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
640  &4214,4215,4216,4296,4322,
641  &81*0,
642 C...UED
643  %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
644  &5031,5032,5033,
645  &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
646  &25*0/
647  DATA (mdcy(i,3),i= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
648  &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,
649  &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,
650  &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,
651  &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,
652  &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,
653  &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,
654  &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
655  &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,
656  &3*22,15,12,2*7,7*0,6*1,26,30,
657  &81*0,
658 C...UED
659  &6*2,6*3,9*1,24,1,18,6,25*0/
660  DATA (mdme(i,1),i= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
661  &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,
662  &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,
663  &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,
664  &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,
665  &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
666  &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,
667  &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,
668  &5*-1,3*1,-1,
669  &649*0,
670 C...UED
671  &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
672  &1,24*1,2912*0/
673  DATA (mdme(i,2),i= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
674  &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
675  &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
676  &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
677  &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,
678  &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,
679  &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,
680  &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
681  &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,
682  &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,
683  &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,
684  &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,
685  &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,
686  &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,
687  &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
688  &16*32,
689 C...UED
690  &653*0,30*0,9*0,12*0,37*0,2912*0/
691  DATA (brat(i) ,i= 1, 348)/43*0d0,0.00003d0,0.001765d0,
692  &0.998205d0,35*0d0,1d0,6*0d0,0.1783d0,0.1735d0,0.1131d0,0.2494d0,
693  &0.003d0,0.09d0,0.0027d0,0.01d0,0.0014d0,0.0012d0,2*0.00025d0,
694  &0.0071d0,0.012d0,0.0004d0,0.00075d0,0.00006d0,2*0.00078d0,
695  &0.0034d0,0.08d0,0.011d0,0.0191d0,0.00006d0,0.005d0,0.0133d0,
696  &0.0067d0,0.0005d0,0.0035d0,0.0006d0,0.0015d0,0.00021d0,0.0002d0,
697  &0.00075d0,0.0001d0,0.0002d0,0.0011d0,3*0.0002d0,0.00022d0,
698  &0.0004d0,0.0001d0,2*0.00205d0,2*0.00069d0,0.00025d0,0.00051d0,
699  &0.00025d0,35*0d0,0.153995d0,0.11942d0,0.153984d0,0.119259d0,
700  &0.152272d0,3*0d0,0.033576d0,0.066806d0,0.033576d0,0.066806d0,
701  &0.0335d0,0.066806d0,2*0d0,0.321369d0,0.016494d0,2*0d0,0.016502d0,
702  &0.320615d0,2*0d0,0.00001d0,0.000591d0,6*0d0,2*0.108166d0,
703  &0.108087d0,0d0,0.000001d0,0d0,0.000353d0,0.04359d0,0.795274d0,
704  &4*0d0,0.000339d0,0.095746d0,0d0,0.060724d0,0.003054d0,0.000919d0,
705  &64*0d0,0.145835d0,0.113276d0,0.145835d0,0.113271d0,0.145781d0,
706  &0.049002d0,2*0d0,0.032025d0,0.063642d0,0.032025d0,0.063642d0,
707  &0.032022d0,0.063642d0,8*0d0,0.251225d0,0.0129d0,0.000006d0,0d0,
708  &0.0129d0,0.250764d0,0.00038d0,0d0,0.000008d0,0.000465d0,
709  &0.215418d0,5*0d0,2*0.085312d0,0.08531d0,7*0d0,0.000029d0,
710  &0.000536d0,5*0d0,0.000074d0,0d0,0.000417d0,0.000015d0,0.000061d0/
711  DATA (brat(i) ,i= 349, 655)/0.306789d0,0.689189d0,0d0,0.00289d0,
712  &69*0d0,0.000001d0,0.000072d0,0.001333d0,4*0d0,0.000001d0,
713  &0.000184d0,0d0,0.003108d0,0.000015d0,0.000003d0,2*0d0,0.995284d0,
714  &66*0d0,0.000014d0,0.082234d0,2*0d0,0.000013d0,0.003746d0,0d0,
715  &0.913992d0,18*0d0,3*0.215119d0,0.214724d0,2*0d0,0.06996d0,
716  &0.069959d0,0d0,2*1d0,2*0.08d0,0.76d0,0.08d0,2*0.105d0,0.04d0,
717  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,0.988d0,0.012d0,
718  &0.998739d0,0.00079d0,0.00038d0,0.000046d0,0.000045d0,2*0.34725d0,
719  &0.144d0,0.104d0,0.0245d0,2*0.01225d0,0.0028d0,0.0057d0,0.2112d0,
720  &0.1256d0,2*0.1939d0,2*0.1359d0,0.002d0,0.001d0,0.0006d0,
721  &0.999877d0,0.000123d0,0.99955d0,0.00045d0,2*0.34725d0,0.144d0,
722  &0.104d0,0.049d0,0.0028d0,0.0057d0,0.3923d0,0.321d0,0.2317d0,
723  &0.0478d0,0.0049d0,0.0013d0,0.0003d0,0.0007d0,0.89d0,0.08693d0,
724  &0.0221d0,0.00083d0,2*0.00007d0,0.564d0,0.282d0,0.072d0,0.028d0,
725  &0.023d0,2*0.0115d0,0.005d0,0.003d0,0.6861d0,0.3139d0,2*0.5d0,
726  &0.665d0,0.333d0,0.002d0,0.333d0,0.166d0,0.168d0,0.084d0,0.087d0,
727  &0.043d0,0.059d0,2*0.029d0,0.002d0,0.6352d0,0.2116d0,0.0559d0,
728  &0.0173d0,0.0482d0,0.0318d0,0.666d0,0.333d0,0.001d0,0.332d0,
729  &0.166d0,0.168d0,0.084d0,0.086d0,0.043d0,0.059d0,2*0.029d0,
730  &2*0.002d0,0.437d0,0.208d0,0.302d0,0.0302d0,0.0212d0,0.0016d0/
731  DATA (brat(i) ,i= 656, 831)/0.48947d0,0.34d0,3*0.043d0,0.027d0,
732  &0.0126d0,0.0013d0,0.0003d0,0.00025d0,0.00008d0,0.444d0,2*0.222d0,
733  &0.104d0,2*0.004d0,0.07d0,0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,
734  &0.07d0,0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,0.026d0,0.019d0,
735  &0.066d0,0.041d0,0.045d0,0.076d0,0.0073d0,2*0.0047d0,0.026d0,
736  &0.001d0,0.0006d0,0.0066d0,0.005d0,2*0.003d0,2*0.0006d0,2*0.001d0,
737  &0.006d0,0.005d0,0.012d0,0.0057d0,0.067d0,0.008d0,0.0022d0,
738  &0.027d0,0.004d0,0.019d0,0.012d0,0.002d0,0.009d0,0.0218d0,0.001d0,
739  &0.022d0,0.087d0,0.001d0,0.0019d0,0.0015d0,0.0028d0,0.683d0,
740  &0.306d0,0.011d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,
741  &0.04d0,0.034d0,0.027d0,2*0.002d0,2*0.004d0,2*0.002d0,0.034d0,
742  &0.027d0,2*0.002d0,2*0.004d0,2*0.002d0,0.0365d0,0.045d0,0.073d0,
743  &0.062d0,3*0.021d0,0.0061d0,0.015d0,0.025d0,0.0088d0,0.074d0,
744  &0.0109d0,0.0041d0,0.002d0,0.0035d0,0.0011d0,0.001d0,0.0027d0,
745  &2*0.0016d0,0.0018d0,0.011d0,0.0063d0,0.0052d0,0.018d0,0.016d0,
746  &0.0034d0,0.0036d0,0.0009d0,0.0006d0,0.015d0,0.0923d0,0.018d0,
747  &0.022d0,0.0077d0,0.009d0,0.0075d0,0.024d0,0.0085d0,0.067d0,
748  &0.0511d0,0.017d0,0.0004d0,0.0028d0,0.619d0,0.381d0,0.3d0,0.15d0,
749  &0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.01d0,2*0.02d0,0.03d0,
750  &2*0.005d0,2*0.02d0,0.03d0,2*0.005d0,0.015d0,0.037d0,0.028d0/
751  DATA (brat(i) ,i= 832, 997)/0.079d0,0.095d0,0.052d0,0.0078d0,
752  &4*0.001d0,0.028d0,0.033d0,0.026d0,0.05d0,0.01d0,4*0.005d0,0.25d0,
753  &0.0952d0,0.94d0,0.06d0,2*0.4d0,2*0.1d0,1d0,0.0602d0,0.0601d0,
754  &0.8797d0,0.135d0,0.865d0,0.02d0,0.055d0,2*0.005d0,0.008d0,
755  &0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,
756  &0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,
757  &0.0185d0,0.0135d0,0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,
758  &0.0019d0,0.0025d0,0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,
759  &1d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,
760  &0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,
761  &2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,
762  &0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,0.0185d0,0.0135d0,
763  &0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,0.0019d0,0.0025d0,
764  &0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,1d0,0.3d0,0.15d0,
765  &0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.02d0,0.055d0,
766  &2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,
767  &0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,
768  &0.018d0,0.015d0,0.0185d0,0.0135d0,0.025d0,2*0.0002d0,0.0007d0,
769  &2*0.0004d0,0.0014d0,0.001d0,0.0009d0,0.0025d0,0.4291d0,0.08d0,
770  &0.07d0,0.02d0,0.015d0,0.005d0,1d0,2*0.3d0,2*0.2d0,0.047d0/
771  DATA (brat(i) ,i= 998,1188)/0.122d0,0.006d0,0.012d0,0.035d0,
772  &0.012d0,0.035d0,0.003d0,0.007d0,0.15d0,0.037d0,0.008d0,0.002d0,
773  &0.05d0,0.015d0,0.003d0,0.001d0,0.014d0,0.042d0,0.014d0,0.042d0,
774  &0.24d0,0.065d0,0.012d0,0.003d0,0.001d0,0.002d0,0.001d0,0.002d0,
775  &0.014d0,0.003d0,1d0,2*0.3d0,2*0.2d0,1d0,0.0252d0,0.0248d0,
776  &0.0267d0,0.015d0,0.045d0,0.015d0,0.045d0,0.7743d0,0.029d0,0.22d0,
777  &0.78d0,1d0,0.331d0,0.663d0,0.006d0,0.663d0,0.331d0,0.006d0,1d0,
778  &0.999d0,0.001d0,0.88d0,2*0.06d0,0.639d0,0.358d0,0.002d0,0.001d0,
779  &1d0,0.88d0,2*0.06d0,0.516d0,0.483d0,0.001d0,0.88d0,2*0.06d0,
780  &0.9988d0,0.0001d0,0.0006d0,0.0004d0,0.0001d0,0.667d0,0.333d0,
781  &0.9954d0,0.0011d0,0.0035d0,0.333d0,0.667d0,0.676d0,0.234d0,
782  &0.085d0,0.005d0,2*1d0,0.018d0,2*0.005d0,0.003d0,0.002d0,
783  &2*0.006d0,0.018d0,2*0.005d0,0.003d0,0.002d0,2*0.006d0,0.0066d0,
784  &0.025d0,0.016d0,0.0088d0,2*0.005d0,0.0058d0,0.005d0,0.0055d0,
785  &4*0.004d0,2*0.002d0,2*0.004d0,0.003d0,0.002d0,2*0.003d0,
786  &3*0.002d0,2*0.001d0,0.002d0,2*0.001d0,2*0.002d0,0.0013d0,
787  &0.0018d0,5*0.001d0,4*0.003d0,2*0.005d0,2*0.002d0,2*0.001d0,
788  &2*0.002d0,2*0.001d0,0.2432d0,0.057d0,2*0.035d0,0.15d0,2*0.075d0,
789  &0.03d0,2*0.015d0,2*0.08d0,0.76d0,0.08d0,4*1d0,2*0.08d0,0.76d0,
790  &0.08d0,1d0,2*0.5d0,1d0,2*0.5d0,2*0.08d0,0.76d0,0.08d0,1d0/
791  DATA (brat(i) ,i=1189,1381)/2*0.08d0,0.76d0,3*0.08d0,0.76d0,
792  &3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,
793  &3*0.08d0,0.76d0,0.08d0,2*1d0,2*0.105d0,0.04d0,0.0077d0,0.02d0,
794  &0.0235d0,0.0285d0,0.0435d0,0.0011d0,0.0022d0,0.0044d0,0.4291d0,
795  &0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,
796  &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,
797  &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,0.04d0,
798  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,
799  &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,
800  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,1d0,2*0.105d0,
801  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
802  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
803  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,
804  &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,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  DATA (brat(i) ,i=1382,1582)/0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
812  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
813  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
814  &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,
815  &0.015d0,0.005d0,2*0.105d0,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,4*1d0,0.52d0,0.26d0,0.11d0,2*0.055d0,0.333d0,
820  &0.334d0,0.333d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,
821  &0.11d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,0.11d0,
822  &0.36d0,0.18d0,0.03d0,2*0.015d0,2*0.2d0,4*0.25d0,0.667d0,0.333d0,
823  &0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.007d0,
824  &0.993d0,1d0,0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,
825  &0.667d0,0.333d0,8*0.5d0,0.02d0,0.98d0,1d0,4*0.5d0,3*0.146d0,
826  &3*0.05d0,0.15d0,2*0.05d0,4*0.024d0,0.066d0,0.667d0,0.333d0,
827  &0.667d0,0.333d0,4*0.25d0,0.667d0,0.333d0,0.667d0,0.333d0,2*0.5d0,
828  &0.273d0,0.727d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.35d0,
829  &0.65d0,2*0.0083d0,0.1866d0,0.324d0,0.184d0,0.027d0,0.001d0,
830  &0.093d0,0.087d0,0.078d0,0.0028d0,3*0.014d0,0.008d0,0.024d0/
831  DATA (brat(i) ,i=1583,4150)/0.008d0,0.024d0,0.425d0,0.02d0,
832  &0.185d0,0.088d0,0.043d0,0.067d0,0.066d0,2404*0d0,0.024396d0,
833  &0.045285d0,0.83119d0,2*0d0,0.000349d0,0.09878d0,0d0,0.019884d0,
834  &0.02341d0,0.362776d0,0.550787d0,2*0d0,0.000152d0,0.042991d0,
835  &0.013695d0,0.025421d0,0.466595d0,2*0d0,0.000196d0,0.055451d0,
836  &0.438642d0,0.445781d0,0d0,0.554219d0,4*0.00335d0,0.522257d0,
837  &0.464343d0,6*0d0,1d0,6*0d0,1d0,4*0.013853d0,0.562703d0,
838  &0.376702d0,0.00518d0,4*0.006254d0,0.974985d0,7*0d0,4*0.148299d0,
839  &0.015351d0,0d0,0.182109d0,0.167099d0,0.042247d0,0.850973d0,
840  &0.005411d0,0.045025d0,0.098591d0,0.849898d0,0.021617d0,
841  &0.030018d0,0.098466d0,0.294448d0,0.10945d0,0.596102d0,0.389906d0,
842  &0.610094d0,3*0.0633d0,0.063299d0,0.063295d0,0.056281d0,2*0d0,
843  &6*0.020495d0,2*0d0,0.327919d0,0.04099d0,0.045236d0,0.090112d0,
844  &0.19874d0,0.010204d0,0.000003d0,0.010205d0,0.198356d0,0.000151d0,
845  &0.000006d0,0.000367d0,0.081967d0,0.19874d0,0.010204d0,0.000003d0,
846  &0.010205d0,0.198356d0,0.000151d0,0.000006d0,0.000367d0,
847  &0.081967d0,4*0d0,0.198776d0,0.010206d0,0.000003d0,0.010207d0,
848  &0.19839d0,0.000151d0,0.000006d0,0.000367d0,0.081893d0,0.198776d0,
849  &0.010206d0,0.000003d0,0.010207d0,0.19839d0,0.000151d0,0.000006d0,
850  &0.000367d0,0.081893d0,4*0d0,0.199344d0,0.010234d0,0.000003d0/
851  DATA (brat(i) ,i=4151,4281)/0.010236d0,0.198928d0,0.000149d0,
852  &0.000006d0,0.000368d0,0.080733d0,0.199344d0,0.010234d0,
853  &0.000003d0,0.010236d0,0.198928d0,0.000149d0,0.000006d0,
854  &0.000368d0,0.080733d0,4*0d0,0.184738d0,0.104588d0,0.184738d0,
855  &0.104587d0,0.184731d0,0.09582d0,0.022902d0,0.008429d0,0.015602d0,
856  &0.022902d0,0.008429d0,0.015602d0,0.022902d0,0.008429d0,
857  &0.015602d0,0.28959d0,0.01487d0,0.000008d0,0.01487d0,0.289061d0,
858  &0.000492d0,0.000009d0,0.000536d0,0.27911d0,2*0.037151d0,
859  &0.03715d0,0.090266d0,2*0.001805d0,0.090266d0,0.001805d0,
860  &0.812263d0,0.00179d0,0.090428d0,0.001809d0,0.001808d0,0.090428d0,
861  &0.001808d0,0.81372d0,0d0,6*1d0,0.095602d0,2*0.338272d0,
862  &0.156896d0,0.019193d0,0.017993d0,0.001168d0,0.001462d0,
863  &0.009608d0,0.003306d0,0.002132d0,0.003127d0,0.002132d0,
864  &0.003127d0,0.00213d0,3*0d0,0.001411d0,0.00045d0,0.001411d0,
865  &0.00045d0,0.001411d0,0.00045d0,2*0d0,0.097996d0,0.399787d0,
866  &0.262464d0,0.185427d0,0.022683d0,0.007648d0,0.004259d0,
867  &0.005925d0,0.000304d0,2*0d0,0.000304d0,0.005914d0,0.000002d0,
868  &2*0d0,0.000011d0,0.001258d0,5*0d0,3*0.002005d0,0d0,0.272178d0,
869  &0.022112d0,0.255165d0,0.015534d0,2*0.108965d0,0.031557d0,
870  &0.005562d0,0.044965d0,0.004674d0,0.007637d0,0.020597d0/
871  DATA (brat(i) ,i=4282,8000)/0.007636d0,0.020595d0,0.007616d0,
872  &3*0d0,0.017298d0,0.004782d0,0.017298d0,0.004782d0,0.017297d0,
873  &0.004782d0,2*0d0,0.055332d0,2*0.319757d0,0.121576d0,2*0.001556d0,
874  &4*0d0,0.0277d0,0.021481d0,0.027699d0,0.021477d0,0.027658d0,3*0d0,
875  &0.006071d0,0.01208d0,0.006071d0,0.01208d0,0.006069d0,0.01208d0,
876  &2*0d0,0.035891d0,0.209476d0,0.129084d0,0.286631d0,0.10742d0,
877  &0.109486d0,4*0d0,0.035282d0,0.001812d0,2*0d0,0.001812d0,
878  &0.035215d0,0.000021d0,0d0,0.000001d0,0.000065d0,0.011965d0,5*0d0,
879  &2*0.011947d0,0.011946d0,0d0,
880  &649*0.d0,
881 C....UED
882  &0.001d0,0.999d0,0.001d0,0.999d0,0.001d0,0.999d0,
883  &0.001d0,0.999d0,0.001d0,0.999d0,0.001d0,0.999d0,
884  &0.33d0,0.66d0,0.01d0,0.33d0,0.66d0,0.01d0,0.33d0,0.66d0,0.01d0,
885  &0.33d0,0.66d0,0.01d0,0.98d0,0.d0,0.02d0,0.33d0,0.66d0,0.01d0,
886  &9*1.d0,
887  &24*0.0416667,
888  &1.,
889  &3*0.d0,6*0.08333d0,
890  &3*0.d0,6*0.08333d0,
891  &6*0.166667d0,
892  &2912*0.d0/
893  DATA (kfdp(i,1),i= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
894  &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
895  &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
896  &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
897  &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
898  &-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,
899  &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
900  &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
901  &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
902  &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
903  &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
904  &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
905  &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
906  &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
907  &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
908  &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
909  &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
910  &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
911  &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
912  &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
913  DATA (kfdp(i,1),i= 378, 580)/1000002,-1000002,1000003,2000003,
914  &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
915  &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
916  &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
917  &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
918  &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
919  &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
920  &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
921  &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
922  &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
923  &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
924  &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
925  &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
926  &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
927  &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
928  &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
929  &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
930  &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
931  &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
932  &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
933  DATA (kfdp(i,1),i= 581, 992)/2*211,213,113,221,223,321,211,331,
934  &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
935  &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
936  &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
937  &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
938  &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
939  &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
940  &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
941  &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
942  &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
943  &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
944  &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
945  &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
946  &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
947  &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
948  &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
949  &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
950  &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
951  &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
952  &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
953  DATA (kfdp(i,1),i= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
954  &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
955  &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
956  &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
957  &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
958  &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
959  &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
960  &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
961  &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
962  &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
963  &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
964  &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
965  &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
966  &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
967  &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
968  &2*-2,2*-4,-2,-4,-12,-14,-16,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,-12,-14,-16,2*-2,2*-4,-2,
970  &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
971  &-14,-16,2*-2,2*-4,-2,-4,-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  DATA (kfdp(i,1),i=1403,1713)/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,221,223,221,
976  &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
977  &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
978  &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
979  &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
980  &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
981  &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
982  &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
983  &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
984  &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
985  &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
986  &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
987  &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
988  &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
989  &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
990  &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
991  &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
992  &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
993  DATA (kfdp(i,1),i=1714,1984)/2000003,1000003,2000003,1000021,
994  &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
995  &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
996  &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
997  &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
998  &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
999  &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1000  &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
1001  &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1002  &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
1003  &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1004  &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
1005  &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1006  &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
1007  &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1008  &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
1009  &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
1010  &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
1011  &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
1012  &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
1013  DATA (kfdp(i,1),i=1985,2321)/-1000003,2000003,-2000003,1000004,
1014  &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1015  &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
1016  &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1017  &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
1018  &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
1019  &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
1020  &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
1021  &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
1022  &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
1023  &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
1024  &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
1025  &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
1026  &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
1027  &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
1028  &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
1029  &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
1030  &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
1031  &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
1032  &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
1033  DATA (kfdp(i,1),i=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1034  &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1035  &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
1036  &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
1037  &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
1038  &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
1039  &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1040  &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1041  &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1042  &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1043  &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1044  &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1045  &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1046  &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1047  &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1048  &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1049  &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1050  &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1051  &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1052  &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
1053  DATA (kfdp(i,1),i=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1054  &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1055  &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1056  &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1057  &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1058  &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1059  &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1060  &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1061  &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1062  &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1063  &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1064  &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1065  &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1066  &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1067  &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1068  &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1069  &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1070  &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1071  &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1072  &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1073  DATA (kfdp(i,1),i=2893,3182)/2000001,-2000001,1000002,-1000002,
1074  &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1075  &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1076  &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1077  &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1078  &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1079  &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1080  &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1081  &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1082  &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1083  &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1084  &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1085  &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1086  &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1087  &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1088  &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1089  &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1090  &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1091  &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1092  &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1093  DATA (kfdp(i,1),i=3183,3459)/1000024,-1000024,1000037,-1000037,
1094  &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1095  &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1096  &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1097  &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1098  &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1099  &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1100  &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1101  &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1102  &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1103  &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1104  &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1105  &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1106  &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1107  &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1108  &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1109  &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1110  &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1111  &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1112  &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1113  DATA (kfdp(i,1),i=3460,3782)/2000012,-1000011,-2000011,1000014,
1114  &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1115  &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1116  &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1117  &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1118  &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1119  &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1120  &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1121  &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1122  &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1123  &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1124  &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1125  &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1126  &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1127  &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1128  &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1129  &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1130  &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1131  &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1132  &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1133  DATA (kfdp(i,1),i=3783,4156)/1000039,1000024,1000037,1000022,
1134  &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1135  &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1136  &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1137  &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1138  &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1139  &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1140  &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1141  &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1142  &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1143  &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1144  &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1145  &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1146  &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1147  &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1148  &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1149  &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,
1150  &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1151  &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1152  &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
1153  &9*15/
1154  DATA (kfdp(i,1),i=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
1155  &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1156  &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1157  &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1158  &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1159  &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1160  &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1161  &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1162  &-11,-13,-15,-17,
1163  &649*0,
1164 C...UED
1165  &5100023,5100022,5100023,5100022,5100023,5100022,
1166  &5100023,5100022,5100023,5100022,5100023,5100022,
1167  &5100023,-5100024,5100022,5100023,5100024,5100022,
1168  &5100023,-5100024,5100022,5100023,5100024,5100022,
1169  &5100023,-5100024,5100022,5100023,5100024,5100022,
1170  &9*5100022,
1171  &6100001,6100002,6100003,6100004,6100005,6100006,
1172  &5100001,5100002,5100003,5100004,5100005,5100006,
1173  &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1174  &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1175  &39,
1176  &6100011,6100013,6100015,
1177  &5100011,5100013,5100015,
1178  %5100012,5100014,5100016,
1179  &-6100011,-6100013,-6100015,
1180  &-5100011,-5100013,-5100015,
1181  %-5100012,-5100014,-5100016,
1182  &-5100011,-5100013,-5100015,
1183  &5100012,5100014,5100016,
1184  &2912*0/
1185  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,
1186  &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,
1187  &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,
1188  &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1189  &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1190  &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1191  &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1192  &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1193  &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1194  &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1195  &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1196  &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1197  &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1198  &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1199  &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1200  &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1201  &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1202  &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1203  &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1204  &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/
1205  DATA (kfdp(i,2),i= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1206  &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1207  &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1208  &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1209  &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1210  &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1211  &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1212  &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1213  &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1214  &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1215  &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1216  &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1217  &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1218  &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1219  &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1220  &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1221  &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1222  &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1223  &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1224  &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1225  DATA (kfdp(i,2),i= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1226  &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1227  &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1228  &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1229  &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1230  &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1231  &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1232  &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1233  &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1234  &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1235  &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1236  &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1237  &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1238  &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1239  &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1240  &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1241  &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1242  &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1243  &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1244  &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1245  DATA (kfdp(i,2),i= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1246  &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1247  &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1248  &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1249  &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1250  &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1251  &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1252  &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1253  &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1254  &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1255  &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1256  &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1257  &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1258  &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1259  &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1260  &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1261  &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,
1262  &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,
1263  &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,
1264  &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/
1265  DATA (kfdp(i,2),i=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1266  &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,
1267  &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,
1268  &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,
1269  &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1270  &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1271  &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1272  &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1273  &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1274  &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1275  &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1276  &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1277  &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1278  &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,
1279  &-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,
1280  &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,
1281  &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,
1282  &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,
1283  &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,
1284  &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/
1285  DATA (kfdp(i,2),i=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1286  &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,
1287  &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1288  &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,
1289  &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1290  &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,
1291  &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,
1292  &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,
1293  &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,
1294  &-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,
1295  &-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,
1296  &-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,
1297  &-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,
1298  &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1299  &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1300  &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1301  &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,
1302  &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,
1303  &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,
1304  &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/
1305  DATA (kfdp(i,2),i=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1306  &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1307  &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1308  &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1309  &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1310  &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1311  &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1312  &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1313  &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,
1314  &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,
1315  &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,
1316  &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,
1317  &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1318  &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1319  &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,
1320  &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1321  &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1322  &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1323  &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1324  &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1325  DATA (kfdp(i,2),i=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1326  &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1327  &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,
1328  &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,
1329  &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1330  &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1331  &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1332  &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1333  &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1334  &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1335  &-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,
1336  &-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,
1337  &-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,
1338  &-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,
1339  &-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,
1340  &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1341  &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,
1342  &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1343  &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1344  &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1345  DATA (kfdp(i,2),i=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1346  &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1347  &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1348  &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1349  &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,
1350  &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,
1351  &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,
1352  &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,
1353  &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1354  &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1355  &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1356  &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1357  &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1358  &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1359  &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1360  &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1361  &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1362  &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1363  &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1364  &-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/
1365  DATA (kfdp(i,2),i=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1366  &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,
1367  &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,
1368  &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,
1369  &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,
1370  &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,
1371  &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,
1372  &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,
1373  &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1374  &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,
1375  &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,
1376  &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1377  &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1378  &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1379  &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1380  &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1381  &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1382  &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,
1383  &3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11,
1384  &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1385  DATA (kfdp(i,2),i=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1386  &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1387  &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1388  &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1389  &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1390  &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1391  &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1392  &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1393  &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1394  &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1395  &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1396  &649*0,
1397 C...UED
1398  &1,1,2,2,3,3,4,4,5,5,6,6,
1399  &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1400  &11,13,15,12,11,14,13,16,15,
1401  &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1402  &1,2,3,4,5,6,1,2,3,4,5,6,
1403  &22,
1404  &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1405  &11,13,15,11,13,15,12,14,16,
1406  &12,14,16,-11,-13,-15,
1407  &2912*0/
1408  DATA (kfdp(i,3),i= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1409  &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1410  &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1411  &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1412  &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1413  &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1414  &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1415  &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1416  &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1417  &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1418  &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1419  &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1420  &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1421  &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1422  &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1423  &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1424  &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1425  &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1426  &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1427  &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1428  DATA (kfdp(i,3),i=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1429  &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1430  &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1431  &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,
1432  &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,
1433  &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,
1434  &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,
1435  &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,
1436  &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,
1437  &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1438  &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1439  &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1440  &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,
1441  &-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,
1442  &-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,
1443  &-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,
1444  &-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,
1445  &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1446  &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1447  &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1448  DATA (kfdp(i,3),i=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1449  &-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,
1450  &-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,
1451  &-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,
1452  &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1453  &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1454  &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1455  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1456  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1457  &-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,
1458  &-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,
1459  &-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,
1460  &-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,
1461  &-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,
1462  &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1463  &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1464  &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1465  &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,
1466  &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,
1467  &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/
1468  DATA (kfdp(i,3),i=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1469  &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,
1470  &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1471  &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1472  &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1473  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1474  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1475  &-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,
1476  &-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,
1477  &-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,
1478  &-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,
1479  &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1480  &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1481  &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1482  &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1483  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1484  &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1485  &-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,
1486  &-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,
1487  &-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/
1488  DATA (kfdp(i,3),i=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1489  &-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,
1490  &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1491  &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,
1492  &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1493  &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1494  &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1495  &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,
1496  &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,
1497  &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,
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,3,-3,5,-5,
1499  &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,
1500  &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1501  &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1502  &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1503  DATA (kfdp(i,4),i= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1504  &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1505  &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1506  &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1507  &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1508  &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1509  &-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,
1510  &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1511  &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,
1512  &162*81,31*0,-211,111,6516*0/
1513  DATA (kfdp(i,5),i= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1514  &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1515  &3*111,-211,111,7193*0/
1516 
1517 C...PYDAT4, with particle names (character strings).
1518  DATA (chaf(i,1),i= 1, 202)/'d','u','s','c','b','t','b''','t''',
1519  &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1520  &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1521  &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1522  &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1523  &'junction',' ','system','cluster','string','indep.','CMshower',
1524  &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1525  &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1526  &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1527  &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1528  &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1529  &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1530  &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1531  &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1532  &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1533  &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1534  &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1535  &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1536  &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1537  &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1538  DATA (chaf(i,1),i= 203, 332)/'Omega_cc+','Omega*_cc+',
1539  &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1540  &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1541  &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1542  &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1543  &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1544  &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1545  &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1546  &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1547  &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1548  &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1549  &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1550  &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1551  &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1552  &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1553  &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1554  &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1555  &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1556  &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1557  &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1558  DATA (chaf(i,1),i= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1559  &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1560  &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1561  &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1562  &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1563  &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1564  &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1565  &81*' ',
1566 C...UED
1567  &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1568  &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1569  &'e*_S-','mu*_S-','tau*_S-',
1570  &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1571  &'g*','gamma*','Z*0','W*+',25*' '/
1572  DATA (chaf(i,2),i= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1573  &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1574  &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1575  &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1576  &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1577  &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1578  &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1579  &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1580  &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1581  &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1582  &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1583  &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1584  &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1585  &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1586  &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1587  &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1588  &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1589  &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1590  &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1591  &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1592  DATA (chaf(i,2),i= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1593  &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1594  &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1595  &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1596  &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1597  &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1598  &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1599  &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1600  &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1601  &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1602  &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1603  &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1604  &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1605  &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1606  &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1607  &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1608  &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1609  &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1610  &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1611  &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1612  DATA (chaf(i,2),i= 326, 500)/'~nu_muRbar','~tau_2+',
1613  &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1614  &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1615  &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1616  &81*' ',
1617 C...UED
1618  &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1619  &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1620  &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1621  &'nu*_eDbar','e*_Dbar+',
1622  &'nu*_muDbar','mu*_Dbar+',
1623  &'nu*_tauDbar','tau*_Dbar+',
1624  &'g*','gamma*','Z*0','W*-',25*' '/
1625 
1626 C...PYDATR, with initial values for the random number generator.
1627  DATA mrpy/19780503,0,0,97,33,0/
1628 
1629 C...Default values for allowed processes and kinematics constraints.
1630  DATA msel/1/
1631  DATA msub/500*0/
1632  DATA ((kfin(i,j),j=-40,40),i=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1633  &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,
1634  &6*1,4*0,4*1,16*0/
1635  DATA ckin/
1636  & 2.0d0, -1.0d0, 0.0d0, -1.0d0, 1.0d0,
1637  & 1.0d0, -10d0, 10d0, -40d0, 40d0,
1638  1 -40d0, 40d0, -40d0, 40d0, -40d0,
1639  1 40d0, -1.0d0, 1.0d0, -1.0d0, 1.0d0,
1640  2 0.0d0, 1.0d0, 0.0d0, 1.0d0, -1.0d0,
1641  2 1.0d0, -1.0d0, 1.0d0, 0d0, 0d0,
1642  3 2.0d0, -1.0d0, 0d0, 0d0, 0.0d0,
1643  3 -1.0d0, 0.0d0, -1.0d0, 4.0d0, -1.0d0,
1644  4 12.0d0, -1.0d0, 12.0d0, -1.0d0, 12.0d0,
1645  4 -1.0d0, 12.0d0, -1.0d0, 0d0, 0d0,
1646  5 0.0d0, -1.0d0, 0.0d0, -1.0d0, 0.0d0,
1647  5 -1.0d0, 0d0, 0d0, 0d0, 0d0,
1648  6 0.0001d0, 0.99d0, 0.0001d0, 0.99d0, 0d0,
1649  6 -1d0, 0d0, -1d0, 0d0, -1d0,
1650  7 0d0, -1d0, 0.0001d0, 0.99d0, 0.0001d0,
1651  7 0.99d0, 2d0, -1d0, 0d0, 0d0,
1652  8 120*0d0/
1653 
1654 C...Default values for main switches and parameters. Reset information.
1655  DATA (mstp(i),i=1,100)/
1656  & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1657  1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1658  2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1659  3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1660  4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1661  5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1662  6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1663  7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1664  8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1665  9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1666  DATA (mstp(i),i=101,200)/
1667  & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1668  1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1669  2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1670  3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1671  4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1672  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1673  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1674  7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1675  8 6, 428, 2013, 9, 5, 0, 0, 0, 0, 0,
1676  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1677  DATA (parp(i),i=1,100)/
1678  & 0.25d0, 10d0, 8*0d0,
1679  1 0d0, 0d0, 1.0d0, 0.01d0, 0.5d0, 1.0d0, 1.0d0, 0.4d0, 2*0d0,
1680  2 10*0d0,
1681  3 1.5d0,2.0d0,0.075d0,1.0d0,0.2d0,0d0,1.0d0,0.70d0,0.006d0,0d0,
1682  4 0.02d0,2.0d0,0.10d0,1000d0,2054d0,123d0,246d0,50d0,0d0,0.054d0,
1683  5 10*0d0,
1684  6 0.25d0, 1.0d0,0.25d0, 1.0d0, 2.0d0,1d-3, 4.0d0,1d-3,2*0d0,
1685  7 4.0d0, 0.25d0, 5*0d0, 0.025d0, 2.0d0, 0.1d0,
1686  8 1.90d0, 2.0d0, 0.5d0, 0.4d0, 0.90d0,
1687  8 0.95d0, 0.7d0, 0.5d0, 1800d0, 0.25d0,
1688  9 2.0d0,0.40d0,5.0d0,1.0d0,0.0d0,3.0d0,1.0d0,0.75d0,1.0d0,5.0d0/
1689  DATA (parp(i),i=101,200)/
1690  & 0.5d0, 0.28d0, 1.0d0, 0.8d0, 0d0, 0d0, 0d0, 0d0, 0d0, 1d0,
1691  1 2.0d0, 3*0d0, 1.5d0, 0.5d0, 0.6d0, 2.5d0, 2.0d0, 1.0d0,
1692  2 1.0d0, 0.4d0, 8*0d0,
1693  3 0.01d0, 9*0d0,
1694  4 1.16d0, 0.0119d0, 0.01d0, 0.01d0, 0.05d0,
1695  4 9.28d0, 0.15d0, 0.02d0, 0.48d0, 0.09d0,
1696  5 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
1697  6 2.20d0, 23.6d0, 18.4d0, 11.5d0, 0.5d0, 0d0, 0d0, 0d0, 2*0d0,
1698  7 0d0, 0d0, 0d0, 1.0d0, 6*0d0,
1699  8 0.1d0, 0.01d0, 0.01d0, 0.01d0, 0.1d0, 0.01d0, 0.01d0, 0.01d0,
1700  8 0.3d0, 0.64d0,
1701  9 0.64d0, 5.0d0, 1.0d4, 1.0d4, 6*0d0/
1702  DATA msti/200*0/
1703  DATA pari/200*0d0/
1704  DATA mint/400*0/
1705  DATA vint/400*0d0/
1706 
1707 C...Constants for the generation of the various processes.
1708  DATA (iset(i),i=1,100)/
1709  & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1710  1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1711  2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1712  3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1713  4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1714  5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1715  6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1716  7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1717  8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1718  9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1719  DATA (iset(i),i=101,200)/
1720  & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1721  1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1722  2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1723  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1724  4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1725  5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1726  6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1727  7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1728  8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1729  9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1730  DATA (iset(i),i=201,300)/
1731  & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1732  1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1733  2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1734  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1735  4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1736  5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1737  6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1738  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1739  8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1740  9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1741  DATA (iset(i),i=301,500)/
1742  & 2, 9*-2, 9*2, 21*-2,
1743  4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1744  5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1745  6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1746  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1747  8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1748  9 1, 1, 2, 2, 2, 5*-2,
1749  & 5, 5, 18*-2,
1750  2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1751  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1752  6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1753  7 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1754  8 2, 2, 18*-2/
1755  DATA ((kfpr(i,j),j=1,2),i=1,50)/
1756  & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1757  & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1758  1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1759  1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1760  2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1761  2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1762  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1763  3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1764  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1765  4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1766  DATA ((kfpr(i,j),j=1,2),i=51,100)/
1767  5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1768  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1769  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1770  6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1771  7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1772  7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1773  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1774  8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1775  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1776  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1777  DATA ((kfpr(i,j),j=1,2),i=101,150)/
1778  & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1779  & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1780  1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1781  1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1782  2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1783  2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1784  3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1785  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1786  4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1787  4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1788  DATA ((kfpr(i,j),j=1,2),i=151,200)/
1789  5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1790  5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1791  6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1792  6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1793  7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1794  7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1795  8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1796  8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1797  9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1798  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1799  DATA ((kfpr(i,j),j=1,2),i=201,240)/
1800  & 1000011, 1000011, 2000011, 2000011, 1000011,
1801  & 2000011, 1000013, 1000013, 2000013, 2000013,
1802  & 1000013, 2000013, 1000015, 1000015, 2000015,
1803  & 2000015, 1000015, 2000015, 1000011, 1000012,
1804  1 1000015, 1000016, 2000015, 1000016, 1000012,
1805  1 1000012, 1000016, 1000016, 0, 0,
1806  1 1000022, 1000022, 1000023, 1000023, 1000025,
1807  1 1000025, 1000035, 1000035, 1000022, 1000023,
1808  2 1000022, 1000025, 1000022, 1000035, 1000023,
1809  2 1000025, 1000023, 1000035, 1000025, 1000035,
1810  2 1000024, 1000024, 1000037, 1000037, 1000024,
1811  2 1000037, 1000022, 1000024, 1000023, 1000024,
1812  3 1000025, 1000024, 1000035, 1000024, 1000022,
1813  3 1000037, 1000023, 1000037, 1000025, 1000037,
1814  3 1000035, 1000037, 1000021, 1000022, 1000021,
1815  3 1000023, 1000021, 1000025, 1000021, 1000035/
1816  DATA ((kfpr(i,j),j=1,2),i=241,280)/
1817  4 1000021, 1000024, 1000021, 1000037, 1000021,
1818  4 1000021, 1000021, 1000021, 0, 0,
1819  4 1000002, 1000022, 2000002, 1000022, 1000002,
1820  4 1000023, 2000002, 1000023, 1000002, 1000025,
1821  5 2000002, 1000025, 1000002, 1000035, 2000002,
1822  5 1000035, 1000001, 1000024, 2000005, 1000024,
1823  5 1000001, 1000037, 2000005, 1000037, 1000002,
1824  5 1000021, 2000002, 1000021, 0, 0,
1825  6 1000006, 1000006, 2000006, 2000006, 1000006,
1826  6 2000006, 1000006, 1000006, 2000006, 2000006,
1827  6 0, 0, 0, 0, 0,
1828  6 0, 0, 0, 0, 0,
1829  7 1000002, 1000002, 2000002, 2000002, 1000002,
1830  7 2000002, 1000002, 1000002, 2000002, 2000002,
1831  7 1000002, 2000002, 1000002, 1000002, 2000002,
1832  7 2000002, 1000002, 1000002, 2000002, 2000002/
1833  DATA ((kfpr(i,j),j=1,2),i=281,350)/
1834  8 1000005, 1000002, 2000005, 2000002, 1000005,
1835  8 2000002, 1000005, 1000002, 2000005, 2000002,
1836  8 1000005, 2000002, 1000005, 1000005, 2000005,
1837  8 2000005, 1000005, 1000005, 2000005, 2000005,
1838  9 1000005, 1000005, 2000005, 2000005, 1000005,
1839  9 2000005, 1000005, 1000021, 2000005, 1000021,
1840  9 1000005, 2000005, 37, 25, 37,
1841  9 35, 36, 25, 36, 35,
1842  & 37, 37, 18*0,
1843 C...UED: 311-319
1844  & 5100021, 5100021,
1845  & 5100002, 5100021,
1846  & 5100002, 5100001,
1847  & 5100002, -5100002,
1848  & 5100002, -5100002,
1849  & 5100002, -6100001,
1850  & 5100002, -5100001,
1851  & 5100002, 6100001,
1852  & 5100001, -5100001,
1853  & 42*0,
1854  4 9900041, 0, 9900042, 0, 9900041,
1855  4 11, 9900042, 11, 9900041, 13,
1856  4 9900042, 13, 9900041, 15, 9900042,
1857  4 15, 9900041, 9900041, 9900042, 9900042/
1858  DATA ((kfpr(i,j),j=1,2),i=351,400)/
1859  5 9900041, 0, 9900042, 0, 9900023,
1860  5 0, 9900024, 0, 0, 0,
1861  5 0, 0, 0, 0, 0,
1862  5 0, 0, 0, 0, 0,
1863  6 24, 24, 24, 3000211, 3000211,
1864  6 3000211, 22, 3000111, 22, 3000221,
1865  6 23, 3000111, 23, 3000221, 24,
1866  6 3000211, 0, 0, 24, 23,
1867  7 24, 3000111, 3000211, 23, 3000211,
1868  7 3000111, 22, 3000211, 23, 3000211,
1869  7 24, 3000111, 24, 3000221, 22,
1870  7 24, 22, 23, 23, 23,
1871  8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1872  8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1873  9 5000039, 0, 5000039, 0, 21,
1874  9 5000039, 0, 5000039, 21, 5000039,
1875  9 10*0/
1876  DATA ((kfpr(i,j),j=1,2),i=401,500)/
1877  & 37, 6, 37, 6, 36*0,
1878  2 443, 21, 9900443, 21, 9900441,
1879  2 21, 9910441, 21, 0, 9900443,
1880  2 0, 9900441, 0, 9910441, 21,
1881  2 9900443, 21, 9900441, 21, 9910441,
1882  3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1883  3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1884  6 553, 21, 9900553, 21, 9900551,
1885  6 21, 9910551, 21, 0, 9900553,
1886  6 0, 9900551, 0, 9910551, 21,
1887  6 9900553, 21, 9900551, 21, 9910551,
1888  7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1889  7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1890  DATA coef/10000*0d0/
1891  DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/
1892  &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,
1893  &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,
1894  &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,
1895  &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,
1896  &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,
1897  &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,
1898  &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,
1899  &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,
1900  &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,
1901  &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/
1902 
1903 C...Treatment of resonances.
1904  DATA (mwid(i) ,i= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1905  &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1906  &81*0,21*1,4*1,25*0/
1907 
1908 C...Character constants: name of processes.
1909  DATA proc(0)/ 'All included subprocesses '/
1910  DATA (proc(i),i=1,20)/
1911  &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1912  &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1913  &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1914  &' ', 'W+ + W- -> h0 ',
1915  &' ', 'f + f'' -> f + f'' (QFD) ',
1916  1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1917  1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1918  1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1919  1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1920  1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1921  DATA (proc(i),i=21,40)/
1922  2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1923  2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1924  2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1925  2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1926  2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1927  3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1928  3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1929  3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1930  3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1931  3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1932  DATA (proc(i),i=41,60)/
1933  4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1934  4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1935  4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1936  4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1937  4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1938  5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1939  5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1940  5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1941  5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1942  5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1943  DATA (proc(i),i=61,80)/
1944  6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1945  6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1946  6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1947  6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1948  6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1949  7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1950  7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1951  7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1952  7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1953  7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1954  DATA (proc(i),i=81,100)/
1955  8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1956  8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1957  8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1958  8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1959  8'g + g -> chi_2c + g ', ' ',
1960  9'Elastic scattering ', 'Single diffractive (XB) ',
1961  9'Single diffractive (AX) ', 'Double diffractive ',
1962  9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1963  9' ', ' ',
1964  9'q + gamma* -> q ', ' '/
1965  DATA (proc(i),i=101,120)/
1966  &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1967  &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1968  &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1969  &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1970  &' ', 'f + fbar -> gamma + h0 ',
1971  1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1972  1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1973  1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1974  1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1975  1' ', ' '/
1976  DATA (proc(i),i=121,140)/
1977  2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1978  2'f + f'' -> f + f'' + h0 ',
1979  2'f + f'' -> f" + f"'' + h0 ',
1980  2' ', ' ',
1981  2' ', ' ',
1982  2' ', ' ',
1983  3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1984  3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1985  3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1986  3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1987  3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1988  DATA (proc(i),i=141,160)/
1989  4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1990  4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1991  4'q + l -> LQ ', 'e + gamma -> e* ',
1992  4'd + g -> d* ', 'u + g -> u* ',
1993  4'g + g -> eta_tc ', ' ',
1994  5'f + fbar -> H0 ', 'g + g -> H0 ',
1995  5'gamma + gamma -> H0 ', ' ',
1996  5' ', 'f + fbar -> A0 ',
1997  5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1998  5' ', ' '/
1999  DATA (proc(i),i=161,180)/
2000  6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2001  6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2002  6'f + fbar -> f'' + fbar'' (g/Z)',
2003  6'f +fbar'' -> f" + fbar"'' (W) ',
2004  6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2005  6'q + qbar -> e + e* ', ' ',
2006  7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2007  7'f + f'' -> f + f'' + H0 ',
2008  7'f + f'' -> f" + f"'' + H0 ',
2009  7' ', 'f + fbar -> Z0 + A0 ',
2010  7'f + fbar'' -> W+/- + A0 ',
2011  7'f + f'' -> f + f'' + A0 ',
2012  7'f + f'' -> f" + f"'' + A0 ',
2013  7' '/
2014  DATA (proc(i),i=181,200)/
2015  8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2016  8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2017  8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2018  8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2019  8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2020  9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2021  9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2022  9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2023  9' ', ' ',
2024  9' ', ' '/
2025  DATA (proc(i),i=201,220)/
2026  &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2027  &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2028  &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2029  &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2030  &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2031  1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2032  1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2033  1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2034  1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2035  1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2036  DATA (proc(i),i=221,240)/
2037  2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2038  2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2039  2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2040  2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2041  2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2042  3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2043  3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2044  3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2045  3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2046  3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2047  DATA (proc(i),i=241,260)/
2048  4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2049  4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2050  4' ', 'qj + g -> ~qj_L + ~chi1 ',
2051  4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2052  4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2053  5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2054  5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2055  5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2056  5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2057  5'qj + g -> ~qj_R + ~g ', ' '/
2058  DATA (proc(i),i=261,300)/
2059  6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2060  6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2061  6'g + g -> ~t_2 + ~t_2bar ', ' ',
2062  6' ', ' ',
2063  6' ', ' ',
2064  7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2065  7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2066  7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2067  7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2068  7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2069  8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2070  8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2071  8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2072  8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2073  8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2074  9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2075  9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2076  9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2077  9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2078  9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2079  DATA (proc(i),i=301,340)/
2080  &'f + fbar -> H+ + H- ',
2081  &9*' ', 'g + g -> g* + g* ',
2082  &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2083  &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2084  &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2085  &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2086  &21*' '/
2087  DATA (proc(i),i=341,380)/
2088  4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2089  4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2090  4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2091  4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2092  4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2093  5'f + f -> f'' + f'' + H_L++/-- ',
2094  5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2095  5'f + fbar'' -> W_R+/- ',5*' ',
2096  6' ', 'f + fbar -> W_L+ W_L- ',
2097  6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2098  6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2099  6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2100  6'f + fbar -> W+/- pi_T-/+ ', ' ',
2101  7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2102  7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2103  7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2104  7'f + fbar'' -> W+/- pi_T0 ',
2105  7'f + fbar'' -> W+/- pi_T0'' ',
2106  7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2107  7'f + fbar -> Z0 Z0 (ETC) '/
2108  DATA (proc(i),i=381,420)/
2109  8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2110  8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2111  8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2112  8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2113  8' ', ' ',
2114  9'f + fbar -> G* ', 'g + g -> G* ',
2115  9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2116  9'g + g -> g + G* ', ' ',
2117  9 4*' ',
2118  &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2119  & 18*' '/
2120  DATA (proc(i),i=421,460)/
2121  2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2122  2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2123  2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2124  2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2125  2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2126  3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2127  3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2128  3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2129  3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2130  3'q + q~ -> g + cc~[3P2(1)] ',
2131  3 21 *' '/
2132  DATA (proc(i),i=461,500)/
2133  6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2134  6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2135  6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2136  6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2137  6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2138  7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2139  7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2140  7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2141  7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2142  7'q + q~ -> g + bb~[3P2(1)] ',
2143  7 21 *' '/
2144 
2145 C...Cross sections and slope offsets.
2146  DATA sigt/294*0d0/
2147 
2148 C...Supersymmetry switches and parameters.
2149  DATA imss/0,
2150  & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2151  1 89*0/
2152  DATA rmss/0d0,
2153  & 80d0,160d0,500d0,800d0,2d0,250d0,200d0,800d0,700d0,800d0,
2154  1 700d0,500d0,250d0,200d0,800d0,400d0,0d0,0.1d0,850d0,0.041d0,
2155  2 1d0,800d0,1d4,1d4,1d4,0d0,0d0,0d0,24d17,0d0,
2156  3 10*0d0,
2157  4 0d0,1d0,8*0d0,
2158  5 49*0d0/
2159 C...Initial values for R-violating SUSY couplings.
2160 C...Should not be changed here. See PYMSIN.
2161  DATA rvlam/27*0d0/
2162  DATA rvlamp/27*0d0/
2163  DATA rvlamb/27*0d0/
2164 
2165 C...Technicolor switches and parameters
2166  DATA itcm/0,
2167  & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2168  1 89*0/
2169  DATA rtcm/0d0,
2170  & 82d0,1.333d0,.333d0,0.408d0,1d0,1d0,.0182d0,1d0,0d0,1.333d0,
2171  1 .05d0,200d0,200d0,0d0,0d0,0d0,0d0,0d0,0d0,0d0,
2172  2 .283d0,.707d0,0d0,0d0,0d0,1.667d0,250d0,250d0,.707d0,0d0,
2173  3 .707d0,0d0,1d0,0d0,0d0,0d0,0d0,0d0,0d0,0d0,
2174  4 1000d0, 1d0, 1d0, 1d0, 1d0, 0d0, 1d0, 3*200d0,
2175  4 200d0, 48*0d0/
2176 
2177 C...UED switches and parameters.
2178 C... IUED(0) empty IUED vector element
2179 C... IUED(1) UED ON(=1)/OFF(=0) switch
2180 C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2181 C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2182 C... IUED(4) N the number of large extra dimensions
2183 C... IUED(5) Selects whether the code takes Lambda (=0)
2184 C... or Lambda*R (=1) as input.
2185 C... IUED(6) With radiative corrections to the masses (=1)
2186 C... or without (=0)
2187 C...
2188 C... RUED(0) empty RUED vector element
2189 C... RUED(1) RINV (1/R) the curvature of the extra dimension
2190 C... RUED(2) XMD the (4+N)-dimensional Planck scale
2191 C... RUED(3) LAMUED (Lambda cutoff scale)
2192 C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2193 C...
2194  DATA iued/0,0,0,5,6,0,1,93*0/
2195  DATA rued/0.d0,1000d0,5000d0,20000.,20.,95*0d0/
2196 
2197 C...Data for histogramming routines.
2198  DATA ihist/1000,20000,55,1/
2199  DATA indx/1000*0/
2200 
2201 C...Data for SUSY Les Houches Accord.
2202  DATA cpro/'PYTHIA ','PYTHIA '/
2203  DATA cver/'6.4 ','6.4 '/
2204  DATA modsel/200*0/
2205  DATA parmin/100*0d0/
2206  DATA rmsoft/101*0d0/
2207  DATA au/9*0d0/
2208  DATA ad/9*0d0/
2209  DATA ae/9*0d0/
2210 
2211  END
2212 
2213 C*********************************************************************
2214 
2215 C...PYCKBD
2216 C...Check that BLOCK DATA PYDATA has been loaded.
2217 C...Should not be required, except that some compilers/linkers
2218 C...are pretty buggy in this respect.
2219 
2220  SUBROUTINE pyckbd
2221 
2222 C...Double precision and integer declarations.
2223  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2224  IMPLICIT INTEGER(i-n)
2225  INTEGER pyk,pychge,pycomp
2226 C...Commonblocks.
2227  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2228  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2229  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2230  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2231  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2232  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2233  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
2234 
2235 C...Check a few variables to see they have been sensibly initialized.
2236  IF(mstu(4).LT.10.OR.mstu(4).GT.900000.OR.pmas(2,1).LT.0.001d0
2237  &.OR.pmas(2,1).GT.1d0.OR.ckin(5).LT.0.01d0.OR.mstp(1).LT.1.OR.
2238  &mstp(1).GT.5) THEN
2239 C...If not, abort the run right away.
2240  WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2241  WRITE(*,*) 'The program execution is stopped now!'
2242  CALL pystop(8)
2243  ENDIF
2244 
2245  RETURN
2246  END
2247 
2248 C*********************************************************************
2249 
2250 C...PYTEST
2251 C...A simple program (disguised as subroutine) to run at installation
2252 C...as a check that the program works as intended.
2253 
2254  SUBROUTINE pytest(MTEST)
2255 
2256 C...Double precision and integer declarations.
2257  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2258  IMPLICIT INTEGER(i-n)
2259  INTEGER pyk,pychge,pycomp
2260 C...Commonblocks.
2261  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2262  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2263  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2264  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2265  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2266  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2267  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
2268 C...Local arrays.
2269  dimension psum(5),pini(6),pfin(6)
2270 
2271 C...Save defaults for values that are changed.
2272  mstj1=mstj(1)
2273  mstj3=mstj(3)
2274  mstj11=mstj(11)
2275  mstj42=mstj(42)
2276  mstj43=mstj(43)
2277  mstj44=mstj(44)
2278  parj17=parj(17)
2279  parj22=parj(22)
2280  parj43=parj(43)
2281  parj54=parj(54)
2282  mst101=mstj(101)
2283  mst104=mstj(104)
2284  mst105=mstj(105)
2285  mst107=mstj(107)
2286  mst116=mstj(116)
2287 
2288 C...First part: loop over simple events to be generated.
2289  IF(mtest.GE.1) CALL pytabu(20)
2290  nerr=0
2291  DO 180 iev=1,500
2292 
2293 C...Reset parameter values. Switch on some nonstandard features.
2294  mstj(1)=1
2295  mstj(3)=0
2296  mstj(11)=1
2297  mstj(42)=2
2298  mstj(43)=4
2299  mstj(44)=2
2300  parj(17)=0.1d0
2301  parj(22)=1.5d0
2302  parj(43)=1d0
2303  parj(54)=-0.05d0
2304  mstj(101)=5
2305  mstj(104)=5
2306  mstj(105)=0
2307  mstj(107)=1
2308  IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
2309 
2310 C...Ten events each for some single jets configurations.
2311  IF(iev.LE.50) THEN
2312  ity=(iev+9)/10
2313  mstj(3)=-1
2314  IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
2315  IF(ity.EQ.1) CALL py1ent(1,1,15d0,0d0,0d0)
2316  IF(ity.EQ.2) CALL py1ent(1,3101,15d0,0d0,0d0)
2317  IF(ity.EQ.3) CALL py1ent(1,-2203,15d0,0d0,0d0)
2318  IF(ity.EQ.4) CALL py1ent(1,-4,30d0,0d0,0d0)
2319  IF(ity.EQ.5) CALL py1ent(1,21,15d0,0d0,0d0)
2320 
2321 C...Ten events each for some simple jet systems; string fragmentation.
2322  ELSEIF(iev.LE.130) THEN
2323  ity=(iev-41)/10
2324  IF(ity.EQ.1) CALL py2ent(1,1,-1,40d0)
2325  IF(ity.EQ.2) CALL py2ent(1,4,-4,30d0)
2326  IF(ity.EQ.3) CALL py2ent(1,2,2103,100d0)
2327  IF(ity.EQ.4) CALL py2ent(1,21,21,40d0)
2328  IF(ity.EQ.5) CALL py3ent(1,2101,21,-3203,30d0,0.6d0,0.8d0)
2329  IF(ity.EQ.6) CALL py3ent(1,5,21,-5,40d0,0.9d0,0.8d0)
2330  IF(ity.EQ.7) CALL py3ent(1,21,21,21,60d0,0.7d0,0.5d0)
2331  IF(ity.EQ.8) CALL py4ent(1,2,21,21,-2,40d0,
2332  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2333 
2334 C...Seventy events with independent fragmentation and momentum cons.
2335  ELSEIF(iev.LE.200) THEN
2336  ity=1+(iev-131)/16
2337  mstj(2)=1+mod(iev-131,4)
2338  mstj(3)=1+mod((iev-131)/4,4)
2339  IF(ity.EQ.1) CALL py2ent(1,4,-5,40d0)
2340  IF(ity.EQ.2) CALL py3ent(1,3,21,-3,40d0,0.9d0,0.4d0)
2341  IF(ity.EQ.3) CALL py4ent(1,2,21,21,-2,40d0,
2342  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2343  IF(ity.GE.4) CALL py4ent(1,2,-3,3,-2,40d0,
2344  & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2345 
2346 C...A hundred events with random jets (check invariant mass).
2347  ELSEIF(iev.LE.300) THEN
2348  100 DO 110 j=1,5
2349  psum(j)=0d0
2350  110 CONTINUE
2351  njet=2d0+6d0*pyr(0)
2352  DO 130 i=1,njet
2353  kfl=21
2354  IF(i.EQ.1) kfl=int(1d0+4d0*pyr(0))
2355  IF(i.EQ.njet) kfl=-int(1d0+4d0*pyr(0))
2356  ejet=5d0+20d0*pyr(0)
2357  theta=acos(2d0*pyr(0)-1d0)
2358  phi=6.2832d0*pyr(0)
2359  IF(i.LT.njet) CALL py1ent(-i,kfl,ejet,theta,phi)
2360  IF(i.EQ.njet) CALL py1ent(i,kfl,ejet,theta,phi)
2361  IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
2362  IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+pymass(kfl)
2363  DO 120 j=1,4
2364  psum(j)=psum(j)+p(i,j)
2365  120 CONTINUE
2366  130 CONTINUE
2367  IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
2368  & (psum(5)+parj(32))**2) goto 100
2369 
2370 C...Fifty e+e- continuum events with matrix elements.
2371  ELSEIF(iev.LE.350) THEN
2372  mstj(101)=2
2373  CALL pyeevt(0,40d0)
2374 
2375 C...Fifty e+e- continuum event with varying shower options.
2376  ELSEIF(iev.LE.400) THEN
2377  mstj(42)=1+mod(iev,2)
2378  mstj(43)=1+mod(iev/2,4)
2379  mstj(44)=mod(iev/8,3)
2380  CALL pyeevt(0,90d0)
2381 
2382 C...Fifty e+e- continuum events with coherent shower.
2383  ELSEIF(iev.LE.450) THEN
2384  CALL pyeevt(0,500d0)
2385 
2386 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2387  ELSE
2388  CALL pyonia(5,9.46d0)
2389  ENDIF
2390 
2391 C...Generate event. Find total momentum, energy and charge.
2392  DO 140 j=1,4
2393  pini(j)=pyp(0,j)
2394  140 CONTINUE
2395  pini(6)=pyp(0,6)
2396  CALL pyexec
2397  DO 150 j=1,4
2398  pfin(j)=pyp(0,j)
2399  150 CONTINUE
2400  pfin(6)=pyp(0,6)
2401 
2402 C...Check conservation of energy, momentum and charge;
2403 C...usually exact, but only approximate for single jets.
2404  merr=0
2405  IF(iev.LE.50) THEN
2406  IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.10d0)
2407  & merr=merr+1
2408  epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
2409  IF(epzrem.LT.0d0.OR.epzrem.GT.2d0*parj(31)) merr=merr+1
2410  IF(abs(pfin(6)-pini(6)).GT.2.1d0) merr=merr+1
2411  ELSE
2412  DO 160 j=1,4
2413  IF(abs(pfin(j)-pini(j)).GT.0.0001d0*pini(4)) merr=merr+1
2414  160 CONTINUE
2415  IF(abs(pfin(6)-pini(6)).GT.0.1d0) merr=merr+1
2416  ENDIF
2417  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
2418  & (pfin(j),j=1,4),pfin(6)
2419 
2420 C...Check that all KF codes are known ones, and that partons/particles
2421 C...satisfy energy-momentum-mass relation. Store particle statistics.
2422  DO 170 i=1,n
2423  IF(k(i,1).GT.20) goto 170
2424  IF(pycomp(k(i,2)).EQ.0) THEN
2425  WRITE(mstu(11),5100) i
2426  merr=merr+1
2427  ENDIF
2428  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
2429  IF(abs(pd).GT.max(0.1d0,0.001d0*p(i,4)**2).OR.p(i,4).LT.0d0)
2430  & THEN
2431  WRITE(mstu(11),5200) i
2432  merr=merr+1
2433  ENDIF
2434  170 CONTINUE
2435  IF(mtest.GE.1) CALL pytabu(21)
2436 
2437 C...List all erroneous events and some normal ones.
2438  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
2439  IF(merr.GE.1) WRITE(mstu(11),6400)
2440  CALL pylist(2)
2441  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
2442  CALL pylist(1)
2443  ENDIF
2444 
2445 C...Stop execution if too many errors.
2446  IF(merr.NE.0) nerr=nerr+1
2447  IF(nerr.GE.10) THEN
2448  WRITE(mstu(11),6300)
2449  CALL pylist(1)
2450  CALL pystop(9)
2451  ENDIF
2452  180 CONTINUE
2453 
2454 C...Summarize result of run.
2455  IF(mtest.GE.1) CALL pytabu(22)
2456 
2457 C...Reset commonblock variables changed during run.
2458  mstj(1)=mstj1
2459  mstj(3)=mstj3
2460  mstj(11)=mstj11
2461  mstj(42)=mstj42
2462  mstj(43)=mstj43
2463  mstj(44)=mstj44
2464  parj(17)=parj17
2465  parj(22)=parj22
2466  parj(43)=parj43
2467  parj(54)=parj54
2468  mstj(101)=mst101
2469  mstj(104)=mst104
2470  mstj(105)=mst105
2471  mstj(107)=mst107
2472  mstj(116)=mst116
2473 
2474 C...Second part: complete events of various kinds.
2475 C...Common initial values. Loop over initiating conditions.
2476  mstp(122)=max(0,min(2,mtest))
2477  mdcy(pycomp(111),1)=0
2478  DO 230 iproc=1,8
2479 
2480 C...Reset process type, kinematics cuts, and the flags used.
2481  msel=0
2482  DO 190 isub=1,500
2483  msub(isub)=0
2484  190 CONTINUE
2485  ckin(1)=2d0
2486  ckin(3)=0d0
2487  mstp(2)=1
2488  mstp(11)=0
2489  mstp(33)=0
2490  mstp(81)=1
2491  mstp(82)=1
2492  mstp(111)=1
2493  mstp(131)=0
2494  mstp(133)=0
2495  parp(131)=0.01d0
2496 
2497 C...Prompt photon production at fixed target.
2498  IF(iproc.EQ.1) THEN
2499  pzsum=300d0
2500  pesum=sqrt(pzsum**2+pymass(211)**2)+pymass(2212)
2501  pqsum=2d0
2502  msel=10
2503  ckin(3)=5d0
2504  CALL pyinit('FIXT','pi+','p',pzsum)
2505 
2506 C...QCD processes at ISR energies.
2507  ELSEIF(iproc.EQ.2) THEN
2508  pesum=63d0
2509  pzsum=0d0
2510  pqsum=2d0
2511  msel=1
2512  ckin(3)=5d0
2513  CALL pyinit('CMS','p','p',pesum)
2514 
2515 C...W production + multiple interactions at CERN Collider.
2516  ELSEIF(iproc.EQ.3) THEN
2517  pesum=630d0
2518  pzsum=0d0
2519  pqsum=0d0
2520  msel=12
2521  ckin(1)=20d0
2522  mstp(82)=4
2523  mstp(2)=2
2524  mstp(33)=3
2525  CALL pyinit('CMS','p','pbar',pesum)
2526 
2527 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2528  ELSEIF(iproc.EQ.4) THEN
2529  pesum=1800d0
2530  pzsum=0d0
2531  pqsum=0d0
2532  msub(22)=1
2533  msub(23)=1
2534  msub(25)=1
2535  ckin(1)=200d0
2536  mstp(111)=0
2537  mstp(131)=1
2538  mstp(133)=2
2539  parp(131)=0.04d0
2540  CALL pyinit('CMS','p','pbar',pesum)
2541 
2542 C...Higgs production at LHC.
2543  ELSEIF(iproc.EQ.5) THEN
2544  pesum=15400d0
2545  pzsum=0d0
2546  pqsum=2d0
2547  msub(3)=1
2548  msub(102)=1
2549  msub(123)=1
2550  msub(124)=1
2551  pmas(25,1)=300d0
2552  ckin(1)=200d0
2553  mstp(81)=0
2554  mstp(111)=0
2555  CALL pyinit('CMS','p','p',pesum)
2556 
2557 C...Z' production at SSC.
2558  ELSEIF(iproc.EQ.6) THEN
2559  pesum=40000d0
2560  pzsum=0d0
2561  pqsum=2d0
2562  msel=21
2563  pmas(32,1)=600d0
2564  ckin(1)=400d0
2565  mstp(81)=0
2566  mstp(111)=0
2567  CALL pyinit('CMS','p','p',pesum)
2568 
2569 C...W pair production at 1 TeV e+e- collider.
2570  ELSEIF(iproc.EQ.7) THEN
2571  pesum=1000d0
2572  pzsum=0d0
2573  pqsum=0d0
2574  msub(25)=1
2575  msub(69)=1
2576  mstp(11)=1
2577  CALL pyinit('CMS','e+','e-',pesum)
2578 
2579 C...Deep inelastic scattering at a LEP+LHC ep collider.
2580  ELSEIF(iproc.EQ.8) THEN
2581  p(1,1)=0d0
2582  p(1,2)=0d0
2583  p(1,3)=8000d0
2584  p(2,1)=0d0
2585  p(2,2)=0d0
2586  p(2,3)=-80d0
2587  pesum=8080d0
2588  pzsum=7920d0
2589  pqsum=0d0
2590  msub(10)=1
2591  ckin(3)=50d0
2592  mstp(111)=0
2593  CALL pyinit('3MOM','p','e-',pesum)
2594  ENDIF
2595 
2596 C...Generate 20 events of each required type.
2597  DO 220 iev=1,20
2598  CALL pyevnt
2599  pesumm=pesum
2600  IF(iproc.EQ.4) pesumm=msti(41)*pesum
2601 
2602 C...Check conservation of energy/momentum/flavour.
2603  pini(1)=0d0
2604  pini(2)=0d0
2605  pini(3)=pzsum
2606  pini(4)=pesumm
2607  pini(6)=pqsum
2608  DO 200 j=1,4
2609  pfin(j)=pyp(0,j)
2610  200 CONTINUE
2611  pfin(6)=pyp(0,6)
2612  merr=0
2613  deve=abs(pfin(4)-pini(4))+abs(pfin(3)-pini(3))
2614  devt=abs(pfin(1)-pini(1))+abs(pfin(2)-pini(2))
2615  devq=abs(pfin(6)-pini(6))
2616  IF(deve.GT.2d-3*pesum.OR.devt.GT.max(0.01d0,1d-4*pesum).OR.
2617  & devq.GT.0.1d0) merr=1
2618  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
2619  & (pfin(j),j=1,4),pfin(6)
2620 
2621 C...Check that all KF codes are known ones, and that partons/particles
2622 C...satisfy energy-momentum-mass relation.
2623  DO 210 i=1,n
2624  IF(k(i,1).GT.20) goto 210
2625  IF(pycomp(k(i,2)).EQ.0) THEN
2626  WRITE(mstu(11),5100) i
2627  merr=merr+1
2628  ENDIF
2629  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2*
2630  & sign(1d0,p(i,5))
2631  IF(abs(pd).GT.max(0.1d0,0.002d0*p(i,4)**2,0.002d0*p(i,5)**2)
2632  & .OR.(p(i,5).GE.0d0.AND.p(i,4).LT.0d0)) THEN
2633  WRITE(mstu(11),5200) i
2634  merr=merr+1
2635  ENDIF
2636  210 CONTINUE
2637 
2638 C...Listing of erroneous events, and first event of each type.
2639  IF(merr.GE.1) nerr=nerr+1
2640  IF(nerr.GE.10) THEN
2641  WRITE(mstu(11),6300)
2642  CALL pylist(1)
2643  CALL pystop(9)
2644  ENDIF
2645  IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN
2646  IF(merr.GE.1) WRITE(mstu(11),6400)
2647  CALL pylist(1)
2648  ENDIF
2649  220 CONTINUE
2650 
2651 C...List statistics for each process type.
2652  IF(mtest.GE.1) CALL pystat(1)
2653  230 CONTINUE
2654 
2655 C...Summarize result of run.
2656  IF(nerr.EQ.0) WRITE(mstu(11),6500)
2657  IF(nerr.GT.0) WRITE(mstu(11),6600) nerr
2658 
2659 C...Format statements for output.
2660  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2661  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
2662  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
2663  &4(1x,f12.5),1x,f8.2)
2664  5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
2665  5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
2666  &'kinematics')
2667  6300 FORMAT(/5x,'This is the tenth error experienced! Something is ',
2668  &'wrong.'/5x,'Execution will be stopped after listing of event.')
2669  6400 FORMAT(5x,'Faulty event follows:')
2670  6500 FORMAT(//5x,'End result of PYTEST: no errors detected.')
2671  6600 FORMAT(//5x,'End result of PYTEST:',i2,' errors detected.'/
2672  &5x,'This should not have happened!')
2673 
2674  RETURN
2675  END
2676 
2677 C*********************************************************************
2678 
2679 C...PYHEPC
2680 C...Converts PYTHIA event record contents to or from
2681 C...the standard event record commonblock.
2682 
2683  SUBROUTINE pyhepc(MCONV)
2684 
2685 C...Double precision and integer declarations.
2686  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2687  IMPLICIT INTEGER(i-n)
2688  INTEGER pyk,pychge,pycomp
2689 C...Commonblocks.
2690  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2691  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2692  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2693  SAVE /pyjets/,/pydat1/,/pydat2/
2694 C...HEPEVT commonblock.
2695  parameter(nmxhep=4000)
2696  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
2697  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
2698  DOUBLE PRECISION phep,vhep
2699  SAVE /hepevt/
2700 
2701 C...Store HEPEVT commonblock size (for interfacing issues).
2702  mstu(8)=nmxhep
2703 
2704 C...Initialize variable(s)
2705  inew = 1
2706 
2707 C...Conversion from PYTHIA to standard, the easy part.
2708  IF(mconv.EQ.1) THEN
2709  nevhep=0
2710  IF(n.GT.nmxhep) CALL pyerrm(8,
2711  & '(PYHEPC:) no more space in /HEPEVT/')
2712  nhep=min(n,nmxhep)
2713  DO 150 i=1,nhep
2714  isthep(i)=0
2715  IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
2716  IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
2717  IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
2718  IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
2719  idhep(i)=k(i,2)
2720  jmohep(1,i)=k(i,3)
2721  jmohep(2,i)=0
2722  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
2723  jdahep(1,i)=k(i,4)
2724  jdahep(2,i)=k(i,5)
2725  ELSE
2726  jdahep(1,i)=0
2727  jdahep(2,i)=0
2728  ENDIF
2729  DO 100 j=1,5
2730  phep(j,i)=p(i,j)
2731  100 CONTINUE
2732  DO 110 j=1,4
2733  vhep(j,i)=v(i,j)
2734  110 CONTINUE
2735 
2736 C...Check if new event (from pileup).
2737  IF(i.EQ.1) THEN
2738  inew=1
2739  ELSE
2740  IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
2741  ENDIF
2742 
2743 C...Fill in missing mother information.
2744  IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
2745  imo1=i-2
2746  120 IF(imo1.GT.inew.AND.k(imo1+1,1).EQ.21.AND.k(imo1+1,3).EQ.0)
2747  & THEN
2748  imo1=imo1-1
2749  goto 120
2750  ENDIF
2751  jmohep(1,i)=imo1
2752  jmohep(2,i)=imo1+1
2753  ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
2754  i1=k(i,3)-1
2755  130 i1=i1+1
2756  IF(i1.GE.i) CALL pyerrm(8,
2757  & '(PYHEPC:) translation of inconsistent event history')
2758  IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) goto 130
2759  kc=pycomp(k(i1,2))
2760  IF(i1.LT.i.AND.kc.EQ.0) goto 130
2761  IF(i1.LT.i.AND.kchg(kc,2).EQ.0) goto 130
2762  jmohep(2,i)=i1
2763  ELSEIF(k(i,2).EQ.94) THEN
2764  njet=2
2765  IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
2766  IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
2767  jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
2768  IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
2769  & mod(k(i+1,4)/mstu(5),mstu(5))
2770  ENDIF
2771 
2772 C...Fill in missing daughter information.
2773  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
2774  DO 140 i1=jdahep(1,i),jdahep(2,i)
2775  i2=mod(k(i1,4)/mstu(5),mstu(5))
2776  jdahep(1,i2)=i
2777  140 CONTINUE
2778  ENDIF
2779  IF(k(i,2).GE.91.AND.k(i,2).LE.94) goto 150
2780  i1=jmohep(1,i)
2781  IF(i1.LE.0.OR.i1.GT.nhep) goto 150
2782  IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) goto 150
2783  IF(jdahep(1,i1).EQ.0) THEN
2784  jdahep(1,i1)=i
2785  ELSE
2786  jdahep(2,i1)=i
2787  ENDIF
2788  150 CONTINUE
2789  DO 160 i=1,nhep
2790  IF(k(i,1).NE.13.AND.k(i,1).NE.14) goto 160
2791  IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
2792  160 CONTINUE
2793 
2794 C...Conversion from standard to PYTHIA, the easy part.
2795  ELSE
2796  IF(nhep.GT.mstu(4)) CALL pyerrm(8,
2797  & '(PYHEPC:) no more space in /PYJETS/')
2798  n=min(nhep,mstu(4))
2799  nkq=0
2800  kqsum=0
2801  DO 190 i=1,n
2802  k(i,1)=0
2803  IF(isthep(i).EQ.1) k(i,1)=1
2804  IF(isthep(i).EQ.2) THEN
2805  k(i,1)=11
2806  IF(k(i,4).GT.0.AND.(k(i,4).EQ.k(i,5)).AND.
2807  $ (k(k(i,4),2).GE.91.AND.k(k(i,4),2).LE.93).AND.
2808  $ (i.LT.n).AND.(k(i,4).EQ.k(i+1,4))) k(i,1)=12
2809  ENDIF
2810  IF(isthep(i).EQ.3) k(i,1)=21
2811  k(i,2)=idhep(i)
2812  k(i,3)=jmohep(1,i)
2813  k(i,4)=jdahep(1,i)
2814  k(i,5)=jdahep(2,i)
2815  DO 170 j=1,5
2816  p(i,j)=phep(j,i)
2817  170 CONTINUE
2818  DO 180 j=1,4
2819  v(i,j)=vhep(j,i)
2820  180 CONTINUE
2821  v(i,5)=0d0
2822  IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
2823  i1=jdahep(1,i)
2824  IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
2825  & phep(5,i)/phep(4,i)
2826  ENDIF
2827 
2828 C...Fill in missing information on colour connection in jet systems.
2829  IF(isthep(i).EQ.1) THEN
2830  kc=pycomp(k(i,2))
2831  kq=0
2832  IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
2833  IF(kq.NE.0) nkq=nkq+1
2834  IF(kq.NE.2) kqsum=kqsum+kq
2835  IF(kq.NE.0.AND.kqsum.NE.0) THEN
2836  k(i,1)=2
2837  ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
2838  IF(k(i+1,2).EQ.21) k(i,1)=2
2839  ENDIF
2840  ENDIF
2841  190 CONTINUE
2842  IF(nkq.EQ.1.OR.kqsum.NE.0) CALL pyerrm(8,
2843  & '(PYHEPC:) input parton configuration not colour singlet')
2844  ENDIF
2845 
2846  END
2847 
2848 C*********************************************************************
2849 
2850 C...PYINIT
2851 C...Initializes the generation procedure; finds maxima of the
2852 C...differential cross-sections to be used for weighting.
2853 
2854  SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)
2855 
2856 C...Double precision and integer declarations.
2857  IMPLICIT DOUBLE PRECISION(a-h, o-z)
2858  IMPLICIT INTEGER(i-n)
2859  INTEGER pyk,pychge,pycomp
2860 C...Commonblocks.
2861  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2862  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2863  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2864  common/pydat4/chaf(500,2)
2865  CHARACTER chaf*16
2866  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2867  common/pypars/mstp(200),parp(200),msti(200),pari(200)
2868  common/pyint1/mint(400),vint(400)
2869  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2870  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2871  common/pypued/iued(0:99),rued(0:99)
2872  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
2873  &/pyint1/,/pyint2/,/pyint5/,/pypued/
2874 C...Local arrays and character variables.
2875  dimension alamin(20),nfin(20)
2876  CHARACTER*(*) frame,beam,target
2877  CHARACTER chfram*12,chbeam*12,chtarg*12,chlh(2)*6
2878 
2879 C...Interface to PDFLIB.
2880  common/w50511/nptype,ngroup,nset,mode,nfl,lo,tmas
2881  common/w50512/qcdl4,qcdl5
2882  SAVE /w50511/,/w50512/
2883  DOUBLE PRECISION value(20),tmas,qcdl4,qcdl5
2884  CHARACTER*20 parm(20)
2885  DATA value/20*0d0/,parm/20*' '/
2886 
2887 C...Data:Lambda and n_f values for parton distributions..
2888  DATA alamin/0.177d0,0.239d0,0.247d0,0.2322d0,0.248d0,0.248d0,
2889  &0.192d0,0.326d0,2*0.2d0,0.2d0,0.2d0,0.29d0,0.2d0,0.4d0,5*0.2d0/,
2890  &nfin/20*4/
2891  DATA chlh/'lepton','hadron'/
2892 
2893 C...Check that BLOCK DATA PYDATA has been loaded.
2894  CALL pyckbd
2895 
2896 C...Reset MINT and VINT arrays. Write headers.
2897  msti(53)=0
2898  DO 100 j=1,400
2899  mint(j)=0
2900  vint(j)=0d0
2901  100 CONTINUE
2902  IF(mstu(12).NE.12345) CALL pylist(0)
2903  IF(mstp(122).GE.1) WRITE(mstu(11),5100)
2904 
2905 C...Reset error counters.
2906  mstu(23)=0
2907  mstu(27)=0
2908  mstu(30)=0
2909 
2910 C...Reset processes that should not be on.
2911  msub(96)=0
2912  msub(97)=0
2913 
2914 C...Select global FSR/ISR/UE parameter set = 'tune'
2915 C...See routine PYTUNE for details
2916  IF (mstp(5).NE.0) THEN
2917  mstp5=mstp(5)
2918  CALL pytune(mstp5)
2919  ENDIF
2920 
2921 C...Call user process initialization routine.
2922  IF(frame(1:1).EQ.'u'.OR.frame(1:1).EQ.'U') THEN
2923  msel=0
2924  CALL upinit
2925  msel=0
2926  ENDIF
2927 
2928 C...Maximum 4 generations; set maximum number of allowed flavours.
2929  mstp(1)=min(4,mstp(1))
2930  mstu(114)=min(mstu(114),2*mstp(1))
2931  mstp(58)=min(mstp(58),2*mstp(1))
2932 
2933 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2934  DO 120 i=-20,20
2935  vint(180+i)=0d0
2936  ia=iabs(i)
2937  IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN
2938  DO 110 j=1,mstp(1)
2939  ib=2*j-1+mod(ia,2)
2940  IF(ib.GE.6.AND.mstp(9).EQ.0) goto 110
2941  ipm=(5-isign(1,i))/2
2942  idc=j+mdcy(ia,2)+2
2943  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)=
2944  & vint(180+i)+vckm((ia+1)/2,(ib+1)/2)
2945  110 CONTINUE
2946  ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN
2947  vint(180+i)=1d0
2948  ENDIF
2949  120 CONTINUE
2950 
2951 C...Initialize parton distributions: PDFLIB.
2952  IF(mstp(52).EQ.2) THEN
2953  parm(1)='NPTYPE'
2954  value(1)=1
2955  parm(2)='NGROUP'
2956  value(2)=mstp(51)/1000
2957  parm(3)='NSET'
2958  value(3)=mod(mstp(51),1000)
2959  parm(4)='TMAS'
2960  value(4)=pmas(6,1)
2961  CALL pdfset(parm,value)
2962  mint(93)=1000000+mstp(51)
2963  ENDIF
2964 
2965 C...Choose Lambda value to use in alpha-strong.
2966  mstu(111)=mstp(2)
2967  IF(mstp(3).GE.2) THEN
2968  alam=0.2d0
2969  nf=4
2970  IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.20) THEN
2971  alam=alamin(mstp(51))
2972  nf=nfin(mstp(51))
2973  ELSEIF(mstp(52).EQ.2.AND.nfl.EQ.5) THEN
2974  alam=qcdl5
2975  nf=5
2976  ELSEIF(mstp(52).EQ.2) THEN
2977  alam=qcdl4
2978  nf=4
2979  ENDIF
2980  parp(1)=alam
2981  parp(61)=alam
2982  parp(72)=alam
2983  paru(112)=alam
2984  mstu(112)=nf
2985  IF(mstp(3).EQ.3) parj(81)=alam
2986  ENDIF
2987 
2988 C...Initialize the UED masses and widths
2989  IF (iued(1).EQ.1) CALL pyxdin
2990 
2991 C...Initialize the SUSY generation: couplings, masses,
2992 C...decay modes, branching ratios, and so on.
2993  CALL pymsin
2994 C...Initialize widths and partial widths for resonances.
2995  CALL pyinre
2996 C...Set Z0 mass and width for e+e- routines.
2997  parj(123)=pmas(23,1)
2998  parj(124)=pmas(23,2)
2999 
3000 C...Identify beam and target particles and frame of process.
3001  chfram=frame//' '
3002  chbeam=beam//' '
3003  chtarg=TARGET//' '
3004  CALL pyinbm(chfram,chbeam,chtarg,win)
3005  IF(mint(65).EQ.1) goto 170
3006 
3007 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3008 C...For e-gamma allow 2 alternatives.
3009  mint(121)=1
3010  IF(mstp(14).EQ.10.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)=6
3014  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3015  & (iabs(mint(11)).EQ.11.OR.iabs(mint(12)).EQ.11)) mint(121)=2
3016  ELSEIF(mstp(14).EQ.20.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3017  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3018  & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=3
3019  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=9
3020  ELSEIF(mstp(14).EQ.25.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3021  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3022  & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=2
3023  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=4
3024  ELSEIF(mstp(14).EQ.30.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3025  IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3026  & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=4
3027  IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=13
3028  ENDIF
3029  mint(123)=mstp(14)
3030  IF((mstp(14).EQ.10.OR.mstp(14).EQ.20.OR.mstp(14).EQ.25.OR.
3031  &mstp(14).EQ.30).AND.msel.NE.1.AND.msel.NE.2) mint(123)=0
3032  IF(mstp(14).GE.11.AND.mstp(14).LE.19) THEN
3033  IF(mstp(14).EQ.11) mint(123)=0
3034  IF(mstp(14).EQ.12.OR.mstp(14).EQ.14) mint(123)=5
3035  IF(mstp(14).EQ.13.OR.mstp(14).EQ.17) mint(123)=6
3036  IF(mstp(14).EQ.15) mint(123)=2
3037  IF(mstp(14).EQ.16.OR.mstp(14).EQ.18) mint(123)=7
3038  IF(mstp(14).EQ.19) mint(123)=3
3039  ELSEIF(mstp(14).GE.21.AND.mstp(14).LE.24) THEN
3040  IF(mstp(14).EQ.21) mint(123)=0
3041  IF(mstp(14).EQ.22.OR.mstp(14).EQ.23) mint(123)=4
3042  IF(mstp(14).EQ.24) mint(123)=1
3043  ELSEIF(mstp(14).GE.26.AND.mstp(14).LE.29) THEN
3044  IF(mstp(14).EQ.26.OR.mstp(14).EQ.28) mint(123)=8
3045  IF(mstp(14).EQ.27.OR.mstp(14).EQ.29) mint(123)=9
3046  ENDIF
3047 
3048 C...Set up kinematics of process.
3049  CALL pyinki(0)
3050 
3051 C...Set up kinematics for photons inside leptons.
3052  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(1,wtgaga)
3053 
3054 C...Precalculate flavour selection weights.
3055  CALL pykfin
3056 
3057 C...Loop over gamma-p or gamma-gamma alternatives.
3058  ckin3=ckin(3)
3059  msav48=0
3060  DO 160 iga=1,mint(121)
3061  ckin(3)=ckin3
3062  mint(122)=iga
3063 
3064 C...Select partonic subprocesses to be included in the simulation.
3065  CALL pyinpr
3066  mint(101)=1
3067  mint(102)=1
3068  mint(103)=mint(11)
3069  mint(104)=mint(12)
3070 
3071 C...Count number of subprocesses on.
3072  mint(48)=0
3073  DO 130 isub=1,500
3074  IF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
3075  & msub(isub).EQ.1.AND.mint(121).GT.1) THEN
3076  msub(isub)=0
3077  ELSEIF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
3078  & msub(isub).EQ.1) THEN
3079  WRITE(mstu(11),5200) isub,chlh(mint(41)),chlh(mint(42))
3080  CALL pystop(1)
3081  ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN
3082  WRITE(mstu(11),5300) isub
3083  CALL pystop(1)
3084  ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN
3085  WRITE(mstu(11),5400) isub
3086  CALL pystop(1)
3087  ELSEIF(msub(isub).EQ.1) THEN
3088  mint(48)=mint(48)+1
3089  ENDIF
3090  130 CONTINUE
3091 
3092 C...Stop or raise warning flag if no subprocesses on.
3093  IF(mint(121).EQ.1.AND.mint(48).EQ.0) THEN
3094  IF(mstp(127).NE.1) THEN
3095  WRITE(mstu(11),5500)
3096  CALL pystop(1)
3097  ELSE
3098  WRITE(mstu(11),5700)
3099  msti(53)=1
3100  ENDIF
3101  ENDIF
3102  mint(49)=mint(48)-msub(91)-msub(92)-msub(93)-msub(94)
3103  msav48=msav48+mint(48)
3104 
3105 C...Reset variables for cross-section calculation.
3106  DO 150 i=0,500
3107  DO 140 j=1,3
3108  ngen(i,j)=0
3109  xsec(i,j)=0d0
3110  140 CONTINUE
3111  150 CONTINUE
3112 
3113 C...Find parametrized total cross-sections.
3114  CALL pyxtot
3115  vint(318)=vint(317)
3116 
3117 C...Maxima of differential cross-sections.
3118  IF(mstp(121).LE.1) CALL pymaxi
3119 
3120 C...Initialize possibility of pileup events.
3121  IF(mint(121).GT.1) mstp(131)=0
3122  IF(mstp(131).NE.0) CALL pypile(1)
3123 
3124 C...Initialize multiple interactions with variable impact parameter.
3125  IF(mint(50).EQ.1) THEN
3126  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
3127  IF(mod(mstp(81),10).EQ.0.AND.(ckin(3).GT.ptmn.OR.
3128  & ((msel.NE.1.AND.msel.NE.2)))) mstp(82)=min(1,mstp(82))
3129  IF((mint(49).NE.0.OR.mstp(131).NE.0).AND.mstp(82).GE.2) THEN
3130  mint(35)=1
3131  CALL pymult(1)
3132  mint(35)=3
3133  CALL pymign(1)
3134  ENDIF
3135  ENDIF
3136 
3137 C...Save results for gamma-p and gamma-gamma alternatives.
3138  IF(mint(121).GT.1) CALL pysave(1,iga)
3139  160 CONTINUE
3140 
3141 C...Initialization finished.
3142  IF(msav48.EQ.0) THEN
3143  IF(mstp(127).NE.1) THEN
3144  WRITE(mstu(11),5500)
3145  CALL pystop(1)
3146  ELSE
3147  WRITE(mstu(11),5700)
3148  msti(53)=1
3149  ENDIF
3150  ENDIF
3151  170 IF(mstp(122).GE.1) WRITE(mstu(11),5600)
3152 
3153 C...Formats for initialization information.
3154  5100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',
3155  &'routines',1x,17('*'))
3156  5200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,
3157  &'-',a6,' interactions.'/1x,'Execution stopped!')
3158  5300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/
3159  &1x,'Execution stopped!')
3160  5400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/
3161  &1x,'Execution stopped!')
3162  5500 FORMAT(1x,'Error: no subprocess switched on.'/
3163  &1x,'Execution stopped.')
3164  5600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,
3165  &22('*'))
3166  5700 FORMAT(1x,'Error: no subprocess switched on.'/
3167  &1x,'Execution will stop if you try to generate events.')
3168 
3169  RETURN
3170  END
3171 
3172 C*********************************************************************
3173 
3174 C...PYEVNT
3175 C...Administers the generation of a high-pT event via calls to
3176 C...a number of subroutines.
3177 
3178  SUBROUTINE pyevnt
3179 
3180 C...Double precision and integer declarations.
3181  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3182  IMPLICIT INTEGER(i-n)
3183  INTEGER pyk,pychge,pycomp
3184  parameter(maxnur=1000)
3185 C...Commonblocks.
3186  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
3187  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3188  common/pyctag/nct,mct(4000,2)
3189  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3190  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3191  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
3192  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3193  common/pyint1/mint(400),vint(400)
3194  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3195  common/pyint4/mwid(500),wids(500,5)
3196  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
3197  SAVE /pyjets/,/pydat1/,/pyctag/,/pydat2/,/pydat3/,/pypars/,
3198  &/pyint1/,/pyint2/,/pyint4/,/pyint5/
3199 C...Local array.
3200  dimension vtx(4)
3201 
3202 C...Optionally let PYEVNW do the whole job.
3203  IF(mstp(81).GE.20) THEN
3204  CALL pyevnw
3205  RETURN
3206  ENDIF
3207 
3208 C...Stop if no subprocesses on.
3209  IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
3210  WRITE(mstu(11),5100)
3211  CALL pystop(1)
3212  ENDIF
3213 
3214 C...Initial values for some counters.
3215  mstu(1)=0
3216  mstu(2)=0
3217  n=0
3218  mint(5)=mint(5)+1
3219  mint(7)=0
3220  mint(8)=0
3221  mint(30)=0
3222  mint(83)=0
3223  mint(84)=mstp(126)
3224  mstu(24)=0
3225  mstu70=0
3226  mstj14=mstj(14)
3227 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3228  nct=0
3229  mint(33)=0
3230 
3231 C...Let called routines know call is from PYEVNT (not PYEVNW).
3232  mint(35)=1
3233  IF (mstp(81).GE.10) mint(35)=2
3234 
3235 C...If variable energies: redo incoming kinematics and cross-section.
3236  msti(61)=0
3237  IF(mstp(171).EQ.1) THEN
3238  CALL pyinki(1)
3239  IF(msti(61).EQ.1) THEN
3240  mint(5)=mint(5)-1
3241  RETURN
3242  ENDIF
3243  IF(mint(121).GT.1) CALL pysave(3,1)
3244  CALL pyxtot
3245  ENDIF
3246 
3247 C...Loop over number of pileup events; check space left.
3248  IF(mstp(131).LE.0) THEN
3249  npile=1
3250  ELSE
3251  CALL pypile(2)
3252  npile=mint(81)
3253  ENDIF
3254  DO 270 ipile=1,npile
3255  IF(mint(84)+100.GE.mstu(4)) THEN
3256  CALL pyerrm(11,
3257  & '(PYEVNT:) no more space in PYJETS for pileup events')
3258  IF(mstu(21).GE.1) goto 280
3259  ENDIF
3260  mint(82)=ipile
3261 
3262 C...Generate variables of hard scattering.
3263  mint(51)=0
3264  msti(52)=0
3265  100 CONTINUE
3266  IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
3267  mint(31)=0
3268  mint(39)=0
3269  mint(51)=0
3270  mint(57)=0
3271  CALL pyrand
3272  IF(msti(61).EQ.1) THEN
3273  mint(5)=mint(5)-1
3274  RETURN
3275  ENDIF
3276  IF(mint(51).EQ.2) RETURN
3277  isub=mint(1)
3278  IF(mstp(111).EQ.-1) goto 260
3279 
3280 C...Loopback point if PYPREP fails, especially for junction topologies.
3281  nprep=0
3282  mnt31s=mint(31)
3283  110 nprep=nprep+1
3284  mint(31)=mnt31s
3285 
3286  IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
3287 C...Hard scattering (including low-pT):
3288 C...reconstruct kinematics and colour flow of hard scattering.
3289  mint31=mint(31)
3290  120 mint(31)=mint31
3291  mint(51)=0
3292  CALL pyscat
3293  IF(mint(51).EQ.1) goto 100
3294  ipu1=mint(84)+1
3295  ipu2=mint(84)+2
3296  IF(isub.EQ.95) goto 140
3297 
3298 C...Reset statistics on activity in event.
3299  DO 130 j=351,359
3300  mint(j)=0
3301  vint(j)=0d0
3302  130 CONTINUE
3303 
3304 C...Showering of initial state partons (optional).
3305  nfin=n
3306  alamsv=parj(81)
3307  parj(81)=parp(72)
3308  IF(mstp(61).GE.1.AND.mint(47).GE.2.AND.mint(111).NE.12)
3309  & CALL pysspa(ipu1,ipu2)
3310  parj(81)=alamsv
3311  IF(mint(51).EQ.1) goto 100
3312 
3313 C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3314  IF (npart.GE.2.AND.(mstj(41).EQ.11.OR.mstj(41).EQ.12)) THEN
3315  ptmax=0.5*sqrt(parp(71))*vint(55)
3316  CALL pyptfs(3,ptmax,0d0,ptgen)
3317  ENDIF
3318 
3319 C...Showering of final state partons (optional).
3320  alamsv=parj(81)
3321  parj(81)=parp(72)
3322  IF(mstp(71).GE.1.AND.iset(isub).GE.2.AND.iset(isub).LE.10)
3323  & THEN
3324  ipu3=mint(84)+3
3325  ipu4=mint(84)+4
3326  IF(iset(isub).EQ.5) ipu4=-3
3327  qmax=vint(55)
3328  IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
3329  CALL pyshow(ipu3,ipu4,qmax)
3330  ELSEIF(iset(isub).EQ.11) THEN
3331  CALL pyadsh(nfin)
3332  ENDIF
3333  parj(81)=alamsv
3334 
3335 C...Allow possibility for user to abort event generation.
3336  iveto=0
3337  IF(ipile.EQ.1.AND.mstp(143).EQ.1) CALL pyveto(iveto)
3338  IF(iveto.EQ.1) goto 100
3339 
3340 C...Decay of final state resonances.
3341  mint(32)=0
3342  IF(mstp(41).GE.1.AND.iset(isub).LE.10) CALL pyresd(0)
3343  IF(mint(51).EQ.1) goto 100
3344  mint(52)=n
3345 
3346 
3347 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3348  140 IF(mstp(81).GE.10.AND.mint(50).EQ.1) THEN
3349  IF(isub.EQ.95) mint(31)=mint(31)+1
3350  CALL pymign(6)
3351  IF(mint(51).EQ.1) goto 100
3352  mint(53)=n
3353 
3354 C...Beam remnant flavour and colour assignments - new scheme.
3355  CALL pymihk
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 
3360 C...Primordial kT and beam remnant momentum sharing - new scheme.
3361  CALL pymirm
3362  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3363  & goto 120
3364  IF(mint(51).EQ.1) goto 100
3365  IF(isub.EQ.95) mint(31)=mint(31)-1
3366 
3367 C...Multiple interactions - PYTHIA 6.2 style.
3368  ELSEIF(mint(111).NE.12) THEN
3369  IF (mstp(81).GE.1.AND.mint(50).EQ.1.AND.isub.NE.95) THEN
3370  CALL pymult(6)
3371  mint(53)=n
3372  ENDIF
3373 
3374 C...Hadron remnants and primordial kT.
3375  CALL pyremn(ipu1,ipu2)
3376  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) goto
3377  & 110
3378  IF(mint(51).EQ.1) goto 100
3379  ENDIF
3380 
3381  ELSEIF(isub.NE.99) THEN
3382 C...Diffractive and elastic scattering.
3383  CALL pydiff
3384 
3385  ELSE
3386 C...DIS scattering (photon flux external).
3387  CALL pydisg
3388  IF(mint(51).EQ.1) goto 100
3389  ENDIF
3390 
3391 C...Check that no odd resonance left undecayed.
3392  mint(54)=n
3393  IF(mstp(111).GE.1) THEN
3394  nfix=n
3395  DO 150 i=mint(84)+1,nfix
3396  IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
3397  & k(i,2).NE.22) THEN
3398  kca=pycomp(k(i,2))
3399  IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
3400  CALL pyresd(i)
3401  IF(mint(51).EQ.1) goto 100
3402  ENDIF
3403  ENDIF
3404  150 CONTINUE
3405  ENDIF
3406 
3407 C...Boost hadronic subsystem to overall rest frame.
3408 C..(Only relevant when photon inside lepton beam.)
3409  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
3410 
3411 C...Recalculate energies from momenta and masses (if desired).
3412  IF(mstp(113).GE.1) THEN
3413  DO 160 i=mint(83)+1,n
3414  IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
3415  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3416  160 CONTINUE
3417  nrecal=n
3418  ENDIF
3419 
3420 C...Colour reconnection before string formation
3421  IF (mstp(95).GE.2) CALL pyfscr(mint(84)+1)
3422 
3423 C...Rearrange partons along strings, check invariant mass cuts.
3424  mstu(28)=0
3425  IF(mstp(111).LE.0) mstj(14)=-1
3426  CALL pyprep(mint(84)+1)
3427  mstj(14)=mstj14
3428  IF(mint(51).EQ.1.AND.mstu(24).EQ.1) THEN
3429  mstu(24)=0
3430  goto 100
3431  ENDIF
3432  IF (mint(51).EQ.1.AND.nprep.LE.5) goto 110
3433  IF (mint(51).EQ.1) goto 100
3434  IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) goto 100
3435  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
3436  DO 190 i=mint(84)+1,n
3437  IF(k(i,2).EQ.94) THEN
3438  DO 180 i1=i+1,min(n,i+10)
3439  IF(k(i1,3).EQ.i) THEN
3440  k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
3441  IF(k(i1,3).EQ.0) THEN
3442  DO 170 ii=mint(84)+1,i-1
3443  IF(k(ii,2).EQ.k(i1,2)) THEN
3444  IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
3445  & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
3446  ENDIF
3447  170 CONTINUE
3448  IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
3449  ENDIF
3450  ENDIF
3451  180 CONTINUE
3452  ENDIF
3453  190 CONTINUE
3454  CALL pyedit(12)
3455  CALL pyedit(14)
3456  IF(mstp(125).EQ.0) CALL pyedit(15)
3457  IF(mstp(125).EQ.0) mint(4)=0
3458  DO 210 i=mint(83)+1,n
3459  IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
3460  DO 200 i1=i+1,n
3461  IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
3462  IF(k(i1,3).EQ.i) k(i,5)=i1
3463  200 CONTINUE
3464  ENDIF
3465  210 CONTINUE
3466  ENDIF
3467 
3468 C...Introduce separators between sections in PYLIST event listing.
3469  IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
3470  mstu70=1
3471  mstu(71)=n
3472  ELSEIF(ipile.EQ.1) THEN
3473  mstu70=3
3474  mstu(71)=2
3475  mstu(72)=mint(4)
3476  mstu(73)=n
3477  ENDIF
3478 
3479 C...Go back to lab frame (needed for vertices, also in fragmentation).
3480  CALL pyfram(1)
3481 
3482 C...Set nonvanishing production vertex (optional).
3483  IF(mstp(151).EQ.1) THEN
3484  DO 220 j=1,4
3485  vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
3486  & sin(paru(2)*pyr(0))
3487  220 CONTINUE
3488  DO 240 i=mint(83)+1,n
3489  DO 230 j=1,4
3490  v(i,j)=v(i,j)+vtx(j)
3491  230 CONTINUE
3492  240 CONTINUE
3493  ENDIF
3494 
3495 C...Perform hadronization (if desired).
3496  IF(mstp(111).GE.1) THEN
3497  CALL pyexec
3498  IF(mstu(24).NE.0) goto 100
3499  ENDIF
3500  IF(mstp(113).GE.1) THEN
3501  DO 250 i=nrecal,n
3502  IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
3503  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3504  250 CONTINUE
3505  ENDIF
3506  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
3507 
3508 C...Store event information and calculate Monte Carlo estimates of
3509 C...subprocess cross-sections.
3510  260 IF(ipile.EQ.1) CALL pydocu
3511 
3512 C...Set counters for current pileup event and loop to next one.
3513  msti(41)=ipile
3514  IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
3515  IF(mstu70.LT.10) THEN
3516  mstu70=mstu70+1
3517  mstu(70+mstu70)=n
3518  ENDIF
3519  mint(83)=n
3520  mint(84)=n+mstp(126)
3521  IF(ipile.LT.npile) CALL pyfram(2)
3522  270 CONTINUE
3523 
3524 C...Generic information on pileup events. Reconstruct missing history.
3525  IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
3526  pari(91)=vint(132)
3527  pari(92)=vint(133)
3528  pari(93)=vint(134)
3529  IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
3530  ENDIF
3531  CALL pyedit(16)
3532 
3533 C...Transform to the desired coordinate frame.
3534  280 CALL pyfram(mstp(124))
3535  mstu(70)=mstu70
3536  paru(21)=vint(1)
3537 
3538 C...Error messages
3539  5100 FORMAT(1x,'Error: no subprocess switched on.'/
3540  &1x,'Execution stopped.')
3541 
3542  RETURN
3543  END
3544 
3545 C*********************************************************************
3546 
3547 C...PYEVNW
3548 C...Administers the generation of a high-pT event via calls to
3549 C...a number of subroutines for the new multiple interactions and
3550 C...showering framework.
3551 
3552  SUBROUTINE pyevnw
3553 
3554 C...Double precision and integer declarations.
3555  IMPLICIT DOUBLE PRECISION(a-h, o-z)
3556  IMPLICIT INTEGER(i-n)
3557  INTEGER pyk,pychge,pycomp
3558  parameter(maxnur=1000)
3559 C...Commonblocks.
3560  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
3561 C...Commonblocks.
3562  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3563  common/pyctag/nct,mct(4000,2)
3564  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3565  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3566  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
3567  common/pypars/mstp(200),parp(200),msti(200),pari(200)
3568  common/pyint1/mint(400),vint(400)
3569  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3570  common/pyint4/mwid(500),wids(500,5)
3571  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
3572  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
3573  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
3574  & xmi(2,240),pt2mi(240),imisep(0:240)
3575  SAVE /pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,
3576  & /pypars/,/pyint1/,/pyint2/,/pyint4/,/pyint5/,/pyintm/
3577 C...Local arrays.
3578  dimension vtx(4)
3579 
3580 C...Stop if no subprocesses on.
3581  IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
3582  WRITE(mstu(11),5100)
3583  CALL pystop(1)
3584  ENDIF
3585 
3586 C...Initial values for some counters.
3587  mstu(1)=0
3588  mstu(2)=0
3589  n=0
3590  mint(5)=mint(5)+1
3591  mint(7)=0
3592  mint(8)=0
3593  mint(30)=0
3594  mint(83)=0
3595  mint(84)=mstp(126)
3596  mstu(24)=0
3597  mstu70=0
3598  mstj14=mstj(14)
3599 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3600  nct=0
3601  mint(33)=0
3602 C...Zero counters for pT-ordered showers (failsafe)
3603  npart=0
3604  npartd=0
3605 
3606 C...Let called routines know call is from PYEVNW (not PYEVNT).
3607  mint(35)=3
3608 
3609 C...If variable energies: redo incoming kinematics and cross-section.
3610  msti(61)=0
3611  IF(mstp(171).EQ.1) THEN
3612  CALL pyinki(1)
3613  IF(msti(61).EQ.1) THEN
3614  mint(5)=mint(5)-1
3615  RETURN
3616  ENDIF
3617  IF(mint(121).GT.1) CALL pysave(3,1)
3618  CALL pyxtot
3619  ENDIF
3620 
3621 C...Loop over number of pileup events; check space left.
3622  IF(mstp(131).LE.0) THEN
3623  npile=1
3624  ELSE
3625  CALL pypile(2)
3626  npile=mint(81)
3627  ENDIF
3628  DO 300 ipile=1,npile
3629  IF(mint(84)+100.GE.mstu(4)) THEN
3630  CALL pyerrm(11,
3631  & '(PYEVNW:) no more space in PYJETS for pileup events')
3632  IF(mstu(21).GE.1) goto 310
3633  ENDIF
3634  mint(82)=ipile
3635 
3636 C...Generate variables of hard scattering.
3637  mint(51)=0
3638  msti(52)=0
3639  loophs =0
3640  100 CONTINUE
3641  loophs = loophs + 1
3642  IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
3643  IF(loophs.GE.10) THEN
3644  CALL pyerrm(19,'(PYEVNW:) failed to evolve shower or '
3645  & //'multiple interactions. Returning.')
3646  mint(51)=1
3647  RETURN
3648  ENDIF
3649  mint(31)=0
3650  mint(39)=0
3651  mint(36)=0
3652  mint(51)=0
3653  mint(57)=0
3654  CALL pyrand
3655  IF(msti(61).EQ.1) THEN
3656  mint(5)=mint(5)-1
3657  RETURN
3658  ENDIF
3659  IF(mint(51).EQ.2) RETURN
3660  isub=mint(1)
3661  IF(mstp(111).EQ.-1) goto 290
3662 
3663 C...Loopback point if PYPREP fails, especially for junction topologies.
3664  nprep=0
3665  mnt31s=mint(31)
3666  110 nprep=nprep+1
3667  mint(31)=mnt31s
3668 
3669  IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
3670 C...Hard scattering (including low-pT):
3671 C...reconstruct kinematics and colour flow of hard scattering.
3672  mint31=mint(31)
3673  120 mint(31)=mint31
3674  mint(51)=0
3675  CALL pyscat
3676  IF(mint(51).EQ.1) goto 100
3677  npartd=n
3678  nfin=n
3679 
3680 C...Intertwined initial state showers and multiple interactions.
3681 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3682 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3683  mstp61=mstp(61)
3684  IF (mint(47).LT.2) mstp(61)=0
3685  mstp81=mstp(81)
3686  IF (mint(50).EQ.0) mstp(81)=0
3687  IF ((mstp(61).GE.1.OR.mod(mstp(81),10).GE.0).AND.
3688  & mint(111).NE.12) THEN
3689 C...Absolute max pT2 scale for evolution: phase space limit.
3690  pt2mxs=0.25d0*vint(2)
3691 C...Check if more constrained by ISR and MI max scales:
3692  pt2mxs=min(pt2mxs,max(max(1d0,parp(67))*vint(56),vint(62)))
3693 C...Loopback point in case of failure in evolution.
3694  loop=0
3695  130 loop=loop+1
3696  mint(51)=0
3697  IF(loop.GT.100) THEN
3698  CALL pyerrm(9,'(PYEVNW:) failed to evolve shower or '
3699  & //'multiple interactions. Trying new point.')
3700  mint(51)=1
3701  RETURN
3702  ENDIF
3703 
3704 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3705 C...once per event. (E.g. compute constants and save variables to be
3706 C...restored later in case of failure.)
3707  IF (loop.EQ.1) CALL pyevol(-1,dummy1,dummy2)
3708 
3709 C...Initialize interleaved MI/ISR/JI evolution.
3710 C...PT2MAX: absolute upper limit for evolution - Initialization may
3711 C... return a PT2MAX which is lower than this.
3712 C...PT2MIN: absolute lower limit for evolution - Initialization may
3713 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3714  pt2max=pt2mxs
3715  pt2min=0d0
3716  CALL pyevol(0,pt2max,pt2min)
3717 C...If failed to initialize evolution, generate a new hard process
3718  IF (mint(51).EQ.1) goto 100
3719 
3720 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3721 C...In principle factorized, so can be stopped and restarted.
3722 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3723 C PT2MED=MAX(10D0**2,PT2MIN)
3724 C CALL PYEVOL(1,PT2MAX,PT2MED)
3725 C IF (MINT(51).EQ.1) GOTO 160
3726 C PT2MAX=PT2MED
3727  CALL pyevol(1,pt2max,pt2min)
3728 C...If fatal error (e.g., massive hard-process initiator, but no available
3729 C...phase space for creation), generate a new hard process
3730  IF (mint(51).EQ.2) goto 100
3731 C...If smaller error, just try running evolution again
3732  IF (mint(51).EQ.1) goto 130
3733 
3734 C...Finalize interleaved MI/ISR/JI evolution.
3735  CALL pyevol(2,pt2max,pt2min)
3736  IF (mint(51).EQ.1) goto 130
3737 
3738  ENDIF
3739  mstp(61)=mstp61
3740  mstp(81)=mstp81
3741  IF(mint(51).EQ.1) goto 100
3742 C...(MINT(52) is actually obsolete in this routine. Set anyway
3743 C...to ensure PYDOCU stable.)
3744  mint(52)=n
3745  mint(53)=n
3746 
3747 C...Beam remnants - new scheme.
3748  140 IF(mint(50).EQ.1) THEN
3749  IF (isub.EQ.95) mint(31)=1
3750 
3751 C...Beam remnant flavour and colour assignments - new scheme.
3752  CALL pymihk
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 
3757 C...Primordial kT and beam remnant momentum sharing - new scheme.
3758  CALL pymirm
3759  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3760  & goto 120
3761  IF(mint(51).EQ.1) goto 100
3762  IF (isub.EQ.95) mint(31)=0
3763  ELSEIF(mint(111).NE.12) THEN
3764 C...Hadron remnants and primordial kT - old model.
3765 C...Happens e.g. for direct photon on one side.
3766  ipu1=imi(1,1,1)
3767  ipu2=imi(2,1,1)
3768  CALL pyremn(ipu1,ipu2)
3769  IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) goto
3770  & 110
3771  IF(mint(51).EQ.1) goto 100
3772 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3773  DO 160 i=mint(53)+1,n
3774  DO 150 kcs=4,5
3775  ida=mod(k(i,kcs),mstu(5))
3776  IF (ida.NE.0) THEN
3777  mct(i,kcs-3)=mct(ida,6-kcs)
3778  ELSE
3779  mct(i,kcs-3)=0
3780  ENDIF
3781  150 CONTINUE
3782  160 CONTINUE
3783 C...Instruct PYPREP to use colour tags
3784  mint(33)=1
3785 
3786  DO 360 mqgst=1,2
3787  DO 350 i=mint(84)+1,n
3788 
3789 C...Look for coloured string endpoint, or (later) leftover gluon.
3790  IF (k(i,1).NE.3) goto 350
3791  kc=pycomp(k(i,2))
3792  IF(kc.EQ.0) goto 350
3793  kq=kchg(kc,2)
3794  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 350
3795 
3796 C... Pick up loose string end with no previous tag.
3797  kcs=4
3798  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
3799  IF(mct(i,kcs-3).NE.0) goto 350
3800 
3801  CALL pycttr(i,kcs,i)
3802  IF(mint(51).NE.0) RETURN
3803 
3804  350 CONTINUE
3805  360 CONTINUE
3806 C...Now delete any colour processing information if set (since partons
3807 C...otherwise not FS showered!)
3808  DO 170 i=mint(84)+1,n
3809  IF (i.LE.n) THEN
3810  k(i,4)=mod(k(i,4),mstu(5)**2)
3811  k(i,5)=mod(k(i,5),mstu(5)**2)
3812  ENDIF
3813  170 CONTINUE
3814  ENDIF
3815 
3816 C...Showering of final state partons (optional).
3817  alamsv=parj(81)
3818  parj(81)=parp(72)
3819  IF(mstp(71).GE.1.AND.iset(isub).GE.1.AND.iset(isub).LE.10)
3820  & THEN
3821  qmax=vint(55)
3822  IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
3823  CALL pyptfs(1,qmax,0d0,ptgen)
3824 C...External processes: handle successive showers.
3825  ELSEIF(iset(isub).EQ.11) THEN
3826  CALL pyadsh(nfin)
3827  ENDIF
3828  parj(81)=alamsv
3829 
3830 C...Allow possibility for user to abort event generation.
3831  iveto=0
3832  IF(ipile.EQ.1.AND.mstp(143).EQ.1) CALL pyveto(iveto) ! sm
3833  IF(iveto.EQ.1) THEN
3834 C...........No reason to count this as an error
3835  loophs = loophs-1
3836  goto 100
3837  ENDIF
3838 
3839 
3840 C...Decay of final state resonances.
3841  mint(32)=0
3842  IF(mstp(41).GE.1.AND.iset(isub).LE.10) THEN
3843  CALL pyresd(0)
3844  IF(mint(51).NE.0) goto 100
3845  ENDIF
3846 
3847  IF(mint(51).EQ.1) goto 100
3848 
3849  ELSEIF(isub.NE.99) THEN
3850 C...Diffractive and elastic scattering.
3851  CALL pydiff
3852 
3853  ELSE
3854 C...DIS scattering (photon flux external).
3855  CALL pydisg
3856  IF(mint(51).EQ.1) goto 100
3857  ENDIF
3858 
3859 C...Check that no odd resonance left undecayed.
3860  mint(54)=n
3861  IF(mstp(111).GE.1) THEN
3862  nfix=n
3863  DO 180 i=mint(84)+1,nfix
3864  IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
3865  & k(i,2).NE.22) THEN
3866  kca=pycomp(k(i,2))
3867  IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
3868  CALL pyresd(i)
3869  IF(mint(51).EQ.1) goto 100
3870  ENDIF
3871  ENDIF
3872  180 CONTINUE
3873  ENDIF
3874 
3875 C...Boost hadronic subsystem to overall rest frame.
3876 C..(Only relevant when photon inside lepton beam.)
3877  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
3878 
3879 C...Recalculate energies from momenta and masses (if desired).
3880  IF(mstp(113).GE.1) THEN
3881  DO 190 i=mint(83)+1,n
3882  IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
3883  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3884  190 CONTINUE
3885  nrecal=n
3886  ENDIF
3887 
3888 C...Colour reconnection before string formation
3889  CALL pyfscr(mint(84)+1)
3890 
3891 C...Rearrange partons along strings, check invariant mass cuts.
3892  mstu(28)=0
3893  IF(mstp(111).LE.0) mstj(14)=-1
3894  CALL pyprep(mint(84)+1)
3895  mstj(14)=mstj14
3896  IF(mint(51).EQ.1.AND.mstu(24).EQ.1) THEN
3897  mstu(24)=0
3898  goto 100
3899  ENDIF
3900  IF(mint(51).EQ.1) goto 110
3901  IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) goto 100
3902  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
3903  DO 220 i=mint(84)+1,n
3904  IF(k(i,2).EQ.94) THEN
3905  DO 210 i1=i+1,min(n,i+10)
3906  IF(k(i1,3).EQ.i) THEN
3907  k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
3908  IF(k(i1,3).EQ.0) THEN
3909  DO 200 ii=mint(84)+1,i-1
3910  IF(k(ii,2).EQ.k(i1,2)) THEN
3911  IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
3912  & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
3913  ENDIF
3914  200 CONTINUE
3915  IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
3916  ENDIF
3917  ENDIF
3918  210 CONTINUE
3919 C...Also collapse particles decaying to themselves (if same KS)
3920 C...Sep 22 2009: Commented out by PS following suggestion by TS to fix
3921 C...problem with history point-backs in new shower, where a particle is
3922 C...copied with a new momentum when it is the recoiler.
3923 C ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3924 C & .AND.K(I,4).LT.N) THEN
3925 C IDA=K(I,4)
3926 C IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3927 C K(I,1)=0
3928 C ENDIF
3929  ENDIF
3930  220 CONTINUE
3931  CALL pyedit(12)
3932  CALL pyedit(14)
3933  IF(mstp(125).EQ.0) CALL pyedit(15)
3934  IF(mstp(125).EQ.0) mint(4)=0
3935  DO 240 i=mint(83)+1,n
3936  IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
3937  DO 230 i1=i+1,n
3938  IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
3939  IF(k(i1,3).EQ.i) k(i,5)=i1
3940  230 CONTINUE
3941  ENDIF
3942  240 CONTINUE
3943  ENDIF
3944 
3945 C...Introduce separators between sections in PYLIST event listing.
3946  IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
3947  mstu70=1
3948  mstu(71)=n
3949  ELSEIF(ipile.EQ.1) THEN
3950  mstu70=3
3951  mstu(71)=2
3952  mstu(72)=mint(4)
3953  mstu(73)=n
3954  ENDIF
3955 
3956 C...Go back to lab frame (needed for vertices, also in fragmentation).
3957  CALL pyfram(1)
3958 
3959 C...Set nonvanishing production vertex (optional).
3960  IF(mstp(151).EQ.1) THEN
3961  DO 250 j=1,4
3962  vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
3963  & sin(paru(2)*pyr(0))
3964  250 CONTINUE
3965  DO 270 i=mint(83)+1,n
3966  DO 260 j=1,4
3967  v(i,j)=v(i,j)+vtx(j)
3968  260 CONTINUE
3969  270 CONTINUE
3970  ENDIF
3971 
3972 C...Perform hadronization (if desired).
3973  IF(mstp(111).GE.1) THEN
3974  CALL pyexec
3975  IF(mstu(24).NE.0) goto 100
3976  ENDIF
3977  IF(mstp(113).GE.1) THEN
3978  DO 280 i=nrecal,n
3979  IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
3980  & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3981  280 CONTINUE
3982  ENDIF
3983  IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
3984 
3985 C...Store event information and calculate Monte Carlo estimates of
3986 C...subprocess cross-sections.
3987  290 IF(ipile.EQ.1) CALL pydocu
3988 
3989 C...Set counters for current pileup event and loop to next one.
3990  msti(41)=ipile
3991  IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
3992  IF(mstu70.LT.10) THEN
3993  mstu70=mstu70+1
3994  mstu(70+mstu70)=n
3995  ENDIF
3996  mint(83)=n
3997  mint(84)=n+mstp(126)
3998  IF(ipile.LT.npile) CALL pyfram(2)
3999  300 CONTINUE
4000 
4001 C...Generic information on pileup events. Reconstruct missing history.
4002  IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
4003  pari(91)=vint(132)
4004  pari(92)=vint(133)
4005  pari(93)=vint(134)
4006  IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
4007  ENDIF
4008  CALL pyedit(16)
4009 
4010 C...Transform to the desired coordinate frame.
4011  310 CALL pyfram(mstp(124))
4012  mstu(70)=mstu70
4013  paru(21)=vint(1)
4014 
4015 C...Error messages
4016  5100 FORMAT(1x,'Error: no subprocess switched on.'/
4017  &1x,'Execution stopped.')
4018 
4019  RETURN
4020  END
4021 
4022 
4023 C***********************************************************************
4024 
4025 C...PYSTAT
4026 C...Prints out information about cross-sections, decay widths, branching
4027 C...ratios, kinematical limits, status codes and parameter values.
4028 
4029  SUBROUTINE pystat(MSTAT)
4030 
4031 C...Double precision and integer declarations.
4032  IMPLICIT DOUBLE PRECISION(a-h, o-z)
4033  IMPLICIT INTEGER(i-n)
4034  INTEGER pyk,pychge,pycomp
4035 C...Parameter statement to help give large particle numbers.
4036  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
4037  &kexcit=4000000,kdimen=5000000)
4038  parameter(eps=1d-3)
4039 C...Commonblocks.
4040  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4041  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4042  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
4043  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
4044  common/pypars/mstp(200),parp(200),msti(200),pari(200)
4045  common/pyint1/mint(400),vint(400)
4046  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4047  common/pyint4/mwid(500),wids(500,5)
4048  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
4049  common/pyint6/proc(0:500)
4050  CHARACTER proc*28, chtmp*16
4051  common/pymssm/imss(0:99),rmss(0:99)
4052  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
4053  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
4054  &/pyint2/,/pyint4/,/pyint5/,/pyint6/,/pymssm/,/pymsrv/
4055 C...Local arrays, character variables and data.
4056  dimension wdtp(0:400),wdte(0:400,0:5),nmodes(0:20),pbrat(10)
4057  CHARACTER proga(6)*28,chau*16,chkf*16,chd1*16,chd2*16,chd3*16,
4058  &chin(2)*12,state(-1:5)*4,chkin(21)*18,disga(2)*28,
4059  &progg9(13)*28,progg4(4)*28,progg2(2)*28,progp4(4)*28
4060  CHARACTER*24 chd0, chdc(10)
4061  CHARACTER*6 dname(3)
4062  DATA proga/
4063  &'VMD/hadron * VMD ','VMD/hadron * direct ',
4064  &'VMD/hadron * anomalous ','direct * direct ',
4065  &'direct * anomalous ','anomalous * anomalous '/
4066  DATA disga/'e * VMD','e * anomalous'/
4067  DATA progg9/
4068  &'direct * direct ','direct * VMD ',
4069  &'direct * anomalous ','VMD * direct ',
4070  &'VMD * VMD ','VMD * anomalous ',
4071  &'anomalous * direct ','anomalous * VMD ',
4072  &'anomalous * anomalous ','DIS * VMD ',
4073  &'DIS * anomalous ','VMD * DIS ',
4074  &'anomalous * DIS '/
4075  DATA progg4/
4076  &'direct * direct ','direct * resolved ',
4077  &'resolved * direct ','resolved * resolved '/
4078  DATA progg2/
4079  &'direct * hadron ','resolved * hadron '/
4080  DATA progp4/
4081  &'VMD * hadron ','direct * hadron ',
4082  &'anomalous * hadron ','DIS * hadron '/
4083  DATA state/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4084  &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4085  &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4086  &' y*_small ',' eta*_large ',' eta*_small ',
4087  &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4088  &' x_2 ',' x_F ',' cos(theta_hard) ',
4089  &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4090  &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4091  &' tau'' '/
4092  DATA dname /'q ','lepton','nu '/
4093 
4094 C...Cross-sections.
4095  IF(mstat.LE.1) THEN
4096  IF(mint(121).GT.1) CALL pysave(5,0)
4097  WRITE(mstu(11),5000)
4098  WRITE(mstu(11),5100)
4099  WRITE(mstu(11),5200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)
4100  DO 100 i=1,500
4101  IF(msub(i).NE.1) goto 100
4102  WRITE(mstu(11),5200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)
4103  100 CONTINUE
4104  IF(mint(121).GT.1) THEN
4105  WRITE(mstu(11),5300)
4106  DO 110 iga=1,mint(121)
4107  CALL pysave(3,iga)
4108  IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
4109  WRITE(mstu(11),5200) iga,disga(iga),ngen(0,3),ngen(0,1),
4110  & xsec(0,3)
4111  ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
4112  WRITE(mstu(11),5200) iga,progg9(iga),ngen(0,3),ngen(0,1),
4113  & xsec(0,3)
4114  ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.30) THEN
4115  WRITE(mstu(11),5200) iga,progp4(iga),ngen(0,3),ngen(0,1),
4116  & xsec(0,3)
4117  ELSEIF(mint(121).EQ.4) THEN
4118  WRITE(mstu(11),5200) iga,progg4(iga),ngen(0,3),ngen(0,1),
4119  & xsec(0,3)
4120  ELSEIF(mint(121).EQ.2) THEN
4121  WRITE(mstu(11),5200) iga,progg2(iga),ngen(0,3),ngen(0,1),
4122  & xsec(0,3)
4123  ELSE
4124  WRITE(mstu(11),5200) iga,proga(iga),ngen(0,3),ngen(0,1),
4125  & xsec(0,3)
4126  ENDIF
4127  110 CONTINUE
4128  CALL pysave(5,0)
4129  ENDIF
4130  WRITE(mstu(11),5400) mstu(23),mstu(30),mstu(27),
4131  & 1d0-dble(ngen(0,3))/max(1d0,dble(ngen(0,2)))
4132 
4133 C...Decay widths and branching ratios.
4134  ELSEIF(mstat.EQ.2) THEN
4135  WRITE(mstu(11),5500)
4136  WRITE(mstu(11),5600)
4137  DO 140 kc=1,500
4138  kf=kchg(kc,4)
4139  CALL pyname(kf,chkf)
4140  ioff=0
4141  IF(kc.LE.22) THEN
4142  IF(kc.GT.2*mstp(1).AND.kc.LE.10) goto 140
4143  IF(kc.GT.10+2*mstp(1).AND.kc.LE.20) goto 140
4144  IF(kc.LE.5.OR.(kc.GE.11.AND.kc.LE.16)) ioff=1
4145  IF(kc.EQ.18.AND.pmas(18,1).LT.1d0) ioff=1
4146  IF(kc.EQ.21.OR.kc.EQ.22) ioff=1
4147  ELSE
4148  IF(mwid(kc).LE.0) goto 140
4149  IF(imss(1).LE.0.AND.(kf/ksusy1.EQ.1.OR.
4150  & kf/ksusy1.EQ.2)) goto 140
4151  ENDIF
4152 C...Off-shell branchings.
4153  IF(ioff.EQ.1) THEN
4154  ngp=0
4155  IF(kc.LE.20) ngp=(mod(kc,10)+1)/2
4156  IF(ngp.LE.mstp(1)) WRITE(mstu(11),5700) kf,chkf(1:10),
4157  & pmas(kc,1),0d0,0d0,state(mdcy(kc,1)),0d0
4158  DO 120 j=1,mdcy(kc,3)
4159  idc=j+mdcy(kc,2)-1
4160  ngp1=0
4161  IF(iabs(kfdp(idc,1)).LE.20) ngp1=
4162  & (mod(iabs(kfdp(idc,1)),10)+1)/2
4163  ngp2=0
4164  IF(iabs(kfdp(idc,2)).LE.20) ngp2=
4165  & (mod(iabs(kfdp(idc,2)),10)+1)/2
4166  CALL pyname(kfdp(idc,1),chd1)
4167  CALL pyname(kfdp(idc,2),chd2)
4168  IF(kfdp(idc,3).EQ.0) THEN
4169  IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
4170  & ngp2.LE.mstp(1)) WRITE(mstu(11),5800) idc,chd1(1:10),
4171  & chd2(1:10),0d0,0d0,state(mdme(idc,1)),0d0
4172  ELSE
4173  CALL pyname(kfdp(idc,3),chd3)
4174  IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
4175  & ngp2.LE.mstp(1)) WRITE(mstu(11),5900) idc,chd1(1:10),
4176  & chd2(1:10),chd3(1:10),0d0,0d0,state(mdme(idc,1)),0d0
4177  ENDIF
4178  120 CONTINUE
4179 C...On-shell decays.
4180  ELSE
4181  CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
4182  brfin=1d0
4183  IF(wdte(0,0).LE.0d0) brfin=0d0
4184  WRITE(mstu(11),5700) kf,chkf(1:10),pmas(kc,1),wdtp(0),1d0,
4185  & state(mdcy(kc,1)),brfin
4186  DO 130 j=1,mdcy(kc,3)
4187  idc=j+mdcy(kc,2)-1
4188  ngp1=0
4189  IF(iabs(kfdp(idc,1)).LE.20) ngp1=
4190  & (mod(iabs(kfdp(idc,1)),10)+1)/2
4191  ngp2=0
4192  IF(iabs(kfdp(idc,2)).LE.20) ngp2=
4193  & (mod(iabs(kfdp(idc,2)),10)+1)/2
4194  brpri=0d0
4195  IF(wdtp(0).GT.0d0) brpri=wdtp(j)/wdtp(0)
4196  brfin=0d0
4197  IF(wdte(0,0).GT.0d0) brfin=wdte(j,0)/wdte(0,0)
4198  CALL pyname(kfdp(idc,1),chd1)
4199  CALL pyname(kfdp(idc,2),chd2)
4200  IF(kfdp(idc,3).EQ.0) THEN
4201  IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
4202  & WRITE(mstu(11),5800) idc,chd1(1:10),
4203  & chd2(1:10),wdtp(j),brpri,
4204  & state(mdme(idc,1)),brfin
4205  ELSE
4206  CALL pyname(kfdp(idc,3),chd3)
4207  IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
4208  & WRITE(mstu(11),5900) idc,chd1(1:10),
4209  & chd2(1:10),chd3(1:10),wdtp(j),brpri,
4210  & state(mdme(idc,1)),brfin
4211  ENDIF
4212  130 CONTINUE
4213  ENDIF
4214  140 CONTINUE
4215  WRITE(mstu(11),6000)
4216 
4217 C...Allowed incoming partons/particles at hard interaction.
4218  ELSEIF(mstat.EQ.3) THEN
4219  WRITE(mstu(11),6100)
4220  CALL pyname(mint(11),chau)
4221  chin(1)=chau(1:12)
4222  CALL pyname(mint(12),chau)
4223  chin(2)=chau(1:12)
4224  WRITE(mstu(11),6200) chin(1),chin(2)
4225  DO 150 i=-20,22
4226  IF(i.EQ.0) goto 150
4227  ia=iabs(i)
4228  IF(ia.GT.mstp(58).AND.ia.LE.10) goto 150
4229  IF(ia.GT.10+2*mstp(1).AND.ia.LE.20) goto 150
4230  CALL pyname(i,chau)
4231  WRITE(mstu(11),6300) chau,state(kfin(1,i)),chau,
4232  & state(kfin(2,i))
4233  150 CONTINUE
4234  WRITE(mstu(11),6400)
4235 
4236 C...User-defined limits on kinematical variables.
4237  ELSEIF(mstat.EQ.4) THEN
4238  WRITE(mstu(11),6500)
4239  WRITE(mstu(11),6600)
4240  shrmax=ckin(2)
4241  IF(shrmax.LT.0d0) shrmax=vint(1)
4242  WRITE(mstu(11),6700) ckin(1),chkin(1),shrmax
4243  pthmin=max(ckin(3),ckin(5))
4244  pthmax=ckin(4)
4245  IF(pthmax.LT.0d0) pthmax=0.5d0*shrmax
4246  WRITE(mstu(11),6800) ckin(3),pthmin,chkin(2),pthmax
4247  WRITE(mstu(11),6900) chkin(3),ckin(6)
4248  DO 160 i=4,14
4249  WRITE(mstu(11),6700) ckin(2*i-1),chkin(i),ckin(2*i)
4250  160 CONTINUE
4251  sprmax=ckin(32)
4252  IF(sprmax.LT.0d0) sprmax=vint(1)
4253  WRITE(mstu(11),6700) ckin(31),chkin(15),sprmax
4254  WRITE(mstu(11),7000)
4255 
4256 C...Status codes and parameter values.
4257  ELSEIF(mstat.EQ.5) THEN
4258  WRITE(mstu(11),7100)
4259  WRITE(mstu(11),7200)
4260  DO 170 i=1,100
4261  WRITE(mstu(11),7300) i,mstp(i),parp(i),100+i,mstp(100+i),
4262  & parp(100+i)
4263  170 CONTINUE
4264 
4265 C...List of all processes implemented in the program.
4266  ELSEIF(mstat.EQ.6) THEN
4267  WRITE(mstu(11),7400)
4268  WRITE(mstu(11),7500)
4269  DO 180 i=1,500
4270  IF(iset(i).LT.0) goto 180
4271  WRITE(mstu(11),7600) i,proc(i),iset(i),kfpr(i,1),kfpr(i,2)
4272  180 CONTINUE
4273  WRITE(mstu(11),7700)
4274 
4275  ELSEIF(mstat.EQ.7) THEN
4276  WRITE (mstu(11),8000)
4277  nmodes(0)=0
4278  nmodes(10)=0
4279  nmodes(9)=0
4280  DO 290 ilr=1,2
4281  DO 280 kfsm=1,16
4282  kfsusy=ilr*ksusy1+kfsm
4283  nrvdc=0
4284 C...SDOWN DECAYS
4285  IF (kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5) THEN
4286  nrvdc=3
4287  DO 190 i=1,nrvdc
4288  pbrat(i)=0d0
4289  nmodes(i)=0
4290  190 CONTINUE
4291  CALL pyname(kfsusy,chtmp)
4292  chd0=chtmp//' '
4293  chdc(1)=dname(3) // ' + ' // dname(1)
4294  chdc(2)=dname(2) // ' + ' // dname(1)
4295  chdc(3)=dname(1) // ' + ' // dname(1)
4296  kc=pycomp(kfsusy)
4297  DO 200 j=1,mdcy(kc,3)
4298  idc=j+mdcy(kc,2)-1
4299  id1=iabs(kfdp(idc,1))
4300  id2=iabs(kfdp(idc,2))
4301  IF (kfdp(idc,3).EQ.0) THEN
4302  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4303  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4304  pbrat(1)=pbrat(1)+brat(idc)
4305  nmodes(1)=nmodes(1)+1
4306  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4307  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4308  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4309  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6)) THEN
4310  pbrat(2)=pbrat(2)+brat(idc)
4311  nmodes(2)=nmodes(2)+1
4312  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4313  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4314  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4315  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4316  pbrat(3)=pbrat(3)+brat(idc)
4317  nmodes(3)=nmodes(3)+1
4318  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4319  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4320  ENDIF
4321  ENDIF
4322  200 CONTINUE
4323  ENDIF
4324 C...SUP DECAYS
4325  IF (kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6) THEN
4326  nrvdc=2
4327  DO 210 i=1,nrvdc
4328  nmodes(i)=0
4329  pbrat(i)=0d0
4330  210 CONTINUE
4331  CALL pyname(kfsusy,chtmp)
4332  chd0=chtmp//' '
4333  chdc(1)=dname(2) // ' + ' // dname(1)
4334  chdc(2)=dname(1) // ' + ' // dname(1)
4335  kc=pycomp(kfsusy)
4336  DO 220 j=1,mdcy(kc,3)
4337  idc=j+mdcy(kc,2)-1
4338  id1=iabs(kfdp(idc,1))
4339  id2=iabs(kfdp(idc,2))
4340  IF (kfdp(idc,3).EQ.0) THEN
4341  IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).AND.(id2
4342  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4343  pbrat(1)=pbrat(1)+brat(idc)
4344  nmodes(1)=nmodes(1)+1
4345  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4346  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4347  ELSE IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).AND.(id2
4348  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4349  pbrat(2)=pbrat(2)+brat(idc)
4350  nmodes(2)=nmodes(2)+1
4351  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4352  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4353  ENDIF
4354  ENDIF
4355  220 CONTINUE
4356  ENDIF
4357 C...SLEPTON DECAYS
4358  IF (kfsm.EQ.11.OR.kfsm.EQ.13.OR.kfsm.EQ.15) THEN
4359  nrvdc=2
4360  DO 230 i=1,nrvdc
4361  pbrat(i)=0d0
4362  nmodes(i)=0
4363  230 CONTINUE
4364  CALL pyname(kfsusy,chtmp)
4365  chd0=chtmp//' '
4366  chdc(1)=dname(3) // ' + ' // dname(2)
4367  chdc(2)=dname(1) // ' + ' // dname(1)
4368  kc=pycomp(kfsusy)
4369  DO 240 j=1,mdcy(kc,3)
4370  idc=j+mdcy(kc,2)-1
4371  id1=iabs(kfdp(idc,1))
4372  id2=iabs(kfdp(idc,2))
4373  IF (kfdp(idc,3).EQ.0) THEN
4374  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4375  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15)) THEN
4376  pbrat(1)=pbrat(1)+brat(idc)
4377  nmodes(1)=nmodes(1)+1
4378  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4379  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4380  ENDIF
4381  IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).AND.(id2
4382  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4383  pbrat(2)=pbrat(2)+brat(idc)
4384  nmodes(2)=nmodes(2)+1
4385  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4386  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4387  ENDIF
4388  ENDIF
4389  240 CONTINUE
4390  ENDIF
4391 C...SNEUTRINO DECAYS
4392  IF ((kfsm.EQ.12.OR.kfsm.EQ.14.OR.kfsm.EQ.16).AND.ilr.EQ.1)
4393  & THEN
4394  nrvdc=2
4395  DO 250 i=1,nrvdc
4396  pbrat(i)=0d0
4397  nmodes(i)=0
4398  250 CONTINUE
4399  CALL pyname(kfsusy,chtmp)
4400  chd0=chtmp//' '
4401  chdc(1)=dname(2) // ' + ' // dname(2)
4402  chdc(2)=dname(1) // ' + ' // dname(1)
4403  kc=pycomp(kfsusy)
4404  DO 260 j=1,mdcy(kc,3)
4405  idc=j+mdcy(kc,2)-1
4406  id1=iabs(kfdp(idc,1))
4407  id2=iabs(kfdp(idc,2))
4408  IF (kfdp(idc,3).EQ.0) THEN
4409  IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).AND.(id2
4410  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15)) THEN
4411  pbrat(1)=pbrat(1)+brat(idc)
4412  nmodes(1)=nmodes(1)+1
4413  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4414  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4415  ENDIF
4416  IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).AND.(id2
4417  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4418  nmodes(2)=nmodes(2)+1
4419  pbrat(2)=pbrat(2)+brat(idc)
4420  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4421  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4422  ENDIF
4423  ENDIF
4424  260 CONTINUE
4425  ENDIF
4426  IF (nrvdc.NE.0) THEN
4427  DO 270 i=1,nrvdc
4428  WRITE (mstu(11),8200) chd0, chdc(i), pbrat(i), nmodes(i)
4429  nmodes(0)=nmodes(0)+nmodes(i)
4430  270 CONTINUE
4431  ENDIF
4432  280 CONTINUE
4433  290 CONTINUE
4434  DO 370 kfsm=21,37
4435  kfsusy=ksusy1+kfsm
4436  nrvdc=0
4437 C...NEUTRALINO DECAYS
4438  IF (kfsm.EQ.22.OR.kfsm.EQ.23.OR.kfsm.EQ.25.OR.kfsm.EQ.35) THEN
4439  nrvdc=4
4440  DO 300 i=1,nrvdc
4441  pbrat(i)=0d0
4442  nmodes(i)=0
4443  300 CONTINUE
4444  CALL pyname(kfsusy,chtmp)
4445  chd0=chtmp//' '
4446  chdc(1)=dname(3) // ' + ' // dname(2) // ' + ' // dname(2)
4447  chdc(2)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4448  chdc(3)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4449  chdc(4)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4450  kc=pycomp(kfsusy)
4451  DO 310 j=1,mdcy(kc,3)
4452  idc=j+mdcy(kc,2)-1
4453  id1=iabs(kfdp(idc,1))
4454  id2=iabs(kfdp(idc,2))
4455  id3=iabs(kfdp(idc,3))
4456  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4457  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.EQ.11.or
4458  & .id3.EQ.13.OR.id3.EQ.15)) THEN
4459  pbrat(1)=pbrat(1)+brat(idc)
4460  nmodes(1)=nmodes(1)+1
4461  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4462  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4463  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4464  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4465  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4466  pbrat(2)=pbrat(2)+brat(idc)
4467  nmodes(2)=nmodes(2)+1
4468  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4469  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4470  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4471  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.EQ.1
4472  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4473  pbrat(3)=pbrat(3)+brat(idc)
4474  nmodes(3)=nmodes(3)+1
4475  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4476  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4477  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4478  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4479  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4480  pbrat(4)=pbrat(4)+brat(idc)
4481  nmodes(4)=nmodes(4)+1
4482  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4483  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4484  ENDIF
4485  310 CONTINUE
4486  ENDIF
4487 C...CHARGINO DECAYS
4488  IF (kfsm.EQ.24.OR.kfsm.EQ.37) THEN
4489  nrvdc=5
4490  DO 320 i=1,nrvdc
4491  pbrat(i)=0d0
4492  nmodes(i)=0
4493  320 CONTINUE
4494  CALL pyname(kfsusy,chtmp)
4495  chd0=chtmp//' '
4496  chdc(1)=dname(3) // ' + ' // dname(3) // ' + ' // dname(2)
4497  chdc(2)=dname(2) // ' + ' // dname(2) // ' + ' // dname(2)
4498  chdc(3)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4499  chdc(4)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4500  chdc(5)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4501  kc=pycomp(kfsusy)
4502  DO 330 j=1,mdcy(kc,3)
4503  idc=j+mdcy(kc,2)-1
4504  id1=iabs(kfdp(idc,1))
4505  id2=iabs(kfdp(idc,2))
4506  id3=iabs(kfdp(idc,3))
4507  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4508  & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.EQ.12.or
4509  & .id3.EQ.14.OR.id3.EQ.16)) THEN
4510  pbrat(1)=pbrat(1)+brat(idc)
4511  nmodes(1)=nmodes(1)+1
4512  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4513  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4514  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4515  & .(id2.EQ.12.OR.id2.EQ.14.OR.id2.EQ.16).AND.(id3.eq
4516  & .11.OR.id3.EQ.13.OR.id3.EQ.15)) THEN
4517  pbrat(1)=pbrat(1)+brat(idc)
4518  nmodes(1)=nmodes(1)+1
4519  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4520  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4521  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4522  & .(id2.EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.eq
4523  & .11.OR.id3.EQ.13.OR.id3.EQ.15)) THEN
4524  pbrat(2)=pbrat(2)+brat(idc)
4525  nmodes(2)=nmodes(2)+1
4526  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4527  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4528  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4529  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4530  & .2.OR.id3.EQ.4.OR.id3.EQ.6)) THEN
4531  pbrat(3)=pbrat(3)+brat(idc)
4532  nmodes(3)=nmodes(3)+1
4533  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4534  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4535  ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4536  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4537  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4538  pbrat(3)=pbrat(3)+brat(idc)
4539  nmodes(3)=nmodes(3)+1
4540  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4541  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4542  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4543  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4544  & .2.OR.id3.EQ.4.OR.id3.EQ.6)) THEN
4545  pbrat(4)=pbrat(4)+brat(idc)
4546  nmodes(4)=nmodes(4)+1
4547  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4548  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4549  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4550  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4551  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4552  pbrat(4)=pbrat(4)+brat(idc)
4553  nmodes(4)=nmodes(4)+1
4554  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4555  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4556  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4557  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4558  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4559  pbrat(5)=pbrat(5)+brat(idc)
4560  nmodes(5)=nmodes(5)+1
4561  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4562  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4563  ELSE IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).and
4564  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4565  & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4566  pbrat(5)=pbrat(5)+brat(idc)
4567  nmodes(5)=nmodes(5)+1
4568  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4569  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4570  ENDIF
4571  330 CONTINUE
4572  ENDIF
4573 C...GLUINO DECAYS
4574  IF (kfsm.EQ.21) THEN
4575  nrvdc=3
4576  DO 340 i=1,nrvdc
4577  pbrat(i)=0d0
4578  nmodes(i)=0
4579  340 CONTINUE
4580  CALL pyname(kfsusy,chtmp)
4581  chd0=chtmp//' '
4582  chdc(1)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4583  chdc(2)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4584  chdc(3)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4585  kc=pycomp(kfsusy)
4586  DO 350 j=1,mdcy(kc,3)
4587  idc=j+mdcy(kc,2)-1
4588  id1=iabs(kfdp(idc,1))
4589  id2=iabs(kfdp(idc,2))
4590  id3=iabs(kfdp(idc,3))
4591  IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4592  & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1.or
4593  & .id3.EQ.3.OR.id3.EQ.5)) THEN
4594  pbrat(1)=pbrat(1)+brat(idc)
4595  nmodes(1)=nmodes(1)+1
4596  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4597  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4598  ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4599  & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.EQ.1
4600  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4601  pbrat(2)=pbrat(2)+brat(idc)
4602  nmodes(2)=nmodes(2)+1
4603  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4604  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4605  ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4606  & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4607  & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4608  pbrat(3)=pbrat(3)+brat(idc)
4609  nmodes(3)=nmodes(3)+1
4610  IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4611  IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4612  ENDIF
4613  350 CONTINUE
4614  ENDIF
4615 
4616  IF (nrvdc.NE.0) THEN
4617  DO 360 i=1,nrvdc
4618  WRITE (mstu(11),8200) chd0, chdc(i), pbrat(i), nmodes(i)
4619  nmodes(0)=nmodes(0)+nmodes(i)
4620  360 CONTINUE
4621  ENDIF
4622  370 CONTINUE
4623  WRITE (mstu(11),8100) nmodes(0), nmodes(10), nmodes(9)
4624 
4625  IF (imss(51).GE.1.OR.imss(52).GE.1.OR.imss(53).GE.1) THEN
4626  WRITE (mstu(11),8500)
4627  DO 400 irv=1,3
4628  DO 390 jrv=1,3
4629  DO 380 krv=1,3
4630  WRITE (mstu(11),8700) irv,jrv,krv,rvlam(irv,jrv,krv)
4631  & ,rvlamp(irv,jrv,krv),rvlamb(irv,jrv,krv)
4632  380 CONTINUE
4633  390 CONTINUE
4634  400 CONTINUE
4635  WRITE (mstu(11),8600)
4636  ENDIF
4637  ENDIF
4638 
4639 C...Formats for printouts.
4640  5000 FORMAT('1',9('*'),1x,'PYSTAT: Statistics on Number of ',
4641  &'Events and Cross-sections',1x,9('*'))
4642  5100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x,
4643  &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,
4644  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),
4645  &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,
4646  &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x,
4647  &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x,
4648  &'I',12x,'I')
4649  5200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p,
4650  &d10.3,1x,'I')
4651  5300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/
4652  &1x,'I',34x,'I',28x,'I',12x,'I')
4653  5400 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//
4654  &1x,'********* Total number of errors, excluding junctions =',
4655  &1x,i8,' *************'/
4656  &1x,'********* Total number of errors, including junctions =',
4657  &1x,i8,' *************'/
4658  &1x,'********* Total number of warnings = ',
4659  &1x,i8,' *************'/
4660  &1x,'********* Fraction of events that fail fragmentation ',
4661  &'cuts =',1x,f8.5,' *********'/)
4662  5500 FORMAT('1',27('*'),1x,'PYSTAT: Decay Widths and Branching ',
4663  &'Ratios',1x,27('*'))
4664  5600 FORMAT(/1x,98('=')/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
4665  &1x,'I',5x,'Mother --> Branching/Decay Channel',8x,'I',1x,
4666  &'Width (GeV)',1x,'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,
4667  &'Eff. B.R.',1x,'I'/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
4668  &1x,98('='))
4669  5700 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,
4670  &i8,2x,a10,3x,'(m =',f10.3,')',2x,'-->',5x,'I',2x,1p,d10.3,0p,1x,
4671  &'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,d10.3,0p,1x,'I')
4672  5800 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,15x,'I',2x,
4673  &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
4674  &1p,d10.3,0p,1x,'I')
4675  5900 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,1x,'+',1x,a10,2x,'I',2x,
4676  &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
4677  &1p,d10.3,0p,1x,'I')
4678  6000 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,98('='))
4679  6100 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/',
4680  &'Particles at Hard Interaction',1x,7('*'))
4681  6200 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,
4682  &'Beam particle:',1x,a12,10x,'I',1x,'Target particle:',1x,a12,7x,
4683  &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',6x,'State',19x,
4684  &'I',1x,'Content',6x,'State',18x,'I'/1x,'I',38x,'I',37x,'I'/1x,
4685  &78('=')/1x,'I',38x,'I',37x,'I')
4686  6300 FORMAT(1x,'I',1x,a9,5x,a4,19x,'I',1x,a9,5x,a4,18x,'I')
4687  6400 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('='))
4688  6500 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',
4689  &'Kinematical Variables',1x,12('*'))
4690  6600 FORMAT(/1x,78('=')/1x,'I',76x,'I')
4691  6700 FORMAT(1x,'I',16x,1p,d10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,d10.3,0p,
4692  &16x,'I')
4693  6800 FORMAT(1x,'I',3x,1p,d10.3,0p,1x,'(',1p,d10.3,0p,')',1x,'<',1x,a,
4694  &1x,'<',1x,1p,d10.3,0p,16x,'I')
4695  6900 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,d10.3,0p,16x,'I')
4696  7000 FORMAT(1x,'I',76x,'I'/1x,78('='))
4697  7100 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ',
4698  &'Parameter Values',1x,12('*'))
4699  7200 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x,
4700  &'PARP(I)'/)
4701  7300 FORMAT(1x,i3,5x,i6,6x,1p,d10.3,0p,18x,i3,5x,i6,6x,1p,d10.3)
4702  7400 FORMAT('1',13('*'),1x,'PYSTAT: List of implemented processes',
4703  &1x,13('*'))
4704  7500 FORMAT(/1x,65('=')/1x,'I',34x,'I',28x,'I'/1x,'I',12x,
4705  &'Subprocess',12x,'I',1x,'ISET',2x,'KFPR(I,1)',2x,'KFPR(I,2)',1x,
4706  &'I'/1x,'I',34x,'I',28x,'I'/1x,65('=')/1x,'I',34x,'I',28x,'I')
4707  7600 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i4,1x,i10,1x,i10,1x,'I')
4708  7700 FORMAT(1x,'I',34x,'I',28x,'I'/1x,65('='))
4709  8000 FORMAT(1x/ 1x/
4710  & 17x,'Sums over R-Violating branching ratios',1x/ 1x
4711  & /1x,70('=')/1x,'I',50x,'I',11x,'I',5x,'I'/1x,'I',4x
4712  & ,'Mother --> Sum over final state flavours',4x,'I',2x
4713  & ,'BR(sum)',2x,'I',2x,'N',2x,'I'/1x,'I',50x,'I',11x,'I',5x,'I'
4714  & /1x,70('=')/1x,'I',50x,'I',11x,'I',5x,'I')
4715  8100 FORMAT(1x,'I',50x,'I',11x,'I',5x,'I'/1x,70('=')/1x,'I',1x
4716  & ,'Total number of R-Violating modes :',3x,i5,24x,'I'/
4717  & 1x,'I',1x,'Total number with non-vanishing BR :',2x,i5,24x
4718  & ,'I'/1x,'I',1x,'Total number with BR > 0.001 :',8x,i5,24x,'I'
4719  & /1x,70('='))
4720  8200 FORMAT(1x,'I',1x,a9,1x,'-->',1x,a24,11x,
4721  & 'I',2x,1p,d8.2,0p,1x,'I',2x,i2,1x,'I')
4722  8300 FORMAT(1x,'I',50x,'I',11x,'I',5x,'I')
4723  8500 FORMAT(1x/ 1x/
4724  & 1x,'R-Violating couplings',1x/ 1x /
4725  & 1x,55('=')/
4726  & 1x,'I',1x,'IJK',1x,'I',2x,'LAMBDA(IJK)',2x,'I',2x
4727  & ,'LAMBDA''(IJK)',1x,'I',1x,"LAMBDA''(IJK)",1x,'I'/1x,'I',5x
4728  & ,'I',15x,'I',15x,'I',15x,'I')
4729  8600 FORMAT(1x,55('='))
4730  8700 FORMAT(1x,'I',1x,i1,i1,i1,1x,'I',1x,1p,d13.3,0p,1x,'I',1x,1p
4731  & ,d13.3,0p,1x,'I',1x,1p,d13.3,0p,1x,'I')
4732 
4733  RETURN
4734  END
4735 
4736 C*********************************************************************
4737 
4738 C...PYUPEV
4739 C...Administers the hard-process generation required for output to the
4740 C...Les Houches event record.
4741 
4742  SUBROUTINE pyupev
4743 
4744 C...Double precision and integer declarations.
4745  IMPLICIT DOUBLE PRECISION(a-h, o-z)
4746  IMPLICIT INTEGER(i-n)
4747  INTEGER pyk,pychge,pycomp
4748 
4749 C...Commonblocks.
4750  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
4751  common/pyctag/nct,mct(4000,2)
4752  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4753  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4754  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
4755  common/pypars/mstp(200),parp(200),msti(200),pari(200)
4756  common/pyint1/mint(400),vint(400)
4757  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4758  common/pyint4/mwid(500),wids(500,5)
4759  SAVE /pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,/pypars/,
4760  &/pyint1/,/pyint2/,/pyint4/
4761 
4762 C...HEPEUP for output.
4763  INTEGER maxnup
4764  parameter(maxnup=500)
4765  INTEGER nup,idprup,idup,istup,mothup,icolup
4766  DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
4767  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
4768  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
4769  &vtimup(maxnup),spinup(maxnup)
4770  SAVE /hepeup/
4771 
4772 C...Stop if no subprocesses on.
4773  IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
4774  WRITE(mstu(11),5100)
4775  stop
4776  ENDIF
4777 
4778 
4779 C...Special flags for hard-process generation only.
4780  mstp71=mstp(71)
4781  mstp(71)=0
4782  mst128=mstp(128)
4783  mstp(128)=1
4784 
4785 C...Initial values for some counters.
4786  n=0
4787  mint(5)=mint(5)+1
4788  mint(7)=0
4789  mint(8)=0
4790  mint(30)=0
4791  mint(83)=0
4792  mint(84)=mstp(126)
4793  mstu(24)=0
4794  mstu70=0
4795  mstj14=mstj(14)
4796 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4797  mint(33)=0
4798 
4799 C...If variable energies: redo incoming kinematics and cross-section.
4800  msti(61)=0
4801  IF(mstp(171).EQ.1) THEN
4802  CALL pyinki(1)
4803  IF(msti(61).EQ.1) THEN
4804  mint(5)=mint(5)-1
4805  RETURN
4806  ENDIF
4807  IF(mint(121).GT.1) CALL pysave(3,1)
4808  CALL pyxtot
4809  ENDIF
4810 
4811 C...Do not allow pileup events.
4812  mint(82)=1
4813 
4814 C...Generate variables of hard scattering.
4815  mint(51)=0
4816  msti(52)=0
4817  100 CONTINUE
4818  IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
4819  mint(31)=0
4820  mint(51)=0
4821  mint(57)=0
4822  CALL pyrand
4823  IF(msti(61).EQ.1) THEN
4824  mint(5)=mint(5)-1
4825  RETURN
4826  ENDIF
4827  IF(mint(51).EQ.2) RETURN
4828  isub=mint(1)
4829 
4830  IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
4831 C...Hard scattering (including low-pT):
4832 C...reconstruct kinematics and colour flow of hard scattering.
4833  mint31=mint(31)
4834  110 mint(31)=mint31
4835  mint(51)=0
4836  CALL pyscat
4837  IF(mint(51).EQ.1) goto 100
4838  ipu1=mint(84)+1
4839  ipu2=mint(84)+2
4840 
4841 C...Decay of final state resonances.
4842  mint(32)=0
4843  IF(mstp(41).GE.1.AND.iset(isub).LE.10.AND.isub.NE.95)
4844  & CALL pyresd(0)
4845  IF(mint(51).EQ.1) goto 100
4846  mint(52)=n
4847 
4848 C...Longitudinal boost of hard scattering.
4849  betaz=(vint(41)-vint(42))/(vint(41)+vint(42))
4850  CALL pyrobo(mint(84)+1,n,0d0,0d0,0d0,0d0,betaz)
4851 
4852  ELSEIF(isub.NE.99) THEN
4853 C...Diffractive and elastic scattering.
4854  CALL pydiff
4855 
4856  ELSE
4857 C...DIS scattering (photon flux external).
4858  CALL pydisg
4859  IF(mint(51).EQ.1) goto 100
4860  ENDIF
4861 
4862 C...Check that no odd resonance left undecayed.
4863  mint(54)=n
4864  nfix=n
4865  DO 120 i=mint(84)+1,nfix
4866  IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
4867  & k(i,2).NE.22) THEN
4868  kca=pycomp(k(i,2))
4869  IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
4870  CALL pyresd(i)
4871  IF(mint(51).EQ.1) goto 100
4872  ENDIF
4873  ENDIF
4874  120 CONTINUE
4875 C...Add the option to veto or select certain types of events
4876  iveto=0
4877  IF(mstp(143).EQ.1) CALL pyveto(iveto)
4878  IF(iveto.EQ.1) goto 100
4879 
4880 C...Boost hadronic subsystem to overall rest frame.
4881 C..(Only relevant when photon inside lepton beam.)
4882  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
4883 
4884 C...Store event information and calculate Monte Carlo estimates of
4885 C...subprocess cross-sections.
4886  130 CALL pydocu
4887 
4888 C...Transform to the desired coordinate frame.
4889  140 CALL pyfram(mstp(124))
4890  mstu(70)=mstu70
4891  paru(21)=vint(1)
4892 
4893 C...Restore special flags for hard-process generation only.
4894  mstp(71)=mstp71
4895  mstp(128)=mst128
4896 
4897 C...Trace colour tags; convert to LHA style labels.
4898  nct=100
4899  DO 150 i=mint(84)+1,n
4900  mct(i,1)=0
4901  mct(i,2)=0
4902  150 CONTINUE
4903  DO 160 i=mint(84)+1,n
4904  kq=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
4905  IF(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
4906  IF(k(i,4).NE.0.AND.(kq.EQ.1.OR.kq.EQ.2).AND.mct(i,1).EQ.0)
4907  & THEN
4908  imo=mod(k(i,4)/mstu(5),mstu(5))
4909  ida=mod(k(i,4),mstu(5))
4910  IF(imo.NE.0.AND.mod(k(imo,5)/mstu(5),mstu(5)).EQ.i.AND.
4911  & mct(imo,2).NE.0) THEN
4912  mct(i,1)=mct(imo,2)
4913  ELSEIF(imo.NE.0.AND.mod(k(imo,4),mstu(5)).EQ.i.AND.
4914  & mct(imo,1).NE.0) THEN
4915  mct(i,1)=mct(imo,1)
4916  ELSEIF(ida.NE.0.AND.mod(k(ida,5),mstu(5)).EQ.i.AND.
4917  & mct(ida,2).NE.0) THEN
4918  mct(i,1)=mct(ida,2)
4919  ELSE
4920  nct=nct+1
4921  mct(i,1)=nct
4922  ENDIF
4923  ENDIF
4924  IF(k(i,5).NE.0.AND.(kq.EQ.-1.OR.kq.EQ.2).AND.mct(i,2).EQ.0)
4925  & THEN
4926  imo=mod(k(i,5)/mstu(5),mstu(5))
4927  ida=mod(k(i,5),mstu(5))
4928  IF(imo.NE.0.AND.mod(k(imo,4)/mstu(5),mstu(5)).EQ.i.AND.
4929  & mct(imo,1).NE.0) THEN
4930  mct(i,2)=mct(imo,1)
4931  ELSEIF(imo.NE.0.AND.mod(k(imo,5),mstu(5)).EQ.i.AND.
4932  & mct(imo,2).NE.0) THEN
4933  mct(i,2)=mct(imo,2)
4934  ELSEIF(ida.NE.0.AND.mod(k(ida,4),mstu(5)).EQ.i.AND.
4935  & mct(ida,1).NE.0) THEN
4936  mct(i,2)=mct(ida,1)
4937  ELSE
4938  nct=nct+1
4939  mct(i,2)=nct
4940  ENDIF
4941  ENDIF
4942  ENDIF
4943  160 CONTINUE
4944 C...Error checking
4945  IF(msti(52).EQ.0) THEN
4946 
4947 C...Put event in HEPEUP commonblock.
4948  nup=n-mint(84)
4949  idprup=mint(1)
4950  xwgtup=1d0
4951  scalup=vint(53)
4952  aqedup=vint(57)
4953  aqcdup=vint(58)
4954  DO 180 i=1,nup
4955  idup(i)=k(i+mint(84),2)
4956  IF(i.LE.2) THEN
4957  istup(i)=-1
4958  mothup(1,i)=0
4959  mothup(2,i)=0
4960  ELSEIF(k(i+4,3).EQ.0) THEN
4961  istup(i)=1
4962  mothup(1,i)=1
4963  mothup(2,i)=2
4964  ELSE
4965  istup(i)=1
4966 C...Necessary check for some processes, such as VV->VV
4967  IF(k(i+mint(84),3)-mint(84).GT.0) THEN
4968  mothup(1,i)=k(i+mint(84),3)-mint(84)
4969  mothup(2,i)=0
4970  ELSE
4971  mothup(1,i)=1
4972  mothup(2,i)=2
4973  ENDIF
4974  ENDIF
4975 C...Check positivity of index for certain cases
4976  IF(i.GE.3.AND.k(i+mint(84),3)-mint(84).GT.0)
4977  $ istup(k(i+mint(84),3)-mint(84))=2
4978  icolup(1,i)=mct(i+mint(84),1)
4979  icolup(2,i)=mct(i+mint(84),2)
4980  DO 170 j=1,5
4981  pup(j,i)=p(i+mint(84),j)
4982  170 CONTINUE
4983  vtimup(i)=v(i,5)
4984  spinup(i)=9d0
4985  180 CONTINUE
4986 
4987  ENDIF
4988 
4989 C...Optionally write out event to disk. Minimal size for time/spin fields.
4990  IF(mstp(162).GT.0) THEN
4991  WRITE(mstp(162),5200) nup,idprup,xwgtup,scalup,aqedup,aqcdup
4992  DO 190 i=1,nup
4993  IF(vtimup(i).EQ.0d0) THEN
4994  WRITE(mstp(162),5300) idup(i),istup(i),mothup(1,i),
4995  & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5),
4996  & ' 0. 9.'
4997  ELSE
4998  WRITE(mstp(162),5400) idup(i),istup(i),mothup(1,i),
4999  & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5),
5000  & vtimup(i),' 9.'
5001  ENDIF
5002  190 CONTINUE
5003 
5004 C...Optional extra line with parton-density information.
5005  IF(mstp(165).GE.1) WRITE(mstp(162),5500) msti(15),msti(16),
5006  & pari(33),pari(34),pari(23),pari(29),pari(30)
5007  ENDIF
5008 
5009 C...Error messages and other print formats.
5010  5100 FORMAT(1x,'Error: no subprocess switched on.'/
5011  &1x,'Execution stopped.')
5012  5200 FORMAT(1p,2i6,4e14.6)
5013  5300 FORMAT(1p,i8,5i5,5e18.10,a6)
5014  5400 FORMAT(1p,i8,5i5,5e18.10,e12.4,a3)
5015  5500 FORMAT(1p,'#pdf ',2i5,5e18.10)
5016 
5017  RETURN
5018  END
5019 
5020 C*********************************************************************
5021 
5022 C...PYUPIN
5023 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5024 C...processes, and optionally stores that information on file.
5025 
5026  SUBROUTINE pyupin
5027 
5028 C...Double precision and integer declarations.
5029  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5030  IMPLICIT INTEGER(i-n)
5031 
5032 C...Commonblocks.
5033  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5034  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5035  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5036  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
5037  SAVE /pyjets/,/pysubs/,/pypars/,/pyint5/
5038 
5039 C...User process initialization commonblock.
5040  INTEGER maxpup
5041  parameter(maxpup=100)
5042  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
5043  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
5044  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5045  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5046  &lprup(maxpup)
5047  SAVE /heprup/
5048 
5049 C...Store info on incoming beams.
5050  idbmup(1)=k(1,2)
5051  idbmup(2)=k(2,2)
5052  ebmup(1)=p(1,4)
5053  ebmup(2)=p(2,4)
5054  pdfgup(1)=0
5055  pdfgup(2)=0
5056  pdfsup(1)=mstp(51)
5057  pdfsup(2)=mstp(51)
5058 
5059 C...Event weighting strategy.
5060  idwtup=3
5061 
5062 C...Info on individual processes.
5063  nprup=0
5064  DO 100 isub=1,500
5065  IF(msub(isub).EQ.1) THEN
5066  nprup=nprup+1
5067  xsecup(nprup)=1d9*xsec(isub,3)
5068  xerrup(nprup)=xsecup(nprup)/sqrt(max(1d0,dble(ngen(isub,3))))
5069  xmaxup(nprup)=1d0
5070  lprup(nprup)=isub
5071  ENDIF
5072  100 CONTINUE
5073 
5074 C...Write info to file.
5075  IF(mstp(161).GT.0) THEN
5076  WRITE(mstp(161),5100) idbmup(1),idbmup(2),ebmup(1),ebmup(2),
5077  & pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
5078  DO 110 ipr=1,nprup
5079  WRITE(mstp(161),5200) xsecup(ipr),xerrup(ipr),xmaxup(ipr),
5080  & lprup(ipr)
5081  110 CONTINUE
5082  ENDIF
5083 
5084 C...Formats for printout.
5085  5100 FORMAT(1p,2i8,2e14.6,6i6)
5086  5200 FORMAT(1p,3e14.6,i6)
5087 
5088  RETURN
5089  END
5090 
5091 
5092 C*********************************************************************
5093 
5094 C...Combine the two old-style Pythia initialization and event files
5095 C...into a single Les Houches Event File.
5096 
5097  SUBROUTINE pylhef
5098 
5099 C...Double precision and integer declarations.
5100  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5101  IMPLICIT INTEGER(i-n)
5102 
5103 C...PYTHIA commonblock: only used to provide read/write units and version.
5104  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5105  SAVE /pypars/
5106 
5107 C...User process initialization commonblock.
5108  INTEGER maxpup
5109  parameter(maxpup=100)
5110  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
5111  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
5112  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5113  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5114  &lprup(maxpup)
5115  SAVE /heprup/
5116 
5117 C...User process event common block.
5118  INTEGER maxnup
5119  parameter(maxnup=500)
5120  INTEGER nup,idprup,idup,istup,mothup,icolup
5121  DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
5122  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
5123  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
5124  &vtimup(maxnup),spinup(maxnup)
5125  SAVE /hepeup/
5126 
5127 C...Lines to read in assumed never longer than 200 characters.
5128  parameter(maxlen=200)
5129  CHARACTER*(MAXLEN) string
5130 
5131 C...Format for reading lines.
5132  CHARACTER*6 strfmt
5133  strfmt='(A000)'
5134  WRITE(strfmt(3:5),'(I3)') maxlen
5135 
5136 C...Rewind initialization and event files.
5137  rewind mstp(161)
5138  rewind mstp(162)
5139 
5140 C...Write header info.
5141  WRITE(mstp(163),'(A)') '<LesHouchesEvents version="1.0">'
5142  WRITE(mstp(163),'(A)') '<!--'
5143  WRITE(mstp(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5144  &mstp(181),'.',mstp(182)
5145  WRITE(mstp(163),'(A)') '-->'
5146 
5147 C...Read first line of initialization info and get number of processes.
5148  READ(mstp(161),'(A)',end=400,err=400) string
5149  READ(string,*,err=400) idbmup(1),idbmup(2),ebmup(1),
5150  &ebmup(2),pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
5151 
5152 C...Copy initialization lines, omitting trailing blanks.
5153 C...Embed in <init> ... </init> block.
5154  WRITE(mstp(163),'(A)') '<init>'
5155  DO 140 ipr=0,nprup
5156  IF(ipr.GT.0) READ(mstp(161),'(A)',end=400,err=400) string
5157  len=maxlen+1
5158  120 len=len-1
5159  IF(len.GT.1.AND.string(len:len).EQ.' ') goto 120
5160  WRITE(mstp(163),'(A)',err=400) string(1:len)
5161  140 CONTINUE
5162  WRITE(mstp(163),'(A)') '</init>'
5163 
5164 C...Begin event loop. Read first line of event info or already done.
5165  READ(mstp(162),'(A)',end=320,err=400) string
5166  200 CONTINUE
5167 
5168 C...Look at first line to know number of particles in event.
5169  READ(string,*,err=400) nup,idprup,xwgtup,scalup,aqedup,aqcdup
5170 
5171 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5172  WRITE(mstp(163),'(A)') '<event>'
5173  DO 240 i=0,nup
5174  IF(i.GT.0) READ(mstp(162),'(A)',end=400,err=400) string
5175  len=maxlen+1
5176  220 len=len-1
5177  IF(len.GT.1.AND.string(len:len).EQ.' ') goto 220
5178  WRITE(mstp(163),'(A)',err=400) string(1:len)
5179  240 CONTINUE
5180 
5181 C...Copy trailing comment lines - with a # in the first column - as is.
5182  260 READ(mstp(162),'(A)',end=300,err=400) string
5183  IF(string(1:1).EQ.'#') THEN
5184  len=maxlen+1
5185  280 len=len-1
5186  IF(len.GT.1.AND.string(len:len).EQ.' ') goto 280
5187  WRITE(mstp(163),'(A)',err=400) string(1:len)
5188  goto 260
5189  ENDIF
5190 
5191 C..End the <event> block. Loop back to look for next event.
5192  WRITE(mstp(163),'(A)') '</event>'
5193  goto 200
5194 
5195 C...Successfully reached end of event loop: write closing tag
5196 C...and remove temporary intermediate files (unless asked not to).
5197  300 WRITE(mstp(163),'(A)') '</event>'
5198  320 WRITE(mstp(163),'(A)') '</LesHouchesEvents>'
5199  IF(mstp(164).EQ.1) RETURN
5200  CLOSE(mstp(161),err=400,status='DELETE')
5201  CLOSE(mstp(162),err=400,status='DELETE')
5202  RETURN
5203 
5204 C...Error exit.
5205  400 WRITE(*,*) ' PYLHEF file joining failed!'
5206 
5207  RETURN
5208  END
5209 
5210 C*********************************************************************
5211 
5212 C...PYINRE
5213 C...Calculates full and effective widths of gauge bosons, stores
5214 C...masses and widths, rescales coefficients to be used for
5215 C...resonance production generation.
5216 
5217  SUBROUTINE pyinre
5218 
5219 C...Double precision and integer declarations.
5220  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5221  IMPLICIT INTEGER(i-n)
5222  INTEGER pyk,pychge,pycomp
5223 C...Parameter statement to help give large particle numbers.
5224  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
5225  &kexcit=4000000,kdimen=5000000)
5226 C...Commonblocks.
5227  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5228  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5229  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
5230  common/pydat4/chaf(500,2)
5231  CHARACTER chaf*16
5232  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5233  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5234  common/pyint1/mint(400),vint(400)
5235  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5236  common/pyint4/mwid(500),wids(500,5)
5237  common/pyint6/proc(0:500)
5238  CHARACTER proc*28
5239  common/pymssm/imss(0:99),rmss(0:99)
5240  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
5241  &/pyint1/,/pyint2/,/pyint4/,/pyint6/,/pymssm/
5242 C...Local arrays and data.
5243  CHARACTER prtmp*9
5244  dimension wdtp(0:400),wdte(0:400,0:5),wdtpm(0:400),
5245  &wdtem(0:400,0:5),kcord(500),pmord(500)
5246 
5247 C...Born level couplings in MSSM Higgs doublet sector.
5248  xw=paru(102)
5249  xwv=xw
5250  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
5251  xw1=1d0-xw
5252  IF(mstp(4).EQ.2) THEN
5253  tanbe=paru(141)
5254  ratbe=((1d0-tanbe**2)/(1d0+tanbe**2))**2
5255  sqmz=pmas(23,1)**2
5256  sqmw=pmas(24,1)**2
5257  sqmh=pmas(25,1)**2
5258  sqma=sqmh*(sqmz-sqmh)/(sqmz*ratbe-sqmh)
5259  sqmhp=0.5d0*(sqma+sqmz+sqrt((sqma+sqmz)**2-4d0*sqma*sqmz*ratbe))
5260  sqmhc=sqma+sqmw
5261  IF(sqmh.GE.sqmz.OR.min(sqma,sqmhp,sqmhc).LE.0d0) THEN
5262  WRITE(mstu(11),5000)
5263  CALL pystop(101)
5264  ENDIF
5265  pmas(35,1)=sqrt(sqmhp)
5266  pmas(36,1)=sqrt(sqma)
5267  pmas(37,1)=sqrt(sqmhc)
5268  alsu=0.5d0*atan(2d0*tanbe*(sqma+sqmz)/((1d0-tanbe**2)*
5269  & (sqma-sqmz)))
5270  besu=atan(tanbe)
5271  paru(142)=1d0
5272  paru(143)=1d0
5273  paru(161)=-sin(alsu)/cos(besu)
5274  paru(162)=cos(alsu)/sin(besu)
5275  paru(163)=paru(161)
5276  paru(164)=sin(besu-alsu)
5277  paru(165)=paru(164)
5278  paru(168)=sin(besu-alsu)+0.5d0*cos(2d0*besu)*sin(besu+alsu)/xw
5279  paru(171)=cos(alsu)/cos(besu)
5280  paru(172)=sin(alsu)/sin(besu)
5281  paru(173)=paru(171)
5282  paru(174)=cos(besu-alsu)
5283  paru(175)=paru(174)
5284  paru(176)=cos(2d0*alsu)*cos(besu+alsu)-2d0*sin(2d0*alsu)*
5285  & sin(besu+alsu)
5286  paru(177)=cos(2d0*besu)*cos(besu+alsu)
5287  paru(178)=cos(besu-alsu)-0.5d0*cos(2d0*besu)*cos(besu+alsu)/xw
5288  paru(181)=tanbe
5289  paru(182)=1d0/tanbe
5290  paru(183)=paru(181)
5291  paru(184)=0d0
5292  paru(185)=paru(184)
5293  paru(186)=cos(besu-alsu)
5294  paru(187)=sin(besu-alsu)
5295  paru(188)=paru(186)
5296  paru(189)=paru(187)
5297  paru(190)=0d0
5298  paru(195)=cos(besu-alsu)
5299  ENDIF
5300 
5301 C...Reset effective widths of gauge bosons.
5302  DO 110 i=1,500
5303  DO 100 j=1,5
5304  wids(i,j)=1d0
5305  100 CONTINUE
5306  110 CONTINUE
5307 
5308 C...Order resonances by increasing mass (except Z0 and W+/-).
5309  nres=0
5310  DO 140 kc=1,500
5311  kf=kchg(kc,4)
5312  IF(kf.EQ.0) goto 140
5313  IF(mwid(kc).EQ.0) goto 140
5314  IF(kc.EQ.7.OR.kc.EQ.8.OR.kc.EQ.17.OR.kc.EQ.18) THEN
5315  IF(mstp(1).LE.3) goto 140
5316  ENDIF
5317  IF(kf/ksusy1.EQ.1.OR.kf/ksusy1.EQ.2) THEN
5318  IF(imss(1).LE.0) goto 140
5319  ENDIF
5320  nres=nres+1
5321  pmres=pmas(kc,1)
5322  IF(kc.EQ.23.OR.kc.EQ.24) pmres=0d0
5323  DO 120 i1=nres-1,1,-1
5324  IF(pmres.GE.pmord(i1)) goto 130
5325  kcord(i1+1)=kcord(i1)
5326  pmord(i1+1)=pmord(i1)
5327  120 CONTINUE
5328  130 kcord(i1+1)=kc
5329  pmord(i1+1)=pmres
5330  140 CONTINUE
5331 
5332 C...Loop over possible resonances.
5333  DO 180 i=1,nres
5334  kc=kcord(i)
5335  kf=kchg(kc,4)
5336 
5337 C...Check that no fourth generation channels on by mistake.
5338  IF(mstp(1).LE.3) THEN
5339  DO 150 j=1,mdcy(kc,3)
5340  idc=j+mdcy(kc,2)-1
5341  kfa1=iabs(kfdp(idc,1))
5342  kfa2=iabs(kfdp(idc,2))
5343  IF(kfa1.EQ.7.OR.kfa1.EQ.8.OR.kfa1.EQ.17.OR.kfa1.EQ.18.OR.
5344  & kfa2.EQ.7.OR.kfa2.EQ.8.OR.kfa2.EQ.17.OR.kfa2.EQ.18)
5345  & mdme(idc,1)=-1
5346  150 CONTINUE
5347  ENDIF
5348 
5349 C...Check that no supersymmetric channels on by mistake.
5350  IF(imss(1).LE.0) THEN
5351  DO 160 j=1,mdcy(kc,3)
5352  idc=j+mdcy(kc,2)-1
5353  kfa1s=iabs(kfdp(idc,1))/ksusy1
5354  kfa2s=iabs(kfdp(idc,2))/ksusy1
5355  IF(kfa1s.EQ.1.OR.kfa1s.EQ.2.OR.kfa2s.EQ.1.OR.kfa2s.EQ.2)
5356  & mdme(idc,1)=-1
5357  160 CONTINUE
5358  ENDIF
5359 
5360 C...Find mass and evaluate width.
5361  pmr=pmas(kc,1)
5362  IF(kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) mint(62)=1
5363  IF(mwid(kc).EQ.3) mint(63)=1
5364  CALL pywidt(kf,pmr**2,wdtp,wdte)
5365  mint(51)=0
5366 
5367 C...Evaluate suppression factors due to non-simulated channels.
5368  IF(kchg(kc,3).EQ.0) THEN
5369  wdtp0i=0d0
5370  IF(wdtp(0).GT.0d0) wdtp0i=1d0/wdtp(0)
5371  wids(kc,1)=((wdte(0,1)+wdte(0,2))**2+
5372  & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
5373  & 2d0*wdte(0,4)*wdte(0,5))*wdtp0i**2
5374  wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))*wdtp0i
5375  wids(kc,3)=0d0
5376  wids(kc,4)=0d0
5377  wids(kc,5)=0d0
5378  ELSE
5379  IF(mwid(kc).EQ.3) mint(63)=1
5380  CALL pywidt(-kf,pmr**2,wdtpm,wdtem)
5381  mint(51)=0
5382  wdtp0i=0d0
5383  IF(wdtp(0).GT.0d0) wdtp0i=1d0/wdtp(0)
5384  wids(kc,1)=((wdte(0,1)+wdte(0,2))*(wdtem(0,1)+wdtem(0,3))+
5385  & (wdte(0,1)+wdte(0,2))*(wdtem(0,4)+wdtem(0,5))+
5386  & (wdte(0,4)+wdte(0,5))*(wdtem(0,1)+wdtem(0,3))+
5387  & wdte(0,4)*wdtem(0,5)+wdte(0,5)*wdtem(0,4))*wdtp0i**2
5388  wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))*wdtp0i
5389  wids(kc,3)=(wdtem(0,1)+wdtem(0,3)+wdtem(0,4))*wdtp0i
5390  wids(kc,4)=((wdte(0,1)+wdte(0,2))**2+
5391  & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
5392  & 2d0*wdte(0,4)*wdte(0,5))*wdtp0i**2
5393  wids(kc,5)=((wdtem(0,1)+wdtem(0,3))**2+
5394  & 2d0*(wdtem(0,1)+wdtem(0,3))*(wdtem(0,4)+wdtem(0,5))+
5395  & 2d0*wdtem(0,4)*wdtem(0,5))*wdtp0i**2
5396  ENDIF
5397 
5398 C...Set resonance widths and branching ratios;
5399 C...also on/off switch for decays.
5400  IF(mwid(kc).EQ.1.OR.mwid(kc).EQ.3) THEN
5401  pmas(kc,2)=wdtp(0)
5402  pmas(kc,3)=min(0.9d0*pmas(kc,1),10d0*pmas(kc,2))
5403  IF(mstp(41).EQ.0.OR.mstp(41).EQ.1) mdcy(kc,1)=mstp(41)
5404  DO 170 j=1,mdcy(kc,3)
5405  idc=j+mdcy(kc,2)-1
5406  brat(idc)=0d0
5407  IF(wdtp(0).GT.0d0) brat(idc)=wdtp(j)/wdtp(0)
5408  170 CONTINUE
5409  ENDIF
5410  180 CONTINUE
5411 
5412 C...Flavours of leptoquark: redefine charge and name.
5413  kflqq=kfdp(mdcy(42,2),1)
5414  kflql=kfdp(mdcy(42,2),2)
5415  kchg(42,1)=kchg(pycomp(kflqq),1)*isign(1,kflqq)+
5416  &kchg(pycomp(kflql),1)*isign(1,kflql)
5417  ll=1
5418  IF(iabs(kflql).EQ.13) ll=2
5419  IF(iabs(kflql).EQ.15) ll=3
5420  chaf(42,1)='LQ_'//chaf(iabs(kflqq),1)(1:1)//
5421  &chaf(iabs(kflql),1)(1:ll)//' '
5422  chaf(42,2)=chaf(42,2)(1:4+ll)//'bar '
5423 
5424 C...Special cases in treatment of gamma*/Z0: redefine process name.
5425  IF(mstp(43).EQ.1) THEN
5426  proc(1)='f + fbar -> gamma*'
5427  proc(15)='f + fbar -> g + gamma*'
5428  proc(19)='f + fbar -> gamma + gamma*'
5429  proc(30)='f + g -> f + gamma*'
5430  proc(35)='f + gamma -> f + gamma*'
5431  ELSEIF(mstp(43).EQ.2) THEN
5432  proc(1)='f + fbar -> Z0'
5433  proc(15)='f + fbar -> g + Z0'
5434  proc(19)='f + fbar -> gamma + Z0'
5435  proc(30)='f + g -> f + Z0'
5436  proc(35)='f + gamma -> f + Z0'
5437  ELSEIF(mstp(43).EQ.3) THEN
5438  proc(1)='f + fbar -> gamma*/Z0'
5439  proc(15)='f + fbar -> g + gamma*/Z0'
5440  proc(19)='f+ fbar -> gamma + gamma*/Z0'
5441  proc(30)='f + g -> f + gamma*/Z0'
5442  proc(35)='f + gamma -> f + gamma*/Z0'
5443  ENDIF
5444 
5445 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5446  IF(mstp(44).EQ.1) THEN
5447  proc(141)='f + fbar -> gamma*'
5448  ELSEIF(mstp(44).EQ.2) THEN
5449  proc(141)='f + fbar -> Z0'
5450  ELSEIF(mstp(44).EQ.3) THEN
5451  proc(141)='f + fbar -> Z''0'
5452  ELSEIF(mstp(44).EQ.4) THEN
5453  proc(141)='f + fbar -> gamma*/Z0'
5454  ELSEIF(mstp(44).EQ.5) THEN
5455  proc(141)='f + fbar -> gamma*/Z''0'
5456  ELSEIF(mstp(44).EQ.6) THEN
5457  proc(141)='f + fbar -> Z0/Z''0'
5458  ELSEIF(mstp(44).EQ.7) THEN
5459  proc(141)='f + fbar -> gamma*/Z0/Z''0'
5460  ENDIF
5461 
5462 C...Special cases in treatment of WW -> WW: redefine process name.
5463  IF(mstp(45).EQ.1) THEN
5464  proc(77)='W+ + W+ -> W+ + W+'
5465  ELSEIF(mstp(45).EQ.2) THEN
5466  proc(77)='W+ + W- -> W+ + W-'
5467  ELSEIF(mstp(45).EQ.3) THEN
5468  proc(77)='W+/- + W+/- -> W+/- + W+/-'
5469  ENDIF
5470 
5471 C...Initialize Generic Processes
5472  kfgen=9900001
5473  kcgen=pycomp(kfgen)
5474  IF(kcgen.GT.0) THEN
5475  idcy=mdcy(kcgen,2)
5476  IF(idcy.GT.0) THEN
5477  kff1=kfdp(idcy+1,1)
5478  kff2=kfdp(idcy+1,2)
5479  kcf1=pycomp(kff1)
5480  kcf2=pycomp(kff2)
5481  ij1=1
5482  ij2=1
5483  kci1=pycomp(kfdp(idcy,1))
5484  IF(kfdp(idcy,1).LT.0) ij1=2
5485  kci2=pycomp(kfdp(idcy,2))
5486  IF(kfdp(idcy,2).LT.0) ij2=2
5487  itmp1=0
5488  190 itmp1=itmp1+1
5489  IF(chaf(kci1,ij1)(itmp1+1:itmp1+1).NE.' '.AND.itmp1.LT.4)
5490  & goto 190
5491  itmp2=0
5492  200 itmp2=itmp2+1
5493  IF(chaf(kci2,ij2)(itmp2+1:itmp2+1).NE.' '.AND.itmp2.LT.4)
5494  & goto 200
5495  prtmp=chaf(kci1,ij1)(1:itmp1)//'+'//chaf(kci2,ij2)(1:itmp2)
5496  itmp3=0
5497  205 itmp3=itmp3+1
5498  IF(prtmp(itmp3+1:itmp3+1).NE.' '.AND.itmp3.LT.9)
5499  & goto 205
5500  proc(481)=prtmp(1:itmp3)//' -> '//chaf(kcgen,1)
5501  ij1=1
5502  ij2=1
5503  IF(kff1.LT.0) ij1=2
5504  IF(kff2.LT.0) ij2=2
5505  itmp1=0
5506  210 itmp1=itmp1+1
5507  IF(chaf(kcf1,ij1)(itmp1+1:itmp1+1).NE.' '.AND.itmp1.LT.8)
5508  & goto 210
5509  itmp2=0
5510  220 itmp2=itmp2+1
5511  IF(chaf(kcf2,ij2)(itmp2+1:itmp2+1).NE.' '.AND.itmp2.LT.8)
5512  & goto 220
5513  proc(482)=prtmp(1:itmp3)//' -> '//chaf(kcf1,ij1)(1:itmp1)//
5514  & '+'//chaf(kcf2,ij2)(1:itmp2)
5515  ENDIF
5516  ENDIF
5517 
5518 
5519 
5520 C...Format for error information.
5521  5000 FORMAT(1x,'Error: unphysical input tan^2(beta) and m_H ',
5522  &'combination'/1x,'Execution stopped!')
5523 
5524  RETURN
5525  END
5526 
5527 C*********************************************************************
5528 
5529 C...PYINBM
5530 C...Identifies the two incoming particles and the choice of frame.
5531 
5532  SUBROUTINE pyinbm(CHFRAM,CHBEAM,CHTARG,WIN)
5533 
5534 C...Double precision and integer declarations.
5535  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5536  IMPLICIT INTEGER(i-n)
5537  INTEGER pyk,pychge,pycomp
5538 
5539 C...User process initialization commonblock.
5540  INTEGER maxpup
5541  parameter(maxpup=100)
5542  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
5543  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
5544  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5545  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5546  &lprup(maxpup)
5547  SAVE /heprup/
5548 
5549 C...Commonblocks.
5550  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5551  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5552  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5553  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5554  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5555  common/pyint1/mint(400),vint(400)
5556  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
5557 
5558 C...Local arrays, character variables and data.
5559  CHARACTER chfram*12,chbeam*12,chtarg*12,chcom(3)*12,chalp(2)*26,
5560  &chidnt(3)*12,chtemp*12,chcde(39)*12,chinit*76,chname*16
5561  dimension len(3),kcde(39),pm(2)
5562  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
5563  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5564  DATA chcde/ 'e- ','e+ ','nu_e ',
5565  &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5566  &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5567  &'nu_taubar ','pi+ ','pi- ','n0 ',
5568  &'nbar0 ','p+ ','pbar- ','gamma ',
5569  &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5570  &'xi- ','xi0 ','omega- ','pi0 ',
5571  &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5572  &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5573  &'k+ ','k- ','ks0 ','kl0 '/
5574  DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5575  &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5576  &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5577 
5578 C...Store initial energy. Default frame.
5579  vint(290)=win
5580  mint(111)=0
5581 
5582 C...Special user process initialization; convert to normal input.
5583  IF(chfram(1:1).EQ.'u'.OR.chfram(1:1).EQ.'U') THEN
5584  mint(111)=11
5585  IF(pdfgup(1).EQ.-9.OR.pdfgup(2).EQ.-9) mint(111)=12
5586  CALL pyname(idbmup(1),chname)
5587  chbeam=chname(1:12)
5588  CALL pyname(idbmup(2),chname)
5589  chtarg=chname(1:12)
5590  ENDIF
5591 
5592 C...Convert character variables to lowercase and find their length.
5593  chcom(1)=chfram
5594  chcom(2)=chbeam
5595  chcom(3)=chtarg
5596  DO 130 i=1,3
5597  len(i)=12
5598  DO 110 ll=12,1,-1
5599  IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1
5600  DO 100 la=1,26
5601  IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=
5602  & chalp(1)(la:la)
5603  100 CONTINUE
5604  110 CONTINUE
5605  chidnt(i)=chcom(i)
5606 
5607 C...Fix up bar, underscore and charge in particle name (if needed).
5608  DO 120 ll=1,10
5609  IF(chidnt(i)(ll:ll).EQ.'~') THEN
5610  chtemp=chidnt(i)
5611  chidnt(i)=chtemp(1:ll-1)//'bar'//chtemp(ll+1:10)//' '
5612  ENDIF
5613  120 CONTINUE
5614  IF(chidnt(i)(1:2).EQ.'nu'.AND.chidnt(i)(3:3).NE.'_') THEN
5615  chtemp=chidnt(i)
5616  chidnt(i)='nu_'//chtemp(3:7)
5617  ELSEIF(chidnt(i)(1:2).EQ.'n ') THEN
5618  chidnt(i)(1:3)='n0 '
5619  ELSEIF(chidnt(i)(1:4).EQ.'nbar') THEN
5620  chidnt(i)(1:5)='nbar0'
5621  ELSEIF(chidnt(i)(1:2).EQ.'p ') THEN
5622  chidnt(i)(1:3)='p+ '
5623  ELSEIF(chidnt(i)(1:4).EQ.'pbar'.OR.
5624  & chidnt(i)(1:2).EQ.'p-') THEN
5625  chidnt(i)(1:5)='pbar-'
5626  ELSEIF(chidnt(i)(1:6).EQ.'lambda') THEN
5627  chidnt(i)(7:7)='0'
5628  ELSEIF(chidnt(i)(1:3).EQ.'reg') THEN
5629  chidnt(i)(1:7)='reggeon'
5630  ELSEIF(chidnt(i)(1:3).EQ.'pom') THEN
5631  chidnt(i)(1:7)='pomeron'
5632  ENDIF
5633  130 CONTINUE
5634 
5635 C...Identify free initialization.
5636  IF(chcom(1)(1:2).EQ.'no') THEN
5637  mint(65)=1
5638  RETURN
5639  ENDIF
5640 
5641 C...Identify incoming beam and target particles.
5642  DO 160 i=1,2
5643  DO 140 j=1,39
5644  IF(chidnt(i+1).EQ.chcde(j)) mint(10+i)=kcde(j)
5645  140 CONTINUE
5646  pm(i)=pymass(mint(10+i))
5647  vint(2+i)=pm(i)
5648  mint(140+i)=0
5649  IF(mint(10+i).EQ.22.AND.chidnt(i+1)(6:6).EQ.'/') THEN
5650  chtemp=chidnt(i+1)(7:12)//' '
5651  DO 150 j=1,12
5652  IF(chtemp.EQ.chcde(j)) mint(140+i)=kcde(j)
5653  150 CONTINUE
5654  pm(i)=pymass(mint(140+i))
5655  vint(302+i)=pm(i)
5656  ENDIF
5657  160 CONTINUE
5658  IF(mint(11).EQ.0) WRITE(mstu(11),5000) chbeam(1:len(2))
5659  IF(mint(12).EQ.0) WRITE(mstu(11),5100) chtarg(1:len(3))
5660  IF(mint(11).EQ.0.OR.mint(12).EQ.0) CALL pystop(7)
5661 
5662 C...Identify choice of frame and input energies.
5663  chinit=' '
5664 
5665 C...Events defined in the CM frame.
5666  IF(chcom(1)(1:2).EQ.'cm') THEN
5667  mint(111)=1
5668  s=win**2
5669  IF(mstp(122).GE.1) THEN
5670  IF(chcom(2)(1:1).NE.'e') THEN
5671  loffs=(31-(len(2)+len(3)))/2
5672  chinit(loffs+1:76)='PYTHIA will be initialized for a '//
5673  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5674  & ' collider'//' '
5675  ELSE
5676  loffs=(30-(len(2)+len(3)))/2
5677  chinit(loffs+1:76)='PYTHIA will be initialized for an '//
5678  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5679  & ' collider'//' '
5680  ENDIF
5681  WRITE(mstu(11),5200) chinit
5682  WRITE(mstu(11),5300) win
5683  ENDIF
5684 
5685 C...Events defined in fixed target frame.
5686  ELSEIF(chcom(1)(1:3).EQ.'fix') THEN
5687  mint(111)=2
5688  s=pm(1)**2+pm(2)**2+2d0*pm(2)*sqrt(pm(1)**2+win**2)
5689  IF(mstp(122).GE.1) THEN
5690  loffs=(29-(len(2)+len(3)))/2
5691  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5692  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5693  & ' fixed target'//' '
5694  WRITE(mstu(11),5200) chinit
5695  WRITE(mstu(11),5400) win
5696  WRITE(mstu(11),5500) sqrt(s)
5697  ENDIF
5698 
5699 C...Frame defined by user three-vectors.
5700  ELSEIF(chcom(1)(1:1).EQ.'3') THEN
5701  mint(111)=3
5702  p(1,5)=pm(1)
5703  p(2,5)=pm(2)
5704  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
5705  p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
5706  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5707  & (p(1,3)+p(2,3))**2
5708  IF(mstp(122).GE.1) THEN
5709  loffs=(22-(len(2)+len(3)))/2
5710  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5711  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5712  & ' user configuration'//' '
5713  WRITE(mstu(11),5200) chinit
5714  WRITE(mstu(11),5600)
5715  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5716  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5717  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5718  ENDIF
5719 
5720 C...Frame defined by user four-vectors.
5721  ELSEIF(chcom(1)(1:1).EQ.'4') THEN
5722  mint(111)=4
5723  pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
5724  p(1,5)=sign(sqrt(abs(pms1)),pms1)
5725  pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
5726  p(2,5)=sign(sqrt(abs(pms2)),pms2)
5727  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5728  & (p(1,3)+p(2,3))**2
5729  IF(mstp(122).GE.1) THEN
5730  loffs=(22-(len(2)+len(3)))/2
5731  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5732  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5733  & ' user configuration'//' '
5734  WRITE(mstu(11),5200) chinit
5735  WRITE(mstu(11),5600)
5736  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5737  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5738  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5739  ENDIF
5740 
5741 C...Frame defined by user five-vectors.
5742  ELSEIF(chcom(1)(1:1).EQ.'5') THEN
5743  mint(111)=5
5744  s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5745  & (p(1,3)+p(2,3))**2
5746  IF(mstp(122).GE.1) THEN
5747  loffs=(22-(len(2)+len(3)))/2
5748  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5749  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5750  & ' user configuration'//' '
5751  WRITE(mstu(11),5200) chinit
5752  WRITE(mstu(11),5600)
5753  WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5754  WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5755  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5756  ENDIF
5757 
5758 C...Frame defined by HEPRUP common block.
5759  ELSEIF(mint(111).GE.11) THEN
5760  s=(ebmup(1)+ebmup(2))**2-(sqrt(max(0d0,ebmup(1)**2-pm(1)**2))-
5761  & sqrt(max(0d0,ebmup(2)**2-pm(2)**2)))**2
5762  IF(mstp(122).GE.1) THEN
5763  loffs=(22-(len(2)+len(3)))/2
5764  chinit(loffs+1:76)='PYTHIA will be initialized for '//
5765  & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5766  & ' user configuration'//' '
5767  WRITE(mstu(11),5200) chinit
5768  WRITE(mstu(11),6000) ebmup(1),ebmup(2)
5769  WRITE(mstu(11),5500) sqrt(max(0d0,s))
5770  ENDIF
5771 
5772 C...Unknown frame. Error for too low CM energy.
5773  ELSE
5774  WRITE(mstu(11),5800) chfram(1:len(1))
5775  CALL pystop(7)
5776  ENDIF
5777  IF(s.LT.parp(2)**2) THEN
5778  WRITE(mstu(11),5900) sqrt(s)
5779  CALL pystop(7)
5780  ENDIF
5781 
5782 C...Formats for initialization and error information.
5783  5000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''D0'/
5784  &1x,'Execution stopped!')
5785  5100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''D0'/
5786  &1x,'Execution stopped!')
5787  5200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I')
5788  5300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',
5789  &19x,'I'/1x,'I',76x,'I'/1x,78('='))
5790  5400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')
5791  5500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,
5792  &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))
5793  5600 FORMAT(1x,'I',76x,'I'/1x,'I',18x,'px (GeV/c)',3x,'py (GeV/c)',3x,
5794  &'pz (GeV/c)',6x,'E (GeV)',9x,'I')
5795  5700 FORMAT(1x,'I',8x,a8,4(2x,f10.3,1x),8x,'I')
5796  5800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''D0'/
5797  &1x,'Execution stopped!')
5798  5900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ',
5799  &'generation.'/1x,'Execution stopped!')
5800  6000 FORMAT(1x,'I',12x,'with',1x,f10.3,1x,'GeV on',1x,f10.3,1x,
5801  &'GeV beam energies',13x,'I')
5802 
5803  RETURN
5804  END
5805 
5806 C*********************************************************************
5807 
5808 C...PYINKI
5809 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5810 
5811  SUBROUTINE pyinki(MODKI)
5812 
5813 C...Double precision and integer declarations.
5814  IMPLICIT DOUBLE PRECISION(a-h, o-z)
5815  IMPLICIT INTEGER(i-n)
5816  INTEGER pyk,pychge,pycomp
5817 
5818 C...User process initialization commonblock.
5819  INTEGER maxpup
5820  parameter(maxpup=100)
5821  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
5822  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
5823  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5824  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5825  &lprup(maxpup)
5826  SAVE /heprup/
5827 
5828 C...Commonblocks.
5829  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5830  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5831  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5832  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5833  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5834  common/pyint1/mint(400),vint(400)
5835  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
5836 
5837 C...Set initial flavour state.
5838  n=2
5839  DO 100 i=1,2
5840  k(i,1)=1
5841  k(i,2)=mint(10+i)
5842  IF(mint(140+i).NE.0) k(i,2)=mint(140+i)
5843  100 CONTINUE
5844 
5845 C...Reset boost. Do kinematics for various cases.
5846  DO 110 j=6,10
5847  vint(j)=0d0
5848  110 CONTINUE
5849 
5850 C...Set up kinematics for events defined in CM frame.
5851  IF(mint(111).EQ.1) THEN
5852  win=vint(290)
5853  IF(modki.EQ.1) win=parp(171)*vint(290)
5854  s=win**2
5855  p(1,5)=vint(3)
5856  p(2,5)=vint(4)
5857  IF(mint(141).NE.0) p(1,5)=vint(303)
5858  IF(mint(142).NE.0) p(2,5)=vint(304)
5859  p(1,1)=0d0
5860  p(1,2)=0d0
5861  p(2,1)=0d0
5862  p(2,2)=0d0
5863  p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2d0*p(1,5)*p(2,5))**2)/
5864  & (4d0*s))
5865  p(2,3)=-p(1,3)
5866  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
5867  p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)
5868 
5869 C...Set up kinematics for fixed target events.
5870  ELSEIF(mint(111).EQ.2) THEN
5871  win=vint(290)
5872  IF(modki.EQ.1) win=parp(171)*vint(290)
5873  p(1,5)=vint(3)
5874  p(2,5)=vint(4)
5875  IF(mint(141).NE.0) p(1,5)=vint(303)
5876  IF(mint(142).NE.0) p(2,5)=vint(304)
5877  p(1,1)=0d0
5878  p(1,2)=0d0
5879  p(2,1)=0d0
5880  p(2,2)=0d0
5881  p(1,3)=win
5882  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
5883  p(2,3)=0d0
5884  p(2,4)=p(2,5)
5885  s=p(1,5)**2+p(2,5)**2+2d0*p(2,4)*p(1,4)
5886  vint(10)=p(1,3)/(p(1,4)+p(2,4))
5887  CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
5888 
5889 C...Set up kinematics for events in user-defined frame.
5890  ELSEIF(mint(111).EQ.3) THEN
5891  p(1,5)=vint(3)
5892  p(2,5)=vint(4)
5893  IF(mint(141).NE.0) p(1,5)=vint(303)
5894  IF(mint(142).NE.0) p(2,5)=vint(304)
5895  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
5896  p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
5897  DO 120 j=1,3
5898  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5899  120 CONTINUE
5900  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5901  vint(7)=pyangl(p(1,1),p(1,2))
5902  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5903  vint(6)=pyangl(p(1,3),p(1,1))
5904  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5905  s=p(1,5)**2+p(2,5)**2+2d0*(p(1,4)*p(2,4)-p(1,3)*p(2,3))
5906 
5907 C...Set up kinematics for events with user-defined four-vectors.
5908  ELSEIF(mint(111).EQ.4) THEN
5909  pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
5910  p(1,5)=sign(sqrt(abs(pms1)),pms1)
5911  pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
5912  p(2,5)=sign(sqrt(abs(pms2)),pms2)
5913  DO 130 j=1,3
5914  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5915  130 CONTINUE
5916  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5917  vint(7)=pyangl(p(1,1),p(1,2))
5918  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5919  vint(6)=pyangl(p(1,3),p(1,1))
5920  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5921  s=(p(1,4)+p(2,4))**2
5922 
5923 C...Set up kinematics for events with user-defined five-vectors.
5924  ELSEIF(mint(111).EQ.5) THEN
5925  DO 140 j=1,3
5926  vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5927  140 CONTINUE
5928  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5929  vint(7)=pyangl(p(1,1),p(1,2))
5930  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5931  vint(6)=pyangl(p(1,3),p(1,1))
5932  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5933  s=(p(1,4)+p(2,4))**2
5934 
5935 C...Set up kinematics for events with external user processes.
5936  ELSEIF(mint(111).GE.11) THEN
5937  p(1,5)=vint(3)
5938  p(2,5)=vint(4)
5939  IF(mint(141).NE.0) p(1,5)=vint(303)
5940  IF(mint(142).NE.0) p(2,5)=vint(304)
5941  p(1,1)=0d0
5942  p(1,2)=0d0
5943  p(2,1)=0d0
5944  p(2,2)=0d0
5945  p(1,3)=sqrt(max(0d0,ebmup(1)**2-p(1,5)**2))
5946  p(2,3)=-sqrt(max(0d0,ebmup(2)**2-p(2,5)**2))
5947  p(1,4)=ebmup(1)
5948  p(2,4)=ebmup(2)
5949  vint(10)=(p(1,3)+p(2,3))/(p(1,4)+p(2,4))
5950  CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
5951  s=(p(1,4)+p(2,4))**2
5952  ENDIF
5953 
5954 C...Return or error for too low CM energy.
5955  IF(modki.EQ.1.AND.s.LT.parp(2)**2) THEN
5956  IF(mstp(172).LE.1) THEN
5957  CALL pyerrm(23,
5958  & '(PYINKI:) too low invariant mass in this event')
5959  ELSE
5960  msti(61)=1
5961  RETURN
5962  ENDIF
5963  ENDIF
5964 
5965 C...Save information on incoming particles.
5966  vint(1)=sqrt(s)
5967  vint(2)=s
5968  IF(mint(111).GE.4) THEN
5969  IF(mint(141).EQ.0) THEN
5970  vint(3)=p(1,5)
5971  IF(mint(11).EQ.22.AND.p(1,5).LT.0) vint(307)=p(1,5)**2
5972  ELSE
5973  vint(303)=p(1,5)
5974  ENDIF
5975  IF(mint(142).EQ.0) THEN
5976  vint(4)=p(2,5)
5977  IF(mint(12).EQ.22.AND.p(2,5).LT.0) vint(308)=p(2,5)**2
5978  ELSE
5979  vint(304)=p(2,5)
5980  ENDIF
5981  ENDIF
5982  vint(5)=p(1,3)
5983  IF(modki.EQ.0) vint(289)=s
5984  DO 150 j=1,5
5985  v(1,j)=0d0
5986  v(2,j)=0d0
5987  vint(290+j)=p(1,j)
5988  vint(295+j)=p(2,j)
5989  150 CONTINUE
5990 
5991 C...Store pT cut-off and related constants to be used in generation.
5992  IF(modki.EQ.0) vint(285)=ckin(3)
5993  IF(mstp(82).LE.1) THEN
5994  ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
5995  ELSE
5996  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
5997  ENDIF
5998  vint(149)=4d0*ptmn**2/s
5999  vint(154)=ptmn
6000 
6001  RETURN
6002  END
6003 
6004 C*********************************************************************
6005 
6006 C...PYINPR
6007 C...Selects partonic subprocesses to be included in the simulation.
6008 
6009  SUBROUTINE pyinpr
6010 
6011 C...Double precision and integer declarations.
6012  IMPLICIT DOUBLE PRECISION(a-h, o-z)
6013  IMPLICIT INTEGER(i-n)
6014  INTEGER pyk,pychge,pycomp
6015 
6016 C...User process initialization commonblock.
6017  INTEGER maxpup
6018  parameter(maxpup=100)
6019  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
6020  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
6021  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
6022  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
6023  &lprup(maxpup)
6024  SAVE /heprup/
6025 
6026 C...Commonblocks and character variables.
6027  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6028  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6029  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
6030  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
6031  common/pypars/mstp(200),parp(200),msti(200),pari(200)
6032  common/pyint1/mint(400),vint(400)
6033  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
6034  common/pyint6/proc(0:500)
6035  CHARACTER proc*28
6036  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
6037  &/pyint2/,/pyint6/
6038  CHARACTER chipr*10
6039 
6040 
6041 C...Reset processes to be included.
6042  IF(msel.NE.0) THEN
6043  DO 100 i=1,500
6044  msub(i)=0
6045  100 CONTINUE
6046  ENDIF
6047 
6048 C...Set running pTmin scale.
6049  IF(mstp(82).LE.1) THEN
6050  ptmrun=parp(81)*(vint(1)/parp(89))**parp(90)
6051  ELSE
6052  ptmrun=parp(82)*(vint(1)/parp(89))**parp(90)
6053  ENDIF
6054 
6055 C...Begin by assuming incoming photon to enter subprocess.
6056  IF(mint(11).EQ.22) mint(15)=22
6057  IF(mint(12).EQ.22) mint(16)=22
6058 
6059 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
6060  IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
6061  msub(10)=1
6062  mint(123)=mint(122)+1
6063 
6064 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
6065 C...allow mixture.
6066 C...Here also set a few parameters otherwise normally not touched.
6067  ELSEIF(mint(121).GT.1) THEN
6068 
6069 C...Parton distributions dampened at small Q2; go to low energies,
6070 C...alpha_s <1; no minimum pT cut-off a priori.
6071  IF(mstp(18).EQ.2) THEN
6072  mstp(57)=3
6073  parp(2)=2d0
6074  paru(115)=1d0
6075  ckin(5)=0.2d0
6076  ckin(6)=0.2d0
6077  ENDIF
6078 
6079 C...Define pT cut-off parameters and whether run involves low-pT.
6080  ptmvmd=ptmrun
6081  vint(154)=ptmvmd
6082  ptmdir=ptmvmd
6083  IF(mstp(18).EQ.2) ptmdir=parp(15)
6084  ptmano=ptmvmd
6085  IF(mstp(15).EQ.5) ptmano=0.60d0+
6086  & 0.125d0*log(1d0+0.10d0*vint(1))**2
6087  iptl=1
6088  IF(vint(285).GT.max(ptmvmd,ptmdir,ptmano)) iptl=0
6089  IF(msel.EQ.2) iptl=1
6090 
6091 C...Set up for p/gamma * gamma; real or virtual photons.
6092  IF(mint(121).EQ.3.OR.mint(121).EQ.6.OR.(mint(121).EQ.4.AND.
6093  & mstp(14).EQ.30)) THEN
6094 
6095 C...Set up for p/VMD * VMD.
6096  IF(mint(122).EQ.1) THEN
6097  mint(123)=2
6098  msub(11)=1
6099  msub(12)=1
6100  msub(13)=1
6101  msub(28)=1
6102  msub(53)=1
6103  msub(68)=1
6104  IF(iptl.EQ.1) msub(95)=1
6105  IF(msel.EQ.2) THEN
6106  msub(91)=1
6107  msub(92)=1
6108  msub(93)=1
6109  msub(94)=1
6110  ENDIF
6111  IF(iptl.EQ.1) ckin(3)=0d0
6112 
6113 C...Set up for p/VMD * direct gamma.
6114  ELSEIF(mint(122).EQ.2) THEN
6115  mint(123)=0
6116  IF(mint(121).EQ.6) mint(123)=5
6117  msub(131)=1
6118  msub(132)=1
6119  msub(135)=1
6120  msub(136)=1
6121  IF(iptl.EQ.1) ckin(3)=ptmdir
6122 
6123 C...Set up for p/VMD * anomalous gamma.
6124  ELSEIF(mint(122).EQ.3) THEN
6125  mint(123)=3
6126  IF(mint(121).EQ.6) mint(123)=7
6127  msub(11)=1
6128  msub(12)=1
6129  msub(13)=1
6130  msub(28)=1
6131  msub(53)=1
6132  msub(68)=1
6133  IF(iptl.EQ.1) msub(95)=1
6134  IF(msel.EQ.2) THEN
6135  msub(91)=1
6136  msub(92)=1
6137  msub(93)=1
6138  msub(94)=1
6139  ENDIF
6140  IF(iptl.EQ.1) ckin(3)=0d0
6141 
6142 C...Set up for DIS * p.
6143  ELSEIF(mint(122).EQ.4.AND.(iabs(mint(11)).GT.100.OR.
6144  & iabs(mint(12)).GT.100)) THEN
6145  mint(123)=8
6146  IF(iptl.EQ.1) msub(99)=1
6147 
6148 C...Set up for direct * direct gamma (switch off leptons).
6149  ELSEIF(mint(122).EQ.4) THEN
6150  mint(123)=0
6151  msub(137)=1
6152  msub(138)=1
6153  msub(139)=1
6154  msub(140)=1
6155  DO 110 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6156  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6157  110 CONTINUE
6158  IF(iptl.EQ.1) ckin(3)=ptmdir
6159 
6160 C...Set up for direct * anomalous gamma.
6161  ELSEIF(mint(122).EQ.5) THEN
6162  mint(123)=6
6163  msub(131)=1
6164  msub(132)=1
6165  msub(135)=1
6166  msub(136)=1
6167  IF(iptl.EQ.1) ckin(3)=ptmano
6168 
6169 C...Set up for anomalous * anomalous gamma.
6170  ELSEIF(mint(122).EQ.6) THEN
6171  mint(123)=3
6172  msub(11)=1
6173  msub(12)=1
6174  msub(13)=1
6175  msub(28)=1
6176  msub(53)=1
6177  msub(68)=1
6178  IF(iptl.EQ.1) msub(95)=1
6179  IF(msel.EQ.2) THEN
6180  msub(91)=1
6181  msub(92)=1
6182  msub(93)=1
6183  msub(94)=1
6184  ENDIF
6185  IF(iptl.EQ.1) ckin(3)=0d0
6186  ENDIF
6187 
6188 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6189  ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
6190 
6191 C...Set up for direct * direct gamma (switch off leptons).
6192  IF(mint(122).EQ.1) THEN
6193  mint(123)=0
6194  msub(137)=1
6195  msub(138)=1
6196  msub(139)=1
6197  msub(140)=1
6198  DO 120 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6199  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6200  120 CONTINUE
6201  IF(iptl.EQ.1) ckin(3)=ptmdir
6202 
6203 C...Set up for direct * VMD and VMD * direct gamma.
6204  ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.4) THEN
6205  mint(123)=5
6206  msub(131)=1
6207  msub(132)=1
6208  msub(135)=1
6209  msub(136)=1
6210  IF(iptl.EQ.1) ckin(3)=ptmdir
6211 
6212 C...Set up for direct * anomalous and anomalous * direct gamma.
6213  ELSEIF(mint(122).EQ.3.OR.mint(122).EQ.7) THEN
6214  mint(123)=6
6215  msub(131)=1
6216  msub(132)=1
6217  msub(135)=1
6218  msub(136)=1
6219  IF(iptl.EQ.1) ckin(3)=ptmano
6220 
6221 C...Set up for VMD*VMD.
6222  ELSEIF(mint(122).EQ.5) THEN
6223  mint(123)=2
6224  msub(11)=1
6225  msub(12)=1
6226  msub(13)=1
6227  msub(28)=1
6228  msub(53)=1
6229  msub(68)=1
6230  IF(iptl.EQ.1) msub(95)=1
6231  IF(msel.EQ.2) THEN
6232  msub(91)=1
6233  msub(92)=1
6234  msub(93)=1
6235  msub(94)=1
6236  ENDIF
6237  IF(iptl.EQ.1) ckin(3)=0d0
6238 
6239 C...Set up for VMD * anomalous and anomalous * VMD gamma.
6240  ELSEIF(mint(122).EQ.6.OR.mint(122).EQ.8) THEN
6241  mint(123)=7
6242  msub(11)=1
6243  msub(12)=1
6244  msub(13)=1
6245  msub(28)=1
6246  msub(53)=1
6247  msub(68)=1
6248  IF(iptl.EQ.1) msub(95)=1
6249  IF(msel.EQ.2) THEN
6250  msub(91)=1
6251  msub(92)=1
6252  msub(93)=1
6253  msub(94)=1
6254  ENDIF
6255  IF(iptl.EQ.1) ckin(3)=0d0
6256 
6257 C...Set up for anomalous * anomalous gamma.
6258  ELSEIF(mint(122).EQ.9) THEN
6259  mint(123)=3
6260  msub(11)=1
6261  msub(12)=1
6262  msub(13)=1
6263  msub(28)=1
6264  msub(53)=1
6265  msub(68)=1
6266  IF(iptl.EQ.1) msub(95)=1
6267  IF(msel.EQ.2) THEN
6268  msub(91)=1
6269  msub(92)=1
6270  msub(93)=1
6271  msub(94)=1
6272  ENDIF
6273  IF(iptl.EQ.1) ckin(3)=0d0
6274 
6275 C...Set up for DIS * VMD and VMD * DIS gamma.
6276  ELSEIF(mint(122).EQ.10.OR.mint(122).EQ.12) THEN
6277  mint(123)=8
6278  IF(iptl.EQ.1) msub(99)=1
6279 
6280 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6281  ELSEIF(mint(122).EQ.11.OR.mint(122).EQ.13) THEN
6282  mint(123)=9
6283  IF(iptl.EQ.1) msub(99)=1
6284  ENDIF
6285 
6286 C...Set up for gamma* * p; virtual photons = dir, res.
6287  ELSEIF(mint(121).EQ.2) THEN
6288 
6289 C...Set up for direct * p.
6290  IF(mint(122).EQ.1) THEN
6291  mint(123)=0
6292  msub(131)=1
6293  msub(132)=1
6294  msub(135)=1
6295  msub(136)=1
6296  IF(iptl.EQ.1) ckin(3)=ptmdir
6297 
6298 C...Set up for resolved * p.
6299  ELSEIF(mint(122).EQ.2) THEN
6300  mint(123)=1
6301  msub(11)=1
6302  msub(12)=1
6303  msub(13)=1
6304  msub(28)=1
6305  msub(53)=1
6306  msub(68)=1
6307  IF(iptl.EQ.1) msub(95)=1
6308  IF(msel.EQ.2) THEN
6309  msub(91)=1
6310  msub(92)=1
6311  msub(93)=1
6312  msub(94)=1
6313  ENDIF
6314  IF(iptl.EQ.1) ckin(3)=0d0
6315  ENDIF
6316 
6317 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6318  ELSEIF(mint(121).EQ.4) THEN
6319 
6320 C...Set up for direct * direct gamma (switch off leptons).
6321  IF(mint(122).EQ.1) THEN
6322  mint(123)=0
6323  msub(137)=1
6324  msub(138)=1
6325  msub(139)=1
6326  msub(140)=1
6327  DO 130 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6328  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6329  130 CONTINUE
6330  IF(iptl.EQ.1) ckin(3)=ptmdir
6331 
6332 C...Set up for direct * resolved and resolved * direct gamma.
6333  ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.3) THEN
6334  mint(123)=5
6335  msub(131)=1
6336  msub(132)=1
6337  msub(135)=1
6338  msub(136)=1
6339  IF(iptl.EQ.1) ckin(3)=ptmdir
6340 
6341 C...Set up for resolved * resolved gamma.
6342  ELSEIF(mint(122).EQ.4) THEN
6343  mint(123)=2
6344  msub(11)=1
6345  msub(12)=1
6346  msub(13)=1
6347  msub(28)=1
6348  msub(53)=1
6349  msub(68)=1
6350  IF(iptl.EQ.1) msub(95)=1
6351  IF(msel.EQ.2) THEN
6352  msub(91)=1
6353  msub(92)=1
6354  msub(93)=1
6355  msub(94)=1
6356  ENDIF
6357  IF(iptl.EQ.1) ckin(3)=0d0
6358  ENDIF
6359 
6360 C...End of special set up for gamma-p and gamma-gamma.
6361  ENDIF
6362  ckin(1)=2d0*ckin(3)
6363  ENDIF
6364 
6365 C...Flavour information for individual beams.
6366  DO 140 i=1,2
6367  mint(40+i)=1
6368  IF(mint(123).GE.1.AND.mint(10+i).EQ.22) mint(40+i)=2
6369  IF(iabs(mint(10+i)).GT.100) mint(40+i)=2
6370  mint(44+i)=mint(40+i)
6371  IF(mstp(11).GE.1.AND.(iabs(mint(10+i)).EQ.11.OR.
6372  & iabs(mint(10+i)).EQ.13.OR.iabs(mint(10+i)).EQ.15)) mint(44+i)=3
6373  140 CONTINUE
6374 
6375 C...If two real gammas, whereof one direct, pick the first.
6376 C...For two virtual photons, keep requested order.
6377  IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
6378  IF(mstp(14).LE.10.AND.mint(123).GE.4.AND.mint(123).LE.6) THEN
6379  mint(41)=1
6380  mint(45)=1
6381  ELSEIF(mstp(14).EQ.12.OR.mstp(14).EQ.13.OR.mstp(14).EQ.22.OR.
6382  & mstp(14).EQ.26.OR.mstp(14).EQ.27) THEN
6383  mint(41)=1
6384  mint(45)=1
6385  ELSEIF(mstp(14).EQ.14.OR.mstp(14).EQ.17.OR.mstp(14).EQ.23.OR.
6386  & mstp(14).EQ.28.OR.mstp(14).EQ.29) THEN
6387  mint(42)=1
6388  mint(46)=1
6389  ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.2
6390  & .OR.mint(122).EQ.3.OR.mint(122).EQ.10.OR.mint(122).EQ.11)) THEN
6391  mint(41)=1
6392  mint(45)=1
6393  ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.4
6394  & .OR.mint(122).EQ.7.OR.mint(122).EQ.12.OR.mint(122).EQ.13)) THEN
6395  mint(42)=1
6396  mint(46)=1
6397  ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.2) THEN
6398  mint(41)=1
6399  mint(45)=1
6400  ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.3) THEN
6401  mint(42)=1
6402  mint(46)=1
6403  ENDIF
6404  ELSEIF(mint(11).EQ.22.OR.mint(12).EQ.22) THEN
6405  IF(mstp(14).EQ.26.OR.mstp(14).EQ.28.OR.mint(122).EQ.4) THEN
6406  IF(mint(11).EQ.22) THEN
6407  mint(41)=1
6408  mint(45)=1
6409  ELSE
6410  mint(42)=1
6411  mint(46)=1
6412  ENDIF
6413  ENDIF
6414  IF(mint(123).GE.4.AND.mint(123).LE.7) CALL pyerrm(26,
6415  & '(PYINPR:) unallowed MSTP(14) code for single photon')
6416  ENDIF
6417 
6418 C...Flavour information on combination of incoming particles.
6419  mint(43)=2*mint(41)+mint(42)-2
6420  mint(44)=mint(43)
6421  IF(mint(123).LE.0) THEN
6422  IF(mint(11).EQ.22) mint(43)=mint(43)+2
6423  IF(mint(12).EQ.22) mint(43)=mint(43)+1
6424  ELSEIF(mint(123).LE.3) THEN
6425  IF(mint(11).EQ.22) mint(44)=mint(44)-2
6426  IF(mint(12).EQ.22) mint(44)=mint(44)-1
6427  ELSEIF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
6428  mint(43)=4
6429  mint(44)=1
6430  ENDIF
6431  mint(47)=2*min(2,mint(45))+min(2,mint(46))-2
6432  IF(min(mint(45),mint(46)).EQ.3) mint(47)=5
6433  IF(mint(45).EQ.1.AND.mint(46).EQ.3) mint(47)=6
6434  IF(mint(45).EQ.3.AND.mint(46).EQ.1) mint(47)=7
6435  mint(50)=0
6436  IF(mint(41).EQ.2.AND.mint(42).EQ.2.AND.mint(111).NE.12) mint(50)=1
6437  mint(107)=0
6438  mint(108)=0
6439  IF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
6440  IF((mint(122).GE.4.AND.mint(122).LE.6).OR.mint(122).EQ.12)
6441  & mint(107)=2
6442  IF((mint(122).GE.7.AND.mint(122).LE.9).OR.mint(122).EQ.13)
6443  & mint(107)=3
6444  IF(mint(122).EQ.10.OR.mint(122).EQ.11) mint(107)=4
6445  IF(mint(122).EQ.2.OR.mint(122).EQ.5.OR.mint(122).EQ.8.OR.
6446  & mint(122).EQ.10) mint(108)=2
6447  IF(mint(122).EQ.3.OR.mint(122).EQ.6.OR.mint(122).EQ.9.OR.
6448  & mint(122).EQ.11) mint(108)=3
6449  IF(mint(122).EQ.12.OR.mint(122).EQ.13) mint(108)=4
6450  ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.25) THEN
6451  IF(mint(122).GE.3) mint(107)=1
6452  IF(mint(122).EQ.2.OR.mint(122).EQ.4) mint(108)=1
6453  ELSEIF(mint(121).EQ.2) THEN
6454  IF(mint(122).EQ.2.AND.mint(11).EQ.22) mint(107)=1
6455  IF(mint(122).EQ.2.AND.mint(12).EQ.22) mint(108)=1
6456  ELSE
6457  IF(mint(11).EQ.22) THEN
6458  mint(107)=mint(123)
6459  IF(mint(123).GE.4) mint(107)=0
6460  IF(mint(123).EQ.7) mint(107)=2
6461  IF(mstp(14).EQ.26.OR.mstp(14).EQ.27) mint(107)=4
6462  IF(mstp(14).EQ.28) mint(107)=2
6463  IF(mstp(14).EQ.29) mint(107)=3
6464  IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
6465  & mint(107)=4
6466  ENDIF
6467  IF(mint(12).EQ.22) THEN
6468  mint(108)=mint(123)
6469  IF(mint(123).GE.4) mint(108)=mint(123)-3
6470  IF(mint(123).EQ.7) mint(108)=3
6471  IF(mstp(14).EQ.26) mint(108)=2
6472  IF(mstp(14).EQ.27) mint(108)=3
6473  IF(mstp(14).EQ.28.OR.mstp(14).EQ.29) mint(108)=4
6474  IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
6475  & mint(108)=4
6476  ENDIF
6477  IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.(mstp(14).EQ.14.OR.
6478  & mstp(14).EQ.17.OR.mstp(14).EQ.18.OR.mstp(14).EQ.23)) THEN
6479  minttp=mint(107)
6480  mint(107)=mint(108)
6481  mint(108)=minttp
6482  ENDIF
6483  ENDIF
6484  IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
6485  IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
6486 
6487 C...Select default processes according to incoming beams
6488 C...(already done for gamma-p and gamma-gamma with
6489 C...MSTP(14) = 10, 20, 25 or 30).
6490  IF(mint(121).GT.1) THEN
6491  ELSEIF(msel.EQ.1.OR.msel.EQ.2) THEN
6492 
6493  IF(mint(43).EQ.1) THEN
6494 C...Lepton + lepton -> gamma/Z0 or W.
6495  IF(mint(11)+mint(12).EQ.0) msub(1)=1
6496  IF(mint(11)+mint(12).NE.0) msub(2)=1
6497 
6498  ELSEIF(mint(43).LE.3.AND.mint(123).EQ.0.AND.
6499  & (mint(11).EQ.22.OR.mint(12).EQ.22)) THEN
6500 C...Unresolved photon + lepton: Compton scattering.
6501  msub(133)=1
6502  msub(134)=1
6503 
6504  ELSEIF((mint(123).EQ.8.OR.mint(123).EQ.9).AND.(mint(11).EQ.22
6505  & .OR.mint(12).EQ.22)) THEN
6506 C...DIS as pure gamma* + f -> f process.
6507  msub(99)=1
6508 
6509  ELSEIF(mint(43).LE.3) THEN
6510 C...Lepton + hadron: deep inelastic scattering.
6511  msub(10)=1
6512 
6513  ELSEIF(mint(123).EQ.0.AND.mint(11).EQ.22.AND.
6514  & mint(12).EQ.22) THEN
6515 C...Two unresolved photons: fermion pair production,
6516 C...exclude lepton pairs.
6517  DO 150 isub=137,140
6518  msub(isub)=1
6519  150 CONTINUE
6520  DO 160 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6521  IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6522  160 CONTINUE
6523  ptmdir=ptmrun
6524  IF(mstp(18).EQ.2) ptmdir=parp(15)
6525  IF(ckin(3).LT.ptmrun.OR.msel.EQ.2) ckin(3)=ptmdir
6526  ckin(1)=max(ckin(1),2d0*ckin(3))
6527 
6528  ELSEIF((mint(123).EQ.0.AND.(mint(11).EQ.22.OR.mint(12).EQ.22))
6529  & .OR.(mint(123).GE.4.AND.mint(123).LE.6.AND.mint(11).EQ.22.AND.
6530  & mint(12).EQ.22)) THEN
6531 C...Unresolved photon + hadron: photon-parton scattering.
6532  DO 170 isub=131,136
6533  msub(isub)=1
6534  170 CONTINUE
6535 
6536  ELSEIF(msel.EQ.1) THEN
6537 C...High-pT QCD processes:
6538  msub(11)=1
6539  msub(12)=1
6540  msub(13)=1
6541  msub(28)=1
6542  msub(53)=1
6543  msub(68)=1
6544  ptmn=ptmrun
6545  vint(154)=ptmn
6546  IF(ckin(3).LT.ptmn) msub(95)=1
6547  IF(msub(95).EQ.1.AND.mint(50).EQ.0) msub(95)=0
6548 
6549  ELSE
6550 C...All QCD processes:
6551  msub(11)=1
6552  msub(12)=1
6553  msub(13)=1
6554  msub(28)=1
6555  msub(53)=1
6556  msub(68)=1
6557  msub(91)=1
6558  msub(92)=1
6559  msub(93)=1
6560  msub(94)=1
6561  msub(95)=1
6562  ENDIF
6563 
6564  ELSEIF(msel.GE.4.AND.msel.LE.8) THEN
6565 C...Heavy quark production.
6566  msub(81)=1
6567  msub(82)=1
6568  msub(84)=1
6569  DO 180 j=1,min(8,mdcy(21,3))
6570  mdme(mdcy(21,2)+j-1,1)=0
6571  180 CONTINUE
6572  mdme(mdcy(21,2)+msel-1,1)=1
6573  msub(85)=1
6574  DO 190 j=1,min(12,mdcy(22,3))
6575  mdme(mdcy(22,2)+j-1,1)=0
6576  190 CONTINUE
6577  mdme(mdcy(22,2)+msel-1,1)=1
6578 
6579  ELSEIF(msel.EQ.10) THEN
6580 C...Prompt photon production:
6581  msub(14)=1
6582  msub(18)=1
6583  msub(29)=1
6584 
6585  ELSEIF(msel.EQ.11) THEN
6586 C...Z0/gamma* production:
6587  msub(1)=1
6588 
6589  ELSEIF(msel.EQ.12) THEN
6590 C...W+/- production:
6591  msub(2)=1
6592 
6593  ELSEIF(msel.EQ.13) THEN
6594 C...Z0 + jet:
6595  msub(15)=1
6596  msub(30)=1
6597 
6598  ELSEIF(msel.EQ.14) THEN
6599 C...W+/- + jet:
6600  msub(16)=1
6601  msub(31)=1
6602 
6603  ELSEIF(msel.EQ.15) THEN
6604 C...Z0 & W+/- pair production:
6605  msub(19)=1
6606  msub(20)=1
6607  msub(22)=1
6608  msub(23)=1
6609  msub(25)=1
6610 
6611  ELSEIF(msel.EQ.16) THEN
6612 C...h0 production:
6613  msub(3)=1
6614  msub(102)=1
6615  msub(103)=1
6616  msub(123)=1
6617  msub(124)=1
6618 
6619  ELSEIF(msel.EQ.17) THEN
6620 C...h0 & Z0 or W+/- pair production:
6621  msub(24)=1
6622  msub(26)=1
6623 
6624  ELSEIF(msel.EQ.18) THEN
6625 C...h0 production; interesting processes in e+e-.
6626  msub(24)=1
6627  msub(103)=1
6628  msub(123)=1
6629  msub(124)=1
6630 
6631  ELSEIF(msel.EQ.19) THEN
6632 C...h0, H0 and A0 production; interesting processes in e+e-.
6633  msub(24)=1
6634  msub(103)=1
6635  msub(123)=1
6636  msub(124)=1
6637  msub(153)=1
6638  msub(171)=1
6639  msub(173)=1
6640  msub(174)=1
6641  msub(158)=1
6642  msub(176)=1
6643  msub(178)=1
6644  msub(179)=1
6645 
6646  ELSEIF(msel.EQ.21) THEN
6647 C...Z'0 production:
6648  msub(141)=1
6649 
6650  ELSEIF(msel.EQ.22) THEN
6651 C...W'+/- production:
6652  msub(142)=1
6653 
6654  ELSEIF(msel.EQ.23) THEN
6655 C...H+/- production:
6656  msub(143)=1
6657 
6658  ELSEIF(msel.EQ.24) THEN
6659 C...R production:
6660  msub(144)=1
6661 
6662  ELSEIF(msel.EQ.25) THEN
6663 C...LQ (leptoquark) production.
6664  msub(145)=1
6665  msub(162)=1
6666  msub(163)=1
6667  msub(164)=1
6668 
6669  ELSEIF(msel.GE.35.AND.msel.LE.38) THEN
6670 C...Production of one heavy quark (W exchange):
6671  msub(83)=1
6672  DO 200 j=1,min(8,mdcy(21,3))
6673  mdme(mdcy(21,2)+j-1,1)=0
6674  200 CONTINUE
6675  mdme(mdcy(21,2)+msel-31,1)=1
6676 
6677 CMRENNA++Define SUSY alternatives.
6678  ELSEIF(msel.EQ.39) THEN
6679 C...Turn on all SUSY processes.
6680  IF(mint(43).EQ.4) THEN
6681 C...Hadron-hadron processes.
6682  DO 210 i=201,296
6683  IF(iset(i).GE.0) msub(i)=1
6684  210 CONTINUE
6685  ELSEIF(mint(43).EQ.1) THEN
6686 C...Lepton-lepton processes: QED production of squarks.
6687  DO 220 i=201,214
6688  msub(i)=1
6689  220 CONTINUE
6690  msub(210)=0
6691  msub(211)=0
6692  msub(212)=0
6693  DO 230 i=216,228
6694  msub(i)=1
6695  230 CONTINUE
6696  DO 240 i=261,263
6697  msub(i)=1
6698  240 CONTINUE
6699  msub(277)=1
6700  msub(278)=1
6701  ENDIF
6702 
6703  ELSEIF(msel.EQ.40) THEN
6704 C...Gluinos and squarks.
6705  IF(mint(43).EQ.4) THEN
6706  msub(243)=1
6707  msub(244)=1
6708  msub(258)=1
6709  msub(259)=1
6710  msub(261)=1
6711  msub(262)=1
6712  msub(264)=1
6713  msub(265)=1
6714  DO 250 i=271,296
6715  msub(i)=1
6716  250 CONTINUE
6717  ELSEIF(mint(43).EQ.1) THEN
6718  msub(277)=1
6719  msub(278)=1
6720  ENDIF
6721 
6722  ELSEIF(msel.EQ.41) THEN
6723 C...Stop production.
6724  msub(261)=1
6725  msub(262)=1
6726  msub(263)=1
6727  IF(mint(43).EQ.4) THEN
6728  msub(264)=1
6729  msub(265)=1
6730  ENDIF
6731 
6732  ELSEIF(msel.EQ.42) THEN
6733 C...Slepton production.
6734  DO 260 i=201,214
6735  msub(i)=1
6736  260 CONTINUE
6737  IF(mint(43).NE.4) THEN
6738  msub(210)=0
6739  msub(211)=0
6740  msub(212)=0
6741  ENDIF
6742 
6743  ELSEIF(msel.EQ.43) THEN
6744 C...Neutralino/Chargino + Gluino/Squark.
6745  IF(mint(43).EQ.4) THEN
6746  DO 270 i=237,242
6747  msub(i)=1
6748  270 CONTINUE
6749  DO 280 i=246,254
6750  msub(i)=1
6751  280 CONTINUE
6752  msub(256)=1
6753  ENDIF
6754 
6755  ELSEIF(msel.EQ.44) THEN
6756 C...Neutralino/Chargino pair production.
6757  IF(mint(43).EQ.4) THEN
6758  DO 290 i=216,236
6759  msub(i)=1
6760  290 CONTINUE
6761  ELSEIF(mint(43).EQ.1) THEN
6762  DO 300 i=216,228
6763  msub(i)=1
6764  300 CONTINUE
6765  ENDIF
6766 
6767  ELSEIF(msel.EQ.45) THEN
6768 C...Sbottom production.
6769  msub(287)=1
6770  msub(288)=1
6771  IF(mint(43).EQ.4) THEN
6772  DO 310 i=281,296
6773  msub(i)=1
6774  310 CONTINUE
6775  ENDIF
6776 
6777  ELSEIF(msel.EQ.50) THEN
6778 C...Pair production of technipions and gauge bosons.
6779  DO 320 i=361,368
6780  msub(i)=1
6781  320 CONTINUE
6782  IF(mint(43).EQ.4) THEN
6783  DO 330 i=370,377
6784  msub(i)=1
6785  330 CONTINUE
6786  ENDIF
6787 
6788  ELSEIF(msel.EQ.51) THEN
6789 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6790  DO 340 i=381,386
6791  msub(i)=1
6792  340 CONTINUE
6793 
6794  ELSEIF(msel.EQ.61) THEN
6795 C...Charmonium production in colour octet model, with recoiling parton.
6796  DO 342 i=421,439
6797  msub(i)=1
6798  342 CONTINUE
6799 
6800  ELSEIF(msel.EQ.62) THEN
6801 C...Bottomonium production in colour octet model, with recoiling parton.
6802  DO 344 i=461,479
6803  msub(i)=1
6804  344 CONTINUE
6805 
6806  ELSEIF(msel.EQ.63) THEN
6807 C...Charmonium and bottomonium production in colour octet model.
6808  DO 346 i=421,439
6809  msub(i)=1
6810  msub(i+40)=1
6811  346 CONTINUE
6812  ENDIF
6813 
6814 C...Find heaviest new quark flavour allowed in processes 81-84.
6815  kflqm=1
6816  DO 350 i=1,min(8,mdcy(21,3))
6817  idc=i+mdcy(21,2)-1
6818  IF(mdme(idc,1).LE.0) goto 350
6819  kflqm=i
6820  350 CONTINUE
6821  IF(mstp(7).GE.1.AND.mstp(7).LE.8.AND.(msel.LE.3.OR.msel.GE.9))
6822  &kflqm=mstp(7)
6823  mint(55)=kflqm
6824  kfpr(81,1)=kflqm
6825  kfpr(81,2)=kflqm
6826  kfpr(82,1)=kflqm
6827  kfpr(82,2)=kflqm
6828  kfpr(83,1)=kflqm
6829  kfpr(84,1)=kflqm
6830  kfpr(84,2)=kflqm
6831 
6832 C...Find heaviest new fermion flavour allowed in process 85.
6833  kflfm=1
6834  DO 360 i=1,min(12,mdcy(22,3))
6835  idc=i+mdcy(22,2)-1
6836  IF(mdme(idc,1).LE.0) goto 360
6837  kflfm=kfdp(idc,1)
6838  360 CONTINUE
6839  IF(((mstp(7).GE.1.AND.mstp(7).LE.8).OR.(mstp(7).GE.11.AND.
6840  &mstp(7).LE.18)).AND.(msel.LE.3.OR.msel.GE.9)) kflfm=mstp(7)
6841  mint(56)=kflfm
6842  kfpr(85,1)=kflfm
6843  kfpr(85,2)=kflfm
6844 
6845 C...Initialize Generic Processes
6846  kfgen=9900001
6847  kcgen=pycomp(kfgen)
6848  IF(kcgen.GT.0) THEN
6849  idcy=mdcy(kcgen,2)
6850  IF(idcy.GT.0) THEN
6851  kff1=kfdp(idcy+1,1)
6852  kff2=kfdp(idcy+1,2)
6853  kcf1=pycomp(kff1)
6854  kcf2=pycomp(kff2)
6855  jcol1=iabs(kchg(kcf1,2))
6856  IF(jcol1.EQ.1) THEN
6857  kf1=kff1
6858  kf2=kff2
6859  ELSE
6860  kf1=kff2
6861  kf2=kff1
6862  ENDIF
6863  kfpr(481,1)=kf1
6864  kfpr(481,2)=kf2
6865  kfpr(482,1)=kf1
6866  kfpr(482,2)=kf2
6867  ENDIF
6868  IF(kfdp(idcy,1).EQ.21.OR.kfdp(idcy,2).EQ.21) THEN
6869  kfin(1,0)=1
6870  kfin(2,0)=1
6871  ENDIF
6872  ENDIF
6873 
6874 C...Import relevant information on external user processes.
6875  IF(mint(111).GE.11) THEN
6876  ipypr=0
6877  DO 390 iup=1,nprup
6878 C...Find next empty PYTHIA process number slot and enable it.
6879  370 ipypr=ipypr+1
6880  IF(ipypr.GT.500) CALL pyerrm(26,
6881  & '(PYINPR.) no more empty slots for user processes')
6882  IF(iset(ipypr).GE.0.AND.iset(ipypr).LE.9) goto 370
6883  IF(ipypr.GE.91.AND.ipypr.LE.100) goto 370
6884  iset(ipypr)=11
6885 C...Overwrite KFPR with references back to process number and ID.
6886  kfpr(ipypr,1)=iup
6887  kfpr(ipypr,2)=lprup(iup)
6888 C...Process title.
6889  WRITE(chipr,'(I10)') lprup(iup)
6890  ichin=1
6891  DO 380 ich=1,9
6892  IF(chipr(ich:ich).EQ.' ') ichin=ich+1
6893  380 CONTINUE
6894  proc(ipypr)='User process '//chipr(ichin:10)//' '
6895 C...Switch on process.
6896  msub(ipypr)=1
6897  390 CONTINUE
6898  ENDIF
6899 
6900  RETURN
6901  END
6902 
6903 C*********************************************************************
6904 
6905 C...PYXTOT
6906 C...Parametrizes total, elastic and diffractive cross-sections
6907 C...for different energies and beams. Donnachie-Landshoff for
6908 C...total and Schuler-Sjostrand for elastic and diffractive.
6909 C...Process code IPROC:
6910 C...= 1 : p + p;
6911 C...= 2 : pbar + p;
6912 C...= 3 : pi+ + p;
6913 C...= 4 : pi- + p;
6914 C...= 5 : pi0 + p;
6915 C...= 6 : phi + p;
6916 C...= 7 : J/psi + p;
6917 C...= 11 : rho + rho;
6918 C...= 12 : rho + phi;
6919 C...= 13 : rho + J/psi;
6920 C...= 14 : phi + phi;
6921 C...= 15 : phi + J/psi;
6922 C...= 16 : J/psi + J/psi;
6923 C...= 21 : gamma + p (DL);
6924 C...= 22 : gamma + p (VDM).
6925 C...= 23 : gamma + pi (DL);
6926 C...= 24 : gamma + pi (VDM);
6927 C...= 25 : gamma + gamma (DL);
6928 C...= 26 : gamma + gamma (VDM).
6929 
6930  SUBROUTINE pyxtot
6931 
6932 C...Double precision and integer declarations.
6933  IMPLICIT DOUBLE PRECISION(a-h, o-z)
6934  IMPLICIT INTEGER(i-n)
6935  INTEGER pyk,pychge,pycomp
6936 C...Commonblocks.
6937  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6938  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6939  common/pypars/mstp(200),parp(200),msti(200),pari(200)
6940  common/pyint1/mint(400),vint(400)
6941  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
6942  common/pyint7/sigt(0:6,0:6,0:5)
6943  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint5/,/pyint7/
6944 C...Local arrays.
6945  dimension nproc(30),xpar(30),ypar(30),ihada(20),ihadb(20),
6946  &pmhad(4),bhad(4),betp(4),ifitsd(20),ifitdd(20),ceffs(10,8),
6947  &ceffd(10,9),sigtmp(6,0:5)
6948 
6949 C...Common constants.
6950  DATA eps/0.0808d0/, eta/-0.4525d0/, alp/0.25d0/, cres/2d0/,
6951  &pmrc/1.062d0/, smp/0.880d0/, facel/0.0511d0/, facsd/0.0336d0/,
6952  &facdd/0.0084d0/
6953 
6954 C...Number of multiple processes to be evaluated (= 0 : undefined).
6955  DATA nproc/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6956 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6957  DATA xpar/2*21.70d0,3*13.63d0,10.01d0,0.970d0,3*0d0,
6958  &8.56d0,6.29d0,0.609d0,4.62d0,0.447d0,0.0434d0,4*0d0,
6959  &0.0677d0,0.0534d0,0.0425d0,0.0335d0,2.11d-4,1.31d-4,4*0d0/
6960  DATA ypar/
6961  &56.08d0,98.39d0,27.56d0,36.02d0,31.79d0,-1.51d0,-0.146d0,3*0d0,
6962  &13.08d0,-0.62d0,-0.060d0,0.030d0,-0.0028d0,0.00028d0,4*0d0,
6963  &0.129d0,0.115d0,0.081d0,0.072d0,2.15d-4,1.70d-4,4*0d0/
6964 
6965 C...Beam and target hadron class:
6966 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6967  DATA ihada/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6968  DATA ihadb/7*1,3*0,2,3,4,3,2*4,4*0/
6969 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6970  DATA pmhad/0.938d0,0.770d0,1.020d0,3.097d0/
6971  DATA bhad/2.3d0,1.4d0,1.4d0,0.23d0/
6972  DATA betp/4.658d0,2.926d0,2.149d0,0.208d0/
6973 
6974 C...Fitting constants used in parametrizations of diffractive results.
6975  DATA ifitsd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6976  DATA ifitdd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6977  DATA ((ceffs(j1,j2),j2=1,8),j1=1,10)/
6978  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.213d0, 0.0d0, -0.47d0, 150d0,
6979  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.267d0, 0.0d0, -0.47d0, 100d0,
6980  &0.213d0, 0.0d0, -0.47d0, 150d0, 0.232d0, 0.0d0, -0.47d0, 110d0,
6981  &0.213d0, 7.0d0, -0.55d0, 800d0, 0.115d0, 0.0d0, -0.47d0, 110d0,
6982  &0.267d0, 0.0d0, -0.46d0, 75d0, 0.267d0, 0.0d0, -0.46d0, 75d0,
6983  &0.232d0, 0.0d0, -0.46d0, 85d0, 0.267d0, 0.0d0, -0.48d0, 100d0,
6984  &0.115d0, 0.0d0, -0.50d0, 90d0, 0.267d0, 6.0d0, -0.56d0, 420d0,
6985  &0.232d0, 0.0d0, -0.48d0, 110d0, 0.232d0, 0.0d0, -0.48d0, 110d0,
6986  &0.115d0, 0.0d0, -0.52d0, 120d0, 0.232d0, 6.0d0, -0.56d0, 470d0,
6987  &0.115d0, 5.5d0, -0.58d0, 570d0, 0.115d0, 5.5d0, -0.58d0, 570d0/
6988  DATA ((ceffd(j1,j2),j2=1,9),j1=1,10)/
6989  &3.11d0, -7.34d0, 9.71d0, 0.068d0, -0.42d0, 1.31d0,
6990  &-1.37d0, 35.0d0, 118d0, 3.11d0, -7.10d0, 10.6d0,
6991  &0.073d0, -0.41d0, 1.17d0, -1.41d0, 31.6d0, 95d0,
6992  &3.12d0, -7.43d0, 9.21d0, 0.067d0, -0.44d0, 1.41d0,
6993  &-1.35d0, 36.5d0, 132d0, 3.13d0, -8.18d0, -4.20d0,
6994  &0.056d0, -0.71d0, 3.12d0, -1.12d0, 55.2d0, 1298d0,
6995  &3.11d0, -6.90d0, 11.4d0, 0.078d0, -0.40d0, 1.05d0,
6996  &-1.40d0, 28.4d0, 78d0, 3.11d0, -7.13d0, 10.0d0,
6997  &0.071d0, -0.41d0, 1.23d0, -1.34d0, 33.1d0, 105d0,
6998  &3.12d0, -7.90d0, -1.49d0, 0.054d0, -0.64d0, 2.72d0,
6999  &-1.13d0, 53.1d0, 995d0, 3.11d0, -7.39d0, 8.22d0,
7000  &0.065d0, -0.44d0, 1.45d0, -1.36d0, 38.1d0, 148d0,
7001  &3.18d0, -8.95d0, -3.37d0, 0.057d0, -0.76d0, 3.32d0,
7002  &-1.12d0, 55.6d0, 1472d0, 4.18d0, -29.2d0, 56.2d0,
7003  &0.074d0, -1.36d0, 6.67d0, -1.14d0, 116.2d0, 6532d0/
7004 
7005 C...Parameters. Combinations of the energy.
7006  aem=paru(101)
7007  pmth=parp(102)
7008  s=vint(2)
7009  srt=vint(1)
7010  seps=s**eps
7011  seta=s**eta
7012  slog=log(s)
7013 
7014 C...Ratio of gamma/pi (for rescaling in parton distributions).
7015  vint(281)=(xpar(22)*seps+ypar(22)*seta)/
7016  &(xpar(5)*seps+ypar(5)*seta)
7017  vint(317)=1d0
7018  IF(mint(50).NE.1) RETURN
7019 
7020 C...Order flavours of incoming particles: KF1 < KF2.
7021  IF(iabs(mint(11)).LE.iabs(mint(12))) THEN
7022  kf1=iabs(mint(11))
7023  kf2=iabs(mint(12))
7024  iord=1
7025  ELSE
7026  kf1=iabs(mint(12))
7027  kf2=iabs(mint(11))
7028  iord=2
7029  ENDIF
7030  isgn12=isign(1,mint(11)*mint(12))
7031 
7032 C...Find process number (for lookup tables).
7033  IF(kf1.GT.1000) THEN
7034  iproc=1
7035  IF(isgn12.LT.0) iproc=2
7036  ELSEIF(kf1.GT.100.AND.kf2.GT.1000) THEN
7037  iproc=3
7038  IF(isgn12.LT.0) iproc=4
7039  IF(kf1.EQ.111) iproc=5
7040  ELSEIF(kf1.GT.100) THEN
7041  iproc=11
7042  ELSEIF(kf2.GT.1000) THEN
7043  iproc=21
7044  IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=22
7045  ELSEIF(kf2.GT.100) THEN
7046  iproc=23
7047  IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=24
7048  ELSE
7049  iproc=25
7050  IF(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7) iproc=26
7051  ENDIF
7052 
7053 C... Number of multiple processes to be stored; beam/target side.
7054  npr=nproc(iproc)
7055  mint(101)=1
7056  mint(102)=1
7057  IF(npr.EQ.3) THEN
7058  mint(100+iord)=4
7059  ELSEIF(npr.EQ.6) THEN
7060  mint(101)=4
7061  mint(102)=4
7062  ENDIF
7063  n1=0
7064  IF(mint(101).EQ.4) n1=4
7065  n2=0
7066  IF(mint(102).EQ.4) n2=4
7067 
7068 C...Do not do any more for user-set or undefined cross-sections.
7069  IF(mstp(31).LE.0) RETURN
7070  IF(npr.EQ.0) CALL pyerrm(26,
7071  &'(PYXTOT:) cross section for this process not yet implemented')
7072 
7073 C...Parameters. Combinations of the energy.
7074  aem=paru(101)
7075  pmth=parp(102)
7076  s=vint(2)
7077  srt=vint(1)
7078  seps=s**eps
7079  seta=s**eta
7080  slog=log(s)
7081 
7082 C...Loop over multiple processes (for VDM).
7083  DO 110 i=1,npr
7084  IF(npr.EQ.1) THEN
7085  ipr=iproc
7086  ELSEIF(npr.EQ.3) THEN
7087  ipr=i+4
7088  IF(kf2.LT.1000) ipr=i+10
7089  ELSEIF(npr.EQ.6) THEN
7090  ipr=i+10
7091  ENDIF
7092 
7093 C...Evaluate hadron species, mass, slope contribution and fit number.
7094  iha=ihada(ipr)
7095  ihb=ihadb(ipr)
7096  pma=pmhad(iha)
7097  pmb=pmhad(ihb)
7098  bha=bhad(iha)
7099  bhb=bhad(ihb)
7100  isd=ifitsd(ipr)
7101  idd=ifitdd(ipr)
7102 
7103 C...Skip if energy too low relative to masses.
7104  DO 100 j=0,5
7105  sigtmp(i,j)=0d0
7106  100 CONTINUE
7107  IF(srt.LT.pma+pmb+parp(104)) goto 110
7108 
7109 C...Total cross-section. Elastic slope parameter and cross-section.
7110  sigtmp(i,0)=xpar(ipr)*seps+ypar(ipr)*seta
7111  bel=2d0*bha+2d0*bhb+4d0*seps-4.2d0
7112  sigtmp(i,1)=facel*sigtmp(i,0)**2/bel
7113 
7114 C...Diffractive scattering A + B -> X + B.
7115  bsd=2d0*bhb
7116  sqml=(pma+pmth)**2
7117  sqmu=s*ceffs(isd,1)+ceffs(isd,2)
7118  sum1=log((bsd+2d0*alp*log(s/sqml))/
7119  & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
7120  bxb=ceffs(isd,3)+ceffs(isd,4)/s
7121  sum2=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)/
7122  & (bsd+2d0*alp*log(s/((pma+pmth)*(pma+pmrc)))+bxb)
7123  sigtmp(i,2)=facsd*xpar(ipr)*betp(ihb)*max(0d0,sum1+sum2)
7124 
7125 C...Diffractive scattering A + B -> A + X.
7126  bsd=2d0*bha
7127  sqml=(pmb+pmth)**2
7128  sqmu=s*ceffs(isd,5)+ceffs(isd,6)
7129  sum1=log((bsd+2d0*alp*log(s/sqml))/
7130  & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
7131  bax=ceffs(isd,7)+ceffs(isd,8)/s
7132  sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/
7133  & (bsd+2d0*alp*log(s/((pmb+pmth)*(pmb+pmrc)))+bax)
7134  sigtmp(i,3)=facsd*xpar(ipr)*betp(iha)*max(0d0,sum1+sum2)
7135 
7136 C...Order single diffractive correctly.
7137  IF(iord.EQ.2) THEN
7138  sigsav=sigtmp(i,2)
7139  sigtmp(i,2)=sigtmp(i,3)
7140  sigtmp(i,3)=sigsav
7141  ENDIF
7142 
7143 C...Double diffractive scattering A + B -> X1 + X2.
7144  yeff=log(s*smp/((pma+pmth)*(pmb+pmth))**2)
7145  deff=ceffd(idd,1)+ceffd(idd,2)/slog+ceffd(idd,3)/slog**2
7146  sum1=(deff+yeff*(log(max(1d-10,yeff/deff))-1d0))/(2d0*alp)
7147  IF(yeff.LE.0) sum1=0d0
7148  sqmu=s*(ceffd(idd,4)+ceffd(idd,5)/slog+ceffd(idd,6)/slog**2)
7149  slup=log(max(1.1d0,s/(alp*(pma+pmth)**2*(pmb+pmth)*(pmb+pmrc))))
7150  sldn=log(max(1.1d0,s/(alp*sqmu*(pmb+pmth)*(pmb+pmrc))))
7151  sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)*log(slup/sldn)/
7152  & (2d0*alp)
7153  slup=log(max(1.1d0,s/(alp*(pmb+pmth)**2*(pma+pmth)*(pma+pmrc))))
7154  sldn=log(max(1.1d0,s/(alp*sqmu*(pma+pmth)*(pma+pmrc))))
7155  sum3=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)*log(slup/sldn)/
7156  & (2d0*alp)
7157  bxx=ceffd(idd,7)+ceffd(idd,8)/srt+ceffd(idd,9)/s
7158  slrr=log(s/(alp*(pma+pmth)*(pma+pmrc)*(pmb+pmth)*(pmb+pmrc)))
7159  sum4=cres**2*log(1d0+((pma+pmrc)/(pma+pmth))**2)*
7160  & log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/max(0.1d0,2d0*alp*slrr+bxx)
7161  sigtmp(i,4)=facdd*xpar(ipr)*max(0d0,sum1+sum2+sum3+sum4)
7162 
7163 C...Non-diffractive by unitarity.
7164  sigtmp(i,5)=sigtmp(i,0)-sigtmp(i,1)-sigtmp(i,2)-sigtmp(i,3)-
7165  & sigtmp(i,4)
7166  110 CONTINUE
7167 
7168 C...Put temporary results in output array: only one process.
7169  IF(mint(101).EQ.1.AND.mint(102).EQ.1) THEN
7170  DO 120 j=0,5
7171  sigt(0,0,j)=sigtmp(1,j)
7172  120 CONTINUE
7173 
7174 C...Beam multiple processes.
7175  ELSEIF(mint(101).EQ.4.AND.mint(102).EQ.1) THEN
7176  IF(mint(107).EQ.2) THEN
7177  vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
7178  ELSE
7179  vint(317)=16d0*parp(15)**2*vint(154)**2/
7180  & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
7181  ENDIF
7182  IF(mstp(20).GT.0) THEN
7183  vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)))**mstp(20)
7184  ENDIF
7185  DO 140 i=1,4
7186  IF(mint(107).EQ.2) THEN
7187  conv=(aem/parp(160+i))*vint(317)
7188  ELSEIF(vint(154).GT.parp(15)) THEN
7189  conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
7190  & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7191  ELSE
7192  conv=0d0
7193  ENDIF
7194  i1=max(1,i-1)
7195  DO 130 j=0,5
7196  sigt(i,0,j)=conv*sigtmp(i1,j)
7197  130 CONTINUE
7198  140 CONTINUE
7199  DO 150 j=0,5
7200  sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
7201  150 CONTINUE
7202 
7203 C...Target multiple processes.
7204  ELSEIF(mint(101).EQ.1.AND.mint(102).EQ.4) THEN
7205  IF(mint(108).EQ.2) THEN
7206  vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
7207  ELSE
7208  vint(317)=16d0*parp(15)**2*vint(154)**2/
7209  & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
7210  ENDIF
7211  IF(mstp(20).GT.0) THEN
7212  vint(317)=vint(317)*(vint(2)/(vint(2)+vint(308)))**mstp(20)
7213  ENDIF
7214  DO 170 i=1,4
7215  IF(mint(108).EQ.2) THEN
7216  conv=(aem/parp(160+i))*vint(317)
7217  ELSEIF(vint(154).GT.parp(15)) THEN
7218  conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
7219  & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7220  ELSE
7221  conv=0d0
7222  ENDIF
7223  iv=max(1,i-1)
7224  DO 160 j=0,5
7225  sigt(0,i,j)=conv*sigtmp(iv,j)
7226  160 CONTINUE
7227  170 CONTINUE
7228  DO 180 j=0,5
7229  sigt(0,0,j)=sigt(0,1,j)+sigt(0,2,j)+sigt(0,3,j)+sigt(0,4,j)
7230  180 CONTINUE
7231 
7232 C...Both beam and target multiple processes.
7233  ELSE
7234  IF(mint(107).EQ.2) THEN
7235  vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
7236  ELSE
7237  vint(317)=16d0*parp(15)**2*vint(154)**2/
7238  & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
7239  ENDIF
7240  IF(mint(108).EQ.2) THEN
7241  vint(317)=vint(317)*(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
7242  ELSE
7243  vint(317)=vint(317)*16d0*parp(15)**2*vint(154)**2/
7244  & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
7245  ENDIF
7246  IF(mstp(20).GT.0) THEN
7247  vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)+
7248  & vint(308)))**mstp(20)
7249  ENDIF
7250  DO 210 i1=1,4
7251  DO 200 i2=1,4
7252  IF(mint(107).EQ.2) THEN
7253  conv=(aem/parp(160+i1))*vint(317)
7254  ELSEIF(vint(154).GT.parp(15)) THEN
7255  conv=(aem/paru(1))*(kchg(i1,1)/3d0)**2*parp(18)**2*
7256  & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7257  ELSE
7258  conv=0d0
7259  ENDIF
7260  IF(mint(108).EQ.2) THEN
7261  conv=conv*(aem/parp(160+i2))
7262  ELSEIF(vint(154).GT.parp(15)) THEN
7263  conv=conv*(aem/paru(1))*(kchg(i2,1)/3d0)**2*parp(18)**2*
7264  & (1d0/parp(15)**2-1d0/vint(154)**2)
7265  ELSE
7266  conv=0d0
7267  ENDIF
7268  IF(i1.LE.2) THEN
7269  iv=max(1,i2-1)
7270  ELSEIF(i2.LE.2) THEN
7271  iv=max(1,i1-1)
7272  ELSEIF(i1.EQ.i2) THEN
7273  iv=2*i1-2
7274  ELSE
7275  iv=5
7276  ENDIF
7277  DO 190 j=0,5
7278  jv=j
7279  IF(i2.GT.i1.AND.(j.EQ.2.OR.j.EQ.3)) jv=5-j
7280  sigt(i1,i2,j)=conv*sigtmp(iv,jv)
7281  190 CONTINUE
7282  200 CONTINUE
7283  210 CONTINUE
7284  DO 230 j=0,5
7285  DO 220 i=1,4
7286  sigt(i,0,j)=sigt(i,1,j)+sigt(i,2,j)+sigt(i,3,j)+sigt(i,4,j)
7287  sigt(0,i,j)=sigt(1,i,j)+sigt(2,i,j)+sigt(3,i,j)+sigt(4,i,j)
7288  220 CONTINUE
7289  sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
7290  230 CONTINUE
7291  ENDIF
7292 
7293 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7294  IF(iproc.EQ.21.OR.iproc.EQ.23.OR.iproc.EQ.25) THEN
7295  rfac=(xpar(iproc)*seps+ypar(iproc)*seta)/sigt(0,0,0)
7296  DO 260 i1=0,n1
7297  DO 250 i2=0,n2
7298  DO 240 j=0,5
7299  sigt(i1,i2,j)=rfac*sigt(i1,i2,j)
7300  240 CONTINUE
7301  250 CONTINUE
7302  260 CONTINUE
7303  ENDIF
7304 
7305  RETURN
7306  END
7307 
7308 C*********************************************************************
7309 
7310 C...PYMAXI
7311 C...Finds optimal set of coefficients for kinematical variable selection
7312 C...and the maximum of the part of the differential cross-section used
7313 C...in the event weighting.
7314 
7315  SUBROUTINE pymaxi
7316 
7317 C...Double precision and integer declarations.
7318  IMPLICIT DOUBLE PRECISION(a-h, o-z)
7319  IMPLICIT INTEGER(i-n)
7320  INTEGER pyk,pychge,pycomp
7321 C...Parameter statement to help give large particle numbers.
7322  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
7323  &kexcit=4000000,kdimen=5000000)
7324 
7325 C...User process initialization commonblock.
7326  INTEGER maxpup
7327  parameter(maxpup=100)
7328  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
7329  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
7330  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
7331  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
7332  &lprup(maxpup)
7333  SAVE /heprup/
7334 
7335 C...Commonblocks.
7336  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
7337  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
7338  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
7339  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
7340  common/pypars/mstp(200),parp(200),msti(200),pari(200)
7341  common/pyint1/mint(400),vint(400)
7342  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
7343  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
7344  common/pyint4/mwid(500),wids(500,5)
7345  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
7346  common/pyint6/proc(0:500)
7347  CHARACTER proc*28
7348  common/pyint7/sigt(0:6,0:6,0:5)
7349  common/pytcsm/itcm(0:99),rtcm(0:99)
7350  common/pytcco/coefx(194:380,2)
7351  common/tcpara/ires,jres,xmas(3),xwid(3),ymas(2),ywid(2)
7352  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
7353  &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint6/,/pyint7/,/pytcco/,
7354  &/pytcsm/,/tcpara/
7355 C...Local arrays, character variables and data.
7356  LOGICAL iok
7357  CHARACTER cvar(4)*4
7358  dimension npts(4),mvarpt(500,4),vintpt(500,30),sigspt(500),
7359  &narel(9),wtrel(9),wtmat(9,9),wtreln(9),coefu(9),coefo(9),
7360  &iaccmx(4),sigsmx(4),sigssm(3),pmmn(2),wtrsav(9),tempc(9),
7361  &iq(9),ip(9)
7362  DATA cvar/'tau ','tau''','y* ','cth '/
7363  DATA sigssm/3*0d0/
7364 
7365 C...Initial values and loop over subprocesses.
7366  nposi=0
7367  vint(143)=1d0
7368  vint(144)=1d0
7369  xsec(0,1)=0d0
7370  itech=0
7371  DO 460 isub=1,500
7372  mint(1)=isub
7373  mint(51)=0
7374 
7375 C...Find maximum weight factors for photon flux.
7376  IF(msub(isub).EQ.1.OR.(isub.GE.91.AND.isub.LE.100)) THEN
7377  IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(2,wtgaga)
7378  ENDIF
7379 
7380 C...Select subprocess to study: skip cases not applicable.
7381  IF(iset(isub).EQ.11) THEN
7382  IF(msub(isub).NE.1) goto 460
7383 C...User process intialization: cross section model dependent.
7384  IF(iabs(idwtup).EQ.1) THEN
7385  IF(idwtup.GT.0.AND.xmaxup(kfpr(isub,1)).LT.0d0) CALL
7386  & pyerrm(26,'(PYMAXI:) Negative XMAXUP for user process')
7387  xsec(isub,1)=1.00000001d-9*abs(xmaxup(kfpr(isub,1)))
7388  ELSE
7389  IF((idwtup.EQ.2.OR.idwtup.EQ.3).AND.
7390  & xsecup(kfpr(isub,1)).LT.0d0) CALL
7391  & pyerrm(26,'(PYMAXI:) Negative XSECUP for user process')
7392  IF(idwtup.EQ.2.AND.xmaxup(kfpr(isub,1)).LT.0d0) CALL
7393  & pyerrm(26,'(PYMAXI:) Negative XMAXUP for user process')
7394  xsec(isub,1)=1.00000001d-9*abs(xsecup(kfpr(isub,1)))
7395  ENDIF
7396  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7397  & wtgaga*xsec(isub,1)
7398  nposi=nposi+1
7399  goto 450
7400  ELSEIF(isub.GE.91.AND.isub.LE.95) THEN
7401  CALL pysigh(nchn,sigs)
7402  xsec(isub,1)=sigs
7403  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7404  & wtgaga*xsec(isub,1)
7405  IF(msub(isub).NE.1) goto 460
7406  nposi=nposi+1
7407  goto 450
7408  ELSEIF(isub.EQ.99.AND.msub(isub).EQ.1) THEN
7409  CALL pysigh(nchn,sigs)
7410  xsec(isub,1)=sigs
7411  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7412  & wtgaga*xsec(isub,1)
7413  IF(xsec(isub,1).EQ.0d0) THEN
7414  msub(isub)=0
7415  ELSE
7416  nposi=nposi+1
7417  ENDIF
7418  goto 450
7419  ELSEIF(isub.EQ.96) THEN
7420  IF(mint(50).EQ.0) goto 460
7421  IF(msub(95).NE.1.AND.mod(mstp(81),10).LE.0.AND.mstp(131).LE.0)
7422  & goto 460
7423  IF(mint(49).EQ.0.AND.mstp(131).EQ.0) goto 460
7424  ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.
7425  & isub.EQ.53.OR.isub.EQ.68) THEN
7426  IF(msub(isub).NE.1.OR.msub(95).EQ.1) goto 460
7427  ELSEIF(isub.GE.381.AND.isub.LE.386) THEN
7428  IF(msub(isub).NE.1.OR.msub(95).EQ.1) goto 460
7429  ELSE
7430  IF(msub(isub).NE.1) goto 460
7431  ENDIF
7432  istsb=iset(isub)
7433  IF(isub.EQ.96) istsb=2
7434  IF(mstp(122).GE.2) WRITE(mstu(11),5000) isub
7435  mwtxs=0
7436  IF(mstp(142).GE.1.AND.isub.NE.96.AND.msub(91)+msub(92)+msub(93)+
7437  & msub(94)+msub(95).EQ.0) mwtxs=1
7438 
7439 C...Find resonances (explicit or implicit in cross-section).
7440  mint(72)=0
7441  kfr1=0
7442  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
7443  kfr1=kfpr(isub,1)
7444  ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165
7445  & .OR.isub.EQ.171.OR.isub.EQ.176) THEN
7446  kfr1=23
7447  ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172
7448  & .OR.isub.EQ.177) THEN
7449  kfr1=24
7450  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
7451  kfr1=25
7452  IF(mstp(46).EQ.5) THEN
7453  kfr1=89
7454  pmas(89,1)=parp(45)
7455  pmas(89,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
7456  ENDIF
7457  ELSEIF(isub.EQ.481) THEN
7458  kfr1=9900001
7459  ENDIF
7460  ckmx=ckin(2)
7461  IF(ckmx.LE.0d0) ckmx=vint(1)
7462  kcr1=pycomp(kfr1)
7463  IF(kcr1.EQ.0) kfr1=0
7464  IF(kfr1.NE.0) THEN
7465  IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
7466  & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
7467  ENDIF
7468  IF(kfr1.NE.0) THEN
7469  taur1=pmas(kcr1,1)**2/vint(2)
7470  gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
7471  mint(72)=1
7472  mint(73)=kfr1
7473  vint(73)=taur1
7474  vint(74)=gamr1
7475  ENDIF
7476  kfr2=0
7477  kfr3=0
7478  IF(isub.EQ.141.OR.isub.EQ.194.OR.isub.EQ.195.OR.
7479  $ (isub.GE.361.AND.isub.LE.380))
7480  $ THEN
7481  kfr2=23
7482  IF(isub.EQ.141) THEN
7483  kcr2=pycomp(kfr2)
7484  IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
7485  & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) THEN
7486  kfr2=0
7487  ELSE
7488  taur2=pmas(kcr2,1)**2/vint(2)
7489  gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
7490  mint(72)=2
7491  mint(74)=kfr2
7492  vint(75)=taur2
7493  vint(76)=gamr2
7494  ENDIF
7495  ELSEIF(itech.EQ.0) THEN
7496  alprht=2.16d0*(3d0/dble(itcm(1)))
7497  itech=1
7498  kfr1=ktechn+113
7499  kcr1=pycomp(kfr1)
7500  kfr2=ktechn+223
7501  kcr2=pycomp(kfr2)
7502  kfr3=ktechn+115
7503  kcr3=pycomp(kfr3)
7504  ires=0
7505 C...Order the resonances
7506  IF(pmas(kcr3,1).LT.pmas(kcr2,1)) THEN
7507  kct=kcr3
7508  kcr3=kcr2
7509  kcr2=kct
7510  ENDIF
7511  IF(pmas(kcr3,1).LT.pmas(kcr1,1)) THEN
7512  kct=kcr3
7513  kcr3=kcr1
7514  kcr1=kct
7515  ENDIF
7516  IF(pmas(kcr2,1).LT.pmas(kcr1,1)) THEN
7517  kct=kcr2
7518  kcr2=kcr1
7519  kcr1=kct
7520  ENDIF
7521  DO 101 i=1,3
7522  IF(i.EQ.1) THEN
7523  shn0=pmas(kcr1,1)**2
7524  ELSEIF(i.EQ.2) THEN
7525  IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LE.1d-6) goto 101
7526  shn0=pmas(kcr2,1)**2
7527  ELSEIF(i.EQ.3) THEN
7528  IF(abs(pmas(kcr3,1)-pmas(kcr3,1)).LE.1d-6) goto 101
7529  shn0=pmas(kcr3,1)**2
7530  ENDIF
7531  aem=pyalem(shn0)
7532  far=sqrt(aem/alprht)
7533  shn=shn0*(1d0-far)
7534  CALL pytecm(shn,s1,wido,1)
7535  res=shn-s1
7536  shn=s1*.99d0
7537  shstep=2d0
7538  102 shn=shn+shstep
7539  CALL pytecm(shn,s1,wido,1)
7540  IF(res.LT.0d0.AND.shn-s1.GE.0d0) THEN
7541  iok=.false.
7542  IF(ires.GT.0) THEN
7543  IF(abs(sqrt(s1)-xmas(ires)).GT.1d-6) iok=.true.
7544  ELSEIF(ires.EQ.0) THEN
7545  iok=.true.
7546  ENDIF
7547  IF(iok) THEN
7548  ires=ires+1
7549  xmas(ires)=sqrt(s1)
7550  xwid(ires)=wido
7551  ENDIF
7552  ENDIF
7553  res=shn-s1
7554  IF(ires.LT.3.AND.shn.LT.shn0*(1d0+far)) goto 102
7555  101 CONTINUE
7556  jres=0
7557  kfr1=ktechn+213
7558  kcr1=pycomp(kfr1)
7559  kfr2=ktechn+215
7560  kcr2=pycomp(kfr2)
7561  IF(pmas(kcr2,1).LT.pmas(kcr1,1)) THEN
7562  kct=kcr2
7563  kcr2=kcr1
7564  kcr1=kct
7565  ENDIF
7566  DO 103 i=1,2
7567  IF(i.EQ.1) THEN
7568  shn0=pmas(kcr1,1)**2
7569  ELSEIF(i.EQ.2) THEN
7570  IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LE.1d-6) goto 103
7571  shn0=pmas(kcr2,1)**2
7572  ENDIF
7573  aem=pyalem(shn0)
7574  far=sqrt(aem/alprht)
7575  shn=shn0*(1d0-far)
7576  CALL pytecm(shn,s1,wido,2)
7577  res=shn-s1
7578  shn=s1*.99d0
7579  shstep=2d0
7580  104 shn=shn+shstep
7581  CALL pytecm(shn,s1,wido,2)
7582  IF(res.LT.0d0.AND.shn-s1.GE.0d0) THEN
7583  iok=.false.
7584  IF(jres.GT.0) THEN
7585  IF(abs(sqrt(s1)-xmas(ires)).GT.1d-6) iok=.true.
7586  ELSEIF(jres.EQ.0) THEN
7587  iok=.true.
7588  ENDIF
7589  IF(iok) THEN
7590  jres=jres+1
7591  ymas(jres)=sqrt(s1)
7592  ywid(jres)=wido
7593  ENDIF
7594  ENDIF
7595  res=shn-s1
7596  IF(jres.LT.2.AND.shn.LT.shn0*(1d0+far)) goto 104
7597  103 CONTINUE
7598  ENDIF
7599  IF(isub.EQ.194.OR.(isub.GE.361.AND.isub.LE.368).OR.
7600  & isub.EQ.379.OR.isub.EQ.380) THEN
7601  mint(72)=ires
7602  IF(ires.GE.1) THEN
7603  vint(73)=xmas(1)**2/vint(2)
7604  vint(74)=xmas(1)*xwid(1)/vint(2)
7605  taur1=vint(73)
7606  gamr1=vint(74)
7607  xm1=xmas(1)
7608  xg1=xwid(1)
7609  kfr1=1
7610  ENDIF
7611  IF(ires.GE.2) THEN
7612  vint(75)=xmas(2)**2/vint(2)
7613  vint(76)=xmas(2)*xwid(2)/vint(2)
7614  taur2=vint(75)
7615  gamr2=vint(76)
7616  xm2=xmas(2)
7617  xg2=xwid(2)
7618  kfr2=2
7619  ENDIF
7620  IF(ires.EQ.3) THEN
7621  vint(77)=xmas(3)**2/vint(2)
7622  vint(78)=xmas(3)*xwid(3)/vint(2)
7623  taur3=vint(77)
7624  gamr3=vint(78)
7625  xm3=xmas(3)
7626  xg3=xwid(3)
7627  kfr3=3
7628  ENDIF
7629 C...Charged current: rho+- and a+-
7630  ELSEIF(isub.EQ.195.OR.isub.GE.370.AND.isub.LE.378) THEN
7631  mint(72)=ires
7632  IF(jres.GE.1) THEN
7633  vint(73)=ymas(1)**2/vint(2)
7634  vint(74)=ymas(1)*ywid(1)/vint(2)
7635  kfr1=1
7636  taur1=vint(73)
7637  gamr1=vint(74)
7638  xm1=ymas(1)
7639  xg1=ywid(1)
7640  ENDIF
7641  IF(jres.GE.2) THEN
7642  vint(75)=ymas(2)**2/vint(2)
7643  vint(76)=ymas(2)*ywid(2)/vint(2)
7644  kfr2=2
7645  taur2=vint(73)
7646  gamr2=vint(74)
7647  xm2=ymas(2)
7648  xg2=ywid(2)
7649  ENDIF
7650  kfr3=0
7651  ENDIF
7652  IF(isub.NE.141) THEN
7653  IF(kfr1.NE.0.AND.(ckin(1).GT.(xm1+20d0*xg1)
7654  & .OR.ckmx.LT.(xm1-20d0*xg1))) kfr1=0
7655  IF(kfr2.NE.0.AND.(ckin(1).GT.(xm2+20d0*xg2)
7656  & .OR.ckmx.LT.(xm2-20d0*xg2))) kfr2=0
7657  IF(kfr3.NE.0.AND.(ckin(1).GT.(xm3+20d0*xg3)
7658  & .OR.ckmx.LT.(xm3-20d0*xg3))) kfr3=0
7659  IF(kfr3.NE.0.AND.kfr2.NE.0.AND.kfr1.NE.0) THEN
7660 
7661  ELSEIF(kfr1.NE.0.AND.kfr2.NE.0) THEN
7662  mint(72)=2
7663  ELSEIF(kfr1.NE.0.AND.kfr3.NE.0) THEN
7664  mint(72)=2
7665  mint(74)=kfr3
7666  vint(75)=taur3
7667  vint(76)=gamr3
7668  ELSEIF(kfr2.NE.0.AND.kfr3.NE.0) THEN
7669  mint(72)=2
7670  mint(73)=kfr2
7671  vint(73)=taur2
7672  vint(74)=gamr2
7673  mint(74)=kfr3
7674  vint(75)=taur3
7675  vint(76)=gamr3
7676  ELSEIF(kfr1.NE.0) THEN
7677  mint(72)=1
7678  ELSEIF(kfr2.NE.0) THEN
7679  mint(72)=1
7680  mint(73)=kfr2
7681  vint(73)=taur2
7682  vint(74)=gamr2
7683  ELSEIF(kfr3.NE.0) THEN
7684  mint(72)=1
7685  mint(73)=kfr3
7686  vint(73)=taur3
7687  vint(74)=gamr3
7688  ELSE
7689  mint(72)=0
7690  ENDIF
7691  ELSE
7692  IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
7693 
7694  ELSEIF(kfr2.NE.0) THEN
7695  kfr1=kfr2
7696  taur1=taur2
7697  gamr1=gamr2
7698  mint(72)=1
7699  mint(73)=kfr1
7700  vint(73)=taur1
7701  vint(74)=gamr1
7702  kfr2=0
7703  ELSE
7704  mint(72)=0
7705  ENDIF
7706  ENDIF
7707  ENDIF
7708 
7709 C...Find product masses and minimum pT of process.
7710  sqm3=0d0
7711  sqm4=0d0
7712  mint(71)=0
7713  vint(71)=ckin(3)
7714  vint(80)=1d0
7715  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
7716  nbw=0
7717  DO 110 i=1,2
7718  pmmn(i)=0d0
7719  IF(kfpr(isub,i).EQ.0) THEN
7720  ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
7721  & parp(41)) THEN
7722  IF(i.EQ.1) sqm3=pmas(pycomp(kfpr(isub,i)),1)**2
7723  IF(i.EQ.2) sqm4=pmas(pycomp(kfpr(isub,i)),1)**2
7724  ELSE
7725  nbw=nbw+1
7726 C...This prevents SUSY/t particles from becoming too light.
7727  kflw=kfpr(isub,i)
7728  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
7729  kcw=pycomp(kflw)
7730  pmmn(i)=pmas(kcw,1)
7731  DO 100 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
7732  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
7733  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
7734  & pmas(pycomp(kfdp(idc,2)),1)
7735  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
7736  & pmas(pycomp(kfdp(idc,3)),1)
7737  pmmn(i)=min(pmmn(i),pmsum)
7738  ENDIF
7739  100 CONTINUE
7740  ELSEIF(kflw.EQ.6) THEN
7741  pmmn(i)=pmas(24,1)+pmas(5,1)
7742  ENDIF
7743  ENDIF
7744  110 CONTINUE
7745  IF(nbw.GE.1) THEN
7746  ckin41=ckin(41)
7747  ckin43=ckin(43)
7748  ckin(41)=max(pmmn(1),ckin(41))
7749  ckin(43)=max(pmmn(2),ckin(43))
7750  CALL pyofsh(3,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
7751  ckin(41)=ckin41
7752  ckin(43)=ckin43
7753  IF(mint(51).EQ.1) THEN
7754  WRITE(mstu(11),5100) isub
7755  msub(isub)=0
7756  goto 460
7757  ENDIF
7758  sqm3=pqm3**2
7759  sqm4=pqm4**2
7760  ENDIF
7761  IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1
7762  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
7763  IF(isub.EQ.96.AND.mstp(82).LE.1) THEN
7764  vint(71)=parp(81)*(vint(1)/parp(89))**parp(90)
7765  ELSEIF(isub.EQ.96) THEN
7766  vint(71)=0.08d0*parp(82)*(vint(1)/parp(89))**parp(90)
7767  ENDIF
7768  ENDIF
7769  vint(63)=sqm3
7770  vint(64)=sqm4
7771 
7772 C...Prepare for additional variable choices in 2 -> 3.
7773  IF(istsb.EQ.5) THEN
7774  vint(201)=0d0
7775  IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
7776  vint(206)=vint(201)
7777  IF(isub.EQ.401.OR.isub.EQ.402) vint(206)=pmas(5,1)
7778  vint(204)=pmas(23,1)
7779  IF(isub.EQ.124.OR.isub.EQ.351) vint(204)=pmas(24,1)
7780  IF(isub.EQ.352) vint(204)=pmas(pycomp(9900024),1)
7781  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182
7782  & .OR.isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402)
7783  & vint(204)=vint(201)
7784  vint(209)=vint(204)
7785  IF(isub.EQ.401.OR.isub.EQ.402) vint(209)=vint(206)
7786  ENDIF
7787 
7788 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7789  ipeak7=0
7790  npts(1)=2+2*mint(72)
7791  IF(mint(47).EQ.1) THEN
7792  IF(istsb.EQ.1.OR.istsb.EQ.2) npts(1)=1
7793  ELSEIF(mint(47).GE.5) THEN
7794  IF(istsb.LE.2.OR.istsb.GT.5) THEN
7795  npts(1)=npts(1)+1
7796  ipeak7=1
7797  ENDIF
7798  ENDIF
7799  npts(2)=1
7800  IF(istsb.GE.3.AND.istsb.LE.5) THEN
7801  IF(mint(47).GE.2) npts(2)=2
7802  IF(mint(47).GE.5) npts(2)=3
7803  ENDIF
7804  npts(3)=1
7805  IF(mint(47).EQ.4.OR.mint(47).EQ.5) THEN
7806  npts(3)=3
7807  IF(mint(45).EQ.3) npts(3)=npts(3)+1
7808  IF(mint(46).EQ.3) npts(3)=npts(3)+1
7809  ENDIF
7810  npts(4)=1
7811  IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5
7812  ntry=npts(1)*npts(2)*npts(3)*npts(4)
7813 
7814 C...Reset coefficients of cross-section weighting.
7815  DO 120 j=1,20
7816  coef(isub,j)=0d0
7817  120 CONTINUE
7818  IF(isub.EQ.194.OR.isub.EQ.195.OR.(isub.GE.361
7819  & .AND.isub.LE.380)) THEN
7820  DO 125 j=1,2
7821  coefx(isub,j)=0d0
7822  125 CONTINUE
7823  ENDIF
7824  coef(isub,1)=1d0
7825  coef(isub,8)=0.5d0
7826  coef(isub,9)=0.5d0
7827  coef(isub,13)=1d0
7828  coef(isub,18)=1d0
7829  mcth=0
7830  mtaup=0
7831  metaup=0
7832  vint(23)=0d0
7833  vint(26)=0d0
7834  sigsam=0d0
7835 
7836 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7837 C...in grid of phase space points.
7838  CALL pyklim(1)
7839  metau=mint(51)
7840  nacc=0
7841  DO 150 itry=1,ntry
7842  mint(51)=0
7843  IF(metau.EQ.1) goto 150
7844  IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN
7845  mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))
7846  IF(mint(72).LE.2.AND.mtau.GT.2+2*mint(72)) THEN
7847  mtau=7
7848  ELSEIF(mint(72).EQ.3.AND.ipeak7.EQ.0.AND.mtau.GE.7) THEN
7849  mtau=mtau+1
7850  ENDIF
7851  rtau=0.5d0
7852 C...Special case when both resonances have same mass,
7853 C...as is often the case in process 194.
7854 c IF(MINT(72).GE.2) THEN
7855 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7856 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7857 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7858 c RTAU=0.4D0
7859 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7860 c RTAU=0.6D0
7861 c ENDIF
7862 c ENDIF
7863 c ENDIF
7864  CALL pykmap(1,mtau,rtau)
7865  IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)
7866  metaup=mint(51)
7867  ENDIF
7868  IF(metaup.EQ.1) goto 150
7869  IF(istsb.GE.3.AND.istsb.LE.5.AND.mod(itry-1,npts(3)*npts(4))
7870  & .EQ.0) THEN
7871  mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2))
7872  CALL pykmap(4,mtaup,0.5d0)
7873  ENDIF
7874  IF(mod(itry-1,npts(3)*npts(4)).EQ.0) THEN
7875  CALL pyklim(2)
7876  meyst=mint(51)
7877  ENDIF
7878  IF(meyst.EQ.1) goto 150
7879  IF(mod(itry-1,npts(4)).EQ.0) THEN
7880  myst=1+mod((itry-1)/npts(4),npts(3))
7881  IF(myst.EQ.4.AND.mint(45).NE.3) myst=5
7882  CALL pykmap(2,myst,0.5d0)
7883  CALL pyklim(3)
7884  mecth=mint(51)
7885  ENDIF
7886  IF(mecth.EQ.1) goto 150
7887  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
7888  mcth=1+mod(itry-1,npts(4))
7889  CALL pykmap(3,mcth,0.5d0)
7890  ENDIF
7891  IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)
7892 
7893 C...Store position and limits.
7894  mint(51)=0
7895  CALL pyklim(0)
7896  IF(mint(51).EQ.1) goto 150
7897  nacc=nacc+1
7898  mvarpt(nacc,1)=mtau
7899  mvarpt(nacc,2)=mtaup
7900  mvarpt(nacc,3)=myst
7901  mvarpt(nacc,4)=mcth
7902  DO 130 j=1,30
7903  vintpt(nacc,j)=vint(10+j)
7904  130 CONTINUE
7905 
7906 C...Normal case: calculate cross-section.
7907  IF(istsb.NE.5) THEN
7908  CALL pysigh(nchn,sigs)
7909  IF(mwtxs.EQ.1) THEN
7910  CALL pyevwt(wtxs)
7911  sigs=wtxs*sigs
7912  ENDIF
7913 
7914 C..2 -> 3: find highest value out of a number of tries.
7915  ELSE
7916  sigs=0d0
7917  DO 140 ikin3=1,mstp(129)
7918  CALL pykmap(5,0,0d0)
7919  IF(mint(51).EQ.1) goto 140
7920  CALL pysigh(nchn,sigtmp)
7921  IF(mwtxs.EQ.1) THEN
7922  CALL pyevwt(wtxs)
7923  sigtmp=wtxs*sigtmp
7924  ENDIF
7925  IF(sigtmp.GT.sigs) sigs=sigtmp
7926  140 CONTINUE
7927  ENDIF
7928 
7929 C...Store cross-section.
7930  sigspt(nacc)=sigs
7931  IF(sigs.GT.sigsam) sigsam=sigs
7932  IF(mstp(122).GE.2) WRITE(mstu(11),5200) mtau,myst,mcth,mtaup,
7933  & vint(21),vint(22),vint(23),vint(26),sigs
7934  150 CONTINUE
7935  IF(nacc.EQ.0) THEN
7936  WRITE(mstu(11),5100) isub
7937  msub(isub)=0
7938  goto 460
7939  ELSEIF(sigsam.EQ.0d0) THEN
7940  WRITE(mstu(11),5300) isub
7941  msub(isub)=0
7942  goto 460
7943  ENDIF
7944  IF(isub.NE.96) nposi=nposi+1
7945 
7946 C...Calculate integrals in tau over maximal phase space limits.
7947  taumin=vint(11)
7948  taumax=vint(31)
7949  atau1=log(taumax/taumin)
7950  IF(npts(1).GE.2) THEN
7951  atau2=(taumax-taumin)/(taumax*taumin)
7952  ENDIF
7953  IF(npts(1).GE.4) THEN
7954  atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
7955  atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/
7956  & gamr1
7957  ENDIF
7958  IF(npts(1).GE.6) THEN
7959  atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
7960  atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/
7961  & gamr2
7962  ENDIF
7963  IF(npts(1).GE.8) THEN
7964  atau8=log(taumax/taumin*(taumin+taur3)/(taumax+taur3))/taur3
7965  atau9=(atan((taumax-taur3)/gamr3)-atan((taumin-taur3)/gamr3))/
7966  & gamr3
7967  ENDIF
7968  IF(ipeak7.EQ.1) THEN
7969  atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
7970  ENDIF
7971 
7972 C...Reset. Sum up cross-sections in points calculated.
7973  DO 320 ivar=1,4
7974  IF(npts(ivar).EQ.1) goto 320
7975  IF(isub.EQ.96.AND.ivar.EQ.4) goto 320
7976  nbin=npts(ivar)
7977  DO 170 j1=1,nbin
7978  narel(j1)=0
7979  wtrel(j1)=0d0
7980  coefu(j1)=0d0
7981  DO 160 j2=1,nbin
7982  wtmat(j1,j2)=0d0
7983  160 CONTINUE
7984  170 CONTINUE
7985  DO 180 iacc=1,nacc
7986  ibin=mvarpt(iacc,ivar)
7987  IF(ivar.EQ.1) THEN
7988  IF(ibin.GT.7.AND.ipeak7.EQ.0) THEN
7989  ibin=ibin-1
7990  ELSEIF(ibin.EQ.7.AND.ipeak7.EQ.1.AND.mstp(72).LT.3) THEN
7991  ibin=3+2*mint(72)
7992  ENDIF
7993  ENDIF
7994  IF(ivar.EQ.3.AND.ibin.EQ.5.AND.mint(45).NE.3) ibin=4
7995  narel(ibin)=narel(ibin)+1
7996  wtrel(ibin)=wtrel(ibin)+sigspt(iacc)
7997 
7998 C...Sum up tau cross-section pieces in points used.
7999  IF(ivar.EQ.1) THEN
8000  tau=vintpt(iacc,11)
8001  wtmat(ibin,1)=wtmat(ibin,1)+1d0
8002  wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau
8003  IF(nbin.GE.4) THEN
8004  wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1)
8005  wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/
8006  & ((tau-taur1)**2+gamr1**2)
8007  ENDIF
8008  IF(nbin.GE.6) THEN
8009  wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2)
8010  wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/
8011  & ((tau-taur2)**2+gamr2**2)
8012  ENDIF
8013  IF(mint(72).LE.2.AND.ipeak7.EQ.1) THEN
8014  wtmat(ibin,3+2*mint(72))=wtmat(ibin,3+2*mint(72))
8015  & +(atau1/atau7)*tau/max(2d-10,1d0-tau)
8016  ELSEIF(mint(72).EQ.3.AND.ipeak7.EQ.1) THEN
8017  wtmat(ibin,7)=wtmat(ibin,7)
8018  & +(atau1/atau7)*tau/max(2d-10,1d0-tau)
8019  ENDIF
8020  IF(mint(72).EQ.3) THEN
8021  wtmat(ibin,7+ipeak7)=wtmat(ibin,7+ipeak7)
8022  & +(atau1/atau8)/(tau+taur3)
8023  wtmat(ibin,8+ipeak7)=wtmat(ibin,8+ipeak7)
8024  & +(atau1/atau9)*tau/((tau-taur3)**2+gamr3**2)
8025  ENDIF
8026 C...Sum up tau' cross-section pieces in points used.
8027  ELSEIF(ivar.EQ.2) THEN
8028  tau=vintpt(iacc,11)
8029  taup=vintpt(iacc,16)
8030  taupmn=vintpt(iacc,6)
8031  taupmx=vintpt(iacc,26)
8032  ataup1=log(taupmx/taupmn)
8033  ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
8034  wtmat(ibin,1)=wtmat(ibin,1)+1d0
8035  wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*
8036  & (1d0-tau/taup)**3/taup
8037  IF(nbin.GE.3) THEN
8038  ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
8039  wtmat(ibin,3)=wtmat(ibin,3)+(ataup1/ataup3)*
8040  & taup/max(2d-10,1d0-taup)
8041  ENDIF
8042 
8043 C...Sum up y* cross-section pieces in points used.
8044  ELSEIF(ivar.EQ.3) THEN
8045  yst=vintpt(iacc,12)
8046  ystmin=vintpt(iacc,2)
8047  ystmax=vintpt(iacc,22)
8048  ayst0=ystmax-ystmin
8049  ayst1=0.5d0*(ystmax-ystmin)**2
8050  ayst2=ayst1
8051  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
8052  wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)
8053  wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst2)*(ystmax-yst)
8054  wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst)
8055  IF(mint(45).EQ.3) THEN
8056  taue=vintpt(iacc,11)
8057  IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
8058  yst0=-0.5d0*log(taue)
8059  ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
8060  & max(1d-10,exp(yst0-ystmax)-1d0))
8061  wtmat(ibin,4)=wtmat(ibin,4)+(ayst0/ayst4)/
8062  & max(1d-10,1d0-exp(yst-yst0))
8063  ENDIF
8064  IF(mint(46).EQ.3) THEN
8065  taue=vintpt(iacc,11)
8066  IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
8067  yst0=-0.5d0*log(taue)
8068  ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
8069  & max(1d-10,exp(yst0+ystmin)-1d0))
8070  wtmat(ibin,nbin)=wtmat(ibin,nbin)+(ayst0/ayst5)/
8071  & max(1d-10,1d0-exp(-yst-yst0))
8072  ENDIF
8073 
8074 C...Sum up cos(theta-hat) cross-section pieces in points used.
8075  ELSE
8076  rm34=max(1d-20,2d0*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2)
8077  rsqm=1d0+rm34
8078  cthmax=sqrt(1d0-4d0*vint(71)**2/(taumax*vint(2)))
8079  cthmin=-cthmax
8080  IF(cthmax.GT.0.9999d0) rm34=max(rm34,2d0*vint(71)**2/
8081  & (taumax*vint(2)))
8082  acth1=cthmax-cthmin
8083  acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))
8084  acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))
8085  acth4=1d0/max(rm34,rsqm-cthmax)-1d0/max(rm34,rsqm-cthmin)
8086  acth5=1d0/max(rm34,rsqm+cthmin)-1d0/max(rm34,rsqm+cthmax)
8087  cth=vintpt(iacc,13)
8088  wtmat(ibin,1)=wtmat(ibin,1)+1d0
8089  wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/
8090  & max(rm34,rsqm-cth)
8091  wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/
8092  & max(rm34,rsqm+cth)
8093  wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/
8094  & max(rm34,rsqm-cth)**2
8095  wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/
8096  & max(rm34,rsqm+cth)**2
8097  ENDIF
8098  180 CONTINUE
8099 
8100 C...Check that equation system solvable.
8101  IF(mstp(122).GE.2) WRITE(mstu(11),5400) cvar(ivar)
8102  msolv=1
8103  wtrels=0d0
8104  DO 190 ibin=1,nbin
8105  IF(mstp(122).GE.2) WRITE(mstu(11),5500) (wtmat(ibin,ired),
8106  & ired=1,nbin),wtrel(ibin)
8107  IF(narel(ibin).EQ.0) msolv=0
8108  wtrels=wtrels+wtrel(ibin)
8109  190 CONTINUE
8110  IF(abs(wtrels).LT.1d-20) msolv=0
8111 
8112 C...Solve to find relative importance of cross-section pieces.
8113  IF(msolv.EQ.1) THEN
8114  DO 200 ibin=1,nbin
8115  wtreln(ibin)=max(0.1d0,wtrel(ibin)/wtrels)
8116  wtrsav(ibin)=wtrel(ibin)
8117  200 CONTINUE
8118 C...Auxiliary vectors to record order of permutations
8119  DO i=1,nbin
8120  ip(i) = i
8121  iq(i) = i
8122  ENDDO
8123  DO 230 ired=1,nbin-1
8124  mrow=ired
8125  resmax=abs(wtrel(mrow))
8126 C...Find row with largest residual
8127  DO jbin=ired+1,nbin
8128  IF(resmax.LT.abs(wtrel(jbin))) THEN
8129  mrow=jbin
8130  resmax=abs(wtrel(mrow))
8131  ENDIF
8132  ENDDO
8133  IF(resmax.LT.1d-20) THEN
8134  msolv=0
8135  goto 260
8136  ENDIF
8137  mcol = ired
8138  amax = abs(wtmat(mrow,mcol))
8139 C...Find column with largest entry
8140  DO jbin=ired+1,nbin
8141  IF (amax.LT.abs(wtmat(mrow,jbin))) THEN
8142  mcol = jbin
8143  amax = abs(wtmat(mrow,mcol))
8144  ENDIF
8145  ENDDO
8146 C...Swap rows if necessary
8147  IF(mrow.NE.ired) THEN
8148  DO jbin=1,nbin
8149  tmpe=wtmat(ired,jbin)
8150  wtmat(ired,jbin)=wtmat(mrow,jbin)
8151  wtmat(mrow,jbin)=tmpe
8152  ENDDO
8153  tmpe=wtrel(ired)
8154  wtrel(ired)=wtrel(mrow)
8155  wtrel(mrow)=tmpe
8156  mtmp=iq(ired)
8157  iq(ired)=iq(mrow)
8158  iq(mrow)=mtmp
8159  ENDIF
8160 C...Swap columns if necessary
8161  IF(mcol.NE.ired) THEN
8162  DO jbin=1,nbin
8163  tmpe=wtmat(jbin,ired)
8164  wtmat(jbin,ired)=wtmat(jbin,mcol)
8165  wtmat(jbin,mcol)=tmpe
8166  ENDDO
8167  mtmp=ip(ired)
8168  ip(ired)=ip(mcol)
8169  ip(mcol)=mtmp
8170  ENDIF
8171 C...Begin eliminating equations
8172  DO 220 ibin=ired+1,nbin
8173  IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
8174  msolv=0
8175  goto 260
8176  ENDIF
8177 C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8178  rqtu=wtmat(ibin,ired)
8179  rqtl=wtmat(ired,ired)
8180 C...Switch order of operations
8181  wtrel(ibin)=wtrel(ibin)-rqtu*
8182  $ (wtrel(ired)/rqtl)
8183  DO 210 icoe=ired,nbin
8184  wtmat(ibin,icoe)=wtmat(ibin,icoe)-
8185  $ rqtu*(wtmat(ired,icoe)/rqtl)
8186  210 CONTINUE
8187  220 CONTINUE
8188  230 CONTINUE
8189  DO 250 ired=nbin,1,-1
8190  DO 240 icoe=ired+1,nbin
8191  wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)
8192  240 CONTINUE
8193  IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
8194  msolv=0
8195  goto 260
8196  ENDIF
8197  coefu(ired)=wtrel(ired)/wtmat(ired,ired)
8198  tempc(ired)=coefu(ired)
8199  250 CONTINUE
8200 C...Return to original order
8201  DO ibin=1,nbin
8202  mtmp=ip(ibin)
8203  coefu(mtmp)=tempc(ibin)
8204  ENDDO
8205  ENDIF
8206 
8207 C...Share evenly if failure.
8208  260 IF(msolv.EQ.0) THEN
8209  DO 270 ibin=1,nbin
8210  coefu(ibin)=1d0
8211  wtreln(ibin)=0.1d0
8212  IF(wtrels.GT.0d0) wtreln(ibin)=max(0.1d0,
8213  & wtrsav(ibin)/wtrels)
8214  270 CONTINUE
8215  ENDIF
8216 
8217 C...Normalize coefficients, with piece shared democratically.
8218  coefsu=0d0
8219  wtrels=0d0
8220  DO 280 ibin=1,nbin
8221  coefu(ibin)=max(0d0,coefu(ibin))
8222  coefsu=coefsu+coefu(ibin)
8223  wtrels=wtrels+wtreln(ibin)
8224  280 CONTINUE
8225  IF(coefsu.GT.0d0) THEN
8226  DO 290 ibin=1,nbin
8227  coefo(ibin)=parp(122)/nbin+(1d0-parp(122))*0.5d0*
8228  & (coefu(ibin)/coefsu+wtreln(ibin)/wtrels)
8229  290 CONTINUE
8230  ELSE
8231  DO 300 ibin=1,nbin
8232  coefo(ibin)=1d0/nbin
8233  300 CONTINUE
8234  ENDIF
8235  IF(ivar.EQ.1) ioff=0
8236  IF(ivar.EQ.2) ioff=17
8237  IF(ivar.EQ.3) ioff=7
8238  IF(ivar.EQ.4) ioff=12
8239  DO 310 ibin=1,nbin
8240  icof=ioff+ibin
8241  IF(ivar.EQ.1) THEN
8242  IF(ibin.EQ.nbin.AND.(mint(72).LE.2.AND.ipeak7.EQ.1)) THEN
8243  icof=7
8244  ENDIF
8245  ENDIF
8246  IF(ivar.EQ.3.AND.ibin.EQ.4.AND.mint(45).NE.3) icof=icof+1
8247  IF(ivar.EQ.1.AND.ibin.GE.7+ipeak7.AND.mint(72).EQ.3) THEN
8248  coefx(isub,ibin-6-ipeak7)=coefo(ibin)
8249  ELSE
8250  coef(isub,icof)=coefo(ibin)
8251  ENDIF
8252  310 CONTINUE
8253 
8254  IF(mstp(122).GE.2) WRITE(mstu(11),5600) cvar(ivar),
8255  & (coefo(ibin),ibin=1,nbin)
8256 
8257  320 CONTINUE
8258 
8259 C...Find two most promising maxima among points previously determined.
8260  DO 330 j=1,4
8261  iaccmx(j)=0
8262  sigsmx(j)=0d0
8263  330 CONTINUE
8264  nmax=0
8265  DO 390 iacc=1,nacc
8266  DO 340 j=1,30
8267  vint(10+j)=vintpt(iacc,j)
8268  340 CONTINUE
8269  IF(istsb.NE.5) THEN
8270  CALL pysigh(nchn,sigs)
8271  IF(mwtxs.EQ.1) THEN
8272  CALL pyevwt(wtxs)
8273  sigs=wtxs*sigs
8274  ENDIF
8275  ELSE
8276  sigs=0d0
8277  DO 350 ikin3=1,mstp(129)
8278  CALL pykmap(5,0,0d0)
8279  IF(mint(51).EQ.1) goto 350
8280  CALL pysigh(nchn,sigtmp)
8281  IF(mwtxs.EQ.1) THEN
8282  CALL pyevwt(wtxs)
8283  sigtmp=wtxs*sigtmp
8284  ENDIF
8285  IF(sigtmp.GT.sigs) sigs=sigtmp
8286  350 CONTINUE
8287  ENDIF
8288  ieq=0
8289  DO 360 imv=1,nmax
8290  IF(abs(sigs-sigsmx(imv)).LT.1d-4*(sigs+sigsmx(imv))) ieq=imv
8291  360 CONTINUE
8292  IF(ieq.EQ.0) THEN
8293  DO 370 imv=nmax,1,-1
8294  iin=imv+1
8295  IF(sigs.LE.sigsmx(imv)) goto 380
8296  iaccmx(imv+1)=iaccmx(imv)
8297  sigsmx(imv+1)=sigsmx(imv)
8298  370 CONTINUE
8299  iin=1
8300  380 iaccmx(iin)=iacc
8301  sigsmx(iin)=sigs
8302  IF(nmax.LE.1) nmax=nmax+1
8303  ENDIF
8304  390 CONTINUE
8305 
8306 C...Read out starting position for search.
8307  IF(mstp(122).GE.2) WRITE(mstu(11),5700)
8308  sigsam=sigsmx(1)
8309  DO 440 imax=1,nmax
8310  iacc=iaccmx(imax)
8311  mtau=mvarpt(iacc,1)
8312  mtaup=mvarpt(iacc,2)
8313  myst=mvarpt(iacc,3)
8314  mcth=mvarpt(iacc,4)
8315  vtau=0.5d0
8316  vyst=0.5d0
8317  vcth=0.5d0
8318  vtaup=0.5d0
8319 
8320 C...Starting point and step size in parameter space.
8321  DO 430 irpt=1,2
8322  DO 420 ivar=1,4
8323  IF(npts(ivar).EQ.1) goto 420
8324  IF(ivar.EQ.1) vvar=vtau
8325  IF(ivar.EQ.2) vvar=vtaup
8326  IF(ivar.EQ.3) vvar=vyst
8327  IF(ivar.EQ.4) vvar=vcth
8328  IF(ivar.EQ.1) mvar=mtau
8329  IF(ivar.EQ.2) mvar=mtaup
8330  IF(ivar.EQ.3) mvar=myst
8331  IF(ivar.EQ.4) mvar=mcth
8332  IF(irpt.EQ.1) vdel=0.1d0
8333  IF(irpt.EQ.2) vdel=max(0.01d0,min(0.05d0,vvar-0.02d0,
8334  & 0.98d0-vvar))
8335  IF(irpt.EQ.1) vmar=0.02d0
8336  IF(irpt.EQ.2) vmar=0.002d0
8337  imov0=1
8338  IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0
8339  DO 410 imov=imov0,8
8340 
8341 C...Define new point in parameter space.
8342  IF(imov.EQ.0) THEN
8343  inew=2
8344  vnew=vvar
8345  ELSEIF(imov.EQ.1) THEN
8346  inew=3
8347  vnew=vvar+vdel
8348  ELSEIF(imov.EQ.2) THEN
8349  inew=1
8350  vnew=vvar-vdel
8351  ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND.
8352  & vvar+2d0*vdel.LT.1d0-vmar) THEN
8353  vvar=vvar+vdel
8354  sigssm(1)=sigssm(2)
8355  sigssm(2)=sigssm(3)
8356  inew=3
8357  vnew=vvar+vdel
8358  ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND.
8359  & vvar-2d0*vdel.GT.vmar) THEN
8360  vvar=vvar-vdel
8361  sigssm(3)=sigssm(2)
8362  sigssm(2)=sigssm(1)
8363  inew=1
8364  vnew=vvar-vdel
8365  ELSEIF(sigssm(3).GE.sigssm(1)) THEN
8366  vdel=0.5d0*vdel
8367  vvar=vvar+vdel
8368  sigssm(1)=sigssm(2)
8369  inew=2
8370  vnew=vvar
8371  ELSE
8372  vdel=0.5d0*vdel
8373  vvar=vvar-vdel
8374  sigssm(3)=sigssm(2)
8375  inew=2
8376  vnew=vvar
8377  ENDIF
8378 
8379 C...Convert to relevant variables and find derived new limits.
8380  ilerr=0
8381  IF(ivar.EQ.1) THEN
8382  vtau=vnew
8383  CALL pykmap(1,mtau,vtau)
8384  IF(istsb.GE.3.AND.istsb.LE.5) THEN
8385  CALL pyklim(4)
8386  IF(mint(51).EQ.1) ilerr=1
8387  ENDIF
8388  ENDIF
8389  IF(ivar.LE.2.AND.istsb.GE.3.AND.istsb.LE.5.AND.
8390  & ilerr.EQ.0) THEN
8391  IF(ivar.EQ.2) vtaup=vnew
8392  CALL pykmap(4,mtaup,vtaup)
8393  ENDIF
8394  IF(ivar.LE.2.AND.ilerr.EQ.0) THEN
8395  CALL pyklim(2)
8396  IF(mint(51).EQ.1) ilerr=1
8397  ENDIF
8398  IF(ivar.LE.3.AND.ilerr.EQ.0) THEN
8399  IF(ivar.EQ.3) vyst=vnew
8400  CALL pykmap(2,myst,vyst)
8401  CALL pyklim(3)
8402  IF(mint(51).EQ.1) ilerr=1
8403  ENDIF
8404  IF((istsb.EQ.2.OR.istsb.EQ.4.OR.istsb.EQ.6).AND.
8405  & ilerr.EQ.0) THEN
8406  IF(ivar.EQ.4) vcth=vnew
8407  CALL pykmap(3,mcth,vcth)
8408  ENDIF
8409  IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2)
8410 
8411 C...Evaluate cross-section. Save new maximum. Final maximum.
8412  IF(ilerr.NE.0) THEN
8413  sigs=0.
8414  ELSEIF(istsb.NE.5) THEN
8415  CALL pysigh(nchn,sigs)
8416  IF(mwtxs.EQ.1) THEN
8417  CALL pyevwt(wtxs)
8418  sigs=wtxs*sigs
8419  ENDIF
8420  ELSE
8421  sigs=0d0
8422  DO 400 ikin3=1,mstp(129)
8423  CALL pykmap(5,0,0d0)
8424  IF(mint(51).EQ.1) goto 400
8425  CALL pysigh(nchn,sigtmp)
8426  IF(mwtxs.EQ.1) THEN
8427  CALL pyevwt(wtxs)
8428  sigtmp=wtxs*sigtmp
8429  ENDIF
8430  IF(sigtmp.GT.sigs) sigs=sigtmp
8431  400 CONTINUE
8432  ENDIF
8433  sigssm(inew)=sigs
8434  IF(sigs.GT.sigsam) sigsam=sigs
8435  IF(mstp(122).GE.2) WRITE(mstu(11),5800) imax,ivar,mvar,
8436  & imov,vnew,vint(21),vint(22),vint(23),vint(26),sigs
8437  410 CONTINUE
8438  420 CONTINUE
8439  430 CONTINUE
8440  440 CONTINUE
8441  IF(mstp(121).EQ.1) sigsam=parp(121)*sigsam
8442  xsec(isub,1)=1.05d0*sigsam
8443 C...Add extra headroom for UED
8444  IF(isub.GT.310.AND.isub.LT.320) xsec(isub,1)=xsec(isub,1)*1.1d0
8445  IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
8446  & wtgaga*xsec(isub,1)
8447  450 CONTINUE
8448  IF(mstp(173).EQ.1.AND.isub.NE.96) xsec(isub,1)=
8449  & parp(174)*xsec(isub,1)
8450  IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)
8451  460 CONTINUE
8452  mint(51)=0
8453 
8454 C...Print summary table.
8455  IF(mint(121).EQ.1.AND.nposi.EQ.0) THEN
8456  IF(mstp(127).NE.1) THEN
8457  WRITE(mstu(11),5900)
8458  CALL pystop(1)
8459  ELSE
8460  WRITE(mstu(11),6400)
8461  msti(53)=1
8462  ENDIF
8463  ENDIF
8464  IF(mstp(122).GE.1) THEN
8465  WRITE(mstu(11),6000)
8466  WRITE(mstu(11),6100)
8467  DO 470 isub=1,500
8468  IF(msub(isub).NE.1.AND.isub.NE.96) goto 470
8469  IF(isub.EQ.96.AND.mint(50).EQ.0) goto 470
8470  IF(isub.EQ.96.AND.msub(95).NE.1.AND.mod(mstp(81),10).LE.0)
8471  & goto 470
8472  IF(isub.EQ.96.AND.mint(49).EQ.0.AND.mstp(131).EQ.0) goto 470
8473  IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13
8474  & .OR.isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) goto 470
8475  IF(msub(95).EQ.1.AND.isub.GE.381.AND.isub.LE.386) goto 470
8476  WRITE(mstu(11),6200) isub,proc(isub),xsec(isub,1)
8477  470 CONTINUE
8478  WRITE(mstu(11),6300)
8479  ENDIF
8480 
8481 C...Format statements for maximization results.
8482  5000 FORMAT(/1x,'Coefficient optimization and maximum search for ',
8483  &'subprocess no',i4/1x,'Coefficient modes tau',10x,'y*',9x,
8484  &'cth',9x,'tau''',7x,'sigma')
8485  5100 FORMAT(1x,'Warning: requested subprocess ',i3,' has no allowed ',
8486  &'phase space.'/1x,'Process switched off!')
8487  5200 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,d12.4)
8488  5300 FORMAT(1x,'Warning: requested subprocess ',i3,' has vanishing ',
8489  &'cross-section.'/1x,'Process switched off!')
8490  5400 FORMAT(1x,'Coefficients of equation system to be solved for ',a4)
8491  5500 FORMAT(1x,1p,10d11.3)
8492  5600 FORMAT(1x,'Result for ',a4,':',9f9.4)
8493  5700 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',
8494  &'MOD MOV VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma')
8495  5800 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,d12.4)
8496  5900 FORMAT(1x,'Error: no requested process has non-vanishing ',
8497  &'cross-section.'/1x,'Execution stopped!')
8498  6000 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',
8499  &'cross-section maximum search',1x,8('*'))
8500  6100 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I ISUB ',
8501  &'Subprocess name',15x,'I Maximum value I'/11x,'I',38x,'I',
8502  &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')
8503  6200 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,d12.4,3x,'I')
8504  6300 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))
8505  6400 FORMAT(1x,'Error: no requested process has non-vanishing ',
8506  &'cross-section.'/
8507  &1x,'Execution will stop if you try to generate events.')
8508 
8509  RETURN
8510  END
8511 
8512 C*********************************************************************
8513 
8514 C...PYPILE
8515 C...Initializes multiplicity distribution and selects mutliplicity
8516 C...of pileup events, i.e. several events occuring at the same
8517 C...beam crossing.
8518 
8519  SUBROUTINE pypile(MPILE)
8520 
8521 C...Double precision and integer declarations.
8522  IMPLICIT DOUBLE PRECISION(a-h, o-z)
8523  IMPLICIT INTEGER(i-n)
8524  INTEGER pyk,pychge,pycomp
8525 C...Commonblocks.
8526  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
8527  common/pypars/mstp(200),parp(200),msti(200),pari(200)
8528  common/pyint1/mint(400),vint(400)
8529  common/pyint7/sigt(0:6,0:6,0:5)
8530  SAVE /pydat1/,/pypars/,/pyint1/,/pyint7/
8531 C...Local arrays and saved variables.
8532  dimension wti(0:200)
8533  SAVE imin,imax,wti,wts
8534 
8535 C...Sum of allowed cross-sections for pileup events.
8536  IF(mpile.EQ.1) THEN
8537  vint(131)=sigt(0,0,5)
8538  IF(mstp(132).GE.2) vint(131)=vint(131)+sigt(0,0,4)
8539  IF(mstp(132).GE.3) vint(131)=vint(131)+sigt(0,0,2)+sigt(0,0,3)
8540  IF(mstp(132).GE.4) vint(131)=vint(131)+sigt(0,0,1)
8541  IF(mstp(133).LE.0) RETURN
8542 
8543 C...Initialize multiplicity distribution at maximum.
8544  xnave=vint(131)*parp(131)
8545  IF(xnave.GT.120d0) WRITE(mstu(11),5000) xnave
8546  inave=max(1,min(200,nint(xnave)))
8547  wti(inave)=1d0
8548  wts=wti(inave)
8549  wtn=wti(inave)*inave
8550 
8551 C...Find shape of multiplicity distribution below maximum.
8552  imin=inave
8553  DO 100 i=inave-1,1,-1
8554  IF(mstp(133).EQ.1) wti(i)=wti(i+1)*(i+1)/xnave
8555  IF(mstp(133).GE.2) wti(i)=wti(i+1)*i/xnave
8556  IF(wti(i).LT.1d-6) goto 110
8557  wts=wts+wti(i)
8558  wtn=wtn+wti(i)*i
8559  imin=i
8560  100 CONTINUE
8561 
8562 C...Find shape of multiplicity distribution above maximum.
8563  110 imax=inave
8564  DO 120 i=inave+1,200
8565  IF(mstp(133).EQ.1) wti(i)=wti(i-1)*xnave/i
8566  IF(mstp(133).GE.2) wti(i)=wti(i-1)*xnave/(i-1)
8567  IF(wti(i).LT.1d-6) goto 130
8568  wts=wts+wti(i)
8569  wtn=wtn+wti(i)*i
8570  imax=i
8571  120 CONTINUE
8572  130 vint(132)=xnave
8573  vint(133)=wtn/wts
8574  IF(mstp(133).EQ.1.AND.imin.EQ.1) vint(134)=
8575  & wts/(wts+wti(1)/xnave)
8576  IF(mstp(133).EQ.1.AND.imin.GT.1) vint(134)=1d0
8577  IF(mstp(133).GE.2) vint(134)=xnave
8578 
8579 C...Pick multiplicity of pileup events.
8580  ELSE
8581  IF(mstp(133).LE.0) THEN
8582  mint(81)=max(1,mstp(134))
8583  ELSE
8584  wtr=wts*pyr(0)
8585  DO 140 i=imin,imax
8586  mint(81)=i
8587  wtr=wtr-wti(i)
8588  IF(wtr.LE.0d0) goto 150
8589  140 CONTINUE
8590  150 CONTINUE
8591  ENDIF
8592  ENDIF
8593 
8594 C...Format statement for error message.
8595  5000 FORMAT(1x,'Warning: requested average number of events per bunch',
8596  &'crossing too large, ',1p,d12.4)
8597 
8598  RETURN
8599  END
8600 
8601 C*********************************************************************
8602 
8603 C...PYSAVE
8604 C...Saves and restores parameter and cross section values for the
8605 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8606 C...Also makes random choice between alternatives.
8607 
8608  SUBROUTINE pysave(ISAVE,IGA)
8609 
8610 C...Double precision and integer declarations.
8611  IMPLICIT DOUBLE PRECISION(a-h, o-z)
8612  IMPLICIT INTEGER(i-n)
8613  INTEGER pyk,pychge,pycomp
8614 C...Commonblocks.
8615  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
8616  common/pypars/mstp(200),parp(200),msti(200),pari(200)
8617  common/pyint1/mint(400),vint(400)
8618  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
8619  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
8620  common/pyint7/sigt(0:6,0:6,0:5)
8621  SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint5/,/pyint7/
8622 C...Local arrays and saved variables.
8623  dimension ncp(15),nsubcp(15,20),msubcp(15,20),coefcp(15,20,20),
8624  &ngencp(15,0:20,3),xseccp(15,0:20,3),sigtcp(15,0:6,0:6,0:5),
8625  &intcp(15,20),recp(15,20)
8626  SAVE ncp,nsubcp,msubcp,coefcp,ngencp,xseccp,sigtcp,intcp,recp
8627 
8628 C...Save list of subprocesses and cross-section information.
8629  IF(isave.EQ.1) THEN
8630  icp=0
8631  DO 120 i=1,500
8632  IF(msub(i).EQ.0.AND.i.NE.96.AND.i.NE.97) goto 120
8633  icp=icp+1
8634  nsubcp(iga,icp)=i
8635  msubcp(iga,icp)=msub(i)
8636  DO 100 j=1,20
8637  coefcp(iga,icp,j)=coef(i,j)
8638  100 CONTINUE
8639  DO 110 j=1,3
8640  ngencp(iga,icp,j)=ngen(i,j)
8641  xseccp(iga,icp,j)=xsec(i,j)
8642  110 CONTINUE
8643  120 CONTINUE
8644  ncp(iga)=icp
8645  DO 130 j=1,3
8646  ngencp(iga,0,j)=ngen(0,j)
8647  xseccp(iga,0,j)=xsec(0,j)
8648  130 CONTINUE
8649  DO 160 i1=0,6
8650  DO 150 i2=0,6
8651  DO 140 j=0,5
8652  sigtcp(iga,i1,i2,j)=sigt(i1,i2,j)
8653  140 CONTINUE
8654  150 CONTINUE
8655  160 CONTINUE
8656 
8657 C...Save various common process variables.
8658  DO 170 j=1,10
8659  intcp(iga,j)=mint(40+j)
8660  170 CONTINUE
8661  intcp(iga,11)=mint(101)
8662  intcp(iga,12)=mint(102)
8663  intcp(iga,13)=mint(107)
8664  intcp(iga,14)=mint(108)
8665  intcp(iga,15)=mint(123)
8666  recp(iga,1)=ckin(3)
8667  recp(iga,2)=vint(318)
8668 
8669 C...Save cross-section information only.
8670  ELSEIF(isave.EQ.2) THEN
8671  DO 190 icp=1,ncp(iga)
8672  i=nsubcp(iga,icp)
8673  DO 180 j=1,3
8674  ngencp(iga,icp,j)=ngen(i,j)
8675  xseccp(iga,icp,j)=xsec(i,j)
8676  180 CONTINUE
8677  190 CONTINUE
8678  DO 200 j=1,3
8679  ngencp(iga,0,j)=ngen(0,j)
8680  xseccp(iga,0,j)=xsec(0,j)
8681  200 CONTINUE
8682 
8683 C...Choose between allowed alternatives.
8684  ELSEIF(isave.EQ.3.OR.isave.EQ.4) THEN
8685  IF(isave.EQ.4) THEN
8686  xsumcp=0d0
8687  DO 210 ig=1,mint(121)
8688  xsumcp=xsumcp+xseccp(ig,0,1)
8689  210 CONTINUE
8690  xsumcp=xsumcp*pyr(0)
8691  DO 220 ig=1,mint(121)
8692  iga=ig
8693  xsumcp=xsumcp-xseccp(ig,0,1)
8694  IF(xsumcp.LE.0d0) goto 230
8695  220 CONTINUE
8696  230 CONTINUE
8697  ENDIF
8698 
8699 C...Restore cross-section information.
8700  DO 240 i=1,500
8701  msub(i)=0
8702  240 CONTINUE
8703  DO 270 icp=1,ncp(iga)
8704  i=nsubcp(iga,icp)
8705  msub(i)=msubcp(iga,icp)
8706  DO 250 j=1,20
8707  coef(i,j)=coefcp(iga,icp,j)
8708  250 CONTINUE
8709  DO 260 j=1,3
8710  ngen(i,j)=ngencp(iga,icp,j)
8711  xsec(i,j)=xseccp(iga,icp,j)
8712  260 CONTINUE
8713  270 CONTINUE
8714  DO 280 j=1,3
8715  ngen(0,j)=ngencp(iga,0,j)
8716  xsec(0,j)=xseccp(iga,0,j)
8717  280 CONTINUE
8718  DO 310 i1=0,6
8719  DO 300 i2=0,6
8720  DO 290 j=0,5
8721  sigt(i1,i2,j)=sigtcp(iga,i1,i2,j)
8722  290 CONTINUE
8723  300 CONTINUE
8724  310 CONTINUE
8725 
8726 C...Restore various common process variables.
8727  DO 320 j=1,10
8728  mint(40+j)=intcp(iga,j)
8729  320 CONTINUE
8730  mint(101)=intcp(iga,11)
8731  mint(102)=intcp(iga,12)
8732  mint(107)=intcp(iga,13)
8733  mint(108)=intcp(iga,14)
8734  mint(123)=intcp(iga,15)
8735  ckin(3)=recp(iga,1)
8736  ckin(1)=2d0*ckin(3)
8737  vint(318)=recp(iga,2)
8738 
8739 C...Sum up cross-section info (for PYSTAT).
8740  ELSEIF(isave.EQ.5) THEN
8741  DO 330 i=1,500
8742  msub(i)=0
8743  ngen(i,1)=0
8744  ngen(i,3)=0
8745  xsec(i,3)=0d0
8746  330 CONTINUE
8747  ngen(0,1)=0
8748  ngen(0,2)=0
8749  ngen(0,3)=0
8750  xsec(0,3)=0
8751  DO 350 ig=1,mint(121)
8752  DO 340 icp=1,ncp(ig)
8753  i=nsubcp(ig,icp)
8754  IF(msubcp(ig,icp).EQ.1) msub(i)=1
8755  ngen(i,1)=ngen(i,1)+ngencp(ig,icp,1)
8756  ngen(i,3)=ngen(i,3)+ngencp(ig,icp,3)
8757  xsec(i,3)=xsec(i,3)+xseccp(ig,icp,3)
8758  340 CONTINUE
8759  ngen(0,1)=ngen(0,1)+ngencp(ig,0,1)
8760  ngen(0,2)=ngen(0,2)+ngencp(ig,0,2)
8761  ngen(0,3)=ngen(0,3)+ngencp(ig,0,3)
8762  xsec(0,3)=xsec(0,3)+xseccp(ig,0,3)
8763  350 CONTINUE
8764  ENDIF
8765 
8766  RETURN
8767  END
8768 
8769 C*********************************************************************
8770 
8771 C...PYGAGA
8772 C...For lepton beams it gives photon-hadron or photon-photon systems
8773 C...to be treated with the ordinary machinery and combines this with a
8774 C...description of the lepton -> lepton + photon branching.
8775 
8776  SUBROUTINE pygaga(IGAGA,WTGAGA)
8777 
8778 C...Double precision and integer declarations.
8779  IMPLICIT DOUBLE PRECISION(a-h, o-z)
8780  IMPLICIT INTEGER(i-n)
8781  INTEGER pyk,pychge,pycomp
8782 C...Commonblocks.
8783  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
8784  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
8785  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
8786  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
8787  common/pypars/mstp(200),parp(200),msti(200),pari(200)
8788  common/pyint1/mint(400),vint(400)
8789  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
8790  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
8791  &/pyint5/
8792 C...Local variables and data statement.
8793  dimension pms(2),xmin(2),xmax(2),q2min(2),q2max(2),pmc(3),
8794  &x(2),q2(2),y(2),theta(2),phi(2),pt(2),beta(3)
8795  SAVE pms,xmin,xmax,q2min,q2max,pmc,x,q2,theta,phi,pt,w2min
8796  DATA eps/1d-4/
8797 
8798 C...Initialize generation of photons inside leptons.
8799  IF(igaga.EQ.1) THEN
8800 
8801 C...Save quantities on incoming lepton system.
8802  vint(301)=vint(1)
8803  vint(302)=vint(2)
8804  pms(1)=vint(303)**2
8805  IF(mint(141).EQ.0) pms(1)=sign(vint(3)**2,vint(3))
8806  pms(2)=vint(304)**2
8807  IF(mint(142).EQ.0) pms(2)=sign(vint(4)**2,vint(4))
8808  pmc(3)=vint(302)-pms(1)-pms(2)
8809  w2min=max(ckin(77),2d0*ckin(3),2d0*ckin(5))**2
8810 
8811 C...Calculate range of x and Q2 values allowed in generation.
8812  DO 100 i=1,2
8813  pmc(i)=vint(302)+pms(i)-pms(3-i)
8814  IF(mint(140+i).NE.0) THEN
8815  xmin(i)=max(ckin(59+2*i),eps)
8816  xmax(i)=min(ckin(60+2*i),1d0-2d0*vint(301)*sqrt(pms(i))/
8817  & pmc(i),1d0-eps)
8818  ymin=max(ckin(71+2*i),eps)
8819  ymax=min(ckin(72+2*i),1d0-eps)
8820  IF(ckin(64+2*i).GT.0d0) xmin(i)=max(xmin(i),
8821  & (ymin*pmc(3)-ckin(64+2*i))/pmc(i))
8822  xmax(i)=min(xmax(i),(ymax*pmc(3)-ckin(63+2*i))/pmc(i))
8823  themin=max(ckin(67+2*i),0d0)
8824  themax=min(ckin(68+2*i),paru(1))
8825  IF(ckin(68+2*i).LT.0d0) themax=paru(1)
8826  q2min(i)=max(ckin(63+2*i),xmin(i)**2*pms(i)/(1d0-xmin(i))+
8827  & ((1d0-xmax(i))*(vint(302)-2d0*pms(3-i))-
8828  & 2d0*pms(i)/(1d0-xmax(i)))*sin(themin/2d0)**2,0d0)
8829  q2max(i)=xmax(i)**2*pms(i)/(1d0-xmax(i))+
8830  & ((1d0-xmin(i))*(vint(302)-2d0*pms(3-i))-
8831  & 2d0*pms(i)/(1d0-xmin(i)))*sin(themax/2d0)**2
8832  IF(ckin(64+2*i).GT.0d0) q2max(i)=min(ckin(64+2*i),q2max(i))
8833 C...W limits when lepton on one side only.
8834  IF(mint(143-i).EQ.0) THEN
8835  xmin(i)=max(xmin(i),(w2min-pms(3-i))/pmc(i))
8836  IF(ckin(78).GT.0d0) xmax(i)=min(xmax(i),
8837  & (ckin(78)**2-pms(3-i))/pmc(i))
8838  ENDIF
8839  ENDIF
8840  100 CONTINUE
8841 
8842 C...W limits when lepton on both sides.
8843  IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8844  IF(ckin(78).GT.0d0) xmax(1)=min(xmax(1),
8845  & (ckin(78)**2+pmc(3)-pmc(2)*xmin(2))/pmc(1))
8846  IF(ckin(78).GT.0d0) xmax(2)=min(xmax(2),
8847  & (ckin(78)**2+pmc(3)-pmc(1)*xmin(1))/pmc(2))
8848  IF(iabs(mint(141)).NE.iabs(mint(142))) THEN
8849  xmin(1)=max(xmin(1),(pms(1)-pms(2)+vint(302)*(w2min-
8850  & pms(1)-pms(2))/(pmc(2)*xmax(2)+pms(1)-pms(2)))/pmc(1))
8851  xmin(2)=max(xmin(2),(pms(2)-pms(1)+vint(302)*(w2min-
8852  & pms(1)-pms(2))/(pmc(1)*xmax(1)+pms(2)-pms(1)))/pmc(2))
8853  ELSE
8854  xmin(1)=max(xmin(1),w2min/(vint(302)*xmax(2)))
8855  xmin(2)=max(xmin(2),w2min/(vint(302)*xmax(1)))
8856  ENDIF
8857  ENDIF
8858 
8859 C...Q2 and W values and photon flux weight factors for initialization.
8860  ELSEIF(igaga.EQ.2) THEN
8861  isub=mint(1)
8862  mint(15)=0
8863  mint(16)=0
8864 
8865 C...W value for photon on one or both sides, and for processes
8866 C...with gamma-gamma cross section peaked at small shat.
8867  IF(mint(141).NE.0.AND.mint(142).EQ.0) THEN
8868  vint(2)=vint(302)+pms(1)-pmc(1)*(1d0-xmax(1))
8869  ELSEIF(mint(141).EQ.0.AND.mint(142).NE.0) THEN
8870  vint(2)=vint(302)+pms(2)-pmc(2)*(1d0-xmax(2))
8871  ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
8872  vint(2)=max(ckin(77)**2,12d0*max(ckin(3),ckin(5))**2)
8873  IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
8874  ELSE
8875  vint(2)=xmax(1)*xmax(2)*vint(302)
8876  IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
8877  ENDIF
8878  vint(1)=sqrt(max(0d0,vint(2)))
8879 
8880 C...Upper estimate of photon flux weight factor.
8881 C...Initialization Q2 scale. Flag incoming unresolved photon.
8882  wtgaga=1d0
8883  DO 110 i=1,2
8884  IF(mint(140+i).NE.0) THEN
8885  wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
8886  & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
8887  IF(isub.EQ.99.AND.mint(106+i).EQ.4.AND.mint(109-i).EQ.3)
8888  & THEN
8889  q2init=5d0+q2min(3-i)
8890  ELSEIF(isub.EQ.99.AND.mint(106+i).EQ.4) THEN
8891  q2init=pmas(pycomp(113),1)**2+q2min(3-i)
8892  ELSEIF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
8893  q2init=max(ckin(1),2d0*ckin(3),2d0*ckin(5))**2/3d0
8894  ELSEIF((isub.EQ.138.AND.i.EQ.2).OR.
8895  & (isub.EQ.139.AND.i.EQ.1)) THEN
8896  q2init=vint(2)/3d0
8897  ELSEIF(isub.EQ.140) THEN
8898  q2init=vint(2)/2d0
8899  ELSE
8900  q2init=q2min(i)
8901  ENDIF
8902  vint(2+i)=-sqrt(max(q2min(i),min(q2max(i),q2init)))
8903  IF(mstp(14).EQ.0.OR.(isub.GE.131.AND.isub.LE.140))
8904  & mint(14+i)=22
8905  vint(306+i)=vint(2+i)**2
8906  ENDIF
8907  110 CONTINUE
8908  vint(320)=wtgaga
8909 
8910 C...Update pTmin and cross section information.
8911  IF(mstp(82).LE.1) THEN
8912  ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
8913  ELSE
8914  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
8915  ENDIF
8916  vint(149)=4d0*ptmn**2/vint(2)
8917  vint(154)=ptmn
8918  CALL pyxtot
8919  vint(318)=vint(317)
8920 
8921 C...Generate photons inside leptons and
8922 C...calculate photon flux weight factors.
8923  ELSEIF(igaga.EQ.3) THEN
8924  isub=mint(1)
8925  mint(15)=0
8926  mint(16)=0
8927 
8928 C...Generate phase space point and check against cuts.
8929  loop=0
8930  120 loop=loop+1
8931  DO 130 i=1,2
8932  IF(mint(140+i).NE.0) THEN
8933 C...Pick x and Q2
8934  x(i)=xmin(i)*(xmax(i)/xmin(i))**pyr(0)
8935  q2(i)=q2min(i)*(q2max(i)/q2min(i))**pyr(0)
8936 C...Cuts on internal consistency in x and Q2.
8937  IF(q2(i).LT.x(i)**2*pms(i)/(1d0-x(i))) goto 120
8938  IF(q2(i).GT.(1d0-x(i))*(vint(302)-2d0*pms(3-i))-
8939  & (2d0-x(i)**2)*pms(i)/(1d0-x(i))) goto 120
8940 C...Cuts on y and theta.
8941  y(i)=(pmc(i)*x(i)+q2(i))/pmc(3)
8942  IF(y(i).LT.ckin(71+2*i).OR.y(i).GT.ckin(72+2*i)) goto 120
8943  rat=((1d0-x(i))*q2(i)-x(i)**2*pms(i))/
8944  & ((1d0-x(i))**2*(vint(302)-2d0*pms(3-i)-2d0*pms(i)))
8945  theta(i)=2d0*asin(sqrt(max(0d0,min(1d0,rat))))
8946  IF(theta(i).LT.ckin(67+2*i)) goto 120
8947  IF(ckin(68+2*i).GT.0d0.AND.theta(i).GT.ckin(68+2*i))
8948  & goto 120
8949 
8950 C...Phi angle isotropic. Reconstruct pT.
8951  phi(i)=paru(2)*pyr(0)
8952  pt(i)=sqrt(((1d0-x(i))*pmc(i))**2/(4d0*vint(302))-
8953  & pms(i))*sin(theta(i))
8954 
8955 C...Store info on variables selected, for documentation purposes.
8956  vint(2+i)=-sqrt(q2(i))
8957  vint(304+i)=x(i)
8958  vint(306+i)=q2(i)
8959  vint(308+i)=y(i)
8960  vint(310+i)=theta(i)
8961  vint(312+i)=phi(i)
8962  ELSE
8963  vint(304+i)=1d0
8964  vint(306+i)=0d0
8965  vint(308+i)=1d0
8966  vint(310+i)=0d0
8967  vint(312+i)=0d0
8968  ENDIF
8969  130 CONTINUE
8970 
8971 C...Cut on W combines info from two sides.
8972  IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8973  w2=-q2(1)-q2(2)+0.5d0*x(1)*pmc(1)*x(2)*pmc(2)/vint(302)-
8974  & 2d0*pt(1)*pt(2)*cos(phi(1)-phi(2))+2d0*
8975  & sqrt((0.5d0*x(1)*pmc(1)/vint(301))**2+q2(1)-pt(1)**2)*
8976  & sqrt((0.5d0*x(2)*pmc(2)/vint(301))**2+q2(2)-pt(2)**2)
8977  IF(w2.LT.w2min) goto 120
8978  IF(ckin(78).GT.0d0.AND.w2.GT.ckin(78)**2) goto 120
8979  pms1=-q2(1)
8980  pms2=-q2(2)
8981  ELSEIF(mint(141).NE.0) THEN
8982  w2=(vint(302)+pms(1))*x(1)+pms(2)*(1d0-x(1))
8983  pms1=-q2(1)
8984  pms2=pms(2)
8985  ELSEIF(mint(142).NE.0) THEN
8986  w2=(vint(302)+pms(2))*x(2)+pms(1)*(1d0-x(2))
8987  pms1=pms(1)
8988  pms2=-q2(2)
8989  ENDIF
8990 
8991 C...Store kinematics info for photon(s) in subsystem cm frame.
8992  vint(2)=w2
8993  vint(1)=sqrt(w2)
8994  vint(291)=0d0
8995  vint(292)=0d0
8996  vint(293)=0.5d0*sqrt((w2-pms1-pms2)**2-4d0*pms1*pms2)/vint(1)
8997  vint(294)=0.5d0*(w2+pms1-pms2)/vint(1)
8998  vint(295)=sign(sqrt(abs(pms1)),pms1)
8999  vint(296)=0d0
9000  vint(297)=0d0
9001  vint(298)=-vint(293)
9002  vint(299)=0.5d0*(w2+pms2-pms1)/vint(1)
9003  vint(300)=sign(sqrt(abs(pms2)),pms2)
9004 
9005 C...Assign weight for photon flux; different for transverse and
9006 C...longitudinal photons. Flag incoming unresolved photon.
9007  wtgaga=1d0
9008  DO 140 i=1,2
9009  IF(mint(140+i).NE.0) THEN
9010  wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
9011  & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
9012  IF(mstp(16).EQ.0) THEN
9013  xy=x(i)
9014  ELSE
9015  wtgaga=wtgaga*x(i)/y(i)
9016  xy=y(i)
9017  ENDIF
9018  IF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
9019  wtgaga=wtgaga*(1d0-xy)
9020  ELSEIF(i.EQ.1.AND.(isub.EQ.139.OR.isub.EQ.140)) THEN
9021  wtgaga=wtgaga*(1d0-xy)
9022  ELSEIF(i.EQ.2.AND.(isub.EQ.138.OR.isub.EQ.140)) THEN
9023  wtgaga=wtgaga*(1d0-xy)
9024  ELSE
9025  wtgaga=wtgaga*(0.5d0*(1d0+(1d0-xy)**2)-
9026  & pms(i)*xy**2/q2(i))
9027  ENDIF
9028  IF(mint(106+i).EQ.0) mint(14+i)=22
9029  ENDIF
9030  140 CONTINUE
9031  vint(319)=wtgaga
9032  mint(143)=loop
9033 
9034 C...Update pTmin and cross section information.
9035  IF(mstp(82).LE.1) THEN
9036  ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
9037  ELSE
9038  ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
9039  ENDIF
9040  vint(149)=4d0*ptmn**2/vint(2)
9041  vint(154)=ptmn
9042  CALL pyxtot
9043 
9044 C...Reconstruct kinematics of photons inside leptons.
9045  ELSEIF(igaga.EQ.4) THEN
9046 
9047 C...Make place for incoming particles and scattered leptons.
9048  move=3
9049  IF(mint(141).NE.0.AND.mint(142).NE.0) move=4
9050  mint(4)=mint(4)+move
9051  DO 160 i=mint(84)-move,mint(83)+1,-1
9052  IF(k(i,1).EQ.21) THEN
9053  DO 150 j=1,5
9054  k(i+move,j)=k(i,j)
9055  p(i+move,j)=p(i,j)
9056  v(i+move,j)=v(i,j)
9057  150 CONTINUE
9058  IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
9059  & k(i+move,3)=k(i,3)+move
9060  IF(k(i,4).GT.mint(83).AND.k(i,4).LE.mint(84))
9061  & k(i+move,4)=k(i,4)+move
9062  IF(k(i,5).GT.mint(83).AND.k(i,5).LE.mint(84))
9063  & k(i+move,5)=k(i,5)+move
9064  ENDIF
9065  160 CONTINUE
9066  DO 170 i=mint(84)+1,n
9067  IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
9068  & k(i,3)=k(i,3)+move
9069  170 CONTINUE
9070 
9071 C...Fill in incoming particles.
9072  DO 190 i=mint(83)+1,mint(83)+move
9073  DO 180 j=1,5
9074  k(i,j)=0
9075  p(i,j)=0d0
9076  v(i,j)=0d0
9077  180 CONTINUE
9078  190 CONTINUE
9079  DO 200 i=1,2
9080  k(mint(83)+i,1)=21
9081  IF(mint(140+i).NE.0) THEN
9082  k(mint(83)+i,2)=mint(140+i)
9083  p(mint(83)+i,5)=vint(302+i)
9084  ELSE
9085  k(mint(83)+i,2)=mint(10+i)
9086  p(mint(83)+i,5)=vint(2+i)
9087  ENDIF
9088  p(mint(83)+i,3)=0.5d0*sqrt((pmc(3)**2-4d0*pms(1)*pms(2))/
9089  & vint(302))*(-1d0)**(i+1)
9090  p(mint(83)+i,4)=0.5d0*pmc(i)/vint(301)
9091  200 CONTINUE
9092 
9093 C...New mother-daughter relations in documentation section.
9094  IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
9095  k(mint(83)+1,4)=mint(83)+3
9096  k(mint(83)+1,5)=mint(83)+5
9097  k(mint(83)+2,4)=mint(83)+4
9098  k(mint(83)+2,5)=mint(83)+6
9099  k(mint(83)+3,3)=mint(83)+1
9100  k(mint(83)+5,3)=mint(83)+1
9101  k(mint(83)+4,3)=mint(83)+2
9102  k(mint(83)+6,3)=mint(83)+2
9103  ELSEIF(mint(141).NE.0) THEN
9104  k(mint(83)+1,4)=mint(83)+3
9105  k(mint(83)+1,5)=mint(83)+4
9106  k(mint(83)+2,4)=mint(83)+5
9107  k(mint(83)+3,3)=mint(83)+1
9108  k(mint(83)+4,3)=mint(83)+1
9109  k(mint(83)+5,3)=mint(83)+2
9110  ELSEIF(mint(142).NE.0) THEN
9111  k(mint(83)+1,4)=mint(83)+4
9112  k(mint(83)+2,4)=mint(83)+3
9113  k(mint(83)+2,5)=mint(83)+5
9114  k(mint(83)+3,3)=mint(83)+2
9115  k(mint(83)+4,3)=mint(83)+1
9116  k(mint(83)+5,3)=mint(83)+2
9117  ENDIF
9118 
9119 C...Fill scattered lepton(s).
9120  DO 210 i=1,2
9121  IF(mint(140+i).NE.0) THEN
9122  lsc=mint(83)+min(i+2,move)
9123  k(lsc,1)=21
9124  k(lsc,2)=mint(140+i)
9125  p(lsc,1)=pt(i)*cos(phi(i))
9126  p(lsc,2)=pt(i)*sin(phi(i))
9127  p(lsc,4)=(1d0-x(i))*p(mint(83)+i,4)
9128  p(lsc,3)=sqrt(p(lsc,4)**2-pms(i))*cos(theta(i))*
9129  & (-1d0)**(i-1)
9130  p(lsc,5)=vint(302+i)
9131  ENDIF
9132  210 CONTINUE
9133 
9134 C...Find incoming four-vectors to subprocess.
9135  k(n+1,1)=21
9136  IF(mint(141).NE.0) THEN
9137  DO 220 j=1,4
9138  p(n+1,j)=p(mint(83)+1,j)-p(mint(83)+3,j)
9139  220 CONTINUE
9140  ELSE
9141  DO 230 j=1,4
9142  p(n+1,j)=p(mint(83)+1,j)
9143  230 CONTINUE
9144  ENDIF
9145  k(n+2,1)=21
9146  IF(mint(142).NE.0) THEN
9147  DO 240 j=1,4
9148  p(n+2,j)=p(mint(83)+2,j)-p(mint(83)+move,j)
9149  240 CONTINUE
9150  ELSE
9151  DO 250 j=1,4
9152  p(n+2,j)=p(mint(83)+2,j)
9153  250 CONTINUE
9154  ENDIF
9155 
9156 C...Define boost and rotation between hadronic subsystem and
9157 C...collision rest frame; boost hadronic subsystem to this frame.
9158  DO 260 j=1,3
9159  beta(j)=(p(n+1,j)+p(n+2,j))/(p(n+1,4)+p(n+2,4))
9160  260 CONTINUE
9161  CALL pyrobo(n+1,n+2,0d0,0d0,-beta(1),-beta(2),-beta(3))
9162  bphi=pyangl(p(n+1,1),p(n+1,2))
9163  CALL pyrobo(n+1,n+2,0d0,-bphi,0d0,0d0,0d0)
9164  btheta=pyangl(p(n+1,3),p(n+1,1))
9165  CALL pyrobo(mint(83)+move+1,n,btheta,bphi,beta(1),beta(2),
9166  & beta(3))
9167 
9168 C...Add on scattered leptons to final state.
9169  DO 280 i=1,2
9170  IF(mint(140+i).NE.0) THEN
9171  lsc=mint(83)+min(i+2,move)
9172  n=n+1
9173  DO 270 j=1,5
9174  k(n,j)=k(lsc,j)
9175  p(n,j)=p(lsc,j)
9176  v(n,j)=v(lsc,j)
9177  270 CONTINUE
9178  k(n,1)=1
9179  k(n,3)=lsc
9180  ENDIF
9181  280 CONTINUE
9182  ENDIF
9183 
9184  RETURN
9185  END
9186 
9187 C*********************************************************************
9188 
9189 C...PYRAND
9190 C...Generates quantities characterizing the high-pT scattering at the
9191 C...parton level according to the matrix elements. Chooses incoming,
9192 C...reacting partons, their momentum fractions and one of the possible
9193 C...subprocesses.
9194 
9195  SUBROUTINE pyrand
9196 
9197 C...Double precision and integer declarations.
9198  IMPLICIT DOUBLE PRECISION(a-h, o-z)
9199  IMPLICIT INTEGER(i-n)
9200  INTEGER pyk,pychge,pycomp
9201 C...Parameter statement to help give large particle numbers.
9202  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
9203  &kexcit=4000000,kdimen=5000000)
9204 
9205 C...User process initialization and event commonblocks.
9206  INTEGER maxpup
9207  parameter(maxpup=100)
9208  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
9209  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
9210  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
9211  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
9212  &lprup(maxpup)
9213  INTEGER maxnup
9214  parameter(maxnup=500)
9215  INTEGER nup,idprup,idup,istup,mothup,icolup
9216  DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
9217  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
9218  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
9219  &vtimup(maxnup),spinup(maxnup)
9220  SAVE /heprup/,/hepeup/
9221 
9222 C...Commonblocks.
9223  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
9224  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
9225  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
9226  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
9227  common/pypars/mstp(200),parp(200),msti(200),pari(200)
9228  common/pyint1/mint(400),vint(400)
9229  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
9230  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
9231  common/pyint4/mwid(500),wids(500,5)
9232  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
9233  common/pyint7/sigt(0:6,0:6,0:5)
9234  common/pymssm/imss(0:99),rmss(0:99)
9235  common/pytcco/coefx(194:380,2)
9236  common/tcpara/ires,jres,xmas(3),xwid(3),ymas(2),ywid(2)
9237  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
9238  &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,/pymssm/,/pytcco/,
9239  &/tcpara/
9240 C...Local arrays.
9241  dimension xpq(-25:25),pmm(2),pdif(4),bhad(4),pmmn(2)
9242 
9243 C...Parameters and data used in elastic/diffractive treatment.
9244  DATA eps/0.0808d0/, alp/0.25d0/, cres/2d0/, pmrc/1.062d0/,
9245  &smp/0.880d0/, bhad/2.3d0,1.4d0,1.4d0,0.23d0/
9246 
9247 C...Initial values, specifically for (first) semihard interaction.
9248  mint(10)=0
9249  mint(17)=0
9250  mint(18)=0
9251  vint(143)=1d0
9252  vint(144)=1d0
9253  vint(157)=0d0
9254  vint(158)=0d0
9255  mfail=0
9256  IF(mstp(171).EQ.1.AND.mstp(172).EQ.2) mfail=1
9257  isub=0
9258  istsb=0
9259  loop=0
9260  100 loop=loop+1
9261  mint(51)=0
9262  mint(143)=1
9263  vint(97)=1d0
9264 
9265 C...Start by assuming incoming photon is entering subprocess.
9266  IF(mint(11).EQ.22) THEN
9267  mint(15)=22
9268  vint(307)=vint(3)**2
9269  ENDIF
9270  IF(mint(12).EQ.22) THEN
9271  mint(16)=22
9272  vint(308)=vint(4)**2
9273  ENDIF
9274  mint(103)=mint(11)
9275  mint(104)=mint(12)
9276 
9277 C...Choice of process type - first event of pileup.
9278  inmult=0
9279  IF(mint(82).EQ.1.AND.isub.GE.91.AND.isub.LE.96) THEN
9280  ELSEIF(mint(82).EQ.1) THEN
9281 
9282 C...For gamma-p or gamma-gamma first pick between alternatives.
9283  iga=0
9284  IF(mint(121).GT.1) CALL pysave(4,iga)
9285  mint(122)=iga
9286 
9287 C...For real gamma + gamma with different nature, flip at random.
9288  IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
9289  & mstp(14).LE.10.AND.pyr(0).GT.0.5d0) THEN
9290  mintsv=mint(41)
9291  mint(41)=mint(42)
9292  mint(42)=mintsv
9293  mintsv=mint(45)
9294  mint(45)=mint(46)
9295  mint(46)=mintsv
9296  mintsv=mint(107)
9297  mint(107)=mint(108)
9298  mint(108)=mintsv
9299  IF(mint(47).EQ.2.OR.mint(47).EQ.3) mint(47)=5-mint(47)
9300  ENDIF
9301 
9302 C...Pick process type, possibly by user process machinery.
9303 C...(If the latter, also event will be picked here.)
9304  IF(mint(111).GE.11.AND.iabs(idwtup).EQ.2.AND.loop.GE.2) THEN
9305  CALL upevnt
9306  CALL pyupre
9307  ELSEIF(mint(111).GE.11.AND.iabs(idwtup).GE.3) THEN
9308  CALL upevnt
9309  CALL pyupre
9310  isub=0
9311  110 isub=isub+1
9312  IF((iset(isub).NE.11.OR.kfpr(isub,2).NE.idprup).AND.
9313  & isub.LT.500) goto 110
9314  ELSE
9315  rsub=xsec(0,1)*pyr(0)
9316  DO 120 i=1,500
9317  IF(msub(i).NE.1.OR.i.EQ.96) goto 120
9318  isub=i
9319  rsub=rsub-xsec(i,1)
9320  IF(rsub.LE.0d0) goto 130
9321  120 CONTINUE
9322  130 IF(isub.EQ.95) isub=96
9323  IF(isub.EQ.96) inmult=1
9324  IF(iset(isub).EQ.11) THEN
9325  idprup=kfpr(isub,2)
9326  CALL upevnt
9327  CALL pyupre
9328  ENDIF
9329  ENDIF
9330 
9331 C...Choice of inclusive process type - pileup events.
9332  ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN
9333  rsub=vint(131)*pyr(0)
9334  isub=96
9335  IF(rsub.GT.sigt(0,0,5)) isub=94
9336  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)) isub=93
9337  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)) isub=92
9338  IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)+sigt(0,0,2))
9339  & isub=91
9340  IF(isub.EQ.96) inmult=1
9341  ENDIF
9342 
9343 C...Choice of photon energy and flux factor inside lepton.
9344  IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
9345  CALL pygaga(3,wtgaga)
9346  IF(isub.GE.131.AND.isub.LE.140) THEN
9347  ckin(3)=max(vint(285),vint(154))
9348  ckin(1)=2d0*ckin(3)
9349  ENDIF
9350 C...When necessary set direct/resolved photon by hand.
9351  ELSEIF(mint(15).EQ.22.OR.mint(16).EQ.22) THEN
9352  IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
9353  IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
9354  ENDIF
9355 
9356 C...Restrict direct*resolved processes to pTmin >= Q,
9357 C...to avoid doublecounting with DIS.
9358  IF(mstp(18).EQ.3.AND.isub.GE.131.AND.isub.LE.136) THEN
9359  IF(mint(15).EQ.22) THEN
9360  ckin(3)=max(vint(285),vint(154),abs(vint(3)))
9361  ELSE
9362  ckin(3)=max(vint(285),vint(154),abs(vint(4)))
9363  ENDIF
9364  ckin(1)=2d0*ckin(3)
9365  ENDIF
9366 
9367 C...Set up for multiple interactions (may include impact parameter).
9368  IF(inmult.EQ.1) THEN
9369  IF(mint(35).LE.1) CALL pymult(2)
9370  IF(mint(35).GE.2) CALL pymign(2)
9371  ENDIF
9372 
9373 C...Loopback point for minimum bias in photon physics.
9374  loop2=0
9375  140 loop2=loop2+1
9376  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+mint(143)
9377  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+mint(143)
9378  IF(isub.EQ.96.AND.loop2.EQ.1.AND.mint(82).EQ.1)
9379  &ngen(97,1)=ngen(97,1)+mint(143)
9380  mint(1)=isub
9381  istsb=iset(isub)
9382 
9383 C...Random choice of flavour for some SUSY processes.
9384  IF(isub.GE.201.AND.isub.LE.301) THEN
9385 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9386  IF(isub.EQ.210) THEN
9387  kfpr(isub,1)=ksusy1+11+2*int(0.5d0+pyr(0))
9388  kfpr(isub,2)=kfpr(isub,1)+1
9389 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9390  ELSEIF(isub.EQ.213) THEN
9391  kfpr(isub,1)=ksusy1+12+2*int(0.5d0+pyr(0))
9392  kfpr(isub,2)=kfpr(isub,1)
9393 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9394  ELSEIF(isub.GE.246.AND.isub.LE.259.AND.isub.NE.255.AND.
9395  & isub.NE.257) THEN
9396  IF(isub.GE.258) THEN
9397  rkf=4d0
9398  ELSE
9399  rkf=5d0
9400  ENDIF
9401  IF(mod(isub,2).EQ.0) THEN
9402  kfpr(isub,1)=ksusy1+1+int(rkf*pyr(0))
9403  ELSE
9404  kfpr(isub,1)=ksusy2+1+int(rkf*pyr(0))
9405  ENDIF
9406 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9407  ELSEIF(isub.GE.271.AND.isub.LE.276) THEN
9408  IF(isub.EQ.271.OR.isub.EQ.274) THEN
9409  ksu1=ksusy1
9410  ksu2=ksusy1
9411  ELSEIF(isub.EQ.272.OR.isub.EQ.275) THEN
9412  ksu1=ksusy2
9413  ksu2=ksusy2
9414  ELSEIF(pyr(0).LT.0.5d0) THEN
9415  ksu1=ksusy1
9416  ksu2=ksusy2
9417  ELSE
9418  ksu1=ksusy2
9419  ksu2=ksusy1
9420  ENDIF
9421  kfpr(isub,1)=ksu1+1+int(4d0*pyr(0))
9422  kfpr(isub,2)=ksu2+1+int(4d0*pyr(0))
9423 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9424  ELSEIF(isub.EQ.277.OR.isub.EQ.279) THEN
9425  kfpr(isub,1)=ksusy1+1+int(4d0*pyr(0))
9426  kfpr(isub,2)=kfpr(isub,1)
9427  ELSEIF(isub.EQ.278.OR.isub.EQ.280) THEN
9428  kfpr(isub,1)=ksusy2+1+int(4d0*pyr(0))
9429  kfpr(isub,2)=kfpr(isub,1)
9430 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9431  ELSEIF(isub.GE.281.AND.isub.LE.286) THEN
9432  IF(isub.EQ.281.OR.isub.EQ.284) THEN
9433  ksu1=ksusy1
9434  ksu2=ksusy1
9435  ELSEIF(isub.EQ.282.OR.isub.EQ.285) THEN
9436  ksu1=ksusy2
9437  ksu2=ksusy2
9438  ELSEIF(pyr(0).LT.0.5d0) THEN
9439  ksu1=ksusy1
9440  ksu2=ksusy2
9441  ELSE
9442  ksu1=ksusy2
9443  ksu2=ksusy1
9444  ENDIF
9445  IF(isub.EQ.281.OR.isub.LE.283) THEN
9446  rkf=5d0
9447  ELSE
9448  rkf=4d0
9449  ENDIF
9450  kfpr(isub,2)=ksu2+1+int(rkf*pyr(0))
9451  ENDIF
9452  ENDIF
9453 
9454 C...Random choice of flavours for some UED processes
9455 c...The production processes can generate a doublet pair,
9456 c...a singlet pair, or a doublet + singlet.
9457  IF(isub.EQ.313)THEN
9458 C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9459  IF(pyr(0).LE.0.1)THEN
9460  kfpr(isub,1)=5100001
9461  ELSE
9462  kfpr(isub,1)=5100002
9463  ENDIF
9464  kfpr(isub,2)=kfpr(isub,1)
9465  ELSEIF(isub.EQ.314.OR.isub.EQ.315)THEN
9466 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9467 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9468  IF(pyr(0).LE.0.1)THEN
9469  kfpr(isub,1)=5100001
9470  ELSE
9471  kfpr(isub,1)=5100002
9472  ENDIF
9473  kfpr(isub,2)=-kfpr(isub,1)
9474  ELSEIF(isub.EQ.316)THEN
9475 C...qi + qbarj -> q*_Di + q*_Sbarj
9476  IF(pyr(0).LE.0.5)THEN
9477  kfpr(isub,1)=5100001
9478 c Changed from private pythia6410_ued code
9479 c KFPR(ISUB,2)=-5010001
9480  kfpr(isub,2)=-6100002
9481  ELSE
9482  kfpr(isub,1)=5100002
9483 c Changed from private pythia6410_ued code
9484 c KFPR(ISUB,2)=-5010002
9485  kfpr(isub,2)=-6100001
9486  ENDIF
9487  ELSEIF(isub.EQ.317)THEN
9488 C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9489  IF(pyr(0).LE.0.5)THEN
9490  kfpr(isub,1)=5100001
9491  kfpr(isub,2)=-5100002
9492  ELSE
9493  kfpr(isub,1)=5100002
9494  kfpr(isub,2)=-5100001
9495  ENDIF
9496  ELSEIF(isub.EQ.318)THEN
9497 C...qi + qj -> q*_Di + q*_Sj
9498  IF(pyr(0).LE.0.5)THEN
9499  kfpr(isub,1)=5100001
9500  kfpr(isub,2)=6100002
9501  ELSE
9502  kfpr(isub,1)=5100002
9503  kfpr(isub,2)=6100001
9504  ENDIF
9505  ENDIF
9506 
9507 C...Find resonances (explicit or implicit in cross-section).
9508  mint(72)=0
9509  kfr1=0
9510  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
9511  kfr1=kfpr(isub,1)
9512  ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165.OR.
9513  & isub.EQ.171.OR.isub.EQ.176) THEN
9514  kfr1=23
9515  ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172.OR.
9516  & isub.EQ.177) THEN
9517  kfr1=24
9518  ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
9519  kfr1=25
9520  IF(mstp(46).EQ.5) THEN
9521  kfr1=89
9522  pmas(89,1)=parp(45)
9523  pmas(89,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
9524  ENDIF
9525  ELSEIF(isub.EQ.481) THEN
9526  kfr1=9900001
9527  ENDIF
9528  ckmx=ckin(2)
9529  IF(ckmx.LE.0d0) ckmx=vint(1)
9530  kcr1=pycomp(kfr1)
9531  IF(kcr1.EQ.0) kfr1=0
9532  IF(kfr1.NE.0) THEN
9533  IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
9534  & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
9535  ENDIF
9536  IF(kfr1.NE.0) THEN
9537  taur1=pmas(kcr1,1)**2/vint(2)
9538  gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
9539  mint(72)=1
9540  mint(73)=kfr1
9541  vint(73)=taur1
9542  vint(74)=gamr1
9543  ENDIF
9544  kfr2=0
9545  kfr3=0
9546  IF(isub.EQ.141.OR.isub.EQ.194.OR.isub.EQ.195.OR.
9547  $(isub.GE.361.AND.isub.LE.380))
9548  $THEN
9549  kfr2=23
9550  IF(isub.EQ.141) THEN
9551  kcr2=pycomp(kfr2)
9552  IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
9553  & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) THEN
9554  kfr2=0
9555  ELSE
9556  taur2=pmas(kcr2,1)**2/vint(2)
9557  gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
9558  mint(72)=2
9559  mint(74)=kfr2
9560  vint(75)=taur2
9561  vint(76)=gamr2
9562  ENDIF
9563 C...3 resonances at work: rho, omega, a
9564  ELSEIF(isub.EQ.194.OR.(isub.GE.361.AND.isub.LE.368)
9565  & .OR.isub.EQ.379.OR.isub.EQ.380) THEN
9566  mint(72)=ires
9567  IF(ires.GE.1) THEN
9568  vint(73)=xmas(1)**2/vint(2)
9569  vint(74)=xmas(1)*xwid(1)/vint(2)
9570  taur1=vint(73)
9571  gamr1=vint(74)
9572  kfr1=1
9573  ENDIF
9574  IF(ires.GE.2) THEN
9575  vint(75)=xmas(2)**2/vint(2)
9576  vint(76)=xmas(2)*xwid(2)/vint(2)
9577  taur2=vint(75)
9578  gamr2=vint(76)
9579  kfr2=2
9580  ENDIF
9581  IF(ires.EQ.3) THEN
9582  vint(77)=xmas(3)**2/vint(2)
9583  vint(78)=xmas(3)*xwid(3)/vint(2)
9584  taur3=vint(77)
9585  gamr3=vint(78)
9586  kfr3=3
9587  ENDIF
9588 C...Charged current: rho+- and a+-
9589  ELSEIF(isub.EQ.195.OR.isub.GE.370.AND.isub.LE.378) THEN
9590  mint(72)=ires
9591  IF(jres.GE.1) THEN
9592  vint(73)=ymas(1)**2/vint(2)
9593  vint(74)=ymas(1)*ywid(1)/vint(2)
9594  kfr1=1
9595  taur1=vint(73)
9596  gamr1=vint(74)
9597  ENDIF
9598  IF(jres.GE.2) THEN
9599  vint(75)=ymas(2)**2/vint(2)
9600  vint(76)=ymas(2)*ywid(2)/vint(2)
9601  kfr2=2
9602  taur2=vint(73)
9603  gamr2=vint(74)
9604  ENDIF
9605  kfr3=0
9606  ENDIF
9607  IF(isub.NE.141) THEN
9608  IF(kfr3.NE.0.AND.kfr2.NE.0.AND.kfr1.NE.0) THEN
9609 
9610  ELSEIF(kfr1.NE.0.AND.kfr2.NE.0) THEN
9611  mint(72)=2
9612  ELSEIF(kfr1.NE.0.AND.kfr3.NE.0) THEN
9613  mint(72)=2
9614  mint(74)=kfr3
9615  vint(75)=taur3
9616  vint(76)=gamr3
9617  ELSEIF(kfr2.NE.0.AND.kfr3.NE.0) THEN
9618  mint(72)=2
9619  mint(73)=kfr2
9620  vint(73)=taur2
9621  vint(74)=gamr2
9622  mint(74)=kfr3
9623  vint(75)=taur3
9624  vint(76)=gamr3
9625  ELSEIF(kfr1.NE.0) THEN
9626  mint(72)=1
9627  ELSEIF(kfr2.NE.0) THEN
9628  mint(72)=1
9629  mint(73)=kfr2
9630  vint(73)=taur2
9631  vint(74)=gamr2
9632  ELSEIF(kfr3.NE.0) THEN
9633  mint(72)=1
9634  mint(73)=kfr3
9635  vint(73)=taur3
9636  vint(74)=gamr3
9637  ELSE
9638  mint(72)=0
9639  ENDIF
9640  ELSE
9641  IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
9642 
9643  ELSEIF(kfr2.NE.0) THEN
9644  kfr1=kfr2
9645  taur1=taur2
9646  gamr1=gamr2
9647  mint(72)=1
9648  mint(73)=kfr1
9649  vint(73)=taur1
9650  vint(74)=gamr1
9651  kfr2=0
9652  ELSE
9653  mint(72)=0
9654  ENDIF
9655  ENDIF
9656  ENDIF
9657 
9658 C...Find product masses and minimum pT of process,
9659 C...optionally with broadening according to a truncated Breit-Wigner.
9660  vint(63)=0d0
9661  vint(64)=0d0
9662  mint(71)=0
9663  vint(71)=ckin(3)
9664  IF(mint(82).GE.2) vint(71)=0d0
9665  vint(80)=1d0
9666  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
9667  nbw=0
9668  DO 160 i=1,2
9669  pmmn(i)=0d0
9670  IF(kfpr(isub,i).EQ.0) THEN
9671  ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
9672  & parp(41)) THEN
9673  vint(62+i)=pmas(pycomp(kfpr(isub,i)),1)**2
9674  ELSE
9675  nbw=nbw+1
9676 C...This prevents SUSY/t particles from becoming too light.
9677  kflw=kfpr(isub,i)
9678  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
9679  kcw=pycomp(kflw)
9680  pmmn(i)=pmas(kcw,1)
9681  DO 150 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
9682  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
9683  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
9684  & pmas(pycomp(kfdp(idc,2)),1)
9685  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
9686  & pmas(pycomp(kfdp(idc,3)),1)
9687  pmmn(i)=min(pmmn(i),pmsum)
9688  ENDIF
9689  150 CONTINUE
9690  ELSEIF(kflw.EQ.6) THEN
9691  pmmn(i)=pmas(24,1)+pmas(5,1)
9692  ENDIF
9693  ENDIF
9694  160 CONTINUE
9695  IF(nbw.GE.1) THEN
9696  ckin41=ckin(41)
9697  ckin43=ckin(43)
9698  ckin(41)=max(pmmn(1),ckin(41))
9699  ckin(43)=max(pmmn(2),ckin(43))
9700  CALL pyofsh(4,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
9701  ckin(41)=ckin41
9702  ckin(43)=ckin43
9703  IF(mint(51).EQ.1) THEN
9704  IF(mint(121).GT.1) CALL pysave(2,iga)
9705  IF(mfail.EQ.1) THEN
9706  msti(61)=1
9707  RETURN
9708  ENDIF
9709  goto 100
9710  ENDIF
9711  vint(63)=pqm3**2
9712  vint(64)=pqm4**2
9713  ENDIF
9714  IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1
9715  IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
9716  ENDIF
9717 
9718 C...Prepare for additional variable choices in 2 -> 3.
9719  IF(istsb.EQ.5) THEN
9720  vint(201)=0d0
9721  IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
9722  vint(206)=vint(201)
9723  IF(isub.EQ.401.OR.isub.EQ.402) vint(206)=pmas(5,1)
9724  vint(204)=pmas(23,1)
9725  IF(isub.EQ.124.OR.isub.EQ.174.OR.isub.EQ.179.OR.isub.EQ.351)
9726  & vint(204)=pmas(24,1)
9727  IF(isub.EQ.352) vint(204)=pmas(pycomp(9900024),1)
9728  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
9729  & isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402)
9730  & vint(204)=vint(201)
9731  vint(209)=vint(204)
9732  IF(isub.EQ.401.OR.isub.EQ.402) vint(209)=vint(206)
9733  ENDIF
9734 
9735 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9736  IF(istsb.NE.0.AND.(mint(101).GE.2.OR.mint(102).GE.2).AND.
9737  &(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7)) THEN
9738  vrn=pyr(0)*sigt(0,0,5)
9739  IF(mint(101).LE.1) THEN
9740  i1mn=0
9741  i1mx=0
9742  ELSE
9743  i1mn=1
9744  i1mx=mint(101)
9745  ENDIF
9746  IF(mint(102).LE.1) THEN
9747  i2mn=0
9748  i2mx=0
9749  ELSE
9750  i2mn=1
9751  i2mx=mint(102)
9752  ENDIF
9753  DO 180 i1=i1mn,i1mx
9754  kfv1=110*i1+3
9755  DO 170 i2=i2mn,i2mx
9756  kfv2=110*i2+3
9757  vrn=vrn-sigt(i1,i2,5)
9758  IF(vrn.LE.0d0) goto 190
9759  170 CONTINUE
9760  180 CONTINUE
9761  190 IF(mint(101).GE.2) mint(103)=kfv1
9762  IF(mint(102).GE.2) mint(104)=kfv2
9763  ENDIF
9764 
9765  IF(istsb.EQ.0) THEN
9766 C...Elastic scattering or single or double diffractive scattering.
9767 
9768 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9769  mint(103)=mint(11)
9770  mint(104)=mint(12)
9771  pmm(1)=vint(3)
9772  pmm(2)=vint(4)
9773  IF(mint(101).GE.2.OR.mint(102).GE.2) THEN
9774  jj=isub-90
9775  vrn=pyr(0)*sigt(0,0,jj)
9776  IF(mint(101).LE.1) THEN
9777  i1mn=0
9778  i1mx=0
9779  ELSE
9780  i1mn=1
9781  i1mx=mint(101)
9782  ENDIF
9783  IF(mint(102).LE.1) THEN
9784  i2mn=0
9785  i2mx=0
9786  ELSE
9787  i2mn=1
9788  i2mx=mint(102)
9789  ENDIF
9790  DO 210 i1=i1mn,i1mx
9791  kfv1=110*i1+3
9792  DO 200 i2=i2mn,i2mx
9793  kfv2=110*i2+3
9794  vrn=vrn-sigt(i1,i2,jj)
9795  IF(vrn.LE.0d0) goto 220
9796  200 CONTINUE
9797  210 CONTINUE
9798  220 IF(mint(101).GE.2) THEN
9799  mint(103)=kfv1
9800  pmm(1)=pymass(kfv1)
9801  ENDIF
9802  IF(mint(102).GE.2) THEN
9803  mint(104)=kfv2
9804  pmm(2)=pymass(kfv2)
9805  ENDIF
9806  ENDIF
9807  vint(67)=pmm(1)
9808  vint(68)=pmm(2)
9809 
9810 C...Select mass for GVMD states (rejecting previous assignment).
9811  q0s=4d0*parp(15)**2
9812  q1s=4d0*vint(154)**2
9813  loop3=0
9814  230 loop3=loop3+1
9815  DO 240 jt=1,2
9816  IF(mint(106+jt).EQ.3) THEN
9817  ps=vint(2+jt)**2
9818  pmm(jt)=sqrt((q0s+ps)*(q1s+ps)/
9819  & (q0s+pyr(0)*(q1s-q0s)+ps)-ps)
9820  IF(mint(102+jt).GE.333) pmm(jt)=pmm(jt)-
9821  & pmas(pycomp(113),1)+pmas(pycomp(mint(102+jt)),1)
9822  ENDIF
9823  240 CONTINUE
9824  IF(pmm(1)+pmm(2)+parp(104).GE.vint(1)) THEN
9825  IF(loop3.LT.100.AND.(mint(107).EQ.3.OR.mint(108).EQ.3))
9826  & goto 230
9827  goto 100
9828  ENDIF
9829 
9830 C...Side/sides of diffractive system.
9831  mint(17)=0
9832  mint(18)=0
9833  IF(isub.EQ.92.OR.isub.EQ.94) mint(17)=1
9834  IF(isub.EQ.93.OR.isub.EQ.94) mint(18)=1
9835 
9836 C...Find masses of particles and minimal masses of diffractive states.
9837  DO 250 jt=1,2
9838  pdif(jt)=pmm(jt)
9839  vint(68+jt)=pdif(jt)
9840  IF(mint(16+jt).EQ.1) pdif(jt)=pdif(jt)+parp(102)
9841  250 CONTINUE
9842  sh=vint(2)
9843  sqm1=pmm(1)**2
9844  sqm2=pmm(2)**2
9845  sqm3=pdif(1)**2
9846  sqm4=pdif(2)**2
9847  smres1=(pmm(1)+pmrc)**2
9848  smres2=(pmm(2)+pmrc)**2
9849 
9850 C...Find elastic slope and lower limit diffractive slope.
9851  iha=max(2,iabs(mint(103))/110)
9852  IF(iha.GE.5) iha=1
9853  ihb=max(2,iabs(mint(104))/110)
9854  IF(ihb.GE.5) ihb=1
9855  IF(isub.EQ.91) THEN
9856  bmn=2d0*bhad(iha)+2d0*bhad(ihb)+4d0*sh**eps-4.2d0
9857  ELSEIF(isub.EQ.92) THEN
9858  bmn=max(2d0,2d0*bhad(ihb))
9859  ELSEIF(isub.EQ.93) THEN
9860  bmn=max(2d0,2d0*bhad(iha))
9861  ELSEIF(isub.EQ.94) THEN
9862  bmn=2d0*alp*4d0
9863  ENDIF
9864 
9865 C...Determine maximum possible t range and coefficient of generation.
9866  sqla12=(sh-sqm1-sqm2)**2-4d0*sqm1*sqm2
9867  sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
9868  tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
9869  thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
9870  thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
9871  & (sqm1*sqm4-sqm2*sqm3)/sh
9872  thl=-0.5d0*(tha+thb)
9873  thu=thc/thl
9874  thrnd=exp(max(-50d0,bmn*(thl-thu)))-1d0
9875 
9876 C...Select diffractive mass/masses according to dm^2/m^2.
9877  loop3=0
9878  260 loop3=loop3+1
9879  DO 270 jt=1,2
9880  IF(mint(16+jt).EQ.0) THEN
9881  pdif(2+jt)=pdif(jt)
9882  ELSE
9883  pmmin=pdif(jt)
9884  pmmax=max(vint(2+jt),vint(1)-pdif(3-jt))
9885  pdif(2+jt)=pmmin*(pmmax/pmmin)**pyr(0)
9886  ENDIF
9887  270 CONTINUE
9888  sqm3=pdif(3)**2
9889  sqm4=pdif(4)**2
9890 
9891 C..Additional mass factors, including resonance enhancement.
9892  IF(pdif(3)+pdif(4).GE.vint(1)) THEN
9893  IF(loop3.LT.100) goto 260
9894  goto 100
9895  ENDIF
9896  IF(isub.EQ.92) THEN
9897  fsd=(1d0-sqm3/sh)*(1d0+cres*smres1/(smres1+sqm3))
9898  IF(fsd.LT.pyr(0)*(1d0+cres)) goto 260
9899  ELSEIF(isub.EQ.93) THEN
9900  fsd=(1d0-sqm4/sh)*(1d0+cres*smres2/(smres2+sqm4))
9901  IF(fsd.LT.pyr(0)*(1d0+cres)) goto 260
9902  ELSEIF(isub.EQ.94) THEN
9903  fdd=(1d0-(pdif(3)+pdif(4))**2/sh)*(sh*smp/
9904  & (sh*smp+sqm3*sqm4))*(1d0+cres*smres1/(smres1+sqm3))*
9905  & (1d0+cres*smres2/(smres2+sqm4))
9906  IF(fdd.LT.pyr(0)*(1d0+cres)**2) goto 260
9907  ENDIF
9908 
9909 C...Select t according to exp(Bmn*t) and correct to right slope.
9910  th=thu+log(1d0+thrnd*pyr(0))/bmn
9911  IF(isub.GE.92) THEN
9912  IF(isub.EQ.92) THEN
9913  badd=2d0*alp*log(sh/sqm3)
9914  IF(bhad(ihb).LT.1d0) badd=max(0d0,badd+2d0*bhad(ihb)-2d0)
9915  ELSEIF(isub.EQ.93) THEN
9916  badd=2d0*alp*log(sh/sqm4)
9917  IF(bhad(iha).LT.1d0) badd=max(0d0,badd+2d0*bhad(iha)-2d0)
9918  ELSEIF(isub.EQ.94) THEN
9919  badd=2d0*alp*(log(exp(4d0)+sh/(alp*sqm3*sqm4))-4d0)
9920  ENDIF
9921  IF(exp(max(-50d0,badd*(th-thu))).LT.pyr(0)) goto 260
9922  ENDIF
9923 
9924 C...Check whether m^2 and t choices are consistent.
9925  sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
9926  tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
9927  thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
9928  IF(thb.LE.1d-8) goto 260
9929  thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
9930  & (sqm1*sqm4-sqm2*sqm3)/sh
9931  thlm=-0.5d0*(tha+thb)
9932  thum=thc/thlm
9933  IF(th.LT.thlm.OR.th.GT.thum) goto 260
9934 
9935 C...Information to output.
9936  vint(21)=1d0
9937  vint(22)=0d0
9938  vint(23)=min(1d0,max(-1d0,(tha+2d0*th)/thb))
9939  vint(45)=th
9940  vint(59)=2d0*sqrt(max(0d0,-(thc+tha*th+th**2)))/thb
9941  vint(63)=pdif(3)**2
9942  vint(64)=pdif(4)**2
9943  vint(283)=pmm(1)**2/4d0
9944  vint(284)=pmm(2)**2/4d0
9945 
9946 C...Note: in the following, by In is meant the integral over the
9947 C...quantity multiplying coefficient cn.
9948 C...Choose tau according to h1(tau)/tau, where
9949 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9950 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9951 C...I1/I5*c5*1/(tau+tau_R') +
9952 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9953 C...I1/I7*c7*tau/(1.-tau), and
9954 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9955  ELSEIF(istsb.GE.1.AND.istsb.LE.5) THEN
9956  CALL pyklim(1)
9957  IF(mint(51).NE.0) THEN
9958  IF(mint(121).GT.1) CALL pysave(2,iga)
9959  IF(mfail.EQ.1) THEN
9960  msti(61)=1
9961  RETURN
9962  ENDIF
9963  goto 100
9964  ENDIF
9965  rtau=pyr(0)
9966  mtau=1
9967  IF(rtau.GT.coef(isub,1)) mtau=2
9968  IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3
9969  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4
9970  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4))
9971  & mtau=5
9972  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
9973  & coef(isub,5)) mtau=6
9974  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
9975  & coef(isub,5)+coef(isub,6)) mtau=7
9976 C...Additional check to handle techni-processes with extra resonance
9977 C....Only modify tau treatment
9978  IF(isub.EQ.194.OR.isub.EQ.195.OR.(isub.GE.361.AND.isub.LE.380))
9979  & THEN
9980  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)
9981  & +coef(isub,4)+coef(isub,5)+coef(isub,6)+coef(isub,7)) mtau=8
9982  IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)
9983  & +coef(isub,4)+coef(isub,5)+coef(isub,6)+coef(isub,7)
9984  & +coefx(isub,1)) mtau=9
9985  ENDIF
9986  CALL pykmap(1,mtau,pyr(0))
9987 
9988 C...2 -> 3, 4 processes:
9989 C...Choose tau' according to h4(tau,tau')/tau', where
9990 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9991 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9992  IF(istsb.GE.3.AND.istsb.LE.5) THEN
9993  CALL pyklim(4)
9994  IF(mint(51).NE.0) THEN
9995  IF(mint(121).GT.1) CALL pysave(2,iga)
9996  IF(mfail.EQ.1) THEN
9997  msti(61)=1
9998  RETURN
9999  ENDIF
10000  goto 100
10001  ENDIF
10002  rtaup=pyr(0)
10003  mtaup=1
10004  IF(rtaup.GT.coef(isub,18)) mtaup=2
10005  IF(rtaup.GT.coef(isub,18)+coef(isub,19)) mtaup=3
10006  CALL pykmap(4,mtaup,pyr(0))
10007  ENDIF
10008 
10009 C...Choose y* according to h2(y*), where
10010 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
10011 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
10012 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
10013 C...and c1 + c2 + c3 + c4 + c5 = 1.
10014  CALL pyklim(2)
10015  IF(mint(51).NE.0) THEN
10016  IF(mint(121).GT.1) CALL pysave(2,iga)
10017  IF(mfail.EQ.1) THEN
10018  msti(61)=1
10019  RETURN
10020  ENDIF
10021  goto 100
10022  ENDIF
10023  ryst=pyr(0)
10024  myst=1
10025  IF(ryst.GT.coef(isub,8)) myst=2
10026  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
10027  IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)) myst=4
10028  IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)+
10029  & coef(isub,11)) myst=5
10030  CALL pykmap(2,myst,pyr(0))
10031 
10032 C...2 -> 2 processes:
10033 C...Choose cos(theta-hat) (cth) according to h3(cth), where
10034 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
10035 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
10036 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
10037 C...and c0 + c1 + c2 + c3 + c4 = 1.
10038  CALL pyklim(3)
10039  IF(mint(51).NE.0) THEN
10040  IF(mint(121).GT.1) CALL pysave(2,iga)
10041  IF(mfail.EQ.1) THEN
10042  msti(61)=1
10043  RETURN
10044  ENDIF
10045  goto 100
10046  ENDIF
10047  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
10048  rcth=pyr(0)
10049  mcth=1
10050  IF(rcth.GT.coef(isub,13)) mcth=2
10051  IF(rcth.GT.coef(isub,13)+coef(isub,14)) mcth=3
10052  IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)) mcth=4
10053  IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)+
10054  & coef(isub,16)) mcth=5
10055  CALL pykmap(3,mcth,pyr(0))
10056  ENDIF
10057 
10058 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
10059  IF(istsb.EQ.5) THEN
10060  CALL pykmap(5,0,0d0)
10061  IF(mint(51).NE.0) THEN
10062  IF(mint(121).GT.1) CALL pysave(2,iga)
10063  IF(mfail.EQ.1) THEN
10064  msti(61)=1
10065  RETURN
10066  ENDIF
10067  goto 100
10068  ENDIF
10069  ENDIF
10070 
10071 C...DIS as f + gamma* -> f process: set dummy values.
10072  ELSEIF(istsb.EQ.8) THEN
10073  vint(21)=0.9d0
10074  vint(22)=0d0
10075  vint(23)=0d0
10076  vint(47)=0d0
10077  vint(48)=0d0
10078 
10079 C...Low-pT or multiple interactions (first semihard interaction).
10080  ELSEIF(istsb.EQ.9) THEN
10081  IF(mint(35).LE.1) CALL pymult(3)
10082  IF(mint(35).GE.2) CALL pymign(3)
10083  isub=mint(1)
10084 
10085 C...Study user-defined process: kinematics plus weight.
10086  ELSEIF(istsb.EQ.11) THEN
10087  IF(idwtup.GT.0.AND.xwgtup.LT.0d0) CALL
10088  & pyerrm(26,'(PYRAND:) Negative XWGTUP for user process')
10089  msti(51)=0
10090  IF(nup.LE.0) THEN
10091  mint(51)=2
10092  msti(51)=1
10093  IF(mint(82).EQ.1) THEN
10094  ngen(0,1)=ngen(0,1)-1
10095  ngen(isub,1)=ngen(isub,1)-1
10096  ENDIF
10097  IF(mint(121).GT.1) CALL pysave(2,iga)
10098  RETURN
10099  ENDIF
10100 
10101 C...Extract cross section event weight.
10102  IF(iabs(idwtup).EQ.1.OR.iabs(idwtup).EQ.4) THEN
10103  sigs=1d-9*xwgtup
10104  ELSE
10105  sigs=1d-9*xsecup(kfpr(isub,1))
10106  ENDIF
10107  IF(iabs(idwtup).GE.1.AND.iabs(idwtup).LE.3) THEN
10108  vint(97)=sign(1d0,xwgtup)
10109  ELSE
10110  vint(97)=1d-9*xwgtup
10111  ENDIF
10112 
10113 C...Construct 'trivial' kinematical variables needed.
10114  kfl1=idup(1)
10115  kfl2=idup(2)
10116  vint(41)=pup(4,1)/ebmup(1)
10117  vint(42)=pup(4,2)/ebmup(2)
10118  IF (vint(41).GT.1.000001.OR.vint(42).GT.1.000001) THEN
10119  CALL pyerrm(9,'(PYRAND:) x > 1 in external event '//
10120  & '(listing follows):')
10121  CALL pylist(7)
10122  ENDIF
10123  vint(21)=vint(41)*vint(42)
10124  vint(22)=0.5d0*log(vint(41)/vint(42))
10125  vint(44)=vint(21)*vint(2)
10126  vint(43)=sqrt(max(0d0,vint(44)))
10127  vint(55)=scalup
10128  IF(scalup.LE.0d0) vint(55)=vint(43)
10129  vint(56)=vint(55)**2
10130  vint(57)=aqedup
10131  vint(58)=aqcdup
10132 
10133 C...Construct other kinematical variables needed (approximately).
10134  vint(23)=0d0
10135  vint(26)=vint(21)
10136  vint(45)=-0.5d0*vint(44)
10137  vint(46)=-0.5d0*vint(44)
10138  vint(49)=vint(43)
10139  vint(50)=vint(44)
10140  vint(51)=vint(55)
10141  vint(52)=vint(56)
10142  vint(53)=vint(55)
10143  vint(54)=vint(56)
10144  vint(25)=0d0
10145  vint(48)=0d0
10146  IF(istup(1).NE.-1.OR.istup(2).NE.-1) CALL pyerrm(26,
10147  & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10148  DO 280 iup=3,nup
10149  IF(istup(iup).LT.1.OR.istup(iup).GT.3) CALL pyerrm(26,
10150  & '(PYRAND:) unacceptable ISTUP code for particles')
10151  IF(istup(iup).EQ.1) vint(25)=vint(25)+2d0*(pup(5,iup)**2+
10152  & pup(1,iup)**2+pup(2,iup)**2)/vint(2)
10153  IF(istup(iup).EQ.1) vint(48)=vint(48)+0.5d0*(pup(1,iup)**2+
10154  & pup(2,iup)**2)
10155  280 CONTINUE
10156  vint(47)=sqrt(vint(48))
10157  ENDIF
10158 
10159 C...Choose azimuthal angle.
10160  vint(24)=0d0
10161  IF(istsb.NE.11) vint(24)=paru(2)*pyr(0)
10162 
10163 C...Check against user cuts on kinematics at parton level.
10164  mint(51)=0
10165  IF((isub.LE.90.OR.isub.GT.100).AND.istsb.LE.10) CALL pyklim(0)
10166  IF(mint(51).NE.0) THEN
10167  IF(mint(121).GT.1) CALL pysave(2,iga)
10168  IF(mfail.EQ.1) THEN
10169  msti(61)=1
10170  RETURN
10171  ENDIF
10172  goto 100
10173  ENDIF
10174  IF(mint(82).EQ.1.AND.mstp(141).GE.1.AND.istsb.LE.10) THEN
10175  mcut=0
10176  IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)
10177  & CALL pykcut(mcut)
10178  IF(mcut.NE.0) THEN
10179  IF(mint(121).GT.1) CALL pysave(2,iga)
10180  IF(mfail.EQ.1) THEN
10181  msti(61)=1
10182  RETURN
10183  ENDIF
10184  goto 100
10185  ENDIF
10186  ENDIF
10187 
10188  IF(istsb.LE.10) THEN
10189 C... If internal process, call PYSIGH
10190  CALL pysigh(nchn,sigs)
10191  ELSE
10192 C... If external process, still have to set MI starting scale
10193  IF (mstp(86).EQ.1) THEN
10194 C... Limit phase space by xT2 of hard interaction
10195 C... (gives undercounting of MI when ext proc != dijets)
10196  xt2gmx = vint(25)
10197  ELSE
10198 C... All accessible phase space allowed
10199 C... (gives double counting of MI when ext proc = dijets)
10200  xt2gmx = (1d0-vint(41))*(1d0-vint(42))
10201  ENDIF
10202  vint(62)=0.25d0*xt2gmx*vint(2)
10203  vint(61)=sqrt(max(0d0,vint(62)))
10204  ENDIF
10205 
10206  sigsor=sigs
10207  siglpt=sigt(0,0,5)*vint(315)*vint(316)
10208 
10209 C...Multiply cross section by lepton -> photon flux factor.
10210  IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
10211  sigs=wtgaga*sigs
10212  DO 290 ichn=1,nchn
10213  sigh(ichn)=wtgaga*sigh(ichn)
10214  290 CONTINUE
10215  siglpt=wtgaga*siglpt
10216  ENDIF
10217 
10218 C...Multiply cross-section by user-defined weights.
10219  IF(mstp(173).EQ.1) THEN
10220  sigs=parp(173)*sigs
10221  DO 300 ichn=1,nchn
10222  sigh(ichn)=parp(173)*sigh(ichn)
10223  300 CONTINUE
10224  siglpt=parp(173)*siglpt
10225  ENDIF
10226  wtxs=1d0
10227  sigswt=sigs
10228  vint(99)=1d0
10229  vint(100)=1d0
10230  IF(mint(82).EQ.1.AND.mstp(142).GE.1) THEN
10231  IF(isub.NE.96.AND.msub(91)+msub(92)+msub(93)+msub(94)+
10232  & msub(95).EQ.0) CALL pyevwt(wtxs)
10233  sigswt=wtxs*sigs
10234  vint(99)=wtxs
10235  IF(mstp(142).EQ.1) vint(100)=1d0/wtxs
10236  ENDIF
10237 
10238 C...Calculations for Monte Carlo estimate of all cross-sections.
10239  IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN
10240  IF(mstp(142).LE.1) THEN
10241  xsec(isub,2)=xsec(isub,2)+sigs
10242  ELSE
10243  xsec(isub,2)=xsec(isub,2)+sigswt
10244  ENDIF
10245  ELSEIF(mint(82).EQ.1) THEN
10246  xsec(isub,2)=xsec(isub,2)+sigs
10247  ENDIF
10248  IF((isub.EQ.95.OR.isub.EQ.96).AND.loop2.EQ.1.AND.
10249  &mint(82).EQ.1) xsec(97,2)=xsec(97,2)+siglpt
10250 
10251 C...Multiple interactions: store results of cross-section calculation.
10252  IF(mint(50).EQ.1.AND.mstp(82).GE.3) THEN
10253  vint(153)=sigsor
10254  IF(mint(35).LE.1) CALL pymult(4)
10255  IF(mint(35).GE.2) CALL pymign(4)
10256  ENDIF
10257 
10258 C...Ratio of actual to maximum cross section.
10259  IF(istsb.NE.11) THEN
10260  viol=sigswt/xsec(isub,1)
10261  IF(isub.EQ.96.AND.mstp(173).EQ.1) viol=viol/parp(174)
10262  ELSEIF(idwtup.EQ.1.OR.idwtup.EQ.2) THEN
10263  viol=xwgtup/xmaxup(kfpr(isub,1))
10264  ELSEIF(idwtup.EQ.-1.OR.idwtup.EQ.-2) THEN
10265  viol=abs(xwgtup)/abs(xmaxup(kfpr(isub,1)))
10266  ELSE
10267  viol=1d0
10268  ENDIF
10269 
10270 C...Check that weight not negative.
10271  IF(mstp(123).LE.0) THEN
10272  IF(viol.LT.-1d-3) THEN
10273  WRITE(mstu(11),5000) viol,ngen(0,3)+1
10274  IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
10275  & vint(22),vint(23),vint(26)
10276  CALL pystop(2)
10277  ENDIF
10278  ELSE
10279  IF(viol.LT.min(-1d-3,vint(109))) THEN
10280  vint(109)=viol
10281  IF(mstp(123).LE.2) WRITE(mstu(11),5200) viol,ngen(0,3)+1
10282  IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
10283  & vint(22),vint(23),vint(26)
10284  ENDIF
10285  ENDIF
10286 
10287 C...Weighting using estimate of maximum of differential cross-section.
10288  ratnd=1d0
10289  IF(mfail.EQ.0.AND.isub.NE.95.AND.isub.NE.96) THEN
10290  IF(viol.LT.pyr(0)) THEN
10291  IF(mint(121).GT.1) CALL pysave(2,iga)
10292  IF(isub.GE.91.AND.isub.LE.94) isub=0
10293  goto 100
10294  ENDIF
10295  ELSEIF(mfail.EQ.0) THEN
10296  ratnd=siglpt/xsec(95,1)
10297  viol=viol/ratnd
10298  IF(loop2.EQ.1.AND.ratnd.LT.pyr(0)) THEN
10299  IF(viol.GT.pyr(0).AND.mint(82).EQ.1.AND.msub(95).EQ.1.AND.
10300  & (isub.LE.90.OR.isub.GE.95)) ngen(95,1)=ngen(95,1)+mint(143)
10301  IF(mint(121).GT.1) CALL pysave(2,iga)
10302  isub=0
10303  goto 100
10304  ENDIF
10305  IF(viol.LT.pyr(0)) THEN
10306  goto 140
10307  ENDIF
10308  ELSEIF(isub.NE.95.AND.isub.NE.96) THEN
10309  IF(viol.LT.pyr(0)) THEN
10310  msti(61)=1
10311  IF(mint(121).GT.1) CALL pysave(2,iga)
10312  RETURN
10313  ENDIF
10314  ELSE
10315  ratnd=siglpt/xsec(95,1)
10316  IF(loop.EQ.1.AND.ratnd.LT.pyr(0)) THEN
10317  msti(61)=1
10318  IF(mint(121).GT.1) CALL pysave(2,iga)
10319  RETURN
10320  ENDIF
10321  viol=viol/ratnd
10322  IF(viol.LT.pyr(0)) THEN
10323  IF(mint(121).GT.1) CALL pysave(2,iga)
10324  goto 100
10325  ENDIF
10326  ENDIF
10327 
10328 C...Check for possible violation of estimated maximum of differential
10329 C...cross-section used in weighting.
10330  IF(mstp(123).LE.0) THEN
10331  IF(viol.GT.1d0) THEN
10332  WRITE(mstu(11),5300) viol,ngen(0,3)+1
10333  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10334  & vint(22),vint(23),vint(26)
10335  CALL pystop(2)
10336  ENDIF
10337  ELSEIF(mstp(123).EQ.1) THEN
10338  IF(viol.GT.vint(108)) THEN
10339  vint(108)=viol
10340  IF(viol.GT.1.0001d0) THEN
10341  mint(10)=1
10342  WRITE(mstu(11),5400) viol,ngen(0,3)+1
10343  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10344  & vint(22),vint(23),vint(26)
10345  ENDIF
10346  ENDIF
10347  ELSEIF(viol.GT.vint(108)) THEN
10348  vint(108)=viol
10349  IF(viol.GT.1d0) THEN
10350  mint(10)=1
10351  IF(mstp(123).EQ.2) WRITE(mstu(11),5400) viol,ngen(0,3)+1
10352  IF(istsb.EQ.11.AND.(iabs(idwtup).EQ.1.OR.iabs(idwtup).EQ.2))
10353  & THEN
10354  xmaxup(kfpr(isub,1))=viol*xmaxup(kfpr(isub,1))
10355  IF(kfpr(isub,1).LE.9) THEN
10356  IF(mstp(123).EQ.2) WRITE(mstu(11),5800) kfpr(isub,1),
10357  & xmaxup(kfpr(isub,1))
10358  ELSEIF(kfpr(isub,1).LE.99) THEN
10359  IF(mstp(123).EQ.2) WRITE(mstu(11),5900) kfpr(isub,1),
10360  & xmaxup(kfpr(isub,1))
10361  ELSE
10362  IF(mstp(123).EQ.2) WRITE(mstu(11),6000) kfpr(isub,1),
10363  & xmaxup(kfpr(isub,1))
10364  ENDIF
10365  ENDIF
10366  IF(istsb.NE.11.OR.iabs(idwtup).EQ.1) THEN
10367  xdif=xsec(isub,1)*(viol-1d0)
10368  xsec(isub,1)=xsec(isub,1)+xdif
10369  IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))
10370  & xsec(0,1)=xsec(0,1)+xdif
10371  IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10372  & vint(22),vint(23),vint(26)
10373  IF(isub.LE.9) THEN
10374  IF(mstp(123).EQ.2) WRITE(mstu(11),5500) isub,xsec(isub,1)
10375  ELSEIF(isub.LE.99) THEN
10376  IF(mstp(123).EQ.2) WRITE(mstu(11),5600) isub,xsec(isub,1)
10377  ELSE
10378  IF(mstp(123).EQ.2) WRITE(mstu(11),5700) isub,xsec(isub,1)
10379  ENDIF
10380  ENDIF
10381  vint(108)=1d0
10382  ENDIF
10383  ENDIF
10384 
10385 C...Multiple interactions: choose impact parameter (if not already done).
10386  IF(mint(39).EQ.0) vint(148)=1d0
10387  IF(mint(50).EQ.1.AND.(isub.LE.90.OR.isub.GE.96).AND.
10388  &mstp(82).GE.3) THEN
10389  IF(mint(35).LE.1) CALL pymult(5)
10390  IF(mint(35).GE.2) CALL pymign(5)
10391  IF(vint(150).LT.pyr(0)) THEN
10392  IF(mint(121).GT.1) CALL pysave(2,iga)
10393  IF(mfail.EQ.1) THEN
10394  msti(61)=1
10395  RETURN
10396  ENDIF
10397  goto 100
10398  ENDIF
10399  ENDIF
10400  IF(mint(82).EQ.1) ngen(0,2)=ngen(0,2)+1
10401  IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN
10402  IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+mint(143)
10403  IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1
10404  ENDIF
10405  IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1
10406 
10407 C...Choose flavour of reacting partons (and subprocess).
10408  IF(istsb.GE.11) goto 320
10409  rsigs=sigs*pyr(0)
10410  qt2=vint(48)
10411  rqqbar=parp(87)*(1d0-(qt2/(qt2+(parp(88)*parp(82)*
10412  &(vint(1)/parp(89))**parp(90))**2))**2)
10413  IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.
10414  &pyr(0).GT.rqqbar)) THEN
10415  DO 310 ichn=1,nchn
10416  kfl1=isig(ichn,1)
10417  kfl2=isig(ichn,2)
10418  mint(2)=isig(ichn,3)
10419  rsigs=rsigs-sigh(ichn)
10420  IF(rsigs.LE.0d0) goto 320
10421  310 CONTINUE
10422 
10423 C...Multiple interactions: choose qqbar preferentially at small pT.
10424  ELSEIF(isub.EQ.96) THEN
10425  mint(105)=mint(103)
10426  mint(109)=mint(107)
10427  CALL pyspli(mint(11),21,kfl1,kfldum)
10428  mint(105)=mint(104)
10429  mint(109)=mint(108)
10430  CALL pyspli(mint(12),21,kfl2,kfldum)
10431  mint(1)=11
10432  mint(2)=1
10433  IF(kfl1.EQ.kfl2.AND.pyr(0).LT.0.5d0) mint(2)=2
10434 
10435 C...Low-pT: choose string drawing configuration.
10436  ELSE
10437  kfl1=21
10438  kfl2=21
10439  rsigs=6d0*pyr(0)
10440  mint(2)=1
10441  IF(rsigs.GT.1d0) mint(2)=2
10442  IF(rsigs.GT.2d0) mint(2)=3
10443  ENDIF
10444 
10445 C...Reassign QCD process. Partons before initial state radiation.
10446  320 IF(mint(2).GT.10) THEN
10447  mint(1)=mint(2)/10
10448  mint(2)=mod(mint(2),10)
10449  ENDIF
10450  IF(mint(82).EQ.1.AND.mstp(111).GE.0) ngen(mint(1),2)=
10451  &ngen(mint(1),2)+1
10452  mint(15)=kfl1
10453  mint(16)=kfl2
10454  mint(13)=mint(15)
10455  mint(14)=mint(16)
10456  vint(141)=vint(41)
10457  vint(142)=vint(42)
10458  vint(151)=0d0
10459  vint(152)=0d0
10460 
10461 C...Calculate x value of photon for parton inside photon inside e.
10462  DO 350 jt=1,2
10463  mint(18+jt)=0
10464  vint(154+jt)=0d0
10465  mspli=0
10466  IF(jt.EQ.1.AND.mint(43).LE.2) mspli=1
10467  IF(jt.EQ.2.AND.mod(mint(43),2).EQ.1) mspli=1
10468  IF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) mspli=mspli+1
10469  IF(mspli.EQ.2) THEN
10470  kflh=mint(14+jt)
10471  xhrd=vint(140+jt)
10472  q2hrd=vint(54)
10473  mint(105)=mint(102+jt)
10474  mint(109)=mint(106+jt)
10475  vint(120)=vint(2+jt)
10476  IF(mstp(57).LE.1) THEN
10477  CALL pypdfu(22,xhrd,q2hrd,xpq)
10478  ELSE
10479  CALL pypdfl(22,xhrd,q2hrd,xpq)
10480  ENDIF
10481  wtmx=4d0*xpq(kflh)
10482  IF(mstp(13).EQ.2) THEN
10483  q2pms=q2hrd/pmas(11,1)**2
10484  wtmx=wtmx*log(max(2d0,q2pms*(1d0-xhrd)/xhrd**2))
10485  ENDIF
10486  330 xe=xhrd**pyr(0)
10487  xg=min(1d0-1d-10,xhrd/xe)
10488  IF(mstp(57).LE.1) THEN
10489  CALL pypdfu(22,xg,q2hrd,xpq)
10490  ELSE
10491  CALL pypdfl(22,xg,q2hrd,xpq)
10492  ENDIF
10493  wt=(1d0+(1d0-xe)**2)*xpq(kflh)
10494  IF(mstp(13).EQ.2) wt=wt*log(max(2d0,q2pms*(1d0-xe)/xe**2))
10495  IF(wt.LT.pyr(0)*wtmx) goto 330
10496  mint(18+jt)=1
10497  vint(154+jt)=xe
10498  DO 340 kfls=-25,25
10499  xsfx(jt,kfls)=xpq(kfls)
10500  340 CONTINUE
10501  ENDIF
10502  350 CONTINUE
10503 
10504 C...Pick scale where photon is resolved.
10505  q0s=parp(15)**2
10506  q1s=vint(154)**2
10507  vint(283)=0d0
10508  IF(mint(107).EQ.3) THEN
10509  IF(mstp(66).EQ.1) THEN
10510  vint(283)=q0s*(vint(54)/q0s)**pyr(0)
10511  ELSEIF(mstp(66).EQ.2) THEN
10512  ps=vint(3)**2
10513  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10514  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10515  q2int=sqrt(q0s*q2eff)
10516  vint(283)=q2int*(vint(54)/q2int)**pyr(0)
10517  ELSEIF(mstp(66).EQ.3) THEN
10518  vint(283)=q0s*(q1s/q0s)**pyr(0)
10519  ELSEIF(mstp(66).GE.4) THEN
10520  ps=0.25d0*vint(3)**2
10521  vint(283)=(q0s+ps)*(q1s+ps)/
10522  & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
10523  ENDIF
10524  ENDIF
10525  vint(284)=0d0
10526  IF(mint(108).EQ.3) THEN
10527  IF(mstp(66).EQ.1) THEN
10528  vint(284)=q0s*(vint(54)/q0s)**pyr(0)
10529  ELSEIF(mstp(66).EQ.2) THEN
10530  ps=vint(4)**2
10531  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10532  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10533  q2int=sqrt(q0s*q2eff)
10534  vint(284)=q2int*(vint(54)/q2int)**pyr(0)
10535  ELSEIF(mstp(66).EQ.3) THEN
10536  vint(284)=q0s*(q1s/q0s)**pyr(0)
10537  ELSEIF(mstp(66).GE.4) THEN
10538  ps=0.25d0*vint(4)**2
10539  vint(284)=(q0s+ps)*(q1s+ps)/
10540  & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
10541  ENDIF
10542  ENDIF
10543  IF(mint(121).GT.1) CALL pysave(2,iga)
10544 
10545 C...Format statements for differential cross-section maximum violations.
10546  5000 FORMAT(/1x,'Error: negative cross-section fraction',1p,d11.3,1x,
10547  &'in event',1x,i7,'D0'/1x,'Execution stopped!')
10548  5100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p,
10549  &d11.3,', y* =',d11.3,', cthe = ',0p,f11.7,', tau'' =',1p,d11.3)
10550  5200 FORMAT(/1x,'Warning: negative cross-section fraction',1p,d11.3,1x,
10551  &'in event',1x,i7)
10552  5300 FORMAT(/1x,'Error: maximum violated by',1p,d11.3,1x,
10553  &'in event',1x,i7,'D0'/1x,'Execution stopped!')
10554  5400 FORMAT(/1x,'Advisory warning: maximum violated by',1p,d11.3,1x,
10555  &'in event',1x,i7)
10556  5500 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,d11.3)
10557  5600 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,d11.3)
10558  5700 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,d11.3)
10559  5800 FORMAT(1x,'XMAXUP(',i1,') increased to',1p,d11.3)
10560  5900 FORMAT(1x,'XMAXUP(',i2,') increased to',1p,d11.3)
10561  6000 FORMAT(1x,'XMAXUP(',i3,') increased to',1p,d11.3)
10562 
10563  RETURN
10564  END
10565 
10566 C*********************************************************************
10567 
10568 C...PYSCAT
10569 C...Finds outgoing flavours and event type; sets up the kinematics
10570 C...and colour flow of the hard scattering
10571 
10572  SUBROUTINE pyscat
10573 
10574 C...Double precision and integer declarations
10575  IMPLICIT DOUBLE PRECISION(a-h, o-z)
10576  IMPLICIT INTEGER(i-n)
10577  INTEGER pyk,pychge,pycomp
10578 C...Parameter statement to help give large particle numbers.
10579  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
10580  &kexcit=4000000,kdimen=5000000)
10581 C...Parameter statement for maximum size of showers.
10582  parameter(maxnur=1000)
10583 
10584 C...User process event common block.
10585  INTEGER maxnup
10586  parameter(maxnup=500)
10587  INTEGER nup,idprup,idup,istup,mothup,icolup
10588  DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
10589  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
10590  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
10591  &vtimup(maxnup),spinup(maxnup)
10592  SAVE /hepeup/
10593 
10594 C...Commonblocks.
10595  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
10596  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10597  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
10598  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
10599  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
10600  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
10601  common/pypars/mstp(200),parp(200),msti(200),pari(200)
10602  common/pyint1/mint(400),vint(400)
10603  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
10604  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
10605  common/pyint4/mwid(500),wids(500,5)
10606  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
10607  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
10608  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
10609  common/pytcsm/itcm(0:99),rtcm(0:99)
10610  common/pypued/iued(0:99),rued(0:99)
10611  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,
10612  &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyssmt/,
10613  &/pytcsm/,/pypued/
10614 C...Local arrays and saved variables
10615  dimension wdtp(0:400),wdte(0:400,0:5),pmq(2),z(2),cthe(2),
10616  &phi(2),kuppo(100),vintsv(41:66),ilab(100)
10617  INTEGER iokfla(6),iiflav
10618 C...UED related declarations:
10619 C...equivalences between ordered particles (451->475)
10620 C...and UED particle code (5 000 000 + id)
10621  dimension iuedeq(475),mued(2)
10622  DATA (iuedeq(i),i=451,475)/
10623  & 6100001,6100002,6100003,6100004,6100005,6100006,
10624  & 5100001,5100002,5100003,5100004,5100005,5100006,
10625  & 6100011,6100013,6100015,
10626  & 5100012,5100011,5100014,5100013,5100016,5100015,
10627  & 5100021,5100022,5100023,5100024/
10628  SAVE vintsv
10629 
10630 C...Read out process
10631  isub=mint(1)
10632  isubsv=isub
10633 
10634 C...Restore information for low-pT processes
10635  IF(isub.EQ.95.AND.mint(57).GE.1) THEN
10636  DO 100 j=41,66
10637  100 vint(j)=vintsv(j)
10638  ENDIF
10639 
10640 C...Convert H' or A process into equivalent H one
10641  ihigg=1
10642  kfhigg=25
10643  IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
10644  &isub.LE.190)) THEN
10645  ihigg=2
10646  IF(mod(isub-1,10).GE.5) ihigg=3
10647  kfhigg=33+ihigg
10648  IF(isub.EQ.151.OR.isub.EQ.156) isub=3
10649  IF(isub.EQ.152.OR.isub.EQ.157) isub=102
10650  IF(isub.EQ.153.OR.isub.EQ.158) isub=103
10651  IF(isub.EQ.171.OR.isub.EQ.176) isub=24
10652  IF(isub.EQ.172.OR.isub.EQ.177) isub=26
10653  IF(isub.EQ.173.OR.isub.EQ.178) isub=123
10654  IF(isub.EQ.174.OR.isub.EQ.179) isub=124
10655  IF(isub.EQ.181.OR.isub.EQ.186) isub=121
10656  IF(isub.EQ.182.OR.isub.EQ.187) isub=122
10657  IF(isub.EQ.183.OR.isub.EQ.188) isub=111
10658  IF(isub.EQ.184.OR.isub.EQ.189) isub=112
10659  IF(isub.EQ.185.OR.isub.EQ.190) isub=113
10660  ENDIF
10661 
10662  IF(isub.EQ.401.OR.isub.EQ.402) kfhigg=kfpr(isub,1)
10663 
10664 C...Convert bottomonium process into equivalent charmonium ones.
10665  IF(isub.GE.461.AND.isub.LE.479) isub=isub-40
10666 
10667 C...Choice of subprocess, number of documentation lines
10668  idoc=6+iset(isub)
10669  IF(isub.EQ.95) idoc=8
10670  IF(iset(isub).EQ.5) idoc=9
10671  IF(iset(isub).EQ.11) idoc=4+nup
10672  mint(3)=idoc-6
10673  IF(idoc.GE.9.AND.iset(isub).LE.4) idoc=idoc+2
10674  mint(4)=idoc
10675  ipu1=mint(84)+1
10676  ipu2=mint(84)+2
10677  ipu3=mint(84)+3
10678  ipu4=mint(84)+4
10679  ipu5=mint(84)+5
10680  ipu6=mint(84)+6
10681 
10682 C...Reset K, P and V vectors. Store incoming particles
10683  DO 120 jt=1,mstp(126)+100
10684  i=mint(83)+jt
10685  IF(i.GT.mstu(4)) goto 120
10686  DO 110 j=1,5
10687  k(i,j)=0
10688  p(i,j)=0d0
10689  v(i,j)=0d0
10690  110 CONTINUE
10691  120 CONTINUE
10692  DO 140 jt=1,2
10693  i=mint(83)+jt
10694  k(i,1)=21
10695  k(i,2)=mint(10+jt)
10696  DO 130 j=1,5
10697  p(i,j)=vint(285+5*jt+j)
10698  130 CONTINUE
10699  140 CONTINUE
10700  mint(6)=2
10701  kfres=0
10702 
10703 C...Store incoming partons in their CM-frame. Save pdf value.
10704  sh=vint(44)
10705  shr=sqrt(sh)
10706  shp=vint(26)*vint(2)
10707  shpr=sqrt(shp)
10708  shuser=shr
10709  IF(iset(isub).GE.3.AND.iset(isub).LE.5) shuser=shpr
10710  DO 150 jt=1,2
10711  i=mint(84)+jt
10712  k(i,1)=14
10713  k(i,2)=mint(14+jt)
10714  k(i,3)=mint(83)+2+jt
10715  p(i,3)=0.5d0*shuser*(-1d0)**(jt-1)
10716  p(i,4)=0.5d0*shuser
10717  IF(mint(14+jt).GE.-40.AND.mint(14+jt).LE.40) THEN
10718  vint(38+jt)=xsfx(jt,mint(14+jt))
10719  ELSE
10720  vint(38+jt)=1d0
10721  ENDIF
10722  150 CONTINUE
10723 
10724 C...Copy incoming partons to documentation lines
10725  DO 170 jt=1,2
10726  i1=mint(83)+4+jt
10727  i2=mint(84)+jt
10728  k(i1,1)=21
10729  k(i1,2)=k(i2,2)
10730  k(i1,3)=i1-2
10731  DO 160 j=1,5
10732  p(i1,j)=p(i2,j)
10733  160 CONTINUE
10734  170 CONTINUE
10735 
10736 C...Choose new quark/lepton flavour for relevant annihilation graphs
10737  IF(isub.EQ.12.OR.isub.EQ.53.OR.isub.EQ.54.OR.isub.EQ.58.OR.
10738  &isub.EQ.314.OR.isub.EQ.319.OR.isub.EQ.316.OR.
10739  &(isub.GE.135.AND.isub.LE.140).OR.isub.EQ.382.OR.isub.EQ.385) THEN
10740  iglga=21
10741  IF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) iglga=22
10742  CALL pywidt(iglga,sh,wdtp,wdte)
10743  180 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
10744  DO 190 i=1,mdcy(iglga,3)
10745  kflf=kfdp(i+mdcy(iglga,2)-1,1)
10746  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
10747  IF(rkfl.LE.0d0) goto 200
10748  190 CONTINUE
10749  200 CONTINUE
10750  IF((isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319
10751  & .OR.isub.EQ.316).AND.mint(2).LE.2) THEN
10752  IF(kflf.GE.4) goto 180
10753  ELSEIF((isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319.
10754  & or.isub.EQ.316).AND.mint(2).LE.4) THEN
10755  kflf=4
10756  mint(2)=mint(2)-2
10757  ELSEIF(isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319.
10758  & or.isub.EQ.316) THEN
10759  kflf=5
10760  mint(2)=mint(2)-4
10761  ELSEIF(isub.EQ.382.AND.itcm(5).EQ.1.AND.iabs(mint(15)).LE.2
10762  & .AND.iabs(kflf).GE.3) THEN
10763  facqqb=vint(58)**2*4d0/9d0*(vint(45)**2+vint(46)**2)/
10764  & vint(44)**2
10765  faccib=vint(46)**2/rtcm(41)**4
10766  IF(facqqb/(facqqb+faccib).LT.pyr(0)) goto 180
10767  ELSEIF(isub.EQ.382.AND.itcm(5).EQ.5.AND.mint(2).EQ.2) THEN
10768  kflf=5
10769  mint(2)=1
10770  ELSEIF(isub.EQ.382.AND.itcm(5).EQ.5.AND.mint(2).EQ.1) THEN
10771  IF(kflf.EQ.5) goto 180
10772  ELSEIF(isub.EQ.54.OR.isub.EQ.135.OR.isub.EQ.136) THEN
10773  IF((kchg(pycomp(kflf),1)/2d0)**2.LT.pyr(0)) goto 180
10774  ELSEIF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) THEN
10775  IF((kchg(pycomp(kflf),1)/3d0)**2.LT.pyr(0)) goto 180
10776  ENDIF
10777  ENDIF
10778 
10779 C...Final state flavours and colour flow: default values
10780  js=1
10781  mint(21)=mint(15)
10782  mint(22)=mint(16)
10783  mint(23)=0
10784  mint(24)=0
10785  kcc=20
10786  kcs=isign(1,mint(15))
10787 
10788  IF(iset(isub).EQ.11) THEN
10789 C...User-defined processes: find products
10790  mint(3)=0
10791  DO 210 iup=3,nup
10792  IF(istup(iup).LT.1.OR.istup(iup).GT.3) THEN
10793  ELSEIF(nup.EQ.5.AND.iup.GE.4.AND.mothup(1,4).EQ.3) THEN
10794  mint(21+iup)=idup(iup)
10795  ELSEIF(istup(iup).EQ.1.AND.(istup(mothup(1,iup)).EQ.2.OR.
10796  & istup(mothup(1,iup)).EQ.3).AND.idup(mothup(1,iup)).NE.0) THEN
10797  ELSEIF(idup(iup).EQ.0) THEN
10798  ELSE
10799  mint(3)=mint(3)+1
10800  IF(mint(3).LE.6) mint(20+mint(3))=idup(iup)
10801  ENDIF
10802  210 CONTINUE
10803 
10804  ELSEIF(isub.LE.10) THEN
10805  IF(isub.EQ.1) THEN
10806 C...f + fbar -> gamma*/Z0
10807  kfres=23
10808 
10809  ELSEIF(isub.EQ.2) THEN
10810 C...f + fbar' -> W+/-
10811  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10812  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10813  kfres=isign(24,kch1+kch2)
10814 
10815  ELSEIF(isub.EQ.3) THEN
10816 C...f + fbar -> h0 (or H0, or A0)
10817  kfres=kfhigg
10818 
10819  ELSEIF(isub.EQ.4) THEN
10820 C...gamma + W+/- -> W+/-
10821 
10822  ELSEIF(isub.EQ.5) THEN
10823 C...Z0 + Z0 -> h0
10824  xh=sh/shp
10825  mint(21)=mint(15)
10826  mint(22)=mint(16)
10827  pmq(1)=pymass(mint(21))
10828  pmq(2)=pymass(mint(22))
10829  220 jt=int(1.5d0+pyr(0))
10830  zmin=2d0*pmq(jt)/shpr
10831  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
10832  & (shpr*(shpr-pmq(3-jt)))
10833  zmax=min(1d0-xh,zmax)
10834  z(jt)=zmin+(zmax-zmin)*pyr(0)
10835  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
10836  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 220
10837  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
10838  IF(sqc1.LT.1d-8) goto 220
10839  c1=sqrt(sqc1)
10840  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
10841  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10842  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
10843  z(3-jt)=1d0-xh/(1d0-z(jt))
10844  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
10845  IF(sqc1.LT.1d-8) goto 220
10846  c1=sqrt(sqc1)
10847  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
10848  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10849  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
10850  phir=paru(2)*pyr(0)
10851  cphi=cos(phir)
10852  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
10853  & sqrt(1d0-cthe(2)**2)*cphi
10854  z1=2d0-z(jt)
10855  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
10856  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
10857  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
10858  & pmq(3-jt)**2/shp))
10859  zmin=2d0*pmq(3-jt)/shpr
10860  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
10861  zmax=min(1d0-xh,zmax)
10862  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 220
10863  kcc=22
10864  kfres=25
10865 
10866  ELSEIF(isub.EQ.6) THEN
10867 C...Z0 + W+/- -> W+/-
10868 
10869  ELSEIF(isub.EQ.7) THEN
10870 C...W+ + W- -> Z0
10871 
10872  ELSEIF(isub.EQ.8) THEN
10873 C...W+ + W- -> h0
10874  xh=sh/shp
10875  230 DO 260 jt=1,2
10876  i=mint(14+jt)
10877  ia=iabs(i)
10878  IF(ia.LE.10) THEN
10879  rvckm=vint(180+i)*pyr(0)
10880  DO 240 j=1,mstp(1)
10881  ib=2*j-1+mod(ia,2)
10882  ipm=(5-isign(1,i))/2
10883  idc=j+mdcy(ia,2)+2
10884  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 240
10885  mint(20+jt)=isign(ib,i)
10886  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10887  IF(rvckm.LE.0d0) goto 250
10888  240 CONTINUE
10889  ELSE
10890  ib=2*((ia+1)/2)-1+mod(ia,2)
10891  mint(20+jt)=isign(ib,i)
10892  ENDIF
10893  250 pmq(jt)=pymass(mint(20+jt))
10894  260 CONTINUE
10895  jt=int(1.5d0+pyr(0))
10896  zmin=2d0*pmq(jt)/shpr
10897  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
10898  & (shpr*(shpr-pmq(3-jt)))
10899  zmax=min(1d0-xh,zmax)
10900  IF(zmin.GE.zmax) goto 230
10901  z(jt)=zmin+(zmax-zmin)*pyr(0)
10902  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
10903  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 230
10904  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
10905  IF(sqc1.LT.1d-8) goto 230
10906  c1=sqrt(sqc1)
10907  c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
10908  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10909  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
10910  z(3-jt)=1d0-xh/(1d0-z(jt))
10911  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
10912  IF(sqc1.LT.1d-8) goto 230
10913  c1=sqrt(sqc1)
10914  c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
10915  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10916  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
10917  phir=paru(2)*pyr(0)
10918  cphi=cos(phir)
10919  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
10920  & sqrt(1d0-cthe(2)**2)*cphi
10921  z1=2d0-z(jt)
10922  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
10923  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
10924  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
10925  & pmq(3-jt)**2/shp))
10926  zmin=2d0*pmq(3-jt)/shpr
10927  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
10928  zmax=min(1d0-xh,zmax)
10929  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 230
10930  kcc=22
10931  kfres=25
10932 
10933  ELSEIF(isub.EQ.10) THEN
10934 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10935  IF(mint(2).EQ.1) THEN
10936  kcc=22
10937  ELSE
10938 C...W exchange: need to mix flavours according to CKM matrix
10939  DO 280 jt=1,2
10940  i=mint(14+jt)
10941  ia=iabs(i)
10942  IF(ia.LE.10) THEN
10943  rvckm=vint(180+i)*pyr(0)
10944  DO 270 j=1,mstp(1)
10945  ib=2*j-1+mod(ia,2)
10946  ipm=(5-isign(1,i))/2
10947  idc=j+mdcy(ia,2)+2
10948  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 270
10949  mint(20+jt)=isign(ib,i)
10950  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10951  IF(rvckm.LE.0d0) goto 280
10952  270 CONTINUE
10953  ELSE
10954  ib=2*((ia+1)/2)-1+mod(ia,2)
10955  mint(20+jt)=isign(ib,i)
10956  ENDIF
10957  280 CONTINUE
10958  kcc=22
10959  ENDIF
10960  ENDIF
10961 
10962  ELSEIF(isub.LE.20) THEN
10963  IF(isub.EQ.11) THEN
10964 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10965  kcc=mint(2)
10966  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
10967 
10968  ELSEIF(isub.EQ.12) THEN
10969 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10970  mint(21)=isign(kflf,mint(15))
10971  mint(22)=-mint(21)
10972  kcc=4
10973 
10974  ELSEIF(isub.EQ.13) THEN
10975 C...f + fbar -> g + g; th arbitrary
10976  mint(21)=21
10977  mint(22)=21
10978  kcc=mint(2)+4
10979 
10980  ELSEIF(isub.EQ.14) THEN
10981 C...f + fbar -> g + gamma; th arbitrary
10982  IF(pyr(0).GT.0.5d0) js=2
10983  mint(20+js)=21
10984  mint(23-js)=22
10985  kcc=17+js
10986 
10987  ELSEIF(isub.EQ.15) THEN
10988 C...f + fbar -> g + Z0; th arbitrary
10989  IF(pyr(0).GT.0.5d0) js=2
10990  mint(20+js)=21
10991  mint(23-js)=23
10992  kcc=17+js
10993 
10994  ELSEIF(isub.EQ.16) THEN
10995 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10996  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10997  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10998  IF(mint(15)*(kch1+kch2).LT.0) js=2
10999  mint(20+js)=21
11000  mint(23-js)=isign(24,kch1+kch2)
11001  kcc=17+js
11002 
11003  ELSEIF(isub.EQ.17) THEN
11004 C...f + fbar -> g + h0; th arbitrary
11005  IF(pyr(0).GT.0.5d0) js=2
11006  mint(20+js)=21
11007  mint(23-js)=25
11008  kcc=17+js
11009 
11010  ELSEIF(isub.EQ.18) THEN
11011 C...f + fbar -> gamma + gamma; th arbitrary
11012  mint(21)=22
11013  mint(22)=22
11014 
11015  ELSEIF(isub.EQ.19) THEN
11016 C...f + fbar -> gamma + Z0; th arbitrary
11017  IF(pyr(0).GT.0.5d0) js=2
11018  mint(20+js)=22
11019  mint(23-js)=23
11020 
11021  ELSEIF(isub.EQ.20) THEN
11022 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
11023 C...(p(fbar')-p(W+))**2
11024  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11025  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11026  IF(mint(15)*(kch1+kch2).LT.0) js=2
11027  mint(20+js)=22
11028  mint(23-js)=isign(24,kch1+kch2)
11029  ENDIF
11030 
11031  ELSEIF(isub.LE.30) THEN
11032  IF(isub.EQ.21) THEN
11033 C...f + fbar -> gamma + h0; th arbitrary
11034  IF(pyr(0).GT.0.5d0) js=2
11035  mint(20+js)=22
11036  mint(23-js)=25
11037 
11038  ELSEIF(isub.EQ.22) THEN
11039 C...f + fbar -> Z0 + Z0; th arbitrary
11040  mint(21)=23
11041  mint(22)=23
11042 
11043  ELSEIF(isub.EQ.23) THEN
11044 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11045  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11046  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11047  IF(mint(15)*(kch1+kch2).LT.0) js=2
11048  mint(20+js)=23
11049  mint(23-js)=isign(24,kch1+kch2)
11050 
11051  ELSEIF(isub.EQ.24) THEN
11052 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
11053  IF(pyr(0).GT.0.5d0) js=2
11054  mint(20+js)=23
11055  mint(23-js)=kfhigg
11056 
11057  ELSEIF(isub.EQ.25) THEN
11058 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
11059  mint(21)=-isign(24,mint(15))
11060  mint(22)=-mint(21)
11061 
11062  ELSEIF(isub.EQ.26) THEN
11063 C...f + fbar' -> W+/- + h0 (or H0, or A0);
11064 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11065  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11066  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11067  IF(mint(15)*(kch1+kch2).GT.0) js=2
11068  mint(20+js)=isign(24,kch1+kch2)
11069  mint(23-js)=kfhigg
11070 
11071  ELSEIF(isub.EQ.27) THEN
11072 C...f + fbar -> h0 + h0
11073 
11074  ELSEIF(isub.EQ.28) THEN
11075 C...f + g -> f + g; th = (p(f)-p(f))**2
11076  IF(mint(15).EQ.21) js=2
11077  kcc=mint(2)+6
11078  IF(mint(15).EQ.21) kcc=kcc+2
11079  IF(mint(15).NE.21) kcs=isign(1,mint(15))
11080  IF(mint(16).NE.21) kcs=isign(1,mint(16))
11081 
11082  ELSEIF(isub.EQ.29) THEN
11083 C...f + g -> f + gamma; th = (p(f)-p(f))**2
11084  IF(mint(15).EQ.21) js=2
11085  mint(23-js)=22
11086  kcc=15+js
11087  kcs=isign(1,mint(14+js))
11088 
11089  ELSEIF(isub.EQ.30) THEN
11090 C...f + g -> f + Z0; th = (p(f)-p(f))**2
11091  IF(mint(15).EQ.21) js=2
11092  mint(23-js)=23
11093  kcc=15+js
11094  kcs=isign(1,mint(14+js))
11095  ENDIF
11096 
11097  ELSEIF(isub.LE.40) THEN
11098  IF(isub.EQ.31) THEN
11099 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
11100  IF(mint(15).EQ.21) js=2
11101  i=mint(14+js)
11102  ia=iabs(i)
11103  mint(23-js)=isign(24,kchg(ia,1)*i)
11104  rvckm=vint(180+i)*pyr(0)
11105  DO 290 j=1,mstp(1)
11106  ib=2*j-1+mod(ia,2)
11107  ipm=(5-isign(1,i))/2
11108  idc=j+mdcy(ia,2)+2
11109  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 290
11110  mint(20+js)=isign(ib,i)
11111  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11112  IF(rvckm.LE.0d0) goto 300
11113  290 CONTINUE
11114  300 kcc=15+js
11115  kcs=isign(1,mint(14+js))
11116 
11117  ELSEIF(isub.EQ.32) THEN
11118 C...f + g -> f + h0; th = (p(f)-p(f))**2
11119  IF(mint(15).EQ.21) js=2
11120  mint(23-js)=25
11121  kcc=15+js
11122  kcs=isign(1,mint(14+js))
11123 
11124  ELSEIF(isub.EQ.33) THEN
11125 C...f + gamma -> f + g; th=(p(f)-p(f))**2
11126  IF(mint(15).EQ.22) js=2
11127  mint(23-js)=21
11128  kcc=24+js
11129  kcs=isign(1,mint(14+js))
11130 
11131  ELSEIF(isub.EQ.34) THEN
11132 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11133  IF(mint(15).EQ.22) js=2
11134  kcc=22
11135  kcs=isign(1,mint(14+js))
11136 
11137  ELSEIF(isub.EQ.35) THEN
11138 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11139  IF(mint(15).EQ.22) js=2
11140  mint(23-js)=23
11141  kcc=22
11142 
11143  ELSEIF(isub.EQ.36) THEN
11144 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11145  IF(mint(15).EQ.22) js=2
11146  i=mint(14+js)
11147  ia=iabs(i)
11148  mint(23-js)=isign(24,kchg(ia,1)*i)
11149  IF(ia.LE.10) THEN
11150  rvckm=vint(180+i)*pyr(0)
11151  DO 310 j=1,mstp(1)
11152  ib=2*j-1+mod(ia,2)
11153  ipm=(5-isign(1,i))/2
11154  idc=j+mdcy(ia,2)+2
11155  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 310
11156  mint(20+js)=isign(ib,i)
11157  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11158  IF(rvckm.LE.0d0) goto 320
11159  310 CONTINUE
11160  ELSE
11161  ib=2*((ia+1)/2)-1+mod(ia,2)
11162  mint(20+js)=isign(ib,i)
11163  ENDIF
11164  320 kcc=22
11165 
11166  ELSEIF(isub.EQ.37) THEN
11167 C...f + gamma -> f + h0
11168 
11169  ELSEIF(isub.EQ.38) THEN
11170 C...f + Z0 -> f + g
11171 
11172  ELSEIF(isub.EQ.39) THEN
11173 C...f + Z0 -> f + gamma
11174 
11175  ELSEIF(isub.EQ.40) THEN
11176 C...f + Z0 -> f + Z0
11177  ENDIF
11178 
11179  ELSEIF(isub.LE.50) THEN
11180  IF(isub.EQ.41) THEN
11181 C...f + Z0 -> f' + W+/-
11182 
11183  ELSEIF(isub.EQ.42) THEN
11184 C...f + Z0 -> f + h0
11185 
11186  ELSEIF(isub.EQ.43) THEN
11187 C...f + W+/- -> f' + g
11188 
11189  ELSEIF(isub.EQ.44) THEN
11190 C...f + W+/- -> f' + gamma
11191 
11192  ELSEIF(isub.EQ.45) THEN
11193 C...f + W+/- -> f' + Z0
11194 
11195  ELSEIF(isub.EQ.46) THEN
11196 C...f + W+/- -> f' + W+/-
11197 
11198  ELSEIF(isub.EQ.47) THEN
11199 C...f + W+/- -> f' + h0
11200 
11201  ELSEIF(isub.EQ.48) THEN
11202 C...f + h0 -> f + g
11203 
11204  ELSEIF(isub.EQ.49) THEN
11205 C...f + h0 -> f + gamma
11206 
11207  ELSEIF(isub.EQ.50) THEN
11208 C...f + h0 -> f + Z0
11209  ENDIF
11210 
11211  ELSEIF(isub.LE.60) THEN
11212  IF(isub.EQ.51) THEN
11213 C...f + h0 -> f' + W+/-
11214 
11215  ELSEIF(isub.EQ.52) THEN
11216 C...f + h0 -> f + h0
11217 
11218  ELSEIF(isub.EQ.53) THEN
11219 C...g + g -> f + fbar; th arbitrary
11220  kcs=(-1)**int(1.5d0+pyr(0))
11221  mint(21)=isign(kflf,kcs)
11222  mint(22)=-mint(21)
11223  kcc=mint(2)+10
11224 
11225  ELSEIF(isub.EQ.54) THEN
11226 C...g + gamma -> f + fbar; th arbitrary
11227  kcs=(-1)**int(1.5d0+pyr(0))
11228  mint(21)=isign(kflf,kcs)
11229  mint(22)=-mint(21)
11230  kcc=27
11231  IF(mint(16).EQ.21) kcc=28
11232 
11233  ELSEIF(isub.EQ.55) THEN
11234 C...g + Z0 -> f + fbar
11235 
11236  ELSEIF(isub.EQ.56) THEN
11237 C...g + W+/- -> f + fbar'
11238 
11239  ELSEIF(isub.EQ.57) THEN
11240 C...g + h0 -> f + fbar
11241 
11242  ELSEIF(isub.EQ.58) THEN
11243 C...gamma + gamma -> f + fbar; th arbitrary
11244  kcs=(-1)**int(1.5d0+pyr(0))
11245  mint(21)=isign(kflf,kcs)
11246  mint(22)=-mint(21)
11247  kcc=21
11248 
11249  ELSEIF(isub.EQ.59) THEN
11250 C...gamma + Z0 -> f + fbar
11251 
11252  ELSEIF(isub.EQ.60) THEN
11253 C...gamma + W+/- -> f + fbar'
11254  ENDIF
11255 
11256  ELSEIF(isub.LE.70) THEN
11257  IF(isub.EQ.61) THEN
11258 C...gamma + h0 -> f + fbar
11259 
11260  ELSEIF(isub.EQ.62) THEN
11261 C...Z0 + Z0 -> f + fbar
11262 
11263  ELSEIF(isub.EQ.63) THEN
11264 C...Z0 + W+/- -> f + fbar'
11265 
11266  ELSEIF(isub.EQ.64) THEN
11267 C...Z0 + h0 -> f + fbar
11268 
11269  ELSEIF(isub.EQ.65) THEN
11270 C...W+ + W- -> f + fbar
11271 
11272  ELSEIF(isub.EQ.66) THEN
11273 C...W+/- + h0 -> f + fbar'
11274 
11275  ELSEIF(isub.EQ.67) THEN
11276 C...h0 + h0 -> f + fbar
11277 
11278  ELSEIF(isub.EQ.68) THEN
11279 C...g + g -> g + g; th arbitrary
11280  kcc=mint(2)+12
11281  kcs=(-1)**int(1.5d0+pyr(0))
11282 
11283  ELSEIF(isub.EQ.69) THEN
11284 C...gamma + gamma -> W+ + W-; th arbitrary
11285  mint(21)=24
11286  mint(22)=-24
11287  kcc=21
11288 
11289  ELSEIF(isub.EQ.70) THEN
11290 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11291  IF(mint(15).EQ.22) mint(21)=23
11292  IF(mint(16).EQ.22) mint(22)=23
11293  kcc=21
11294  ENDIF
11295 
11296  ELSEIF(isub.LE.80) THEN
11297  IF(isub.EQ.71.OR.isub.EQ.72) THEN
11298 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11299  xh=sh/shp
11300  mint(21)=mint(15)
11301  mint(22)=mint(16)
11302  pmq(1)=pymass(mint(21))
11303  pmq(2)=pymass(mint(22))
11304  330 jt=int(1.5d0+pyr(0))
11305  zmin=2d0*pmq(jt)/shpr
11306  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11307  & (shpr*(shpr-pmq(3-jt)))
11308  zmax=min(1d0-xh,zmax)
11309  z(jt)=zmin+(zmax-zmin)*pyr(0)
11310  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11311  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 330
11312  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11313  IF(sqc1.LT.1d-8) goto 330
11314  c1=sqrt(sqc1)
11315  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
11316  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11317  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11318  z(3-jt)=1d0-xh/(1d0-z(jt))
11319  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11320  IF(sqc1.LT.1d-8) goto 330
11321  c1=sqrt(sqc1)
11322  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11323  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11324  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11325  phir=paru(2)*pyr(0)
11326  cphi=cos(phir)
11327  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11328  & sqrt(1d0-cthe(2)**2)*cphi
11329  z1=2d0-z(jt)
11330  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11331  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11332  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11333  & pmq(3-jt)**2/shp))
11334  zmin=2d0*pmq(3-jt)/shpr
11335  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11336  zmax=min(1d0-xh,zmax)
11337  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 330
11338  kcc=22
11339 
11340  ELSEIF(isub.EQ.73) THEN
11341 C...Z0 + W+/- -> Z0 + W+/-
11342  js=mint(2)
11343  xh=sh/shp
11344  340 jt=3-mint(2)
11345  i=mint(14+jt)
11346  ia=iabs(i)
11347  IF(ia.LE.10) THEN
11348  rvckm=vint(180+i)*pyr(0)
11349  DO 350 j=1,mstp(1)
11350  ib=2*j-1+mod(ia,2)
11351  ipm=(5-isign(1,i))/2
11352  idc=j+mdcy(ia,2)+2
11353  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 350
11354  mint(20+jt)=isign(ib,i)
11355  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11356  IF(rvckm.LE.0d0) goto 360
11357  350 CONTINUE
11358  ELSE
11359  ib=2*((ia+1)/2)-1+mod(ia,2)
11360  mint(20+jt)=isign(ib,i)
11361  ENDIF
11362  360 pmq(jt)=pymass(mint(20+jt))
11363  mint(23-jt)=mint(17-jt)
11364  pmq(3-jt)=pymass(mint(23-jt))
11365  jt=int(1.5d0+pyr(0))
11366  zmin=2d0*pmq(jt)/shpr
11367  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11368  & (shpr*(shpr-pmq(3-jt)))
11369  zmax=min(1d0-xh,zmax)
11370  IF(zmin.GE.zmax) goto 340
11371  z(jt)=zmin+(zmax-zmin)*pyr(0)
11372  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11373  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 340
11374  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11375  IF(sqc1.LT.1d-8) goto 340
11376  c1=sqrt(sqc1)
11377  c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
11378  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11379  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11380  z(3-jt)=1d0-xh/(1d0-z(jt))
11381  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11382  IF(sqc1.LT.1d-8) goto 340
11383  c1=sqrt(sqc1)
11384  c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11385  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11386  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11387  phir=paru(2)*pyr(0)
11388  cphi=cos(phir)
11389  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11390  & sqrt(1d0-cthe(2)**2)*cphi
11391  z1=2d0-z(jt)
11392  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11393  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11394  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11395  & pmq(3-jt)**2/shp))
11396  zmin=2d0*pmq(3-jt)/shpr
11397  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11398  zmax=min(1d0-xh,zmax)
11399  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 340
11400  kcc=22
11401 
11402  ELSEIF(isub.EQ.74) THEN
11403 C...Z0 + h0 -> Z0 + h0
11404 
11405  ELSEIF(isub.EQ.75) THEN
11406 C...W+ + W- -> gamma + gamma
11407 
11408  ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN
11409 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11410  xh=sh/shp
11411  370 DO 400 jt=1,2
11412  i=mint(14+jt)
11413  ia=iabs(i)
11414  IF(ia.LE.10) THEN
11415  rvckm=vint(180+i)*pyr(0)
11416  DO 380 j=1,mstp(1)
11417  ib=2*j-1+mod(ia,2)
11418  ipm=(5-isign(1,i))/2
11419  idc=j+mdcy(ia,2)+2
11420  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 380
11421  mint(20+jt)=isign(ib,i)
11422  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11423  IF(rvckm.LE.0d0) goto 390
11424  380 CONTINUE
11425  ELSE
11426  ib=2*((ia+1)/2)-1+mod(ia,2)
11427  mint(20+jt)=isign(ib,i)
11428  ENDIF
11429  390 pmq(jt)=pymass(mint(20+jt))
11430  400 CONTINUE
11431  jt=int(1.5d0+pyr(0))
11432  zmin=2d0*pmq(jt)/shpr
11433  zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11434  & (shpr*(shpr-pmq(3-jt)))
11435  zmax=min(1d0-xh,zmax)
11436  IF(zmin.GE.zmax) goto 370
11437  z(jt)=zmin+(zmax-zmin)*pyr(0)
11438  IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11439  & (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 370
11440  sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11441  IF(sqc1.LT.1d-8) goto 370
11442  c1=sqrt(sqc1)
11443  c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
11444  cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11445  cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11446  z(3-jt)=1d0-xh/(1d0-z(jt))
11447  sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11448  IF(sqc1.LT.1d-8) goto 370
11449  c1=sqrt(sqc1)
11450  c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11451  cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11452  cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11453  phir=paru(2)*pyr(0)
11454  cphi=cos(phir)
11455  ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11456  & sqrt(1d0-cthe(2)**2)*cphi
11457  z1=2d0-z(jt)
11458  z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11459  z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11460  z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11461  & pmq(3-jt)**2/shp))
11462  zmin=2d0*pmq(3-jt)/shpr
11463  zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11464  zmax=min(1d0-xh,zmax)
11465  IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 370
11466  kcc=22
11467 
11468  ELSEIF(isub.EQ.78) THEN
11469 C...W+/- + h0 -> W+/- + h0
11470 
11471  ELSEIF(isub.EQ.79) THEN
11472 C...h0 + h0 -> h0 + h0
11473 
11474  ELSEIF(isub.EQ.80) THEN
11475 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11476  IF(mint(15).EQ.22) js=2
11477  i=mint(14+js)
11478  ia=iabs(i)
11479  mint(23-js)=isign(211,kchg(ia,1)*i)
11480  ib=3-ia
11481  mint(20+js)=isign(ib,i)
11482  kcc=22
11483  ENDIF
11484 
11485  ELSEIF(isub.LE.90) THEN
11486  IF(isub.EQ.81) THEN
11487 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11488  mint(21)=isign(mint(55),mint(15))
11489  mint(22)=-mint(21)
11490  kcc=4
11491 
11492  ELSEIF(isub.EQ.82) THEN
11493 C...g + g -> Q + Qbar; th arbitrary
11494  kcs=(-1)**int(1.5d0+pyr(0))
11495  mint(21)=isign(mint(55),kcs)
11496  mint(22)=-mint(21)
11497  kcc=mint(2)+10
11498 
11499  ELSEIF(isub.EQ.83) THEN
11500 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11501  kfold=mint(16)
11502  IF(mint(2).EQ.2) kfold=mint(15)
11503  kfaold=iabs(kfold)
11504  IF(kfaold.GT.10) THEN
11505  kfanew=kfaold+2*mod(kfaold,2)-1
11506  ELSE
11507  rckm=vint(180+kfold)*pyr(0)
11508  ipm=(5-isign(1,kfold))/2
11509  kfanew=-mod(kfaold+1,2)
11510  410 kfanew=kfanew+2
11511  idc=mdcy(kfaold,2)+(kfanew+1)/2+2
11512  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) THEN
11513  IF(mod(kfaold,2).EQ.0) rckm=rckm-
11514  & vckm(kfaold/2,(kfanew+1)/2)
11515  IF(mod(kfaold,2).EQ.1) rckm=rckm-
11516  & vckm(kfanew/2,(kfaold+1)/2)
11517  ENDIF
11518  IF(kfanew.LE.6.AND.rckm.GT.0d0) goto 410
11519  ENDIF
11520  IF(mint(2).EQ.1) THEN
11521  mint(21)=isign(mint(55),mint(15))
11522  mint(22)=isign(kfanew,mint(16))
11523  ELSE
11524  mint(21)=isign(kfanew,mint(15))
11525  mint(22)=isign(mint(55),mint(16))
11526  js=2
11527  ENDIF
11528  kcc=22
11529 
11530  ELSEIF(isub.EQ.84) THEN
11531 C...g + gamma -> Q + Qbar; th arbitary
11532  kcs=(-1)**int(1.5d0+pyr(0))
11533  mint(21)=isign(mint(55),kcs)
11534  mint(22)=-mint(21)
11535  kcc=27
11536  IF(mint(16).EQ.21) kcc=28
11537 
11538  ELSEIF(isub.EQ.85) THEN
11539 C...gamma + gamma -> F + Fbar; th arbitary
11540  kcs=(-1)**int(1.5d0+pyr(0))
11541  mint(21)=isign(mint(56),kcs)
11542  mint(22)=-mint(21)
11543  kcc=21
11544 
11545  ELSEIF(isub.GE.86.AND.isub.LE.89) THEN
11546 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11547  mint(21)=kfpr(isub,1)
11548  mint(22)=kfpr(isub,2)
11549  kcc=24
11550  kcs=(-1)**int(1.5d0+pyr(0))
11551  ENDIF
11552 
11553  ELSEIF(isub.LE.100) THEN
11554  IF(isub.EQ.95) THEN
11555 C...Low-pT ( = energyless g + g -> g + g)
11556  kcc=mint(2)+12
11557  kcs=(-1)**int(1.5d0+pyr(0))
11558 
11559  ELSEIF(isub.EQ.96) THEN
11560 C...Multiple interactions (should be reassigned to QCD process)
11561  ENDIF
11562 
11563  ELSEIF(isub.LE.110) THEN
11564  IF(isub.EQ.101) THEN
11565 C...g + g -> gamma*/Z0
11566  kcc=21
11567  kfres=22
11568 
11569  ELSEIF(isub.EQ.102) THEN
11570 C...g + g -> h0 (or H0, or A0)
11571  kcc=21
11572  kfres=kfhigg
11573 
11574  ELSEIF(isub.EQ.103) THEN
11575 C...gamma + gamma -> h0 (or H0, or A0)
11576  kcc=21
11577  kfres=kfhigg
11578 
11579  ELSEIF(isub.EQ.104.OR.isub.EQ.105) THEN
11580 C...g + g -> chi_0c or chi_2c.
11581  kcc=21
11582  kfres=kfpr(isub,1)
11583 
11584  ELSEIF(isub.EQ.106) THEN
11585 C...g + g -> J/Psi + gamma
11586  mint(21)=kfpr(isub,1)
11587  mint(22)=kfpr(isub,2)
11588  kcc=21
11589 
11590  ELSEIF(isub.EQ.107) THEN
11591 C...g + gamma -> J/Psi + g
11592  mint(21)=kfpr(isub,1)
11593  mint(22)=kfpr(isub,2)
11594  kcc=22
11595  IF(mint(16).EQ.22) kcc=33
11596 
11597  ELSEIF(isub.EQ.108) THEN
11598 C...gamma + gamma -> J/Psi + gamma
11599  mint(21)=kfpr(isub,1)
11600  mint(22)=kfpr(isub,2)
11601 
11602  ELSEIF(isub.EQ.110) THEN
11603 C...f + fbar -> gamma + h0; th arbitrary
11604  IF(pyr(0).GT.0.5d0) js=2
11605  mint(20+js)=22
11606  mint(23-js)=kfhigg
11607  ENDIF
11608 
11609  ELSEIF(isub.LE.120) THEN
11610  IF(isub.EQ.111) THEN
11611 C...f + fbar -> g + h0; th arbitrary
11612  IF(pyr(0).GT.0.5d0) js=2
11613  mint(20+js)=21
11614  mint(23-js)=kfhigg
11615  kcc=17+js
11616 
11617  ELSEIF(isub.EQ.112) THEN
11618 C...f + g -> f + h0; th = (p(f) - p(f))**2
11619  IF(mint(15).EQ.21) js=2
11620  mint(23-js)=kfhigg
11621  kcc=15+js
11622  kcs=isign(1,mint(14+js))
11623 
11624  ELSEIF(isub.EQ.113) THEN
11625 C...g + g -> g + h0; th arbitrary
11626  IF(pyr(0).GT.0.5d0) js=2
11627  mint(23-js)=kfhigg
11628  kcc=22+js
11629  kcs=(-1)**int(1.5d0+pyr(0))
11630 
11631  ELSEIF(isub.EQ.114) THEN
11632 C...g + g -> gamma + gamma; th arbitrary
11633  IF(pyr(0).GT.0.5d0) js=2
11634  mint(21)=22
11635  mint(22)=22
11636  kcc=21
11637 
11638  ELSEIF(isub.EQ.115) THEN
11639 C...g + g -> g + gamma; th arbitrary
11640  IF(pyr(0).GT.0.5d0) js=2
11641  mint(23-js)=22
11642  kcc=22+js
11643  kcs=(-1)**int(1.5d0+pyr(0))
11644 
11645  ELSEIF(isub.EQ.116) THEN
11646 C...g + g -> gamma + Z0
11647 
11648  ELSEIF(isub.EQ.117) THEN
11649 C...g + g -> Z0 + Z0
11650 
11651  ELSEIF(isub.EQ.118) THEN
11652 C...g + g -> W+ + W-
11653  ENDIF
11654 
11655  ELSEIF(isub.LE.140) THEN
11656  IF(isub.EQ.121) THEN
11657 C...g + g -> Q + Qbar + h0
11658  kcs=(-1)**int(1.5d0+pyr(0))
11659  mint(21)=isign(kfpr(isubsv,2),kcs)
11660  mint(22)=-mint(21)
11661  kcc=11+int(0.5d0+pyr(0))
11662  kfres=kfhigg
11663 
11664  ELSEIF(isub.EQ.122) THEN
11665 C...q + qbar -> Q + Qbar + h0
11666  mint(21)=isign(kfpr(isubsv,2),mint(15))
11667  mint(22)=-mint(21)
11668  kcc=4
11669  kfres=kfhigg
11670 
11671  ELSEIF(isub.EQ.123) THEN
11672 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11673 C...inner process)
11674  kcc=22
11675  kfres=kfhigg
11676 
11677  ELSEIF(isub.EQ.124) THEN
11678 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11679 C...inner process)
11680  DO 430 jt=1,2
11681  i=mint(14+jt)
11682  ia=iabs(i)
11683  IF(ia.LE.10) THEN
11684  rvckm=vint(180+i)*pyr(0)
11685  DO 420 j=1,mstp(1)
11686  ib=2*j-1+mod(ia,2)
11687  ipm=(5-isign(1,i))/2
11688  idc=j+mdcy(ia,2)+2
11689  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 420
11690  mint(20+jt)=isign(ib,i)
11691  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11692  IF(rvckm.LE.0d0) goto 430
11693  420 CONTINUE
11694  ELSE
11695  ib=2*((ia+1)/2)-1+mod(ia,2)
11696  mint(20+jt)=isign(ib,i)
11697  ENDIF
11698  430 CONTINUE
11699  kcc=22
11700  kfres=kfhigg
11701 
11702  ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
11703 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11704  IF(mint(15).EQ.22) js=2
11705  mint(23-js)=21
11706  kcc=24+js
11707  kcs=isign(1,mint(14+js))
11708 
11709  ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
11710 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11711  IF(mint(15).EQ.22) js=2
11712  kcc=22
11713  kcs=isign(1,mint(14+js))
11714 
11715  ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
11716 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11717  kcs=(-1)**int(1.5d0+pyr(0))
11718  mint(21)=isign(kflf,kcs)
11719  mint(22)=-mint(21)
11720  kcc=27
11721  IF(mint(16).EQ.21) kcc=28
11722 
11723  ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
11724 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11725  kcs=(-1)**int(1.5d0+pyr(0))
11726  mint(21)=isign(kflf,kcs)
11727  mint(22)=-mint(21)
11728  kcc=21
11729 
11730  ENDIF
11731 
11732  ELSEIF(isub.LE.160) THEN
11733  IF(isub.EQ.141) THEN
11734 C...f + fbar -> gamma*/Z0/Z'0
11735  kfres=32
11736 
11737  ELSEIF(isub.EQ.142) THEN
11738 C...f + fbar' -> W'+/-
11739  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11740  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11741  kfres=isign(34,kch1+kch2)
11742 
11743  ELSEIF(isub.EQ.143) THEN
11744 C...f + fbar' -> H+/-
11745  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11746  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11747  kfres=isign(37,kch1+kch2)
11748 
11749  ELSEIF(isub.EQ.144) THEN
11750 C...f + fbar' -> R
11751  kfres=isign(41,mint(15)+mint(16))
11752 
11753  ELSEIF(isub.EQ.145) THEN
11754 C...q + l -> LQ (leptoquark)
11755  IF(iabs(mint(16)).LE.8) js=2
11756  kfres=isign(42,mint(14+js))
11757  kcc=28+js
11758  kcs=isign(1,mint(14+js))
11759 
11760  ELSEIF(isub.EQ.146) THEN
11761 C...e + gamma -> e* (excited lepton)
11762  IF(mint(15).EQ.22) js=2
11763  kfres=isign(kfpr(isub,1),mint(14+js))
11764  kcc=22
11765 
11766  ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
11767 C...q + g -> q* (excited quark)
11768  IF(mint(15).EQ.21) js=2
11769  kfres=isign(kfpr(isub,1),mint(14+js))
11770  kcc=30+js
11771  kcs=isign(1,mint(14+js))
11772 
11773  ELSEIF(isub.EQ.149) THEN
11774 C...g + g -> eta_tc
11775  kfres=ktechn+331
11776  kcc=23
11777  kcs=(-1)**int(1.5d0+pyr(0))
11778  ENDIF
11779 
11780  ELSEIF(isub.LE.200) THEN
11781  IF(isub.EQ.161) THEN
11782 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11783  IF(mint(15).EQ.21) js=2
11784  i=mint(14+js)
11785  ia=iabs(i)
11786  mint(23-js)=isign(37,kchg(ia,1)*i)
11787  ib=ia+mod(ia,2)-mod(ia+1,2)
11788  mint(20+js)=isign(ib,i)
11789  kcc=15+js
11790  kcs=isign(1,mint(14+js))
11791 
11792  ELSEIF(isub.EQ.162) THEN
11793 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11794  IF(mint(15).EQ.21) js=2
11795  mint(20+js)=isign(42,mint(14+js))
11796  kflql=kfdp(mdcy(42,2),2)
11797  mint(23-js)=-isign(kflql,mint(14+js))
11798  kcc=15+js
11799  kcs=isign(1,mint(14+js))
11800 
11801  ELSEIF(isub.EQ.163) THEN
11802 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11803  kcs=(-1)**int(1.5d0+pyr(0))
11804  mint(21)=isign(42,kcs)
11805  mint(22)=-mint(21)
11806  kcc=mint(2)+10
11807 
11808  ELSEIF(isub.EQ.164) THEN
11809 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11810  mint(21)=isign(42,mint(15))
11811  mint(22)=-mint(21)
11812  kcc=4
11813 
11814  ELSEIF(isub.EQ.165) THEN
11815 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11816  mint(21)=isign(kfpr(isub,1),mint(15))
11817  mint(22)=-mint(21)
11818 
11819  ELSEIF(isub.EQ.166) THEN
11820 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11821  IF(mod(mint(15),2).EQ.0) THEN
11822  mint(21)=isign(kfpr(isub,1)+1,mint(15))
11823  mint(22)=isign(kfpr(isub,1),mint(16))
11824  ELSE
11825  mint(21)=isign(kfpr(isub,1),mint(15))
11826  mint(22)=isign(kfpr(isub,1)+1,mint(16))
11827  ENDIF
11828 
11829  ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
11830 C...q + q' -> q" + q* (excited quark)
11831  kfqstr=kfpr(isub,2)
11832  kfqexc=mod(kfqstr,kexcit)
11833  js=mint(2)
11834  mint(20+js)=isign(kfqstr,mint(14+js))
11835  IF(iabs(mint(15)).NE.kfqexc.AND.iabs(mint(16)).NE.kfqexc)
11836  & mint(23-js)=isign(kfqexc,mint(17-js))
11837  kcc=22
11838  js=3-js
11839 
11840  ELSEIF(isub.EQ.169) THEN
11841 C...q + qbar -> e + e* (excited lepton)
11842  kfqstr=kfpr(isub,2)
11843  kfqexc=mod(kfqstr,kexcit)
11844  js=mint(2)
11845  mint(20+js)=isign(kfqstr,mint(14+js))
11846  mint(23-js)=isign(kfqexc,mint(17-js))
11847  js=3-js
11848 
11849  ELSEIF(isub.EQ.191) THEN
11850 C...f + fbar -> rho_tc0.
11851  kfres=ktechn+113
11852 
11853  ELSEIF(isub.EQ.192) THEN
11854 C...f + fbar' -> rho_tc+/-
11855  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11856  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11857  kfres=isign(ktechn+213,kch1+kch2)
11858 
11859  ELSEIF(isub.EQ.193) THEN
11860 C...f + fbar -> omega_tc0.
11861  kfres=ktechn+223
11862 
11863  ELSEIF(isub.EQ.194) THEN
11864 C...f + fbar -> f' + fbar' via mixture of s-channel
11865 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11866  mint(21)=isign(kfpr(isub,1),mint(15))
11867  mint(22)=-mint(21)
11868 
11869  ELSEIF(isub.EQ.195) THEN
11870 C...f + fbar' -> f'' + fbar''' via s-channel
11871 C...rho_tc+ th=(p(f)-p(f'))**2
11872 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11873  IF(mod(mint(15),2).EQ.0) THEN
11874  mint(21)=isign(kfpr(isub,1)+1,mint(15))
11875  mint(22)=isign(kfpr(isub,1),mint(16))
11876  ELSE
11877  mint(21)=isign(kfpr(isub,1),mint(15))
11878  mint(22)=isign(kfpr(isub,1)+1,mint(16))
11879  ENDIF
11880  ENDIF
11881 
11882 CMRENNA++
11883  ELSEIF(isub.LE.215) THEN
11884  IF(isub.EQ.201) THEN
11885 C...f + fbar -> ~e_L + ~e_Lbar
11886  mint(21)=isign(ksusy1+11,kcs)
11887  mint(22)=-mint(21)
11888 
11889  ELSEIF(isub.EQ.202) THEN
11890 C...f + fbar -> ~e_R + ~e_Rbar
11891  mint(21)=isign(ksusy2+11,kcs)
11892  mint(22)=-mint(21)
11893 
11894  ELSEIF(isub.EQ.203) THEN
11895 C...f + fbar -> ~e_L + ~e_Rbar
11896  IF(mint(15).LT.0) js=2
11897  IF(mint(2).EQ.1) THEN
11898  mint(20+js)=kfpr(isub,1)
11899  mint(23-js)=-kfpr(isub,2)
11900  ELSE
11901  mint(20+js)=-kfpr(isub,1)
11902  mint(23-js)=kfpr(isub,2)
11903  ENDIF
11904 
11905  ELSEIF(isub.EQ.204) THEN
11906 C...f + fbar -> ~mu_L + ~mu_Lbar
11907  mint(21)=isign(ksusy1+13,kcs)
11908  mint(22)=-mint(21)
11909 
11910  ELSEIF(isub.EQ.205) THEN
11911 C...f + fbar -> ~mu_R + ~mu_Rbar
11912  mint(21)=isign(ksusy2+13,kcs)
11913  mint(22)=-mint(21)
11914 
11915  ELSEIF(isub.EQ.206) THEN
11916 C...f + fbar -> ~mu_L + ~mu_Rbar
11917  IF(mint(15).LT.0) js=2
11918  IF(mint(2).EQ.1) THEN
11919  mint(20+js)=kfpr(isub,1)
11920  mint(23-js)=-kfpr(isub,2)
11921  ELSE
11922  mint(20+js)=-kfpr(isub,1)
11923  mint(23-js)=kfpr(isub,2)
11924  ENDIF
11925 
11926  ELSEIF(isub.EQ.207) THEN
11927 C...f + fbar -> ~tau_1 + ~tau_1bar
11928  mint(21)=isign(ksusy1+15,kcs)
11929  mint(22)=-mint(21)
11930 
11931  ELSEIF(isub.EQ.208) THEN
11932 C...f + fbar -> ~tau_2 + ~tau_2bar
11933  mint(21)=isign(ksusy2+15,kcs)
11934  mint(22)=-mint(21)
11935 
11936  ELSEIF(isub.EQ.209) THEN
11937 C...f + fbar -> ~tau_1 + ~tau_2bar
11938  IF(mint(15).LT.0) js=2
11939  IF(mint(2).EQ.1) THEN
11940  mint(20+js)=kfpr(isub,1)
11941  mint(23-js)=-kfpr(isub,2)
11942  ELSE
11943  mint(20+js)=-kfpr(isub,1)
11944  mint(23-js)=kfpr(isub,2)
11945  ENDIF
11946 
11947  ELSEIF(isub.EQ.210) THEN
11948 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11949  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11950  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11951  mint(21)=-isign(kfpr(isub,1),kch1+kch2)
11952  mint(22)=isign(kfpr(isub,2),kch1+kch2)
11953 
11954  ELSEIF(isub.EQ.211) THEN
11955 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11956  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11957  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11958  mint(21)=-isign(ksusy1+15,kch1+kch2)
11959  mint(22)=isign(ksusy1+16,kch1+kch2)
11960 
11961  ELSEIF(isub.EQ.212) THEN
11962 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11963  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11964  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11965  mint(21)=-isign(ksusy2+15,kch1+kch2)
11966  mint(22)=isign(ksusy1+16,kch1+kch2)
11967 
11968  ELSEIF(isub.EQ.213) THEN
11969 C...f + fbar -> ~nul + ~nulbar
11970  mint(21)=isign(kfpr(isub,1),kcs)
11971  mint(22)=-mint(21)
11972 
11973  ELSEIF(isub.EQ.214) THEN
11974 C...f + fbar -> ~nutau + ~nutaubar
11975  mint(21)=isign(ksusy1+16,kcs)
11976  mint(22)=-mint(21)
11977  ENDIF
11978 
11979  ELSEIF(isub.LE.225) THEN
11980  IF(isub.EQ.216) THEN
11981 C...f + fbar -> ~chi01 + ~chi01
11982  mint(21)=ksusy1+22
11983  mint(22)=ksusy1+22
11984 
11985  ELSEIF(isub.EQ.217) THEN
11986 C...f + fbar -> ~chi02 + ~chi02
11987  mint(21)=ksusy1+23
11988  mint(22)=ksusy1+23
11989 
11990  ELSEIF(isub.EQ.218 ) THEN
11991 C...f + fbar -> ~chi03 + ~chi03
11992  mint(21)=ksusy1+25
11993  mint(22)=ksusy1+25
11994 
11995  ELSEIF(isub.EQ.219 ) THEN
11996 C...f + fbar -> ~chi04 + ~chi04
11997  mint(21)=ksusy1+35
11998  mint(22)=ksusy1+35
11999 
12000  ELSEIF(isub.EQ.220 ) THEN
12001 C...f + fbar -> ~chi01 + ~chi02
12002  IF(mint(15).LT.0) js=2
12003 C IF(PYR(0).GT.0.5D0) JS=2
12004  mint(20+js)=ksusy1+22
12005  mint(23-js)=ksusy1+23
12006 
12007  ELSEIF(isub.EQ.221 ) THEN
12008 C...f + fbar -> ~chi01 + ~chi03
12009  IF(mint(15).LT.0) js=2
12010 C IF(PYR(0).GT.0.5D0) JS=2
12011  mint(20+js)=ksusy1+22
12012  mint(23-js)=ksusy1+25
12013 
12014  ELSEIF(isub.EQ.222) THEN
12015 C...f + fbar -> ~chi01 + ~chi04
12016  IF(mint(15).LT.0) js=2
12017 C IF(PYR(0).GT.0.5D0) JS=2
12018  mint(20+js)=ksusy1+22
12019  mint(23-js)=ksusy1+35
12020 
12021  ELSEIF(isub.EQ.223) THEN
12022 C...f + fbar -> ~chi02 + ~chi03
12023  IF(mint(15).LT.0) js=2
12024 C IF(PYR(0).GT.0.5D0) JS=2
12025  mint(20+js)=ksusy1+23
12026  mint(23-js)=ksusy1+25
12027 
12028  ELSEIF(isub.EQ.224) THEN
12029 C...f + fbar -> ~chi02 + ~chi04
12030  IF(mint(15).LT.0) js=2
12031 C IF(PYR(0).GT.0.5D0) JS=2
12032  mint(20+js)=ksusy1+23
12033  mint(23-js)=ksusy1+35
12034 
12035  ELSEIF(isub.EQ.225) THEN
12036 C...f + fbar -> ~chi03 + ~chi04
12037  IF(mint(15).LT.0) js=2
12038 C IF(PYR(0).GT.0.5D0) JS=2
12039  mint(20+js)=ksusy1+25
12040  mint(23-js)=ksusy1+35
12041  ENDIF
12042 
12043  ELSEIF(isub.LE.236) THEN
12044  IF(isub.EQ.226) THEN
12045 C...f + fbar -> ~chi+-1 + ~chi-+1
12046 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
12047  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12048  mint(21)=isign(ksusy1+24,kch1)
12049  mint(22)=-mint(21)
12050 
12051  ELSEIF(isub.EQ.227) THEN
12052 C...f + fbar -> ~chi+-2 + ~chi-+2
12053  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12054  mint(21)=isign(ksusy1+37,kch1)
12055  mint(22)=-mint(21)
12056 
12057  ELSEIF(isub.EQ.228) THEN
12058 C...f + fbar -> ~chi+-1 + ~chi-+2
12059 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
12060 C...js=1 if pyr<.5, js=2 if pyr>.5
12061 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
12062 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
12063 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
12064 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
12065  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12066  kch2=int(1-kch1)/2
12067  IF(mint(2).EQ.1) THEN
12068  mint(21)= isign(ksusy1+24,kch1)
12069  mint(22)= -isign(ksusy1+37,kch1)
12070 c IF(KCH2.EQ.0) JS=2
12071  ELSE
12072  mint(21)= isign(ksusy1+37,kch1)
12073  mint(22)= -isign(ksusy1+24,kch1)
12074  js=2
12075 c IF(KCH2.EQ.1) JS=2
12076  ENDIF
12077 
12078  ELSEIF(isub.EQ.229) THEN
12079 C...q + qbar' -> ~chi01 + ~chi+-1
12080 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
12081  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12082  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12083 C...CHECK THIS
12084  IF(mod(mint(15),2).EQ.0) js=2
12085  mint(20+js)=ksusy1+22
12086  mint(23-js)=isign(ksusy1+24,kch1+kch2)
12087 
12088  ELSEIF(isub.EQ.230) THEN
12089 C...q + qbar' -> ~chi02 + ~chi+-1
12090  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12091  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12092  IF(mod(mint(15),2).EQ.0) js=2
12093  mint(20+js)=ksusy1+23
12094  mint(23-js)=isign(ksusy1+24,kch1+kch2)
12095 
12096  ELSEIF(isub.EQ.231) THEN
12097 C...q + qbar' -> ~chi03 + ~chi+-1
12098  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12099  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12100  IF(mod(mint(15),2).EQ.0) js=2
12101  mint(20+js)=ksusy1+25
12102  mint(23-js)=isign(ksusy1+24,kch1+kch2)
12103 
12104  ELSEIF(isub.EQ.232) THEN
12105 C...q + qbar' -> ~chi04 + ~chi+-1
12106  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12107  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12108  IF(mod(mint(15),2).EQ.0) js=2
12109  mint(20+js)=ksusy1+35
12110  mint(23-js)=isign(ksusy1+24,kch1+kch2)
12111 
12112  ELSEIF(isub.EQ.233) THEN
12113 C...q + qbar' -> ~chi01 + ~chi+-2
12114  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12115  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12116  IF(mod(mint(15),2).EQ.0) js=2
12117  mint(20+js)=ksusy1+22
12118  mint(23-js)=isign(ksusy1+37,kch1+kch2)
12119 
12120  ELSEIF(isub.EQ.234) THEN
12121 C...q + qbar' -> ~chi02 + ~chi+-2
12122  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12123  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12124  IF(mod(mint(15),2).EQ.0) js=2
12125  mint(20+js)=ksusy1+23
12126  mint(23-js)=isign(ksusy1+37,kch1+kch2)
12127 
12128  ELSEIF(isub.EQ.235) THEN
12129 C...q + qbar' -> ~chi03 + ~chi+-2
12130  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12131  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12132  IF(mod(mint(15),2).EQ.0) js=2
12133  mint(20+js)=ksusy1+25
12134  mint(23-js)=isign(ksusy1+37,kch1+kch2)
12135 
12136  ELSEIF(isub.EQ.236) THEN
12137 C...q + qbar' -> ~chi04 + ~chi+-2
12138  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12139  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12140  IF(mod(mint(15),2).EQ.0) js=2
12141  mint(20+js)=ksusy1+35
12142  mint(23-js)=isign(ksusy1+37,kch1+kch2)
12143  ENDIF
12144 
12145  ELSEIF(isub.LE.245) THEN
12146  IF(isub.EQ.237) THEN
12147 C...q + qbar -> ~chi01 + ~g
12148 C...th arbitrary
12149  IF(pyr(0).GT.0.5d0) js=2
12150  mint(20+js)=ksusy1+21
12151  mint(23-js)=ksusy1+22
12152  kcc=17+js
12153 
12154  ELSEIF(isub.EQ.238) THEN
12155 C...q + qbar -> ~chi02 + ~g
12156 C...th arbitrary
12157  IF(pyr(0).GT.0.5d0) js=2
12158  mint(20+js)=ksusy1+21
12159  mint(23-js)=ksusy1+23
12160  kcc=17+js
12161 
12162  ELSEIF(isub.EQ.239) THEN
12163 C...q + qbar -> ~chi03 + ~g
12164 C...th arbitrary
12165  IF(pyr(0).GT.0.5d0) js=2
12166  mint(20+js)=ksusy1+21
12167  mint(23-js)=ksusy1+25
12168  kcc=17+js
12169 
12170  ELSEIF(isub.EQ.240) THEN
12171 C...q + qbar -> ~chi04 + ~g
12172 C...th arbitrary
12173  IF(pyr(0).GT.0.5d0) js=2
12174  mint(20+js)=ksusy1+21
12175  mint(23-js)=ksusy1+35
12176  kcc=17+js
12177 
12178  ELSEIF(isub.EQ.241) THEN
12179 C...q + qbar' -> ~chi+-1 + ~g
12180 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12181 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12182 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12183 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12184 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12185  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12186  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12187  js=1
12188  IF(mint(15)*(kch1+kch2).GT.0) js=2
12189  mint(20+js)=ksusy1+21
12190  mint(23-js)=isign(ksusy1+24,kch1+kch2)
12191  kcc=17+js
12192 
12193  ELSEIF(isub.EQ.242) THEN
12194 C...q + qbar' -> ~chi+-2 + ~g
12195 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12196 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12197 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12198 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12199 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12200  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12201  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12202  js=1
12203  IF(mint(15)*(kch1+kch2).GT.0) js=2
12204  mint(20+js)=ksusy1+21
12205  mint(23-js)=isign(ksusy1+37,kch1+kch2)
12206  kcc=17+js
12207 
12208  ELSEIF(isub.EQ.243) THEN
12209 C...q + qbar -> ~g + ~g ; th arbitrary
12210  mint(21)=ksusy1+21
12211  mint(22)=ksusy1+21
12212  kcc=mint(2)+4
12213 
12214  ELSEIF(isub.EQ.244) THEN
12215 C...g + g -> ~g + ~g ; th arbitrary
12216  kcc=mint(2)+12
12217  kcs=(-1)**int(1.5d0+pyr(0))
12218  mint(21)=ksusy1+21
12219  mint(22)=ksusy1+21
12220  ENDIF
12221 
12222  ELSEIF(isub.LE.260) THEN
12223  IF(isub.EQ.246) THEN
12224 C...qj + g -> ~qj_L + ~chi01
12225  IF(mint(15).EQ.21) js=2
12226  i=mint(14+js)
12227  ia=iabs(i)
12228  mint(20+js)=isign(ksusy1+ia,i)
12229  mint(23-js)=ksusy1+22
12230  kcc=15+js
12231  kcs=isign(1,mint(14+js))
12232 
12233  ELSEIF(isub.EQ.247) THEN
12234 C...qj + g -> ~qj_R + ~chi01
12235  IF(mint(15).EQ.21) js=2
12236  i=mint(14+js)
12237  ia=iabs(i)
12238  mint(20+js)=isign(ksusy2+ia,i)
12239  mint(23-js)=ksusy1+22
12240  kcc=15+js
12241  kcs=isign(1,mint(14+js))
12242 
12243  ELSEIF(isub.EQ.248) THEN
12244 C...qj + g -> ~qj_L + ~chi02
12245  IF(mint(15).EQ.21) js=2
12246  i=mint(14+js)
12247  ia=iabs(i)
12248  mint(20+js)=isign(ksusy1+ia,i)
12249  mint(23-js)=ksusy1+23
12250  kcc=15+js
12251  kcs=isign(1,mint(14+js))
12252 
12253  ELSEIF(isub.EQ.249) THEN
12254 C...qj + g -> ~qj_R + ~chi02
12255  IF(mint(15).EQ.21) js=2
12256  i=mint(14+js)
12257  ia=iabs(i)
12258  mint(20+js)=isign(ksusy2+ia,i)
12259  mint(23-js)=ksusy1+23
12260  kcc=15+js
12261  kcs=isign(1,mint(14+js))
12262 
12263  ELSEIF(isub.EQ.250) THEN
12264 C...qj + g -> ~qj_L + ~chi03
12265  IF(mint(15).EQ.21) js=2
12266  i=mint(14+js)
12267  ia=iabs(i)
12268  mint(20+js)=isign(ksusy1+ia,i)
12269  mint(23-js)=ksusy1+25
12270  kcc=15+js
12271  kcs=isign(1,mint(14+js))
12272 
12273  ELSEIF(isub.EQ.251) THEN
12274 C...qj + g -> ~qj_R + ~chi03
12275  IF(mint(15).EQ.21) js=2
12276  i=mint(14+js)
12277  ia=iabs(i)
12278  mint(20+js)=isign(ksusy2+ia,i)
12279  mint(23-js)=ksusy1+25
12280  kcc=15+js
12281  kcs=isign(1,mint(14+js))
12282 
12283  ELSEIF(isub.EQ.252) THEN
12284 C...qj + g -> ~qj_L + ~chi04
12285  IF(mint(15).EQ.21) js=2
12286  i=mint(14+js)
12287  ia=iabs(i)
12288  mint(20+js)=isign(ksusy1+ia,i)
12289  mint(23-js)=ksusy1+35
12290  kcc=15+js
12291  kcs=isign(1,mint(14+js))
12292 
12293  ELSEIF(isub.EQ.253) THEN
12294 C...qj + g -> ~qj_R + ~chi04
12295  IF(mint(15).EQ.21) js=2
12296  i=mint(14+js)
12297  ia=iabs(i)
12298  mint(20+js)=isign(ksusy2+ia,i)
12299  mint(23-js)=ksusy1+35
12300  kcc=15+js
12301  kcs=isign(1,mint(14+js))
12302 
12303  ELSEIF(isub.EQ.254) THEN
12304 C...qj + g -> ~qk_L + ~chi+-1
12305  IF(mint(15).EQ.21) js=2
12306  i=mint(14+js)
12307  ia=iabs(i)
12308  mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
12309  ib=-ia+int((ia+1)/2)*4-1
12310  mint(20+js)=isign(ksusy1+ib,i)
12311  kcc=15+js
12312  kcs=isign(1,mint(14+js))
12313 
12314  ELSEIF(isub.EQ.255) THEN
12315 C...qj + g -> ~qk_L + ~chi+-1
12316  IF(mint(15).EQ.21) js=2
12317  i=mint(14+js)
12318  ia=iabs(i)
12319  mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
12320  ib=-ia+int((ia+1)/2)*4-1
12321  mint(20+js)=isign(ksusy2+ib,i)
12322  kcc=15+js
12323  kcs=isign(1,mint(14+js))
12324 
12325  ELSEIF(isub.EQ.256) THEN
12326 C...qj + g -> ~qk_L + ~chi+-2
12327  IF(mint(15).EQ.21) js=2
12328  i=mint(14+js)
12329  ia=iabs(i)
12330  ib=-ia+int((ia+1)/2)*4-1
12331  mint(20+js)=isign(ksusy1+ib,i)
12332  mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
12333  kcc=15+js
12334  kcs=isign(1,mint(14+js))
12335 
12336  ELSEIF(isub.EQ.257) THEN
12337 C...qj + g -> ~qk_R + ~chi+-2
12338  IF(mint(15).EQ.21) js=2
12339  i=mint(14+js)
12340  ia=iabs(i)
12341  ib=-ia+int((ia+1)/2)*4-1
12342  mint(20+js)=isign(ksusy2+ib,i)
12343  mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
12344  kcc=15+js
12345  kcs=isign(1,mint(14+js))
12346 
12347  ELSEIF(isub.EQ.258) THEN
12348 C...qj + g -> ~qj_L + ~g
12349  IF(mint(15).EQ.21) js=2
12350  i=mint(14+js)
12351  ia=iabs(i)
12352  mint(20+js)=isign(ksusy1+ia,i)
12353  mint(23-js)=ksusy1+21
12354  kcc=mint(2)+6
12355  IF(js.EQ.2) kcc=kcc+2
12356  kcs=isign(1,i)
12357 
12358  ELSEIF(isub.EQ.259) THEN
12359 C...qj + g -> ~qj_R + ~g
12360  IF(mint(15).EQ.21) js=2
12361  i=mint(14+js)
12362  ia=iabs(i)
12363  mint(20+js)=isign(ksusy2+ia,i)
12364  mint(23-js)=ksusy1+21
12365  kcc=mint(2)+6
12366  IF(js.EQ.2) kcc=kcc+2
12367  kcs=isign(1,i)
12368  ENDIF
12369 
12370  ELSEIF(isub.LE.270) THEN
12371  IF(isub.EQ.261) THEN
12372 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12373  isgn=1
12374  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12375  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12376  mint(22)=-mint(21)
12377 C...Correct color combination
12378  IF(mint(43).EQ.4) kcc=4
12379 
12380  ELSEIF(isub.EQ.262) THEN
12381 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12382  isgn=1
12383  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12384  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12385  mint(22)=-mint(21)
12386 C...Correct color combination
12387  IF(mint(43).EQ.4) kcc=4
12388 
12389  ELSEIF(isub.EQ.263) THEN
12390 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12391  IF((kcs.GT.0.AND.mint(2).EQ.1).OR.
12392  & (kcs.LT.0.AND.mint(2).EQ.2)) THEN
12393  mint(21)=isign(kfpr(isub,1),kcs)
12394  mint(22)=-isign(kfpr(isub,2),kcs)
12395  ELSE
12396  js=2
12397  mint(21)=isign(kfpr(isub,2),kcs)
12398  mint(22)=-isign(kfpr(isub,1),kcs)
12399  ENDIF
12400 C...Correct color combination
12401  IF(mint(43).EQ.4) kcc=4
12402 
12403  ELSEIF(isub.EQ.264) THEN
12404 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12405  kcs=(-1)**int(1.5d0+pyr(0))
12406  mint(21)=isign(kfpr(isub,1),kcs)
12407  mint(22)=-mint(21)
12408  kcc=mint(2)+10
12409 
12410  ELSEIF(isub.EQ.265) THEN
12411 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12412  kcs=(-1)**int(1.5d0+pyr(0))
12413  mint(21)=isign(kfpr(isub,1),kcs)
12414  mint(22)=-mint(21)
12415  kcc=mint(2)+10
12416  ENDIF
12417 
12418  ELSEIF(isub.LE.301) THEN
12419  IF(isub.EQ.271.OR.isub.EQ.281.OR.isub.EQ.291) THEN
12420 C...qi + qj -> ~qi_L + ~qj_L
12421  kcc=mint(2)
12422  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12423  mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
12424  mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
12425 
12426  ELSEIF(isub.EQ.272.OR.isub.EQ.282.OR.isub.EQ.292) THEN
12427 C...qi + qj -> ~qi_R + ~qj_R
12428  kcc=mint(2)
12429  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12430  mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
12431  mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
12432 
12433  ELSEIF(isub.EQ.273.OR.isub.EQ.283.OR.isub.EQ.293) THEN
12434 C...qi + qj -> ~qi_L + ~qj_R
12435  mint(21)=isign(kfpr(isub,1),mint(15))
12436  mint(22)=isign(kfpr(isub,2),mint(16))
12437  kcc=mint(2)
12438  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12439 
12440  ELSEIF(isub.EQ.274.OR.isub.EQ.284) THEN
12441 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12442  mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
12443  mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
12444  kcc=mint(2)
12445  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12446 
12447  ELSEIF(isub.EQ.275.OR.isub.EQ.285) THEN
12448 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12449  mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
12450  mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
12451  kcc=mint(2)
12452  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12453 
12454  ELSEIF(isub.EQ.276.OR.isub.EQ.286.OR.isub.EQ.296) THEN
12455 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12456  mint(21)=isign(kfpr(isub,1),mint(15))
12457  mint(22)=isign(kfpr(isub,2),mint(16))
12458  kcc=mint(2)
12459  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12460 
12461  ELSEIF(isub.EQ.277.OR.isub.EQ.287) THEN
12462 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12463  isgn=1
12464  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12465  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12466  mint(22)=-mint(21)
12467  IF(mint(43).EQ.4) kcc=4
12468 
12469  ELSEIF(isub.EQ.278.OR.isub.EQ.288) THEN
12470 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12471  isgn=1
12472  IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12473  mint(21)=isgn*isign(kfpr(isub,1),kcs)
12474  mint(22)=-mint(21)
12475  IF(mint(43).EQ.4) kcc=4
12476 
12477  ELSEIF(isub.EQ.279.OR.isub.EQ.289) THEN
12478 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12479 C...pure LL + RR
12480  kcs=(-1)**int(1.5d0+pyr(0))
12481  mint(21)=isign(kfpr(isub,1),kcs)
12482  mint(22)=-mint(21)
12483  kcc=mint(2)+10
12484 
12485  ELSEIF(isub.EQ.280.OR.isub.EQ.290) THEN
12486 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12487  kcs=(-1)**int(1.5d0+pyr(0))
12488  mint(21)=isign(kfpr(isub,1),kcs)
12489  mint(22)=-mint(21)
12490  kcc=mint(2)+10
12491 
12492  ELSEIF(isub.EQ.294) THEN
12493 C...qj + g -> ~qj_L + ~g
12494  IF(mint(15).EQ.21) js=2
12495  i=mint(14+js)
12496  ia=iabs(i)
12497  mint(20+js)=isign(ksusy1+ia,i)
12498  mint(23-js)=ksusy1+21
12499  kcc=mint(2)+6
12500  IF(js.EQ.2) kcc=kcc+2
12501  kcs=isign(1,i)
12502 
12503  ELSEIF(isub.EQ.295) THEN
12504 C...qj + g -> ~qj_R + ~g
12505  IF(mint(15).EQ.21) js=2
12506  i=mint(14+js)
12507  ia=iabs(i)
12508  mint(20+js)=isign(ksusy2+ia,i)
12509  mint(23-js)=ksusy1+21
12510  kcc=mint(2)+6
12511  IF(js.EQ.2) kcc=kcc+2
12512  kcs=isign(1,i)
12513 
12514  ELSEIF(isub.EQ.297.OR.isub.EQ.298) THEN
12515 C...q + qbar' -> H+ + H0
12516  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12517  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12518  IF(mint(15)*(kch1+kch2).GT.0) js=2
12519  mint(20+js)=isign(37,kch1+kch2)
12520  mint(23-js)=kfpr(isub,2)
12521  ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
12522 C...f + fbar -> A0 + H0; th arbitrary
12523  IF(pyr(0).GT.0.5d0) js=2
12524  mint(20+js)=kfpr(isub,1)
12525  mint(23-js)=kfpr(isub,2)
12526  ELSEIF(isub.EQ.301) THEN
12527 C...f + fbar -> H+ H-
12528  mint(21)=isign(kfpr(isub,1),kcs)
12529  mint(22)=-mint(21)
12530  ENDIF
12531 CMRENNA--
12532  ELSEIF(isub.LE.330) THEN
12533  IF(isub.EQ.311)THEN
12534 C...g + g -> g* + g* (UED)
12535  kcc=mint(2)+12
12536  kcs=(-1)**int(1.5d0+pyr(0))
12537  mued(1)=472
12538  mued(2)=472
12539  mint(21)=iuedeq(472)
12540  mint(22)=iuedeq(472)
12541  ELSEIF(isub.EQ.312)THEN
12542 C...q + g -> q*_D + g*, q*_S + g*
12543 C...The two channels have the same cross section
12544  kkflmi=450
12545  IF(pyr(0).GT.0.5)kkflmi=456
12546  IF(mint(15).EQ.21) js=2
12547  kcc=mint(2)+6
12548  IF(mint(15).EQ.21)kcc=kcc+2
12549  IF(mint(15).NE.21)THEN
12550  kcs=isign(1,mint(15))
12551  mued(2)=472
12552  mued(1)=kcs*(kkflmi+iabs(mint(15)))
12553  mint(22)=iuedeq(472)
12554  mint(21)=kcs*iuedeq(kkflmi+iabs(mint(15)))
12555  ENDIF
12556  IF(mint(16).NE.21)THEN
12557  kcs=isign(1,mint(16))
12558  mued(2)=kcs*(kkflmi+iabs(mint(16)))
12559  mued(1)=472
12560  mint(22)=kcs*iuedeq(kkflmi+iabs(mint(16)))
12561  mint(21)=iuedeq(472)
12562  ENDIF
12563  ELSEIF(isub.EQ.313)THEN
12564 C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12565 C...The two channels have the same cross section
12566  kkflmi=450
12567  IF(pyr(0).GT.0.5)kkflmi=456
12568  kcc=mint(2)
12569  IF(mint(15).EQ.mint(16))THEN
12570  mued(1)=sign(1,mint(15))*(kkflmi+iabs(mint(15)))
12571  mued(2)=mint(21)
12572  mint(21)=sign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12573  mint(22)=mint(21)
12574  ELSE
12575  mued(1)=sign(1,mint(15))*(kkflmi+iabs(mint(15)))
12576  mued(2)=sign(1,mint(16))*(kkflmi+iabs(mint(16)))
12577  mint(21)=sign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12578  mint(22)=sign(1,mint(16))*iuedeq(kkflmi+iabs(mint(16)))
12579  ENDIF
12580  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12581  ELSEIF(isub.EQ.314)THEN
12582 C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12583 C...The two channels have the same cross section
12584  kkflmi=450
12585  IF(pyr(0).GT.0.5)kkflmi=456
12586  kcs=(-1)**int(1.5d0+pyr(0))
12587  xflaout=pyr(0)
12588  IF(xflaout.LE.0.2)THEN
12589  mued(1)=isign(1,kcs)*(kkflmi+1)
12590  mint(21)=isign(1,kcs)*iuedeq(kkflmi+1)
12591  ELSEIF(xflaout.LE.0.4)THEN
12592  mued(1)=isign(1,kcs)*(kkflmi+2)
12593  mint(21)=isign(1,kcs)*iuedeq(kkflmi+2)
12594  ELSEIF(xflaout.LE.0.6)THEN
12595  mued(1)=isign(1,kcs)*(kkflmi+3)
12596  mint(21)=isign(1,kcs)*iuedeq(kkflmi+3)
12597  ELSEIF(xflaout.LE.0.8)THEN
12598  mued(1)=isign(1,kcs)*(kkflmi+4)
12599  mint(21)=isign(1,kcs)*iuedeq(kkflmi+4)
12600  ELSE
12601  mued(1)=isign(1,kcs)*(kkflmi+5)
12602  mint(21)=isign(1,kcs)*iuedeq(kkflmi+5)
12603  ENDIF
12604  mint(22)=-mint(21)
12605  mued(2)=-mued(1)
12606  kcc=mint(2)+10
12607  ELSEIF(isub.EQ.315)THEN
12608 C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12609 C...The two channels have the same cross section
12610  kkflmi=450
12611  IF(pyr(0).GT.0.5)kkflmi=456
12612  mued(1)=isign(1,mint(15))*(kkflmi+iabs(mint(15)))
12613  mued(2)=-mint(21)
12614  mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12615  mint(22)=-mint(21)
12616  kcc=4
12617  ELSEIF(isub.EQ.316)THEN
12618 C...q + qbar' -> q*_D + q*_S_bar'
12619  mued(1)=isign(1,mint(15))*(456+iabs(mint(15)))
12620  mued(2)=isign(1,mint(16))*(450+iabs(mint(16)))
12621  mint(21)=isign(1,mint(15))*iuedeq(456+iabs(mint(15)))
12622  mint(22)=isign(1,mint(16))*iuedeq(450+iabs(mint(16)))
12623  kcc=mint(2)+2
12624  ELSEIF(isub.EQ.317)THEN
12625 C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12626 C...The two channels have the same cross section
12627  kkflmi=450
12628  IF(pyr(0).GT.0.5)kkflmi=456
12629  mued(1)=isign(1,mint(15))*(kkflmi+iabs(mint(15)))
12630  mued(2)=isign(1,mint(16))*(kkflmi+iabs(mint(16)))
12631  mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12632  mint(22)=isign(1,mint(16))*iuedeq(kkflmi+iabs(mint(16)))
12633  kcc=mint(2)+2
12634  ELSEIF(isub.EQ.318)THEN
12635 C...q + q' -> q*_D + q*_S'
12636  kcc=mint(2)
12637  mued(1)=sign(1,mint(15))*(456+iabs(mint(15)))
12638  mued(2)=sign(1,mint(16))*(450+iabs(mint(16)))
12639  mint(21)=sign(1,mint(15))*iuedeq(456+iabs(mint(15)))
12640  mint(22)=sign(1,mint(16))*iuedeq(450+iabs(mint(16)))
12641  ELSEIF(isub.EQ.319)THEN
12642 C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12643 C...The two channels have the same cross section
12644  kkflmi=450
12645  IF(pyr(0).GT.0.5)kkflmi=456
12646  xflaout=pyr(0)
12647  iiflav=0
12648 C...N.B. NFLAVOURS=IUED(3)
12649 C DO I=1,NFLAVOURS
12650  DO 433 i=1,iued(3)
12651  IF(i.NE.iabs(mint(15)))THEN
12652  iiflav=iiflav+1
12653  iokfla(iiflav)=i
12654  ENDIF
12655  433 CONTINUE
12656  flastep=1./(iued(3)-1)
12657  DO i=1,iued(3)-1
12658  flavv=flastep*i
12659  IF(xflaout.LE.flavv)THEN
12660  mued(1)=isign(1,mint(15))*(kkflmi+iokfla(i))
12661  mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iokfla(i))
12662  goto 435
12663  ENDIF
12664  ENDDO
12665  435 CONTINUE
12666  IF(iabs(mued(1)).LT.451.AND.iabs(mued(1)).GT.462)THEN
12667  WRITE(mstu(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12668  CALL pystop(5000000)
12669  ENDIF
12670  mint(22)=-mint(21)
12671  kcc=4
12672  ENDIF
12673 
12674  ELSEIF(isub.LE.360) THEN
12675 
12676  IF(isub.EQ.341.OR.isub.EQ.342) THEN
12677 C...l + l -> H_L++/--, H_R++/--
12678  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12679  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12680  kfres=isign(kfpr(isub,1),kch1+kch2)
12681 
12682  ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
12683 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12684  IF(mint(15).EQ.22) js=2
12685  mint(20+js)=isign(kfpr(isub,1),-mint(14+js))
12686  mint(23-js)=isign(kfpr(isub,2),-mint(14+js))
12687  kcc=22
12688 
12689  ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
12690 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12691  mint(21)=-isign(kfpr(isub,1),mint(15))
12692  mint(22)=-mint(21)
12693 
12694  ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
12695 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12696 C...as inner process).
12697  DO 450 jt=1,2
12698  i=mint(14+jt)
12699  ia=iabs(i)
12700  IF(ia.LE.10) THEN
12701  rvckm=vint(180+i)*pyr(0)
12702  DO 440 j=1,mstp(1)
12703  ib=2*j-1+mod(ia,2)
12704  ipm=(5-isign(1,i))/2
12705  idc=j+mdcy(ia,2)+2
12706  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 440
12707  mint(20+jt)=isign(ib,i)
12708  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
12709  IF(rvckm.LE.0d0) goto 450
12710  440 CONTINUE
12711  ELSE
12712  ib=2*((ia+1)/2)-1+mod(ia,2)
12713  mint(20+jt)=isign(ib,i)
12714  ENDIF
12715  450 CONTINUE
12716  kcc=22
12717  kfres=isign(kfpr(isub,1),mint(15))
12718  IF(mod(mint(15),2).EQ.1) kfres=-kfres
12719 
12720  ELSEIF(isub.EQ.353) THEN
12721 C...f + fbar -> Z_R0
12722  kfres=kfpr(isub,1)
12723 
12724  ELSEIF(isub.EQ.354) THEN
12725 C...f + fbar' -> W+/-
12726  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12727  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12728  kfres=isign(kfpr(isub,1),kch1+kch2)
12729 
12730  ENDIF
12731 
12732  ELSEIF(isub.LE.380) THEN
12733 
12734  IF(isub.LE.363.OR.isub.EQ.368) THEN
12735 C...f + fbar -> charged+ charged- technicolor
12736  ksw=(-1)**int(1.5d0+pyr(0))
12737  mint(21)=isign(kfpr(isub,1),ksw)
12738  mint(22)=-isign(kfpr(isub,2),ksw)
12739 
12740  ELSEIF(isub.LE.367.OR.isub.EQ.379.OR.isub.EQ.380) THEN
12741 C...f + fbar -> neutral neutral technicolor
12742  mint(21)=kfpr(isub,1)
12743  mint(22)=kfpr(isub,2)
12744 
12745  ELSEIF(isub.EQ.374.OR.isub.EQ.375.OR.isub.EQ.378) THEN
12746 C...f + fbar' -> neutral charged technicolor
12747  in=1
12748  ic=2
12749  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12750  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12751  IF(mint(15)*(kch1+kch2).LT.0) js=2
12752  mint(23-js)=isign(kfpr(isub,ic),kch1+kch2)
12753  mint(20+js)=kfpr(isub,in)
12754 
12755  ELSEIF(isub.GE.370.AND.isub.LE.377) THEN
12756 C...f + fbar' -> charged neutral technicolor
12757  in=2
12758  ic=1
12759  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12760  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12761  IF(mint(15)*(kch1+kch2).GT.0) js=2
12762  mint(20+js)=isign(kfpr(isub,ic),kch1+kch2)
12763  mint(23-js)=kfpr(isub,in)
12764  ENDIF
12765 
12766  ELSEIF(isub.LE.400) THEN
12767  IF(isub.EQ.381) THEN
12768 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12769  kcc=mint(2)
12770  IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12771 
12772  ELSEIF(isub.EQ.382) THEN
12773 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12774  mint(21)=isign(kflf,mint(15))
12775  mint(22)=-mint(21)
12776  kcc=4
12777 
12778  ELSEIF(isub.EQ.383) THEN
12779 C...f + fbar -> g + g; th arbitrary, TC extensions
12780  mint(21)=21
12781  mint(22)=21
12782  kcc=mint(2)+4
12783 
12784  ELSEIF(isub.EQ.384) THEN
12785 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12786  IF(mint(15).EQ.21) js=2
12787  kcc=mint(2)+6
12788  IF(mint(15).EQ.21) kcc=kcc+2
12789  IF(mint(15).NE.21) kcs=isign(1,mint(15))
12790  IF(mint(16).NE.21) kcs=isign(1,mint(16))
12791 
12792  ELSEIF(isub.EQ.385) THEN
12793 C...g + g -> f + fbar; th arbitrary, TC extensions
12794  kcs=(-1)**int(1.5d0+pyr(0))
12795  mint(21)=isign(kflf,kcs)
12796  mint(22)=-mint(21)
12797  kcc=mint(2)+10
12798 
12799  ELSEIF(isub.EQ.386) THEN
12800 C...g + g -> g + g; th arbitrary, TC extensions
12801  kcc=mint(2)+12
12802  kcs=(-1)**int(1.5d0+pyr(0))
12803 
12804  ELSEIF(isub.EQ.387) THEN
12805 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12806  mint(21)=isign(mint(55),mint(15))
12807  mint(22)=-mint(21)
12808  kcc=4
12809 
12810  ELSEIF(isub.EQ.388) THEN
12811 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12812  kcs=(-1)**int(1.5d0+pyr(0))
12813  mint(21)=isign(mint(55),kcs)
12814  mint(22)=-mint(21)
12815  kcc=mint(2)+10
12816 
12817  ELSEIF(isub.EQ.391) THEN
12818 C...f + fbar -> G*.
12819  kfres=kfpr(isub,1)
12820 
12821  ELSEIF(isub.EQ.392) THEN
12822 C...g + g -> G*.
12823  kcc=21
12824  kfres=kfpr(isub,1)
12825 
12826  ELSEIF(isub.EQ.393) THEN
12827 C...q + qbar -> g + G*; th arbitrary.
12828  IF(pyr(0).GT.0.5d0) js=2
12829  mint(20+js)=kfpr(isub,1)
12830  mint(23-js)=kfpr(isub,2)
12831  kcc=17+js
12832 
12833  ELSEIF(isub.EQ.394) THEN
12834 C...q + g -> q + G*; th = (p(f) - p(f))**2
12835  IF(mint(15).EQ.21) js=2
12836  mint(23-js)=kfpr(isub,2)
12837  kcc=15+js
12838  kcs=isign(1,mint(14+js))
12839 
12840  ELSEIF(isub.EQ.395) THEN
12841 C...g + g -> G* + g; th arbitrary.
12842  IF(pyr(0).GT.0.5d0) js=2
12843  mint(23-js)=kfpr(isub,2)
12844  kcc=22+js
12845  ENDIF
12846 
12847  ELSEIF(isub.LE.420) THEN
12848  IF(isub.EQ.401) THEN
12849 C...g + g -> t + b + H+/-
12850  kcs=(-1)**int(1.5d0+pyr(0))
12851  mint(21)=isign(kfpr(isubsv,2),kcs)
12852  mint(22)=isign(5,-kcs)
12853  kcc=11+int(0.5d0+pyr(0))
12854  kfres=isign(kfhigg,-kcs)
12855 
12856  ELSEIF(isub.EQ.402) THEN
12857 C...q + qbar -> t + b + H+/-
12858  kfl=(-1)**int(1.5d0+pyr(0))
12859  mint(21)=isign(int(6.+.5*kfl),kcs)
12860  mint(22)=isign(int(6.-.5*kfl),-kcs)
12861  kcc=4
12862  kfres=isign(kfhigg,-kfl*kcs)
12863  ENDIF
12864 
12865 C...QUARKONIA+++
12866 C...Additional code by Stefan Wolf
12867  ELSEIF(isub.LE.430) THEN
12868  IF(isub.GE.421.AND.isub.LE.424) THEN
12869 C...g + g -> QQ~[n] + g
12870 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12871 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12872 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12873 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12874 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12875 C...[g + g -> g + g; th arbitrary]
12876  mint(21)=kfpr(isubsv,1)
12877  mint(22)=kfpr(isubsv,2)
12878  IF(isub.EQ.421) THEN
12879  kcc=24
12880  kcs=(-1)**int(1.5d0+pyr(0))
12881  ELSE
12882  kcc=mint(2)+12
12883  kcs=(-1)**int(1.5d0+pyr(0))
12884  ENDIF
12885 
12886  ELSEIF(isub.GE.425.AND.isub.LE.427) THEN
12887 C...q + g -> q + QQ~[n]
12888 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12889 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12890 C...KCC copied from ISUB.EQ.28
12891 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12892  IF(mint(15).EQ.21) js=2
12893  mint(23-js)=kfpr(isubsv,2)
12894  kcc=mint(2)+6
12895  IF(mint(15).EQ.21) kcc=kcc+2
12896  IF(mint(15).NE.21) kcs=isign(1,mint(15))
12897  IF(mint(16).NE.21) kcs=isign(1,mint(16))
12898 
12899  ELSEIF(isub.GE.428.AND.isub.LE.430) THEN
12900 C...q + q~ -> g + QQ~[n]
12901 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12902 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12903 C...KCC copied from ISUB.EQ.13
12904 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12905  IF(pyr(0).GT.0.5) js=2
12906  mint(20+js)=21
12907  mint(23-js)=kfpr(isubsv,2)
12908  kcc=mint(2)+4
12909  ENDIF
12910 
12911  ELSEIF(isub.LE.440) THEN
12912  IF(isub.GE.431.AND.isub.LE.433) THEN
12913 C...g + g -> QQ~[n] + g
12914 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12915 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12916 C...KCC and KCS copied from ISUB.EQ.86-89
12917 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12918  mint(21)=kfpr(isubsv,1)
12919  mint(22)=kfpr(isubsv,2)
12920  kcc=24
12921  kcs=(-1)**int(1.5d0+pyr(0))
12922 
12923  ELSEIF(isub.GE.434.AND.isub.LE.436) THEN
12924 C...q + g -> q + QQ~[n]
12925 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12926 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12927 C...KCC and KCS copied from ISUB.EQ.112
12928 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12929  IF(mint(15).EQ.21) js=2
12930  mint(23-js)=kfpr(isubsv,2)
12931  kcc=15+js
12932  kcs=isign(1,mint(14+js))
12933 
12934  ELSEIF(isub.GE.437.AND.isub.LE.439) THEN
12935 C...q + q~ -> g + QQ~[n]
12936 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12937 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12938 C...KCC copied from ISUB.EQ.111
12939 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12940  IF(pyr(0).GT.0.5) js=2
12941  mint(20+js)=21
12942  mint(23-js)=kfpr(isubsv,2)
12943  kcc=17+js
12944 C...QUARKONIA---
12945  ENDIF
12946  ELSEIF(isub.LE.500) THEN
12947  IF(isub.EQ.481.OR.isub.EQ.482) THEN
12948  kfres=9900001
12949  kcres=pycomp(kfres)
12950  mcol=kchg(kcres,2)
12951  mchg=kchg(kcres,1)
12952  IF(kcres.EQ.0)
12953  $ CALL pyerrm(21,"No resonance for Generic 2-> 2 Process")
12954  idcy=mdcy(kcres,2)
12955  IF(idcy.EQ.0)
12956  $ CALL pyerrm(21,"No decays for resonance in Generic 2->2")
12957  kci1=pycomp(mint(15))
12958  kci2=pycomp(mint(16))
12959  icol1=isign(kchg(kci1,2),mint(15))
12960  icol2=isign(kchg(kci2,2),mint(16))
12961  kff1=kfpr(isub,1)
12962  kff2=kfpr(isub,2)
12963  kcf1=pycomp(kff1)
12964  kcf2=pycomp(kff2)
12965  jcol1=sign(kchg(kcf1,2),kff1)
12966  IF(jcol1.EQ.-2) jcol1=2
12967  jcol2=sign(kchg(kcf2,2),kff2)
12968  IF(jcol2.EQ.-2) jcol2=2
12969  kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12970  kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12971  kchw=kch1+kch2
12972  krel=1
12973  IF(mchg.NE.0.AND.kchw.EQ.-mchg) krel=-1
12974  IF(kchg(kcf1,3).NE.0) kff1=kff1*krel
12975  IF(kchg(kcf2,3).NE.0) kff2=kff2*krel
12976  IF(jcol1.EQ.1.OR.jcol1.EQ.-1) jcol1=jcol1*krel
12977  IF(jcol2.EQ.1.OR.jcol2.EQ.-1) jcol2=jcol2*krel
12978  IF((icol1.EQ.1.AND.icol2.EQ.-1).OR.
12979  $ (icol2.EQ.1.AND.icol1.EQ.-1)) THEN
12980  IF(pyr(0).GT.0.5d0) js=2
12981  mint(20+js)=kff1
12982  mint(23-js)=kff2
12983  IF(jcol1.EQ.0.AND.jcol2.EQ.0) THEN
12984 
12985  ELSEIF(jcol1.EQ.0.AND.jcol2.EQ.2) THEN
12986  kcc=17+js
12987  mint(20+js)=kff2
12988  mint(23-js)=kff1
12989  ELSEIF(jcol1.EQ.2.AND.jcol2.EQ.0) THEN
12990  kcc=17+js
12991  mint(20+js)=kff1
12992  mint(23-js)=kff2
12993  ELSEIF(jcol1.EQ.2.AND.jcol2.EQ.2.AND.mcol.EQ.0) THEN
12994 
12995  ELSEIF(jcol1.EQ.2.AND.jcol2.EQ.2) THEN
12996  kcc=mint(2)+4
12997  ELSEIF((jcol1.EQ.1.AND.jcol2.EQ.-1).OR.
12998  $ (jcol1.EQ.-1.AND.jcol2.EQ.1)) THEN
12999  IF(icol1.EQ.jcol1) THEN
13000  js=1
13001  mint(21)=kff1
13002  mint(22)=kff2
13003  ELSE
13004  js=2
13005  mint(21)=kff2
13006  mint(22)=kff1
13007  ENDIF
13008  IF(mcol.EQ.0) THEN
13009 
13010  ELSE
13011  kcc=4
13012  ENDIF
13013  ENDIF
13014  ELSEIF((icol1.EQ.2.AND.(icol2.EQ.1.OR.icol2.EQ.-1)).OR.
13015  $ (icol2.EQ.2.AND.(icol1.EQ.1.OR.icol1.EQ.-1))) THEN
13016  IF((jcol1.EQ.2.AND.abs(jcol2).EQ.1).OR.
13017  $ (jcol2.EQ.2.AND.abs(jcol1).EQ.1)) THEN
13018  IF(mint(15).EQ.21) js=2
13019  kcc=mint(2)+6
13020  IF(mint(15).EQ.21) kcc=kcc+2
13021  IF(mint(15).NE.21) kcs=isign(1,mint(15))
13022  IF(mint(16).NE.21) kcs=isign(1,mint(16))
13023  IF(jcol1.EQ.2) THEN
13024  mint(20+js)=kff2
13025  mint(23-js)=kff1
13026  ELSE
13027  mint(20+js)=kff1
13028  mint(23-js)=kff2
13029  ENDIF
13030  ELSEIF((abs(jcol1).EQ.1.AND.jcol2.EQ.0).OR.
13031  $ (abs(jcol2).EQ.1.AND.jcol1.EQ.0)) THEN
13032  IF(mint(15).EQ.21) js=2
13033  kcc=15+js
13034  kcs=isign(1,mint(14+js))
13035  IF(jcol1.EQ.0) THEN
13036  mint(23-js)=kff1
13037  mint(20+js)=kff2
13038  ELSE
13039  mint(23-js)=kff2
13040  mint(20+js)=kff1
13041  ENDIF
13042  ENDIF
13043  ELSEIF(icol1.EQ.2.AND.icol2.EQ.2.AND.
13044  $ jcol1.EQ.0.AND.jcol2.EQ.0) THEN
13045  IF(pyr(0).GT.0.5d0) js=2
13046  kcc=21
13047  mint(20+js)=kff1
13048  mint(23-js)=kff2
13049  ELSEIF(icol1.EQ.2.AND.icol2.EQ.2.AND.
13050  $ ((jcol1.EQ.0.AND.jcol2.EQ.2).OR.
13051  $ ((jcol2.EQ.0.AND.jcol1.EQ.2)))) THEN
13052  IF(pyr(0).GT.0.5d0) js=2
13053  kcc=22+js
13054  kcs=(-1)**int(1.5d0+pyr(0))
13055  IF(jcol1.EQ.0) THEN
13056  mint(23-js)=kff1
13057  mint(20+js)=kff2
13058  ELSE
13059  mint(23-js)=kff2
13060  mint(20+js)=kff1
13061  ENDIF
13062  ELSEIF(icol1.EQ.2.AND.icol2.EQ.2.AND.
13063  $ ((jcol1.EQ.1.AND.jcol2.EQ.-1).OR.
13064  $ ((jcol2.EQ.1.AND.jcol1.EQ.-1)))) THEN
13065 C....two choices, 0 or 2 depending upon mother properties
13066  IF(mcol.EQ.2) THEN
13067  kcs=(-1)**int(1.5d0+pyr(0))
13068  kcc=mint(2)+10
13069  IF(jcol1.EQ.1) THEN
13070  mint(21)=kff1*kcs
13071  mint(22)=kff2*kcs
13072  ELSE
13073  mint(22)=kff1*kcs
13074  mint(21)=kff2*kcs
13075  ENDIF
13076 c MINT(20+JS)=KFF1*KCS
13077 c MINT(23-JS)=KFF2*KCS
13078  ELSEIF(mcol.EQ.0) THEN
13079  kcc=21
13080  mint(20+js)=kff1*kcs
13081  mint(23-js)=kff2*kcs
13082  ENDIF
13083 
13084  ELSEIF(icol1.EQ.2.AND.icol2.EQ.2.AND.
13085  $ jcol1.EQ.2.AND.jcol2.EQ.2) THEN
13086 C....two choices, 0 or 2 depending upon mother properties
13087  IF(mcol.EQ.0) THEN
13088  kcc=21
13089  IF(pyr(0).GT.0.5d0) js=2
13090  mint(20+js)=kff1
13091  mint(23-js)=kff2
13092  ELSEIF(mcol.EQ.2) THEN
13093  IF(pyr(0).GT.0.5d0) js=2
13094  kcc=mint(2)+12
13095  kcs=(-1)**int(1.5d0+pyr(0))
13096  mint(20+js)=kff1
13097  mint(23-js)=kff2
13098  ENDIF
13099  ELSEIF((icol1.EQ.1.AND.icol2.EQ.1).OR.
13100  $ (icol1.EQ.-1.AND.icol2.EQ.-1)) THEN
13101  kcc=mint(2)
13102  IF(pyr(0).GT.0.5d0) js=2
13103  mint(20+js)=kff1
13104  mint(23-js)=kff2
13105  ELSEIF(icol1.EQ.0.AND.icol2.EQ.0.AND.mcol.EQ.0) THEN
13106  kcc=20
13107  IF(pyr(0).GT.0.5d0) js=2
13108  mint(20+js)=kff1
13109  mint(23-js)=kff2
13110  ELSE
13111  CALL pyerrm(21,"PYSCAT: No recognized Generic Process")
13112  ENDIF
13113  IF(isubsv.EQ.482) kfres=0
13114  ENDIF
13115  ENDIF
13116 
13117  IF(iset(isub).EQ.11) THEN
13118 C...Store documentation for user-defined processes
13119  bezup=(pup(3,1)+pup(3,2))/(pup(4,1)+pup(4,2))
13120  kuppo(1)=mint(83)+5
13121  kuppo(2)=mint(83)+6
13122  i=mint(83)+6
13123  DO 470 iup=3,nup
13124  kuppo(iup)=0
13125  IF(mstp(128).GE.2.AND.mothup(1,iup).GE.3) THEN
13126  idoc=idoc-1
13127  mint(4)=mint(4)-1
13128  goto 470
13129  ENDIF
13130  i=i+1
13131  kuppo(iup)=i
13132  k(i,1)=21
13133  k(i,2)=idup(iup)
13134  IF(idup(iup).EQ.0) k(i,2)=90
13135  k(i,3)=0
13136  IF(mothup(1,iup).GE.3) k(i,3)=kuppo(mothup(1,iup))
13137  k(i,4)=0
13138  k(i,5)=0
13139  DO 460 j=1,5
13140  p(i,j)=pup(j,iup)
13141  460 CONTINUE
13142  v(i,5)=vtimup(iup)
13143  470 CONTINUE
13144  CALL pyrobo(mint(83)+7,mint(83)+4+nup,0d0,vint(24),0d0,0d0,
13145  & -bezup)
13146 
13147 C...Store final state partons for user-defined processes
13148  n=ipu2
13149  DO 490 iup=3,nup
13150  n=n+1
13151  k(n,1)=1
13152  IF(istup(iup).EQ.2.OR.istup(iup).EQ.3) k(n,1)=11
13153  k(n,2)=idup(iup)
13154  IF(idup(iup).EQ.0) k(n,2)=90
13155  IF(mstp(128).LE.0.OR.mothup(1,iup).EQ.0) THEN
13156  k(n,3)=kuppo(iup)
13157  ELSE
13158  k(n,3)=mint(84)+mothup(1,iup)
13159  ENDIF
13160  k(n,4)=0
13161  k(n,5)=0
13162 C...Search for daughters of intermediate colourless particles.
13163  IF(k(n,1).EQ.11.AND.kchg(pycomp(k(n,2)),2).EQ.0) THEN
13164  DO 475 iupdau=iup+1,nup
13165  IF(mothup(1,iupdau).EQ.iup.AND.k(n,4).EQ.0) k(n,4)=
13166  & n+iupdau-iup
13167  IF(mothup(1,iupdau).EQ.iup) k(n,5)=n+iupdau-iup
13168  475 CONTINUE
13169  ENDIF
13170  DO 480 j=1,5
13171  p(n,j)=pup(j,iup)
13172  480 CONTINUE
13173  v(n,5)=vtimup(iup)
13174  490 CONTINUE
13175  CALL pyrobo(ipu3,n,0d0,vint(24),0d0,0d0,-bezup)
13176 
13177 C...Arrange colour flow for user-defined processes
13178  nlbl=0
13179  DO 540 iup1=1,nup
13180  i1=mint(84)+iup1
13181  IF(kchg(pycomp(k(i1,2)),2).EQ.0) goto 540
13182  IF(k(i1,1).EQ.1) k(i1,1)=3
13183  IF(k(i1,1).EQ.11) k(i1,1)=14
13184 C...Find a not yet considered colour/anticolour line.
13185  DO 530 isde1=1,2
13186  IF(icolup(isde1,iup1).EQ.0) goto 530
13187  nmat=0
13188  DO 500 ilbl=1,nlbl
13189  IF(icolup(isde1,iup1).EQ.ilab(ilbl)) nmat=1
13190  500 CONTINUE
13191  IF(nmat.EQ.0) THEN
13192  nlbl=nlbl+1
13193  ilab(nlbl)=icolup(isde1,iup1)
13194 C...Find all others belonging to same line.
13195  i3=i1
13196  i4=0
13197  DO 520 iup2=iup1+1,nup
13198  i2=mint(84)+iup2
13199  DO 510 isde2=1,2
13200  IF(icolup(isde2,iup2).EQ.icolup(isde1,iup1)) THEN
13201  IF(isde2.EQ.isde1) THEN
13202  k(i3,3+isde2)=k(i3,3+isde2)+i2
13203  k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i3
13204  i3=i2
13205  ELSEIF(i4.NE.0) THEN
13206  k(i4,3+isde2)=k(i4,3+isde2)+i2
13207  k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i4
13208  i4=i2
13209  ELSEIF(iup2.LE.2) THEN
13210  k(i1,3+isde1)=k(i1,3+isde1)+i2
13211  k(i2,3+isde2)=k(i2,3+isde2)+i1
13212  i4=i2
13213  ELSE
13214  k(i1,3+isde1)=k(i1,3+isde1)+mstu(5)*i2
13215  k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i1
13216  i4=i2
13217  ENDIF
13218  ENDIF
13219  510 CONTINUE
13220  520 CONTINUE
13221  ENDIF
13222  530 CONTINUE
13223  540 CONTINUE
13224 
13225  ELSEIF(idoc.EQ.7) THEN
13226 C...Resonance not decaying; store kinematics
13227  i=mint(83)+7
13228  k(ipu3,1)=1
13229  k(ipu3,2)=kfres
13230  k(ipu3,3)=i
13231  p(ipu3,4)=shuser
13232  p(ipu3,5)=shuser
13233  k(i,1)=21
13234  k(i,2)=kfres
13235  p(i,4)=shuser
13236  p(i,5)=shuser
13237  n=ipu3
13238  mint(21)=kfres
13239  mint(22)=0
13240 
13241 C...Special cases: colour flow in coloured resonances
13242  kcres=pycomp(kfres)
13243  IF(kchg(kcres,2).NE.0) THEN
13244  k(ipu3,1)=3
13245  DO 550 j=1,2
13246  jc=j
13247  IF(kcs.EQ.-1) jc=3-j
13248  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13249  & mint(84)+icol(kcc,1,jc)
13250  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13251  & mint(84)+icol(kcc,2,jc)
13252  IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
13253  & mstu(5)*(mint(84)+icol(kcc,3,jc))
13254  550 CONTINUE
13255  ELSE
13256  k(ipu1,4)=ipu2
13257  k(ipu1,5)=ipu2
13258  k(ipu2,4)=ipu1
13259  k(ipu2,5)=ipu1
13260  ENDIF
13261 
13262  ELSEIF(idoc.EQ.8) THEN
13263 C...2 -> 2 processes: store outgoing partons in their CM-frame
13264  DO 560 jt=1,2
13265  i=mint(84)+2+jt
13266  kca=pycomp(mint(20+jt))
13267  k(i,1)=1
13268  IF(kchg(kca,2).NE.0) k(i,1)=3
13269  k(i,2)=mint(20+jt)
13270  k(i,3)=mint(83)+idoc+jt-2
13271  kfaa=iabs(k(i,2))
13272  IF(kfpr(isubsv,1+mod(js+jt,2)).NE.0) THEN
13273  p(i,5)=sqrt(vint(63+mod(js+jt,2)))
13274  ELSE
13275  p(i,5)=pymass(k(i,2))
13276  ENDIF
13277  IF((kfaa.EQ.6.OR.kfaa.EQ.7.OR.kfaa.EQ.8).AND.
13278  & p(i,5).LT.parp(42)) p(i,5)=pymass(k(i,2))
13279  560 CONTINUE
13280  IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN
13281  kfa1=iabs(mint(21))
13282  kfa2=iabs(mint(22))
13283  IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))
13284  & THEN
13285  mint(51)=1
13286  RETURN
13287  ENDIF
13288  p(ipu3,5)=0d0
13289  p(ipu4,5)=0d0
13290  ENDIF
13291  p(ipu3,4)=0.5d0*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr)
13292  p(ipu3,3)=sqrt(max(0d0,p(ipu3,4)**2-p(ipu3,5)**2))
13293  p(ipu4,4)=shr-p(ipu3,4)
13294  p(ipu4,3)=-p(ipu3,3)
13295  n=ipu4
13296  mint(7)=mint(83)+7
13297  mint(8)=mint(83)+8
13298 
13299 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13300  CALL pyrobo(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)
13301 
13302  ELSEIF(idoc.EQ.9) THEN
13303 C...2 -> 3 processes: store outgoing partons in their CM frame
13304  DO 570 jt=1,2
13305  i=mint(84)+2+jt
13306  kca=pycomp(mint(20+jt))
13307  k(i,1)=1
13308  IF(kchg(kca,2).NE.0) k(i,1)=3
13309  k(i,2)=mint(20+jt)
13310  k(i,3)=mint(83)+idoc+jt-3
13311  jta=jt
13312 C...t and b in opposide order in event list as compared to
13313 C...matrix element?
13314  IF(isub.EQ.402.AND.iabs(mint(21)).EQ.5) jta=3-jt
13315  IF(iabs(k(i,2)).LE.22) THEN
13316  p(i,5)=pymass(k(i,2))
13317  ELSE
13318  p(i,5)=sqrt(vint(63+mod(js+jta,2)))
13319  ENDIF
13320  pt=sqrt(max(0d0,vint(197+5*jta)-p(i,5)**2+vint(196+5*jta)**2))
13321  p(i,1)=pt*cos(vint(198+5*jta))
13322  p(i,2)=pt*sin(vint(198+5*jta))
13323  570 CONTINUE
13324  k(ipu5,1)=1
13325  k(ipu5,2)=kfres
13326  k(ipu5,3)=mint(83)+idoc
13327  p(ipu5,5)=shr
13328  p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
13329  p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
13330  pms1=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
13331  pms2=p(ipu4,5)**2+p(ipu4,1)**2+p(ipu4,2)**2
13332  pms3=p(ipu5,5)**2+p(ipu5,1)**2+p(ipu5,2)**2
13333  pmt3=sqrt(pms3)
13334  p(ipu5,3)=pmt3*sinh(vint(211))
13335  p(ipu5,4)=pmt3*cosh(vint(211))
13336  pms12=(shpr-p(ipu5,4))**2-p(ipu5,3)**2
13337  sql12=(pms12-pms1-pms2)**2-4d0*pms1*pms2
13338  IF(sql12.LE.0d0) THEN
13339  mint(51)=1
13340  RETURN
13341  ENDIF
13342  p(ipu3,3)=(-p(ipu5,3)*(pms12+pms1-pms2)+
13343  & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
13344  p(ipu4,3)=-p(ipu3,3)-p(ipu5,3)
13345  IF(isub.EQ.402.AND.iabs(mint(21)).EQ.5) THEN
13346 C...t and b in opposide order in event list as compared to
13347 C...matrix element
13348  p(ipu4,3)=(-p(ipu5,3)*(pms12+pms2-pms1)+
13349  & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
13350  p(ipu3,3)=-p(ipu4,3)-p(ipu5,3)
13351  END IF
13352  p(ipu3,4)=sqrt(pms1+p(ipu3,3)**2)
13353  p(ipu4,4)=sqrt(pms2+p(ipu4,3)**2)
13354  mint(23)=kfres
13355  n=ipu5
13356  mint(7)=mint(83)+7
13357  mint(8)=mint(83)+8
13358 
13359  ELSEIF(idoc.EQ.11) THEN
13360 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13361  phi(1)=paru(2)*pyr(0)
13362  phi(2)=phi(1)-phir
13363  DO 580 jt=1,2
13364  i=mint(84)+2+jt
13365  k(i,1)=1
13366  IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
13367  k(i,2)=mint(20+jt)
13368  k(i,3)=mint(83)+idoc+jt-2
13369  p(i,5)=pymass(k(i,2))
13370  IF(0.5d0*shpr*z(jt).LE.p(i,5)) THEN
13371  mint(51)=1
13372  RETURN
13373  ENDIF
13374  pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
13375  ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
13376  p(i,1)=ptabs*cos(phi(jt))
13377  p(i,2)=ptabs*sin(phi(jt))
13378  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13379  p(i,4)=0.5d0*shpr*z(jt)
13380  izw=mint(83)+6+jt
13381  k(izw,1)=21
13382  k(izw,2)=23
13383  IF(isub.EQ.8) k(izw,2)=isign(24,pychge(mint(14+jt)))
13384  k(izw,3)=izw-2
13385  p(izw,1)=-p(i,1)
13386  p(izw,2)=-p(i,2)
13387  p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13388  p(izw,4)=0.5d0*shpr*(1d0-z(jt))
13389  p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13390  580 CONTINUE
13391  i=mint(83)+9
13392  k(ipu5,1)=1
13393  k(ipu5,2)=kfres
13394  k(ipu5,3)=i
13395  p(ipu5,5)=shr
13396  p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
13397  p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
13398  p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)
13399  p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)
13400  k(i,1)=21
13401  k(i,2)=kfres
13402  DO 590 j=1,5
13403  p(i,j)=p(ipu5,j)
13404  590 CONTINUE
13405  n=ipu5
13406  mint(23)=kfres
13407 
13408  ELSEIF(idoc.EQ.12) THEN
13409 C...Z0 and W+/- scattering: store bosons and outgoing partons
13410  phi(1)=paru(2)*pyr(0)
13411  phi(2)=phi(1)-phir
13412  jtran=int(1.5d0+pyr(0))
13413  DO 600 jt=1,2
13414  i=mint(84)+2+jt
13415  k(i,1)=1
13416  IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
13417  k(i,2)=mint(20+jt)
13418  k(i,3)=mint(83)+idoc+jt-2
13419  p(i,5)=pymass(k(i,2))
13420  IF(0.5d0*shpr*z(jt).LE.p(i,5)) p(i,5)=0d0
13421  pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
13422  ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
13423  p(i,1)=ptabs*cos(phi(jt))
13424  p(i,2)=ptabs*sin(phi(jt))
13425  p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13426  p(i,4)=0.5d0*shpr*z(jt)
13427  izw=mint(83)+6+jt
13428  k(izw,1)=21
13429  IF(mint(14+jt).EQ.mint(20+jt)) THEN
13430  k(izw,2)=23
13431  ELSE
13432  k(izw,2)=isign(24,pychge(mint(14+jt))-pychge(mint(20+jt)))
13433  ENDIF
13434  k(izw,3)=izw-2
13435  p(izw,1)=-p(i,1)
13436  p(izw,2)=-p(i,2)
13437  p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13438  p(izw,4)=0.5d0*shpr*(1d0-z(jt))
13439  p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13440  ipu=mint(84)+4+jt
13441  k(ipu,1)=3
13442  k(ipu,2)=kfpr(isub,jt)
13443  IF(isub.EQ.72.AND.jt.EQ.jtran) k(ipu,2)=-k(ipu,2)
13444  IF(isub.EQ.73.OR.isub.EQ.77) k(ipu,2)=k(izw,2)
13445  k(ipu,3)=mint(83)+8+jt
13446  IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN
13447  p(ipu,5)=pymass(k(ipu,2))
13448  ELSE
13449  p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))
13450  ENDIF
13451  mint(22+jt)=k(ipu,2)
13452  600 CONTINUE
13453 C...Find rotation and boost for hard scattering subsystem
13454  i1=mint(83)+7
13455  i2=mint(83)+8
13456  bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))
13457  beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))
13458  bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))
13459  gamcm=(p(i1,4)+p(i2,4))/shr
13460  bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3)
13461  px=p(i1,1)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bexcm
13462  py=p(i1,2)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*beycm
13463  pz=p(i1,3)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bezcm
13464  thecm=pyangl(pz,sqrt(px**2+py**2))
13465  phicm=pyangl(px,py)
13466 C...Store hard scattering subsystem. Rotate and boost it
13467  sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4d0*p(ipu5,5)**2*
13468  & p(ipu6,5)**2
13469  pabs=sqrt(max(0d0,sqlam/(4d0*sh)))
13470  cthwz=vint(23)
13471  sthwz=sqrt(max(0d0,1d0-cthwz**2))
13472  phiwz=vint(24)-phicm
13473  p(ipu5,1)=pabs*sthwz*cos(phiwz)
13474  p(ipu5,2)=pabs*sthwz*sin(phiwz)
13475  p(ipu5,3)=pabs*cthwz
13476  p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)
13477  p(ipu6,1)=-p(ipu5,1)
13478  p(ipu6,2)=-p(ipu5,2)
13479  p(ipu6,3)=-p(ipu5,3)
13480  p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)
13481  CALL pyrobo(ipu5,ipu6,thecm,phicm,bexcm,beycm,bezcm)
13482  DO 620 jt=1,2
13483  i1=mint(83)+8+jt
13484  i2=mint(84)+4+jt
13485  k(i1,1)=21
13486  k(i1,2)=k(i2,2)
13487  DO 610 j=1,5
13488  p(i1,j)=p(i2,j)
13489  610 CONTINUE
13490  620 CONTINUE
13491  n=ipu6
13492  mint(7)=mint(83)+9
13493  mint(8)=mint(83)+10
13494  ENDIF
13495 
13496  IF(iset(isub).EQ.11) THEN
13497  ELSEIF(idoc.GE.8) THEN
13498 C...Store colour connection indices
13499  DO 630 j=1,2
13500  jc=j
13501  IF(kcs.EQ.-1) jc=3-j
13502  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13503  & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)
13504  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13505  & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)
13506  IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
13507  & mstu(5)*(mint(84)+icol(kcc,3,jc))
13508  IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
13509  & mstu(5)*(mint(84)+icol(kcc,4,jc))
13510  630 CONTINUE
13511 
13512 C...Copy outgoing partons to documentation lines
13513  imax=2
13514  IF(idoc.EQ.9) imax=3
13515  DO 650 i=1,imax
13516  i1=mint(83)+idoc-imax+i
13517  i2=mint(84)+2+i
13518  k(i1,1)=21
13519  k(i1,2)=k(i2,2)
13520  IF(idoc.LE.9) k(i1,3)=0
13521  IF(idoc.GE.11) k(i1,3)=mint(83)+2+i
13522  DO 640 j=1,5
13523  p(i1,j)=p(i2,j)
13524  640 CONTINUE
13525  650 CONTINUE
13526 
13527  ELSEIF(idoc.EQ.9) THEN
13528 C...Store colour connection indices
13529  DO 660 j=1,2
13530  jc=j
13531  IF(kcs.EQ.-1) jc=3-j
13532  IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13533  & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)+
13534  & max(0,min(1,icol(kcc,1,jc)-2))
13535  IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13536  & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)+
13537  & max(0,min(1,icol(kcc,2,jc)-2))
13538  IF(icol(kcc,3,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
13539  & mstu(5)*(mint(84)+icol(kcc,3,jc))
13540  IF(icol(kcc,4,jc).NE.0.AND.k(ipu5,1).EQ.3) k(ipu5,j+3)=
13541  & mstu(5)*(mint(84)+icol(kcc,4,jc))
13542  660 CONTINUE
13543 
13544 C...Copy outgoing partons to documentation lines
13545  DO 680 i=1,3
13546  i1=mint(83)+idoc-3+i
13547  i2=mint(84)+2+i
13548  k(i1,1)=21
13549  k(i1,2)=k(i2,2)
13550  k(i1,3)=0
13551  DO 670 j=1,5
13552  p(i1,j)=p(i2,j)
13553  670 CONTINUE
13554  680 CONTINUE
13555  ENDIF
13556 
13557 C...Copy outgoing partons to list of allowed radiators.
13558  npart=0
13559  IF(mint(35).GE.2.AND.iset(isub).NE.0) THEN
13560  DO 690 i=mint(84)+3,n
13561  npart=npart+1
13562  ipart(npart)=i
13563  ptpart(npart)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2)
13564  690 CONTINUE
13565  ENDIF
13566 
13567 C...Low-pT events: remove gluons used for string drawing purposes
13568  IF(isub.EQ.95) THEN
13569  IF(mint(35).LE.1) THEN
13570  k(ipu3,1)=k(ipu3,1)+10
13571  k(ipu4,1)=k(ipu4,1)+10
13572  ENDIF
13573  DO 700 j=41,66
13574  vintsv(j)=vint(j)
13575  vint(j)=0d0
13576  700 CONTINUE
13577  DO 720 i=mint(83)+5,mint(83)+8
13578  DO 710 j=1,5
13579  p(i,j)=0d0
13580  710 CONTINUE
13581  720 CONTINUE
13582  ENDIF
13583 
13584  RETURN
13585  END
13586 
13587 C***********************************************************************
13588 
13589 C...PYEVOL
13590 C...Handles intertwined pT-ordered spacelike initial-state parton
13591 C...and multiple interactions.
13592 
13593  SUBROUTINE pyevol(MODE,PT2MAX,PT2MIN)
13594 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13595 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13596 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13597 
13598 C...Double precision and integer declarations.
13599  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13600  IMPLICIT INTEGER(i-n)
13601  INTEGER pyk,pychge,pycomp
13602 C...External
13603  EXTERNAL pyalps
13604  DOUBLE PRECISION pyalps
13605 C...Parameter statement for maximum size of showers.
13606  parameter(maxnur=1000)
13607 C...Commonblocks.
13608  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
13609  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13610  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13611  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
13612  common/pypars/mstp(200),parp(200),msti(200),pari(200)
13613  common/pyint1/mint(400),vint(400)
13614  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
13615  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13616  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
13617  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
13618  & xmi(2,240),pt2mi(240),imisep(0:240)
13619  common/pyctag/nct,mct(4000,2)
13620  common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
13621  & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
13622  common/pyisjn/mjn1mx,mjn2mx,mjoind(2,240)
13623 C...Max size of hard system = HEPEUP size
13624  INTEGER maxnup
13625  parameter(maxnup=500)
13626 C...Local arrays and saved variables.
13627  dimension vintsv(11:80),ksav(maxnup,5),psav(maxnup,5),
13628  & vsav(maxnup,5),shat(240)
13629  SAVE nsav,nparts,m15sv,m16sv,m21sv,m22sv,vintsv,shat,isubhd,alam3
13630  & ,psav,ksav,vsav
13631 
13632  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,
13633  & /pyint2/,/pyint3/,/pyintm/,/pyctag/,/pyismx/,/pyisjn/
13634 
13635 C----------------------------------------------------------------------
13636 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13637 C...done only once per event, while MODE=0 is repeated each time the
13638 C...evolution needs to be restarted.
13639  IF (mode.EQ.-1) THEN
13640  isubhd=mint(1)
13641  nsav=n
13642  nparts=npart
13643 C...Store hard scattering variables
13644  m15sv=mint(15)
13645  m16sv=mint(16)
13646  m21sv=mint(21)
13647  m22sv=mint(22)
13648  DO 100 j=11,80
13649  vintsv(j)=vint(j)
13650  100 CONTINUE
13651  DO 120 j=1,5
13652  DO 110 is=1,nsav-mint(84)
13653  i=is+mint(84)
13654  psav(is,j)=p(i,j)
13655  ksav(is,j)=k(i,j)
13656  vsav(is,j)=v(i,j)
13657  110 CONTINUE
13658  120 CONTINUE
13659 
13660 C...Set shat for hardest scattering
13661  shat(1)=vint(44)
13662  IF(iset(isubhd).GE.3.AND.iset(isubhd).LE.5) shat(1)=vint(26)
13663  & *vint(2)
13664 
13665 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13666  rmc=pmas(4,1)
13667  rmb=pmas(5,1)
13668  alam4=parp(61)
13669  IF(mstu(112).LT.4) alam4=parp(61)*(parp(61)/rmc)**(2d0/25d0)
13670  IF(mstu(112).GT.4) alam4=parp(61)*(rmb/parp(61))**(2d0/25d0)
13671  alam3=alam4*(rmc/alam4)**(2d0/27d0)
13672 
13673 C----------------------------------------------------------------------
13674 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13675 C...interaction initiators, with no previous evolution. Check the input
13676 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13677 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13678 C...smaller than the CM energy / 2.)
13679  ELSEIF (mode.EQ.0) THEN
13680 C...Reset counters and switches
13681  n=nsav
13682  npart=nparts
13683  mint(30)=0
13684  mint(31)=1
13685  mint(36)=1
13686 C...Reset hard scattering variables
13687  mint(1)=isubhd
13688  DO 130 j=11,80
13689  vint(j)=vintsv(j)
13690  130 CONTINUE
13691  DO 150 j=1,5
13692  DO 140 is=1,nsav-mint(84)
13693  i=is+mint(84)
13694  p(i,j)=psav(is,j)
13695  k(i,j)=ksav(is,j)
13696  v(i,j)=vsav(is,j)
13697  p(mint(83)+4+is,j)=psav(is,j)
13698  v(mint(83)+4+is,j)=vsav(is,j)
13699  140 CONTINUE
13700  150 CONTINUE
13701 C...Reset statistics on activity in event.
13702  DO 160 j=351,359
13703  mint(j)=0
13704  vint(j)=0d0
13705  160 CONTINUE
13706 C...Reset extra companion reweighting factor
13707  vint(140)=1d0
13708 
13709 C...We do not generate MI for soft process (ISUB=95), but the
13710 C...initialization must be done regardless, for later purposes.
13711  mint(36)=1
13712 
13713 C...Initialize multiple interactions.
13714  CALL pyptmi(-1,ptdum1,ptdum2,ptdum3,idum)
13715  IF(mint(51).NE.0) RETURN
13716 
13717 C...Decide whether quarks in hard scattering were valence or sea
13718  pt2hd=vint(54)
13719  DO 170 js=1,2
13720  mint(30)=js
13721  CALL pyptmi(2,pt2hd,ptdum2,ptdum3,idum)
13722  IF(mint(51).NE.0) RETURN
13723  170 CONTINUE
13724 
13725 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13726  vint(18)=0d0
13727  pt2min=max(pt2min,(1.1d0*alam3)**2)
13728  IF (mstp(70).EQ.2) THEN
13729 C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13730  vint(18)=(parp(82)*(vint(1)/parp(89))**parp(90))**2
13731  ELSEIF (mstp(70).EQ.3) THEN
13732 C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13733  alpha0 = max(1d-6,parp(73))
13734  q20 = alam3**2/parp(64)
13735  IF (mstp(64).EQ.3) q20 = q20 * 1.661**2
13736  vint(18) = q20 * (exp(12*paru(1)/27d0/alpha0)-1d0)
13737  ENDIF
13738 C...Also store PT2MIN in VINT(17).
13739  180 vint(17)=pt2min
13740 
13741 C...Set FS masses zero now.
13742  vint(63)=0d0
13743  vint(64)=0d0
13744 
13745 C...Initialize IS showers with VINT(56) as max scale.
13746  pt2isr=vint(56)
13747  pt20=pt2min
13748  IF (mstp(70).EQ.0) THEN
13749  pt20=max(pt2min,parp(62)**2)
13750  ELSEIF (mstp(70).EQ.1) THEN
13751  pt20=max(pt2min,(parp(81)*(vint(1)/parp(89))**parp(90))**2)
13752  ENDIF
13753  CALL pyptis(-1,pt2isr,pt20,pt2dum,ifail)
13754  IF(mint(51).NE.0) RETURN
13755 
13756  RETURN
13757 
13758 C----------------------------------------------------------------------
13759 C...MODE= 1: Evolve event from PTMAX to PTMIN.
13760  ELSEIF (mode.EQ.1) THEN
13761 
13762 C...Skip if no phase space.
13763  190 IF (pt2max.LE.pt2min) goto 330
13764 
13765 C...Starting pT2 max scale (to be udpated successively).
13766  pt2cmx=pt2max
13767 
13768 C...Evolve two sides of the event to find which branches at highest pT.
13769  200 jsmx=-1
13770  mimx=0
13771  pt2mx=0d0
13772 
13773 C...Loop over current shower initiators.
13774  IF (mstp(61).GE.1) THEN
13775  DO 230 mi=1,mint(31)
13776  IF (mi.GE.2.AND.mstp(84).LE.0) goto 230
13777  isub=96
13778  IF (mi.EQ.1) isub=isubhd
13779  mint(1)=isub
13780  mint(36)=mi
13781 C...Set up shat, initiator x values, and x remaining in BR.
13782  vint(44)=shat(mi)
13783  vint(141)=xmi(1,mi)
13784  vint(142)=xmi(2,mi)
13785  vint(143)=1d0
13786  vint(144)=1d0
13787  DO 210 ji=1,mint(31)
13788  IF (ji.EQ.mint(36)) goto 210
13789  vint(143)=vint(143)-xmi(1,ji)
13790  vint(144)=vint(144)-xmi(2,ji)
13791  210 CONTINUE
13792 C...Loop over sides.
13793 C...Generate trial branchings for this interaction. The hardest
13794 C...branching so far is automatically updated if necessary in /PYISMX/.
13795  DO 220 js=1,2
13796  mint(30)=js
13797  pt20=pt2min
13798  IF (mstp(70).EQ.0) THEN
13799  pt20=max(pt2min,parp(62)**2)
13800  ELSEIF (mstp(70).EQ.1) THEN
13801  pt20=max(pt2min,
13802  & (parp(81)*(vint(1)/parp(89))**parp(90))**2)
13803  ENDIF
13804  CALL pyptis(0,pt2cmx,pt20,pt2new,ifail)
13805  IF (mint(51).NE.0) RETURN
13806  220 CONTINUE
13807  230 CONTINUE
13808  ENDIF
13809 
13810 C...Generate trial additional interaction.
13811  mint(36)=mint(31)+1
13812  240 IF (mod(mstp(81),10).GE.1) THEN
13813  mint(1)=96
13814 C...Set up X remaining in BR.
13815  vint(143)=1d0
13816  vint(144)=1d0
13817  DO 250 ji=1,mint(31)
13818  vint(143)=vint(143)-xmi(1,ji)
13819  vint(144)=vint(144)-xmi(2,ji)
13820  250 CONTINUE
13821 C...Generate trial interaction
13822  260 CALL pyptmi(0,pt2cmx,pt2min,pt2new,ifail)
13823  IF (mint(51).EQ.1) RETURN
13824  ENDIF
13825 
13826 C...And the winner is:
13827  IF (pt2mx.LT.pt2min) THEN
13828  goto 330
13829  ELSEIF (jsmx.EQ.0) THEN
13830 C...Accept additional interaction (may still fail).
13831  CALL pyptmi(1,pt2new,pt2min,pt2dum,ifail)
13832  IF(mint(51).NE.0) RETURN
13833  IF (ifail.EQ.0) THEN
13834  shat(mint(36))=vint(44)
13835 C...Decide on flavours (valence/sea/companion).
13836  DO 270 js=1,2
13837  mint(30)=js
13838  CALL pyptmi(2,pt2new,pt2min,pt2dum,ifail)
13839  IF(mint(51).NE.0) RETURN
13840  270 CONTINUE
13841  ENDIF
13842  ELSEIF (jsmx.EQ.1.OR.jsmx.EQ.2) THEN
13843 C...Reconstruct kinematics of acceptable ISR branching.
13844 C...Set up shat, initiator x values, and x remaining in BR.
13845  mint(30)=jsmx
13846  mint(36)=mimx
13847  vint(44)=shat(mint(36))
13848  vint(141)=xmi(1,mint(36))
13849  vint(142)=xmi(2,mint(36))
13850  vint(143)=1d0
13851  vint(144)=1d0
13852  DO 280 ji=1,mint(31)
13853  IF (ji.EQ.mint(36)) goto 280
13854  vint(143)=vint(143)-xmi(1,ji)
13855  vint(144)=vint(144)-xmi(2,ji)
13856  280 CONTINUE
13857  pt2new=pt2mx
13858  CALL pyptis(1,pt2new,pt2dm1,pt2dm2,ifail)
13859  IF (mint(51).EQ.1) RETURN
13860  ELSEIF (jsmx.EQ.3.OR.jsmx.EQ.4) THEN
13861 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13862  mint(354)=mint(354)+1
13863  vint(354)=vint(354)+sqrt(pt2mx)
13864  IF (mint(354).EQ.1) vint(359)=sqrt(pt2mx)
13865  mjoind(jsmx-2,mjn1mx)=mjn2mx
13866  mjoind(jsmx-2,mjn2mx)=mjn1mx
13867  ENDIF
13868 
13869 C...Update PT2 iteration scale.
13870  pt2cmx=pt2mx
13871 
13872 C...Loop back to continue evolution.
13873  IF(n.GT.mstu(4)-mstu(32)-10) THEN
13874  CALL pyerrm(11,'(PYEVOL:) no more memory left in PYJETS')
13875  ELSE
13876  IF (jsmx.GE.0.AND.pt2cmx.GE.pt2min) goto 200
13877  ENDIF
13878 
13879 C----------------------------------------------------------------------
13880 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13881  ELSEIF (mode.EQ.2) THEN
13882 
13883 C...Revert to "ordinary" meanings of some parameters.
13884  290 DO 310 js=1,2
13885  mint(12+js)=k(imi(js,1,1),2)
13886  vint(140+js)=xmi(js,1)
13887  IF(mint(18+js).EQ.1) vint(140+js)=vint(154+js)*xmi(js,1)
13888  vint(142+js)=1d0
13889  DO 300 mi=1,mint(31)
13890  vint(142+js)=vint(142+js)-xmi(js,mi)
13891  300 CONTINUE
13892  310 CONTINUE
13893 
13894 C...Restore saved quantities for hardest interaction.
13895  mint(1)=isubhd
13896  mint(15)=m15sv
13897  mint(16)=m16sv
13898  mint(21)=m21sv
13899  mint(22)=m22sv
13900  DO 320 j=11,80
13901  vint(j)=vintsv(j)
13902  320 CONTINUE
13903 
13904  ENDIF
13905 
13906  330 RETURN
13907  END
13908 
13909 C*********************************************************************
13910 
13911 C...PYSSPA
13912 C...Generates spacelike parton showers.
13913 
13914  SUBROUTINE pysspa(IPU1,IPU2)
13915 
13916 C...Double precision and integer declarations.
13917  IMPLICIT DOUBLE PRECISION(a-h, o-z)
13918  IMPLICIT INTEGER(i-n)
13919  INTEGER pyk,pychge,pycomp
13920  parameter(maxnur=1000)
13921 C...Commonblocks.
13922  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
13923  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13924  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13925  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
13926  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
13927  common/pypars/mstp(200),parp(200),msti(200),pari(200)
13928  common/pyint1/mint(400),vint(400)
13929  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
13930  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13931  common/pyctag/nct,mct(4000,2)
13932  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,
13933  &/pyint1/,/pyint2/,/pyint3/,/pyctag/
13934 C...Local arrays and data.
13935  dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevcsv(2),tevesv(2),
13936  &xfs(2,-25:25),xfa(-25:25),xfb(-25:25),xfn(-25:25),wtapc(-25:25),
13937  &wtape(-25:25),wtsf(-25:25),the2(2),alam(2),dq2(3),dpc(3),dpd(4),
13938  &dpb(4),robo(5),more(2),kfbeam(2),q2mncs(2),kcfi(2),nfis(2),
13939  &thefis(2,2),isfi(2),dphi(2),mcesv(2)
13940  DATA is/2*0/
13941 
13942 C...Read out basic information; set global Q^2 scale.
13943  ipus1=ipu1
13944  ipus2=ipu2
13945  isub=mint(1)
13946  q2mx=vint(56)
13947  vint2r=vint(2)*vint(143)*vint(144)
13948  IF(iset(isub).EQ.2.OR.iset(isub).EQ.9.OR.iset(isub).EQ.11) q2mx=
13949  &min(vint2r,parp(67)*vint(56))
13950  fcq2mx=1d0
13951 
13952 C...Define which processes ME corrections have been implemented for.
13953  mecor=0
13954  IF(mstp(68).EQ.1.OR.mstp(68).EQ.3) THEN
13955  IF(isub.EQ.1.OR.isub.EQ.2.OR.isub.EQ.141.OR.isub.EQ.142.OR.
13956  & isub.EQ.144) mecor=1
13957  IF(isub.EQ.102.OR.isub.EQ.152.OR.isub.EQ.157) mecor=2
13958  IF(isub.EQ.3.OR.isub.EQ.151.OR.isub.EQ.156) mecor=3
13959  ENDIF
13960 
13961 C...Initialize QCD evolution and check phase space.
13962  q2mnc=parp(62)**2
13963  q2mncs(1)=q2mnc
13964  q2mncs(2)=q2mnc
13965  IF(mint(107).EQ.2.AND.mstp(66).EQ.2) THEN
13966  q0s=parp(15)**2
13967  ps=vint(3)**2
13968  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
13969  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
13970  q2int=sqrt(q0s*q2eff)
13971  q2mncs(1)=max(q2mnc,q2int)
13972  ELSEIF(mint(107).EQ.3.AND.mstp(66).GE.1) THEN
13973  q2mncs(1)=max(q2mnc,vint(283))
13974  ENDIF
13975  IF(mint(108).EQ.2.AND.mstp(66).EQ.2) THEN
13976  q0s=parp(15)**2
13977  ps=vint(4)**2
13978  q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
13979  & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
13980  q2int=sqrt(q0s*q2eff)
13981  q2mncs(2)=max(q2mnc,q2int)
13982  ELSEIF(mint(108).EQ.3.AND.mstp(66).GE.1) THEN
13983  q2mncs(2)=max(q2mnc,vint(284))
13984  ENDIF
13985  mcev=0
13986  alams=paru(112)
13987  paru(112)=parp(61)
13988  fq2c=1d0
13989  tcmx=0d0
13990  IF(mint(47).GE.2.AND.(mint(47).LT.5.OR.mstp(12).GE.1)) THEN
13991  mcev=1
13992  IF(mstp(64).EQ.1) fq2c=parp(63)
13993  IF(mstp(64).EQ.2) fq2c=parp(64)
13994  tcmx=log(fq2c*q2mx/parp(61)**2)
13995  IF(q2mx.LT.max(q2mnc,2d0*parp(61)**2).OR.tcmx.LT.0.2d0)
13996  & mcev=0
13997  ENDIF
13998 
13999 C...Initialize QED evolution and check phase space.
14000  meev=0
14001  xee=1d-10
14002  spme=pmas(11,1)**2
14003  IF(iabs(mint(11)).EQ.13.OR.iabs(mint(12)).EQ.13)
14004  &spme=pmas(13,1)**2
14005  IF(iabs(mint(11)).EQ.15.OR.iabs(mint(12)).EQ.15)
14006  &spme=pmas(15,1)**2
14007  q2mne=max(parp(68)**2,2d0*spme)
14008  temx=0d0
14009  fwte=10d0
14010  IF(mint(45).EQ.3.OR.mint(46).EQ.3) THEN
14011  meev=1
14012  temx=log(q2mx/spme)
14013  IF(q2mx.LE.q2mne.OR.temx.LT.0.2d0) meev=0
14014  ENDIF
14015  IF(mstp(61).GE.2.AND.mcev.EQ.1.AND.meev.EQ.0) THEN
14016  meev=2
14017  temx=tcmx
14018  fwte=1d0
14019  ENDIF
14020  IF(mcev.EQ.0.AND.meev.EQ.0) RETURN
14021 
14022 C...Loopback point in case of failure to reconstruct kinematics.
14023  ns=n
14024  nparts=npart
14025  loop=0
14026  mnt352=mint(352)
14027  mnt353=mint(353)
14028  vnt352=vint(352)
14029  vnt353=vint(353)
14030  100 loop=loop+1
14031  IF(loop.GT.100) THEN
14032  mint(51)=1
14033  RETURN
14034  ENDIF
14035  n=ns
14036  npart=nparts
14037  mint(352)=mnt352
14038  mint(353)=mnt353
14039  vint(352)=vnt352
14040  vint(353)=vnt353
14041 
14042 C...Initial values: flavours, momenta, virtualities.
14043  DO 120 jt=1,2
14044  more(jt)=1
14045  kfbeam(jt)=mint(10+jt)
14046  IF(mint(18+jt).EQ.1)kfbeam(jt)=22
14047  kfls(jt)=mint(14+jt)
14048  kfls(jt+2)=kfls(jt)
14049  xs(jt)=vint(40+jt)
14050  IF(mint(18+jt).EQ.1) xs(jt)=vint(40+jt)/vint(154+jt)
14051  IF(mint(31).GE.2) xs(jt)=xs(jt)/vint(142+jt)
14052  zs(jt)=1d0
14053  q2s(jt)=fcq2mx*q2mx
14054  dq2(jt)=0d0
14055  tevcsv(jt)=tcmx
14056  alam(jt)=parp(61)
14057  the2(jt)=1d0
14058  tevesv(jt)=temx
14059  mcesv(jt)=0
14060 C...Calculate initial parton distribution weights.
14061  mint(105)=mint(102+jt)
14062  mint(109)=mint(106+jt)
14063  vint(120)=vint(2+jt)
14064  IF(xs(jt).LT.1d0-xee) THEN
14065  IF(mint(31).GE.2) mint(30)=jt
14066  IF(mstp(57).LE.1) THEN
14067  CALL pypdfu(kfbeam(jt),xs(jt),q2s(jt),xfb)
14068  ELSE
14069  CALL pypdfl(kfbeam(jt),xs(jt),q2s(jt),xfb)
14070  ENDIF
14071  ENDIF
14072  DO 110 kfl=-25,25
14073  xfs(jt,kfl)=xfb(kfl)
14074  110 CONTINUE
14075 C...Special kinematics check for c/b quarks (that g -> c cbar or
14076 C...b bbar kinematically possible).
14077  kflcb=iabs(kfls(jt))
14078  IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5)) THEN
14079  IF(xs(jt).GT.0.9d0*q2s(jt)/(pmas(kflcb,1)**2+q2s(jt))) THEN
14080  mint(51)=1
14081  RETURN
14082  ENDIF
14083  ENDIF
14084  120 CONTINUE
14085  dsh=vint(44)
14086  IF(iset(isub).GE.3.AND.iset(isub).LE.5) dsh=vint(26)*vint(2)
14087 
14088 C...Find if interference with final state partons.
14089  mfis=0
14090  IF(mstp(67).GE.1.AND.mstp(67).LE.3) mfis=mstp(67)
14091  IF(mfis.NE.0) THEN
14092  DO 140 i=1,2
14093  kcfi(i)=0
14094  kca=pycomp(iabs(kfls(i)))
14095  IF(kca.NE.0) kcfi(i)=kchg(kca,2)*isign(1,kfls(i))
14096  nfis(i)=0
14097  IF(kcfi(i).NE.0) THEN
14098  IF(i.EQ.1) ipfs=ipus1
14099  IF(i.EQ.2) ipfs=ipus2
14100  DO 130 j=1,2
14101  icsi=mod(k(ipfs,3+j),mstu(5))
14102  IF(icsi.GT.0.AND.icsi.NE.ipus1.AND.icsi.NE.ipus2.AND.
14103  & (kcfi(i).EQ.(-1)**(j+1).OR.kcfi(i).EQ.2)) THEN
14104  nfis(i)=nfis(i)+1
14105  thefis(i,nfis(i))=pyangl(p(icsi,3),sqrt(p(icsi,1)**2+
14106  & p(icsi,2)**2))
14107  IF(i.EQ.2) thefis(i,nfis(i))=paru(1)-thefis(i,nfis(i))
14108  ENDIF
14109  130 CONTINUE
14110  ENDIF
14111  140 CONTINUE
14112  IF(nfis(1)+nfis(2).EQ.0) mfis=0
14113  ENDIF
14114 
14115 C...Pick up leg with highest virtuality.
14116  jtold=1
14117  150 n=n+1
14118  jt=1
14119  IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2
14120  IF(n.EQ.ns+2.AND.jt.EQ.jtold) jt=3-jt
14121  IF(more(jt).EQ.0) jt=3-jt
14122  jtold=jt
14123  kflb=kfls(jt)
14124  xb=xs(jt)
14125  DO 160 kfl=-25,25
14126  xfb(kfl)=xfs(jt,kfl)
14127  160 CONTINUE
14128  dshr=2d0*sqrt(dsh)
14129  dshz=dsh/zs(jt)
14130 
14131 C...Check if allowed to branch.
14132  mcev=0
14133  IF(iabs(kflb).LE.10.OR.kflb.EQ.21) THEN
14134  mcev=1
14135  xec=max(parp(65)*dshr/vint2r,xb*(1d0/(1d0-parp(66))-1d0))
14136  IF(xb.GE.1d0-2d0*xec) mcev=0
14137  ENDIF
14138  meev=0
14139  IF(mint(44+jt).EQ.3) THEN
14140  meev=1
14141  IF(xb.GE.1d0-2d0*xee) meev=0
14142  IF((iabs(kflb).LE.10.OR.kflb.EQ.21).AND.xb.GE.1d0-2d0*xec)
14143  & meev=0
14144 C***Currently kill QED shower for resolved photoproduction.
14145  IF(mint(18+jt).EQ.1) meev=0
14146 C***Currently kill shower for W inside electron.
14147  IF(iabs(kflb).EQ.24) THEN
14148  mcev=0
14149  meev=0
14150  ENDIF
14151  ENDIF
14152  IF(mstp(61).GE.2.AND.mcev.EQ.1.AND.meev.EQ.0.AND.iabs(kflb).LE.10)
14153  &meev=2
14154  IF(mcev.EQ.0.AND.meev.EQ.0) THEN
14155  q2b=0d0
14156  goto 260
14157  ENDIF
14158 
14159 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
14160  q2b=q2s(jt)
14161  tevcb=tevcsv(jt)
14162  teveb=tevesv(jt)
14163  IF(mstp(62).LE.1) THEN
14164  IF(zs(jt).GT.0.99999d0) THEN
14165  q2b=q2s(jt)
14166  ELSE
14167  q2b=0.5d0*(1d0/zs(jt)+1d0)*q2s(jt)+0.5d0*(1d0/zs(jt)-1d0)*
14168  & (q2s(3-jt)-dsh+sqrt((dsh+q2s(1)+q2s(2))**2+
14169  & 8d0*q2s(1)*q2s(2)*zs(jt)/(1d0-zs(jt))))
14170  ENDIF
14171  IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
14172  IF(meev.EQ.1) teveb=log(q2b/spme)
14173  ENDIF
14174  IF(mcev.EQ.1) THEN
14175  alsdum=pyalps(fq2c*q2b)
14176  tevcb=tevcb+2d0*log(alam(jt)/paru(117))
14177  alam(jt)=paru(117)
14178  b0=(33d0-2d0*mstu(118))/6d0
14179  ENDIF
14180  IF(meev.EQ.2) teveb=tevcb
14181  tevcbs=tevcb
14182  tevebs=teveb
14183 
14184 C...Select side for interference with final state partons.
14185  IF(mfis.GE.1.AND.n.LE.ns+2) THEN
14186  ifi=n-ns
14187  isfi(ifi)=0
14188  IF(iabs(kcfi(ifi)).EQ.1.AND.nfis(ifi).EQ.1) THEN
14189  isfi(ifi)=1
14190  ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.1) THEN
14191  IF(pyr(0).GT.0.5d0) isfi(ifi)=1
14192  ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.2) THEN
14193  isfi(ifi)=1
14194  IF(pyr(0).GT.0.5d0) isfi(ifi)=2
14195  ENDIF
14196  ENDIF
14197 
14198 C...Calculate preweighting factor for ME-corrected processes.
14199  IF(mecor.GE.1) CALL pymemx(mecor,wtff,wtgf,wtfg,wtgg)
14200 
14201 C...Calculate Altarelli-Parisi weights.
14202  DO 170 kfl=-25,25
14203  wtapc(kfl)=0d0
14204  wtape(kfl)=0d0
14205  wtsf(kfl)=0d0
14206  170 CONTINUE
14207 C...q -> q (g or gamma emission), g -> q.
14208  IF(iabs(kflb).LE.10) THEN
14209  wtapc(kflb)=(8d0/3d0)*log((1d0-xec-xb)*(xb+xec)/(xec*(1d0-xec)))
14210  wtapc(21)=0.5d0*(xb/(xb+xec)-xb/(1d0-xec))
14211  eq2=1d0/9d0
14212  IF(mod(iabs(kflb),2).EQ.0) eq2=4d0*eq2
14213  IF(meev.EQ.2) wtape(kflb)=2.*eq2*log((1d0-xec-xb)*(xb+xec)/
14214  & (xec*(1d0-xec)))
14215  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
14216  wtapc(kflb)=wtff*wtapc(kflb)
14217  wtapc(21)=wtgf*wtapc(21)
14218  wtape(kflb)=wtff*wtape(kflb)
14219  ENDIF
14220 C...f -> f, gamma -> f.
14221  ELSEIF(iabs(kflb).LE.20) THEN
14222  wtapf1=log((1d0-xee-xb)*(xb+xee)/(xee*(1d0-xee)))
14223  wtapf2=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))
14224  wtape(kflb)=2d0*(wtapf1+wtapf2)
14225  IF(mstp(12).GE.1) wtape(22)=xb/(xb+xee)-xb/(1d0-xee)
14226  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
14227  wtape(kflb)=wtff*wtape(kflb)
14228  wtape(22)=wtgf*wtape(22)
14229  ENDIF
14230 C...f -> g, g -> g.
14231  ELSEIF(kflb.EQ.21) THEN
14232  wtapq=(16d0/3d0)*(sqrt((1d0-xec)/xb)-sqrt((xb+xec)/xb))
14233  DO 180 kfl=1,mstp(58)
14234  wtapc(kfl)=wtapq
14235  wtapc(-kfl)=wtapq
14236  180 CONTINUE
14237  wtapc(21)=6d0*log((1d0-xec-xb)/xec)
14238  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
14239  DO 190 kfl=1,mstp(58)
14240  wtapc(kfl)=wtfg*wtapc(kfl)
14241  wtapc(-kfl)=wtfg*wtapc(-kfl)
14242  190 CONTINUE
14243  wtapc(21)=wtgg*wtapc(21)
14244  ENDIF
14245 C...f -> gamma, W+, W-.
14246  ELSEIF(kflb.EQ.22) THEN
14247  wtapf=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))/xb
14248  wtape(11)=wtapf
14249  wtape(-11)=wtapf
14250  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
14251  wtape(11)=wtfg*wtape(11)
14252  wtape(-11)=wtfg*wtape(-11)
14253  ENDIF
14254  ELSEIF(kflb.EQ.24) THEN
14255  wtape(-11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
14256  & (xee*(xb+xee)))/xb
14257  ELSEIF(kflb.EQ.-24) THEN
14258  wtape(11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
14259  & (xee*(xb+xee)))/xb
14260  ENDIF
14261 
14262 C...Calculate parton distribution weights and sum.
14263  ntry=0
14264  200 ntry=ntry+1
14265  IF(ntry.GT.500) THEN
14266  mint(51)=1
14267  RETURN
14268  ENDIF
14269  wtsumc=0d0
14270  wtsume=0d0
14271  xfbo=max(1d-10,xfb(kflb))
14272  DO 210 kfl=-25,25
14273  wtsf(kfl)=xfb(kfl)/xfbo
14274  wtsumc=wtsumc+wtapc(kfl)*wtsf(kfl)
14275  wtsume=wtsume+wtape(kfl)*wtsf(kfl)
14276  210 CONTINUE
14277  wtsumc=max(0.0001d0,wtsumc)
14278  wtsume=max(0.0001d0/fwte,wtsume)
14279 
14280 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14281  ntry2=0
14282  220 ntry2=ntry2+1
14283  IF(ntry2.GT.500) THEN
14284  mint(51)=1
14285  RETURN
14286  ENDIF
14287  IF(mcev.EQ.1) THEN
14288  IF(mstp(64).LE.0) THEN
14289  tevcb=tevcb+log(pyr(0))*paru(2)/(paru(111)*wtsumc)
14290  ELSEIF(mstp(64).EQ.1) THEN
14291  tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/wtsumc))
14292  ELSE
14293  tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/(5d0*wtsumc)))
14294  ENDIF
14295  ENDIF
14296  IF(meev.EQ.1) THEN
14297  teveb=teveb*exp(max(-50d0,log(pyr(0))*paru(2)/
14298  & (paru(101)*fwte*wtsume*temx)))
14299  ELSEIF(meev.EQ.2) THEN
14300  teveb=teveb+log(pyr(0))*paru(2)/(paru(101)*wtsume)
14301  ENDIF
14302 
14303 C...Translate t into Q2 scale; choose between QCD and QED evolution.
14304  230 IF(mcev.EQ.1) q2cb=alam(jt)**2*exp(max(-50d0,tevcb))/fq2c
14305  IF(meev.EQ.1) q2eb=spme*exp(max(-50d0,teveb))
14306  IF(meev.EQ.2) q2eb=alam(jt)**2*exp(max(-50d0,teveb))/fq2c
14307 C...Ensure that Q2 is above threshold for charm/bottom.
14308  kflcb=iabs(kflb)
14309  IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5).AND.
14310  &mcev.EQ.1) THEN
14311  IF(q2cb.LT.pmas(kflcb,1)**2) THEN
14312  q2cb=1.1d0*pmas(kflcb,1)**2
14313  tevcb=log(fq2c*q2b/alam(jt)**2)
14314  fcq2mx=min(2d0,1.05d0*fcq2mx)
14315  ENDIF
14316  ENDIF
14317  IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5).AND.
14318  &meev.EQ.2) THEN
14319  IF(q2eb.LT.pmas(kflcb,1)**2) meev=0
14320  ENDIF
14321  mce=0
14322  IF(mcev.EQ.0.AND.meev.EQ.0) THEN
14323  ELSEIF(mcev.EQ.1.AND.meev.EQ.0) THEN
14324  IF(q2cb.GT.q2mncs(jt)) mce=1
14325  ELSEIF(mcev.EQ.0.AND.meev.EQ.1) THEN
14326  IF(q2eb.GT.q2mne) mce=2
14327  ELSEIF(mcev.EQ.0.AND.meev.EQ.2) THEN
14328  IF(q2eb.GT.q2mncs(jt)) mce=2
14329  ELSEIF(mcev.EQ.1.AND.meev.EQ.2) THEN
14330  IF(q2cb.GT.q2eb.AND.q2cb.GT.q2mncs(jt)) mce=1
14331  IF(q2eb.GT.q2cb.AND.q2eb.GT.q2mncs(jt)) mce=2
14332  ELSEIF(q2mncs(jt).GT.q2mne) THEN
14333  mce=1
14334  IF(q2eb.GT.q2cb.OR.q2cb.LE.q2mncs(jt)) mce=2
14335  IF(mce.EQ.2.AND.q2eb.LE.q2mne) mce=0
14336  ELSE
14337  mce=2
14338  IF(q2cb.GT.q2eb.OR.q2eb.LE.q2mne) mce=1
14339  IF(mce.EQ.1.AND.q2cb.LE.q2mncs(jt)) mce=0
14340  ENDIF
14341 
14342 C...Evolution possibly ended. Update t values.
14343  IF(mce.EQ.0) THEN
14344  q2b=0d0
14345  goto 260
14346  ELSEIF(mce.EQ.1) THEN
14347  q2b=q2cb
14348  q2ref=fq2c*q2b
14349  IF(meev.EQ.1) teveb=log(q2b/spme)
14350  IF(meev.EQ.2) teveb=log(fq2c*q2b/alam(jt)**2)
14351  ELSE
14352  q2b=q2eb
14353  q2ref=q2b
14354  IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
14355  ENDIF
14356 
14357 C...Select flavour for branching parton.
14358  IF(mce.EQ.1) wtran=pyr(0)*wtsumc
14359  IF(mce.EQ.2) wtran=pyr(0)*wtsume
14360  kfla=-25
14361  240 kfla=kfla+1
14362  IF(mce.EQ.1) wtran=wtran-wtapc(kfla)*wtsf(kfla)
14363  IF(mce.EQ.2) wtran=wtran-wtape(kfla)*wtsf(kfla)
14364  IF(kfla.LE.24.AND.wtran.GT.0d0) goto 240
14365  IF(kfla.EQ.25) THEN
14366  q2b=0d0
14367  goto 260
14368  ENDIF
14369 
14370 C...Choose z value and corrective weight.
14371  wtz=0d0
14372 C...q -> q + g or q -> q + gamma.
14373  IF(iabs(kfla).LE.10.AND.iabs(kflb).LE.10) THEN
14374  z=1d0-((1d0-xb-xec)/(1d0-xec))*
14375  & (xec*(1d0-xec)/((xb+xec)*(1d0-xb-xec)))**pyr(0)
14376  wtz=0.5d0*(1d0+z**2)
14377 C...q -> g + q.
14378  ELSEIF(iabs(kfla).LE.10.AND.kflb.EQ.21) THEN
14379  z=xb/(sqrt(xb+xec)+pyr(0)*(sqrt(1d0-xec)-sqrt(xb+xec)))**2
14380  wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
14381 C...f -> f + gamma.
14382  ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
14383  IF(wtapf1.GT.pyr(0)*(wtapf1+wtapf2)) THEN
14384  z=1d0-((1d0-xb-xee)/(1d0-xee))*
14385  & (xee*(1d0-xee)/((xb+xee)*(1d0-xb-xee)))**pyr(0)
14386  ELSE
14387  z=xb+xb*(xee/(1d0-xee))*
14388  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14389  ENDIF
14390  wtz=0.5d0*(1d0+z**2)*(z-xb)/(1d0-xb)
14391 C...f -> gamma + f.
14392  ELSEIF(iabs(kfla).LE.20.AND.kflb.EQ.22) THEN
14393  z=xb+xb*(xee/(1d0-xee))*
14394  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14395  wtz=0.5d0*(1d0+(1d0-z)**2)*xb*(z-xb)/z
14396 C...f -> W+- + f.
14397  ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).EQ.24) THEN
14398  z=xb+xb*(xee/(1d0-xee))*
14399  & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14400  wtz=0.5d0*(1d0+(1d0-z)**2)*(xb*(z-xb)/z)*
14401  & (q2b/(q2b+pmas(24,1)**2))
14402 C...g -> q + qbar.
14403  ELSEIF(kfla.EQ.21.AND.iabs(kflb).LE.10) THEN
14404  z=xb/(1d0-xec)+pyr(0)*(xb/(xb+xec)-xb/(1d0-xec))
14405  wtz=1d0-2d0*z*(1d0-z)
14406 C...g -> g + g.
14407  ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
14408  z=1d0/(1d0+((1d0-xec-xb)/xb)*(xec/(1d0-xec-xb))**pyr(0))
14409  wtz=(1d0-z*(1d0-z))**2
14410 C...gamma -> f + fbar.
14411  ELSEIF(kfla.EQ.22.AND.iabs(kflb).LE.20) THEN
14412  z=xb/(1d0-xee)+pyr(0)*(xb/(xb+xee)-xb/(1d0-xee))
14413  wtz=1d0-2d0*z*(1d0-z)
14414  ENDIF
14415  IF(mce.EQ.2.AND.meev.EQ.1) wtz=(wtz/fwte)*(teveb/temx)
14416 
14417 C...Option with resummation of soft gluon emission as effective z shift.
14418  IF(mce.EQ.1) THEN
14419  IF(mstp(65).GE.1) THEN
14420  rsoft=6d0
14421  IF(kflb.NE.21) rsoft=8d0/3d0
14422  z=z*(tevcb/tevcsv(jt))**(rsoft*xec/((xb+xec)*b0))
14423  IF(z.LE.xb) goto 220
14424  ENDIF
14425 
14426 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14427  IF(mstp(64).GE.2) THEN
14428  IF((1d0-z)*q2b.LT.q2mncs(jt)) goto 220
14429  alprat=tevcb/(tevcb+log(1d0-z))
14430  IF(alprat.LT.5d0*pyr(0)) goto 220
14431  IF(alprat.GT.5d0) wtz=wtz*alprat/5d0
14432  ENDIF
14433  ENDIF
14434 
14435 C...Remove kinematically impossible branchings.
14436  uhat=q2b-dsh*(1d0-z)/z
14437  IF(mstp(68).GE.0.AND.uhat.GT.0d0) goto 220
14438 
14439 C...Select phi angle of branching at random.
14440  phibr=paru(2)*pyr(0)
14441 
14442 C...Matrix-element corrections for some processes.
14443  IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
14444  IF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
14445  CALL pymewt(mecor,1,q2b,z,phibr,wtme)
14446  wtz=wtz*wtme/wtff
14447  ELSEIF((kfla.EQ.21.OR.kfla.EQ.22).AND.iabs(kflb).LE.20) THEN
14448  CALL pymewt(mecor,2,q2b,z,phibr,wtme)
14449  wtz=wtz*wtme/wtgf
14450  ELSEIF(iabs(kfla).LE.20.AND.(kflb.EQ.21.OR.kflb.EQ.22)) THEN
14451  CALL pymewt(mecor,3,q2b,z,phibr,wtme)
14452  wtz=wtz*wtme/wtfg
14453  ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
14454  CALL pymewt(mecor,4,q2b,z,phibr,wtme)
14455  wtz=wtz*wtme/wtgg
14456  ENDIF
14457  ENDIF
14458 
14459 C...Impose angular constraint in first branching from interference
14460 C...with final state partons.
14461  IF(mce.EQ.1) THEN
14462  IF(mfis.GE.1.AND.n.LE.ns+2.AND.ntry2.LT.200) THEN
14463  the2d=(4d0*q2b)/(dsh*(1d0-z))
14464  IF(n.EQ.ns+1.AND.isfi(1).GE.1) THEN
14465  IF(the2d.GT.thefis(1,isfi(1))**2) goto 220
14466  ELSEIF(n.EQ.ns+2.AND.isfi(2).GE.1) THEN
14467  IF(the2d.GT.thefis(2,isfi(2))**2) goto 220
14468  ENDIF
14469  ENDIF
14470 
14471 C...Option with angular ordering requirement.
14472  IF(mstp(62).GE.3.AND.ntry2.LT.200) THEN
14473  the2t=(4d0*z**2*q2b)/(4d0*z**2*q2b+(1d0-z)*xb**2*vint2r)
14474  IF(the2t.GT.the2(jt)) goto 220
14475  ENDIF
14476  ENDIF
14477 
14478 C...Weighting with new parton distributions.
14479  mint(105)=mint(102+jt)
14480  mint(109)=mint(106+jt)
14481  vint(120)=vint(2+jt)
14482  IF(mint(31).GE.2) mint(30)=jt
14483  IF(mstp(57).LE.1) THEN
14484  CALL pypdfu(kfbeam(jt),xb,q2ref,xfn)
14485  ELSE
14486  CALL pypdfl(kfbeam(jt),xb,q2ref,xfn)
14487  ENDIF
14488  xfbn=xfn(kflb)
14489  IF(xfbn.LT.1d-20) THEN
14490  IF(kfla.EQ.kflb) THEN
14491  tevcb=tevcbs
14492  teveb=tevebs
14493  wtapc(kflb)=0d0
14494  wtape(kflb)=0d0
14495  goto 200
14496  ELSEIF(mce.EQ.1.AND.tevcbs-tevcb.GT.0.2d0) THEN
14497  tevcb=0.5d0*(tevcbs+tevcb)
14498  goto 230
14499  ELSEIF(mce.EQ.2.AND.tevebs-teveb.GT.0.2d0) THEN
14500  teveb=0.5d0*(tevebs+teveb)
14501  goto 230
14502  ELSE
14503  xfbn=1d-10
14504  xfn(kflb)=xfbn
14505  ENDIF
14506  ENDIF
14507  DO 250 kfl=-25,25
14508  xfb(kfl)=xfn(kfl)
14509  250 CONTINUE
14510  xa=xb/z
14511  IF(mint(31).GE.2) mint(30)=jt
14512  IF(mstp(57).LE.1) THEN
14513  CALL pypdfu(kfbeam(jt),xa,q2ref,xfa)
14514  ELSE
14515  CALL pypdfl(kfbeam(jt),xa,q2ref,xfa)
14516  ENDIF
14517  xfan=xfa(kfla)
14518  IF(xfan.LT.1d-20) goto 200
14519  wtsfa=wtsf(kfla)
14520  IF(wtz*xfan/xfbn.LT.pyr(0)*wtsfa) goto 200
14521 
14522 C...Define two hard scatterers in their CM-frame.
14523  260 IF(n.EQ.ns+2) THEN
14524  dq2(jt)=q2b
14525  dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr
14526  DO 280 jr=1,2
14527  i=ns+jr
14528  IF(jr.EQ.1) ipo=ipus1
14529  IF(jr.EQ.2) ipo=ipus2
14530  DO 270 j=1,5
14531  k(i,j)=0
14532  p(i,j)=0d0
14533  v(i,j)=0d0
14534  270 CONTINUE
14535  k(i,1)=14
14536  k(i,2)=kfls(jr+2)
14537  k(i,4)=ipo
14538  k(i,5)=ipo
14539  p(i,3)=dplcm*(-1)**(jr+1)
14540  p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr
14541  p(i,5)=-sqrt(dq2(jr))
14542  k(ipo,1)=14
14543  k(ipo,3)=i
14544  k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i
14545  k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i
14546  mct(i,1)=mct(ipo,1)
14547  mct(i,2)=mct(ipo,2)
14548  280 CONTINUE
14549 
14550 C...Find maximum allowed mass of timelike parton.
14551  ELSEIF(n.GT.ns+2) THEN
14552  jr=3-jt
14553  dq2(3)=q2b
14554  dpc(1)=p(is(1),4)
14555  dpc(2)=p(is(2),4)
14556  dpc(3)=0.5d0*(abs(p(is(1),3))+abs(p(is(2),3)))
14557  dpd(1)=dsh+dq2(jr)+dq2(jt)
14558  dpd(2)=dshz+dq2(jr)+dq2(3)
14559  dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))
14560  dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))
14561  ikin=0
14562  IF(q2s(jr).GE.0.25d0*q2mnc.AND.dpd(1)-dpd(3).GE.
14563  & 1d-10*dpd(1)) ikin=1
14564  IF(ikin.EQ.0) dmsma=(dq2(jt)/zs(jt)-dq2(3))*
14565  & (dsh/(dsh+dq2(jt))-dsh/(dshz+dq2(3)))
14566  IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/
14567  & (2d0*dq2(jr))-dq2(jt)-dq2(3)
14568 
14569 C...Generate timelike parton shower (if required).
14570  it=n
14571  DO 290 j=1,5
14572  k(it,j)=0
14573  p(it,j)=0d0
14574  v(it,j)=0d0
14575  290 CONTINUE
14576 C...f -> f + g (gamma).
14577  IF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).LE.20) THEN
14578  k(it,2)=21
14579  IF(mcesv(jt).EQ.2.OR.iabs(kflb).GE.11) k(it,2)=22
14580 C...f -> g (gamma, W+-) + f.
14581  ELSEIF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).GT.20) THEN
14582  k(it,2)=kflb
14583  IF(kfls(jt+2).EQ.24) THEN
14584  k(it,2)=-12
14585  ELSEIF(kfls(jt+2).EQ.-24) THEN
14586  k(it,2)=12
14587  ENDIF
14588 C...g (gamma) -> f + fbar, g + g.
14589  ELSE
14590  k(it,2)=-kfls(jt+2)
14591  IF(kfls(jt+2).GT.20) k(it,2)=kfls(jt+2)
14592  ENDIF
14593  k(it,1)=3
14594  IF((iabs(k(it,2)).GE.11.AND.iabs(k(it,2)).LE.18).OR.
14595  & iabs(k(it,2)).EQ.22) k(it,1)=1
14596  p(it,5)=pymass(k(it,2))
14597  IF(dmsma.LE.p(it,5)**2) goto 100
14598  IF(mstp(63).GE.1.AND.mcesv(jt).EQ.1) THEN
14599  mstj48=mstj(48)
14600  parj85=parj(85)
14601  p(it,4)=(dshz-dsh-p(it,5)**2)/dshr
14602  p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)
14603  IF(mstp(63).EQ.1) THEN
14604  q2tim=dmsma
14605  ELSEIF(mstp(63).EQ.2) THEN
14606  q2tim=min(dmsma,parp(71)*q2s(jt))
14607  ELSE
14608  q2tim=dmsma
14609  mstj(48)=1
14610  IF(ikin.EQ.0) dpt2=dmsma*(dshz+dq2(3))/(dsh+dq2(jt))
14611  IF(ikin.EQ.1) dpt2=dmsma*(0.5d0*dpd(1)*dpd(2)+0.5d0*dpd(3)*
14612  & dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)))/(4d0*dsh*dpc(3)**2)
14613  parj(85)=sqrt(max(0d0,dpt2))*
14614  & (1d0/p(it,4)+1d0/p(is(jt),4))
14615  ENDIF
14616 C...Only do timelike shower here if using PYSHOW
14617  IF (mstj(41).NE.11.AND.mstj(41).NE.12) THEN
14618  CALL pyshow(it,0,sqrt(q2tim))
14619  ENDIF
14620  mstj(48)=mstj48
14621  parj(85)=parj85
14622  IF(n.GE.it+1) p(it,5)=p(it+1,5)
14623  ENDIF
14624 
14625 C...Reconstruct kinematics of branching: timelike parton shower.
14626  dms=p(it,5)**2
14627  IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))
14628  IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5d0*dpd(1)*dpd(2)+
14629  & 0.5d0*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/
14630  & (4d0*dsh*dpc(3)**2)
14631  IF(dpt2.LT.0d0) goto 100
14632  dpb(1)=(0.5d0*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/
14633  & dshr)/dpc(3)-dpc(3)
14634  p(it,1)=sqrt(dpt2)
14635  p(it,3)=dpb(1)*(-1)**(jt+1)
14636  p(it,4)=sqrt(dpt2+dpb(1)**2+dms)
14637  IF(n.GE.it+1) THEN
14638  dpb(1)=sqrt(dpb(1)**2+dpt2)
14639  dpb(2)=sqrt(dpb(1)**2+dms)
14640  dpb(3)=p(it+1,3)
14641  dpb(4)=sqrt(dpb(3)**2+dms)
14642  dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*
14643  & dpb(1))
14644  CALL pyrobo(it+1,n,0d0,0d0,0d0,0d0,dbez)
14645  the=pyangl(p(it,3),p(it,1))
14646  CALL pyrobo(it+1,n,the,0d0,0d0,0d0,0d0)
14647  ENDIF
14648 
14649 C...Reconstruct kinematics of branching: spacelike parton.
14650  DO 300 j=1,5
14651  k(n+1,j)=0
14652  p(n+1,j)=0d0
14653  v(n+1,j)=0d0
14654  300 CONTINUE
14655  k(n+1,1)=14
14656  k(n+1,2)=kflb
14657  p(n+1,1)=p(it,1)
14658  p(n+1,3)=p(it,3)+p(is(jt),3)
14659  p(n+1,4)=p(it,4)+p(is(jt),4)
14660  p(n+1,5)=-sqrt(dq2(3))
14661  mct(n+1,1)=0
14662  mct(n+1,2)=0
14663 
14664 C...Define colour flow of branching.
14665  k(is(jt),3)=n+1
14666  k(it,3)=n+1
14667  im1=n+1
14668  im2=n+1
14669 C...f -> f + gamma (Z, W).
14670  IF(iabs(k(it,2)).GE.22) THEN
14671  k(it,1)=1
14672  id1=is(jt)
14673  id2=is(jt)
14674 C...f -> gamma (Z, W) + f.
14675  ELSEIF(iabs(k(is(jt),2)).GE.22) THEN
14676  id1=it
14677  id2=it
14678 C...gamma -> q + qbar, g + g.
14679  ELSEIF(k(n+1,2).EQ.22) THEN
14680  id1=is(jt)
14681  id2=it
14682  im1=id2
14683  im2=id1
14684 C...q -> q + g.
14685  ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(it,2).EQ.21) THEN
14686  id1=it
14687  id2=is(jt)
14688 C...q -> g + q.
14689  ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21) THEN
14690  id1=is(jt)
14691  id2=it
14692 C...qbar -> qbar + g.
14693  ELSEIF(k(n+1,2).LT.0.AND.k(it,2).EQ.21) THEN
14694  id1=is(jt)
14695  id2=it
14696 C...qbar -> g + qbar.
14697  ELSEIF(k(n+1,2).LT.0) THEN
14698  id1=it
14699  id2=is(jt)
14700 C...g -> g + g; g -> q + qbar.
14701  ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
14702  id1=is(jt)
14703  id2=it
14704  ELSE
14705  id1=it
14706  id2=is(jt)
14707  ENDIF
14708  IF(im1.EQ.n+1) k(im1,4)=k(im1,4)+id1
14709  IF(im2.EQ.n+1) k(im2,5)=k(im2,5)+id2
14710  k(id1,4)=k(id1,4)+mstu(5)*im1
14711  k(id2,5)=k(id2,5)+mstu(5)*im2
14712  IF(id1.NE.id2) THEN
14713  k(id1,5)=k(id1,5)+mstu(5)*id2
14714  k(id2,4)=k(id2,4)+mstu(5)*id1
14715  ENDIF
14716  n=n+1
14717  IF(k(it,1).EQ.1) THEN
14718  k(it,4)=0
14719  k(it,5)=0
14720  ENDIF
14721 
14722 C...Boost to new CM-frame.
14723  dbsvx=(p(n,1)+p(is(jr),1))/(p(n,4)+p(is(jr),4))
14724  dbsvz=(p(n,3)+p(is(jr),3))/(p(n,4)+p(is(jr),4))
14725  IF(dbsvx**2+dbsvz**2.GE.1d0) goto 100
14726  CALL pyrobo(ns+1,n,0d0,0d0,-dbsvx,0d0,-dbsvz)
14727  ir=n+(jt-1)*(is(1)-n)
14728  CALL pyrobo(ns+1,n,-pyangl(p(ir,3),p(ir,1)),dphi(jt),
14729  & 0d0,0d0,0d0)
14730 
14731 C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14732  IF (mstj(41).EQ.11.OR.mstj(41).EQ.12) THEN
14733  npart=npart+1
14734  ipart(npart)=it
14735  ptpart(npart)=sqrt(parp(71)*dpt2)
14736  ENDIF
14737 
14738 C...Global statistics.
14739  mint(352)=mint(352)+1
14740  vint(352)=vint(352)+sqrt(p(it,1)**2+p(it,2)**2)
14741  IF (mint(352).EQ.1) vint(357)=sqrt(p(it,1)**2+p(it,2)**2)
14742 
14743  ENDIF
14744 
14745 C...Update kinematics variables.
14746  is(jt)=n
14747  dq2(jt)=q2b
14748  IF(mstp(62).GE.3.AND.ntry2.LT.200.AND.mce.EQ.1) the2(jt)=the2t
14749  dsh=dshz
14750 
14751 C...Save quantities; loop back.
14752  q2s(jt)=q2b
14753  dphi(jt)=phibr
14754  mcesv(jt)=mce
14755  IF((mcev.EQ.1.AND.q2b.GE.0.25d0*q2mnc).OR.
14756  &(meev.EQ.1.AND.q2b.GE.q2mne)) THEN
14757  kfls(jt+2)=kfls(jt)
14758  kfls(jt)=kfla
14759  xs(jt)=xa
14760  zs(jt)=z
14761  DO 310 kfl=-25,25
14762  xfs(jt,kfl)=xfa(kfl)
14763  310 CONTINUE
14764  tevcsv(jt)=tevcb
14765  tevesv(jt)=teveb
14766  ELSE
14767  more(jt)=0
14768  IF(jt.EQ.1) ipu1=n
14769  IF(jt.EQ.2) ipu2=n
14770  ENDIF
14771  IF(n.GT.mstu(4)-mstu(32)-10) THEN
14772  CALL pyerrm(11,'(PYSSPA:) no more memory left in PYJETS')
14773  IF(mstu(21).GE.1) n=ns
14774  IF(mstu(21).GE.1) RETURN
14775  ENDIF
14776  IF(more(1).EQ.1.OR.more(2).EQ.1) goto 150
14777 
14778 C...Boost hard scattering partons to frame of shower initiators.
14779  DO 320 j=1,3
14780  robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4))
14781  320 CONTINUE
14782  k(n+2,1)=1
14783  DO 330 j=1,5
14784  p(n+2,j)=p(ns+1,j)
14785  330 CONTINUE
14786  CALL pyrobo(n+2,n+2,0d0,0d0,-robo(3),-robo(4),-robo(5))
14787  robo(2)=pyangl(p(n+2,1),p(n+2,2))
14788  robo(1)=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
14789  imin=mint(83)+5
14790  IF(mint(31).GE.2) imin=min(ipus1,ipus2)
14791  CALL pyrobo(imin,ns,0d0,-robo(2),0d0,0d0,0d0)
14792  CALL pyrobo(imin,ns,robo(1),robo(2),robo(3),robo(4),robo(5))
14793 
14794 C...Store user information. Reset Lambda value.
14795  IF(mint(31).LE.1) THEN
14796  k(ipu1,3)=mint(83)+3
14797  k(ipu2,3)=mint(83)+4
14798  ELSE
14799  k(ipu1,3)=mint(83)+1
14800  k(ipu2,3)=mint(83)+2
14801  ENDIF
14802  DO 340 jt=1,2
14803  mint(12+jt)=kfls(jt)
14804  vint(140+jt)=xs(jt)
14805  IF(mint(18+jt).EQ.1) vint(140+jt)=vint(154+jt)*xs(jt)
14806  IF(mint(31).GE.2) vint(140+jt)=vint(140+jt)*vint(142+jt)
14807  340 CONTINUE
14808  paru(112)=alams
14809 
14810  RETURN
14811  END
14812 
14813 C*********************************************************************
14814 
14815 C...PYPTIS
14816 C...Generates pT-ordered spacelike initial-state parton showers and
14817 C...trial joinings.
14818 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14819 C... interaction initiators at PT2NOW.
14820 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14821 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14822 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14823 C... is below PT2CUT.
14824 C... (Also generate test joinings if MSTP(96)=1.)
14825 C...MODE= 1: Accept stored shower branching. Update event record etc.
14826 C...PT2NOW : Starting (max) PT2 scale for evolution.
14827 C...PT2CUT : Lower limit for evolution.
14828 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14829 C...IFAIL : Status return code. IFAIL=0 when all is well.
14830 
14831  SUBROUTINE pyptis(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14832 
14833 C...Double precision and integer declarations.
14834  IMPLICIT DOUBLE PRECISION(a-h, o-z)
14835  IMPLICIT INTEGER(i-n)
14836  INTEGER pyk,pychge,pycomp
14837 C...Parameter statement for maximum size of showers.
14838  parameter(maxnur=1000)
14839 C...Commonblocks.
14840  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
14841  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
14842  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
14843  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
14844  common/pypars/mstp(200),parp(200),msti(200),pari(200)
14845  common/pyint1/mint(400),vint(400)
14846  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
14847  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
14848  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
14849  & xmi(2,240),pt2mi(240),imisep(0:240)
14850  common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
14851  & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
14852  common/pyctag/nct,mct(4000,2)
14853  common/pyisjn/mjn1mx,mjn2mx,mjoind(2,240)
14854  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,
14855  & /pyint2/,/pyintm/,/pyismx/,/pyctag/,/pyisjn/
14856 C...Local variables
14857  dimension zsav(2,240),pt2sav(2,240),
14858  & xfb(-25:25),xfa(-25:25),xfn(-25:25),xfj(-25:25),
14859  & wtap(-25:25),wtpdf(-25:25),shtnow(240),
14860  & wtapj(240),wtpdfj(240),x1(240),y(240)
14861  SAVE zsav,pt2sav,xfb,xfa,xfn,wtap,wtpdf,xmxc,shtnow,
14862  & rmb2,rmc2,alam3,alam4,alam5,tmin,ptemax,wtemax,aem2pi
14863 C...For check on excessive weights.
14864  CHARACTER chwt*12
14865 
14866 C...Only give errors for very large weights, otherwise just warnings
14867  DATA wtemax /1.5d0/
14868 C...Only give errors for large pT, otherwise just warnings
14869  DATA ptemax /5d0/
14870 
14871  ifail=-1
14872 
14873 C----------------------------------------------------------------------
14874 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14875 C...starting from the hardest interaction initiators.
14876  IF (mode.EQ.-1) THEN
14877 C...Set hard scattering SHAT.
14878  shtnow(1)=vint(44)
14879 C...Mass thresholds and Lambda for QCD evolution.
14880  aem2pi=paru(101)/paru(2)
14881  rmb=pmas(5,1)
14882  rmc=pmas(4,1)
14883  alam4=parp(61)
14884  IF(mstu(112).LT.4) alam4=parp(61)*(parp(61)/rmc)**(2d0/25d0)
14885  IF(mstu(112).GT.4) alam4=parp(61)*(rmb/parp(61))**(2d0/25d0)
14886  alam5=alam4*(alam4/rmb)**(2d0/23d0)
14887  alam3=alam4*(rmc/alam4)**(2d0/27d0)
14888 C...Optionally use Lambda_MC = Lambda_CMW
14889  IF (mstp(64).EQ.3) THEN
14890  alam5 = alam5 * 1.569
14891  alam4 = alam4 * 1.618
14892  alam3 = alam3 * 1.661
14893  ENDIF
14894  rmb2=rmb**2
14895  rmc2=rmc**2
14896 C...Massive quark forced creation threshold (in M**2).
14897  tmin=1.01d0
14898 C...Set upper limit for X (ensures some X left for beam remnant).
14899  xmxc=1d0-2d0*parp(111)/vint(1)
14900 
14901  IF (mstp(61).GE.1) THEN
14902 C...Initial values: flavours, momenta, virtualities.
14903  DO 100 js=1,2
14904  nisgen(js,1)=0
14905 
14906 C...Special kinematics check for c/b quarks (that g -> c cbar or
14907 C...b bbar kinematically possible).
14908  kflb=k(imi(js,1,1),2)
14909  kflcb=iabs(kflb)
14910  IF(kfbeam(js).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5)) THEN
14911 C...Check PT2MAX > mQ^2
14912  IF (vint(56).LT.1.05d0*pmas(pycomp(kflcb),1)**2) THEN
14913  CALL pyerrm(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14914  & 'No Q creation possible.')
14915  mint(51)=1
14916  RETURN
14917  ELSE
14918 C...Check for physical z values (m == MQ / sqrt(s))
14919 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14920  fmq=pmas(kflcb,1)/sqrt(shtnow(1))
14921  zmxcr=(1d0-fmq)/(1d0+fmq*(1d0-fmq))
14922  IF (xmi(js,1).GT.0.9d0*zmxcr) THEN
14923  CALL pyerrm(9,'(PYPTIS:) No physical z value for '//
14924  & 'Q creation.')
14925  mint(51)=1
14926  RETURN
14927  ENDIF
14928  ENDIF
14929  ENDIF
14930  100 CONTINUE
14931  ENDIF
14932 
14933  mint(354)=0
14934 C...Zero joining array
14935  DO 110 mj=1,240
14936  mjoind(1,mj)=0
14937  mjoind(2,mj)=0
14938  110 CONTINUE
14939 
14940 C----------------------------------------------------------------------
14941 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14942 C...MINT(30). Store if emission PT2 scale is largest so far.
14943 C...Also generate test joinings if MSTP(96)=1.
14944  ELSEIF(mode.EQ.0) THEN
14945  ifail=-1
14946  mecor=0
14947  isub=mint(1)
14948  js=mint(30)
14949 C...No shower for structureless beam
14950  IF (mint(44+js).EQ.1) RETURN
14951  mi=mint(36)
14952  shat=vint(44)
14953 C...Absolute shower max scale = VINT(56)
14954  IF (mstp(67).NE.0) THEN
14955  pt2 = min(pt2now,vint(56))
14956  ELSE
14957 C...For MSTP(67)=0, adjust starting scale by PARP(67)
14958  pt2=min(pt2now,parp(67)*vint(56))
14959  ENDIF
14960  IF (nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) shtnow(mi)=shat
14961 C...Define for which processes ME corrections have been implemented.
14962  IF(mstp(68).EQ.1.OR.mstp(68).EQ.3) THEN
14963  IF(isub.EQ.1.OR.isub.EQ.2.OR.isub.EQ.141.OR.isub.eq
14964  & .142.OR.isub.EQ.144) mecor=1
14965  IF(isub.EQ.102.OR.isub.EQ.152.OR.isub.EQ.157) mecor=2
14966  IF(isub.EQ.3.OR.isub.EQ.151.OR.isub.EQ.156) mecor=3
14967 C...Calculate preweighting factor for ME-corrected processes.
14968  IF(mecor.GE.1) CALL pymemx(mecor,wtff,wtgf,wtfg,wtgg)
14969  ENDIF
14970 C...Basic info on daughter for which to find mother.
14971  kflb=k(imi(js,mi,1),2)
14972  kflba=iabs(kflb)
14973 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14974 C...second companion.
14975  ksvcb=max(-1,imi(js,mi,2))
14976 C...Treat "first" companion of a pair like an ordinary sea quark
14977 C...(except that creation diagram is not allowed)
14978  IF(imi(js,mi,2).GT.imisep(mi)) ksvcb=-1
14979 C...X (rescaled to [0,1])
14980  xb=xmi(js,mi)/vint(142+js)
14981 C...Massive quarks (use physical masses.)
14982  rmq2=0d0
14983  mqmass=0
14984  IF (kflba.EQ.4.OR.kflba.EQ.5) THEN
14985  rmq2=rmc2
14986  IF (kflba.EQ.5) rmq2=rmb2
14987 C...Special threshold treatment for non-photon beams
14988  IF (kfbeam(js).NE.22) mqmass=kflba
14989 C...Check that not below mass threshold.
14990  IF(mqmass.GT.0.AND.pt2.LT.tmin*rmq2) THEN
14991  CALL pyerrm(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '//
14992  & 'No Q creation possible.')
14993  mint(51)=1
14994 C...Special return code if failing before any evolution at all: bad event
14995  IF (nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) mint(51)=2
14996  RETURN
14997  ENDIF
14998 
14999  ENDIF
15000 
15001 C...Flags for parton distribution calls.
15002  mint(105)=mint(102+js)
15003  mint(109)=mint(106+js)
15004  vint(120)=vint(2+js)
15005 
15006 C...Calculate initial parton distribution weights.
15007  IF(xb.GE.xmxc) THEN
15008  RETURN
15009  ELSEIF(mqmass.EQ.0) THEN
15010  CALL pypdfu(kfbeam(js),xb,pt2,xfb)
15011  ELSE
15012 C...Initialize massive quark PT2 dependent pdf underestimate.
15013  pt20=pt2
15014  CALL pypdfu(kfbeam(js),xb,pt20,xfb)
15015 C.!.Tentative treatment of massive valence quarks.
15016  xq0=max(1d-10,xpsvc(kflb,ksvcb))
15017  xg0=xfb(21)
15018  tpm0=log(pt20/rmq2)
15019  wpdf0=tpm0*xg0/xq0
15020  ENDIF
15021  IF (kflba.LE.6) THEN
15022 C...For quarks, only include respective sea, val, or cmp part.
15023  IF (ksvcb.LE.0) THEN
15024  xfb(kflb)=xpsvc(kflb,ksvcb)
15025  ELSE
15026 C...Find companion's companion
15027  misea=0
15028  120 misea=misea+1
15029  IF (imi(js,misea,2).NE.imi(js,mi,1)) goto 120
15030  xs=xmi(js,misea)
15031  xrem=vint(142+js)
15032  ys=xs/(xrem+xs)
15033 C...Momentum fraction of the companion quark.
15034 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
15035  yb=xb*(1d0-ys)
15036  xfb(kflb)=pyfcmp(yb/vint(140),ys/vint(140),mstp(87))
15037  ENDIF
15038  ENDIF
15039 
15040 C...Determine overestimated z range: switch at c and b masses.
15041  130 IF (pt2.GT.tmin*rmb2) THEN
15042  izrg=3
15043  pt2mne=max(tmin*rmb2,pt2cut)
15044  b0=23d0/6d0
15045  alam2=alam5**2
15046  ELSEIF(pt2.GT.tmin*rmc2) THEN
15047  izrg=2
15048  pt2mne=max(tmin*rmc2,pt2cut)
15049  b0=25d0/6d0
15050  alam2=alam4**2
15051  ELSE
15052  izrg=1
15053  pt2mne=pt2cut
15054  b0=27d0/6d0
15055  alam2=alam3**2
15056  ENDIF
15057 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
15058  alam2=alam2/parp(64)
15059 C...Overestimated ZMAX:
15060  IF (mqmass.EQ.0) THEN
15061 C...Massless
15062  zmax=1d0-0.5d0*(pt2mne/shtnow(mi))*(sqrt(1d0+4d0*shtnow(mi)
15063  & /pt2mne)-1d0)
15064  ELSE
15065 C...Massive (limit for bremsstrahlung diagram > creation)
15066  fmq=sqrt(rmq2/shtnow(mi))
15067  zmax=1d0/(1d0+fmq)
15068  ENDIF
15069  zmin=xb/xmxc
15070 
15071 C...If kinematically impossible then do not evolve.
15072  IF(pt2.LT.pt2cut.OR.zmax.LE.zmin) RETURN
15073 
15074 C...Reset Altarelli-Parisi and PDF weights.
15075  DO 140 kfl=-5,5
15076  wtap(kfl)=0d0
15077  wtpdf(kfl)=0d0
15078  140 CONTINUE
15079  wtap(21)=0d0
15080  wtpdf(21)=0d0
15081 C...Zero joining weights and compute X(partner) and X(mother) values.
15082  njn=0
15083  IF (mstp(96).NE.0) THEN
15084  DO 150 mj=1,mint(31)
15085  wtapj(mj)=0d0
15086  wtpdfj(mj)=0d0
15087  x1(mj)=xmi(js,mj)/(vint(142+js)+xmi(js,mj))
15088  y(mj)=(xmi(js,mi)+xmi(js,mj))/(vint(142+js)+xmi(js,mj)
15089  & +xmi(js,mi))
15090  150 CONTINUE
15091  ENDIF
15092 
15093 C...Approximate Altarelli-Parisi weights (integrated AP dz).
15094 C...q -> q, g -> q or q -> q + gamma (already set which).
15095  IF(kflba.LE.5) THEN
15096 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
15097  IF (ksvcb.LT.0) THEN
15098  wtap(kflb)=(8d0/3d0)*log((1d0-zmin)/(1d0-zmax))
15099  ELSE
15100  rmin=(1+sqrt(zmin))/(1-sqrt(zmin))
15101  rmax=(1+sqrt(zmax))/(1-sqrt(zmax))
15102  wtap(kflb)=(8d0/3d0)*log(rmax/rmin)
15103  ENDIF
15104  wtap(21)=0.5d0*(zmax-zmin)
15105  wtape=(2d0/9d0)*log((1d0-zmin)/(1d0-zmax))
15106  IF(mod(kflba,2).EQ.0) wtape=4d0*wtape
15107  IF(mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
15108  wtap(kflb)=wtff*wtap(kflb)
15109  wtap(21)=wtgf*wtap(21)
15110  wtape=wtff*wtape
15111  ENDIF
15112  IF(mstp(61).EQ.1) wtape=0d0
15113  IF (ksvcb.GE.1) THEN
15114 C...Kill normal creation but add joining diagrams for cmp quark.
15115  wtap(21)=0d0
15116  IF (kflba.EQ.4.OR.kflba.EQ.5) THEN
15117  CALL pyerrm(9,'(PYPTIS:) Sorry, I got a heavy companion'//
15118  & " quark here. Not handled yet, giving up!")
15119  pt2=0d0
15120  mint(51)=1
15121  RETURN
15122  ENDIF
15123 C...Check for possible joinings
15124  IF (mstp(96).NE.0.AND.mjoind(js,mi).EQ.0) THEN
15125 C...Find companion's companion.
15126  mj=0
15127  160 mj=mj+1
15128  IF (imi(js,mj,2).NE.imi(js,mi,1)) goto 160
15129  IF (mjoind(js,mj).EQ.0) THEN
15130  y(mi)=yb+ys
15131  z=yb/y(mi)
15132  wtapj(mj)=z*(1d0-z)*0.5d0*(z**2+(1d0-z)**2)
15133  IF (wtapj(mj).GT.1d-6) THEN
15134  njn=1
15135  ELSE
15136  wtapj(mj)=0d0
15137  ENDIF
15138  ENDIF
15139 C...Add trial gluon joinings.
15140  DO 170 mj=1,mint(31)
15141  kflc=k(imi(js,mj,1),2)
15142  IF (kflc.NE.21.OR.mjoind(js,mj).NE.0) goto 170
15143  z=xmi(js,mj)/(xmi(js,mi)+xmi(js,mj))
15144  wtapj(mj)=6d0*(z**2+(1d0-z)**2)
15145  IF (wtapj(mj).GT.1d-6) THEN
15146  njn=njn+1
15147  ELSE
15148  wtapj(mj)=0d0
15149  ENDIF
15150  170 CONTINUE
15151  ENDIF
15152  ELSEIF (imi(js,mi,2).GE.0) THEN
15153 C...Kill creation diagram for val quarks and sea quarks with companions.
15154  wtap(21)=0d0
15155  ELSEIF (mqmass.EQ.0) THEN
15156 C...Extra safety factor for massless sea quark creation.
15157  wtap(21)=wtap(21)*1.25d0
15158  ENDIF
15159 
15160 C... q -> g, g -> g.
15161  ELSEIF(kflb.EQ.21) THEN
15162 C...Here we decide later whether a quark picked up is valence or
15163 C...sea, so we maintain the extra factor sqrt(z) since we deal
15164 C...with the *sum* of sea and valence in this context.
15165  wtapq=(16d0/3d0)*(sqrt(1d0/zmin)-sqrt(1d0/zmax))
15166 C...new: do not allow backwards evol to pick up heavy flavour.
15167  DO 180 kfl=1,min(3,mstp(58))
15168  wtap(kfl)=wtapq
15169  wtap(-kfl)=wtapq
15170  180 CONTINUE
15171  wtap(21)=6d0*log(zmax*(1d0-zmin)/(zmin*(1d0-zmax)))
15172  IF(mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
15173  wtapq=wtfg*wtapq
15174  wtap(21)=wtgg*wtap(21)
15175  ENDIF
15176 C...Check for possible joinings (companions handled separately above)
15177  IF (mstp(96).NE.0.AND.mint(31).GE.2.AND.mjoind(js,mi).EQ.0)
15178  & THEN
15179  DO 190 mj=1,mint(31)
15180  IF (mj.EQ.mi.OR.mjoind(js,mj).NE.0) goto 190
15181  ksvcc=imi(js,mj,2)
15182  IF (imi(js,mj,2).GT.imisep(mj)) ksvcc=-1
15183  IF (ksvcc.GE.1) goto 190
15184  kflc=k(imi(js,mj,1),2)
15185 C...Only try g -> g + g once.
15186  IF (mj.GT.mi.AND.kflc.EQ.21) goto 190
15187  z=xmi(js,mj)/(xmi(js,mi)+xmi(js,mj))
15188  IF (kflc.EQ.21) THEN
15189  wtapj(mj)=6d0*(z**2+(1d0-z)**2)
15190  ELSE
15191  wtapj(mj)=z*4d0/3d0*(1d0+z**2)
15192  ENDIF
15193  IF (wtapj(mj).GT.1d-6) THEN
15194  njn=njn+1
15195  ELSE
15196  wtapj(mj)=0d0
15197  ENDIF
15198  190 CONTINUE
15199  ENDIF
15200  ENDIF
15201 
15202 C...Initialize massive quark evolution
15203  IF (mqmass.NE.0) THEN
15204  rml=(rmq2+vint(18))/alam2
15205  tml=log(rml)
15206  tpl=log((pt2+vint(18))/alam2)
15207  tpm=log((pt2+vint(18))/rmq2)
15208  wn=wtap(21)*wpdf0/b0
15209  ENDIF
15210 
15211 
15212 C...Loopback point for iteration
15213  ntry=0
15214  nthres=0
15215  200 ntry=ntry+1
15216  IF(ntry.GT.500) THEN
15217  CALL pyerrm(9,'(PYPTIS:) failed to evolve shower.')
15218  mint(51)=1
15219  RETURN
15220  ENDIF
15221 
15222 C... Calculate PDF weights and sum for evolution rate.
15223  wtsum=0d0
15224  xfbo=max(1d-10,xfb(kflb))
15225  DO 210 kfl=-5,5
15226  wtpdf(kfl)=xfb(kfl)/xfbo
15227  wtsum=wtsum+wtap(kfl)*wtpdf(kfl)
15228  210 CONTINUE
15229 C...Only add gluon mother diagram for massless KFLB.
15230  IF(mqmass.EQ.0) THEN
15231  wtpdf(21)=xfb(21)/xfbo
15232  wtsum=wtsum+wtap(21)*wtpdf(21)
15233  ENDIF
15234  wtsum=max(0.0001d0,wtsum)
15235  wtsums=wtsum
15236 C...Add joining diagrams where applicable.
15237  wtjoin=0d0
15238  IF (mstp(96).NE.0.AND.njn.NE.0) THEN
15239  DO 220 mj=1,mint(31)
15240  IF (wtapj(mj).LT.1d-3) goto 220
15241  wtpdfj(mj)=1d0/xfbo
15242 C...x and x*pdf (+ sea/val) for parton C.
15243  kflc=k(imi(js,mj,1),2)
15244  kflca=iabs(kflc)
15245  ksvcc=max(-1,imi(js,mj,2))
15246  IF (imi(js,mj,2).GT.imisep(mj)) ksvcc=-1
15247  mint(30)=js
15248  mint(36)=mj
15249  CALL pypdfu(kfbeam(js),x1(mj),pt2,xfj)
15250  mint(36)=mi
15251  IF (kflca.LE.6.AND.ksvcc.LE.0) THEN
15252  xfj(kflc)=xpsvc(kflc,ksvcc)
15253  ELSEIF (ksvcc.GE.1) THEN
15254  print*, 'error! parton C is companion!'
15255  ENDIF
15256  wtpdfj(mj)=wtpdfj(mj)/xfj(kflc)
15257 C...x and x*pdf (+ sea/val) for parton A.
15258  kfla=21
15259  ksvca=0
15260  IF (kflca.EQ.21.AND.kflba.LE.5) THEN
15261  kfla=kflb
15262  ksvca=ksvcb
15263  ELSEIF (kflba.EQ.21.AND.kflca.LE.5) THEN
15264  kfla=kflc
15265  ksvca=ksvcc
15266  ENDIF
15267  mint(30)=js
15268  IF (ksvca.LE.0) THEN
15269 C...Consider C the "evolved" parton if B is gluon. Val/sea
15270 C...counting will then be done correctly in PYPDFU.
15271  IF (kflba.EQ.21) mint(36)=mj
15272  CALL pypdfu(kfbeam(js),y(mj),pt2,xfj)
15273  mint(36)=mi
15274  IF (iabs(kfla).LE.6) xfj(kfla)=xpsvc(kfla,ksvca)
15275  ELSE
15276 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15277  xfj(kfla)=pyfcmp(y(mi)/vint(140),ys/vint(140),mstp(87))
15278  ENDIF
15279  wtpdfj(mj)=xfj(kfla)*wtpdfj(mj)
15280  wtjoin=wtjoin+wtapj(mj)*wtpdfj(mj)
15281  220 CONTINUE
15282  ENDIF
15283 
15284 C...Pick normal pT2 (in overestimated z range).
15285  230 pt2old=pt2
15286  wtsum=wtsums
15287  pt2=alam2*((pt2+vint(18))/alam2)**(pyr(0)**(b0/wtsum))-vint(18)
15288  kflc=21
15289 
15290 C...Evolve q -> q gamma separately, pick it if larger pT.
15291  IF(kflba.LE.5.AND.mstp(61).GE.2) THEN
15292  pt2qed=(pt2old+vint(18))*pyr(0)**(1d0/(aem2pi*wtape))-vint(18)
15293  IF(pt2qed.GT.pt2) THEN
15294  pt2=pt2qed
15295  kflc=22
15296  kfla=kflb
15297  ENDIF
15298  ENDIF
15299 
15300 C... Evolve massive quark creation separately.
15301  mcrqq=0
15302  IF (mqmass.NE.0) THEN
15303  pt2cr=(rmq2+vint(18))*(rml**(tpm/(tpl*pyr(0)**(-tml/wn)-tpm)))
15304  & -vint(18)
15305 C...If massive quark also on opposite side, ensure sufficient remaining
15306 C...phase space also for creation of that quark
15307  tminqq = tmin
15308  kflopp = k(imi(3-js,mi,1),2)
15309  IF (abs(kflopp).EQ.4.OR.abs(kflopp).EQ.5) tminqq = 1.05
15310 C...Ensure mininimum PT2CR and force creation near threshold.
15311  IF (pt2cr.LT.tminqq*rmq2) THEN
15312  nthres=nthres+1
15313  IF (nthres.GT.50) THEN
15314  CALL pyerrm(9,'(PYPTIS:) no phase space left for '//
15315  & 'massive quark creation. Gave up trying.')
15316  mint(51)=1
15317 C...Special return code if failing before any evolution at all: bad event
15318  IF (nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) mint(51)=2
15319  RETURN
15320  ENDIF
15321  pt2=0d0
15322  pt2cr=tminqq*rmq2
15323 C...Signal that massive quark creation is being forced
15324  mcrqq=2
15325  ENDIF
15326 C... Select largest PT2 (brems or creation):
15327  IF (pt2cr.GT.pt2) THEN
15328  mcrqq=max(mcrqq,1)
15329  wtsum=0d0
15330  pt2=pt2cr
15331  kfla=21
15332  ELSE
15333  mcrqq=0
15334  kfla=kflb
15335  ENDIF
15336 C... Compute logarithms for this PT2
15337  tpl=log((pt2+vint(18))/alam2)
15338  tpm=log((pt2+vint(18))/(rmq2+vint(18)))
15339  wtcrqq=tpm/log(pt2/rmq2)
15340  ENDIF
15341 
15342 C...Evolve joining separately
15343  mjoin=0
15344  IF (mstp(96).NE.0.AND.njn.NE.0) THEN
15345  pt2jn=alam2*((pt2old+vint(18))/alam2)**(pyr(0)**(b0/wtjoin))
15346  & -vint(18)
15347  IF (pt2jn.GE.pt2) THEN
15348  mjoin=1
15349  pt2=pt2jn
15350  ENDIF
15351  ENDIF
15352 
15353 C...Loopback if crossed c/b mass thresholds.
15354  IF(izrg.EQ.3.AND.pt2.LT.rmb2) THEN
15355  pt2=rmb2
15356  goto 130
15357  ELSEIF(izrg.EQ.2.AND.pt2.LT.rmc2) THEN
15358  pt2=rmc2
15359  goto 130
15360  ENDIF
15361 
15362 C...Speed up shower. Skip if higher-PT acceptable branching
15363 C...already found somewhere else.
15364 C...Also finish if below lower cutoff.
15365  IF ((pt2-pt2mx).LT.-0.001.OR.pt2.LT.pt2cut) RETURN
15366 
15367 C...Select parton A flavour (massive Q handled above.)
15368  IF (mqmass.EQ.0.AND.kflc.NE.22.AND.mjoin.EQ.0) THEN
15369  wtran=pyr(0)*wtsum
15370  kfla=-6
15371  240 kfla=kfla+1
15372  wtran=wtran-wtap(kfla)*wtpdf(kfla)
15373  IF(kfla.LE.5.AND.wtran.GT.0d0) goto 240
15374  IF(kfla.EQ.6) kfla=21
15375  ELSEIF (mjoin.EQ.1) THEN
15376 C...Tentative joining accept/reject.
15377  wtran=pyr(0)*wtjoin
15378  mj=0
15379  250 mj=mj+1
15380  wtran=wtran-wtapj(mj)*wtpdfj(mj)
15381  IF(mj.LE.mint(31)-1.AND.wtran.GT.0d0) goto 250
15382  IF(mjoind(js,mj).NE.0.OR.mjoind(js,mi).NE.0) THEN
15383  CALL pyerrm(9,'(PYPTIS:) Attempted double joining.'//
15384  & ' Rejected.')
15385  goto 230
15386  ENDIF
15387 C...x*pdf (+ sea/val) at new pT2 for parton B.
15388  IF (ksvcb.LE.0) THEN
15389  mint(30)=js
15390  CALL pypdfu(kfbeam(js),xb,pt2,xfb)
15391  IF (kflba.LE.6) xfb(kflb)=xpsvc(kflb,ksvcb)
15392  ELSE
15393 C...Companion distributions do not evolve.
15394  xfb(kflb)=xfbo
15395  ENDIF
15396  wtveto=1d0/wtpdfj(mj)/xfb(kflb)
15397  kflc=k(imi(js,mj,1),2)
15398  kflca=iabs(kflc)
15399  ksvcc=max(-1,imi(js,mj,2))
15400  IF (ksvcb.GE.1) ksvcc=-1
15401 C...x*pdf (+ sea/val) at new pT2 for parton C.
15402  mint(30)=js
15403  mint(36)=mj
15404  CALL pypdfu(kfbeam(js),x1(mj),pt2,xfj)
15405  mint(36)=mi
15406  IF (kflca.LE.6.AND.ksvcc.LE.0) xfj(kflc)=xpsvc(kflc,ksvcc)
15407  wtveto=wtveto/xfj(kflc)
15408 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15409  kfla=21
15410  ksvca=0
15411  IF (kflca.EQ.21.AND.kflba.LE.5) THEN
15412  kfla=kflb
15413  ksvca=ksvcb
15414  ELSEIF (kflba.EQ.21.AND.kflca.LE.5) THEN
15415  kfla=kflc
15416  ksvca=ksvcc
15417  ENDIF
15418  IF (ksvca.LE.0) THEN
15419  mint(30)=js
15420  IF (kflb.EQ.21) mint(36)=mj
15421  CALL pypdfu(kfbeam(js),y(mj),pt2,xfj)
15422  mint(36)=mi
15423  IF (iabs(kfla).LE.6) xfj(kfla)=xpsvc(kfla,ksvca)
15424  ELSE
15425  xfj(kfla)=pyfcmp(y(mj)/vint(140),ys/vint(140),mstp(87))
15426  ENDIF
15427 C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
15428 C...picked up by ISR (necessary since intertwining not implemented)
15429 C...Here simply kill backwards-evolution probability.
15430  IF (kflb.EQ.21.AND.(iabs(kfla).EQ.4.OR.iabs(kfla).EQ.5)) THEN
15431  IF (ksvca.GE.1) wtveto = 0d0
15432  ENDIF
15433  wtveto=wtveto*xfj(kfla)
15434 C...Monte Carlo veto to accept trial joining
15435  IF (wtveto.LT.pyr(0)) goto 200
15436 C...If accept, save PT2 of this joining.
15437  IF (pt2.GT.pt2mx) THEN
15438  pt2mx=pt2
15439  jsmx=2+js
15440  mjn1mx=mj
15441  mjn2mx=mi
15442  wtapj(mj)=0d0
15443  njn=0
15444  ENDIF
15445 C...Exit and continue evolution.
15446  goto 390
15447  ENDIF
15448  kflaa=iabs(kfla)
15449 
15450 C...Choose z value (still in overestimated range) and corrective weight.
15451 C...Unphysical z will be rejected below when Q2 has is computed.
15452  wtz=0d0
15453 
15454 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15455 C...q -> q + g or q -> q + gamma (already set which).
15456  IF (kflaa.LE.5.AND.kflba.LE.5) THEN
15457  IF (ksvcb.LT.0) THEN
15458  z=1d0-(1d0-zmin)*((1d0-zmax)/(1d0-zmin))**pyr(0)
15459  ELSE
15460  zfac=rmin*(rmax/rmin)**pyr(0)
15461  z=((1-zfac)/(1+zfac))**2
15462  ENDIF
15463  wtz=0.5d0*(1d0+z**2)
15464 C...Massive weight correction.
15465  IF (kflba.GE.4) wtz=wtz-z*(1d0-z)**2*rmq2/pt2
15466 C...Valence quark weight correction (extra sqrt)
15467  IF (ksvcb.GE.0) wtz=wtz*sqrt(z)
15468 
15469 C...q -> g + q.
15470 C...NB: MQ>0 not yet implemented. Forced absent above.
15471  ELSEIF (kflaa.LE.5.AND.kflb.EQ.21) THEN
15472  kflc=kfla
15473  z=zmax/(1d0+pyr(0)*(sqrt(zmax/zmin)-1d0))**2
15474  wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
15475 
15476 C...g -> q + qbar.
15477  ELSEIF (kfla.EQ.21.AND.kflba.LE.5) THEN
15478  kflc=-kflb
15479  z=zmin+pyr(0)*(zmax-zmin)
15480  wtz=z**2+(1d0-z)**2
15481 C...Massive correction
15482  IF (mqmass.NE.0) THEN
15483  wtz=wtz+2d0*z*(1d0-z)*rmq2/pt2
15484 C...Extra safety margin for light sea quark creation
15485  ELSEIF (ksvcb.LT.0) THEN
15486  wtz=wtz/1.25d0
15487  ENDIF
15488 
15489 C...g -> g + g.
15490  ELSEIF (kfla.EQ.21.AND.kflb.EQ.21) THEN
15491  kflc=21
15492  z=1d0/(1d0+((1d0-zmin)/zmin)*((1d0-zmax)*zmin/
15493  & (zmax*(1d0-zmin)))**pyr(0))
15494  wtz=(1d0-z*(1d0-z))**2
15495  ENDIF
15496 
15497 C...Derive Q2 from pT2.
15498  q2b=pt2/(1d0-z)
15499  IF (kflba.GE.4) q2b=q2b-rmq2
15500 
15501 C...Loopback if outside allowed z range for given pT2.
15502  rm2c=pymass(kflc)**2
15503  pt2adj=q2b-z*(shtnow(mi)+q2b)*(q2b+rm2c)/shtnow(mi)
15504  IF (pt2adj.LT.1d-6) goto 230
15505 
15506 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15507 C...No modification for very first emission if using ME correction
15508  mstp67 = mstp(67)
15509  IF (mecor.GE.1.AND.nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) THEN
15510  mstp67 = 0
15511  ENDIF
15512 
15513 C...For 1st branching, limit phase space by s-hat with color-partner
15514 C...(prevent infinite loop by limiting number of NTRY)
15515  IF (mstp67.GE.1.AND.nisgen(js,mi).EQ.0.AND.ntry.LE.200) THEN
15516  mside=1
15517  idip=imi(js,mi,1)
15518 C...Use anticolor tag for antiquark, or for gluon half the time
15519  IF ((kflb.LT.0.AND.kflba.LT.10).OR.
15520  & (kflb.EQ.21.AND.pyr(0).GT.0.5)) mside=2
15521 C...Tag
15522  mctag=mct(idip,mside)
15523 C...Default is to set up phase space using the opposite incoming parton
15524  jdip=imi(3-js,mi,1)
15525  ndip=0
15526 
15527 C...Alternatively, look for final-state color partner (pick last if several)
15528  DO 260 ifs=1,npart
15529  mcj = mct(ipart(ifs),mside)
15530  IF (mcj.NE.mctag) goto 260
15531 C...Pick last matching final-state partner if several
15532 C...(if no matching final-state partner, defaults back to annihilation)
15533  ksj = k(ipart(ifs),1)
15534  IF (ksj.GE.1.AND.ksj.LT.10) THEN
15535  jdip=ipart(ifs)
15536  ndip=ndip+1
15537  ENDIF
15538  260 CONTINUE
15539 
15540 C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2
15541 C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2)
15542  sdip=abs(((p(idip,4)-p(jdip,4))**2-(p(idip,3)-p(jdip,3))**2
15543  & -(p(idip,2)-p(jdip,2))**2-(p(idip,1)-p(jdip,1))**2))
15544 
15545  IF (mstp67.EQ.1) THEN
15546 C...1 Option to completely kill radiation above s_dip * PARP(67)
15547  IF (4d0*pt2.GT.parp(67)*sdip) goto 230
15548  ELSE IF (mstp67.EQ.2) THEN
15549 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15550 C... (-> improved power showers?)
15551  IF (4d0*pt2*pyr(0).GT.parp(67)*sdip) goto 230
15552  ENDIF
15553 
15554 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15555  ELSE IF (mstp(62).GE.3.AND.nisgen(js,mi).GE.1) THEN
15556  IF(pt2.GT.((1d0-z)/(z*(1d0-zsav(js,mi))))**2*pt2sav(js,mi))
15557  & goto 230
15558  ENDIF
15559 
15560 C...Select phi angle of branching at random.
15561  phi=paru(2)*pyr(0)
15562 
15563 C...Matrix-element corrections for some processes.
15564  IF (mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
15565  IF (kflaa.LE.20.AND.kflba.LE.20) THEN
15566  CALL pymewt(mecor,1,q2b*shat/shtnow(mi),z,phi,wtme)
15567  wtz=wtz*wtme/wtff
15568  ELSEIF((kfla.EQ.21.OR.kfla.EQ.22).AND.kflba.LE.20) THEN
15569  CALL pymewt(mecor,2,q2b*shat/shtnow(mi),z,phi,wtme)
15570  wtz=wtz*wtme/wtgf
15571  ELSEIF(kflaa.LE.20.AND.(kflb.EQ.21.OR.kflb.EQ.22)) THEN
15572  CALL pymewt(mecor,3,q2b*shat/shtnow(mi),z,phi,wtme)
15573  wtz=wtz*wtme/wtfg
15574  ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
15575  CALL pymewt(mecor,4,q2b*shat/shtnow(mi),z,phi,wtme)
15576  wtz=wtz*wtme/wtgg
15577  ENDIF
15578  ENDIF
15579 
15580 C...Parton distributions at new pT2 but old x.
15581  mint(30)=js
15582  CALL pypdfu(kfbeam(js),xb,pt2,xfn)
15583 C...Treat val and cmp separately
15584  IF (kflba.LE.6.AND.ksvcb.LE.0) xfn(kflb)=xpsvc(kflb,ksvcb)
15585  IF (ksvcb.GE.1)
15586  & xfn(kflb)=pyfcmp(yb/vint(140),ys/vint(140),mstp(87))
15587  xfbn=xfn(kflb)
15588  IF(xfbn.LT.1d-20) THEN
15589  IF(kfla.EQ.kflb) THEN
15590  wtap(kflb)=0d0
15591  goto 200
15592  ELSE
15593  xfbn=1d-10
15594  xfn(kflb)=xfbn
15595  ENDIF
15596  ENDIF
15597  DO 270 kfl=-5,5
15598  xfb(kfl)=xfn(kfl)
15599  270 CONTINUE
15600  xfb(21)=xfn(21)
15601 
15602 C...Parton distributions at new pT2 and new x.
15603  xa=xb/z
15604  mint(30)=js
15605  CALL pypdfu(kfbeam(js),xa,pt2,xfa)
15606  IF (kflba.LE.5.AND.kflaa.LE.5) THEN
15607 C...q -> q + g: only consider respective sea, val, or cmp content.
15608  IF (ksvcb.LE.0) THEN
15609  xfa(kfla)=xpsvc(kfla,ksvcb)
15610  ELSE
15611  ya=xa*(1d0-ys)
15612  xfa(kflb)=pyfcmp(ya/vint(140),ys/vint(140),mstp(87))
15613  ENDIF
15614  ENDIF
15615  xfan=xfa(kfla)
15616  IF(xfan.LT.1d-20) THEN
15617  goto 200
15618  ENDIF
15619 
15620 C...If weighting fails continue evolution.
15621  wttot=0d0
15622  IF (mcrqq.EQ.0) THEN
15623  wtpdfa=1d0/wtpdf(kfla)
15624  wttot=wtz*xfan/xfbn*wtpdfa
15625  ELSEIF(mcrqq.EQ.1) THEN
15626  wtpdfa=tpm/wpdf0
15627  wttot=wtcrqq*wtz*xfan/xfbn*wtpdfa
15628  xbest=tpm/tpm0*xq0
15629  ELSEIF(mcrqq.EQ.2) THEN
15630 C...Force massive quark creation.
15631  wttot=1d0
15632  ENDIF
15633 
15634 C...Loop back if trial emission fails.
15635  IF(wttot.GE.0d0.AND.wttot.LT.pyr(0)) goto 200
15636  wtacc=((1d0+pt2)/(0.25d0+pt2))**2
15637  IF(wttot.LT.0d0) THEN
15638  WRITE(chwt,'(1P,E12.4)') wttot
15639  CALL pyerrm(19,'(PYPTIS:) Weight '//chwt//' negative')
15640  ELSEIF(wttot.GT.wtacc) THEN
15641  WRITE(chwt,'(1P,E12.4)') wttot
15642  IF (pt2.GT.ptemax.OR.wttot.GE.wtemax) THEN
15643 C...Too high weight: write out as error, but do not update error counter
15644  IF(mstu(29).EQ.0) mstu(23)=mstu(23)-1
15645  CALL pyerrm(19,
15646  & '(PYPTIS:) Weight '//chwt//' above unity')
15647  IF (pt2.GT.ptemax) ptemax=pt2
15648  IF (wttot.GT.wtemax) wtemax=wttot
15649  ELSE
15650  CALL pyerrm(9,
15651  & '(PYPTIS:) Weight '//chwt//' above unity')
15652  ENDIF
15653 C...Useful for debugging but commented out for distribution:
15654 C print*, 'JS, MI',JS, MI
15655 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15656 C print*, 'A -> B C',KFLA, KFLB, KFLC
15657 C XFAO=XFBO/WTPDFA
15658 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15659  ENDIF
15660 
15661 C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks
15662 C...simultaneously reached their creation thresholds)
15663  IF (abs(pt2-pt2mx).LT.0.001) THEN
15664  IF (pyr(0).GT.0.5) pt2=1.0001*pt2mx
15665  ENDIF
15666 
15667 C...Save acceptable branching.
15668  IF(pt2.GT.pt2mx) THEN
15669  mimx=mint(36)
15670  jsmx=js
15671  pt2mx=pt2
15672  kflamx=kfla
15673  kflcmx=kflc
15674  rm2cmx=rm2c
15675  q2bmx=q2b
15676  zmx=z
15677  pt2amx=pt2adj
15678  phimx=phi
15679  ENDIF
15680 
15681 C----------------------------------------------------------------------
15682 C...MODE= 1: Accept stored shower branching. Update event record etc.
15683  ELSEIF (mode.EQ.1) THEN
15684  mi=mimx
15685  js=jsmx
15686  shat=shtnow(mi)
15687  side=3d0-2d0*js
15688 C...Shift down rest of event record to make room for insertion.
15689  it=imisep(mi)+1
15690  im=it+1
15691  is=imi(js,mi,1)
15692  DO 290 i=n,it,-1
15693  IF (k(i,3).GE.it) k(i,3)=k(i,3)+2
15694  kt1=k(i,4)/mstu(5)**2
15695  kt2=k(i,5)/mstu(5)**2
15696  id1=mod(k(i,4),mstu(5))
15697  id2=mod(k(i,5),mstu(5))
15698  im1=mod(k(i,4)/mstu(5),mstu(5))
15699  im2=mod(k(i,5)/mstu(5),mstu(5))
15700  IF (id1.GE.it) id1=id1+2
15701  IF (id2.GE.it) id2=id2+2
15702  IF (im1.GE.it) im1=im1+2
15703  IF (im2.GE.it) im2=im2+2
15704  k(i,4)=kt1*mstu(5)**2+im1*mstu(5)+id1
15705  k(i,5)=kt2*mstu(5)**2+im2*mstu(5)+id2
15706  DO 280 ix=1,5
15707  k(i+2,ix)=k(i,ix)
15708  p(i+2,ix)=p(i,ix)
15709  v(i+2,ix)=v(i,ix)
15710  280 CONTINUE
15711  mct(i+2,1)=mct(i,1)
15712  mct(i+2,2)=mct(i,2)
15713  290 CONTINUE
15714  n=n+2
15715 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15716  DO 300 ji=1,mint(31)
15717  IF (imi(1,ji,1).GE.it) imi(1,ji,1)=imi(1,ji,1)+2
15718  IF (imi(1,ji,2).GE.it) imi(1,ji,2)=imi(1,ji,2)+2
15719  IF (imi(2,ji,1).GE.it) imi(2,ji,1)=imi(2,ji,1)+2
15720  IF (imi(2,ji,2).GE.it) imi(2,ji,2)=imi(2,ji,2)+2
15721  IF (ji.GE.mi) imisep(ji)=imisep(ji)+2
15722 C...Also update companion pointers to the present mother.
15723  IF (imi(js,ji,2).EQ.is) imi(js,ji,2)=im
15724  300 CONTINUE
15725  DO 310 ifs=1,npart
15726  IF (ipart(ifs).GE.it) ipart(ifs)=ipart(ifs)+2
15727  310 CONTINUE
15728 C...Zero entries dedicated for new timelike and mother partons.
15729  DO 330 i=it,it+1
15730  DO 320 j=1,5
15731  k(i,j)=0
15732  p(i,j)=0d0
15733  v(i,j)=0d0
15734  320 CONTINUE
15735  mct(i,1)=0
15736  mct(i,2)=0
15737  330 CONTINUE
15738 
15739 C...Define timelike and new mother partons. History.
15740  k(it,1)=3
15741  k(it,2)=kflcmx
15742  k(im,1)=14
15743  k(im,2)=kflamx
15744  k(is,3)=im
15745  k(it,3)=im
15746 C...Set mother origin = side.
15747  k(im,3)=mint(83)+js+2
15748  IF(mi.GE.2) k(im,3)=mint(83)+js
15749 
15750 C...Define colour flow of branching.
15751  im1=im
15752  im2=im
15753 C...q -> q + gamma.
15754  IF(k(it,2).EQ.22) THEN
15755  k(it,1)=1
15756  id1=is
15757  id2=is
15758 C...q -> q + g.
15759  ELSEIF(k(im,2).GT.0.AND.k(im,2).LE.5.AND.k(it,2).EQ.21) THEN
15760  id1=it
15761  id2=is
15762 C...q -> g + q.
15763  ELSEIF(k(im,2).GT.0.AND.k(im,2).LE.5) THEN
15764  id1=is
15765  id2=it
15766 C...qbar -> qbar + g.
15767  ELSEIF(k(im,2).LT.0.AND.k(im,2).GE.-5.AND.k(it,2).EQ.21) THEN
15768  id1=is
15769  id2=it
15770 C...qbar -> g + qbar.
15771  ELSEIF(k(im,2).LT.0.AND.k(im,2).GE.-5) THEN
15772  id1=it
15773  id2=is
15774 C...g -> g + g; g -> q + qbar..
15775  ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
15776  id1=is
15777  id2=it
15778  ELSE
15779  id1=it
15780  id2=is
15781  ENDIF
15782  IF(im1.EQ.im) k(im1,4)=k(im1,4)+id1
15783  IF(im2.EQ.im) k(im2,5)=k(im2,5)+id2
15784  k(id1,4)=k(id1,4)+mstu(5)*im1
15785  k(id2,5)=k(id2,5)+mstu(5)*im2
15786  IF(id1.NE.id2) THEN
15787  k(id1,5)=k(id1,5)+mstu(5)*id2
15788  k(id2,4)=k(id2,4)+mstu(5)*id1
15789  ENDIF
15790  IF(k(it,1).EQ.1) THEN
15791  k(it,4)=0
15792  k(it,5)=0
15793  ENDIF
15794 C...Update IMI and colour tag arrays.
15795  imi(js,mi,1)=im
15796  DO 340 mc=1,2
15797  mct(it,mc)=0
15798  mct(im,mc)=0
15799  340 CONTINUE
15800  DO 350 jcs=4,5
15801  kcs=jcs
15802 C...If mother flag not yet set for spacelike parton, trace it.
15803  IF (k(is,kcs)/mstu(5)**2.LE.1) CALL pycttr(is,-kcs,im)
15804  IF(mint(51).NE.0) RETURN
15805  350 CONTINUE
15806  DO 360 jcs=4,5
15807  kcs=jcs
15808 C...If mother flag not yet set for timelike parton, trace it.
15809  IF (k(it,kcs)/mstu(5)**2.LE.1) CALL pycttr(it,kcs,im)
15810  IF(mint(51).NE.0) RETURN
15811  360 CONTINUE
15812 
15813 C...Boost recoiling parton to compensate for Q2 scale.
15814  betaz=side*(1d0-(1d0+q2bmx/shat)**2)/
15815  & (1d0+(1d0+q2bmx/shat)**2)
15816  ir=imi(3-js,mi,1)
15817  CALL pyrobo(ir,ir,0d0,0d0,0d0,0d0,betaz)
15818 
15819 C...Define system to be rotated and boosted
15820 C...(not including the 2 just added partons)
15821 C...(but including the docu lines for first interaction)
15822  imin=imisep(mi-1)+1
15823  IF (mi.EQ.1) imin=mint(83)+5
15824  imax=imisep(mi)-2
15825 
15826 C...Rotate back system in phi to compensate for subsequent rotation.
15827  CALL pyrobo(imin,imax,0d0,-phimx,0d0,0d0,0d0)
15828 
15829 C...Define kinematics of new partons in old frame.
15830  imax=imisep(mi)
15831  p(im,1)=sqrt(pt2amx)*shat/(zmx*(shat+q2bmx))
15832  p(im,3)=0.5d0*sqrt(shat)*((shat-q2bmx)/((shat
15833  & +q2bmx)*zmx)+(q2bmx+rm2cmx)/shat)*side
15834  p(im,4)=sqrt(p(im,1)**2+p(im,3)**2)
15835  p(it,1)=p(im,1)
15836  p(it,3)=p(im,3)-0.5d0*(shat+q2bmx)/sqrt(shat)*side
15837  p(it,4)=sqrt(p(it,1)**2+p(it,3)**2+rm2cmx)
15838  p(it,5)=sqrt(rm2cmx)
15839 
15840 C...Update internal line, now spacelike
15841  p(is,1)=p(im,1)-p(it,1)
15842  p(is,2)=p(im,2)-p(it,2)
15843  p(is,3)=p(im,3)-p(it,3)
15844  p(is,4)=p(im,4)-p(it,4)
15845  p(is,5)=p(is,4)**2-p(is,1)**2-p(is,2)**2-p(is,3)**2
15846 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15847  IF (p(is,5).LT.0d0) THEN
15848  p(is,5)=-sqrt(abs(p(is,5)))
15849  ELSE
15850  p(is,5)=sqrt(p(is,5))
15851  ENDIF
15852 
15853 C...Boost entire system and rotate to new frame.
15854 C...(including docu lines)
15855  betax=(p(im,1)+p(ir,1))/(p(im,4)+p(ir,4))
15856  betaz=(p(im,3)+p(ir,3))/(p(im,4)+p(ir,4))
15857  IF(betax**2+betaz**2.GE.1d0) THEN
15858  CALL pyerrm(1,'(PYPTIS:) boost bigger than unity')
15859  mint(51)=1
15860  ifail=-1
15861  RETURN
15862  ENDIF
15863  CALL pyrobo(imin,imax,0d0,0d0,-betax,0d0,-betaz)
15864  i1=imi(1,mi,1)
15865  theta=pyangl(p(i1,3),p(i1,1))
15866  CALL pyrobo(imin,imax,-theta,phimx,0d0,0d0,0d0)
15867 
15868 C...Global statistics.
15869  mint(352)=mint(352)+1
15870  vint(352)=vint(352)+sqrt(p(it,1)**2+p(it,2)**2)
15871  IF (mint(352).EQ.1) vint(357)=sqrt(p(it,1)**2+p(it,2)**2)
15872 
15873 C...Add parton with relevant pT scale for timelike shower.
15874  IF (k(it,2).NE.22) THEN
15875  npart=npart+1
15876  ipart(npart)=it
15877  ptpart(npart)=sqrt(pt2amx)
15878  ENDIF
15879 
15880 C...Update saved variables.
15881  shtnow(mimx)=shtnow(mimx)/zmx
15882  nisgen(jsmx,mimx)=nisgen(jsmx,mimx)+1
15883  xmi(jsmx,mimx)=xmi(jsmx,mimx)/zmx
15884  pt2sav(jsmx,mimx)=pt2mx
15885  zsav(js,mimx)=zmx
15886 
15887  ksa=iabs(k(is,2))
15888  kma=iabs(k(im,2))
15889  IF (ksa.EQ.21.AND.kma.GE.1.AND.kma.LE.5) THEN
15890 C...Gluon reconstructs to quark.
15891 C...Decide whether newly created quark is valence or sea:
15892  mint(30)=js
15893  CALL pyptmi(2,pt2now,ptdum1,ptdum2,ifail)
15894  IF(mint(51).NE.0) RETURN
15895  ENDIF
15896  IF(ksa.GE.1.AND.ksa.LE.5.AND.kma.EQ.21) THEN
15897 C...Quark reconstructs to gluon.
15898 C...Now some guy may have lost his companion. Check.
15899  icmp=imi(js,mi,2)
15900  IF (icmp.GT.0) THEN
15901  CALL pyerrm(9,'(PYPTIS:) Sorry, companion quark radiated'
15902  & //' away. Cannot handle that yet. Giving up.')
15903  mint(51)=1
15904  RETURN
15905  ELSEIF(icmp.LT.0) THEN
15906 C...A sea quark with companion still in BR was reconstructed to a gluon.
15907 C...Companion should now be removed from the beam remnant.
15908 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15909  icmp=-icmp
15910  ifl=-k(is,2)
15911  DO 380 jcmp=icmp,nvc(js,ifl)-1
15912  xassoc(js,ifl,jcmp)=xassoc(js,ifl,jcmp+1)
15913  DO 370 ji=1,mint(31)
15914  kmi=-imi(js,ji,2)
15915  jfl=-k(imi(js,ji,1),2)
15916  IF (kmi.EQ.jcmp+1.AND.jfl.EQ.ifl) imi(js,ji,2)=imi(js,ji
15917  & ,2)+1
15918  370 CONTINUE
15919  380 CONTINUE
15920  nvc(js,ifl)=nvc(js,ifl)-1
15921  ENDIF
15922 C...Set gluon IMI(JS,MI,2) = 0.
15923  imi(js,mi,2)=0
15924  ELSEIF(ksa.GE.1.AND.ksa.LE.5.AND.kma.NE.21) THEN
15925 C...Quark reconstructing to quark. If sea with companion still in BR
15926 C...then update associated x value.
15927 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15928  IF (imi(js,mi,2).LT.0) THEN
15929  icmp=-imi(js,mi,2)
15930  ifl=-k(is,2)
15931  xassoc(js,ifl,icmp)=xmi(jsmx,mimx)
15932  ENDIF
15933  ENDIF
15934 
15935  ENDIF
15936 
15937 C...If reached this point, normal exit.
15938  390 ifail=0
15939 
15940  RETURN
15941  END
15942 
15943 C*********************************************************************
15944 
15945 C...PYMEMX
15946 C...Generates maximum ME weight in some initial-state showers.
15947 C...Inparameter MECOR: kind of hard scattering process
15948 C...Outparameter WTFF: maximum weight for fermion -> fermion
15949 C... WTGF: maximum weight for gluon/photon -> fermion
15950 C... WTFG: maximum weight for fermion -> gluon/photon
15951 C... WTGG: maximum weight for gluon -> gluon
15952 
15953  SUBROUTINE pymemx(MECOR,WTFF,WTGF,WTFG,WTGG)
15954 
15955 C...Double precision and integer declarations.
15956  IMPLICIT DOUBLE PRECISION(a-h, o-z)
15957  IMPLICIT INTEGER(i-n)
15958  INTEGER pyk,pychge,pycomp
15959 C...Commonblocks.
15960  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15961  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15962  common/pypars/mstp(200),parp(200),msti(200),pari(200)
15963  common/pyint1/mint(400),vint(400)
15964  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15965  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyint2/
15966 
15967 C...Default maximum weight.
15968  wtff=1d0
15969  wtgf=1d0
15970  wtfg=1d0
15971  wtgg=1d0
15972 
15973 C...Select maximum weight by process.
15974  IF(mecor.EQ.1) THEN
15975  wtff=1d0
15976  wtgf=3d0
15977  ELSEIF(mecor.EQ.2) THEN
15978  wtfg=1d0
15979  wtgg=1d0
15980  ENDIF
15981 
15982  RETURN
15983  END
15984 
15985 C*********************************************************************
15986 
15987 C...PYMEWT
15988 C...Calculates actual ME weight in some initial-state showers.
15989 C...Inparameter MECOR: kind of hard scattering process
15990 C... IFLCB: flavour combination of branching,
15991 C... 1 for fermion -> fermion,
15992 C... 2 for gluon/photon -> fermion
15993 C... 3 for fermion -> gluon/photon,
15994 C... 4 for gluon -> gluon
15995 C... Q2: Q2 value of shower branching
15996 C... Z: Z value of branching
15997 C...In+outparameter PHIBR: azimuthal angle of branching
15998 C...Outparameter WTME: actual ME weight
15999 
16000  SUBROUTINE pymewt(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
16001 
16002 C...Double precision and integer declarations.
16003  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16004  IMPLICIT INTEGER(i-n)
16005  INTEGER pyk,pychge,pycomp
16006 C...Commonblocks.
16007  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16008  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16009  common/pypars/mstp(200),parp(200),msti(200),pari(200)
16010  common/pyint1/mint(400),vint(400)
16011  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
16012  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyint2/
16013 
16014 C...Default output.
16015  wtme=1d0
16016 
16017 C...Define kinematics of shower branching in Mandelstam variables.
16018  sqm=vint(44)
16019  sh=sqm/z
16020  th=-q2
16021  uh=q2-sqm*(1d0-z)/z
16022 
16023 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
16024  IF(mecor.EQ.1) THEN
16025  IF(iflcb.EQ.1) THEN
16026  wtme=(th**2+uh**2+2d0*sqm*sh)/(sh**2+sqm**2)
16027  ELSEIF(iflcb.EQ.2) THEN
16028  wtme=(sh**2+th**2+2d0*sqm*uh)/((sh-sqm)**2+sqm**2)
16029  ENDIF
16030 
16031 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
16032  ELSEIF(mecor.EQ.2) THEN
16033  IF(iflcb.EQ.3) THEN
16034  wtme=(sh**2+uh**2)/(sh**2+(sh-sqm)**2)
16035  ELSEIF(iflcb.EQ.4) THEN
16036  wtme=0.5d0*(sh**4+uh**4+th**4+sqm**4)/(sh**2-sqm*(sh-sqm))**2
16037  ENDIF
16038 
16039 C...Matrix-element corrections for q + qbar -> Higgs (h0)
16040  ELSEIF(mecor.EQ.3) THEN
16041  IF(iflcb.EQ.2) THEN
16042  wtme=(sh**2+th**2+2d0*(sqm-th)*(sqm-sh))/
16043  1 (sh**2+2d0*sqm*(sqm-sh))
16044  ENDIF
16045  ENDIF
16046 
16047  RETURN
16048  END
16049 
16050 C*********************************************************************
16051 
16052 C...PYPTMI
16053 C...Handles the generation of additional interactions in the new
16054 C...multiple interactions framework.
16055 C...MODE=-1 : Initalize MI from scratch.
16056 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
16057 C... Sudakov for PT2, abort if below PT2CUT.
16058 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
16059 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
16060 C...PT2NOW : Starting (max) PT2 scale for evolution.
16061 C...PT2CUT : Lower limit for evolution.
16062 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
16063 C...IFAIL : Status return code.
16064 C... = 0: All is well.
16065 C... < 0: Phase space exhausted, generation to be terminated.
16066 C... > 0: Additional interaction vetoed, but continue evolution.
16067 
16068  SUBROUTINE pyptmi(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
16069 C...Double precision and integer declarations.
16070  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16071  IMPLICIT INTEGER(i-n)
16072  INTEGER pyk,pychge,pycomp
16073 C...Parameter statement for maximum size of showers.
16074  parameter(maxnur=1000)
16075 C...Commonblocks.
16076  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
16077  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16078  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16079  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
16080  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
16081  common/pypars/mstp(200),parp(200),msti(200),pari(200)
16082  common/pyint1/mint(400),vint(400)
16083  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
16084  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
16085  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
16086  common/pyint7/sigt(0:6,0:6,0:5)
16087  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
16088  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
16089  & xmi(2,240),pt2mi(240),imisep(0:240)
16090  common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
16091  & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
16092  common/pyctag/nct,mct(4000,2)
16093 C...Local arrays and saved variables.
16094  dimension wdtp(0:400),wdte(0:400,0:5),xpq(-25:25)
16095 
16096  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pydat3/,/pypars/,
16097  & /pyint1/,/pyint2/,/pyint3/,/pyint5/,/pyint7/,/pyintm/,
16098  & /pyismx/,/pyctag/
16099  SAVE nchn,xt2fac,sigs
16100 
16101  ifail=0
16102 C...Set MI subprocess = QCD 2 -> 2.
16103  isub=96
16104 
16105 C----------------------------------------------------------------------
16106 C...MODE=-1: Initialize from scratch
16107  IF (mode.EQ.-1) THEN
16108 C...Initialize PT2 array.
16109  pt2mi(1)=vint(54)
16110 C...Initialize list of incoming beams and partons from two sides.
16111  DO 110 js=1,2
16112  DO 100 mi=1,240
16113  imi(js,mi,1)=0
16114  imi(js,mi,2)=0
16115  100 CONTINUE
16116  nmi(js)=1
16117  imi(js,1,1)=mint(84)+js
16118  imi(js,1,2)=0
16119  xmi(js,1)=vint(40+js)
16120 C...Rescale x values to fractions of photon energy.
16121  IF(mint(18+js).EQ.1) xmi(js,1)=vint(40+js)/vint(154+js)
16122 C...Hard reset: hard interaction initiators motherless by definition.
16123  k(mint(84)+js,3)=2+js
16124  k(mint(84)+js,4)=mod(k(mint(84)+js,4),mstu(5))
16125  k(mint(84)+js,5)=mod(k(mint(84)+js,5),mstu(5))
16126  110 CONTINUE
16127  imisep(0)=mint(84)
16128  imisep(1)=n
16129  IF (mod(mstp(81),10).GE.1) THEN
16130  IF(mstp(82).LE.1) THEN
16131  sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0
16132  & ,5))
16133  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
16134  & vint(317)/(vint(318)*vint(320))
16135  xt2fac=sigrat*vint(149)/(1d0-vint(149))
16136  ELSE
16137  xt2fac=vint(146)*vint(148)*xsec(isub,1)/
16138  & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
16139  ENDIF
16140  ENDIF
16141 C...Zero entries relating to scatterings beyond the first.
16142  DO 120 mi=2,240
16143  imi(1,mi,1)=0
16144  imi(2,mi,1)=0
16145  imi(1,mi,2)=0
16146  imi(2,mi,2)=0
16147  imisep(mi)=imisep(1)
16148  pt2mi(mi)=0d0
16149  xmi(1,mi)=0d0
16150  xmi(2,mi)=0d0
16151  120 CONTINUE
16152 C...Initialize factors for PDF reshaping.
16153  DO 140 js=1,2
16154  kfbeam(js)=mint(10+js)
16155  IF(mint(18+js).EQ.1) kfbeam(js)=22
16156  kfabm=iabs(kfbeam(js))
16157  kfsbm=isign(1,kfbeam(js))
16158 
16159 C...Zero flavour content of incoming beam particle.
16160  kfival(js,1)=0
16161  kfival(js,2)=0
16162  kfival(js,3)=0
16163 C... Flavour content of baryon.
16164  IF(kfabm.GT.1000) THEN
16165  kfival(js,1)=kfsbm*mod(kfabm/1000,10)
16166  kfival(js,2)=kfsbm*mod(kfabm/100,10)
16167  kfival(js,3)=kfsbm*mod(kfabm/10,10)
16168 C... Flavour content of pi+-, K+-.
16169  ELSEIF(kfabm.EQ.211) THEN
16170  kfival(js,1)=kfsbm*2
16171  kfival(js,2)=-kfsbm
16172  ELSEIF(kfabm.EQ.321) THEN
16173  kfival(js,1)=-kfsbm*3
16174  kfival(js,2)=kfsbm*2
16175 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
16176  ENDIF
16177 
16178 C...Zero initial valence and companion content.
16179  DO 130 ifl=-6,6
16180  nvc(js,ifl)=0
16181  130 CONTINUE
16182  140 CONTINUE
16183 C...Set up colour line tags starting from hard interaction initiators.
16184  nct=0
16185 C...Reset colour tag array and colour processing flags.
16186  DO 150 i=imisep(0)+1,n
16187  mct(i,1)=0
16188  mct(i,2)=0
16189  k(i,4)=mod(k(i,4),mstu(5)**2)
16190  k(i,5)=mod(k(i,5),mstu(5)**2)
16191  150 CONTINUE
16192 C... Consider each side in turn.
16193  DO 170 js=1,2
16194  i1=imi(js,1,1)
16195  i2=imi(3-js,1,1)
16196  DO 160 jcs=4,5
16197  IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
16198  & goto 160
16199  IF (k(i1,jcs)/mstu(5)**2.NE.0) goto 160
16200  kcs=jcs
16201  CALL pycttr(i1,kcs,i2)
16202  IF(mint(51).NE.0) RETURN
16203  160 CONTINUE
16204  170 CONTINUE
16205 
16206 C...Range checking for companion quark pdf large-x param.
16207  IF (mstp(87).LT.0) THEN
16208  CALL pyerrm(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16209  & ' MSTP(87)=0')
16210  mstp(87)=0
16211  ELSEIF (mstp(87).GT.4) THEN
16212  CALL pyerrm(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16213  & ' MSTP(87)=4')
16214  mstp(87)=4
16215  ENDIF
16216 
16217 C----------------------------------------------------------------------
16218 C...MODE=0: Generate trial interaction. Return codes:
16219 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
16220 C...IFAIL = 0: Additional interaction generated at PT2.
16221 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
16222  ELSEIF (mode.EQ.0) THEN
16223 C...Abolute MI max scale = VINT(62)
16224  xt2=4d0*min(pt2now,vint(62))/vint(2)
16225  180 IF(mstp(82).LE.1) THEN
16226  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
16227  IF(xt2.LT.vint(149)) ifail=-2
16228  ELSE
16229  IF(xt2.LE.0.01001d0*vint(149)) THEN
16230  ifail=-3
16231  ELSE
16232  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
16233  & log(pyr(0)))-vint(149)
16234  ENDIF
16235  ENDIF
16236 C...Also exit if below lower limit or if higher trial branching
16237 C...already found.
16238  pt2=0.25d0*vint(2)*xt2
16239  IF (pt2.LE.pt2cut) ifail=-4
16240  IF (pt2.LE.pt2mx) ifail=-5
16241  IF (ifail.NE.0) THEN
16242  pt2=0d0
16243  RETURN
16244  ENDIF
16245  IF(mstp(82).GE.2) pt2=max(0.25d0*vint(2)*0.01d0*vint(149),pt2)
16246  vint(25)=4d0*pt2/vint(2)
16247  xt2=vint(25)
16248 
16249 C...Choose tau and y*. Calculate cos(theta-hat).
16250  IF(pyr(0).LE.coef(isub,1)) THEN
16251  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
16252  tau=xt2*(1d0+taut)**2/(4d0*taut)
16253  ELSE
16254  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
16255  ENDIF
16256  vint(21)=tau
16257 C...New: require shat > 1.
16258  IF(tau*vint(2).LT.1d0) goto 180
16259  CALL pyklim(2)
16260  ryst=pyr(0)
16261  myst=1
16262  IF(ryst.GT.coef(isub,8)) myst=2
16263  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
16264  CALL pykmap(2,myst,pyr(0))
16265  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
16266 
16267 C...Check that x not used up. Accept or reject kinematical variables.
16268  x1m=sqrt(tau)*exp(vint(22))
16269  x2m=sqrt(tau)*exp(-vint(22))
16270  IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) goto 180
16271  vint(71)=0.5d0*vint(1)*sqrt(xt2)
16272  nchn=0
16273  CALL pysigh(nchn,sigs)
16274  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
16275  IF(sigs.LT.xsec(isub,1)*pyr(0)) goto 180
16276  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs/vint(320)
16277 
16278 C...Save if highest PT so far.
16279  IF (pt2.GT.pt2mx) THEN
16280  jsmx=0
16281  mimx=mint(31)+1
16282  pt2mx=pt2
16283  ENDIF
16284 
16285 C----------------------------------------------------------------------
16286 C...MODE=1: Generate and save accepted scattering.
16287  ELSEIF (mode.EQ.1) THEN
16288  pt2=pt2now
16289 C...Reset K, P, V, and MCT vectors.
16290  DO 200 i=n+1,n+4
16291  DO 190 j=1,5
16292  k(i,j)=0
16293  p(i,j)=0d0
16294  v(i,j)=0d0
16295  190 CONTINUE
16296  mct(i,1)=0
16297  mct(i,2)=0
16298  200 CONTINUE
16299 
16300  ntry=0
16301 C...Choose flavour of reacting partons (and subprocess).
16302  210 ntry=ntry+1
16303  IF (ntry.GT.50) THEN
16304  CALL pyerrm(9,'(PYPTMI:) Unable to generate additional '
16305  & //'interaction. Giving up!')
16306  mint(51)=1
16307  RETURN
16308  ENDIF
16309  rsigs=sigs*pyr(0)
16310  DO 220 ichn=1,nchn
16311  kfl1=isig(ichn,1)
16312  kfl2=isig(ichn,2)
16313  iconmi=isig(ichn,3)
16314  rsigs=rsigs-sigh(ichn)
16315  IF(rsigs.LE.0d0) goto 230
16316  220 CONTINUE
16317 
16318 C...Reassign to appropriate process codes.
16319  230 isubmi=iconmi/10
16320  iconmi=mod(iconmi,10)
16321 
16322 C...Choose new quark flavour for annihilation graphs
16323  IF(isubmi.EQ.12.OR.isubmi.EQ.53) THEN
16324  sh=vint(21)*vint(2)
16325  CALL pywidt(21,sh,wdtp,wdte)
16326  240 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
16327  DO 250 i=1,mdcy(21,3)
16328  kflf=kfdp(i+mdcy(21,2)-1,1)
16329  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
16330  IF(rkfl.LE.0d0) goto 260
16331  250 CONTINUE
16332  260 IF(isubmi.EQ.53.AND.iconmi.LE.2) THEN
16333  IF(kflf.GE.4) goto 240
16334  ELSEIF(isubmi.EQ.53.AND.iconmi.LE.4) THEN
16335  kflf=4
16336  iconmi=iconmi-2
16337  ELSEIF(isubmi.EQ.53) THEN
16338  kflf=5
16339  iconmi=iconmi-4
16340  ENDIF
16341  ENDIF
16342 
16343 C...Final state flavours and colour flow: default values
16344  js=1
16345  kfl3=kfl1
16346  kfl4=kfl2
16347  kcc=20
16348  kcs=isign(1,kfl1)
16349 
16350  IF(isubmi.EQ.11) THEN
16351 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16352  kcc=iconmi
16353  IF(kfl1*kfl2.LT.0) kcc=kcc+2
16354 
16355  ELSEIF(isubmi.EQ.12) THEN
16356 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16357  kfl3=isign(kflf,kfl1)
16358  kfl4=-kfl3
16359  kcc=4
16360 
16361  ELSEIF(isubmi.EQ.13) THEN
16362 C...f + fbar -> g + g; th arbitrary
16363  kfl3=21
16364  kfl4=21
16365  kcc=iconmi+4
16366 
16367  ELSEIF(isubmi.EQ.28) THEN
16368 C...f + g -> f + g; th = (p(f)-p(f))**2
16369  IF(kfl1.EQ.21) js=2
16370  kcc=iconmi+6
16371  IF(kfl1.EQ.21) kcc=kcc+2
16372  IF(kfl1.NE.21) kcs=isign(1,kfl1)
16373  IF(kfl2.NE.21) kcs=isign(1,kfl2)
16374 
16375  ELSEIF(isubmi.EQ.53) THEN
16376 C...g + g -> f + fbar; th arbitrary
16377  kcs=(-1)**int(1.5d0+pyr(0))
16378  kfl3=isign(kflf,kcs)
16379  kfl4=-kfl3
16380  kcc=iconmi+10
16381 
16382  ELSEIF(isubmi.EQ.68) THEN
16383 C...g + g -> g + g; th arbitrary
16384  kcc=iconmi+12
16385  kcs=(-1)**int(1.5d0+pyr(0))
16386  ENDIF
16387 
16388 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16389  IF (iabs(kfl3).EQ.4.OR.iabs(kfl4).EQ.4.OR.iabs(kfl3).EQ.5
16390  & .OR.iabs(kfl4).EQ.5) THEN
16391  rmmax2=max(pmas(pycomp(kfl3),1),pmas(pycomp(kfl4),1))**2
16392  IF (pt2.LE.1.05*rmmax2) THEN
16393  IF (ntry.EQ.2) CALL pyerrm(9,'(PYPTMI:) Heavy quarks'
16394  & //' too close to threshold (2nd try).')
16395  goto 210
16396  ENDIF
16397  ENDIF
16398 
16399 C...Store flavours of scattering.
16400  mint(13)=kfl1
16401  mint(14)=kfl2
16402  mint(15)=kfl1
16403  mint(16)=kfl2
16404  mint(21)=kfl3
16405  mint(22)=kfl4
16406 
16407 C...Set flavours and mothers of scattering partons.
16408  k(n+1,1)=14
16409  k(n+2,1)=14
16410  k(n+3,1)=3
16411  k(n+4,1)=3
16412  k(n+1,2)=kfl1
16413  k(n+2,2)=kfl2
16414  k(n+3,2)=kfl3
16415  k(n+4,2)=kfl4
16416  k(n+1,3)=mint(83)+1
16417  k(n+2,3)=mint(83)+2
16418  k(n+3,3)=n+1
16419  k(n+4,3)=n+2
16420 
16421 C...Store colour connection indices.
16422  DO 270 j=1,2
16423  jc=j
16424  IF(kcs.EQ.-1) jc=3-j
16425  IF(icol(kcc,1,jc).NE.0) k(n+1,j+3)=n+icol(kcc,1,jc)
16426  IF(icol(kcc,2,jc).NE.0) k(n+2,j+3)=n+icol(kcc,2,jc)
16427  IF(icol(kcc,3,jc).NE.0) k(n+3,j+3)=mstu(5)*(n+icol(kcc,3,jc))
16428  IF(icol(kcc,4,jc).NE.0) k(n+4,j+3)=mstu(5)*(n+icol(kcc,4,jc))
16429  270 CONTINUE
16430 
16431 C...Store incoming and outgoing partons in their CM-frame.
16432  shr=sqrt(vint(21))*vint(1)
16433  p(n+1,3)=0.5d0*shr
16434  p(n+1,4)=0.5d0*shr
16435  p(n+2,3)=-0.5d0*shr
16436  p(n+2,4)=0.5d0*shr
16437  p(n+3,5)=pymass(k(n+3,2))
16438  p(n+4,5)=pymass(k(n+4,2))
16439  IF(p(n+3,5)+p(n+4,5).GE.shr) THEN
16440  ifail=1
16441  RETURN
16442  ENDIF
16443  p(n+3,4)=0.5d0*(shr+(p(n+3,5)**2-p(n+4,5)**2)/shr)
16444  p(n+3,3)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,5)**2))
16445  p(n+4,4)=shr-p(n+3,4)
16446  p(n+4,3)=-p(n+3,3)
16447 
16448 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16449  phi=paru(2)*pyr(0)
16450  CALL pyrobo(n+3,n+4,acos(vint(23)),phi,0d0,0d0,0d0)
16451 
16452 C...Global statistics.
16453  mint(351)=mint(351)+1
16454  vint(351)=vint(351)+sqrt(p(n+3,1)**2+p(n+3,2)**2)
16455  IF (mint(351).EQ.1) vint(356)=sqrt(p(n+3,1)**2+p(n+3,2)**2)
16456 
16457 C...Keep track of loose colour ends and information on scattering.
16458  mint(31)=mint(31)+1
16459  mint(36)=mint(31)
16460  pt2mi(mint(36))=pt2
16461  imisep(mint(31))=n+4
16462  DO 280 js=1,2
16463  imi(js,mint(31),1)=n+js
16464  imi(js,mint(31),2)=0
16465  xmi(js,mint(31))=vint(40+js)
16466  nmi(js)=nmi(js)+1
16467 C...Update cumulative counters
16468  vint(142+js)=vint(142+js)-vint(40+js)
16469  vint(150+js)=vint(150+js)+vint(40+js)
16470  280 CONTINUE
16471 
16472 C...Add to list of final state partons
16473  ipart(npart+1)=n+3
16474  ipart(npart+2)=n+4
16475  ptpart(npart+1)=sqrt(pt2)
16476  ptpart(npart+2)=sqrt(pt2)
16477  npart=npart+2
16478 
16479 C...Initialize ISR
16480  nisgen(1,mint(31))=0
16481  nisgen(2,mint(31))=0
16482 
16483 C...Update ER
16484  n=n+4
16485  IF(n.GT.mstu(4)-mstu(32)-10) THEN
16486  CALL pyerrm(11,'(PYMIGN:) no more memory left in PYJETS')
16487  mint(51)=1
16488  RETURN
16489  ENDIF
16490 
16491 C...Finally, assign colour tags to new partons
16492  DO 300 js=1,2
16493  i1=imi(js,mint(31),1)
16494  i2=imi(3-js,mint(31),1)
16495  DO 290 jcs=4,5
16496  IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
16497  & goto 290
16498  IF (k(i1,jcs)/mstu(5)**2.NE.0) goto 290
16499  kcs=jcs
16500  CALL pycttr(i1,kcs,i2)
16501  IF(mint(51).NE.0) RETURN
16502  290 CONTINUE
16503  300 CONTINUE
16504 
16505 C----------------------------------------------------------------------
16506 C...MODE=2: Decide whether quarks in last scattering were valence,
16507 C...companion, or sea.
16508  ELSEIF (mode.EQ.2) THEN
16509  js=mint(30)
16510  mi=mint(36)
16511  pt2=pt2now
16512  kfsbm=isign(1,mint(10+js))
16513  ifl=k(imi(js,mi,1),2)
16514  imi(js,mi,2)=0
16515  IF (iabs(ifl).GE.6) THEN
16516  IF (iabs(ifl).EQ.6) THEN
16517  CALL pyerrm(29,'(PYPTMI:) top in initial state!')
16518  ENDIF
16519  RETURN
16520  ENDIF
16521 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16522 C...(Do not include the parton itself in the X rescaling.)
16523  x=xmi(js,mi)
16524  xrsc=x/(vint(142+js)+x)
16525 C...Note: XPSVC = x*pdf.
16526  mint(30)=js
16527  CALL pypdfu(kfbeam(js),xrsc,pt2,xpq)
16528  sea=xpsvc(ifl,-1)
16529  val=xpsvc(ifl,0)
16530 C...Ensure that pdfs are positive definite
16531  IF (sea.LT.0d0) THEN
16532  CALL pyerrm(9,'(PYPTMI:) Sea distribution negative.')
16533  sea=max(0d0,sea)
16534  ELSEIF (val.LT.0d0) THEN
16535  CALL pyerrm(9,'(PYPTMI:) Val distribution negative.')
16536  val=max(0d0,val)
16537  ENDIF
16538  cmp=0d0
16539  DO 310 ivc=1,nvc(js,ifl)
16540  cmp=cmp+xpsvc(ifl,ivc)
16541  310 CONTINUE
16542 C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
16543 C...picked up by MPI (necessary since intertwining not implemented)
16544 C...Here simply reclassify companions as ordinary SEA. Will give
16545 C...additional spurious companions, but is simplest solution.
16546  IF (iabs(ifl).EQ.4.OR.iabs(ifl).EQ.5) THEN
16547  sea = sea + cmp
16548  cmp = 0d0
16549  ENDIF
16550 
16551  ntry=0
16552 C...Decide (Extra factor x cancels in the dvision).
16553  320 rvcs=pyr(0)*(sea+val+cmp)
16554  ivnow=1
16555  ntry=ntry+1
16556  330 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
16557 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16558  ivnow=0
16559  IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
16560  IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
16561  IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
16562  IF(kfival(js,1).EQ.0) THEN
16563  IF(kfbeam(js).EQ.111.AND.iabs(ifl).LE.2) ivnow=1
16564  IF(kfbeam(js).EQ.22.AND.iabs(ifl).LE.5) ivnow=1
16565  IF((kfbeam(js).EQ.130.OR.kfbeam(js).EQ.310).AND.
16566  & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
16567  ELSE
16568 C...Count down valence remaining. Do not count current scattering.
16569  DO 340 i1=1,nmi(js)
16570  IF (i1.EQ.mint(36)) goto 340
16571  IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
16572  & ivnow=ivnow-1
16573  340 CONTINUE
16574  ENDIF
16575  IF(ivnow.EQ.0) goto 330
16576 C...Mark valence.
16577  imi(js,mi,2)=0
16578 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16579  IF(kfival(js,1).EQ.0) THEN
16580  IF(kfbeam(js).EQ.111.OR.kfbeam(js).EQ.22) THEN
16581  kfival(js,1)=ifl
16582  kfival(js,2)=-ifl
16583  ELSEIF(kfbeam(js).EQ.130.OR.kfbeam(js).EQ.310) THEN
16584  kfival(js,1)=ifl
16585  IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
16586  IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
16587  ENDIF
16588  ENDIF
16589 
16590  ELSEIF (rvcs.LE.val+sea) THEN
16591 C...If sea, add opposite sign companion parton. Store X and I.
16592  nvc(js,-ifl)=nvc(js,-ifl)+1
16593  xassoc(js,-ifl,nvc(js,-ifl))=xmi(js,mi)
16594 C...Set pointer to companion
16595  imi(js,mi,2)=-nvc(js,-ifl)
16596 
16597  ELSE
16598 C...If companion, check whether we've got any in the books
16599  IF (nvc(js,ifl).EQ.0) THEN
16600  cmp=0d0
16601 C...Only report error first time for this event
16602  IF (ntry.EQ.1)
16603  & CALL pyerrm(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16604 C...Try a few times
16605  IF (ntry.LE.10) THEN
16606  goto 320
16607 C... But if it stil fails, abort this event
16608  ELSE
16609  mint(51)=1
16610  RETURN
16611  ENDIF
16612  ENDIF
16613 C...If several possibilities, decide which one
16614  cmpsum=val+sea
16615  isel=0
16616  350 isel=isel+1
16617  cmpsum=cmpsum+xpsvc(ifl,isel)
16618  IF (rvcs.GT.cmpsum.AND.isel.LT.nvc(js,ifl)) goto 350
16619 C...Find original sea (anti-)quark. Do not consider current scattering.
16620  iassoc=0
16621  DO 360 i1=1,nmi(js)
16622  IF (i1.EQ.mint(36)) goto 360
16623  IF (k(imi(js,i1,1),2).NE.-ifl) goto 360
16624  IF (-imi(js,i1,2).EQ.isel) THEN
16625  imi(js,mi,2)=imi(js,i1,1)
16626  imi(js,i1,2)=imi(js,mi,1)
16627  ENDIF
16628  360 CONTINUE
16629 C...Mark companion "out-kicked".
16630  xassoc(js,ifl,isel)=-xassoc(js,ifl,isel)
16631  ENDIF
16632 
16633  ENDIF
16634  RETURN
16635  END
16636 
16637 C*********************************************************************
16638 
16639 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16640 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16641 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16642 C...corresponds to an unrescaled range between 0 and 1-X.
16643 
16644  FUNCTION pyfcmp(XC,XS,NPOW)
16645  IMPLICIT NONE
16646  DOUBLE PRECISION xc, xs, y, pyfcmp,fac
16647  INTEGER npow
16648 
16649  pyfcmp=0d0
16650 C...Parent gluon momentum fraction
16651  y=xc+xs
16652  IF (y.GE.1d0) RETURN
16653 C...Common factor (includes factor XC, since PYFCMP=x*f)
16654  fac=3d0*xc*xs*(xc**2+xs**2)/(y**4)
16655 C...Store normalized companion x*f distribution.
16656  IF (npow.LE.0) THEN
16657  pyfcmp=fac/(2d0-xs*(3d0-xs*(3d0-2d0*xs)))
16658  ELSEIF (npow.EQ.1) THEN
16659  pyfcmp=fac*(1d0-y)/(2d0+xs**2*(-3d0+xs)+3d0*xs*log(xs))
16660  ELSEIF (npow.EQ.2) THEN
16661  pyfcmp=fac*(1d0-y)**2/(2d0*((1d0-xs)*(1d0+xs*(4d0+xs))
16662  & +3d0*xs*(1d0+xs)*log(xs)))
16663  ELSEIF (npow.EQ.3) THEN
16664  pyfcmp=fac*(1d0-y)**3*2d0/(4d0+27d0*xs-31d0*xs**3
16665  & +6d0*xs*log(xs)*(3d0+2d0*xs*(3d0+xs)))
16666  ELSEIF (npow.GE.4) THEN
16667  pyfcmp=fac*(1d0-y)**4/(2d0*(1d0+2d0*xs)*((1d0-xs)*(1d0+
16668  & xs*(10d0+xs))+6d0*xs*log(xs)*(1d0+xs)))
16669  ENDIF
16670  RETURN
16671  END
16672 
16673 C*********************************************************************
16674 
16675 C...PYPCMP: Auxiliary to PYPDFU.
16676 C...Giving the momentum integral of a companion quark, with its
16677 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16678 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16679 
16680  FUNCTION pypcmp(XS,NPOW)
16681  IMPLICIT NONE
16682  DOUBLE PRECISION xs, pypcmp
16683  INTEGER npow
16684  IF (xs.GE.1d0.OR.xs.LE.0d0) THEN
16685  pypcmp=0d0
16686  ELSEIF (npow.LE.0) THEN
16687  pypcmp=xs*(5d0+xs*(-9d0-2d0*xs*(-3d0+xs))+3d0*log(xs))
16688  pypcmp=pypcmp/((-1d0+xs)*(2d0+xs*(-1d0+2d0*xs)))
16689  ELSEIF (npow.EQ.1) THEN
16690  pypcmp=-1d0-3d0*xs+(2d0*(-1d0+xs)**2*(1d0+xs+xs**2))
16691  & /(2d0+xs**2*(xs-3d0)+3d0*xs*log(xs))
16692  ELSEIF (npow.EQ.2) THEN
16693  pypcmp=xs*((1d0-xs)*(19d0+xs*(43d0+4d0*xs))
16694  & +6d0*log(xs)*(1d0+6d0*xs+4d0*xs**2))
16695  pypcmp=pypcmp/(4d0*((xs-1d0)*(1d0+xs*(4d0+xs))
16696  & -3d0*xs*log(xs)*(1+xs)))
16697  ELSEIF (npow.EQ.3) THEN
16698  pypcmp=3d0*xs*((xs-1)*(7d0+xs*(28d0+13d0*xs))
16699  & -2d0*log(xs)*(1d0+xs*(9d0+2d0*xs*(6d0+xs))))
16700  pypcmp=pypcmp/(4d0+27d0*xs-31d0*xs**3
16701  & +6d0*xs*log(xs)*(3d0+2d0*xs*(3d0+xs)))
16702  ELSE
16703  pypcmp=(-9d0*xs*(xs**2-1d0)*(5d0+xs*(24d0+xs))+12d0*xs*log(xs)
16704  & *(1d0+2d0*xs)*(1d0+2d0*xs*(5d0+2d0*xs)))
16705  pypcmp=pypcmp/(8d0*(1d0+2d0*xs)*((xs-1d0)*(1d0+xs*(10d0+xs))
16706  & -6d0*xs*log(xs)*(1d0+xs)))
16707  ENDIF
16708  RETURN
16709  END
16710 
16711 C*********************************************************************
16712 
16713 C...PYUPRE
16714 C...Rearranges contents of the HEPEUP commonblock so that
16715 C...mothers precede daughters and daughters of a decay are
16716 C...listed consecutively.
16717 
16718  SUBROUTINE pyupre
16719 
16720 C...Double precision and integer declarations.
16721  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16722  IMPLICIT INTEGER(i-n)
16723 
16724 C...User process event common block.
16725  INTEGER maxnup
16726  parameter(maxnup=500)
16727  INTEGER nup,idprup,idup,istup,mothup,icolup
16728  DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
16729  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
16730  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
16731  &vtimup(maxnup),spinup(maxnup)
16732  SAVE /hepeup/
16733 
16734 C...Local arrays.
16735  dimension newpos(0:maxnup),idupt(maxnup),istupt(maxnup),
16736  &motupt(2,maxnup),icoupt(2,maxnup),pupt(5,maxnup),
16737  &vtiupt(maxnup),spiupt(maxnup)
16738 
16739 C...Check whether a rearrangement is required.
16740  need=0
16741  DO 100 iup=1,nup
16742  IF(mothup(1,iup).GT.iup) need=need+1
16743  100 CONTINUE
16744  DO 110 iup=2,nup
16745  IF(mothup(1,iup).LT.mothup(1,iup-1)) need=need+1
16746  110 CONTINUE
16747 
16748  IF(need.NE.0) THEN
16749 C...Find the new order that particles should have.
16750  newpos(0)=0
16751  nnew=0
16752  inew=-1
16753  120 inew=inew+1
16754  DO 130 iup=1,nup
16755  IF(mothup(1,iup).EQ.newpos(inew)) THEN
16756  nnew=nnew+1
16757  newpos(nnew)=iup
16758  ENDIF
16759  130 CONTINUE
16760  IF(inew.LT.nnew.AND.inew.LT.nup) goto 120
16761  IF(nnew.NE.nup) THEN
16762  CALL pyerrm(2,
16763  & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16764  RETURN
16765  ENDIF
16766 
16767 C...Copy old info into temporary storage.
16768  DO 150 i=1,nup
16769  idupt(i)=idup(i)
16770  istupt(i)=istup(i)
16771  motupt(1,i)=mothup(1,i)
16772  motupt(2,i)=mothup(2,i)
16773  icoupt(1,i)=icolup(1,i)
16774  icoupt(2,i)=icolup(2,i)
16775  DO 140 j=1,5
16776  pupt(j,i)=pup(j,i)
16777  140 CONTINUE
16778  vtiupt(i)=vtimup(i)
16779  spiupt(i)=spinup(i)
16780  150 CONTINUE
16781 
16782 C...Copy info back into HEPEUP in right order.
16783  DO 180 i=1,nup
16784  iold=newpos(i)
16785  idup(i)=idupt(iold)
16786  istup(i)=istupt(iold)
16787  mothup(1,i)=0
16788  mothup(2,i)=0
16789  DO 160 imot=1,i-1
16790  IF(motupt(1,iold).EQ.newpos(imot)) mothup(1,i)=imot
16791  IF(motupt(2,iold).EQ.newpos(imot)) mothup(2,i)=imot
16792  160 CONTINUE
16793  IF(mothup(2,i).GT.0.AND.mothup(2,i).LT.mothup(1,i)) THEN
16794  mothsw=mothup(1,i)
16795  mothup(1,i)=mothup(2,i)
16796  mothup(2,i)=mothsw
16797  ENDIF
16798  icolup(1,i)=icoupt(1,iold)
16799  icolup(2,i)=icoupt(2,iold)
16800  DO 170 j=1,5
16801  pup(j,i)=pupt(j,iold)
16802  170 CONTINUE
16803  vtimup(i)=vtiupt(iold)
16804  spinup(i)=spiupt(iold)
16805  180 CONTINUE
16806  ENDIF
16807 
16808 c...If incoming particles are massive recalculate to put them massless.
16809  IF(pup(5,1).NE.0d0.OR.pup(5,2).NE.0d0) THEN
16810  pplus=(pup(4,1)+pup(3,1))+(pup(4,2)+pup(3,2))
16811  pminus=(pup(4,1)-pup(3,1))+(pup(4,2)-pup(3,2))
16812  pup(4,1)=0.5d0*pplus
16813  pup(3,1)=pup(4,1)
16814  pup(5,1)=0d0
16815  pup(4,2)=0.5d0*pminus
16816  pup(3,2)=-pup(4,2)
16817  pup(5,2)=0d0
16818  ENDIF
16819 
16820  RETURN
16821  END
16822 
16823 C*********************************************************************
16824 
16825 C...PYADSH
16826 C...Administers the generation of successive final-state showers
16827 C...in external processes.
16828 
16829  SUBROUTINE pyadsh(NFIN)
16830 
16831 C...Double precision and integer declarations.
16832  IMPLICIT DOUBLE PRECISION(a-h, o-z)
16833  IMPLICIT INTEGER(i-n)
16834  INTEGER pyk,pychge,pycomp
16835 C...Parameter statement for maximum size of showers.
16836  parameter(maxnur=1000)
16837 C...Commonblocks.
16838  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
16839  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16840  common/pyctag/nct,mct(4000,2)
16841  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16842  common/pypars/mstp(200),parp(200),msti(200),pari(200)
16843  common/pyint1/mint(400),vint(400)
16844  SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pypars/,/pyint1/
16845 C...Local array.
16846  dimension ibeg(100),ksav(100,5),psum(4),beta(3)
16847 
16848 C...Set primary vertex.
16849  DO 100 j=1,5
16850  v(mint(83)+5,j)=0d0
16851  v(mint(83)+6,j)=0d0
16852  v(mint(84)+1,j)=0d0
16853  v(mint(84)+2,j)=0d0
16854  100 CONTINUE
16855 
16856 C...Isolate systems of particles with the same mother.
16857  nsys=0
16858  ims=-1
16859  DO 140 i=mint(84)+3,nfin
16860  im=k(i,3)
16861  IF(im.GT.0.AND.im.LE.mint(84)) im=k(im,3)
16862  IF(im.NE.ims) THEN
16863  nsys=nsys+1
16864  ibeg(nsys)=i
16865  ims=im
16866  ENDIF
16867 
16868 C...Set production vertices.
16869  IF(im.LE.mint(83)+6.OR.(im.GT.mint(84).AND.im.LE.mint(84)+2))
16870  & THEN
16871  DO 110 j=1,4
16872  v(i,j)=0d0
16873  110 CONTINUE
16874  ELSE
16875  DO 120 j=1,4
16876  v(i,j)=v(im,j)+v(im,5)*p(im,j)/p(im,5)
16877  120 CONTINUE
16878  ENDIF
16879  IF(mstp(125).GE.1) THEN
16880  idoc=i-mstp(126)+4
16881  DO 130 j=1,5
16882  v(idoc,j)=v(i,j)
16883  130 CONTINUE
16884  ENDIF
16885  140 CONTINUE
16886 
16887 C...End loop over systems. Return if no showers to be performed.
16888  ibeg(nsys+1)=nfin+1
16889  IF(mstp(71).LE.0) RETURN
16890 
16891 C...Loop through systems of particles; check that sensible size.
16892  DO 270 isys=1,nsys
16893  nsiz=ibeg(isys+1)-ibeg(isys)
16894  IF(mint(35).LE.2) THEN
16895  IF(nsiz.EQ.1.AND.isys.EQ.1) THEN
16896  goto 270
16897  ELSEIF(nsiz.LE.1) THEN
16898  CALL pyerrm(2,'(PYADSH:) only one particle in system')
16899  goto 270
16900  ELSEIF(nsiz.GT.80) THEN
16901  CALL pyerrm(2,'(PYADSH:) more than 80 particles in system')
16902  goto 270
16903  ENDIF
16904  ENDIF
16905 
16906 C...Save status codes and daughters of showering particles; reset them.
16907  DO 150 j=1,4
16908  psum(j)=0d0
16909  150 CONTINUE
16910  DO 170 ii=1,nsiz
16911  i=ibeg(isys)-1+ii
16912  ksav(ii,1)=k(i,1)
16913  IF(k(i,1).GT.10) THEN
16914  k(i,1)=1
16915  IF(ksav(ii,1).EQ.14) k(i,1)=3
16916  ENDIF
16917  IF(ksav(ii,1).LE.10) THEN
16918  ELSEIF(k(i,1).EQ.1) THEN
16919  ksav(ii,4)=k(i,4)
16920  ksav(ii,5)=k(i,5)
16921  k(i,4)=0
16922  k(i,5)=0
16923  ELSE
16924  ksav(ii,4)=mod(k(i,4),mstu(5))
16925  ksav(ii,5)=mod(k(i,5),mstu(5))
16926  k(i,4)=k(i,4)-ksav(ii,4)
16927  k(i,5)=k(i,5)-ksav(ii,5)
16928  ENDIF
16929  DO 160 j=1,4
16930  psum(j)=psum(j)+p(i,j)
16931  160 CONTINUE
16932  170 CONTINUE
16933 
16934 C...Perform shower.
16935  qmax=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-
16936  & psum(3)**2))
16937  IF(isys.EQ.1) qmax=min(qmax,sqrt(parp(71))*vint(55))
16938  nsav=n
16939  IF(mint(35).LE.2) THEN
16940  IF(nsiz.EQ.2) THEN
16941  CALL pyshow(ibeg(isys),ibeg(isys)+1,qmax)
16942  ELSE
16943  CALL pyshow(ibeg(isys),-nsiz,qmax)
16944  ENDIF
16945 
16946 C...For external processes, first call, also ISR partons radiate.
16947 C...Can use existing PYPART list, removing partons that radiate later.
16948  ELSEIF(isys.EQ.1) THEN
16949  npartn=0
16950  DO 175 ii=1,npart
16951  IF(ipart(ii).LT.ibeg(2).OR.ipart(ii).GE.ibeg(nsys+1)) THEN
16952  npartn=npartn+1
16953  ipart(npartn)=ipart(ii)
16954  ptpart(npartn)=ptpart(ii)
16955  ENDIF
16956  175 CONTINUE
16957  npart=npartn
16958  CALL pyptfs(1,0.5d0*qmax,0d0,ptgen)
16959  ELSE
16960 C...For subsequent calls use the systems excluded above.
16961  npart=nsiz
16962  npartd=0
16963  DO 180 ii=1,nsiz
16964  i=ibeg(isys)-1+ii
16965  ipart(ii)=i
16966  ptpart(ii)=0.5d0*qmax
16967  180 CONTINUE
16968  CALL pyptfs(2,0.5d0*qmax,0d0,ptgen)
16969  ENDIF
16970 
16971 C...Look up showered copies of original showering particles.
16972  DO 260 ii=1,nsiz
16973  i=ibeg(isys)-1+ii
16974  imv=i
16975 C...Particles without daughters need not be studied.
16976  IF(ksav(ii,1).LE.10) goto 260
16977  IF(n.EQ.nsav.OR.k(i,1).LE.10) THEN
16978  ELSEIF(k(i,1).EQ.11) THEN
16979  190 imv=mod(k(imv,4),mstu(5))
16980  IF(k(imv,1).EQ.11) goto 190
16981  ELSE
16982  kda1=mod(k(i,4),mstu(5))
16983  IF(kda1.GT.0) THEN
16984  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
16985  ENDIF
16986  kda2=mod(k(i,5),mstu(5))
16987  IF(kda2.GT.0) THEN
16988  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
16989  ENDIF
16990  DO 200 i3=i+1,n
16991  IF(k(i3,2).EQ.k(i,2).AND.(i3.EQ.kda1.OR.i3.EQ.kda2))
16992  & THEN
16993  imv=i3
16994  kda1=mod(k(i3,4),mstu(5))
16995  IF(kda1.GT.0) THEN
16996  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
16997  ENDIF
16998  kda2=mod(k(i3,5),mstu(5))
16999  IF(kda2.GT.0) THEN
17000  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
17001  ENDIF
17002  ENDIF
17003  200 CONTINUE
17004  ENDIF
17005 
17006 C...Restore daughter info of original partons to showered copies.
17007  IF(ksav(ii,1).GT.10) k(imv,1)=ksav(ii,1)
17008  IF(ksav(ii,1).LE.10) THEN
17009  ELSEIF(k(i,1).EQ.1) THEN
17010  k(imv,4)=ksav(ii,4)
17011  k(imv,5)=ksav(ii,5)
17012  ELSE
17013  k(imv,4)=k(imv,4)+ksav(ii,4)
17014  k(imv,5)=k(imv,5)+ksav(ii,5)
17015  ENDIF
17016 
17017 C...Reset mother info of existing daughters to showered copies.
17018  DO 210 i3=ibeg(isys+1),nfin
17019  IF(k(i3,3).EQ.i) k(i3,3)=imv
17020  IF(k(i3,1).EQ.3.OR.k(i3,1).EQ.14) THEN
17021  IF(k(i3,4)/mstu(5).EQ.i) k(i3,4)=k(i3,4)+mstu(5)*(imv-i)
17022  IF(k(i3,5)/mstu(5).EQ.i) k(i3,5)=k(i3,5)+mstu(5)*(imv-i)
17023  ENDIF
17024  210 CONTINUE
17025 
17026 C...Boost all original daughters to new frame of showered copy.
17027 C...Also update their colour tags.
17028  IF(imv.NE.i) THEN
17029  DO 220 j=1,3
17030  beta(j)=(p(imv,j)-p(i,j))/(p(imv,4)+p(i,4))
17031  220 CONTINUE
17032  fac=2d0/(1d0+beta(1)**2+beta(2)**2+beta(3)**2)
17033  DO 230 j=1,3
17034  beta(j)=fac*beta(j)
17035  230 CONTINUE
17036  DO 250 i3=ibeg(isys+1),nfin
17037  imo=i3
17038  240 imo=k(imo,3)
17039  IF(mstp(128).LE.0) THEN
17040  IF(imo.GT.0.AND.imo.NE.i.AND.imo.NE.k(i,3)) goto 240
17041  IF(imo.EQ.i.OR.(k(i,3).LE.mint(84).AND.imo.EQ.k(i,3)))
17042  & THEN
17043  CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
17044  IF(mct(i3,1).EQ.mct(i,1)) mct(i3,1)=mct(imv,1)
17045  IF(mct(i3,2).EQ.mct(i,2)) mct(i3,2)=mct(imv,2)
17046  ENDIF
17047  ELSE
17048  IF(imo.EQ.imv) THEN
17049  CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
17050  IF(mct(i3,1).EQ.mct(i,1)) mct(i3,1)=mct(imv,1)
17051  IF(mct(i3,2).EQ.mct(i,2)) mct(i3,2)=mct(imv,2)
17052  ELSEIF(imo.GT.0.AND.imo.NE.i.AND.imo.NE.k(i,3)) THEN
17053  goto 240
17054  ENDIF
17055  ENDIF
17056  250 CONTINUE
17057  ENDIF
17058  260 CONTINUE
17059 
17060 C...End of loop over showering systems
17061  270 CONTINUE
17062 
17063  RETURN
17064  END
17065 
17066 C*********************************************************************
17067 
17068 C...PYVETO
17069 C...Interface to UPVETO, which allows user to veto event generation
17070 C...on the parton level, after parton showers but before multiple
17071 C...interactions, beam remnants and hadronization is added.
17072 
17073  SUBROUTINE pyveto(IVETO)
17074 
17075 C...All real arithmetic in double precision.
17076  IMPLICIT DOUBLE PRECISION(a-h, o-z)
17077 C...Three Pythia functions return integers, so need declaring.
17078  INTEGER pyk,pychge,pycomp
17079 
17080 C...PYTHIA commonblocks.
17081  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
17082  common/pypars/mstp(200),parp(200),msti(200),pari(200)
17083  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
17084  common/pyint1/mint(400),vint(400)
17085  SAVE /pyjets/,/pypars/,/pyint1/
17086 C...HEPEVT commonblock.
17087  parameter(nmxhep=4000)
17088  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
17089  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
17090  DOUBLE PRECISION phep,vhep
17091  SAVE /hepevt/
17092 C...Local array.
17093  dimension ireso(100)
17094 
17095 C...Define longitudinal boost from initiator rest frame to cm frame.
17096  gamma=0.5d0*(vint(141)+vint(142))/sqrt(vint(141)*vint(142))
17097  gabez=0.5d0*(vint(141)-vint(142))/sqrt(vint(141)*vint(142))
17098 
17099 C...Presentation is different if using pT-ordered shower
17100  IF(mint(35).EQ.3) THEN
17101  gamma=1d0
17102  gabez=0d0
17103  ENDIF
17104 
17105 C... Reset counters.
17106  nevhep=0
17107  nhep=0
17108  nreso=0
17109 
17110 C...Oth pass: identify beam and incoming partons
17111  DO 140 i=mint(83)+1,mint(83)+6
17112  istore=0
17113  IF(k(i,2).EQ.94) THEN
17114 
17115  ELSE
17116  nreso=nreso+1
17117  ireso(nreso)=i
17118  imoth=k(i,3)
17119  ENDIF
17120  140 CONTINUE
17121 
17122 C...First pass: identify final locations of resonances
17123 C...and of their daughters before showering.
17124  DO 150 i=mint(84)+3,n
17125  istore=0
17126  imoth=0
17127 
17128 C...Skip shower CM frame documentation lines.
17129  IF(k(i,2).EQ.94) THEN
17130 
17131 C... Store a new intermediate product, when mother in documentation.
17132  ELSEIF(mstp(128).EQ.0.AND.k(i,3).GT.mint(83)+6.AND.
17133  & k(i,3).LE.mint(84)) THEN
17134  istore=1
17135  nhep=nhep+1
17136  ii=nhep
17137  nreso=nreso+1
17138  ireso(nreso)=i
17139  imoth=max(0,k(k(i,3),3)-(mint(83)+6))
17140 
17141 C... Store a new intermediate product, when mother in main section.
17142  ELSEIF(mstp(128).EQ.1.AND.k(i-mint(84)+mint(83)+4,1).EQ.21.AND.
17143  & k(i-mint(84)+mint(83)+4,2).EQ.k(i,2)) THEN
17144  istore=1
17145  nhep=nhep+1
17146  ii=nhep
17147  nreso=nreso+1
17148  ireso(nreso)=i
17149  imoth=max(0,k(i-mint(84)+mint(83)+4,3)-(mint(83)+6))
17150  ENDIF
17151 
17152  IF(istore.EQ.1) THEN
17153 C...Copy parton info, boosting momenta along z axis to cm frame.
17154  isthep(ii)=2
17155  idhep(ii)=k(i,2)
17156  phep(1,ii)=p(i,1)
17157  phep(2,ii)=p(i,2)
17158  phep(3,ii)=gamma*p(i,3)+gabez*p(i,4)
17159  phep(4,ii)=gamma*p(i,4)+gabez*p(i,3)
17160  phep(5,ii)=p(i,5)
17161 C...Store one mother. Rest of history and vertex info zeroed.
17162  jmohep(1,ii)=imoth
17163  jmohep(2,ii)=0
17164  jdahep(1,ii)=0
17165  jdahep(2,ii)=0
17166  vhep(1,ii)=0d0
17167  vhep(2,ii)=0d0
17168  vhep(3,ii)=0d0
17169  vhep(4,ii)=0d0
17170  ENDIF
17171  150 CONTINUE
17172 
17173 C...Second pass: identify current set of "final" partons.
17174  DO 200 i=mint(84)+3,n
17175  istore=0
17176  imoth=0
17177 
17178 C...Store a final parton.
17179  IF(k(i,1).GE.1.AND.k(i,1).LE.10) THEN
17180  istore=1
17181  nhep=nhep+1
17182  ii=nhep
17183 C..Trace it back through shower, to check if from documented particle.
17184  ihist=i
17185  isave=ihist
17186  160 CONTINUE
17187  IF(ihist.GT.mint(84)) THEN
17188  IF(k(ihist,2).EQ.94) ihist=k(ihist,3)+(isave-1-ihist)
17189  DO 170 iri=1,nreso
17190  IF(ihist.EQ.ireso(iri)) imoth=iri
17191  170 CONTINUE
17192  isave=ihist
17193  ihist=k(ihist,3)
17194  IF(imoth.EQ.0) goto 160
17195  imoth=max(0,imoth-6)
17196  ELSEIF(ihist.LE.4) THEN
17197  IF(ihist.EQ.1.OR.ihist.EQ.2) THEN
17198  istore=0
17199  nhep=nhep-1
17200  ELSE
17201  imoth=0
17202  ENDIF
17203  ENDIF
17204  ENDIF
17205 
17206  IF(istore.EQ.1) THEN
17207 C...Copy parton info, boosting momenta along z axis to cm frame.
17208  isthep(ii)=1
17209  idhep(ii)=k(i,2)
17210  phep(1,ii)=p(i,1)
17211  phep(2,ii)=p(i,2)
17212  phep(3,ii)=gamma*p(i,3)+gabez*p(i,4)
17213  phep(4,ii)=gamma*p(i,4)+gabez*p(i,3)
17214  phep(5,ii)=p(i,5)
17215 C...Store one mother. Rest of history and vertex info zeroed.
17216  jmohep(1,ii)=imoth
17217  jmohep(2,ii)=0
17218  jdahep(1,ii)=0
17219  jdahep(2,ii)=0
17220  vhep(1,ii)=0d0
17221  vhep(2,ii)=0d0
17222  vhep(3,ii)=0d0
17223  vhep(4,ii)=0d0
17224  ENDIF
17225  200 CONTINUE
17226 C...Call user-written routine to decide whether to keep events.
17227  CALL upveto(iveto)
17228  RETURN
17229  END
17230 C*********************************************************************
17231 
17232 C...PYRESD
17233 C...Allows resonances to decay (including parton showers for hadronic
17234 C...channels).
17235 
17236  SUBROUTINE pyresd(IRES)
17237 
17238 C...Double precision and integer declarations.
17239  IMPLICIT DOUBLE PRECISION(a-h, o-z)
17240  IMPLICIT INTEGER(i-n)
17241  INTEGER pyk,pychge,pycomp
17242 C...Parameter statement to help give large particle numbers.
17243  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
17244  &kexcit=4000000,kdimen=5000000)
17245 C...Parameter statement for maximum size of showers.
17246  parameter(maxnur=1000)
17247 C...Commonblocks.
17248  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
17249  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
17250  common/pyctag/nct,mct(4000,2)
17251  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
17252  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
17253  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
17254  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
17255  common/pypars/mstp(200),parp(200),msti(200),pari(200)
17256  common/pyint1/mint(400),vint(400)
17257  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
17258  common/pyint4/mwid(500),wids(500,5)
17259  common/pypued/iued(0:99),rued(0:99)
17260  SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,
17261  &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint4/,/pypued/
17262 C...Local arrays and complex and character variables.
17263  dimension iref(50,8),kdcy(3),kfl1(3),kfl2(3),kfl3(3),keql(3),
17264  &kcqm(3),kcq1(3),kcq2(3),kcq3(3),nsd(3),pmmn(4),ilin(6),
17265  &hgz(3,3),coup(6,4),corl(2,2,2),pk(6,4),pkk(6,6),cthe(3),
17266  &phi(3),wdtp(0:400),wdte(0:400,0:5),dpmo(5),vdcy(4),
17267  &itjunc(3),ctm2(3),kcq(0:10),iant(4),itri(4),ioct(4),kcq4(3),
17268  &kfl4(3)
17269  COMPLEX fgk,ha(6,6),hc(6,6)
17270  REAL tir,uir
17271  CHARACTER code*9,mass*9
17272 C...Local arrays.
17273  dimension pv(10,5),rord(10),ue(3),be(3),wtcor(10)
17274  DATA wtcor/2d0,5d0,15d0,60d0,250d0,1500d0,1.2d4,1.2d5,150d0,16d0/
17275 
17276 C...Functions: momentum in two-particle decays and four-product.
17277  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2d0*a)
17278 
17279 C...The F, Xi and Xj functions of Gunion and Kunszt
17280 C...(Phys. Rev. D33, 665, plus errata from the authors).
17281  fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)*
17282  &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))
17283  digk(dt,du)=-4d0*d34*d56+dt*(3d0*dt+4d0*du)+dt**2*(dt*du/
17284  &(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+2d0*(d34/d56+d56/d34))
17285  djgk(dt,du)=8d0*(d34+d56)**2-8d0*(d34+d56)*(dt+du)-6d0*dt*du-
17286  &2d0*dt*du*(dt*du/(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+
17287  &2d0*(d34/d56+d56/d34))
17288 
17289 C...Some general constants.
17290  xw=paru(102)
17291  xwv=xw
17292  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
17293  xw1=1d0-xw
17294  sqmz=pmas(23,1)**2
17295 
17296  gmmz=pmas(23,1)*pmas(23,2)
17297  sqmw=pmas(24,1)**2
17298  gmmw=pmas(24,1)*pmas(24,2)
17299  sh=vint(44)
17300 
17301 C...Boost and rotate to rest frame of incoming partons,
17302 C...to get proper amount of smearing of decay angles.
17303  ibst=0
17304  IF(ires.EQ.0) THEN
17305  ibst=1
17306  iin1=mint(84)+1
17307  iin2=mint(84)+2
17308 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17309 C...(101,102) are off shell and can have inconsistent momenta, resulting
17310 C...in boosts larger than unity. However, the corresponding docu partons
17311 C...(5,6) are kept on shell, and have consistent momenta that can be used
17312 C...to derive this boost instead. Ultimately, should change the way the new
17313 C...shower stores intermediate partons, but just using partons (5,6) for now
17314 C...does define the boost and furnishes a quick and much needed solution.
17315  IF (mint(35).EQ.3) THEN
17316  iin1=mint(83)+5
17317  iin2=mint(83)+6
17318  ENDIF
17319  etotin=p(iin1,4)+p(iin2,4)
17320  bexin=(p(iin1,1)+p(iin2,1))/etotin
17321  beyin=(p(iin1,2)+p(iin2,2))/etotin
17322  bezin=(p(iin1,3)+p(iin2,3))/etotin
17323  CALL pyrobo(mint(83)+7,n,0d0,0d0,-bexin,-beyin,-bezin)
17324  phiin=pyangl(p(mint(84)+1,1),p(mint(84)+1,2))
17325  CALL pyrobo(mint(83)+7,n,0d0,-phiin,0d0,0d0,0d0)
17326  thein=pyangl(p(mint(84)+1,3),p(mint(84)+1,1))
17327  CALL pyrobo(mint(83)+7,n,-thein,0d0,0d0,0d0,0d0)
17328  ENDIF
17329 
17330 C...Reset original resonance configuration.
17331  DO 100 jt=1,8
17332  iref(1,jt)=0
17333  100 CONTINUE
17334 
17335 C...Define initial one, two or three objects for subprocess.
17336  ihdec=0
17337  IF(ires.EQ.0) THEN
17338  isub=mint(1)
17339  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
17340  iref(1,1)=mint(84)+2+iset(isub)
17341  iref(1,4)=mint(83)+6+iset(isub)
17342  jtmax=1
17343  ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
17344  iref(1,1)=mint(84)+1+iset(isub)
17345  iref(1,2)=mint(84)+2+iset(isub)
17346  iref(1,4)=mint(83)+5+iset(isub)
17347  iref(1,5)=mint(83)+6+iset(isub)
17348  jtmax=2
17349  ELSEIF(iset(isub).EQ.5) THEN
17350  iref(1,1)=mint(84)+3
17351  iref(1,2)=mint(84)+4
17352  iref(1,3)=mint(84)+5
17353  iref(1,4)=mint(83)+7
17354  iref(1,5)=mint(83)+8
17355  iref(1,6)=mint(83)+9
17356  jtmax=3
17357  ENDIF
17358 
17359 C...Define original resonance for odd cases.
17360  ELSE
17361  isub=0
17362  IF(k(ires,2).EQ.25.OR.k(ires,2).EQ.35.OR.k(ires,2).EQ.36)
17363  & ihdec=1
17364  IF(ihdec.EQ.1) isub=3
17365  iref(1,1)=ires
17366  iref(1,4)=k(ires,3)
17367  irestm=ires
17368  IF(iref(1,4).GT.mint(84)) THEN
17369  110 itmpmo=iref(1,4)
17370  IF(k(itmpmo,2).EQ.94) THEN
17371  iref(1,4)=k(itmpmo,3)+(irestm-itmpmo-1)
17372  IF(k(iref(1,4),3).LE.mint(84)) iref(1,4)=k(iref(1,4),3)
17373  ELSEIF(k(itmpmo,2).EQ.k(ires,2)) THEN
17374  irestm=itmpmo
17375 C...Explicitly check that reference particle exists, otherwise stop recursion
17376  IF(itmpmo.GT.0.AND.k(itmpmo,3).GT.0) THEN
17377  iref(1,4)=k(itmpmo,3)
17378  goto 110
17379  ENDIF
17380  ENDIF
17381  ENDIF
17382  IF(iref(1,4).GT.mint(84)) THEN
17383  ematch=1d10
17384  iref14=iref(1,4)
17385  DO 120 ii=mint(83)+7,mint(83)+mint(4)
17386  IF(k(ii,2).EQ.k(ires,2).AND.abs(p(ii,4)-p(iref14,4)).LT.
17387  & ematch) THEN
17388  iref(1,4)=ii
17389  ematch=abs(p(ii,4)-p(iref14,4))
17390  ENDIF
17391  120 CONTINUE
17392  ENDIF
17393  jtmax=1
17394  ENDIF
17395 
17396 C...Check if initial resonance has been moved (in resonance + jet).
17397  DO 140 jt=1,3
17398  IF(iref(1,jt).GT.0) THEN
17399  IF(k(iref(1,jt),1).GT.10) THEN
17400  kfa=iabs(k(iref(1,jt),2))
17401  IF(kfa.GE.6.AND.kchg(pycomp(kfa),2).NE.0) THEN
17402  kda1=mod(k(iref(1,jt),4),mstu(5))
17403  kda2=mod(k(iref(1,jt),5),mstu(5))
17404  IF(kda1.GT.iref(1,jt).AND.kda1.LE.n) THEN
17405  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
17406  ENDIF
17407  IF(kda2.GT.iref(1,jt).AND.kda2.LE.n) THEN
17408  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
17409  ENDIF
17410  DO 130 i=iref(1,jt)+1,n
17411  IF(k(i,2).EQ.k(iref(1,jt),2).AND.(i.EQ.kda1.OR.
17412  & i.EQ.kda2)) THEN
17413  iref(1,jt)=i
17414  kda1=mod(k(iref(1,jt),4),mstu(5))
17415  kda2=mod(k(iref(1,jt),5),mstu(5))
17416  IF(kda1.GT.iref(1,jt).AND.kda1.LE.n) THEN
17417  IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
17418  ENDIF
17419  IF(kda2.GT.iref(1,jt).AND.kda2.LE.n) THEN
17420  IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
17421  ENDIF
17422  ENDIF
17423  130 CONTINUE
17424  ELSE
17425  kda=mod(k(iref(1,jt),4),mstu(5))
17426  IF(mwid(pycomp(kfa)).NE.0.AND.kda.GT.1) iref(1,jt)=kda
17427  ENDIF
17428  ENDIF
17429  ENDIF
17430  140 CONTINUE
17431 
17432 C...Set decay vertex for initial resonances
17433  DO 160 jt=1,jtmax
17434  DO 150 i=1,4
17435  v(iref(1,jt),i)=0d0
17436  150 CONTINUE
17437  160 CONTINUE
17438 
17439 C...Loop over decay history.
17440  np=1
17441  ip=0
17442  170 ip=ip+1
17443  ninh=0
17444  jtmax=2
17445  IF(iref(ip,2).EQ.0) jtmax=1
17446  IF(iref(ip,3).NE.0) jtmax=3
17447  it4=0
17448  nsav=n
17449 
17450 C...Check for Higgs which appears as decay product of user-process.
17451  IF(isub.EQ.0) THEN
17452  ihdec=0
17453  IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
17454  & .EQ.36) ihdec=1
17455  IF(ihdec.EQ.1) isub=3
17456  ENDIF
17457 
17458 C...Start treatment of one, two or three resonances in parallel.
17459  180 n=nsav
17460  DO 340 jt=1,jtmax
17461  id=iref(ip,jt)
17462  kdcy(jt)=0
17463  kfl1(jt)=0
17464  kfl2(jt)=0
17465  kfl3(jt)=0
17466  kfl4(jt)=0
17467  keql(jt)=0
17468  nsd(jt)=id
17469  itjunc(jt)=0
17470 
17471 C...Check whether particle can/is allowed to decay.
17472  IF(id.EQ.0) goto 330
17473  kfa=iabs(k(id,2))
17474  kca=pycomp(kfa)
17475  IF(mwid(kca).EQ.0) goto 330
17476  IF(k(id,1).GT.10.OR.mdcy(kca,1).EQ.0) goto 330
17477  IF(kfa.EQ.6.OR.kfa.EQ.7.OR.kfa.EQ.8.OR.kfa.EQ.17.OR.
17478  & kfa.EQ.18) it4=it4+1
17479  k(id,4)=mstu(5)*(k(id,4)/mstu(5))
17480  k(id,5)=mstu(5)*(k(id,5)/mstu(5))
17481 
17482 C...Choose lifetime and determine decay vertex.
17483  IF(k(id,1).EQ.5) THEN
17484  v(id,5)=0d0
17485  ELSEIF(k(id,1).NE.4) THEN
17486  v(id,5)=-pmas(kca,4)*log(pyr(0))
17487  ENDIF
17488  DO 190 j=1,4
17489  vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
17490  190 CONTINUE
17491 
17492 C...Determine whether decay allowed or not.
17493  mout=0
17494  IF(mstj(22).EQ.2) THEN
17495  IF(pmas(kca,4).GT.parj(71)) mout=1
17496  ELSEIF(mstj(22).EQ.3) THEN
17497  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
17498  ELSEIF(mstj(22).EQ.4) THEN
17499  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
17500  IF(abs(vdcy(3)).GT.parj(74)) mout=1
17501  ENDIF
17502  IF(mout.EQ.1.AND.k(id,1).NE.5) THEN
17503  k(id,1)=4
17504  goto 330
17505  ENDIF
17506 
17507 C...Info for selection of decay channel: sign, pairings.
17508  IF(kchg(kca,3).EQ.0) THEN
17509  ipm=2
17510  ELSE
17511  ipm=(5-isign(1,k(id,2)))/2
17512  ENDIF
17513  kfb=0
17514  IF(jtmax.EQ.2) THEN
17515  kfb=iabs(k(iref(ip,3-jt),2))
17516  ELSEIF(jtmax.EQ.3) THEN
17517  jt2=jt+1-3*(jt/3)
17518  kfb=iabs(k(iref(ip,jt2),2))
17519  IF(kfb.NE.kfa) THEN
17520  jt2=jt+2-3*((jt+1)/3)
17521  kfb=iabs(k(iref(ip,jt2),2))
17522  ENDIF
17523  ENDIF
17524 
17525 C...Select decay channel.
17526  IF(isub.EQ.1.OR.isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.
17527  & isub.EQ.30.OR.isub.EQ.35.OR.isub.EQ.141) mint(61)=1
17528  CALL pywidt(kfa,p(id,5)**2,wdtp,wdte)
17529  wdte0s=wdte(0,1)+wdte(0,ipm)+wdte(0,4)
17530  IF(kfb.EQ.kfa) wdte0s=wdte0s+wdte(0,5)
17531  IF(wdte0s.LE.0d0) goto 330
17532  rkfl=wdte0s*pyr(0)
17533  idl=0
17534  200 idl=idl+1
17535  idc=idl+mdcy(kca,2)-1
17536  rkfl=rkfl-(wdte(idl,1)+wdte(idl,ipm)+wdte(idl,4))
17537  IF(kfb.EQ.kfa) rkfl=rkfl-wdte(idl,5)
17538  IF(idl.LT.mdcy(kca,3).AND.rkfl.GT.0d0) goto 200
17539 
17540  nprod=0
17541 C...Read out flavours and colour charges of decay channel chosen.
17542  kcqm(jt)=kchg(kca,2)*isign(1,k(id,2))
17543  IF(kcqm(jt).EQ.-2) kcqm(jt)=2
17544  kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))
17545  kfc1a=pycomp(iabs(kfl1(jt)))
17546  IF(kchg(kfc1a,3).EQ.0) kfl1(jt)=iabs(kfl1(jt))
17547  nprod=nprod+1
17548  kcq1(jt)=kchg(kfc1a,2)*isign(1,kfl1(jt))
17549  IF(kcq1(jt).EQ.-2) kcq1(jt)=2
17550  kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))
17551  kfc2a=pycomp(iabs(kfl2(jt)))
17552  IF(kchg(kfc2a,3).EQ.0) kfl2(jt)=iabs(kfl2(jt))
17553  kcq2(jt)=kchg(kfc2a,2)*isign(1,kfl2(jt))
17554  IF(kcq2(jt).EQ.-2) kcq2(jt)=2
17555  nprod=nprod+1
17556  kfl3(jt)=kfdp(idc,3)*isign(1,k(id,2))
17557  kcq3(jt)=0
17558  kfl4(jt)=kfdp(idc,4)*isign(1,k(id,2))
17559  kcq4(jt)=0
17560  IF(kfl3(jt).NE.0) THEN
17561  kfc3a=pycomp(iabs(kfl3(jt)))
17562  IF(kchg(kfc3a,3).EQ.0) kfl3(jt)=iabs(kfl3(jt))
17563  kcq3(jt)=kchg(kfc3a,2)*isign(1,kfl3(jt))
17564  IF(kcq3(jt).EQ.-2) kcq3(jt)=2
17565  nprod=nprod+1
17566  IF(kfl4(jt).NE.0) THEN
17567  kfc4a=pycomp(iabs(kfl4(jt)))
17568  IF(kchg(kfc4a,3).EQ.0) kfl4(jt)=iabs(kfl4(jt))
17569  kcq4(jt)=kchg(kfc4a,2)*isign(1,kfl4(jt))
17570  IF(kcq4(jt).EQ.-2) kcq4(jt)=2
17571  nprod=nprod+1
17572  ENDIF
17573  ENDIF
17574 
17575 C...Set/save further info on channel.
17576  kdcy(jt)=1
17577  IF(kfb.EQ.kfa) keql(jt)=mdme(idc,1)
17578  nsd(jt)=n
17579  hgz(jt,1)=vint(111)
17580  hgz(jt,2)=vint(112)
17581  hgz(jt,3)=vint(114)
17582  jtz=jt
17583 
17584  pxsum=0d0
17585 C...Select masses; to begin with assume resonances narrow.
17586  DO 220 i=1,4
17587  p(n+i,5)=0d0
17588  pmmn(i)=0d0
17589  IF(i.EQ.1) THEN
17590  kflw=iabs(kfl1(jt))
17591  kcw=kfc1a
17592  ELSEIF(i.EQ.2) THEN
17593  kflw=iabs(kfl2(jt))
17594  kcw=kfc2a
17595  ELSEIF(i.EQ.3) THEN
17596  IF(kfl3(jt).EQ.0) goto 220
17597  kflw=iabs(kfl3(jt))
17598  kcw=kfc3a
17599  ELSEIF(i.EQ.4) THEN
17600  IF(kfl4(jt).EQ.0) goto 220
17601  kflw=iabs(kfl4(jt))
17602  kcw=kfc4a
17603  ENDIF
17604  p(n+i,5)=pmas(kcw,1)
17605  pxsum=pxsum+p(n+i,5)
17606 CMRENNA++
17607 C...This prevents SUSY/t particles from becoming too light.
17608  IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
17609  pmmn(i)=pmas(kcw,1)
17610  DO 210 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
17611  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
17612  pmsum=pmas(pycomp(kfdp(idc,1)),1)+
17613  & pmas(pycomp(kfdp(idc,2)),1)
17614  IF(kfdp(idc,3).NE.0) pmsum=pmsum+
17615  & pmas(pycomp(kfdp(idc,3)),1)
17616  IF(kfdp(idc,4).NE.0) pmsum=pmsum+
17617  & pmas(pycomp(kfdp(idc,4)),1)
17618  pmmn(i)=min(pmmn(i),pmsum)
17619  ENDIF
17620  210 CONTINUE
17621 C MRENNA--
17622  ELSEIF(kflw.EQ.6) THEN
17623  pmmn(i)=pmas(24,1)+pmas(5,1)
17624  ENDIF
17625 C...UED: select a graviton mass from continuous distribution
17626 C...(stored in PMAS(39,1) so no value returned)
17627  IF (iued(1).EQ.1.AND.iued(2).EQ.1.AND.kflw.EQ.39)
17628  & CALL pygram(1)
17629  220 CONTINUE
17630 
17631 C...Check which two out of three are widest.
17632  iwid1=1
17633  iwid2=2
17634  pwid1=pmas(kfc1a,2)
17635  pwid2=pmas(kfc2a,2)
17636  kflw1=iabs(kfl1(jt))
17637  kflw2=iabs(kfl2(jt))
17638  IF(kfl3(jt).NE.0) THEN
17639  pwid3=pmas(kfc3a,2)
17640  IF(pwid3.GT.pwid1.AND.pwid2.GE.pwid1) THEN
17641  iwid1=3
17642  pwid1=pwid3
17643  kflw1=iabs(kfl3(jt))
17644  ELSEIF(pwid3.GT.pwid2) THEN
17645  iwid2=3
17646  pwid2=pwid3
17647  kflw2=iabs(kfl3(jt))
17648  ENDIF
17649  ENDIF
17650  IF(kfl4(jt).NE.0) THEN
17651  pwid4=pmas(kfc4a,2)
17652  IF(pwid4.GT.pwid1.AND.pwid2.GE.pwid1) THEN
17653  iwid1=4
17654  pwid1=pwid4
17655  kflw1=iabs(kfl4(jt))
17656  ELSEIF(pwid4.GT.pwid2) THEN
17657  iwid2=4
17658  pwid2=pwid4
17659  kflw2=iabs(kfl4(jt))
17660  ENDIF
17661  ENDIF
17662 
17663 C...If all narrow then only check that masses consistent.
17664  IF(mstp(42).LE.0.OR.(pwid1.LT.parp(41).AND.
17665  & pwid2.LT.parp(41))) THEN
17666 CMRENNA++
17667 C....Handle near degeneracy cases.
17668  IF(kfa/ksusy1.EQ.1.OR.kfa/ksusy1.EQ.2) THEN
17669  IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
17670  p(n+1,5)=p(id,5)-p(n+2,5)-0.5d0
17671  IF(p(n+1,5).LT.0d0) p(n+1,5)=0d0
17672  ENDIF
17673  ENDIF
17674 CMRENNA--
17675  IF(pxsum.GT.p(id,5)) THEN
17676  CALL pyerrm(13,'(PYRESD:) daughter masses too large')
17677  mint(51)=1
17678  goto 720
17679  ELSEIF(pxsum+parj(64).GT.p(id,5)) THEN
17680  CALL pyerrm(3,'(PYRESD:) masses+PARJ(64) too large')
17681  mint(51)=1
17682  goto 720
17683  ENDIF
17684 
17685 C...For three wide resonances select narrower of three
17686 C...according to BW decoupled from rest.
17687  ELSE
17688  pmtot=p(id,5)
17689  IF(kfl3(jt).NE.0) THEN
17690  iwid3=6-iwid1-iwid2
17691  kflw3=iabs(kfl1(jt))+iabs(kfl2(jt))+iabs(kfl3(jt))-
17692  & kflw1-kflw2
17693  loop=0
17694  230 loop=loop+1
17695  p(n+iwid3,5)=pymass(kflw3)
17696  IF(loop.LE.10.AND. p(n+iwid3,5).LE.pmmn(iwid3)) goto 230
17697  pmtot=pmtot-p(n+iwid3,5)
17698  ENDIF
17699 C...Select other two correlated within remaining phase space.
17700  IF(ip.EQ.1) THEN
17701  ckin45=ckin(45)
17702  ckin47=ckin(47)
17703  ckin(45)=max(pmmn(iwid1),ckin(45))
17704  ckin(47)=max(pmmn(iwid2),ckin(47))
17705  CALL pyofsh(2,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
17706  & p(n+iwid2,5))
17707  ckin(45)=ckin45
17708  ckin(47)=ckin47
17709  ELSE
17710  ckin(49)=pmmn(iwid1)
17711  ckin(50)=pmmn(iwid2)
17712  CALL pyofsh(5,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
17713  & p(n+iwid2,5))
17714  ckin(49)=0d0
17715  ckin(50)=0d0
17716  ENDIF
17717  IF(mint(51).EQ.1) goto 720
17718  ENDIF
17719 
17720 C...Begin fill decay products, with colour flow for coloured objects.
17721  mstu10=mstu(10)
17722  mstu(10)=1
17723  mstu(19)=1
17724 
17725 
17726 C...Three-body decays
17727  IF(kfl3(jt).NE.0.OR.kfl4(jt).NE.0) THEN
17728  DO 250 i=n+1,n+nprod
17729  DO 240 j=1,5
17730  k(i,j)=0
17731  v(i,j)=0d0
17732  240 CONTINUE
17733  mct(i,1)=0
17734  mct(i,2)=0
17735  250 CONTINUE
17736  k(n+1,1)=1
17737  k(n+1,2)=kfl1(jt)
17738  k(n+2,1)=1
17739  k(n+2,2)=kfl2(jt)
17740  k(n+3,1)=1
17741  k(n+3,2)=kfl3(jt)
17742  IF(kfl4(jt).NE.0) THEN
17743  k(n+4,1)=1
17744  k(n+4,2)=kfl4(jt)
17745  ENDIF
17746  idin=id
17747 
17748 C...Generate kinematics (default is flat)
17749  IF(kfl4(jt).EQ.0) THEN
17750  CALL pytbdy(idin)
17751  ELSE
17752  ps=p(n+1,5)+p(n+2,5)+p(n+3,5)+p(n+4,5)
17753  nd=4
17754  pv(1,1)=0d0
17755  pv(1,2)=0d0
17756  pv(1,3)=0d0
17757  pv(1,4)=p(idin,5)
17758  pv(1,5)=p(idin,5)
17759 C...Calculate maximum weight ND-particle decay.
17760  pv(nd,5)=p(n+nd,5)
17761  wtmax=1d0/wtcor(nd-2)
17762  pmax=pv(1,5)-ps+p(n+nd,5)
17763  pmin=0d0
17764  DO 381 il=nd-1,1,-1
17765  pmax=pmax+p(n+il,5)
17766  pmin=pmin+p(n+il+1,5)
17767  wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
17768  381 CONTINUE
17769 
17770 C...M-generator gives weight. If rejected, try again.
17771 
17772  411 rord(1)=1d0
17773  DO 441 il1=2,nd-1
17774  rsav=pyr(0)
17775  DO 421 il2=il1-1,1,-1
17776  IF(rsav.LE.rord(il2)) goto 431
17777  rord(il2+1)=rord(il2)
17778  421 CONTINUE
17779  431 rord(il2+1)=rsav
17780  441 CONTINUE
17781  rord(nd)=0d0
17782  wt=1d0
17783  DO 451 il=nd-1,1,-1
17784  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*
17785  & (pv(1,5)-ps)
17786  wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
17787  451 CONTINUE
17788  IF(wt.LT.pyr(0)*wtmax) goto 411
17789 
17790 C...Perform two-particle decays in respective CM frame.
17791  DO 481 il=1,nd-1
17792  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
17793  ue(3)=2d0*pyr(0)-1d0
17794  phix=paru(2)*pyr(0)
17795  ue(1)=sqrt(1d0-ue(3)**2)*cos(phix)
17796  ue(2)=sqrt(1d0-ue(3)**2)*sin(phix)
17797  DO 471 j=1,3
17798  p(n+il,j)=pa*ue(j)
17799  pv(il+1,j)=-pa*ue(j)
17800  471 CONTINUE
17801  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
17802  pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
17803  481 CONTINUE
17804 
17805 C...Lorentz transform decay products to lab frame.
17806  DO 491 j=1,4
17807  p(n+nd,j)=pv(nd,j)
17808  491 CONTINUE
17809  DO 531 il=nd-1,1,-1
17810  DO 501 j=1,3
17811  be(j)=pv(il,j)/pv(il,4)
17812  501 CONTINUE
17813  ga=pv(il,4)/pv(il,5)
17814  DO 521 i=n+il,n+nd
17815  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
17816  DO 511 j=1,3
17817  p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
17818  511 CONTINUE
17819  p(i,4)=ga*(p(i,4)+bep)
17820  521 CONTINUE
17821  531 CONTINUE
17822 
17823  ENDIF
17824 
17825 C...Set generic colour flows whenever unambiguous,
17826 C...(independently of the order of the decay products)
17827 C...Sum up total colour content
17828  nant=0
17829  ntri=0
17830  noct=0
17831  kcq(0)=kcqm(jt)
17832  kcq(1)=kcq1(jt)
17833  kcq(2)=kcq2(jt)
17834  kcq(3)=kcq3(jt)
17835  kcq(4)=kcq4(jt)
17836  DO 255 j=0,nprod
17837  IF (kcq(j).EQ.-1) THEN
17838  nant=nant+1
17839  iant(nant)=n+j
17840  ELSEIF (kcq(j).EQ.1) THEN
17841  ntri=ntri+1
17842  itri(ntri)=n+j
17843  ELSEIF (kcq(j).EQ.2) THEN
17844  noct=noct+1
17845  ioct(noct)=n+j
17846  ENDIF
17847  255 CONTINUE
17848 
17849 C...Set color flow for generic 1 -> N processes (N arbitrary)
17850  IF (ntri.EQ.0.AND.nant.EQ.0.AND.noct.EQ.0) THEN
17851 C...All singlets: do nothing
17852 
17853  ELSEIF (noct.EQ.2.AND.ntri.EQ.0.AND.nant.EQ.0) THEN
17854 C...Two octets, zero triplets, n singlets:
17855  IF (kcq(0).EQ.2) THEN
17856 C...8 -> 8 + n(1)
17857  k(id,4)=k(id,4)+ioct(2)
17858  k(id,5)=k(id,5)+ioct(2)
17859  k(ioct(2),1)=3
17860  k(ioct(2),4)=mstu(5)*id
17861  k(ioct(2),5)=mstu(5)*id
17862  mct(ioct(2),1)=mct(id,1)
17863  mct(ioct(2),2)=mct(id,2)
17864  ELSE
17865 C...1 -> 8 + 8 + n(1)
17866  k(ioct(1),1)=3
17867  k(ioct(1),4)=mstu(5)*ioct(2)
17868  k(ioct(1),5)=mstu(5)*ioct(2)
17869  k(ioct(2),1)=3
17870  k(ioct(2),4)=mstu(5)*ioct(1)
17871  k(ioct(2),5)=mstu(5)*ioct(1)
17872  nct=nct+1
17873  mct(ioct(1),1)=nct
17874  mct(ioct(2),2)=nct
17875  nct=nct+1
17876  mct(ioct(2),1)=nct
17877  mct(ioct(1),2)=nct
17878  ENDIF
17879 
17880  ELSEIF (ntri+nant.EQ.2.AND.noct.EQ.0) THEN
17881 C...Two triplets, zero octets, n singlets.
17882  IF (kcq(0).EQ.1) THEN
17883 C...3 -> 3 + n(1)
17884  k(id,4)=k(id,4)+itri(2)
17885  k(itri(2),1)=3
17886  k(itri(2),4)=mstu(5)*id
17887  mct(itri(2),1)=mct(id,1)
17888  ELSEIF (kcq(0).EQ.-1) THEN
17889 C...3bar -> 3bar + n(1)
17890  k(id,5)=k(id,5)+iant(2)
17891  k(iant(2),1)=3
17892  k(iant(2),5)=mstu(5)*id
17893  mct(iant(2),2)=mct(id,2)
17894  ELSE
17895 C...1 -> 3 + 3bar + n(1)
17896  k(itri(1),1)=3
17897  k(itri(1),4)=mstu(5)*iant(1)
17898  k(iant(1),1)=3
17899  k(iant(1),5)=mstu(5)*itri(1)
17900  nct=nct+1
17901  mct(itri(1),1)=nct
17902  mct(iant(1),2)=nct
17903  ENDIF
17904 
17905  ELSEIF(ntri+nant.EQ.2.AND.noct.EQ.1) THEN
17906 C...Two triplets, one octet, n singlets.
17907  IF (kcq(0).EQ.2) THEN
17908 C...8 -> 3 + 3bar + n(1)
17909  k(id,4)=k(id,4)+itri(1)
17910  k(id,5)=k(id,5)+iant(1)
17911  k(itri(1),1)=3
17912  k(itri(1),4)=mstu(5)*id
17913  k(iant(1),1)=3
17914  k(iant(1),5)=mstu(5)*id
17915  mct(itri(1),1)=mct(id,1)
17916  mct(iant(1),2)=mct(id,2)
17917  ELSEIF (kcq(0).EQ.1) THEN
17918 C...3 -> 8 + 3 + n(1)
17919  k(id,4)=k(id,4)+ioct(1)
17920  k(ioct(1),1)=3
17921  k(ioct(1),4)=mstu(5)*id
17922  k(ioct(1),5)=mstu(5)*itri(2)
17923  k(itri(2),1)=3
17924  k(itri(2),4)=mstu(5)*ioct(1)
17925  mct(ioct(1),1)=mct(id,1)
17926  nct=nct+1
17927  mct(ioct(1),2)=nct
17928  mct(itri(2),1)=nct
17929  ELSEIF (kcq(0).EQ.-1) THEN
17930 C...3bar -> 8 + 3bar + n(1)
17931  k(id,5)=k(id,5)+ioct(1)
17932  k(ioct(1),1)=3
17933  k(ioct(1),5)=mstu(5)*id
17934  k(ioct(1),4)=mstu(5)*iant(2)
17935  k(iant(2),1)=3
17936  k(iant(2),5)=mstu(5)*ioct(1)
17937  mct(ioct(1),2)=mct(id,2)
17938  nct=nct+1
17939  mct(ioct(1),1)=nct
17940  mct(iant(2),2)=nct
17941  ELSE
17942 C...1 -> 3 + 3bar + 8 + n(1)
17943  k(itri(1),1)=3
17944  k(itri(1),4)=mstu(5)*ioct(1)
17945  k(ioct(1),1)=3
17946  k(ioct(1),5)=mstu(5)*itri(1)
17947  k(ioct(1),4)=mstu(5)*iant(1)
17948  k(iant(1),1)=3
17949  k(iant(1),5)=mstu(5)*ioct(1)
17950  nct=nct+1
17951  mct(itri(1),1)=nct
17952  mct(ioct(1),2)=nct
17953  nct=nct+1
17954  mct(ioct(1),1)=nct
17955  mct(iant(1),2)=nct
17956  ENDIF
17957  ELSEIF(ntri+nant.EQ.4) THEN
17958 C...
17959  IF (kcq(0).EQ.1) THEN
17960 C...3 -> 3 + n(1) -> 3 + 3bar
17961  k(id,4)=k(id,4)+itri(2)
17962  k(itri(2),1)=3
17963  k(itri(2),4)=mstu(5)*id
17964  mct(itri(2),1)=mct(id,1)
17965  k(itri(3),1)=3
17966  k(itri(3),4)=mstu(5)*iant(1)
17967  k(iant(1),1)=3
17968  k(iant(1),5)=mstu(5)*itri(3)
17969  nct=nct+1
17970  mct(itri(3),1)=nct
17971  mct(iant(1),2)=nct
17972  ELSEIF (kcq(0).EQ.-1) THEN
17973 C...3bar -> 3bar + n(1) -> 3 + 3bar
17974  k(id,5)=k(id,5)+iant(2)
17975  k(iant(2),1)=3
17976  k(iant(2),5)=mstu(5)*id
17977  mct(iant(2),2)=mct(id,2)
17978  k(itri(1),1)=3
17979  k(itri(1),4)=mstu(5)*iant(3)
17980  k(iant(3),1)=3
17981  k(iant(3),5)=mstu(5)*itri(1)
17982  nct=nct+1
17983  mct(itri(1),1)=nct
17984  mct(iant(3),2)=nct
17985  ENDIF
17986  ELSEIF(kfl4(jt).NE.0) THEN
17987  CALL pyerrm(21,'(PYRESD:) unknown 4-bdy decay')
17988 CPS-- End of generic cases
17989 C...(could three octets also be handled?)
17990 C...(could (some of) the RPV cases be made generic as well?)
17991 
17992 C...Special cases (= old treatment)
17993 C...Set colour flow for t -> W + b + Z.
17994  ELSEIF(kfa.EQ.6) THEN
17995  k(n+2,1)=3
17996  isid=4
17997  IF(kcqm(jt).EQ.-1) isid=5
17998  idau=n+2
17999  k(id,isid)=k(id,isid)+idau
18000  k(idau,isid)=mstu(5)*id
18001 
18002 C...Set colour flow in three-body decays - programmed as special cases.
18003 
18004  ELSEIF(kfc2a.LE.6) THEN
18005  k(n+2,1)=3
18006  k(n+3,1)=3
18007  isid=4
18008  IF(kfl2(jt).LT.0) isid=5
18009  k(n+2,isid)=mstu(5)*(n+3)
18010  k(n+3,9-isid)=mstu(5)*(n+2)
18011 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
18012  ELSEIF(kfa.GT.ksusy1.AND.mod(kfa,ksusy1).LT.10
18013  & .AND.kfl3(jt).NE.0) THEN
18014  kqsuma=iabs(kcq1(jt))+iabs(kcq2(jt))+iabs(kcq3(jt))
18015 C...3-body decays of squarks to colour singlets plus one quark
18016  IF (kqsuma.EQ.1) THEN
18017 C...Find quark
18018  iq=0
18019  IF (kcq1(jt).NE.0) iq=1
18020  IF (kcq2(jt).NE.0) iq=2
18021  IF (kcq3(jt).NE.0) iq=3
18022  isid=4
18023  IF (k(n+iq,2).LT.0) isid=5
18024  k(n+iq,1)=3
18025  k(id,isid)=k(id,isid)+(n+iq)
18026  k(n+iq,isid)=mstu(5)*id
18027  ENDIF
18028 C...PS--
18029  ELSEIF(kfl1(jt).EQ.ksusy1+21) THEN
18030  k(n+1,1)=3
18031  k(n+2,1)=3
18032  k(n+3,1)=3
18033  isid=4
18034  IF(kfl2(jt).LT.0) isid=5
18035  k(n+1,isid)=mstu(5)*(n+2)
18036  k(n+1,9-isid)=mstu(5)*(n+3)
18037  k(n+2,isid)=mstu(5)*(n+1)
18038  k(n+3,9-isid)=mstu(5)*(n+1)
18039  ELSEIF(kfa.EQ.ksusy1+21) THEN
18040  k(n+2,1)=3
18041  k(n+3,1)=3
18042  isid=4
18043  IF(kfl2(jt).LT.0) isid=5
18044  k(id,isid)=k(id,isid)+(n+2)
18045  k(id,9-isid)=k(id,9-isid)+(n+3)
18046  k(n+2,isid)=mstu(5)*id
18047  k(n+3,9-isid)=mstu(5)*id
18048 CMRENNA--
18049 
18050  ELSEIF(kfa.GE.ksusy1+22.AND.kfa.LE.ksusy1+37.AND.
18051  & iabs(kcq2(jt)).EQ.1) THEN
18052  k(n+2,1)=3
18053  k(n+3,1)=3
18054  isid=4
18055  IF(kfl2(jt).LT.0) isid=5
18056  k(n+2,isid)=mstu(5)*(n+3)
18057  k(n+3,9-isid)=mstu(5)*(n+2)
18058  ENDIF
18059 
18060 CXXX NSAV=N
18061 
18062 C...Set colour flow in three-body decays with baryon number violation.
18063 C...Neutralino and chargino decays first.
18064  kcqsum=kcq1(jt)+kcq2(jt)+kcq3(jt)
18065  IF(kcqm(jt).EQ.0.AND.iabs(kcqsum).EQ.3) THEN
18066  itjunc(jt)=(1+(1-kcq1(jt))/2)
18067  k(n+4,4)=itjunc(jt)*mstu(5)
18068 C...Insert junction to keep track of colours.
18069  IF(kcq1(jt).NE.0) k(n+1,1)=3
18070  IF(kcq2(jt).NE.0) k(n+2,1)=3
18071  IF(kcq3(jt).NE.0) k(n+3,1)=3
18072 C...Set special junction codes:
18073  k(n+4,1)=42
18074  k(n+4,2)=88
18075 
18076 C...Order decay products by invariant mass. (will be used in PYSTRF).
18077  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)-
18078  & p(n+1,3)*p(n+2,3)
18079  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)-
18080  & p(n+1,3)*p(n+3,3)
18081  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)-
18082  & p(n+2,3)*p(n+3,3)
18083  IF(pm12.LT.pm13.AND.pm12.LT.pm23) THEN
18084  k(n+4,4)=n+3+k(n+4,4)
18085  k(n+4,5)=n+1+mstu(5)*(n+2)
18086  ELSEIF(pm13.LT.pm23) THEN
18087  k(n+4,4)=n+2+k(n+4,4)
18088  k(n+4,5)=n+1+mstu(5)*(n+3)
18089  ELSE
18090  k(n+4,4)=n+1+k(n+4,4)
18091  k(n+4,5)=n+2+mstu(5)*(n+3)
18092  ENDIF
18093  DO 260 j=1,5
18094  p(n+4,j)=0d0
18095  v(n+4,j)=0d0
18096  260 CONTINUE
18097 C...Connect daughters to junction.
18098  DO 270 ii=n+1,n+3
18099  k(ii,4)=0
18100  k(ii,5)=0
18101  k(ii,itjunc(jt)+3)=mstu(5)*(n+4)
18102  270 CONTINUE
18103 C...Particle counter should be stepped up one extra for junction.
18104  n=n+1
18105 
18106 C...Gluino decays.
18107  ELSEIF (kcqm(jt).EQ.2.AND.iabs(kcqsum).EQ.3) THEN
18108  itjunc(jt)=(5+(1-kcq1(jt))/2)
18109  k(n+4,4)=itjunc(jt)*mstu(5)
18110 C...Insert junction to keep track of colours.
18111  IF(kcq1(jt).NE.0) k(n+1,1)=3
18112  IF(kcq2(jt).NE.0) k(n+2,1)=3
18113  IF(kcq3(jt).NE.0) k(n+3,1)=3
18114  k(n+4,1)=42
18115  k(n+4,2)=88
18116  DO 280 j=1,5
18117  p(n+4,j)=0d0
18118  v(n+4,j)=0d0
18119  280 CONTINUE
18120  ctmsum=0d0
18121  DO 290 ii=n+1,n+3
18122  k(ii,4)=0
18123  k(ii,5)=0
18124 C...Start by connecting all daughters to junction.
18125  k(ii,itjunc(jt)-1)=mstu(5)*(n+4)
18126 C...Only consider colour topologies with off shell resonances.
18127  rmq1=pmas(pycomp(k(ii,2)),1)
18128  rmres=pmas(pycomp(ksusy1+iabs(k(ii,2))),1)
18129  rmglu=pmas(pycomp(ksusy1+21),1)
18130  IF (rmglu-rmq1.LT.rmres) THEN
18131 C...Calculate propagators for each colour topology.
18132  rm2q23=rmglu**2+rmq1**2-2d0*(p(ii,4)*p(id,4)+p(ii,1)
18133  & *p(id,1)+p(ii,2)*p(id,2)+p(ii,3)*p(id,3))
18134  ctm2(ii-n)=1d0/(rm2q23-rmres**2)**2
18135  ELSE
18136  ctm2(ii-n)=0d0
18137  ENDIF
18138  ctmsum=ctmsum+ctm2(ii-n)
18139  290 CONTINUE
18140  ctmsum=pyr(0)*ctmsum
18141 C...Select colour topology J, with most off shell least likely.
18142  j=0
18143  300 j=j+1
18144  ctmsum=ctmsum-ctm2(j)
18145  IF (ctmsum.GT.0d0) goto 300
18146 C...The lucky winner gets its colour (anti-colour) directly from gluino.
18147  k(n+j,itjunc(jt)-1)=mstu(5)*id
18148  k(id,itjunc(jt)-1)=n+j+(k(id,itjunc(jt)-1)/mstu(5))*mstu(5)
18149 C...The other gluino colour is connected to junction
18150  k(id,10-itjunc(jt))=n+4+(k(id,10-itjunc(jt))/mstu(5))*
18151  & mstu(5)
18152  k(n+4,4)=k(n+4,4)+id
18153 C...Lastly, connect junction to remaining daughters.
18154  k(n+4,5)=n+1+mod(j,3)+mstu(5)*(n+1+mod(j+1,3))
18155 C...Particle counter should be stepped up one extra for junction.
18156  n=n+1
18157  ENDIF
18158 
18159 C...Update particle counter.
18160  n=n+nprod
18161 
18162 C...2) Everything else two-body decay.
18163  ELSE
18164  CALL py2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))
18165  mct(n-1,1)=0
18166  mct(n-1,2)=0
18167  mct(n,1)=0
18168  mct(n,2)=0
18169 C...First set colour flow as if mother colour singlet.
18170  IF(kcq1(jt).NE.0) THEN
18171  k(n-1,1)=3
18172  IF(kcq1(jt).NE.-1) k(n-1,4)=mstu(5)*n
18173  IF(kcq1(jt).NE.1) k(n-1,5)=mstu(5)*n
18174  ENDIF
18175  IF(kcq2(jt).NE.0) THEN
18176  k(n,1)=3
18177  IF(kcq2(jt).NE.-1) k(n,4)=mstu(5)*(n-1)
18178  IF(kcq2(jt).NE.1) k(n,5)=mstu(5)*(n-1)
18179  ENDIF
18180 C...Then redirect colour flow if mother (anti)triplet.
18181  IF(kcqm(jt).EQ.0) THEN
18182  ELSEIF(kcqm(jt).NE.2) THEN
18183  isid=4
18184  IF(kcqm(jt).EQ.-1) isid=5
18185  idau=n-1
18186  IF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.2) idau=n
18187  k(id,isid)=k(id,isid)+idau
18188  k(idau,isid)=mstu(5)*id
18189 C...Then redirect colour flow if mother octet.
18190  ELSEIF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.0) THEN
18191  idau=n-1
18192  IF(kcq1(jt).EQ.0) idau=n
18193  k(id,4)=k(id,4)+idau
18194  k(id,5)=k(id,5)+idau
18195  k(idau,4)=mstu(5)*id
18196  k(idau,5)=mstu(5)*id
18197  ELSE
18198  isid=4
18199  IF(kcq1(jt).EQ.-1) isid=5
18200  IF(kcq1(jt).EQ.2) isid=int(4.5d0+pyr(0))
18201  k(id,isid)=k(id,isid)+(n-1)
18202  k(id,9-isid)=k(id,9-isid)+n
18203  k(n-1,isid)=mstu(5)*id
18204  k(n,9-isid)=mstu(5)*id
18205  ENDIF
18206 
18207 C...Insert junction
18208  IF(iabs(kcq1(jt)+kcq2(jt)-kcqm(jt)).EQ.3) THEN
18209  n=n+1
18210 C...~q* mother: type 3 junction. ~q mother: type 4.
18211  itjunc(jt)=(7+kcqm(jt))/2
18212 C...Specify junction KF and set colour flow from junction
18213  k(n,1)=42
18214  k(n,2)=88
18215  k(n,3)=id
18216 C...Junction type encoded together with mother:
18217  k(n,4)=id+itjunc(jt)*mstu(5)
18218  k(n,5)=n-1+mstu(5)*(n-2)
18219 C...Zero P and V for junction (V filled later)
18220  DO 310 j=1,5
18221  p(n,j)=0d0
18222  v(n,j)=0d0
18223  310 CONTINUE
18224 C...Set colour flow from mother to junction
18225  k(id,8-itjunc(jt))= n + mstu(5)*(k(id,8-itjunc(jt))/mstu(5))
18226 C...Set colour flow from daughters to junction
18227  DO 320 ii=n-2,n-1
18228  k(ii,4) = 0
18229  k(ii,5) = 0
18230 C...(Anti-)colour mother is junction.
18231  k(ii,1+itjunc(jt)) = mstu(5)*n
18232  320 CONTINUE
18233  ENDIF
18234  ENDIF
18235 
18236 C...End loop over resonances for daughter flavour and mass selection.
18237  mstu(10)=mstu10
18238  330 IF(mwid(kca).NE.0.AND.(kfl1(jt).EQ.0.OR.kfl3(jt).NE.0))
18239  & ninh=ninh+1
18240  IF(ires.GT.0.AND.mwid(kca).NE.0.AND.mdcy(kca,1).NE.0.AND.
18241  & kfl1(jt).EQ.0) THEN
18242  WRITE(code,'(I9)') k(id,2)
18243  WRITE(mass,'(F9.3)') p(id,5)
18244  CALL pyerrm(3,'(PYRESD:) Failed to decay particle'//
18245  & code//' with mass'//mass)
18246  mint(51)=1
18247  goto 720
18248  ENDIF
18249  340 CONTINUE
18250 
18251 C...Check for allowed combinations. Skip if no decays.
18252  IF(jtmax.EQ.1) THEN
18253  IF(kdcy(1).EQ.0) goto 710
18254  ELSEIF(jtmax.EQ.2) THEN
18255  IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0) goto 710
18256  IF(keql(1).EQ.4.AND.keql(2).EQ.4) goto 180
18257  IF(keql(1).EQ.5.AND.keql(2).EQ.5) goto 180
18258  ELSEIF(jtmax.EQ.3) THEN
18259  IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0.AND.kdcy(3).EQ.0) goto 710
18260  IF(keql(1).EQ.4.AND.keql(2).EQ.4) goto 180
18261  IF(keql(1).EQ.4.AND.keql(3).EQ.4) goto 180
18262  IF(keql(2).EQ.4.AND.keql(3).EQ.4) goto 180
18263  IF(keql(1).EQ.5.AND.keql(2).EQ.5) goto 180
18264  IF(keql(1).EQ.5.AND.keql(3).EQ.5) goto 180
18265  IF(keql(2).EQ.5.AND.keql(3).EQ.5) goto 180
18266  ENDIF
18267 
18268 C...Special case: matrix element option for Z0 decay to quarks.
18269  IF(mstp(48).EQ.1.AND.isub.EQ.1.AND.jtmax.EQ.1.AND.
18270  &iabs(mint(11)).EQ.11.AND.iabs(kfl1(1)).LE.5) THEN
18271 
18272 C...Check consistency of MSTJ options set.
18273  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
18274  CALL pyerrm(6,
18275  & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
18276  mstj(110)=1
18277  ENDIF
18278  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
18279  CALL pyerrm(6,
18280  & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
18281 
18282  mstj(111)=0
18283  ENDIF
18284 
18285 C...Select alpha_strong behaviour.
18286  mst111=mstu(111)
18287  par112=paru(112)
18288  mstu(111)=mstj(108)
18289  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
18290  & mstu(111)=1
18291  paru(112)=parj(121)
18292  IF(mstu(111).EQ.2) paru(112)=parj(122)
18293 
18294 C...Find axial fraction in total cross section for scalar gluon model.
18295  parj(171)=0d0
18296  IF((iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.1).OR.
18297  & (mstj(101).EQ.5.AND.mstj(49).EQ.1)) THEN
18298  poll=1d0-parj(131)*parj(132)
18299  sff=1d0/(16d0*xw*xw1)
18300  sfw=p(id,5)**4/((p(id,5)**2-parj(123)**2)**2+
18301  & (parj(123)*parj(124))**2)
18302  sfi=sfw*(1d0-(parj(123)/p(id,5))**2)
18303  ve=4d0*xw-1d0
18304  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
18305  hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*
18306  & (parj(132)-parj(131)))
18307  kflc=iabs(kfl1(1))
18308  pmq=pymass(kflc)
18309  qf=kchg(kflc,1)/3d0
18310  vq=1d0
18311  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,
18312  & 1d0-(2d0*pmq/p(id,5))**2))
18313  vf=sign(1d0,qf)-4d0*qf*xw
18314  rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+
18315  & vf**2*hf1w)+vq**3*hf1w
18316  IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
18317  ENDIF
18318 
18319 C...Choice of jet configuration.
18320  CALL pyxjet(p(id,5),njet,cut)
18321  kflc=iabs(kfl1(1))
18322  kfln=21
18323  IF(njet.EQ.4) THEN
18324  CALL pyx4jt(njet,cut,kflc,p(id,5),kfln,x1,x2,x4,x12,x14)
18325  ELSEIF(njet.EQ.3) THEN
18326  CALL pyx3jt(njet,cut,kflc,p(id,5),x1,x3)
18327  ELSE
18328  mstj(120)=1
18329  ENDIF
18330 
18331 C...Fill jet configuration; return if incorrect kinematics.
18332  nc=n-2
18333  IF(njet.EQ.2.AND.mstj(101).NE.5) THEN
18334  CALL py2ent(nc+1,kflc,-kflc,p(id,5))
18335  ELSEIF(njet.EQ.2) THEN
18336  CALL py2ent(-(nc+1),kflc,-kflc,p(id,5))
18337  ELSEIF(njet.EQ.3) THEN
18338  CALL py3ent(nc+1,kflc,21,-kflc,p(id,5),x1,x3)
18339  ELSEIF(kfln.EQ.21) THEN
18340  CALL py4ent(nc+1,kflc,kfln,kfln,-kflc,p(id,5),x1,x2,x4,
18341  & x12,x14)
18342  ELSE
18343  CALL py4ent(nc+1,kflc,-kfln,kfln,-kflc,p(id,5),x1,x2,x4,
18344  & x12,x14)
18345  ENDIF
18346  IF(mstu(24).NE.0) THEN
18347  mint(51)=1
18348  mstu(111)=mst111
18349  paru(112)=par112
18350  goto 720
18351  ENDIF
18352 
18353 C...Angular orientation according to matrix element.
18354  IF(mstj(106).EQ.1) THEN
18355  CALL pyxdif(nc,njet,kflc,p(id,5),chiz,thez,phiz)
18356  IF(mint(11).LT.0) thez=paru(1)-thez
18357  cthe(1)=cos(thez)
18358  CALL pyrobo(nc+1,n,0d0,chiz,0d0,0d0,0d0)
18359  CALL pyrobo(nc+1,n,thez,phiz,0d0,0d0,0d0)
18360  ENDIF
18361 
18362 C...Boost partons to Z0 rest frame.
18363  CALL pyrobo(nc+1,n,0d0,0d0,p(id,1)/p(id,4),
18364  & p(id,2)/p(id,4),p(id,3)/p(id,4))
18365 
18366 C...Mark decayed resonance and add documentation lines,
18367  k(id,1)=k(id,1)+10
18368  idoc=mint(83)+mint(4)
18369  DO 360 i=nc+1,n
18370  i1=mint(83)+mint(4)+1
18371  k(i,3)=i1
18372  IF(mstp(128).GE.1) k(i,3)=id
18373  IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
18374  mint(4)=mint(4)+1
18375  k(i1,1)=21
18376  k(i1,2)=k(i,2)
18377  k(i1,3)=iref(ip,4)
18378  DO 350 j=1,5
18379  p(i1,j)=p(i,j)
18380  350 CONTINUE
18381  ENDIF
18382  360 CONTINUE
18383 
18384 C...Generate parton shower.
18385  IF(mstj(101).EQ.5.AND.mint(35).LE.1) THEN
18386  CALL pyshow(n-1,n,p(id,5))
18387  ELSEIF(mstj(101).EQ.5.AND.mint(35).GE.2) THEN
18388  npart=2
18389  ipart(1)=n-1
18390  ipart(2)=n
18391  ptpart(1)=0.5d0*p(id,5)
18392  ptpart(2)=ptpart(1)
18393  nct=nct+1
18394  IF(k(n-1,2).GT.0) THEN
18395  mct(n-1,1)=nct
18396  mct(n,2)=nct
18397  ELSE
18398  mct(n-1,2)=nct
18399  mct(n,1)=nct
18400  ENDIF
18401  CALL pyptfs(2,0.5d0*p(id,5),0d0,ptgen)
18402  ENDIF
18403 
18404 C... End special case for Z0: skip ahead.
18405  mstu(111)=mst111
18406  paru(112)=par112
18407  goto 700
18408  ENDIF
18409 
18410 C...Order incoming partons and outgoing resonances.
18411  IF(jtmax.EQ.2.AND.isub.NE.0.AND.mstp(47).GE.1.AND.
18412  &ninh.EQ.0) THEN
18413  ilin(1)=mint(84)+1
18414  IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2
18415  IF(k(ilin(1),2).EQ.21.OR.k(ilin(1),2).EQ.22)
18416  & ilin(1)=2*mint(84)+3-ilin(1)
18417  ilin(2)=2*mint(84)+3-ilin(1)
18418  imin=1
18419  IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
18420  & .EQ.36) imin=3
18421  imax=2
18422  iord=1
18423  IF(k(iref(ip,1),2).EQ.23) iord=2
18424  IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2
18425  iakipd=iabs(k(iref(ip,iord),2))
18426  IF(iakipd.EQ.25.OR.iakipd.EQ.35.OR.iakipd.EQ.36) iord=3-iord
18427  IF(kdcy(iord).EQ.0) iord=3-iord
18428 
18429 C...Order decay products of resonances.
18430  DO 370 jt=iord,3-iord,3-2*iord
18431  IF(kdcy(jt).EQ.0) THEN
18432  ilin(imax+1)=nsd(jt)
18433  imax=imax+1
18434  ELSEIF(k(nsd(jt)+1,2).GT.0) THEN
18435  ilin(imax+1)=n+2*jt-1
18436  ilin(imax+2)=n+2*jt
18437  imax=imax+2
18438  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
18439  k(n+2*jt,2)=k(nsd(jt)+2,2)
18440  ELSE
18441  ilin(imax+1)=n+2*jt
18442 
18443  ilin(imax+2)=n+2*jt-1
18444  imax=imax+2
18445  k(n+2*jt-1,2)=k(nsd(jt)+1,2)
18446  k(n+2*jt,2)=k(nsd(jt)+2,2)
18447  ENDIF
18448  370 CONTINUE
18449 
18450 C...Find charge, isospin, left- and righthanded couplings.
18451  DO 390 i=imin,imax
18452  DO 380 j=1,4
18453  coup(i,j)=0d0
18454  380 CONTINUE
18455  kfa=iabs(k(ilin(i),2))
18456  IF(kfa.EQ.0.OR.kfa.GT.20) goto 390
18457  coup(i,1)=kchg(kfa,1)/3d0
18458  coup(i,2)=(-1)**mod(kfa,2)
18459  coup(i,4)=-2d0*coup(i,1)*xwv
18460  coup(i,3)=coup(i,2)+coup(i,4)
18461  390 CONTINUE
18462 
18463 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18464  IF(isub.EQ.22) THEN
18465  DO 420 i=3,5,2
18466  i1=iord
18467  IF(i.EQ.5) i1=3-iord
18468  DO 410 j1=1,2
18469  DO 400 j2=1,2
18470  corl(i/2,j1,j2)=coup(1,1)**2*hgz(i1,1)*coup(i,1)**2/
18471  & 16d0+coup(1,1)*coup(1,j1+2)*hgz(i1,2)*coup(i,1)*
18472  & coup(i,j2+2)/4d0+coup(1,j1+2)**2*hgz(i1,3)*
18473  & coup(i,j2+2)**2
18474  400 CONTINUE
18475  410 CONTINUE
18476  420 CONTINUE
18477  cowt12=(corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
18478  & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2))
18479  comx12=(corl(1,1,1)+corl(1,1,2)+corl(1,2,1)+corl(1,2,2))*
18480  & (corl(2,1,1)+corl(2,1,2)+corl(2,2,1)+corl(2,2,2))
18481 
18482  IF(cowt12.LT.pyr(0)*comx12) goto 180
18483  ENDIF
18484  ENDIF
18485 
18486 C...Select angular orientation type - Z'/W' only.
18487  mzpwp=0
18488  IF(isub.EQ.141) THEN
18489  IF(pyr(0).LT.paru(130)) mzpwp=1
18490  IF(ip.EQ.2) THEN
18491  IF(iabs(k(iref(2,1),2)).EQ.37) mzpwp=2
18492  iakir=iabs(k(iref(2,2),2))
18493  IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
18494  IF(iakir.LE.20) mzpwp=2
18495  ENDIF
18496  IF(ip.GE.3) mzpwp=2
18497  ELSEIF(isub.EQ.142) THEN
18498  IF(pyr(0).LT.paru(136)) mzpwp=1
18499  IF(ip.EQ.2) THEN
18500  iakir=iabs(k(iref(2,2),2))
18501  IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
18502  IF(iakir.LE.20) mzpwp=2
18503  ENDIF
18504  IF(ip.GE.3) mzpwp=2
18505  ENDIF
18506 
18507 C...Select random angles (begin of weighting procedure).
18508  430 DO 440 jt=1,jtmax
18509  IF(kdcy(jt).EQ.0) goto 440
18510  IF(jtmax.EQ.1.AND.isub.NE.0.AND.ihdec.EQ.0) THEN
18511  cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*pyr(0)
18512  IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)
18513  phi(jt)=vint(24)
18514  ELSE
18515  cthe(jt)=2d0*pyr(0)-1d0
18516  phi(jt)=paru(2)*pyr(0)
18517  ENDIF
18518  440 CONTINUE
18519 
18520  IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN
18521 C...Construct massless four-vectors.
18522  DO 460 i=n+1,n+4
18523  k(i,1)=1
18524  DO 450 j=1,5
18525  p(i,j)=0d0
18526  v(i,j)=0d0
18527  450 CONTINUE
18528  460 CONTINUE
18529  DO 470 jt=1,jtmax
18530  IF(kdcy(jt).EQ.0) goto 470
18531  id=iref(ip,jt)
18532  p(n+2*jt-1,3)=0.5d0*p(id,5)
18533  p(n+2*jt-1,4)=0.5d0*p(id,5)
18534  p(n+2*jt,3)=-0.5d0*p(id,5)
18535  p(n+2*jt,4)=0.5d0*p(id,5)
18536  CALL pyrobo(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),
18537  & p(id,1)/p(id,4),p(id,2)/p(id,4),p(id,3)/p(id,4))
18538  470 CONTINUE
18539 
18540 C...Store incoming and outgoing momenta, with random rotation to
18541 C...avoid accidental zeroes in HA expressions.
18542  IF(isub.NE.0) THEN
18543  DO 490 i=imin,imax
18544  k(n+4+i,1)=1
18545  p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+
18546  & p(ilin(i),3)**2+p(ilin(i),5)**2)
18547  p(n+4+i,5)=p(ilin(i),5)
18548  DO 480 j=1,3
18549  p(n+4+i,j)=p(ilin(i),j)
18550  480 CONTINUE
18551  490 CONTINUE
18552  500 therr=acos(2d0*pyr(0)-1d0)
18553  phirr=paru(2)*pyr(0)
18554  CALL pyrobo(n+4+imin,n+4+imax,therr,phirr,0d0,0d0,0d0)
18555  DO 520 i=imin,imax
18556  IF(p(n+4+i,1)**2+p(n+4+i,2)**2.LT.1d-4*(p(n+4+i,1)**2+
18557  & p(n+4+i,2)**2+p(n+4+i,3)**2)) goto 500
18558  DO 510 j=1,4
18559  pk(i,j)=p(n+4+i,j)
18560  510 CONTINUE
18561  520 CONTINUE
18562  ENDIF
18563 
18564 C...Calculate internal products.
18565  IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25.OR.isub.EQ.141.OR.
18566  & isub.EQ.142) THEN
18567  DO 540 i1=imin,imax-1
18568  DO 530 i2=i1+1,imax
18569  ha(i1,i2)=sngl(sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+
18570  & pk(i2,3))/(1d-20+pk(i1,1)**2+pk(i1,2)**2)))*
18571  & cmplx(sngl(pk(i1,1)),sngl(pk(i1,2)))-
18572  & sngl(sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/
18573  & (1d-20+pk(i2,1)**2+pk(i2,2)**2)))*
18574  & cmplx(sngl(pk(i2,1)),sngl(pk(i2,2)))
18575  hc(i1,i2)=conjg(ha(i1,i2))
18576  IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)
18577  IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)
18578  ha(i2,i1)=-ha(i1,i2)
18579  hc(i2,i1)=-hc(i1,i2)
18580  530 CONTINUE
18581  540 CONTINUE
18582  ENDIF
18583 
18584 C...Calculate four-products.
18585  IF(isub.NE.0) THEN
18586  DO 560 i=1,2
18587  DO 550 j=1,4
18588  pk(i,j)=-pk(i,j)
18589  550 CONTINUE
18590  560 CONTINUE
18591  DO 580 i1=imin,imax-1
18592  DO 570 i2=i1+1,imax
18593  pkk(i1,i2)=2d0*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-
18594  & pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))
18595  pkk(i2,i1)=pkk(i1,i2)
18596  570 CONTINUE
18597  580 CONTINUE
18598  ENDIF
18599  ENDIF
18600 
18601  kfagm=iabs(iref(ip,7))
18602  IF(mstp(47).LE.0.OR.ninh.NE.0) THEN
18603 C...Isotropic decay selected by user.
18604  wt=1d0
18605  wtmax=1d0
18606 
18607  ELSEIF(jtmax.EQ.3) THEN
18608 C...Isotropic decay when three mother particles.
18609  wt=1d0
18610  wtmax=1d0
18611 
18612  ELSEIF(it4.GE.1) THEN
18613 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18614  wt=1d0
18615  wtmax=1d0
18616 
18617  ELSEIF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.
18618  & iref(ip,7).EQ.36) THEN
18619 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18620 C...CP-odd case added by Kari Ertresvag Myklevoll.
18621 C...Now also with mixed Higgs CP-states
18622  eta=parp(25)
18623  IF(ip.EQ.1) wtmax=sh**2
18624  IF(ip.GE.2) wtmax=p(iref(ip,8),5)**4
18625  kfa=iabs(k(iref(ip,1),2))
18626  kft=iabs(k(iref(ip,2),2))
18627 
18628  IF((kfa.EQ.kft).AND.(kfa.EQ.23.OR.kfa.EQ.24).AND.
18629  & mstp(25).GE.3) THEN
18630 C...For mixed CP states need epsilon product.
18631  p10=pk(3,4)
18632  p20=pk(4,4)
18633  p30=pk(5,4)
18634  p40=pk(6,4)
18635  p11=pk(3,1)
18636  p21=pk(4,1)
18637  p31=pk(5,1)
18638  p41=pk(6,1)
18639  p12=pk(3,2)
18640  p22=pk(4,2)
18641  p32=pk(5,2)
18642  p42=pk(6,2)
18643  p13=pk(3,3)
18644  p23=pk(4,3)
18645  p33=pk(5,3)
18646  p43=pk(6,3)
18647  epsi=p10*p21*p32*p43-p10*p21*p33*p42-p10*p22*p31*p43+p10*p22*
18648  & p33*p41+p10*p23*p31*p42-p10*p23*p32*p41-p11*p20*p32*p43+p11*
18649  & p20*p33*p42+p11*p22*p30*p43-p11*p22*p33*p40-p11*p23*p30*p42+
18650  & p11*p23*p32*p40+p12*p20*p31*p43-p12*p20*p33*p41-p12*p21*p30*
18651  & p43+p12*p21*p33*p40+p12*p23*p30*p41-p12*p23*p31*p40-p13*p20*
18652  & p31*p42+p13*p20*p32*p41+p13*p21*p30*p42-p13*p21*p32*p40-p13*
18653  & p22*p30*p41+p13*p22*p31*p40
18654 C...For mixed CP states need gauge boson masses.
18655  xma=sqrt(max(0d0,(pk(3,4)+pk(4,4))**2-(pk(3,1)+pk(4,1))**2-
18656  & (pk(3,2)+pk(4,2))**2-(pk(3,3)+pk(4,3))**2))
18657  xmb=sqrt(max(0d0,(pk(5,4)+pk(6,4))**2-(pk(5,1)+pk(6,1))**2-
18658  & (pk(5,2)+pk(6,2))**2-(pk(5,3)+pk(6,3))**2))
18659  xmv=pmas(kfa,1)
18660  ENDIF
18661 
18662 C...Z decay
18663  IF(kfa.EQ.23.AND.kfa.EQ.kft) THEN
18664  kflf1a=iabs(kfl1(1))
18665  ef1=kchg(kflf1a,1)/3d0
18666  af1=sign(1d0,ef1+0.1d0)
18667  vf1=af1-4d0*ef1*xwv
18668  kflf2a=iabs(kfl1(2))
18669  ef2=kchg(kflf2a,1)/3d0
18670  af2=sign(1d0,ef2+0.1d0)
18671  vf2=af2-4d0*ef2*xwv
18672  va12as=4d0*vf1*af1*vf2*af2/((vf1**2+af1**2)*(vf2**2+af2**2))
18673  IF((mstp(25).EQ.0.AND.iref(ip,7).NE.36).OR.mstp(25).EQ.1)
18674  & THEN
18675 C...CP-even decay
18676  wt=8d0*(1d0+va12as)*pkk(3,5)*pkk(4,6)+
18677  & 8d0*(1d0-va12as)*pkk(3,6)*pkk(4,5)
18678  ELSEIF(mstp(25).LE.2) THEN
18679 C...CP-odd decay
18680  wt=((pkk(3,5)+pkk(4,6))**2 +(pkk(3,6)+pkk(4,5))**2
18681  & -2*pkk(3,4)*pkk(5,6)
18682  & -2*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2/
18683  & (pkk(3,4)*pkk(5,6))
18684  & +va12as*(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))*
18685  & (pkk(3,5)+pkk(4,5)-pkk(3,6)-pkk(4,6)))/(1+va12as)
18686  ELSE
18687 C...Mixed CP states.
18688  wt=32d0*(0.25d0*((1d0+va12as)*pkk(3,5)*pkk(4,6)
18689  & +(1d0-va12as)*pkk(3,6)*pkk(4,5))
18690  & -0.5d0*eta/xmv**2*epsi*((1d0+va12as)*(pkk(3,5)+pkk(4,6))
18691  & -(1d0-va12as)*(pkk(3,6)+pkk(4,5)))
18692  & +6.25d-2*eta**2/xmv**4*(-2d0*pkk(3,4)**2*pkk(5,6)**2
18693  & -2d0*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2
18694  & +pkk(3,4)*pkk(5,6)
18695  & *((pkk(3,5)+pkk(4,6))**2+(pkk(3,6)+pkk(4,5))**2)
18696  & +va12as*pkk(3,4)*pkk(5,6)
18697  & *(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))
18698  & *(pkk(3,5)-pkk(3,6)+pkk(4,5)-pkk(4,6))))
18699  & /(1d0 +2d0*eta*xma*xmb/xmv**2
18700  & +2d0*(eta*xma*xmb/xmv**2)**2*(1d0+va12as))
18701  ENDIF
18702 
18703 C...W decay
18704  ELSEIF(kfa.EQ.24.AND.kfa.EQ.kft) THEN
18705  IF((mstp(25).EQ.0.AND.iref(ip,7).NE.36).OR.mstp(25).EQ.1)
18706  & THEN
18707 C...CP-even decay
18708  wt=16d0*pkk(3,5)*pkk(4,6)
18709  ELSEIF(mstp(25).LE.2) THEN
18710 C...CP-odd decay
18711  wt=0.5d0*((pkk(3,5)+pkk(4,6))**2 +(pkk(3,6)+pkk(4,5))**2
18712  & -2*pkk(3,4)*pkk(5,6)
18713  & -2*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2/
18714  & (pkk(3,4)*pkk(5,6))
18715  & +(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))*
18716  & (pkk(3,5)+pkk(4,5)-pkk(3,6)-pkk(4,6)))
18717  ELSE
18718 C...Mixed CP states.
18719  wt=32d0*(0.25d0*2d0*pkk(3,5)*pkk(4,6)
18720  & -0.5d0*eta/xmv**2*epsi*2d0*(pkk(3,5)+pkk(4,6))
18721  & +6.25d-2*eta**2/xmv**4*(-2d0*pkk(3,4)**2*pkk(5,6)**2
18722  & -2d0*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2
18723  & +pkk(3,4)*pkk(5,6)
18724  & *((pkk(3,5)+pkk(4,6))**2+(pkk(3,6)+pkk(4,5))**2)
18725  & +pkk(3,4)*pkk(5,6)
18726  & *(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))
18727  & *(pkk(3,5)-pkk(3,6)+pkk(4,5)-pkk(4,6))))
18728  & /(1d0 +2d0*eta*xma*xmb/xmv**2
18729  & +(2d0*eta*xma*xmb/xmv**2)**2)
18730  ENDIF
18731 
18732 C...No angular correlations in other Higgs decays.
18733  ELSE
18734  wt=wtmax
18735  ENDIF
18736 
18737  ELSEIF((kfagm.EQ.6.OR.kfagm.EQ.7.OR.kfagm.EQ.8.OR.
18738  & kfagm.EQ.17.OR.kfagm.EQ.18).AND.iabs(k(iref(ip,1),2)).EQ.24)
18739  & THEN
18740 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18741  i1=iref(ip,8)
18742  IF(mod(kfagm,2).EQ.0) THEN
18743  i2=n+1
18744  i3=n+2
18745  ELSE
18746  i2=n+2
18747  i3=n+1
18748  ENDIF
18749  i4=iref(ip,2)
18750  wt=(p(i1,4)*p(i2,4)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
18751  & p(i1,3)*p(i2,3))*(p(i3,4)*p(i4,4)-p(i3,1)*p(i4,1)-
18752  & p(i3,2)*p(i4,2)-p(i3,3)*p(i4,3))
18753  wtmax=(p(i1,5)**4-p(iref(ip,1),5)**4)/8d0
18754 
18755  ELSEIF(isub.EQ.1) THEN
18756 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18757  ei=kchg(iabs(mint(15)),1)/3d0
18758  ai=sign(1d0,ei+0.1d0)
18759  vi=ai-4d0*ei*xwv
18760  ef=kchg(iabs(kfl1(1)),1)/3d0
18761  af=sign(1d0,ef+0.1d0)
18762 
18763  vf=af-4d0*ef*xwv
18764  rmf=min(1d0,4d0*pmas(iabs(kfl1(1)),1)**2/sh)
18765  wt1=ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18766  & (vi**2+ai**2)*vint(114)*(vf**2+(1d0-rmf)*af**2)
18767  wt2=rmf*(ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18768  & (vi**2+ai**2)*vint(114)*vf**2)
18769  wt3=sqrt(1d0-rmf)*(ei*ai*vint(112)*ef*af+
18770  & 4d0*vi*ai*vint(114)*vf*af)
18771  wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
18772  & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
18773  wtmax=2d0*(wt1+abs(wt3))
18774 
18775  ELSEIF(isub.EQ.2) THEN
18776 C...Angular weight for W+/- -> 2 quarks/leptons.
18777  rm3=pmas(iabs(kfl1(1)),1)**2/sh
18778  rm4=pmas(iabs(kfl2(1)),1)**2/sh
18779  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18780  wt=(1d0+be34*cthe(1)*isign(1,mint(15)*kfl1(1)))**2-(rm3-rm4)**2
18781  wtmax=4d0
18782 
18783  ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN
18784 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18785 C...-> gluon/gamma + 2 quarks/leptons.
18786  clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18787  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18788  & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
18789  clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18790  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18791  & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
18792  crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18793  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18794  & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
18795  crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18796  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18797  & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
18798  wt=(clilf+crirf)*(pkk(1,3)**2+pkk(2,4)**2)+
18799  & (clirf+crilf)*(pkk(1,4)**2+pkk(2,3)**2)
18800  wtmax=(clilf+clirf+crilf+crirf)*
18801  & ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)
18802 
18803  ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN
18804 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18805 C...-> gluon/gamma + 2 quarks/leptons.
18806  wt=pkk(1,3)**2+pkk(2,4)**2
18807  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2
18808 
18809  ELSEIF(isub.EQ.22) THEN
18810 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18811  s34=p(iref(ip,iord),5)**2
18812  s56=p(iref(ip,3-iord),5)**2
18813  ti=pkk(1,3)+pkk(1,4)+s34
18814  ui=pkk(1,5)+pkk(1,6)+s56
18815  tir=REAL(ti)
18816  uir=REAL(ui)
18817  fgk135=abs(fgk(1,2,3,4,5,6)/tir+fgk(1,2,5,6,3,4)/uir)**2
18818  fgk145=abs(fgk(1,2,4,3,5,6)/tir+fgk(1,2,5,6,4,3)/uir)**2
18819  fgk136=abs(fgk(1,2,3,4,6,5)/tir+fgk(1,2,6,5,3,4)/uir)**2
18820  fgk146=abs(fgk(1,2,4,3,6,5)/tir+fgk(1,2,6,5,4,3)/uir)**2
18821  fgk253=abs(fgk(2,1,5,6,3,4)/tir+fgk(2,1,3,4,5,6)/uir)**2
18822  fgk263=abs(fgk(2,1,6,5,3,4)/tir+fgk(2,1,3,4,6,5)/uir)**2
18823  fgk254=abs(fgk(2,1,5,6,4,3)/tir+fgk(2,1,4,3,5,6)/uir)**2
18824  fgk264=abs(fgk(2,1,6,5,4,3)/tir+fgk(2,1,4,3,6,5)/uir)**2
18825 
18826  wt=
18827  & corl(1,1,1)*corl(2,1,1)*fgk135+corl(1,1,2)*corl(2,1,1)*fgk145+
18828  & corl(1,1,1)*corl(2,1,2)*fgk136+corl(1,1,2)*corl(2,1,2)*fgk146+
18829  & corl(1,2,1)*corl(2,2,1)*fgk253+corl(1,2,2)*corl(2,2,1)*fgk263+
18830  & corl(1,2,1)*corl(2,2,2)*fgk254+corl(1,2,2)*corl(2,2,2)*fgk264
18831  wtmax=16d0*((corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
18832  & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2)))*s34*s56*
18833  & ((ti**2+ui**2+2d0*sh*(s34+s56))/(ti*ui)-s34*s56*(1d0/ti**2+
18834  & 1d0/ui**2))
18835 
18836  ELSEIF(isub.EQ.23) THEN
18837 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18838  d34=p(iref(ip,iord),5)**2
18839  d56=p(iref(ip,3-iord),5)**2
18840  dt=pkk(1,3)+pkk(1,4)+d34
18841  du=pkk(1,5)+pkk(1,6)+d56
18842  facbw=1d0/((sh-sqmw)**2+gmmw**2)
18843  cawz=coup(2,3)/dt-2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
18844  cbwz=coup(1,3)/du+2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
18845  fgk135=abs(REAL(cawz)*fgk(1,2,3,4,5,6)+
18846 
18847  & REAL(cbwz)*fgk(1,2,5,6,3,4))
18848  fgk136=abs(REAL(cawz)*fgk(1,2,3,4,6,5)+
18849  & REAL(cbwz)*fgk(1,2,6,5,3,4))
18850  wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
18851  wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*
18852  & digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))
18853 
18854  ELSEIF(isub.EQ.24.OR.isub.EQ.171.OR.isub.EQ.176) THEN
18855 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18856 C...(or H0, or A0).
18857  wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*
18858  & pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)*
18859  & coup(3,3))**2)*pkk(1,4)*pkk(2,3)
18860  wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
18861  & (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
18862 
18863  ELSEIF(isub.EQ.25) THEN
18864 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18865  polr=(1d0+parj(132))*(1d0-parj(131))
18866  poll=(1d0-parj(132))*(1d0+parj(131))
18867  d34=p(iref(ip,iord),5)**2
18868  d56=p(iref(ip,3-iord),5)**2
18869  dt=pkk(1,3)+pkk(1,4)+d34
18870  du=pkk(1,5)+pkk(1,6)+d56
18871  facbw=1d0/((sh-sqmz)**2+sqmz*pmas(23,2)**2)
18872  cdww=(coup(1,3)*sqmz*(sh-sqmz)*facbw+coup(1,2))/sh
18873  caww=cdww+0.5d0*(coup(1,2)+1d0)/dt
18874  cbww=cdww+0.5d0*(coup(1,2)-1d0)/du
18875  ccww=coup(1,4)*sqmz*(sh-sqmz)*facbw/sh
18876  fgk135=abs(REAL(caww)*fgk(1,2,3,4,5,6)-
18877  & REAL(cbww)*fgk(1,2,5,6,3,4))
18878  fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
18879  IF(mstp(50).LE.0) THEN
18880  wt=fgk135**2+(ccww*fgk253)**2
18881  wtmax=4d0*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-
18882  & caww*cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-
18883  & djgk(dt,du)))
18884  ELSE
18885  wt=poll*fgk135**2+polr*(ccww*fgk253)**2
18886  wtmax=4d0*d34*d56*(poll*(caww**2*digk(dt,du)+
18887  & cbww**2*digk(du,dt)-caww*cbww*djgk(dt,du))+
18888  & polr*ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du)))
18889  ENDIF
18890 
18891  ELSEIF(isub.EQ.26.OR.isub.EQ.172.OR.isub.EQ.177) THEN
18892 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18893 C...(or H0, or A0).
18894  wt=pkk(1,3)*pkk(2,4)
18895  wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
18896 
18897  ELSEIF(isub.EQ.30.OR.isub.EQ.35) THEN
18898 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18899 C...-> f + 2 quarks/leptons.
18900  clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18901  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18902  & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
18903  clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18904  & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18905  & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
18906  crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18907  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18908  & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
18909  crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18910  & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18911  & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
18912  IF(k(ilin(1),2).GT.0) wt=(clilf+crirf)*(pkk(1,4)**2+
18913  & pkk(3,5)**2)+(clirf+crilf)*(pkk(1,3)**2+pkk(4,5)**2)
18914  IF(k(ilin(1),2).LT.0) wt=(clilf+crirf)*(pkk(1,3)**2+
18915  & pkk(4,5)**2)+(clirf+crilf)*(pkk(1,4)**2+pkk(3,5)**2)
18916  wtmax=(clilf+clirf+crilf+crirf)*
18917  & ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)
18918 
18919  ELSEIF(isub.EQ.31.OR.isub.EQ.36) THEN
18920 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18921  IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2
18922  IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2
18923  wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2
18924 
18925  ELSEIF(isub.EQ.71.OR.isub.EQ.72.OR.isub.EQ.73.OR.isub.EQ.76.OR.
18926  & isub.EQ.77) THEN
18927 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18928  wt=16d0*pkk(3,5)*pkk(4,6)
18929  wtmax=sh**2
18930 
18931  ELSEIF(isub.EQ.110) THEN
18932 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18933  wt=1d0
18934  wtmax=1d0
18935 
18936  ELSEIF(isub.EQ.141) THEN
18937 C...Special case: if only branching ratios known then isotropic decay.
18938  IF(mwid(32).EQ.2) THEN
18939  wt=1d0
18940  wtmax=1d0
18941  ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
18942 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18943 C...Couplings of incoming flavour.
18944  kfai=iabs(mint(15))
18945  ei=kchg(kfai,1)/3d0
18946  ai=sign(1d0,ei+0.1d0)
18947  vi=ai-4d0*ei*xwv
18948  kfaic=1
18949  IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
18950  IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
18951  IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
18952  IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
18953  vpi=paru(119+2*kfaic)
18954  api=paru(120+2*kfaic)
18955  ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
18956  vpi=parj(178+2*kfaic)
18957  api=parj(179+2*kfaic)
18958  ELSE
18959  vpi=parj(186+2*kfaic)
18960  api=parj(187+2*kfaic)
18961  ENDIF
18962 C...Couplings of final flavour.
18963  kfaf=iabs(kfl1(1))
18964  ef=kchg(kfaf,1)/3d0
18965  af=sign(1d0,ef+0.1d0)
18966  vf=af-4d0*ef*xwv
18967  kfafc=1
18968  IF(kfaf.LE.10.AND.mod(kfaf,2).EQ.0) kfafc=2
18969  IF(kfaf.GT.10.AND.mod(kfaf,2).NE.0) kfafc=3
18970  IF(kfaf.GT.10.AND.mod(kfaf,2).EQ.0) kfafc=4
18971  IF(kfaf.LE.2.OR.kfaf.EQ.11.OR.kfaf.EQ.12) THEN
18972  vpf=paru(119+2*kfafc)
18973  apf=paru(120+2*kfafc)
18974  ELSEIF(kfaf.LE.4.OR.kfaf.EQ.13.OR.kfaf.EQ.14) THEN
18975  vpf=parj(178+2*kfafc)
18976  apf=parj(179+2*kfafc)
18977  ELSE
18978  vpf=parj(186+2*kfafc)
18979  apf=parj(187+2*kfafc)
18980  ENDIF
18981 C...Asymmetry and weight.
18982  asym=2d0*(ei*ai*vint(112)*ef*af+ei*api*vint(113)*ef*apf+
18983  & 4d0*vi*ai*vint(114)*vf*af+(vi*api+vpi*ai)*vint(115)*
18984  & (vf*apf+vpf*af)+4d0*vpi*api*vint(116)*vpf*apf)/
18985  & (ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18986  & ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
18987  & (vf**2+af**2)+(vi*vpi+ai*api)*vint(115)*(vf*vpf+af*apf)+
18988  & (vpi**2+api**2)*vint(116)*(vpf**2+apf**2))
18989  wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
18990  wtmax=2d0+abs(asym)
18991  ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).EQ.24) THEN
18992 C...Angular weight for f + fbar -> Z' -> W+ + W-.
18993  rm1=p(nsd(1)+1,5)**2/sh
18994  rm2=p(nsd(1)+2,5)**2/sh
18995  ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
18996  & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
18997  cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
18998  & (rm2-rm1)**2)
18999  wt=cflat+ccos2*cthe(1)**2
19000  wtmax=cflat+max(0d0,ccos2)
19001  ELSEIF(ip.EQ.1.AND.(kfl1(1).EQ.25.OR.kfl1(1).EQ.35.OR.
19002  & iabs(kfl1(1)).EQ.37)) THEN
19003 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
19004  wt=1d0-cthe(1)**2
19005  wtmax=1d0
19006  ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
19007 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
19008  rm1=p(nsd(1)+1,5)**2/sh
19009  rm2=p(nsd(1)+2,5)**2/sh
19010  flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
19011  wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
19012  wtmax=1d0+flam2/(8d0*rm1)
19013  ELSEIF(mzpwp.EQ.0) THEN
19014 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19015 C...(W:s like if intermediate Z).
19016  d34=p(iref(ip,iord),5)**2
19017  d56=p(iref(ip,3-iord),5)**2
19018  dt=pkk(1,3)+pkk(1,4)+d34
19019  du=pkk(1,5)+pkk(1,6)+d56
19020  fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
19021  fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
19022  wt=(coup(1,3)*fgk135)**2+(coup(1,4)*fgk253)**2
19023  wtmax=4d0*d34*d56*(coup(1,3)**2+coup(1,4)**2)*
19024  & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
19025  ELSEIF(mzpwp.EQ.1) THEN
19026 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19027 C...(W:s approximately longitudinal, like if intermediate H).
19028  wt=16d0*pkk(3,5)*pkk(4,6)
19029  wtmax=sh**2
19030  ELSE
19031 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
19032 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
19033  wt=1d0
19034  wtmax=1d0
19035  ENDIF
19036 
19037  ELSEIF(isub.EQ.142) THEN
19038 C...Special case: if only branching ratios known then isotropic decay.
19039  IF(mwid(34).EQ.2) THEN
19040  wt=1d0
19041  wtmax=1d0
19042  ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
19043 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
19044  kfai=iabs(mint(15))
19045  kfaic=1
19046  IF(kfai.GT.10) kfaic=2
19047  vi=paru(129+2*kfaic)
19048  ai=paru(130+2*kfaic)
19049  kfaf=iabs(kfl1(1))
19050  kfafc=1
19051  IF(kfaf.GT.10) kfafc=2
19052  vf=paru(129+2*kfafc)
19053  af=paru(130+2*kfafc)
19054  asym=8d0*vi*ai*vf*af/((vi**2+ai**2)*(vf**2+af**2))
19055  wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
19056  wtmax=2d0+abs(asym)
19057  ELSEIF(ip.EQ.1.AND.iabs(kfl2(1)).EQ.23) THEN
19058 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
19059  rm1=p(nsd(1)+1,5)**2/sh
19060  rm2=p(nsd(1)+2,5)**2/sh
19061  ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
19062  & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
19063  cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
19064  & (rm2-rm1)**2)
19065  wt=cflat+ccos2*cthe(1)**2
19066  wtmax=cflat+max(0d0,ccos2)
19067  ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
19068 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
19069  rm1=p(nsd(1)+1,5)**2/sh
19070  rm2=p(nsd(1)+2,5)**2/sh
19071  flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
19072  wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
19073  wtmax=1d0+flam2/(8d0*rm1)
19074  ELSEIF(mzpwp.EQ.0) THEN
19075 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19076 C...(W/Z like if intermediate W).
19077  d34=p(iref(ip,iord),5)**2
19078  d56=p(iref(ip,3-iord),5)**2
19079  dt=pkk(1,3)+pkk(1,4)+d34
19080  du=pkk(1,5)+pkk(1,6)+d56
19081  fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
19082  fgk136=abs(fgk(1,2,3,4,6,5)-fgk(1,2,6,5,3,4))
19083  wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
19084  wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*
19085  & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
19086  ELSEIF(mzpwp.EQ.1) THEN
19087 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19088 C...(W/Z approximately longitudinal, like if intermediate H).
19089  wt=16d0*pkk(3,5)*pkk(4,6)
19090  wtmax=sh**2
19091  ELSE
19092 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
19093 C...t + bbar -> t + W + bbar.
19094  wt=1d0
19095  wtmax=1d0
19096  ENDIF
19097 
19098  ELSEIF(isub.EQ.145.OR.isub.EQ.162.OR.isub.EQ.163.OR.isub.EQ.164)
19099  & THEN
19100 C...Isotropic decay of leptoquarks (assumed spin 0).
19101  wt=1d0
19102  wtmax=1d0
19103 
19104  ELSEIF(isub.GE.146.AND.isub.LE.148) THEN
19105 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
19106  side=1d0
19107  IF(mint(16).EQ.21.OR.mint(16).EQ.22) side=-1d0
19108  IF(ip.EQ.1.AND.(kfl1(1).EQ.21.OR.kfl1(1).EQ.22)) THEN
19109  wt=1d0+side*cthe(1)
19110  wtmax=2d0
19111  ELSEIF(ip.EQ.1) THEN
19112 
19113  rm1=p(nsd(1)+1,5)**2/sh
19114  wt=1d0+side*cthe(1)*(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
19115  wtmax=1d0+(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
19116  ELSE
19117 C...W/Z decay assumed isotropic, since not known.
19118  wt=1d0
19119  wtmax=1d0
19120  ENDIF
19121 
19122  ELSEIF(isub.EQ.149) THEN
19123 C...Isotropic decay of techni-eta.
19124  wt=1d0
19125  wtmax=1d0
19126 
19127  ELSEIF(isub.EQ.191) THEN
19128  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
19129 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
19130 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
19131  wt=1d0-cthe(1)**2
19132  wtmax=1d0
19133  ELSEIF(ip.EQ.1) THEN
19134 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
19135  cthesg=cthe(1)*isign(1,mint(15))
19136  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
19137  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
19138  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
19139  kfai=iabs(mint(15))
19140  ei=kchg(kfai,1)/3d0
19141  ai=sign(1d0,ei+0.1d0)
19142  vi=ai-4d0*ei*xwv
19143  vali=0.5d0*(vi+ai)
19144  vari=0.5d0*(vi-ai)
19145  alefti=(ei+vali*bwzr)**2+(vali*bwzi)**2
19146  arighi=(ei+vari*bwzr)**2+(vari*bwzi)**2
19147  kfaf=iabs(kfl1(1))
19148  ef=kchg(kfaf,1)/3d0
19149  af=sign(1d0,ef+0.1d0)
19150  vf=af-4d0*ef*xwv
19151  valf=0.5d0*(vf+af)
19152  varf=0.5d0*(vf-af)
19153  aleftf=(ef+valf*bwzr)**2+(valf*bwzi)**2
19154  arighf=(ef+varf*bwzr)**2+(varf*bwzi)**2
19155  asame=alefti*aleftf+arighi*arighf
19156  aflip=alefti*arighf+arighi*aleftf
19157  wt=asame*(1d0+cthesg)**2+aflip*(1d0-cthesg)**2
19158  wtmax=4d0*max(asame,aflip)
19159  ELSE
19160 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
19161  wt=1d0
19162  wtmax=1d0
19163  ENDIF
19164 
19165  ELSEIF(isub.EQ.192) THEN
19166  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
19167 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
19168 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
19169  wt=1d0-cthe(1)**2
19170  wtmax=1d0
19171  ELSEIF(ip.EQ.1) THEN
19172 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
19173  cthesg=cthe(1)*isign(1,mint(15))
19174  wt=(1d0+cthesg)**2
19175  wtmax=4d0
19176  ELSE
19177 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
19178  wt=1d0
19179  wtmax=1d0
19180  ENDIF
19181 
19182  ELSEIF(isub.EQ.193) THEN
19183  IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
19184 C...Angular weight for f + fbar -> omega_tc0 ->
19185 C...gamma pi_tc0 or Z0 pi_tc0.
19186  wt=1d0+cthe(1)**2
19187  wtmax=2d0
19188  ELSEIF(ip.EQ.1) THEN
19189 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
19190  cthesg=cthe(1)*isign(1,mint(15))
19191  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
19192  bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
19193  kfai=iabs(mint(15))
19194  ei=kchg(kfai,1)/3d0
19195  ai=sign(1d0,ei+0.1d0)
19196  vi=ai-4d0*ei*xwv
19197  vali=0.5d0*(vi+ai)
19198  vari=0.5d0*(vi-ai)
19199  blefti=(ei-vali*bwzr)**2+(vali*bwzi)**2
19200  brighi=(ei-vari*bwzr)**2+(vari*bwzi)**2
19201  kfaf=iabs(kfl1(1))
19202  ef=kchg(kfaf,1)/3d0
19203  af=sign(1d0,ef+0.1d0)
19204  vf=af-4d0*ef*xwv
19205  valf=0.5d0*(vf+af)
19206  varf=0.5d0*(vf-af)
19207  bleftf=(ef-valf*bwzr)**2+(valf*bwzi)**2
19208  brighf=(ef-varf*bwzr)**2+(varf*bwzi)**2
19209  bsame=blefti*bleftf+brighi*brighf
19210  bflip=blefti*brighf+brighi*bleftf
19211  wt=bsame*(1d0+cthesg)**2+bflip*(1d0-cthesg)**2
19212  wtmax=4d0*max(bsame,bflip)
19213  ELSE
19214 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
19215  wt=1d0
19216  wtmax=1d0
19217  ENDIF
19218 
19219  ELSEIF(isub.EQ.353) THEN
19220 C...Angular weight for Z_R0 -> 2 quarks/leptons.
19221  ei=kchg(iabs(mint(15)),1)/3d0
19222  ai=sign(1d0,ei+0.1d0)
19223  vi=ai-4d0*ei*xwv
19224  ef=kchg(pycomp(kfl1(1)),1)/3d0
19225  af=sign(1d0,ef+0.1d0)
19226  vf=af-4d0*ef*xwv
19227  rmf=min(1d0,4d0*pmas(pycomp(kfl1(1)),1)**2/sh)
19228  wt1=(vi**2+ai**2)*(vf**2+(1d0-rmf)*af**2)
19229  wt2=rmf*(vi**2+ai**2)*vf**2
19230  wt3=sqrt(1d0-rmf)*4d0*vi*ai*vf*af
19231  wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
19232  & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
19233  wtmax=2d0*(wt1+abs(wt3))
19234 
19235  ELSEIF(isub.EQ.354) THEN
19236 C...Angular weight for W_R+/- -> 2 quarks/leptons.
19237  rm3=pmas(pycomp(kfl1(1)),1)**2/sh
19238  rm4=pmas(pycomp(kfl2(1)),1)**2/sh
19239  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
19240  wt=(1d0+be34*cthe(1)*isign(1,mint(15)*kfl1(1)))**2-(rm3-rm4)**2
19241  wtmax=4d0
19242 
19243  ELSEIF(isub.EQ.391) THEN
19244 C...Angular weight for f + fbar -> G* -> f + fbar
19245  IF(ip.EQ.1.AND.iabs(kfl1(1)).LE.18) THEN
19246  wt=1d0-3d0*cthe(1)**2+4d0*cthe(1)**4
19247  wtmax=2d0
19248 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
19249 C...implemented by M.-C. Lemaire
19250  ELSEIF(ip.EQ.1.AND.(iabs(kfl1(1)).EQ.21.OR.
19251  & iabs(kfl1(1)).EQ.22)) THEN
19252  wt=1d0-cthe(1)**4
19253  wtmax=1d0
19254 C...Other G* decays not yet implemented angular distributions.
19255  ELSE
19256  wt=1d0
19257  wtmax=1d0
19258  ENDIF
19259 
19260  ELSEIF(isub.EQ.392) THEN
19261 C...Angular weight for g + g -> G* -> f + fbar
19262  IF(ip.EQ.1.AND.iabs(kfl1(1)).LE.18) THEN
19263  wt=1d0-cthe(1)**4
19264  wtmax=1d0
19265 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
19266 C...implemented by M.-C. Lemaire
19267  ELSEIF(ip.EQ.1.AND.(iabs(kfl1(1)).EQ.21.OR.
19268  & iabs(kfl1(1)).EQ.22)) THEN
19269  wt=1d0+6d0*cthe(1)**2+cthe(1)**4
19270  wtmax=8d0
19271 C...Other G* decays not yet implemented angular distributions.
19272  ELSE
19273  wt=1d0
19274  wtmax=1d0
19275  ENDIF
19276 
19277 C...Obtain correct angular distribution by rejection techniques.
19278  ELSE
19279  wt=1d0
19280  wtmax=1d0
19281  ENDIF
19282  IF(wt.LT.pyr(0)*wtmax) goto 430
19283 
19284 C...Construct massive four-vectors using angles chosen.
19285  590 DO 690 jt=1,jtmax
19286  IF(kdcy(jt).EQ.0) goto 690
19287  id=iref(ip,jt)
19288  DO 600 j=1,5
19289  dpmo(j)=p(id,j)
19290  600 CONTINUE
19291  dpmo(4)=sqrt(dpmo(1)**2+dpmo(2)**2+dpmo(3)**2+dpmo(5)**2)
19292 CMRENNA++
19293  nprod=2
19294  IF(kfl3(jt).NE.0) nprod=3
19295  IF(kfl4(jt).NE.0) nprod=4
19296  CALL pyrobo(nsd(jt)+1,nsd(jt)+nprod,acos(cthe(jt)),phi(jt),
19297  & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
19298  n0=nsd(jt)+nprod
19299 
19300  DO 610 j=1,4
19301  vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
19302  610 CONTINUE
19303 C...Fill in position of decay vertex.
19304  DO 630 i=nsd(jt)+1,n0
19305  DO 620 j=1,4
19306  v(i,j)=vdcy(j)
19307  620 CONTINUE
19308  v(i,5)=0d0
19309 
19310  630 CONTINUE
19311 CMRENNA--
19312 
19313 C...Mark decayed resonances; trace history.
19314  k(id,1)=k(id,1)+10
19315  kfa=iabs(k(id,2))
19316  kca=pycomp(kfa)
19317  IF(kcqm(jt).NE.0) THEN
19318 C...Do not kill colour flow through coloured resonance!
19319  ELSE
19320  k(id,4)=nsd(jt)+1
19321  k(id,5)=nsd(jt)+nprod
19322  IF(itjunc(jt).NE.0) k(id,5)=k(id,5)+1
19323 C...If 3-body or 2-body with junction:
19324 c IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
19325 C...If 3-body with junction:
19326 c IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
19327  ENDIF
19328 
19329 C...Add documentation lines.
19330  isubrg=max(1,min(500,mint(1)))
19331  IF(ires.EQ.0.OR.iset(isubrg).EQ.11) THEN
19332  idoc=mint(83)+mint(4)
19333 CMRENNA+++
19334  ihi=nsd(jt)+nprod
19335 c IF(KFL3(JT).NE.0) IHI=IHI+1
19336  DO 650 i=nsd(jt)+1,ihi
19337 CMRENNA---
19338  i1=mint(83)+mint(4)+1
19339  k(i,3)=i1
19340  IF(mstp(128).GE.1) k(i,3)=id
19341  IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
19342  mint(4)=mint(4)+1
19343  k(i1,1)=21
19344  k(i1,2)=k(i,2)
19345  k(i1,3)=iref(ip,jt+3)
19346  DO 640 j=1,5
19347  p(i1,j)=p(i,j)
19348  640 CONTINUE
19349  ENDIF
19350  650 CONTINUE
19351  ELSE
19352  k(nsd(jt)+1,3)=id
19353  k(nsd(jt)+2,3)=id
19354 C...If 3-body or 2-body with junction:
19355  IF(kfl3(jt).NE.0.OR.itjunc(jt).GT.0) k(nsd(jt)+3,3)=id
19356 C...If 3-body with junction:
19357  IF(kfl3(jt).NE.0.AND.itjunc(jt).GT.0) k(nsd(jt)+4,3)=id
19358 C...If 4-body or 3-body with junction:
19359  IF(kfl4(jt).NE.0.OR.itjunc(jt).GT.0) k(nsd(jt)+4,3)=id
19360 C...If 4-body with junction:
19361  IF(kfl4(jt).NE.0.AND.itjunc(jt).GT.0) k(nsd(jt)+5,3)=id
19362  ENDIF
19363 
19364 C...Do showering of two or three objects.
19365  nshbef=n
19366  IF(mstp(71).GE.1.AND.mint(35).LE.1) THEN
19367  IF(kfl3(jt).EQ.0) THEN
19368  CALL pyshow(nsd(jt)+1,nsd(jt)+2,p(id,5))
19369  ELSE
19370  CALL pyshow(nsd(jt)+1,-nprod,p(id,5))
19371  ENDIF
19372 
19373 c...For pT-ordered shower need set up first, especially colour tags.
19374 C...(Need to set up colour tags even if MSTP(71) = 0)
19375  ELSEIF(mint(35).GE.2) THEN
19376  npart=nprod
19377 c IF(KFL3(JT).NE.0) NPART=3
19378  ipart(1)=nsd(jt)+1
19379  ipart(2)=nsd(jt)+2
19380  ipart(3)=nsd(jt)+3
19381  ipart(4)=nsd(jt)+4
19382  ptpart(1)=0.5d0*p(id,5)
19383  ptpart(2)=ptpart(1)
19384  ptpart(3)=ptpart(1)
19385  ptpart(4)=ptpart(1)
19386  IF(kcq1(jt).EQ.1.OR.kcq1(jt).EQ.2) THEN
19387  mother=k(nsd(jt)+1,4)/mstu(5)
19388  IF(mother.LE.nsd(jt)) THEN
19389  mct(nsd(jt)+1,1)=mct(mother,1)
19390  ELSE
19391  nct=nct+1
19392  mct(nsd(jt)+1,1)=nct
19393  mct(mother,2)=nct
19394  ENDIF
19395  ENDIF
19396  IF(kcq1(jt).EQ.-1.OR.kcq1(jt).EQ.2) THEN
19397  mother=k(nsd(jt)+1,5)/mstu(5)
19398  IF(mother.LE.nsd(jt)) THEN
19399  mct(nsd(jt)+1,2)=mct(mother,2)
19400  ELSE
19401  nct=nct+1
19402  mct(nsd(jt)+1,2)=nct
19403  mct(mother,1)=nct
19404  ENDIF
19405  ENDIF
19406  IF(mct(nsd(jt)+2,1).EQ.0.AND.(kcq2(jt).EQ.1.OR.
19407  & kcq2(jt).EQ.2)) THEN
19408  mother=k(nsd(jt)+2,4)/mstu(5)
19409  IF(mother.LE.nsd(jt)) THEN
19410  mct(nsd(jt)+2,1)=mct(mother,1)
19411  ELSE
19412  nct=nct+1
19413  mct(nsd(jt)+2,1)=nct
19414  mct(mother,2)=nct
19415  ENDIF
19416  ENDIF
19417  IF(mct(nsd(jt)+2,2).EQ.0.AND.(kcq2(jt).EQ.-1.OR.
19418  & kcq2(jt).EQ.2)) THEN
19419  mother=k(nsd(jt)+2,5)/mstu(5)
19420  IF(mother.LE.nsd(jt)) THEN
19421  mct(nsd(jt)+2,2)=mct(mother,2)
19422  ELSE
19423  nct=nct+1
19424  mct(nsd(jt)+2,2)=nct
19425  mct(mother,1)=nct
19426  ENDIF
19427  ENDIF
19428  IF(npart.EQ.3.AND.mct(nsd(jt)+3,1).EQ.0.AND.
19429  & (kcq3(jt).EQ.1.OR. kcq3(jt).EQ.2)) THEN
19430  mother=k(nsd(jt)+3,4)/mstu(5)
19431  mct(nsd(jt)+3,1)=mct(mother,1)
19432  ENDIF
19433  IF(npart.EQ.3.AND.mct(nsd(jt)+3,2).EQ.0.AND.
19434  & (kcq3(jt).EQ.-1.OR.kcq3(jt).EQ.2)) THEN
19435  mother=k(nsd(jt)+3,5)/mstu(5)
19436  mct(nsd(jt)+2,2)=mct(mother,2)
19437  ENDIF
19438  IF(npart.EQ.4.AND.mct(nsd(jt)+4,1).EQ.0.AND.
19439  & (kcq4(jt).EQ.1.OR. kcq4(jt).EQ.2)) THEN
19440  mother=k(nsd(jt)+4,4)/mstu(5)
19441  mct(nsd(jt)+4,1)=mct(mother,1)
19442  ENDIF
19443  IF(npart.EQ.4.AND.mct(nsd(jt)+4,2).EQ.0.AND.
19444  & (kcq4(jt).EQ.-1.OR.kcq4(jt).EQ.2)) THEN
19445  mother=k(nsd(jt)+4,5)/mstu(5)
19446  mct(nsd(jt)+4,2)=mct(mother,2)
19447  ENDIF
19448 
19449  IF (mstp(71).GE.1) CALL pyptfs(2,0.5d0*p(id,5),0d0,ptgen)
19450  ENDIF
19451  nshaft=n
19452  IF(jt.EQ.1) naft1=n
19453 
19454 C...Check if decay products moved by shower.
19455  nsd1=nsd(jt)+1
19456  nsd2=nsd(jt)+2
19457  nsd3=nsd(jt)+3
19458  nsd4=nsd(jt)+4
19459 C...4-body decays will only work if one of the products is "inert"
19460  IF(nshaft.GT.nshbef) THEN
19461  IF(k(nsd1,1).GT.10) THEN
19462  DO 660 i=nshbef+1,nshaft
19463  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd1,2)) nsd1=i
19464  660 CONTINUE
19465  ENDIF
19466  IF(k(nsd2,1).GT.10) THEN
19467  DO 670 i=nshbef+1,nshaft
19468  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd2,2).AND.
19469  & i.NE.nsd1) nsd2=i
19470  670 CONTINUE
19471  ENDIF
19472  IF(kfl3(jt).NE.0.AND.k(nsd3,1).GT.10) THEN
19473  DO 680 i=nshbef+1,nshaft
19474  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd3,2).AND.
19475  & i.NE.nsd1.AND.i.NE.nsd2) nsd3=i
19476  680 CONTINUE
19477  ENDIF
19478  IF(kfl4(jt).NE.0.AND.k(nsd4,1).GT.10) THEN
19479  DO 685 i=nshbef+1,nshaft
19480  IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd4,2).AND.
19481  & i.NE.nsd1.AND.i.NE.nsd2.AND.i.NE.nsd3) nsd4=i
19482  685 CONTINUE
19483  ENDIF
19484  ENDIF
19485 
19486 C...Store decay products for further treatment.
19487  IF(kfl4(jt).EQ.0) THEN
19488  np=np+1
19489  iref(np,1)=nsd1
19490  iref(np,2)=nsd2
19491  iref(np,3)=0
19492  IF(kfl3(jt).NE.0) iref(np,3)=nsd3
19493  iref(np,4)=idoc+1
19494  iref(np,5)=idoc+2
19495  iref(np,6)=0
19496  IF(kfl3(jt).NE.0) iref(np,6)=idoc+3
19497  iref(np,7)=k(iref(ip,jt),2)
19498  iref(np,8)=iref(ip,jt)
19499  ELSE
19500  nsda=nsd1
19501  nsdb=nsd2
19502  nsdc=nsd3
19503  np=np+1
19504  iref(np,4)=idoc+1
19505  iref(np,5)=idoc+2
19506  iref(np,6)=idoc+3
19507  IF(k(nsd1,1).EQ.1) THEN
19508  nsda=nsd4
19509  iref(np,4)=idoc+4
19510  ELSEIF(k(nsd2,1).EQ.1) THEN
19511  nsdb=nsd4
19512  iref(np,5)=idoc+4
19513  ELSEIF(k(nsd3,1).EQ.1) THEN
19514  nsdc=nsd4
19515  iref(np,6)=idoc+4
19516  ENDIF
19517  iref(np,1)=nsda
19518  iref(np,2)=nsdb
19519  iref(np,3)=nsdc
19520  iref(np,7)=k(iref(ip,jt),2)
19521  iref(np,8)=iref(ip,jt)
19522  ENDIF
19523  690 CONTINUE
19524 
19525 
19526 C...Fill information for 2 -> 1 -> 2.
19527  700 IF(jtmax.EQ.1.AND.kdcy(1).NE.0.AND.isub.NE.0) THEN
19528  mint(7)=mint(83)+6+2*iset(isub)
19529  mint(8)=mint(83)+7+2*iset(isub)
19530  mint(25)=kfl1(1)
19531  mint(26)=kfl2(1)
19532  vint(23)=cthe(1)
19533  rm3=p(n-1,5)**2/sh
19534  rm4=p(n,5)**2/sh
19535  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
19536  vint(45)=-0.5d0*sh*(1d0-rm3-rm4-be34*cthe(1))
19537  vint(46)=-0.5d0*sh*(1d0-rm3-rm4+be34*cthe(1))
19538  vint(48)=0.25d0*sh*be34**2*max(0d0,1d0-cthe(1)**2)
19539  vint(47)=sqrt(vint(48))
19540  ENDIF
19541 
19542 C...Possibility of colour rearrangement in W+W- events.
19543  IF((isub.EQ.25.OR.isub.EQ.22).AND.mstp(115).GE.1) THEN
19544  iakf1=iabs(kfl1(1))
19545  iakf2=iabs(kfl1(2))
19546  iakf3=iabs(kfl2(1))
19547  iakf4=iabs(kfl2(2))
19548  IF(min(iakf1,iakf2,iakf3,iakf4).GE.1.AND.
19549  & max(iakf1,iakf2,iakf3,iakf4).LE.5) CALL
19550  & pyreco(iref(1,1),iref(1,2),nsd(1),naft1)
19551  IF(mint(51).NE.0) RETURN
19552  ENDIF
19553 
19554 C...Loop back if needed.
19555  710 IF(ip.LT.np) goto 170
19556 
19557 C...Boost back to standard frame.
19558  720 IF(ibst.EQ.1) CALL pyrobo(mint(83)+7,n,thein,phiin,bexin,beyin,
19559  &bezin)
19560 
19561 
19562  RETURN
19563  END
19564 
19565 C*********************************************************************
19566 
19567 C...PYMULT
19568 C...Initializes treatment of multiple interactions, selects kinematics
19569 C...of hardest interaction if low-pT physics included in run, and
19570 C...generates all non-hardest interactions.
19571 
19572  SUBROUTINE pymult(MMUL)
19573 
19574 C...Double precision and integer declarations.
19575  IMPLICIT DOUBLE PRECISION(a-h, o-z)
19576  IMPLICIT INTEGER(i-n)
19577  INTEGER pyk,pychge,pycomp
19578 C...Commonblocks.
19579  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
19580  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
19581  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
19582  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
19583  common/pypars/mstp(200),parp(200),msti(200),pari(200)
19584  common/pyint1/mint(400),vint(400)
19585  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
19586  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
19587  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
19588  common/pyint7/sigt(0:6,0:6,0:5)
19589  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
19590  &/pyint2/,/pyint3/,/pyint5/,/pyint7/
19591 C...Local arrays and saved variables.
19592  dimension nmul(20),sigm(20),kstr(500,2),vintsv(80)
19593  SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm,p83a,p83b,p83c,
19594  &cq2i,cq2r,pik,bdiv,b,plowb,phighb,pallb,s4a,s4b,s4c,powip,
19595  &rpwip,b2rpdv,b2rpmx,bavg,vnt145,vnt146,vnt147
19596 
19597 C...Initialization of multiple interaction treatment.
19598  IF(mmul.EQ.1) THEN
19599  IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
19600  isub=96
19601  mint(1)=96
19602  vint(63)=0d0
19603  vint(64)=0d0
19604  vint(143)=1d0
19605  vint(144)=1d0
19606 
19607 C...Loop over phase space points: xT2 choice in 20 bins.
19608  100 sigsum=0d0
19609  DO 120 ixt2=1,20
19610  nmul(ixt2)=mstp(83)
19611  sigm(ixt2)=0d0
19612  DO 110 itry=1,mstp(83)
19613  rsca=0.05d0*((21-ixt2)-pyr(0))
19614  xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
19615  xt2=max(0.01d0*vint(149),xt2)
19616  vint(25)=xt2
19617 
19618 C...Choose tau and y*. Calculate cos(theta-hat).
19619  IF(pyr(0).LE.coef(isub,1)) THEN
19620  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19621  tau=xt2*(1d0+taut)**2/(4d0*taut)
19622  ELSE
19623  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19624  ENDIF
19625  vint(21)=tau
19626  CALL pyklim(2)
19627  ryst=pyr(0)
19628  myst=1
19629  IF(ryst.GT.coef(isub,8)) myst=2
19630  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19631  CALL pykmap(2,myst,pyr(0))
19632  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19633 
19634 C...Calculate differential cross-section.
19635  vint(71)=0.5d0*vint(1)*sqrt(xt2)
19636  CALL pysigh(nchn,sigs)
19637  sigm(ixt2)=sigm(ixt2)+sigs
19638  110 CONTINUE
19639  sigsum=sigsum+sigm(ixt2)
19640  120 CONTINUE
19641  sigsum=sigsum/(20d0*mstp(83))
19642 
19643 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19644  IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
19645  IF(mstp(122).GE.1) WRITE(mstu(11),5100)
19646  & parp(82)*(vint(1)/parp(89))**parp(90),sigsum
19647  parp(82)=0.9d0*parp(82)
19648  vint(149)=4d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
19649  & vint(2)
19650  goto 100
19651  ENDIF
19652  IF(mstp(122).GE.1) WRITE(mstu(11),5200)
19653  & parp(82)*(vint(1)/parp(89))**parp(90), sigsum
19654 
19655 C...Start iteration to find k factor.
19656  yke=sigsum/max(1d-10,sigt(0,0,5))
19657  p83a=(1d0-parp(83))**2
19658  p83b=2d0*parp(83)*(1d0-parp(83))
19659  p83c=parp(83)**2
19660  cq2i=1d0/parp(84)**2
19661  cq2r=2d0/(1d0+parp(84)**2)
19662  so=0.5d0
19663  xi=0d0
19664  yi=0d0
19665  xf=0d0
19666  yf=0d0
19667  xk=0.5d0
19668  iit=0
19669  130 IF(iit.EQ.0) THEN
19670  xk=2d0*xk
19671  ELSEIF(iit.EQ.1) THEN
19672  xk=0.5d0*xk
19673  ELSE
19674  xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
19675  ENDIF
19676 
19677 C...Evaluate overlap integrals. Find where to divide the b range.
19678  IF(mstp(82).EQ.2) THEN
19679  sp=0.5d0*paru(1)*(1d0-exp(-xk))
19680  sop=sp/paru(1)
19681  ELSE
19682  IF(mstp(82).EQ.3) THEN
19683  deltab=0.02d0
19684  ELSEIF(mstp(82).EQ.4) THEN
19685  deltab=min(0.01d0,0.05d0*parp(84))
19686  ELSE
19687  powip=max(0.4d0,parp(83))
19688  rpwip=2d0/powip-1d0
19689  deltab=max(0.02d0,0.02d0*(2d0/powip)**(1d0/powip))
19690  so=0d0
19691  ENDIF
19692  sp=0d0
19693  sop=0d0
19694  bsp=0d0
19695  sohigh=0d0
19696  ibdiv=0
19697  b=-0.5d0*deltab
19698  140 b=b+deltab
19699  IF(mstp(82).EQ.3) THEN
19700  ov=exp(-b**2)/paru(2)
19701  ELSEIF(mstp(82).EQ.4) THEN
19702  ov=(p83a*exp(-min(50d0,b**2))+
19703  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19704  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19705  ELSE
19706  ov=exp(-b**powip)/paru(2)
19707  so=so+paru(2)*b*deltab*ov
19708  ENDIF
19709  IF(ibdiv.EQ.1) sohigh=sohigh+paru(2)*b*deltab*ov
19710  pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
19711  sp=sp+paru(2)*b*deltab*pacc
19712  sop=sop+paru(2)*b*deltab*ov*pacc
19713  bsp=bsp+b*paru(2)*b*deltab*pacc
19714  IF(ibdiv.EQ.0.AND.paru(1)*xk*ov.LT.1d0) THEN
19715  ibdiv=1
19716  bdiv=b+0.5d0*deltab
19717  ENDIF
19718  IF(b.LT.1d0.OR.b*pacc.GT.1d-6) goto 140
19719  ENDIF
19720  yk=paru(1)*xk*so/sp
19721 
19722 C...Continue iteration until convergence.
19723  IF(yk.LT.yke) THEN
19724  xi=xk
19725  yi=yk
19726  IF(iit.EQ.1) iit=2
19727  ELSE
19728  xf=xk
19729  yf=yk
19730  IF(iit.EQ.0) iit=1
19731  ENDIF
19732  IF(abs(yk-yke).GE.1d-5*yke) goto 130
19733 
19734 C...Store some results for subsequent use.
19735  bavg=bsp/sp
19736  vint(145)=sigsum
19737  vint(146)=sop/so
19738  vint(147)=sop/sp
19739  vnt145=vint(145)
19740  vnt146=vint(146)
19741  vnt147=vint(147)
19742 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19743  pik=(vnt146/vnt147)*yke
19744 
19745 C...Find relative weight for low and high impact parameter.
19746  plowb=paru(1)*bdiv**2
19747  IF(mstp(82).EQ.3) THEN
19748  phighb=pik*0.5*exp(-bdiv**2)
19749  ELSEIF(mstp(82).EQ.4) THEN
19750  s4a=p83a*exp(-bdiv**2)
19751  s4b=p83b*exp(-bdiv**2*cq2r)
19752  s4c=p83c*exp(-bdiv**2*cq2i)
19753  phighb=pik*0.5*(s4a+s4b+s4c)
19754  ELSEIF(parp(83).GE.1.999d0) THEN
19755  phighb=pik*sohigh
19756  b2rpdv=bdiv**powip
19757  ELSE
19758  phighb=pik*sohigh
19759  b2rpdv=bdiv**powip
19760  b2rpmx=max(2d0*rpwip,b2rpdv)
19761  ENDIF
19762  pallb=plowb+phighb
19763 
19764 C...Initialize iteration in xT2 for hardest interaction.
19765  ELSEIF(mmul.EQ.2) THEN
19766  vint(145)=vnt145
19767  vint(146)=vnt146
19768  vint(147)=vnt147
19769  IF(mstp(82).LE.0) THEN
19770  ELSEIF(mstp(82).EQ.1) THEN
19771  xt2=1d0
19772  sigrat=xsec(96,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
19773  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
19774  & vint(317)/(vint(318)*vint(320))
19775  xt2fac=sigrat*vint(149)/(1d0-vint(149))
19776  ELSEIF(mstp(82).EQ.2) THEN
19777  xt2=1d0
19778  xt2fac=vnt146*xsec(96,1)/max(1d-10,sigt(0,0,5))*
19779  & vint(149)*(1d0+vint(149))
19780  ELSE
19781  xc2=4d0*ckin(3)**2/vint(2)
19782  IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
19783  ENDIF
19784 
19785 C...Select impact parameter for hardest interaction.
19786  IF(mstp(82).LE.2) RETURN
19787  142 IF(pyr(0)*pallb.LT.plowb) THEN
19788 C...Treatment in low b region.
19789  mint(39)=1
19790  b=bdiv*sqrt(pyr(0))
19791  IF(mstp(82).EQ.3) THEN
19792  ov=exp(-b**2)/paru(2)
19793  ELSEIF(mstp(82).EQ.4) THEN
19794  ov=(p83a*exp(-min(50d0,b**2))+
19795  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19796  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19797  ELSE
19798  ov=exp(-b**powip)/paru(2)
19799  ENDIF
19800  vint(148)=ov/vnt147
19801  pacc=1d0-exp(-min(50d0,pik*ov))
19802  xt2=1d0
19803  xt2fac=vnt146*vint(148)*xsec(96,1)/max(1d-10,sigt(0,0,5))*
19804  & vint(149)*(1d0+vint(149))
19805  ELSE
19806 C...Treatment in high b region.
19807  mint(39)=2
19808  IF(mstp(82).EQ.3) THEN
19809  b=sqrt(bdiv**2-log(pyr(0)))
19810  ov=exp(-b**2)/paru(2)
19811  ELSEIF(mstp(82).EQ.4) THEN
19812  s4rndm=pyr(0)*(s4a+s4b+s4c)
19813  IF(s4rndm.LT.s4a) THEN
19814  b=sqrt(bdiv**2-log(pyr(0)))
19815  ELSEIF(s4rndm.LT.s4a+s4b) THEN
19816  b=sqrt(bdiv**2-log(pyr(0))/cq2r)
19817  ELSE
19818  b=sqrt(bdiv**2-log(pyr(0))/cq2i)
19819  ENDIF
19820  ov=(p83a*exp(-min(50d0,b**2))+
19821  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19822  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19823  ELSEIF(parp(83).GE.1.999d0) THEN
19824  144 b2rpw=b2rpdv-log(pyr(0))
19825  accip=(b2rpw/b2rpdv)**rpwip
19826  IF(accip.LT.pyr(0)) goto 144
19827  ov=exp(-b2rpw)/paru(2)
19828  b=b2rpw**(1d0/powip)
19829  ELSE
19830  146 b2rpw=b2rpdv-2d0*log(pyr(0))
19831  accip=(b2rpw/b2rpmx)**rpwip*exp(-0.5d0*(b2rpw-b2rpmx))
19832  IF(accip.LT.pyr(0)) goto 146
19833  ov=exp(-b2rpw)/paru(2)
19834  b=b2rpw**(1d0/powip)
19835  ENDIF
19836  vint(148)=ov/vnt147
19837  pacc=(1d0-exp(-min(50d0,pik*ov)))/(pik*ov)
19838  ENDIF
19839  IF(pacc.LT.pyr(0)) goto 142
19840  vint(139)=b/bavg
19841 
19842  ELSEIF(mmul.EQ.3) THEN
19843 C...Low-pT or multiple interactions (first semihard interaction):
19844 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19845 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19846  isub=mint(1)
19847  vint(145)=vnt145
19848  vint(146)=vnt146
19849  vint(147)=vnt147
19850  IF(mstp(82).LE.0) THEN
19851  xt2=0d0
19852  ELSEIF(mstp(82).EQ.1) THEN
19853  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
19854 C...Use with "Sudakov" for low b values when impact parameter dependence.
19855  ELSEIF(mstp(82).EQ.2.OR.mint(39).EQ.1) THEN
19856  IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
19857  & vint(149)))).GT.pyr(0)) xt2=1d0
19858  IF(xt2.GE.1d0) THEN
19859  xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
19860  & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
19861  & vint(149)
19862  ELSE
19863  xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
19864  & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
19865  & vint(149)
19866  ENDIF
19867  xt2=max(0.01d0*vint(149),xt2)
19868 C...Use without "Sudakov" for high b values when impact parameter dep.
19869  ELSE
19870  xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
19871  & pyr(0)*(1d0-xc2))-vint(149)
19872  xt2=max(0.01d0*vint(149),xt2)
19873  ENDIF
19874  vint(25)=xt2
19875 
19876 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19877  IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
19878  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-mint(143)
19879  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-mint(143)
19880  isub=95
19881  mint(1)=isub
19882  vint(21)=0.01d0*vint(149)
19883  vint(22)=0d0
19884  vint(23)=0d0
19885  vint(25)=0.01d0*vint(149)
19886 
19887  ELSE
19888 C...Multiple interactions (first semihard interaction).
19889 C...Choose tau and y*. Calculate cos(theta-hat).
19890  IF(pyr(0).LE.coef(isub,1)) THEN
19891  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19892  tau=xt2*(1d0+taut)**2/(4d0*taut)
19893  ELSE
19894  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19895  ENDIF
19896  vint(21)=tau
19897  CALL pyklim(2)
19898  ryst=pyr(0)
19899  myst=1
19900  IF(ryst.GT.coef(isub,8)) myst=2
19901  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19902  CALL pykmap(2,myst,pyr(0))
19903  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19904  ENDIF
19905  vint(71)=0.5d0*vint(1)*sqrt(vint(25))
19906 
19907 C...Store results of cross-section calculation.
19908  ELSEIF(mmul.EQ.4) THEN
19909  isub=mint(1)
19910  vint(145)=vnt145
19911  vint(146)=vnt146
19912  vint(147)=vnt147
19913  xts=vint(25)
19914  IF(iset(isub).EQ.1) xts=vint(21)
19915  IF(iset(isub).EQ.2)
19916  & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
19917  IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
19918  rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
19919  & (xts+vint(149))))
19920  irbin=int(1d0+20d0*rbin)
19921  IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
19922  nmul(irbin)=nmul(irbin)+1
19923  sigm(irbin)=sigm(irbin)+vint(153)
19924  ENDIF
19925 
19926 C...Choose impact parameter if not already done.
19927  ELSEIF(mmul.EQ.5) THEN
19928  isub=mint(1)
19929  vint(145)=vnt145
19930  vint(146)=vnt146
19931  vint(147)=vnt147
19932  150 IF(mint(39).GT.0) THEN
19933  ELSEIF(mstp(82).EQ.3) THEN
19934  expb2=pyr(0)
19935  b2=-log(pyr(0))
19936  vint(148)=expb2/(paru(2)*vnt147)
19937  vint(139)=sqrt(b2)/bavg
19938  ELSEIF(mstp(82).EQ.4) THEN
19939  rtype=pyr(0)
19940  IF(rtype.LT.p83a) THEN
19941  b2=-log(pyr(0))
19942  ELSEIF(rtype.LT.p83a+p83b) THEN
19943  b2=-log(pyr(0))/cq2r
19944  ELSE
19945  b2=-log(pyr(0))/cq2i
19946  ENDIF
19947  vint(148)=(p83a*exp(-min(50d0,b2))+
19948  & p83b*cq2r*exp(-min(50d0,b2*cq2r))+
19949  & p83c*cq2i*exp(-min(50d0,b2*cq2i)))/(paru(2)*vnt147)
19950  vint(139)=sqrt(b2)/bavg
19951  ELSEIF(parp(83).GE.1.999d0) THEN
19952  powip=max(2d0,parp(83))
19953  rpwip=2d0/powip-1d0
19954  prob1=powip/(2d0*exp(-1d0)+powip)
19955  160 IF(pyr(0).LT.prob1) THEN
19956  b2rpw=pyr(0)**(0.5d0*powip)
19957  accip=exp(-b2rpw)
19958  ELSE
19959  b2rpw=1d0-log(pyr(0))
19960  accip=b2rpw**rpwip
19961  ENDIF
19962  IF(accip.LT.pyr(0)) goto 160
19963  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
19964  vint(139)=b2rpw**(1d0/powip)/bavg
19965  ELSE
19966  powip=max(0.4d0,parp(83))
19967  rpwip=2d0/powip-1d0
19968  prob1=rpwip/(rpwip+2d0**rpwip*exp(-rpwip))
19969  170 IF(pyr(0).LT.prob1) THEN
19970  b2rpw=2d0*rpwip*pyr(0)
19971  accip=(b2rpw/rpwip)**rpwip*exp(rpwip-b2rpw)
19972  ELSE
19973  b2rpw=2d0*(rpwip-log(pyr(0)))
19974  accip=(0.5d0*b2rpw/rpwip)**rpwip*exp(rpwip-0.5d0*b2rpw)
19975  ENDIF
19976  IF(accip.lt .pyr(0)) goto 170
19977  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
19978  vint(139)=b2rpw**(1d0/powip)/bavg
19979  ENDIF
19980 
19981 C...Multiple interactions (variable impact parameter) : reject with
19982 C...probability exp(-overlap*cross-section above pT/normalization).
19983 C...Does not apply to low-b region, where "Sudakov" already included.
19984  vint(150)=1d0
19985  IF(mint(39).NE.1) THEN
19986  rncor=(irbin-20d0*rbin)*nmul(irbin)
19987  sigcor=(irbin-20d0*rbin)*sigm(irbin)
19988  DO 180 ibin=irbin+1,20
19989  rncor=rncor+nmul(ibin)
19990  sigcor=sigcor+sigm(ibin)
19991  180 CONTINUE
19992  sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
19993  IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
19994  vint(150)=exp(-min(50d0,vnt146*vint(148)*
19995  & sigabv/max(1d-10,sigt(0,0,5))))
19996  ENDIF
19997  IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isub.NE.11.AND.
19998  & isub.NE.12.AND.isub.NE.13.AND.isub.NE.28.AND.isub.NE.53
19999  & .AND.isub.NE.68.AND.isub.NE.95.AND.isub.NE.96)) THEN
20000  IF(vint(150).LT.pyr(0)) goto 150
20001  vint(150)=1d0
20002  ENDIF
20003 
20004 C...Generate additional multiple semihard interactions.
20005  ELSEIF(mmul.EQ.6) THEN
20006  isubsv=mint(1)
20007  vint(145)=vnt145
20008  vint(146)=vnt146
20009  vint(147)=vnt147
20010  DO 190 j=11,80
20011  vintsv(j)=vint(j)
20012  190 CONTINUE
20013  isub=96
20014  mint(1)=96
20015  vint(151)=0d0
20016  vint(152)=0d0
20017 
20018 C...Reconstruct strings in hard scattering.
20019  nmax=mint(84)+4
20020  IF(iset(isubsv).EQ.1) nmax=mint(84)+2
20021  IF(iset(isubsv).EQ.11) nmax=mint(84)+2+mint(3)
20022  nstr=0
20023  DO 210 i=mint(84)+1,nmax
20024  kcs=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
20025  IF(kcs.EQ.0) goto 210
20026  DO 200 j=1,4
20027  IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) goto 200
20028  IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) goto 200
20029  IF(j.LE.2) THEN
20030  ist=mod(k(i,j+3)/mstu(5),mstu(5))
20031  ELSE
20032  ist=mod(k(i,j+1),mstu(5))
20033  ENDIF
20034  IF(ist.LT.mint(84).OR.ist.GT.i) goto 200
20035  IF(kchg(pycomp(k(ist,2)),2).EQ.0) goto 200
20036  nstr=nstr+1
20037  IF(j.EQ.1.OR.j.EQ.4) THEN
20038  kstr(nstr,1)=i
20039  kstr(nstr,2)=ist
20040  ELSE
20041  kstr(nstr,1)=ist
20042  kstr(nstr,2)=i
20043  ENDIF
20044  200 CONTINUE
20045  210 CONTINUE
20046 
20047 C...Set up starting values for iteration in xT2.
20048  xt2=4d0*vint(62)/vint(2)
20049  IF(mstp(82).LE.1) THEN
20050  sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
20051  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
20052  & vint(317)/(vint(318)*vint(320))
20053  xt2fac=sigrat*vint(149)/(1d0-vint(149))
20054  ELSE
20055  xt2fac=vnt146*vint(148)*xsec(isub,1)/
20056  & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
20057  ENDIF
20058  vint(63)=0d0
20059  vint(64)=0d0
20060  vint(143)=1d0-vint(141)
20061  vint(144)=1d0-vint(142)
20062 
20063 C...Iterate downwards in xT2.
20064  220 IF(mstp(82).LE.1) THEN
20065  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
20066  IF(xt2.LT.vint(149)) goto 270
20067  ELSE
20068  IF(xt2.LE.0.01001d0*vint(149)) goto 270
20069  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
20070  & log(pyr(0)))-vint(149)
20071  IF(xt2.LE.0d0) goto 270
20072  xt2=max(0.01d0*vint(149),xt2)
20073  ENDIF
20074  vint(25)=xt2
20075 
20076 C...Choose tau and y*. Calculate cos(theta-hat).
20077  IF(pyr(0).LE.coef(isub,1)) THEN
20078  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20079  tau=xt2*(1d0+taut)**2/(4d0*taut)
20080  ELSE
20081  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20082  ENDIF
20083  vint(21)=tau
20084  CALL pyklim(2)
20085  ryst=pyr(0)
20086  myst=1
20087  IF(ryst.GT.coef(isub,8)) myst=2
20088  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20089  CALL pykmap(2,myst,pyr(0))
20090  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20091 
20092 C...Check that x not used up. Accept or reject kinematical variables.
20093  x1m=sqrt(tau)*exp(vint(22))
20094  x2m=sqrt(tau)*exp(-vint(22))
20095  IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) goto 220
20096  vint(71)=0.5d0*vint(1)*sqrt(xt2)
20097  CALL pysigh(nchn,sigs)
20098  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
20099  IF(sigs.LT.xsec(isub,1)*pyr(0)) goto 220
20100 
20101 C...Reset K, P and V vectors. Select some variables.
20102  DO 240 i=n+1,n+2
20103  DO 230 j=1,5
20104  k(i,j)=0
20105  p(i,j)=0d0
20106  v(i,j)=0d0
20107  230 CONTINUE
20108  240 CONTINUE
20109  rflav=pyr(0)
20110  pt=0.5d0*vint(1)*sqrt(xt2)
20111  phi=paru(2)*pyr(0)
20112  cth=vint(23)
20113 
20114 C...Add first parton to event record.
20115  k(n+1,1)=3
20116  k(n+1,2)=21
20117  IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=
20118  & 1+int((2d0+parj(2))*pyr(0))
20119  p(n+1,1)=pt*cos(phi)
20120  p(n+1,2)=pt*sin(phi)
20121  p(n+1,3)=0.25d0*vint(1)*(vint(41)*(1d0+cth)-vint(42)*(1d0-cth))
20122  p(n+1,4)=0.25d0*vint(1)*(vint(41)*(1d0+cth)+vint(42)*(1d0-cth))
20123  p(n+1,5)=0d0
20124 
20125 C...Add second parton to event record.
20126  k(n+2,1)=3
20127  k(n+2,2)=21
20128  IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)
20129  p(n+2,1)=-p(n+1,1)
20130  p(n+2,2)=-p(n+1,2)
20131  p(n+2,3)=0.25d0*vint(1)*(vint(41)*(1d0-cth)-vint(42)*(1d0+cth))
20132  p(n+2,4)=0.25d0*vint(1)*(vint(41)*(1d0-cth)+vint(42)*(1d0+cth))
20133  p(n+2,5)=0d0
20134 
20135  IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN
20136 C....Choose relevant string pieces to place gluons on.
20137  DO 260 i=n+1,n+2
20138  dmin=1d8
20139  DO 250 istr=1,nstr
20140  i1=kstr(istr,1)
20141  i2=kstr(istr,2)
20142  dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-
20143  & p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-
20144  & p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1d0,p(i1,4)*p(i2,4)-
20145  & p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))
20146  IF(istr.EQ.1.OR.dist.LT.dmin) THEN
20147  dmin=dist
20148  ist1=i1
20149  ist2=i2
20150  istm=istr
20151  ENDIF
20152  250 CONTINUE
20153 
20154 C....Colour flow adjustments, new string pieces.
20155  IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+
20156  & mod(k(ist1,4),mstu(5))
20157  IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)=
20158  & mstu(5)*(k(ist1,5)/mstu(5))+i
20159  k(i,5)=mstu(5)*ist1
20160  k(i,4)=mstu(5)*ist2
20161  IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+
20162  & mod(k(ist2,5),mstu(5))
20163  IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)=
20164  & mstu(5)*(k(ist2,4)/mstu(5))+i
20165  kstr(istm,2)=i
20166  kstr(nstr+1,1)=i
20167  kstr(nstr+1,2)=ist2
20168  nstr=nstr+1
20169  260 CONTINUE
20170 
20171 C...String drawing and colour flow for gluon loop.
20172  ELSEIF(k(n+1,2).EQ.21) THEN
20173  k(n+1,4)=mstu(5)*(n+2)
20174  k(n+1,5)=mstu(5)*(n+2)
20175  k(n+2,4)=mstu(5)*(n+1)
20176  k(n+2,5)=mstu(5)*(n+1)
20177  kstr(nstr+1,1)=n+1
20178  kstr(nstr+1,2)=n+2
20179  kstr(nstr+2,1)=n+2
20180  kstr(nstr+2,2)=n+1
20181  nstr=nstr+2
20182 
20183 C...String drawing and colour flow for qqbar pair.
20184  ELSE
20185  k(n+1,4)=mstu(5)*(n+2)
20186  k(n+2,5)=mstu(5)*(n+1)
20187  kstr(nstr+1,1)=n+1
20188  kstr(nstr+1,2)=n+2
20189  nstr=nstr+1
20190  ENDIF
20191 
20192 C...Global statistics.
20193  mint(351)=mint(351)+1
20194  vint(351)=vint(351)+pt
20195  IF (mint(351).EQ.1) vint(356)=pt
20196 
20197 C...Update remaining energy; iterate.
20198  n=n+2
20199  IF(n.GT.mstu(4)-mstu(32)-10) THEN
20200  CALL pyerrm(11,'(PYMULT:) no more memory left in PYJETS')
20201  mint(51)=1
20202  RETURN
20203  ENDIF
20204  mint(31)=mint(31)+1
20205  vint(151)=vint(151)+vint(41)
20206  vint(152)=vint(152)+vint(42)
20207  vint(143)=vint(143)-vint(41)
20208  vint(144)=vint(144)-vint(42)
20209 C...Allow FSR for UE (always handle with old showers)
20210  IF(mstp(152).EQ.1) THEN
20211  m41sav=mstj(41)
20212  IF (mstj(41).EQ.10) mstj(41)=2
20213  mstj(41)=mod(mstj(41),10)
20214  CALL pyshow(n-1,n,sqrt(parp(71))*pt)
20215  mstj(41)=m41sav
20216  ENDIF
20217  IF(mint(31).LT.240) goto 220
20218  270 CONTINUE
20219  mint(1)=isubsv
20220  DO 280 j=11,80
20221  vint(j)=vintsv(j)
20222  280 CONTINUE
20223  ENDIF
20224 
20225 C...Format statements for printout.
20226  5000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter',
20227  &'actions for MSTP(82) =',i2,' ******')
20228  5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
20229  &d9.2,' mb: rejected')
20230  5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
20231  &d9.2,' mb: accepted')
20232 
20233  RETURN
20234  END
20235 
20236 C*********************************************************************
20237 
20238 C...PYREMN
20239 C...Adds on target remnants (one or two from each side) and
20240 C...includes primordial kT for hadron beams.
20241 
20242  SUBROUTINE pyremn(IPU1,IPU2)
20243 
20244 C...Double precision and integer declarations.
20245  IMPLICIT DOUBLE PRECISION(a-h, o-z)
20246  IMPLICIT INTEGER(i-n)
20247  INTEGER pyk,pychge,pycomp
20248 C...Commonblocks.
20249  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
20250  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
20251  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
20252  common/pypars/mstp(200),parp(200),msti(200),pari(200)
20253  common/pyint1/mint(400),vint(400)
20254  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
20255 C...Local arrays.
20256  dimension kflch(2),kflsp(2),chi(2),pms(0:6),is(2),isn(2),robo(5),
20257  &psys(0:2,5),pmin(0:2),qold(4),qnew(4),dbe(3),psum(4)
20258 
20259 C...Find event type and remaining energy.
20260  isub=mint(1)
20261  ns=n
20262  IF(mint(50).EQ.0.OR.mod(mstp(81),10).LE.0) THEN
20263  vint(143)=1d0-vint(141)
20264  vint(144)=1d0-vint(142)
20265  ENDIF
20266 
20267 C...Define initial partons.
20268  ntry=0
20269  100 ntry=ntry+1
20270  DO 130 jt=1,2
20271  i=mint(83)+jt+2
20272  IF(jt.EQ.1) ipu=ipu1
20273  IF(jt.EQ.2) ipu=ipu2
20274  k(i,1)=21
20275  k(i,2)=k(ipu,2)
20276  k(i,3)=i-2
20277  pms(jt)=0d0
20278  vint(156+jt)=0d0
20279  vint(158+jt)=0d0
20280  IF(mint(47).EQ.1) THEN
20281  DO 110 j=1,5
20282  p(i,j)=p(i-2,j)
20283  110 CONTINUE
20284  ELSEIF(isub.EQ.95) THEN
20285  k(i,2)=21
20286  ELSE
20287  p(i,5)=p(ipu,5)
20288 
20289 C...No primordial kT, or chosen according to truncated Gaussian or
20290 C...exponential, or (for photon) predetermined or power law.
20291  120 IF(mint(40+jt).EQ.2.AND.mint(10+jt).NE.22) THEN
20292  IF(mstp(91).LE.0) THEN
20293  pt=0d0
20294  ELSEIF(mstp(91).EQ.1) THEN
20295  pt=parp(91)*sqrt(-log(pyr(0)))
20296  ELSE
20297  rpt1=pyr(0)
20298  rpt2=pyr(0)
20299  pt=-parp(92)*log(rpt1*rpt2)
20300  ENDIF
20301  IF(pt.GT.parp(93)) goto 120
20302  ELSEIF(mint(106+jt).EQ.3) THEN
20303  pta=sqrt(vint(282+jt))
20304  ptb=0d0
20305  IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
20306  ptb=parp(99)*sqrt(-log(pyr(0)))
20307  ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
20308  rpt1=pyr(0)
20309  rpt2=pyr(0)
20310  ptb=-parp(99)*log(rpt1*rpt2)
20311  ENDIF
20312  IF(ptb.GT.parp(100)) goto 120
20313  pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
20314  pt=pt*0.8d0**mint(57)
20315  IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
20316  ELSEIF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) THEN
20317  IF(mstp(93).LE.0) THEN
20318  pt=0d0
20319  ELSEIF(mstp(93).EQ.1) THEN
20320  pt=parp(99)*sqrt(-log(pyr(0)))
20321  ELSEIF(mstp(93).EQ.2) THEN
20322  rpt1=pyr(0)
20323  rpt2=pyr(0)
20324  pt=-parp(99)*log(rpt1*rpt2)
20325  ELSEIF(mstp(93).EQ.3) THEN
20326  ha=parp(99)**2
20327  hb=parp(100)**2
20328  pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
20329  ELSE
20330  ha=parp(99)**2
20331  hb=parp(100)**2
20332  IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
20333  pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
20334  ENDIF
20335  IF(pt.GT.parp(100)) goto 120
20336  ELSE
20337  pt=0d0
20338  ENDIF
20339  vint(156+jt)=pt
20340  phi=paru(2)*pyr(0)
20341  p(i,1)=pt*cos(phi)
20342  p(i,2)=pt*sin(phi)
20343  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
20344  ENDIF
20345  130 CONTINUE
20346  IF(mint(47).EQ.1) RETURN
20347 
20348 C...Kinematics construction for initial partons.
20349  i1=mint(83)+3
20350  i2=mint(83)+4
20351  IF(isub.EQ.95) THEN
20352  shs=0d0
20353  shr=0d0
20354  ELSE
20355  shs=vint(141)*vint(142)*vint(2)+(p(i1,1)+p(i2,1))**2+
20356  & (p(i1,2)+p(i2,2))**2
20357  shr=sqrt(max(0d0,shs))
20358  IF((shs-pms(1)-pms(2))**2-4d0*pms(1)*pms(2).LE.0d0) goto 100
20359  p(i1,4)=0.5d0*(shr+(pms(1)-pms(2))/shr)
20360  p(i1,3)=sqrt(max(0d0,p(i1,4)**2-pms(1)))
20361  p(i2,4)=shr-p(i1,4)
20362  p(i2,3)=-p(i1,3)
20363 
20364 C...Transform partons to overall CM-frame.
20365  robo(3)=(p(i1,1)+p(i2,1))/shr
20366  robo(4)=(p(i1,2)+p(i2,2))/shr
20367  CALL pyrobo(i1,i2,0d0,0d0,-robo(3),-robo(4),0d0)
20368  robo(2)=pyangl(p(i1,1),p(i1,2))
20369  CALL pyrobo(i1,i2,0d0,-robo(2),0d0,0d0,0d0)
20370  robo(1)=pyangl(p(i1,3),p(i1,1))
20371  CALL pyrobo(i1,i2,-robo(1),0d0,0d0,0d0,0d0)
20372  CALL pyrobo(i2+1,mint(52),0d0,-robo(2),0d0,0d0,0d0)
20373  CALL pyrobo(i1,mint(52),robo(1),robo(2),robo(3),robo(4),0d0)
20374  robo(5)=(vint(141)-vint(142))/(vint(141)+vint(142))
20375  CALL pyrobo(i1,mint(52),0d0,0d0,0d0,0d0,robo(5))
20376  ENDIF
20377 
20378 C...Optionally fix up x and Q2 definitions for leptoproduction.
20379  idisxq=0
20380  IF((mint(43).EQ.2.OR.mint(43).EQ.3).AND.((isub.EQ.10.AND.
20381  &mstp(23).GE.1).OR.(isub.EQ.83.AND.mstp(23).GE.2))) idisxq=1
20382  IF(idisxq.EQ.1) THEN
20383 
20384 C...Find where incoming and outgoing leptons/partons are sitting.
20385  lesd=1
20386  IF(mint(42).EQ.1) lesd=2
20387  lpin=mint(83)+3-lesd
20388  lein=mint(84)+lesd
20389  lqin=mint(84)+3-lesd
20390  leout=mint(84)+2+lesd
20391  lqout=mint(84)+5-lesd
20392  IF(k(lein,3).GT.lein) lein=k(lein,3)
20393  IF(k(lqin,3).GT.lqin) lqin=k(lqin,3)
20394  lscms=0
20395  DO 140 i=mint(84)+5,n
20396  IF(k(i,2).EQ.94) THEN
20397  lscms=i
20398  leout=i+lesd
20399  lqout=i+3-lesd
20400  ENDIF
20401  140 CONTINUE
20402  lqbg=ipu1
20403  IF(lesd.EQ.1) lqbg=ipu2
20404 
20405 C...Calculate actual and wanted momentum transfer.
20406  xnom=vint(43-lesd)
20407  q2nom=-vint(45)
20408  hpk=2d0*(p(lpin,4)*p(lein,4)-p(lpin,1)*p(lein,1)-
20409  & p(lpin,2)*p(lein,2)-p(lpin,3)*p(lein,3))*
20410  & (p(mint(83)+lesd,4)*vint(40+lesd)/p(lein,4))
20411  hpt2=max(0d0,q2nom*(1d0-q2nom/(xnom*hpk)))
20412  fac=sqrt(hpt2/(p(leout,1)**2+p(leout,2)**2))
20413  p(n+1,1)=fac*p(leout,1)
20414  p(n+1,2)=fac*p(leout,2)
20415  p(n+1,3)=0.25d0*((hpk-q2nom/xnom)/p(lpin,4)-
20416  & q2nom/(p(mint(83)+lesd,4)*vint(40+lesd)))*(-1)**(lesd+1)
20417  p(n+1,4)=sqrt(p(leout,5)**2+p(n+1,1)**2+p(n+1,2)**2+
20418  & p(n+1,3)**2)
20419  DO 150 j=1,4
20420  qold(j)=p(lein,j)-p(leout,j)
20421  qnew(j)=p(lein,j)-p(n+1,j)
20422  150 CONTINUE
20423 
20424 C...Boost outgoing electron and daughters.
20425  IF(lscms.EQ.0) THEN
20426  DO 160 j=1,4
20427  p(leout,j)=p(n+1,j)
20428  160 CONTINUE
20429  ELSE
20430  DO 170 j=1,3
20431  p(n+2,j)=(p(n+1,j)-p(leout,j))/(p(n+1,4)+p(leout,4))
20432  170 CONTINUE
20433  pinv=2d0/(1d0+p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2)
20434  DO 180 j=1,3
20435  dbe(j)=pinv*p(n+2,j)
20436  180 CONTINUE
20437  DO 200 i=lscms+1,n
20438  iorig=i
20439  190 iorig=k(iorig,3)
20440  IF(iorig.GT.leout) goto 190
20441  IF(i.EQ.leout.OR.iorig.EQ.leout)
20442  & CALL pyrobo(i,i,0d0,0d0,dbe(1),dbe(2),dbe(3))
20443  200 CONTINUE
20444  ENDIF
20445 
20446 C...Copy shower initiator and all outgoing partons.
20447  ncop=n+1
20448  k(ncop,3)=lqbg
20449  DO 210 j=1,5
20450  p(ncop,j)=p(lqbg,j)
20451  210 CONTINUE
20452  DO 240 i=mint(84)+1,n
20453  icop=0
20454  IF(k(i,1).GT.10) goto 240
20455  IF(i.EQ.lqbg.OR.i.EQ.lqout) THEN
20456  icop=i
20457  ELSE
20458  iorig=i
20459  220 iorig=k(iorig,3)
20460  IF(iorig.EQ.lqbg.OR.iorig.EQ.lqout) THEN
20461  icop=iorig
20462  ELSEIF(iorig.GT.mint(84).AND.iorig.LE.n) THEN
20463  goto 220
20464  ENDIF
20465  ENDIF
20466  IF(icop.NE.0) THEN
20467  ncop=ncop+1
20468  k(ncop,3)=i
20469  DO 230 j=1,5
20470  p(ncop,j)=p(i,j)
20471  230 CONTINUE
20472  ENDIF
20473  240 CONTINUE
20474 
20475 C...Calculate relative rescaling factors.
20476  slc=3-2*lesd
20477  plcsum=0d0
20478  DO 250 i=n+2,ncop
20479  plcsum=plcsum+(p(i,4)+slc*p(i,3))
20480  250 CONTINUE
20481  DO 260 i=n+2,ncop
20482  v(i,1)=(p(i,4)+slc*p(i,3))/plcsum
20483  260 CONTINUE
20484 
20485 C...Transfer extra three-momentum of current.
20486  DO 280 i=n+2,ncop
20487  DO 270 j=1,3
20488  p(i,j)=p(i,j)+v(i,1)*(qnew(j)-qold(j))
20489  270 CONTINUE
20490  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
20491  280 CONTINUE
20492 
20493 C...Iterate change of initiator momentum to get energy right.
20494  iter=0
20495  290 iter=iter+1
20496  peex=-p(n+1,4)-qnew(4)
20497  pemv=-p(n+1,3)/p(n+1,4)
20498  DO 300 i=n+2,ncop
20499  peex=peex+p(i,4)
20500  pemv=pemv+v(i,1)*p(i,3)/p(i,4)
20501  300 CONTINUE
20502  IF(abs(pemv).LT.1d-10) THEN
20503  mint(51)=1
20504  mint(57)=mint(57)+1
20505  RETURN
20506  ENDIF
20507  pzch=-peex/pemv
20508  p(n+1,3)=p(n+1,3)+pzch
20509  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)
20510  DO 310 i=n+2,ncop
20511  p(i,3)=p(i,3)+v(i,1)*pzch
20512  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
20513  310 CONTINUE
20514  IF(iter.LT.10.AND.abs(peex).GT.1d-6*p(n+1,4)) goto 290
20515 
20516 C...Modify momenta in event record.
20517  hbe=2d0*(p(n+1,4)+p(lqbg,4))*(p(n+1,3)-p(lqbg,3))/
20518  & ((p(n+1,4)+p(lqbg,4))**2+(p(n+1,3)-p(lqbg,3))**2)
20519  IF(abs(hbe).GE.1d0) THEN
20520  mint(51)=1
20521  mint(57)=mint(57)+1
20522  RETURN
20523  ENDIF
20524  i=mint(83)+5-lesd
20525  CALL pyrobo(i,i,0d0,0d0,0d0,0d0,hbe)
20526  DO 330 i=n+1,ncop
20527  icop=k(i,3)
20528  DO 320 j=1,4
20529  p(icop,j)=p(i,j)
20530  320 CONTINUE
20531  330 CONTINUE
20532  ENDIF
20533 
20534 C...Check minimum invariant mass of remnant system(s).
20535  psys(0,4)=p(i1,4)+p(i2,4)+0.5d0*vint(1)*(vint(151)+vint(152))
20536  psys(0,3)=p(i1,3)+p(i2,3)+0.5d0*vint(1)*(vint(151)-vint(152))
20537  pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
20538  pmin(0)=sqrt(pms(0))
20539  DO 340 jt=1,2
20540  psys(jt,4)=0.5d0*vint(1)*vint(142+jt)
20541  psys(jt,3)=psys(jt,4)*(-1)**(jt-1)
20542  pmin(jt)=0d0
20543  IF(mint(44+jt).EQ.1) goto 340
20544  mint(105)=mint(102+jt)
20545  mint(109)=mint(106+jt)
20546  CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))
20547  IF(mint(51).NE.0) THEN
20548  mint(57)=mint(57)+1
20549  RETURN
20550  ENDIF
20551  IF(kflch(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflch(jt))
20552  IF(kflsp(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflsp(jt))
20553  IF(kflch(jt)*kflsp(jt).NE.0) pmin(jt)=pmin(jt)+0.5d0*parp(111)
20554  pmin(jt)=sqrt(pmin(jt)**2+p(mint(83)+jt+2,1)**2+
20555  & p(mint(83)+jt+2,2)**2)
20556  340 CONTINUE
20557  IF(pmin(0)+pmin(1)+pmin(2).GT.vint(1).OR.(mint(45).GE.2.AND.
20558  &pmin(1).GT.psys(1,4)).OR.(mint(46).GE.2.AND.pmin(2).GT.
20559  &psys(2,4))) THEN
20560  mint(51)=1
20561  mint(57)=mint(57)+1
20562  RETURN
20563  ENDIF
20564 
20565 C...Loop over two remnants; skip if none there.
20566  i=ns
20567  DO 410 jt=1,2
20568  isn(jt)=0
20569  IF(mint(44+jt).EQ.1) goto 410
20570  IF(jt.EQ.1) ipu=ipu1
20571  IF(jt.EQ.2) ipu=ipu2
20572 
20573 C...Store first remnant parton.
20574  i=i+1
20575  is(jt)=i
20576  isn(jt)=1
20577  DO 350 j=1,5
20578  k(i,j)=0
20579  p(i,j)=0d0
20580  v(i,j)=0d0
20581  350 CONTINUE
20582  k(i,1)=1
20583  k(i,2)=kflsp(jt)
20584  k(i,3)=mint(83)+jt
20585  p(i,5)=pymass(k(i,2))
20586 
20587 C...First parton colour connections and kinematics.
20588  kcol=kchg(pycomp(kflsp(jt)),2)
20589  IF(kcol.EQ.2) THEN
20590  k(i,1)=3
20591  k(i,4)=mstu(5)*ipu+ipu
20592  k(i,5)=mstu(5)*ipu+ipu
20593  k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
20594  k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
20595  ELSEIF(kcol.NE.0) THEN
20596  k(i,1)=3
20597  kfls=(3-kcol*isign(1,kflsp(jt)))/2
20598  k(i,kfls+3)=ipu
20599  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
20600  ENDIF
20601  IF(kflch(jt).EQ.0) THEN
20602  p(i,1)=-p(mint(83)+jt+2,1)
20603  p(i,2)=-p(mint(83)+jt+2,2)
20604  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
20605  psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
20606  p(i,3)=psys(jt,3)
20607  p(i,4)=psys(jt,4)
20608 
20609 C...When extra remnant parton or hadron: store extra remnant.
20610  ELSE
20611  i=i+1
20612  isn(jt)=2
20613  DO 360 j=1,5
20614  k(i,j)=0
20615  p(i,j)=0d0
20616  v(i,j)=0d0
20617  360 CONTINUE
20618  k(i,1)=1
20619  k(i,2)=kflch(jt)
20620  k(i,3)=mint(83)+jt
20621  p(i,5)=pymass(k(i,2))
20622 
20623 C...Find parton colour connections of extra remnant.
20624  kcol=kchg(pycomp(kflch(jt)),2)
20625  IF(kcol.EQ.2) THEN
20626  k(i,1)=3
20627  k(i,4)=mstu(5)*ipu+ipu
20628  k(i,5)=mstu(5)*ipu+ipu
20629  k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
20630  k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
20631  ELSEIF(kcol.NE.0) THEN
20632  k(i,1)=3
20633  kfls=(3-kcol*isign(1,kflch(jt)))/2
20634  k(i,kfls+3)=ipu
20635  k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
20636  ENDIF
20637 
20638 C...Relative transverse momentum when two remnants.
20639  loop=0
20640  370 loop=loop+1
20641  CALL pyptdi(1,p(i-1,1),p(i-1,2))
20642  IF(iabs(mint(10+jt)).LT.20) THEN
20643  p(i-1,1)=0d0
20644  p(i-1,2)=0d0
20645  ELSE
20646  p(i-1,1)=p(i-1,1)-0.5d0*p(mint(83)+jt+2,1)
20647  p(i-1,2)=p(i-1,2)-0.5d0*p(mint(83)+jt+2,2)
20648  ENDIF
20649  pms(jt+2)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
20650  p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1)
20651  p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2)
20652  pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
20653 
20654 C...Meson or baryon; photon as meson. For splitup below.
20655  imb=1
20656  IF(mod(mint(10+jt)/1000,10).NE.0) imb=2
20657 
20658 C***Relative distribution for electron into two electrons. Temporary!
20659  IF(iabs(mint(10+jt)).LT.20.AND.mint(14+jt).EQ.-mint(10+jt))
20660  & THEN
20661  chi(jt)=pyr(0)
20662 
20663 C...Relative distribution of electron energy into electron plus parton.
20664  ELSEIF(iabs(mint(10+jt)).LT.20) THEN
20665  xhrd=vint(140+jt)
20666  xe=vint(154+jt)
20667  chi(jt)=(xe-xhrd)/(1d0-xhrd)
20668 
20669 C...Relative distribution of energy for particle into two jets.
20670  ELSEIF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN
20671  chik=parp(92+2*imb)
20672  IF(mstp(92).LE.1) THEN
20673  IF(imb.EQ.1) chi(jt)=pyr(0)
20674  IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
20675  ELSEIF(mstp(92).EQ.2) THEN
20676  chi(jt)=1d0-pyr(0)**(1d0/(1d0+chik))
20677  ELSEIF(mstp(92).EQ.3) THEN
20678  cut=2d0*0.3d0/vint(1)
20679  380 chi(jt)=pyr(0)**2
20680  IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25d0*
20681  & (1d0-chi(jt))**chik.LT.pyr(0)) goto 380
20682  ELSEIF(mstp(92).EQ.4) THEN
20683  cut=2d0*0.3d0/vint(1)
20684  cutr=(1d0+sqrt(1d0+cut**2))/cut
20685  390 chir=cut*cutr**pyr(0)
20686  chi(jt)=(chir**2-cut**2)/(2d0*chir)
20687  IF((1d0-chi(jt))**chik.LT.pyr(0)) goto 390
20688  ELSE
20689  cut=2d0*0.3d0/vint(1)
20690  cuta=cut**(1d0-parp(98))
20691  cutb=(1d0+cut)**(1d0-parp(98))
20692  400 chi(jt)=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
20693  IF(((chi(jt)+cut)**2/(2d0*(chi(jt)**2+cut**2)))**
20694  & (0.5d0*parp(98))*(1d0-chi(jt))**chik.LT.pyr(0)) goto 400
20695  ENDIF
20696 
20697 C...Relative distribution of energy for particle into jet plus particle.
20698  ELSE
20699  IF(mstp(94).LE.1) THEN
20700  IF(imb.EQ.1) chi(jt)=pyr(0)
20701  IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
20702  IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
20703  ELSEIF(mstp(94).EQ.2) THEN
20704  chi(jt)=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
20705  IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
20706  ELSEIF(mstp(94).EQ.3) THEN
20707  CALL pyzdis(1,0,pms(jt+4),zz)
20708  chi(jt)=zz
20709  ELSE
20710  CALL pyzdis(1000,0,pms(jt+4),zz)
20711  chi(jt)=zz
20712  ENDIF
20713  ENDIF
20714 
20715 C...Construct total transverse mass; reject if too large.
20716  chi(jt)=max(1d-8,min(1d0-1d-8,chi(jt)))
20717  pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1d0-chi(jt))
20718  IF(pms(jt).GT.psys(jt,4)**2) THEN
20719  IF(loop.LT.100) THEN
20720  goto 370
20721  ELSE
20722  mint(51)=1
20723  mint(57)=mint(57)+1
20724  RETURN
20725  ENDIF
20726  ENDIF
20727  psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
20728  vint(158+jt)=chi(jt)
20729 
20730 C...Subdivide longitudinal momentum according to value selected above.
20731  pw1=chi(jt)*(psys(jt,4)+abs(psys(jt,3)))
20732  p(is(jt)+1,4)=0.5d0*(pw1+pms(jt+4)/pw1)
20733  p(is(jt)+1,3)=0.5d0*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)
20734  p(is(jt),4)=psys(jt,4)-p(is(jt)+1,4)
20735  p(is(jt),3)=psys(jt,3)-p(is(jt)+1,3)
20736  ENDIF
20737  410 CONTINUE
20738  n=i
20739 
20740 C...Check if longitudinal boosts needed - if so pick two systems.
20741  pdev=abs(psys(0,4)+psys(1,4)+psys(2,4)-vint(1))+
20742  &abs(psys(0,3)+psys(1,3)+psys(2,3))
20743  IF(pdev.LE.1d-6*vint(1)) RETURN
20744  IF(isn(1).EQ.0) THEN
20745  ir=0
20746  il=2
20747  ELSEIF(isn(2).EQ.0) THEN
20748  ir=1
20749  il=0
20750  ELSEIF(vint(143).GT.0.2d0.AND.vint(144).GT.0.2d0) THEN
20751  ir=1
20752  il=2
20753  ELSEIF(vint(143).GT.0.2d0) THEN
20754  ir=1
20755  il=0
20756  ELSEIF(vint(144).GT.0.2d0) THEN
20757  ir=0
20758  il=2
20759  ELSEIF(pms(1)/psys(1,4)**2.GT.pms(2)/psys(2,4)**2) THEN
20760  ir=1
20761  il=0
20762  ELSE
20763  ir=0
20764  il=2
20765  ENDIF
20766  ig=3-ir-il
20767 
20768 C...E+-pL wanted for system to be modified.
20769  IF((ig.EQ.1.AND.isn(1).EQ.0).OR.(ig.EQ.2.AND.isn(2).EQ.0)) THEN
20770  ppb=vint(1)
20771  pnb=vint(1)
20772  ELSE
20773  ppb=vint(1)-(psys(ig,4)+psys(ig,3))
20774  pnb=vint(1)-(psys(ig,4)-psys(ig,3))
20775  ENDIF
20776 
20777 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20778  IF(idisxq.EQ.1.AND.ig.NE.0) THEN
20779  ppb=ppb-(psys(0,4)+psys(0,3))
20780  pnb=pnb-(psys(0,4)-psys(0,3))
20781  DO 420 j=1,4
20782  psys(0,j)=0d0
20783  420 CONTINUE
20784  DO 450 i=mint(84)+1,ns
20785  IF(k(i,1).GT.10) goto 450
20786  incl=0
20787  iorig=i
20788  430 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20789  iorig=k(iorig,3)
20790  IF(iorig.GT.lpin) goto 430
20791  IF(incl.EQ.0) goto 450
20792  DO 440 j=1,4
20793  psys(0,j)=psys(0,j)+p(i,j)
20794  440 CONTINUE
20795  450 CONTINUE
20796  pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
20797  ppb=ppb+(psys(0,4)+psys(0,3))
20798  pnb=pnb+(psys(0,4)-psys(0,3))
20799  ENDIF
20800 
20801 C...Construct longitudinal boosts.
20802  dpmtb=ppb*pnb
20803  dpmtr=pms(ir)
20804  dpmtl=pms(il)
20805  dsqlam=sqrt(max(0d0,(dpmtb-dpmtr-dpmtl)**2-4d0*dpmtr*dpmtl))
20806  IF(dsqlam.LE.1d-6*dpmtb) THEN
20807  mint(51)=1
20808  mint(57)=mint(57)+1
20809  RETURN
20810  ENDIF
20811  dsqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))
20812  drkr=(dpmtb+dpmtr-dpmtl+dsqlam*dsqsgn)/
20813  &(2d0*(psys(ir,4)+psys(ir,3))*pnb)
20814  drkl=(dpmtb+dpmtl-dpmtr+dsqlam*dsqsgn)/
20815  &(2d0*(psys(il,4)-psys(il,3))*ppb)
20816  dber=(drkr**2-1d0)/(drkr**2+1d0)
20817  dbel=-(drkl**2-1d0)/(drkl**2+1d0)
20818 
20819 C...Perform longitudinal boosts.
20820  IF(ir.EQ.1.AND.isn(1).EQ.1.AND.dber.LE.-0.99999999d0) THEN
20821  p(is(1),3)=0d0
20822  p(is(1),4)=sqrt(p(is(1),5)**2+p(is(1),1)**2+p(is(1),2)**2)
20823  ELSEIF(ir.EQ.1) THEN
20824  CALL pyrobo(is(1),is(1)+isn(1)-1,0d0,0d0,0d0,0d0,dber)
20825  ELSEIF(idisxq.EQ.1) THEN
20826  DO 470 i=i1,ns
20827  incl=0
20828  iorig=i
20829  460 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20830  iorig=k(iorig,3)
20831  IF(iorig.GT.lpin) goto 460
20832  IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dber)
20833  470 CONTINUE
20834  ELSE
20835  CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dber)
20836  ENDIF
20837  IF(il.EQ.2.AND.isn(2).EQ.1.AND.dbel.GE.0.99999999d0) THEN
20838  p(is(2),3)=0d0
20839  p(is(2),4)=sqrt(p(is(2),5)**2+p(is(2),1)**2+p(is(2),2)**2)
20840  ELSEIF(il.EQ.2) THEN
20841  CALL pyrobo(is(2),is(2)+isn(2)-1,0d0,0d0,0d0,0d0,dbel)
20842  ELSEIF(idisxq.EQ.1) THEN
20843  DO 490 i=i1,ns
20844  incl=0
20845  iorig=i
20846  480 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20847  iorig=k(iorig,3)
20848  IF(iorig.GT.lpin) goto 480
20849  IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dbel)
20850  490 CONTINUE
20851  ELSE
20852  CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dbel)
20853  ENDIF
20854 
20855 C...Final check that energy-momentum conservation worked.
20856  pesum=0d0
20857  pzsum=0d0
20858  DO 500 i=mint(84)+1,n
20859  IF(k(i,1).GT.10) goto 500
20860  pesum=pesum+p(i,4)
20861  pzsum=pzsum+p(i,3)
20862  500 CONTINUE
20863  pdev=abs(pesum-vint(1))+abs(pzsum)
20864  IF(pdev.GT.1d-4*vint(1)) THEN
20865  mint(51)=1
20866  mint(57)=mint(57)+1
20867  RETURN
20868  ENDIF
20869 
20870 C...Calculate rotation and boost from overall CM frame to
20871 C...hadronic CM frame in leptoproduction.
20872  mint(91)=0
20873  IF(mint(82).EQ.1.AND.(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
20874  mint(91)=1
20875  lesd=1
20876  IF(mint(42).EQ.1) lesd=2
20877  lpin=mint(83)+3-lesd
20878 
20879 C...Sum upp momenta of everything not lepton or photon to define boost.
20880  DO 510 j=1,4
20881  psum(j)=0d0
20882  510 CONTINUE
20883  DO 530 i=1,n
20884  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 530
20885  IF(iabs(k(i,2)).GE.11.AND.iabs(k(i,2)).LE.20) goto 530
20886  IF(k(i,2).EQ.22) goto 530
20887  DO 520 j=1,4
20888  psum(j)=psum(j)+p(i,j)
20889  520 CONTINUE
20890  530 CONTINUE
20891  vint(223)=-psum(1)/psum(4)
20892  vint(224)=-psum(2)/psum(4)
20893  vint(225)=-psum(3)/psum(4)
20894 
20895 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20896  k(n+1,1)=1
20897  DO 540 j=1,5
20898  p(n+1,j)=p(lpin,j)
20899  v(n+1,j)=v(lpin,j)
20900  540 CONTINUE
20901  CALL pyrobo(n+1,n+1,0d0,0d0,vint(223),vint(224),vint(225))
20902  vint(222)=-pyangl(p(n+1,1),p(n+1,2))
20903  CALL pyrobo(n+1,n+1,0d0,vint(222),0d0,0d0,0d0)
20904  IF(lesd.EQ.2) THEN
20905  vint(221)=-pyangl(p(n+1,3),p(n+1,1))
20906  ELSE
20907  vint(221)=pyangl(-p(n+1,3),p(n+1,1))
20908  ENDIF
20909  ENDIF
20910 
20911  RETURN
20912  END
20913 
20914 C*********************************************************************
20915 
20916 C...PYMIGN
20917 C...Initializes treatment of new multiple interactions scenario,
20918 C...selects kinematics of hardest interaction if low-pT physics
20919 C...included in run, and generates all non-hardest interactions.
20920 
20921  SUBROUTINE pymign(MMUL)
20922 
20923 C...Double precision and integer declarations.
20924  IMPLICIT DOUBLE PRECISION(a-h, o-z)
20925  IMPLICIT INTEGER(i-n)
20926  INTEGER pyk,pychge,pycomp
20927  EXTERNAL pyalps
20928  DOUBLE PRECISION pyalps
20929 C...Commonblocks.
20930  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
20931  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
20932  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
20933  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
20934  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
20935  common/pypars/mstp(200),parp(200),msti(200),pari(200)
20936  common/pyint1/mint(400),vint(400)
20937  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
20938  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
20939  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
20940  common/pyint7/sigt(0:6,0:6,0:5)
20941  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
20942  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
20943  & xmi(2,240),pt2mi(240),imisep(0:240)
20944  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
20945  &/pyint1/,/pyint2/,/pyint3/,/pyint5/,/pyint7/,/pyintm/
20946 C...Local arrays and saved variables.
20947  dimension nmul(20),sigm(20),kstr(500,2),vintsv(80),
20948  &wdtp(0:400),wdte(0:400,0:5),xpq(-25:25),ksav(4,5),psav(4,5)
20949  SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm,p83a,p83b,p83c,
20950  &cq2i,cq2r,pik,bdiv,b,plowb,phighb,pallb,s4a,s4b,s4c,powip,
20951  &rpwip,b2rpdv,b2rpmx,bavg,vnt145,vnt146,vnt147
20952 
20953 C...Initialization of multiple interaction treatment.
20954  IF(mmul.EQ.1) THEN
20955  IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
20956  isub=96
20957  mint(1)=96
20958  vint(63)=0d0
20959  vint(64)=0d0
20960  vint(143)=1d0
20961  vint(144)=1d0
20962 
20963 C...Loop over phase space points: xT2 choice in 20 bins.
20964  100 sigsum=0d0
20965  DO 120 ixt2=1,20
20966  nmul(ixt2)=mstp(83)
20967  sigm(ixt2)=0d0
20968  DO 110 itry=1,mstp(83)
20969  rsca=0.05d0*((21-ixt2)-pyr(0))
20970  xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
20971  xt2=max(0.01d0*vint(149),xt2)
20972  vint(25)=xt2
20973 
20974 C...Choose tau and y*. Calculate cos(theta-hat).
20975  IF(pyr(0).LE.coef(isub,1)) THEN
20976  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20977  tau=xt2*(1d0+taut)**2/(4d0*taut)
20978  ELSE
20979  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20980  ENDIF
20981  vint(21)=tau
20982  CALL pyklim(2)
20983  ryst=pyr(0)
20984  myst=1
20985  IF(ryst.GT.coef(isub,8)) myst=2
20986  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20987  CALL pykmap(2,myst,pyr(0))
20988  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20989 
20990 C...Calculate differential cross-section.
20991  vint(71)=0.5d0*vint(1)*sqrt(xt2)
20992  CALL pysigh(nchn,sigs)
20993  sigm(ixt2)=sigm(ixt2)+sigs
20994  110 CONTINUE
20995  sigsum=sigsum+sigm(ixt2)
20996  120 CONTINUE
20997  sigsum=sigsum/(20d0*mstp(83))
20998 
20999 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
21000  IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
21001  IF(mstp(122).GE.1) WRITE(mstu(11),5100)
21002  & parp(82)*(vint(1)/parp(89))**parp(90),sigsum
21003  parp(82)=0.9d0*parp(82)
21004  vint(149)=4d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
21005  & vint(2)
21006  goto 100
21007  ENDIF
21008  IF(mstp(122).GE.1) WRITE(mstu(11),5200)
21009  & parp(82)*(vint(1)/parp(89))**parp(90), sigsum
21010 
21011 C...Start iteration to find k factor.
21012  yke=sigsum/max(1d-10,sigt(0,0,5))
21013  p83a=(1d0-parp(83))**2
21014  p83b=2d0*parp(83)*(1d0-parp(83))
21015  p83c=parp(83)**2
21016  cq2i=1d0/parp(84)**2
21017  cq2r=2d0/(1d0+parp(84)**2)
21018  so=0.5d0
21019  xi=0d0
21020  yi=0d0
21021  xf=0d0
21022  yf=0d0
21023  xk=0.5d0
21024  iit=0
21025  130 IF(iit.EQ.0) THEN
21026  xk=2d0*xk
21027  ELSEIF(iit.EQ.1) THEN
21028  xk=0.5d0*xk
21029  ELSE
21030  xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
21031  ENDIF
21032 
21033 C...Evaluate overlap integrals. Find where to divide the b range.
21034  IF(mstp(82).EQ.2) THEN
21035  sp=0.5d0*paru(1)*(1d0-exp(-xk))
21036  sop=sp/paru(1)
21037  ELSE
21038  IF(mstp(82).EQ.3) THEN
21039  deltab=0.02d0
21040  ELSEIF(mstp(82).EQ.4) THEN
21041  deltab=min(0.01d0,0.05d0*parp(84))
21042  ELSE
21043  powip=max(0.4d0,parp(83))
21044  rpwip=2d0/powip-1d0
21045  deltab=max(0.02d0,0.02d0*(2d0/powip)**(1d0/powip))
21046  so=0d0
21047  ENDIF
21048  sp=0d0
21049  sop=0d0
21050  bsp=0d0
21051  sohigh=0d0
21052  ibdiv=0
21053  b=-0.5d0*deltab
21054  140 b=b+deltab
21055  IF(mstp(82).EQ.3) THEN
21056  ov=exp(-b**2)/paru(2)
21057  ELSEIF(mstp(82).EQ.4) THEN
21058  ov=(p83a*exp(-min(50d0,b**2))+
21059  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
21060  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
21061  ELSE
21062  ov=exp(-b**powip)/paru(2)
21063  so=so+paru(2)*b*deltab*ov
21064  ENDIF
21065  IF(ibdiv.EQ.1) sohigh=sohigh+paru(2)*b*deltab*ov
21066  pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
21067  sp=sp+paru(2)*b*deltab*pacc
21068  sop=sop+paru(2)*b*deltab*ov*pacc
21069  bsp=bsp+b*paru(2)*b*deltab*pacc
21070  IF(ibdiv.EQ.0.AND.paru(1)*xk*ov.LT.1d0) THEN
21071  ibdiv=1
21072  bdiv=b+0.5d0*deltab
21073  ENDIF
21074  IF(b.LT.1d0.OR.b*pacc.GT.1d-6) goto 140
21075  ENDIF
21076  yk=paru(1)*xk*so/sp
21077 
21078 C...Continue iteration until convergence.
21079  IF(yk.LT.yke) THEN
21080  xi=xk
21081  yi=yk
21082  IF(iit.EQ.1) iit=2
21083  ELSE
21084  xf=xk
21085  yf=yk
21086  IF(iit.EQ.0) iit=1
21087  ENDIF
21088  IF(abs(yk-yke).GE.1d-5*yke) goto 130
21089 
21090 C...Store some results for subsequent use.
21091  bavg=bsp/sp
21092  vint(145)=sigsum
21093  vint(146)=sop/so
21094  vint(147)=sop/sp
21095  vnt145=vint(145)
21096  vnt146=vint(146)
21097  vnt147=vint(147)
21098 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
21099  pik=(vnt146/vnt147)*yke
21100 
21101 C...Find relative weight for low and high impact parameter..
21102  plowb=paru(1)*bdiv**2
21103  IF(mstp(82).EQ.3) THEN
21104  phighb=pik*0.5*exp(-bdiv**2)
21105  ELSEIF(mstp(82).EQ.4) THEN
21106  s4a=p83a*exp(-bdiv**2)
21107  s4b=p83b*exp(-bdiv**2*cq2r)
21108  s4c=p83c*exp(-bdiv**2*cq2i)
21109  phighb=pik*0.5*(s4a+s4b+s4c)
21110  ELSEIF(parp(83).GE.1.999d0) THEN
21111  phighb=pik*sohigh
21112  b2rpdv=bdiv**powip
21113  ELSE
21114  phighb=pik*sohigh
21115  b2rpdv=bdiv**powip
21116  b2rpmx=max(2d0*rpwip,b2rpdv)
21117  ENDIF
21118  pallb=plowb+phighb
21119 
21120 C...Initialize iteration in xT2 for hardest interaction.
21121  ELSEIF(mmul.EQ.2) THEN
21122  vint(145)=vnt145
21123  vint(146)=vnt146
21124  vint(147)=vnt147
21125  IF(mstp(82).LE.0) THEN
21126  ELSEIF(mstp(82).EQ.1) THEN
21127  xt2=1d0
21128  sigrat=xsec(96,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
21129  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
21130  & vint(317)/(vint(318)*vint(320))
21131  xt2fac=sigrat*vint(149)/(1d0-vint(149))
21132  ELSEIF(mstp(82).EQ.2) THEN
21133  xt2=1d0
21134  xt2fac=vnt146*xsec(96,1)/max(1d-10,sigt(0,0,5))*
21135  & vint(149)*(1d0+vint(149))
21136  ELSE
21137  xc2=4d0*ckin(3)**2/vint(2)
21138  IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
21139  ENDIF
21140 
21141 C...Select impact parameter for hardest interaction.
21142  IF(mstp(82).LE.2) RETURN
21143  142 IF(pyr(0)*pallb.LT.plowb) THEN
21144 C...Treatment in low b region.
21145  mint(39)=1
21146  b=bdiv*sqrt(pyr(0))
21147  IF(mstp(82).EQ.3) THEN
21148  ov=exp(-b**2)/paru(2)
21149  ELSEIF(mstp(82).EQ.4) THEN
21150  ov=(p83a*exp(-min(50d0,b**2))+
21151  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
21152  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
21153  ELSE
21154  ov=exp(-b**powip)/paru(2)
21155  ENDIF
21156  vint(148)=ov/vnt147
21157  pacc=1d0-exp(-min(50d0,pik*ov))
21158  xt2=1d0
21159  xt2fac=vnt146*vint(148)*xsec(96,1)/max(1d-10,sigt(0,0,5))*
21160  & vint(149)*(1d0+vint(149))
21161  ELSE
21162 C...Treatment in high b region.
21163  mint(39)=2
21164  IF(mstp(82).EQ.3) THEN
21165  b=sqrt(bdiv**2-log(pyr(0)))
21166  ov=exp(-b**2)/paru(2)
21167  ELSEIF(mstp(82).EQ.4) THEN
21168  s4rndm=pyr(0)*(s4a+s4b+s4c)
21169  IF(s4rndm.LT.s4a) THEN
21170  b=sqrt(bdiv**2-log(pyr(0)))
21171  ELSEIF(s4rndm.LT.s4a+s4b) THEN
21172  b=sqrt(bdiv**2-log(pyr(0))/cq2r)
21173  ELSE
21174  b=sqrt(bdiv**2-log(pyr(0))/cq2i)
21175  ENDIF
21176  ov=(p83a*exp(-min(50d0,b**2))+
21177  & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
21178  & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
21179  ELSEIF(parp(83).GE.1.999d0) THEN
21180  144 b2rpw=b2rpdv-log(pyr(0))
21181  accip=(b2rpw/b2rpdv)**rpwip
21182  IF(accip.LT.pyr(0)) goto 144
21183  ov=exp(-b2rpw)/paru(2)
21184  b=b2rpw**(1d0/powip)
21185  ELSE
21186  146 b2rpw=b2rpdv-2d0*log(pyr(0))
21187  accip=(b2rpw/b2rpmx)**rpwip*exp(-0.5d0*(b2rpw-b2rpmx))
21188  IF(accip.LT.pyr(0)) goto 146
21189  ov=exp(-b2rpw)/paru(2)
21190  b=b2rpw**(1d0/powip)
21191  ENDIF
21192  vint(148)=ov/vnt147
21193  pacc=(1d0-exp(-min(50d0,pik*ov)))/(pik*ov)
21194  ENDIF
21195  IF(pacc.LT.pyr(0)) goto 142
21196  vint(139)=b/bavg
21197 
21198  ELSEIF(mmul.EQ.3) THEN
21199 C...Low-pT or multiple interactions (first semihard interaction):
21200 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
21201 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
21202  isub=mint(1)
21203  vint(145)=vnt145
21204  vint(146)=vnt146
21205  vint(147)=vnt147
21206  IF(mstp(82).LE.0) THEN
21207  xt2=0d0
21208  ELSEIF(mstp(82).EQ.1) THEN
21209  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
21210 C...Use with "Sudakov" for low b values when impact parameter dependence.
21211  ELSEIF(mstp(82).EQ.2.OR.mint(39).EQ.1) THEN
21212  IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
21213  & vint(149)))).GT.pyr(0)) xt2=1d0
21214  IF(xt2.GE.1d0) THEN
21215  xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
21216  & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
21217  & vint(149)
21218  ELSE
21219  xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
21220  & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
21221  & vint(149)
21222  ENDIF
21223  xt2=max(0.01d0*vint(149),xt2)
21224 C...Use without "Sudakov" for high b values when impact parameter dep.
21225  ELSE
21226  xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
21227  & pyr(0)*(1d0-xc2))-vint(149)
21228  xt2=max(0.01d0*vint(149),xt2)
21229  ENDIF
21230  vint(25)=xt2
21231 
21232 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
21233  IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
21234  IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-mint(143)
21235  IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-mint(143)
21236  isub=95
21237  mint(1)=isub
21238  vint(21)=1d-12*vint(149)
21239  vint(22)=0d0
21240  vint(23)=0d0
21241  vint(25)=1d-12*vint(149)
21242 
21243  ELSE
21244 C...Multiple interactions (first semihard interaction).
21245 C...Choose tau and y*. Calculate cos(theta-hat).
21246  IF(pyr(0).LE.coef(isub,1)) THEN
21247  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
21248  tau=xt2*(1d0+taut)**2/(4d0*taut)
21249  ELSE
21250  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
21251  ENDIF
21252  vint(21)=tau
21253  CALL pyklim(2)
21254  ryst=pyr(0)
21255  myst=1
21256  IF(ryst.GT.coef(isub,8)) myst=2
21257  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
21258  CALL pykmap(2,myst,pyr(0))
21259  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
21260  ENDIF
21261  vint(71)=0.5d0*vint(1)*sqrt(vint(25))
21262 
21263 C...Store results of cross-section calculation.
21264  ELSEIF(mmul.EQ.4) THEN
21265  isub=mint(1)
21266  vint(145)=vnt145
21267  vint(146)=vnt146
21268  vint(147)=vnt147
21269  xts=vint(25)
21270  IF(iset(isub).EQ.1) xts=vint(21)
21271  IF(iset(isub).EQ.2)
21272  & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
21273  IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
21274  rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
21275  & (xts+vint(149))))
21276  irbin=int(1d0+20d0*rbin)
21277  IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
21278  nmul(irbin)=nmul(irbin)+1
21279  sigm(irbin)=sigm(irbin)+vint(153)
21280  ENDIF
21281 
21282 C...Choose impact parameter if not already done.
21283  ELSEIF(mmul.EQ.5) THEN
21284  isub=mint(1)
21285  vint(145)=vnt145
21286  vint(146)=vnt146
21287  vint(147)=vnt147
21288  150 IF(mint(39).GT.0) THEN
21289  ELSEIF(mstp(82).EQ.3) THEN
21290  expb2=pyr(0)
21291  b2=-log(pyr(0))
21292  vint(148)=expb2/(paru(2)*vnt147)
21293  vint(139)=sqrt(b2)/bavg
21294  ELSEIF(mstp(82).EQ.4) THEN
21295  rtype=pyr(0)
21296  IF(rtype.LT.p83a) THEN
21297  b2=-log(pyr(0))
21298  ELSEIF(rtype.LT.p83a+p83b) THEN
21299  b2=-log(pyr(0))/cq2r
21300  ELSE
21301  b2=-log(pyr(0))/cq2i
21302  ENDIF
21303  vint(148)=(p83a*exp(-min(50d0,b2))+
21304  & p83b*cq2r*exp(-min(50d0,b2*cq2r))+
21305  & p83c*cq2i*exp(-min(50d0,b2*cq2i)))/(paru(2)*vnt147)
21306  vint(139)=sqrt(b2)/bavg
21307  ELSEIF(parp(83).GE.1.999d0) THEN
21308  powip=max(2d0,parp(83))
21309  rpwip=2d0/powip-1d0
21310  prob1=powip/(2d0*exp(-1d0)+powip)
21311  160 IF(pyr(0).LT.prob1) THEN
21312  b2rpw=pyr(0)**(0.5d0*powip)
21313  accip=exp(-b2rpw)
21314  ELSE
21315  b2rpw=1d0-log(pyr(0))
21316  accip=b2rpw**rpwip
21317  ENDIF
21318  IF(accip.LT.pyr(0)) goto 160
21319  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
21320  vint(139)=b2rpw**(1d0/powip)/bavg
21321  ELSE
21322  powip=max(0.4d0,parp(83))
21323  rpwip=2d0/powip-1d0
21324  prob1=rpwip/(rpwip+2d0**rpwip*exp(-rpwip))
21325  170 IF(pyr(0).LT.prob1) THEN
21326  b2rpw=2d0*rpwip*pyr(0)
21327  accip=(b2rpw/rpwip)**rpwip*exp(rpwip-b2rpw)
21328  ELSE
21329  b2rpw=2d0*(rpwip-log(pyr(0)))
21330  accip=(0.5d0*b2rpw/rpwip)**rpwip*exp(rpwip-0.5d0*b2rpw)
21331  ENDIF
21332  IF(accip.lt .pyr(0)) goto 170
21333  vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
21334  vint(139)=b2rpw**(1d0/powip)/bavg
21335  ENDIF
21336 
21337 C...Multiple interactions (variable impact parameter) : reject with
21338 C...probability exp(-overlap*cross-section above pT/normalization).
21339 C...Does not apply to low-b region, where "Sudakov" already included.
21340  vint(150)=1d0
21341  IF(mint(39).NE.1) THEN
21342  rncor=(irbin-20d0*rbin)*nmul(irbin)
21343  sigcor=(irbin-20d0*rbin)*sigm(irbin)
21344  DO 180 ibin=irbin+1,20
21345  rncor=rncor+nmul(ibin)
21346  sigcor=sigcor+sigm(ibin)
21347  180 CONTINUE
21348  sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
21349  IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
21350  vint(150)=exp(-min(50d0,vnt146*vint(148)*
21351  & sigabv/max(1d-10,sigt(0,0,5))))
21352  ENDIF
21353  IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isub.NE.11.AND.
21354  & isub.NE.12.AND.isub.NE.13.AND.isub.NE.28.AND.isub.NE.53
21355  & .AND.isub.NE.68.AND.isub.NE.95.AND.isub.NE.96)) THEN
21356  IF(vint(150).LT.pyr(0)) goto 150
21357  vint(150)=1d0
21358  ENDIF
21359 
21360 C...Generate additional multiple semihard interactions.
21361  ELSEIF(mmul.EQ.6) THEN
21362 
21363 C...Save data for hardest initeraction, to be restored.
21364  isubsv=mint(1)
21365  vint(145)=vnt145
21366  vint(146)=vnt146
21367  vint(147)=vnt147
21368  m13sv=mint(13)
21369  m14sv=mint(14)
21370  m15sv=mint(15)
21371  m16sv=mint(16)
21372  m21sv=mint(21)
21373  m22sv=mint(22)
21374  DO 190 j=11,80
21375  vintsv(j)=vint(j)
21376  190 CONTINUE
21377  v141sv=vint(141)
21378  v142sv=vint(142)
21379 
21380 C...Store data on hardest interaction.
21381  xmi(1,1)=vint(141)
21382  xmi(2,1)=vint(142)
21383  pt2mi(1)=vint(54)
21384  imisep(0)=mint(84)
21385  imisep(1)=n
21386 
21387 C...Change process to generate; sum of x values so far.
21388  isub=96
21389  mint(1)=96
21390  vint(143)=1d0-vint(141)
21391  vint(144)=1d0-vint(142)
21392  vint(151)=0d0
21393  vint(152)=0d0
21394 
21395 C...Initialize factors for PDF reshaping.
21396  DO 230 js=1,2
21397  kfbeam=mint(10+js)
21398  kfabm=iabs(kfbeam)
21399  kfsbm=isign(1,kfbeam)
21400 
21401 C...Zero flavour content of incoming beam particle.
21402  kfival(js,1)=0
21403  kfival(js,2)=0
21404  kfival(js,3)=0
21405 C...Flavour content of baryon.
21406  IF(kfabm.GT.1000) THEN
21407  kfival(js,1)=kfsbm*mod(kfabm/1000,10)
21408  kfival(js,2)=kfsbm*mod(kfabm/100,10)
21409  kfival(js,3)=kfsbm*mod(kfabm/10,10)
21410 C...Flavour content of pi+-, K+-.
21411  ELSEIF(kfabm.EQ.211) THEN
21412  kfival(js,1)=kfsbm*2
21413  kfival(js,2)=-kfsbm
21414  ELSEIF(kfabm.EQ.321) THEN
21415  kfival(js,1)=-kfsbm*3
21416  kfival(js,2)=kfsbm*2
21417 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
21418  ENDIF
21419 
21420 C...Zero initial valence and companion content.
21421  DO 200 ifl=-6,6
21422  nvc(js,ifl)=0
21423  200 CONTINUE
21424 
21425 C...Initiate listing of all incoming partons from two sides.
21426  nmi(js)=0
21427  DO 210 i=mint(84)+1,n
21428  IF(k(i,3).EQ.mint(83)+2+js) THEN
21429  imi(js,1,1)=i
21430  imi(js,1,2)=0
21431  ENDIF
21432  210 CONTINUE
21433 
21434 C...Decide whether quarks in hard scattering were valence or sea.
21435  ifl=k(imi(js,1,1),2)
21436  IF (iabs(ifl).GT.6) goto 230
21437 
21438 C...Get PDFs at X and Q2 of the parton shower initiator for the
21439 C...hard scattering.
21440  x=vint(140+js)
21441  IF(mstp(61).GE.1) THEN
21442  q2=parp(62)**2
21443  ELSE
21444  q2=vint(54)
21445  ENDIF
21446 C...Note: XPSVC = x*pdf.
21447  mint(30)=js
21448  CALL pypdfu(kfbeam,x,q2,xpq)
21449  sea=xpsvc(ifl,-1)
21450  val=xpsvc(ifl,0)
21451 
21452 C...Decide (Extra factor x cancels in the division).
21453  rvcs=pyr(0)*(sea+val)
21454  ivnow=1
21455  220 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
21456 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21457  ivnow=0
21458  IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
21459  IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
21460  IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
21461  IF(kfival(js,1).EQ.0) THEN
21462  IF(kfbeam.EQ.111.AND.iabs(ifl).LE.2) ivnow=1
21463  IF(kfbeam.EQ.22.AND.iabs(ifl).LE.5) ivnow=1
21464  IF((kfbeam.EQ.130.OR.kfbeam.EQ.310).AND.
21465  & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
21466  ENDIF
21467  IF(ivnow.EQ.0) goto 220
21468 C...Mark valence.
21469  imi(js,1,2)=0
21470 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21471  IF(kfival(js,1).EQ.0) THEN
21472  IF(kfbeam.EQ.111.OR.kfbeam.EQ.22) THEN
21473  kfival(js,1)=ifl
21474  kfival(js,2)=-ifl
21475  ELSEIF(kfbeam.EQ.130.OR.kfbeam.EQ.310) THEN
21476  kfival(js,1)=ifl
21477  IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
21478  IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
21479  ENDIF
21480  ENDIF
21481 
21482 C...If sea, add opposite sign companion parton. Store X and I.
21483  ELSE
21484  nvc(js,-ifl)=nvc(js,-ifl)+1
21485  xassoc(js,-ifl,nvc(js,-ifl))=x
21486 C...Set pointer to companion
21487  imi(js,1,2)=-nvc(js,-ifl)
21488  ENDIF
21489  230 CONTINUE
21490 
21491 C...Update counter number of multiple interactions.
21492  nmi(1)=1
21493  nmi(2)=1
21494 
21495 C...Set up starting values for iteration in xT2.
21496  IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isubsv.NE.11.AND.
21497  & isubsv.NE.12.AND.isubsv.NE.13.AND.isubsv.NE.28.AND.
21498  & isubsv.NE.53.AND.isubsv.NE.68.AND.isubsv.NE.95.AND.
21499  & isubsv.NE.96)) THEN
21500  xt2=(1d0-vint(141))*(1d0-vint(142))
21501  ELSE
21502  xt2=vint(25)
21503  IF(iset(isubsv).EQ.1) xt2=vint(21)
21504  IF(iset(isubsv).EQ.2)
21505  & xt2=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
21506  IF(iset(isubsv).GE.3.AND.iset(isubsv).LE.5) xt2=vint(26)
21507  ENDIF
21508  IF(mstp(82).LE.1) THEN
21509  sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
21510  IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
21511  & vint(317)/(vint(318)*vint(320))
21512  xt2fac=sigrat*vint(149)/(1d0-vint(149))
21513  ELSE
21514  xt2fac=vnt146*vint(148)*xsec(isub,1)/
21515  & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
21516  ENDIF
21517  vint(63)=0d0
21518  vint(64)=0d0
21519 
21520 C...Iterate downwards in xT2.
21521  240 IF((mint(35).EQ.2.AND.mstp(81).EQ.10).OR.isubsv.EQ.95) THEN
21522  xt2=0d0
21523  goto 440
21524  ELSEIF(mstp(82).LE.1) THEN
21525  xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
21526  IF(xt2.LT.vint(149)) goto 440
21527  ELSE
21528  IF(xt2.LE.0.01001d0*vint(149)) goto 440
21529  xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
21530  & log(pyr(0)))-vint(149)
21531  IF(xt2.LE.0d0) goto 440
21532  xt2=max(0.01d0*vint(149),xt2)
21533  ENDIF
21534  vint(25)=xt2
21535 
21536 C...Choose tau and y*. Calculate cos(theta-hat).
21537  IF(pyr(0).LE.coef(isub,1)) THEN
21538  taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
21539  tau=xt2*(1d0+taut)**2/(4d0*taut)
21540  ELSE
21541  tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
21542  ENDIF
21543  vint(21)=tau
21544 C...New: require shat > 1.
21545  IF(tau*vint(2).LT.1d0) goto 240
21546  CALL pyklim(2)
21547  ryst=pyr(0)
21548  myst=1
21549  IF(ryst.GT.coef(isub,8)) myst=2
21550  IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
21551  CALL pykmap(2,myst,pyr(0))
21552  vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
21553 
21554 C...Check that x not used up. Accept or reject kinematical variables.
21555  x1m=sqrt(tau)*exp(vint(22))
21556  x2m=sqrt(tau)*exp(-vint(22))
21557  IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) goto 240
21558  vint(71)=0.5d0*vint(1)*sqrt(xt2)
21559  CALL pysigh(nchn,sigs)
21560  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
21561  IF(sigs.LT.xsec(isub,1)*pyr(0)) goto 240
21562  IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs/vint(320)
21563 
21564 C...Reset K, P and V vectors.
21565  DO 260 i=n+1,n+4
21566  DO 250 j=1,5
21567  k(i,j)=0
21568  p(i,j)=0d0
21569  v(i,j)=0d0
21570  250 CONTINUE
21571  260 CONTINUE
21572  pt=0.5d0*vint(1)*sqrt(xt2)
21573 
21574 C...Choose flavour of reacting partons (and subprocess).
21575  rsigs=sigs*pyr(0)
21576  DO 270 ichn=1,nchn
21577  kfl1=isig(ichn,1)
21578  kfl2=isig(ichn,2)
21579  iconmi=isig(ichn,3)
21580  rsigs=rsigs-sigh(ichn)
21581  IF(rsigs.LE.0d0) goto 280
21582  270 CONTINUE
21583 
21584 C...Reassign to appropriate process codes.
21585  280 isubmi=iconmi/10
21586  iconmi=mod(iconmi,10)
21587 
21588 C...Choose new quark flavour for annihilation graphs
21589  IF(isubmi.EQ.12.OR.isubmi.EQ.53) THEN
21590  sh=tau*vint(2)
21591  CALL pywidt(21,sh,wdtp,wdte)
21592  290 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
21593  DO 300 i=1,mdcy(21,3)
21594  kflf=kfdp(i+mdcy(21,2)-1,1)
21595  rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
21596  IF(rkfl.LE.0d0) goto 310
21597  300 CONTINUE
21598  310 IF(isubmi.EQ.53.AND.iconmi.LE.2) THEN
21599  IF(kflf.GE.4) goto 290
21600  ELSEIF(isubmi.EQ.53.AND.iconmi.LE.4) THEN
21601  kflf=4
21602  iconmi=iconmi-2
21603  ELSEIF(isubmi.EQ.53) THEN
21604  kflf=5
21605  iconmi=iconmi-4
21606  ENDIF
21607  ENDIF
21608 
21609 C...Final state flavours and colour flow: default values
21610  js=1
21611  kfl3=kfl1
21612  kfl4=kfl2
21613  kcc=20
21614  kcs=isign(1,kfl1)
21615 
21616  IF(isubmi.EQ.11) THEN
21617 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21618  kcc=iconmi
21619  IF(kfl1*kfl2.LT.0) kcc=kcc+2
21620 
21621  ELSEIF(isubmi.EQ.12) THEN
21622 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21623  kfl3=isign(kflf,kfl1)
21624  kfl4=-kfl3
21625  kcc=4
21626 
21627  ELSEIF(isubmi.EQ.13) THEN
21628 C...f + fbar -> g + g; th arbitrary
21629  kfl3=21
21630  kfl4=21
21631  kcc=iconmi+4
21632 
21633  ELSEIF(isubmi.EQ.28) THEN
21634 C...f + g -> f + g; th = (p(f)-p(f))**2
21635  IF(kfl1.EQ.21) js=2
21636  kcc=iconmi+6
21637  IF(kfl1.EQ.21) kcc=kcc+2
21638  IF(kfl1.NE.21) kcs=isign(1,kfl1)
21639  IF(kfl2.NE.21) kcs=isign(1,kfl2)
21640 
21641  ELSEIF(isubmi.EQ.53) THEN
21642 C...g + g -> f + fbar; th arbitrary
21643  kcs=(-1)**int(1.5d0+pyr(0))
21644  kfl3=isign(kflf,kcs)
21645  kfl4=-kfl3
21646  kcc=iconmi+10
21647 
21648  ELSEIF(isubmi.EQ.68) THEN
21649 C...g + g -> g + g; th arbitrary
21650  kcc=iconmi+12
21651  kcs=(-1)**int(1.5d0+pyr(0))
21652  ENDIF
21653 
21654 C...Store flavours of scattering.
21655  mint(13)=kfl1
21656  mint(14)=kfl2
21657  mint(15)=kfl1
21658  mint(16)=kfl2
21659  mint(21)=kfl3
21660  mint(22)=kfl4
21661 
21662 C...Set flavours and mothers of scattering partons.
21663  k(n+1,1)=14
21664  k(n+2,1)=14
21665  k(n+3,1)=3
21666  k(n+4,1)=3
21667  k(n+1,2)=kfl1
21668  k(n+2,2)=kfl2
21669  k(n+3,2)=kfl3
21670  k(n+4,2)=kfl4
21671  k(n+1,3)=mint(83)+1
21672  k(n+2,3)=mint(83)+2
21673  k(n+3,3)=n+1
21674  k(n+4,3)=n+2
21675 
21676 C...Store colour connection indices.
21677  DO 320 j=1,2
21678  jc=j
21679  IF(kcs.EQ.-1) jc=3-j
21680  IF(icol(kcc,1,jc).NE.0) k(n+1,j+3)=n+icol(kcc,1,jc)
21681  IF(icol(kcc,2,jc).NE.0) k(n+2,j+3)=n+icol(kcc,2,jc)
21682  IF(icol(kcc,3,jc).NE.0) k(n+3,j+3)=mstu(5)*(n+icol(kcc,3,jc))
21683  IF(icol(kcc,4,jc).NE.0) k(n+4,j+3)=mstu(5)*(n+icol(kcc,4,jc))
21684  320 CONTINUE
21685 
21686 C...Store incoming and outgoing partons in their CM-frame.
21687  shr=sqrt(tau)*vint(1)
21688  p(n+1,3)=0.5d0*shr
21689  p(n+1,4)=0.5d0*shr
21690  p(n+2,3)=-0.5d0*shr
21691  p(n+2,4)=0.5d0*shr
21692  p(n+3,5)=pymass(k(n+3,2))
21693  p(n+4,5)=pymass(k(n+4,2))
21694  IF(p(n+3,5)+p(n+4,5).GE.shr) goto 240
21695  p(n+3,4)=0.5d0*(shr+(p(n+3,5)**2-p(n+4,5)**2)/shr)
21696  p(n+3,3)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,5)**2))
21697  p(n+4,4)=shr-p(n+3,4)
21698  p(n+4,3)=-p(n+3,3)
21699 
21700 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21701  phi=paru(2)*pyr(0)
21702  CALL pyrobo(n+3,n+4,acos(vint(23)),phi,0d0,0d0,0d0)
21703 
21704 C...Set up default values before showers.
21705  mint(31)=mint(31)+1
21706  ipu1=n+1
21707  ipu2=n+2
21708  ipu3=n+3
21709  ipu4=n+4
21710  vint(141)=vint(41)
21711  vint(142)=vint(42)
21712  n=n+4
21713 
21714 C...Showering of initial state partons (optional).
21715 C...Note: no showering of final state partons here; it comes later.
21716  IF(mstp(84).GE.1.AND.mstp(61).GE.1) THEN
21717  mint(51)=0
21718  alamsv=parj(81)
21719  parj(81)=parp(72)
21720  nsav=n
21721  DO 340 i=1,4
21722  DO 330 j=1,5
21723  ksav(i,j)=k(n-4+i,j)
21724  psav(i,j)=p(n-4+i,j)
21725  330 CONTINUE
21726  340 CONTINUE
21727  CALL pysspa(ipu1,ipu2)
21728  parj(81)=alamsv
21729 C...If shower failed then restore to situation before shower.
21730  IF(mint(51).GE.1) THEN
21731  n=nsav
21732  DO 360 i=1,4
21733  DO 350 j=1,5
21734  k(n-4+i,j)=ksav(i,j)
21735  p(n-4+i,j)=psav(i,j)
21736  350 CONTINUE
21737  360 CONTINUE
21738  ipu1=n-3
21739  ipu2=n-2
21740  vint(141)=vint(41)
21741  vint(142)=vint(42)
21742  ENDIF
21743  ENDIF
21744 
21745 C...Keep track of loose colour ends and information on scattering.
21746  370 imi(1,mint(31),1)=ipu1
21747  imi(2,mint(31),1)=ipu2
21748  imi(1,mint(31),2)=0
21749  imi(2,mint(31),2)=0
21750  xmi(1,mint(31))=vint(141)
21751  xmi(2,mint(31))=vint(142)
21752  pt2mi(mint(31))=vint(54)
21753  imisep(mint(31))=n
21754 
21755 C...Decide whether quarks in last scattering were valence, companion or
21756 C...sea.
21757  DO 430 js=1,2
21758  kfbeam=mint(10+js)
21759  kfsbm=isign(1,mint(10+js))
21760  ifl=k(imi(js,mint(31),1),2)
21761  imi(js,mint(31),2)=0
21762  IF (iabs(ifl).GT.6) goto 430
21763 
21764 C...Get PDFs at X and Q2 of the parton shower initiator for the
21765 C...last scattering. At this point VINT(143:144) do not yet
21766 C...include the scattered x values VINT(141:142).
21767  x=vint(140+js)/vint(142+js)
21768  IF(mstp(84).GE.1.AND.mstp(61).GE.1) THEN
21769  q2=parp(62)**2
21770  ELSE
21771  q2=vint(54)
21772  ENDIF
21773 C...Note: XPSVC = x*pdf.
21774  mint(30)=js
21775  CALL pypdfu(kfbeam,x,q2,xpq)
21776  sea=xpsvc(ifl,-1)
21777  val=xpsvc(ifl,0)
21778  cmp=0d0
21779  DO 380 ivc=1,nvc(js,ifl)
21780  cmp=cmp+xpsvc(ifl,ivc)
21781  380 CONTINUE
21782 
21783 C...Decide (Extra factor x cancels in the dvision).
21784  rvcs=pyr(0)*(sea+val+cmp)
21785  ivnow=1
21786  390 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
21787 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21788  ivnow=0
21789  IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
21790  IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
21791  IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
21792  IF(kfival(js,1).EQ.0) THEN
21793  IF(kfbeam.EQ.111.AND.iabs(ifl).LE.2) ivnow=1
21794  IF(kfbeam.EQ.22.AND.iabs(ifl).LE.5) ivnow=1
21795  IF((kfbeam.EQ.130.OR.kfbeam.EQ.310).AND.
21796  & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
21797  ELSE
21798  DO 400 i1=1,nmi(js)
21799  IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
21800  & ivnow=ivnow-1
21801  400 CONTINUE
21802  ENDIF
21803  IF(ivnow.EQ.0) goto 390
21804 C...Mark valence.
21805  imi(js,mint(31),2)=0
21806 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21807  IF(kfival(js,1).EQ.0) THEN
21808  IF(kfbeam.EQ.111.OR.kfbeam.EQ.22) THEN
21809  kfival(js,1)=ifl
21810  kfival(js,2)=-ifl
21811  ELSEIF(kfbeam.EQ.130.OR.kfbeam.EQ.310) THEN
21812  kfival(js,1)=ifl
21813  IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
21814  IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
21815  ENDIF
21816  ENDIF
21817 
21818  ELSEIF (rvcs.LE.val+sea.OR.nvc(js,ifl).EQ.0) THEN
21819 C...If sea, add opposite sign companion parton. Store X and I.
21820  nvc(js,-ifl)=nvc(js,-ifl)+1
21821  xassoc(js,-ifl,nvc(js,-ifl))=x
21822 C...Set pointer to companion
21823  imi(js,mint(31),2)=-nvc(js,-ifl)
21824  ELSE
21825 C...If companion, decide which one.
21826  cmpsum=val+sea
21827  isel=0
21828  410 isel=isel+1
21829  cmpsum=cmpsum+xpsvc(ifl,isel)
21830  IF (rvcs.GT.cmpsum.AND.isel.LT.nvc(js,ifl)) goto 410
21831 C...Find original sea (anti-)quark:
21832  iassoc=0
21833  DO 420 i1=1,nmi(js)
21834  IF (k(imi(js,i1,1),2).NE.-ifl) goto 420
21835  IF (-imi(js,i1,2).EQ.isel) THEN
21836  imi(js,mint(31),2)=imi(js,i1,1)
21837  imi(js,i1,2)=imi(js,mint(31),1)
21838  ENDIF
21839  420 CONTINUE
21840 C...Change X to what associated companion had, so that the correct
21841 C...amount of momentum can be subtracted from the companion sum below.
21842  x=xassoc(js,ifl,isel)
21843 C...Mark companion read.
21844  xassoc(js,ifl,isel)=0d0
21845  ENDIF
21846  430 CONTINUE
21847 
21848 C...Global statistics.
21849  mint(351)=mint(351)+1
21850  vint(351)=vint(351)+pt
21851  IF (mint(351).EQ.1) vint(356)=pt
21852 
21853 C...Update remaining energy and other counters.
21854  IF(n.GT.mstu(4)-mstu(32)-10) THEN
21855  CALL pyerrm(11,'(PYMIGN:) no more memory left in PYJETS')
21856  mint(51)=1
21857  RETURN
21858  ENDIF
21859  nmi(1)=nmi(1)+1
21860  nmi(2)=nmi(2)+1
21861  vint(151)=vint(151)+vint(41)
21862  vint(152)=vint(152)+vint(42)
21863  vint(143)=vint(143)-vint(141)
21864  vint(144)=vint(144)-vint(142)
21865 
21866 C...Iterate, with more interactions allowed.
21867  IF(mint(31).LT.240) goto 240
21868  440 CONTINUE
21869 
21870 C...Restore saved quantities for hardest interaction.
21871  mint(1)=isubsv
21872  mint(13)=m13sv
21873  mint(14)=m14sv
21874  mint(15)=m15sv
21875  mint(16)=m16sv
21876  mint(21)=m21sv
21877  mint(22)=m22sv
21878  DO 450 j=11,80
21879  vint(j)=vintsv(j)
21880  450 CONTINUE
21881  vint(141)=v141sv
21882  vint(142)=v142sv
21883 
21884  ENDIF
21885 
21886 C...Format statements for printout.
21887  5000 FORMAT(/1x,'****** PYMIGN: initialization of multiple inter',
21888  &'actions for MSTP(82) =',i2,' ******')
21889  5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
21890  &d9.2,' mb: rejected')
21891  5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
21892  &d9.2,' mb: accepted')
21893 
21894  RETURN
21895  END
21896 
21897 C*********************************************************************
21898 
21899 C...PYMIHK
21900 C...Finds left-behind remnant flavour content and hooks up
21901 C...the colour flow between the hard scattering and remnants
21902 
21903  SUBROUTINE pymihk
21904 
21905 C...Double precision and integer declarations.
21906  IMPLICIT DOUBLE PRECISION(a-h, o-z)
21907  IMPLICIT INTEGER(i-n)
21908  INTEGER pyk,pychge,pycomp
21909 C...The event record
21910  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
21911 C...Parameters
21912  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
21913  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
21914  common/pypars/mstp(200),parp(200),msti(200),pari(200)
21915  common/pyint1/mint(400),vint(400)
21916 C...The common block of dangling ends
21917  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
21918  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
21919  & xmi(2,240),pt2mi(240),imisep(0:240)
21920  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyintm/
21921 C...Local variables
21922  parameter(nersiz=4000)
21923  COMMON /pycbls/mco(nersiz,2),ncc,jcco(nersiz,2),jccn(nersiz,2)
21924  & ,maccpt
21925  COMMON /pyctag/nct,mct(nersiz,2)
21926  SAVE /pycbls/,/pyctag/
21927  dimension jst(2,3),iv(2,3),idq(3),nvsum(2),nbrtot(2),ng(2)
21928  & ,itjunc(2),mout(2),insr(1000,3),istr(6),ymi(240)
21929  DATA nerrpr/0/
21930  SAVE nerrpr
21931  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)
21932 
21933 C...Set up error checkers
21934  iboost=0
21935 
21936 C...Initialize colour arrays: MCO (Original) and MCT (New)
21937  DO 110 i=mint(84)+1,nersiz
21938  DO 100 jc=1,2
21939  mct(i,jc)=0
21940  mco(i,jc)=0
21941  100 CONTINUE
21942 C...Also zero colour tracing information, if existed.
21943  IF (i.LE.n) THEN
21944  k(i,4)=mod(k(i,4),mstu(5)**2)
21945  k(i,5)=mod(k(i,5),mstu(5)**2)
21946  ENDIF
21947  110 CONTINUE
21948 
21949 C...Initialize colour tag collapse arrays:
21950 C...JCCO (Original) and JCCN (New).
21951  DO 130 mg=mint(84)+1,nersiz
21952  DO 120 jc=1,2
21953  jcco(mg,jc)=0
21954  jccn(mg,jc)=0
21955  120 CONTINUE
21956  130 CONTINUE
21957 
21958 C...Zero gluon insertion array
21959  DO 150 im=1,1000
21960  DO 140 j=1,3
21961  insr(im,j)=0
21962  140 CONTINUE
21963  150 CONTINUE
21964 
21965 C...Compute hard scattering system rapidities
21966  IF (mstp(89).EQ.1) THEN
21967  DO 160 im=1,240
21968  IF (im.LE.mint(31)) THEN
21969  ymi(im)=log(xmi(1,im)/xmi(2,im))
21970  ELSE
21971 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21972  ymi(im)=100d0
21973  ENDIF
21974  160 CONTINUE
21975  ENDIF
21976 
21977 C...Treat each side separately
21978  DO 290 js=1,2
21979 
21980 C...Initialize side.
21981  ng(js)=0
21982  jv=0
21983  kfs=isign(1,mint(10+js))
21984 
21985 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21986  IF(kfival(js,1).EQ.0) THEN
21987  IF(mint(10+js).EQ.111) THEN
21988  kfival(js,1)=int(1.5d0+pyr(0))
21989  kfival(js,2)=-kfival(js,1)
21990  ELSEIF(mint(10+js).EQ.22) THEN
21991  pyrkf=pyr(0)
21992  kfival(js,1)=1
21993  IF(pyrkf.GT.0.1d0) kfival(js,1)=2
21994  IF(pyrkf.GT.0.5d0) kfival(js,1)=3
21995  IF(pyrkf.GT.0.6d0) kfival(js,1)=4
21996  kfival(js,2)=-kfival(js,1)
21997  ELSEIF(mint(10+js).EQ.130.OR.mint(10+js).EQ.310) THEN
21998  IF(pyr(0).GT.0.5d0) THEN
21999  kfival(js,1)=1
22000  kfival(js,2)=-3
22001  ELSE
22002  kfival(js,1)=3
22003  kfival(js,2)=-1
22004  ENDIF
22005  ENDIF
22006  ENDIF
22007 
22008 C...Initialize beam remnant sea and valence content flavour by flavour.
22009  nvsum(js)=0
22010  nbrtot(js)=0
22011  DO 210 jfa=1,6
22012 C...Count up original number of JFA valence quarks and antiquarks.
22013  nvalq=0
22014  nvalqb=0
22015  nsea=0
22016  DO 170 j=1,3
22017  IF(kfival(js,j).EQ.jfa) nvalq=nvalq+1
22018  IF(kfival(js,j).EQ.-jfa) nvalqb=nvalqb+1
22019  170 CONTINUE
22020  nvsum(js)=nvsum(js)+nvalq+nvalqb
22021 C...Subtract kicked out valence and determine sea from flavour cons.
22022  DO 180 im=1,nmi(js)
22023  ifl = k(imi(js,im,1),2)
22024  ifa = iabs(ifl)
22025  ifs = isign(1,ifl)
22026  IF (ifl.EQ.jfa.AND.imi(js,im,2).EQ.0) THEN
22027 C...Subtract K.O. valence quark from remainder.
22028  nvalq=nvalq-1
22029  jv=nvsum(js)-nvalq-nvalqb
22030  iv(js,jv)=imi(js,im,1)
22031  ELSEIF (ifl.EQ.-jfa.AND.imi(js,im,2).EQ.0) THEN
22032 C...Subtract K.O. valence antiquark from remainder.
22033  nvalqb=nvalqb-1
22034  jv=nvsum(js)-nvalq-nvalqb
22035  iv(js,jv)=imi(js,im,1)
22036  ELSEIF (ifa.EQ.jfa) THEN
22037 C...Outside sea without companion: add opposite sea flavour inside.
22038  IF (imi(js,im,2).LT.0) nsea=nsea-ifs
22039  ENDIF
22040  180 CONTINUE
22041 C...Check if space left in PYJETS for additional BR flavours
22042  nflsum=iabs(nsea)+nvalq+nvalqb
22043  nbrtot(js)=nbrtot(js)+nflsum
22044  IF (n+nflsum+1.GT.mstu(4)) THEN
22045  CALL pyerrm(11,'(PYMIHK:) no more memory left in PYJETS')
22046  mint(51)=1
22047  RETURN
22048  ENDIF
22049 C...Add required val+sea content to beam remnant.
22050  IF (nflsum.GT.0) THEN
22051  DO 200 ia=1,nflsum
22052 C...Insert beam remnant quark as p.t. symbolic parton in ER.
22053  n=n+1
22054  DO 190 ix=1,5
22055  k(n,ix)=0
22056  p(n,ix)=0d0
22057  v(n,ix)=0d0
22058  190 CONTINUE
22059  k(n,1)=3
22060  k(n,2)=isign(jfa,nsea)
22061  IF (ia.LE.nvalq) k(n,2)=jfa
22062  IF (ia.GT.nvalq.AND.ia.LE.nvalq+nvalqb) k(n,2)=-jfa
22063  k(n,3)=mint(83)+js
22064 C...Also update NMI, IMI, and IV arrays.
22065  nmi(js)=nmi(js)+1
22066  imi(js,nmi(js),1)=n
22067  imi(js,nmi(js),2)=-1
22068  IF (ia.LE.nvalq+nvalqb) THEN
22069  imi(js,nmi(js),2)=0
22070  jv=jv+1
22071  iv(js,jv)=imi(js,nmi(js),1)
22072  ENDIF
22073  200 CONTINUE
22074  ENDIF
22075  210 CONTINUE
22076 
22077  im=0
22078  220 im=im+1
22079  IF (im.LE.nmi(js)) THEN
22080  IF (k(imi(js,im,1),2).EQ.21) THEN
22081  ng(js)=ng(js)+1
22082 C...Add fictitious parent gluons for companion pairs.
22083  ELSEIF (imi(js,im,2).NE.0.AND.k(imi(js,im,1),2).GT.0) THEN
22084 C...Randomly assign companions to sea quarks which have none.
22085  IF (imi(js,im,2).LT.0) THEN
22086  imc=pyr(0)*nmi(js)
22087  230 imc=mod(imc,nmi(js))+1
22088  IF (k(imi(js,imc,1),2).NE.-k(imi(js,im,1),2)) goto 230
22089  IF (imi(js,imc,2).GE.0) goto 230
22090  imi(js, im,2) = imi(js,imc,1)
22091  imi(js,imc,2) = imi(js, im,1)
22092  ENDIF
22093 C...Add fictitious parent gluon
22094  n=n+1
22095  DO 240 ix=1,5
22096  k(n,ix)=0
22097  p(n,ix)=0d0
22098  v(n,ix)=0d0
22099  240 CONTINUE
22100  k(n,1)=14
22101  k(n,2)=21
22102  k(n,3)=mint(83)+js
22103 C...Set gluon (anti-)colour daughter pointers
22104  k(n,4)=imi(js, im,1)
22105  k(n,5)=imi(js, im,2)
22106 C...Set quark (anti-)colour parent pointers
22107  k(imi(js, im,2),5)=k(imi(js, im,2),5)+mstu(5)*n
22108  k(imi(js, im,1),4)=k(imi(js, im,1),4)+mstu(5)*n
22109 C...Add gluon to IMI
22110  nmi(js)=nmi(js)+1
22111  imi(js,nmi(js),1)=n
22112  imi(js,nmi(js),2)=0
22113  ENDIF
22114  goto 220
22115  ENDIF
22116 
22117 C...If incoming (anti-)baryon, insert inside (anti-)junction.
22118 C...Set up initial v-v-j-v configuration. Otherwise set up
22119 C...mesonic v-vbar configuration
22120  IF (iabs(mint(10+js)).GT.1000) THEN
22121 C...Determine junction type (1: B=1 2: B=-1)
22122  itjunc(js) = (3-kfs)/2
22123 C...Insert junction.
22124  n=n+1
22125  DO 250 ix=1,5
22126  k(n,ix)=0
22127  p(n,ix)=0d0
22128  v(n,ix)=0d0
22129  250 CONTINUE
22130 C...Set special junction codes:
22131  k(n,1)=42
22132  k(n,2)=88
22133 C...Set parent to side.
22134  k(n,3)=mint(83)+js
22135  k(n,4)=itjunc(js)*mstu(5)
22136  k(n,5)=0
22137 C...Connect valence quarks to junction.
22138  mout(js)=0
22139  manti=itjunc(js)-1
22140 C...Set (anti)colour mother = junction.
22141  DO 260 jv=1,3
22142  k(iv(js,jv),4+manti)=mod(k(iv(js,jv),4+manti),mstu(5))
22143  & +mstu(5)*n
22144 C...Keep track of partons adjacent to junction:
22145  jst(js,jv)=iv(js,jv)
22146  260 CONTINUE
22147  ELSE
22148 C...Mesons: set up initial q-qbar topology
22149  itjunc(js)=0
22150  IF (k(iv(js,1),2).GT.0) THEN
22151  iq=iv(js,1)
22152  iqbar=iv(js,2)
22153  ELSE
22154  iq=iv(js,2)
22155  iqbar=iv(js,1)
22156  ENDIF
22157  iv(js,3)=0
22158  jst(js,1)=iq
22159  jst(js,2)=iqbar
22160  jst(js,3)=0
22161  k(iq,4)=mod(k(iq,4),mstu(5))+mstu(5)*iqbar
22162  k(iqbar,5)=mod(k(iqbar,5),mstu(5))+mstu(5)*iq
22163 C...Special for mesons. Insert gluon if BR empty.
22164  IF (nbrtot(js).EQ.0) THEN
22165  n=n+1
22166  DO 270 ix=1,5
22167  k(n,ix)=0
22168  p(n,ix)=0d0
22169  v(n,ix)=0d0
22170  270 CONTINUE
22171  k(n,1)=3
22172  k(n,2)=21
22173  k(n,3)=mint(83)+js
22174  k(n,4)=0
22175  k(n,5)=0
22176  nbrtot(js)=1
22177  ng(js)=ng(js)+1
22178 C...Add gluon to IMI
22179  nmi(js)=nmi(js)+1
22180  imi(js,nmi(js),1)=n
22181  imi(js,nmi(js),2)=0
22182  ENDIF
22183  mout(js)=0
22184  ENDIF
22185 
22186 C...Count up number of valence quarks outside BR.
22187  DO 280 jv=1,3
22188  IF (jst(js,jv).LE.mint(53).AND.jst(js,jv).GT.0)
22189  & mout(js)=mout(js)+1
22190  280 CONTINUE
22191 
22192  290 CONTINUE
22193 
22194 C...Now both sides have been prepared in an initial vvjv (baryonic) or
22195 C...v(g)vbar (mesonic) configuration.
22196 
22197 C...Create colour line tags starting from initiators.
22198  nct=0
22199  DO 320 im=1,mint(31)
22200 C...Consider each side in turn.
22201  DO 310 js=1,2
22202  i1=imi(js,im,1)
22203  i2=imi(3-js,im,1)
22204  DO 300 jcs=4,5
22205  IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
22206  & goto 300
22207  IF (k(i1,jcs)/mstu(5)**2.NE.0) goto 300
22208 
22209  kcs=jcs
22210  CALL pycttr(i1,kcs,i2)
22211  IF(mint(51).NE.0) RETURN
22212 
22213  300 CONTINUE
22214  310 CONTINUE
22215  320 CONTINUE
22216 
22217  DO 340 js=1,2
22218 C...Create colour tags for beam remnant partons.
22219  DO 330 im=mint(31)+1,nmi(js)
22220  ip=imi(js,im,1)
22221  IF (k(ip,2).NE.21) THEN
22222  jc=(3-isign(1,k(ip,2)))/2
22223  IF (mct(ip,jc).EQ.0) THEN
22224  nct=nct+1
22225  mct(ip,jc)=nct
22226  ENDIF
22227  ELSE
22228 C...Gluons
22229  icd=k(ip,4)
22230  iad=k(ip,5)
22231  IF (icd.NE.0) THEN
22232 C...Fictituous gluons just inherit from their quark daughters.
22233  icc=mct(icd,1)
22234  iac=mct(iad,2)
22235  ELSE
22236 C...Real beam remnant gluons get their own colours
22237  icc=nct+1
22238  iac=nct+2
22239  nct=nct+2
22240  ENDIF
22241  mct(ip,1)=icc
22242  mct(ip,2)=iac
22243  ENDIF
22244  330 CONTINUE
22245  340 CONTINUE
22246 
22247 C...Create colour tags for colour lines which are detached from the
22248 C...initial state.
22249 
22250  DO 360 mqgst=1,2
22251  DO 350 i=mint(84)+1,n
22252 
22253 C...Look for coloured string endpoint, or (later) leftover gluon.
22254  IF (k(i,1).NE.3) goto 350
22255  kc=pycomp(k(i,2))
22256  IF(kc.EQ.0) goto 350
22257  kq=kchg(kc,2)
22258  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 350
22259 
22260 C...Pick up loose string end with no previous tag.
22261  kcs=4
22262  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
22263  IF(mct(i,kcs-3).NE.0) goto 350
22264 
22265  CALL pycttr(i,kcs,i)
22266  IF(mint(51).NE.0) RETURN
22267 
22268  350 CONTINUE
22269  360 CONTINUE
22270 
22271 C...Store original colour tags
22272  DO 370 i=mint(84)+1,n
22273  mco(i,1)=mct(i,1)
22274  mco(i,2)=mct(i,2)
22275  370 CONTINUE
22276 
22277 C...Iteratively add gluons to already existing string pieces, enforcing
22278 C...various possible orderings, and rejecting insertions that would give
22279 C...rise to singlet gluons.
22280 C...<kappa tau> normalization.
22281  rm0=1.5d0
22282  mretry=0
22283  parp80=parp(80)
22284 
22285 C...Set up simplified kinematics.
22286 C...Boost hard interaction systems.
22287  iboost=iboost+1
22288  DO 380 im=1,mint(31)
22289  beta=(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
22290  CALL pyrobo(imisep(im-1)+1,imisep(im),0d0,0d0,0d0,0d0,beta)
22291  380 CONTINUE
22292 C...Assign preliminary beam remnant momenta.
22293  DO 390 i=mint(53)+1,n
22294  js=k(i,3)
22295  p(i,1)=0d0
22296  p(i,2)=0d0
22297  IF (k(i,2).NE.88) THEN
22298  p(i,4)=0.5d0*vint(142+js)*vint(1)/max(1,nmi(js)-mint(31))
22299  p(i,3)=p(i,4)
22300  IF (js.EQ.2) p(i,3)=-p(i,3)
22301  ELSE
22302 C...Junctions are wildcards for the present.
22303  p(i,4)=0d0
22304  p(i,3)=0d0
22305  ENDIF
22306  390 CONTINUE
22307 
22308 C...Reset colour processing information.
22309  400 DO 410 i=mint(84)+1,n
22310  k(i,4)=mod(k(i,4),mstu(5)**2)
22311  k(i,5)=mod(k(i,5),mstu(5)**2)
22312  410 CONTINUE
22313 
22314  ncc=0
22315  DO 430 js=1,2
22316 C...If meson, without gluon in BR, collapse q-qbar colour tags:
22317  IF (itjunc(js).EQ.0) THEN
22318  jc1=mct(jst(js,1),1)
22319  jc2=mct(jst(js,2),2)
22320  ncc=ncc+1
22321  jcco(ncc,1)=max(jc1,jc2)
22322  jcco(ncc,2)=min(jc1,jc2)
22323 C...Collapse colour tags in event record
22324  DO 420 i=mint(84)+1,n
22325  IF (mct(i,1).EQ.jcco(ncc,1)) mct(i,1)=jcco(ncc,2)
22326  IF (mct(i,2).EQ.jcco(ncc,1)) mct(i,2)=jcco(ncc,2)
22327  420 CONTINUE
22328  ENDIF
22329  430 CONTINUE
22330 
22331  440 js=1
22332  IF (pyr(0).GT.0.5d0.OR.ng(1).EQ.0) js=2
22333  IF (ng(js).GT.0) THEN
22334  nopt=0
22335  rlopt=1d9
22336 C...Start at random gluon (optimizes speed for random attachments)
22337  nmgl=0
22338  imgl=pyr(0)*nmi(js)+1
22339  450 imgl=mod(imgl,nmi(js))+1
22340  nmgl=nmgl+1
22341 C...Only loop through NMI once (with upper limit to save time)
22342  IF (nmgl.LE.nmi(js).AND.nopt.LE.3) THEN
22343  igl = imi(js,imgl,1)
22344 C...If not gluon or if already connected, try next.
22345  IF (k(igl,2).NE.21.OR.k(igl,4)/mstu(5).NE.0
22346  & .OR.k(igl,5)/mstu(5).NE.0) goto 450
22347 C...Now loop through all possible insertions of this gluon.
22348  nmp1=0
22349  imp1=pyr(0)*nmi(js)+1
22350  460 imp1=mod(imp1,nmi(js))+1
22351  nmp1=nmp1+1
22352  IF (imp1.EQ.imgl) goto 460
22353 C...Only loop through NMI once (with upper limit to save time).
22354  IF (nmp1.LE.nmi(js).AND.nopt.LE.3) THEN
22355  ip1 = imi(js,imp1,1)
22356 C...Try both colour mother and colour anti-mother.
22357 C...Randomly select which one to try first.
22358  nanti=0
22359  manti=pyr(0)*2
22360  470 manti=mod(manti+1,2)
22361  nanti=nanti+1
22362  IF (nanti.LE.2) THEN
22363  ip2 =mod(k(ip1,4+manti)/mstu(5),mstu(5))
22364 C...Reject if no appropriate mother (or if mother is fictitious
22365 C...parent gluon.)
22366  IF (ip2.LE.0) goto 470
22367  IF (k(ip2,2).EQ.21.AND.ip2.GT.mint(53)) goto 470
22368 C...Also reject if this link has already been tried.
22369  IF (k(ip1,4+manti)/mstu(5)**2.EQ.2) goto 470
22370  IF (k(ip2,5-manti)/mstu(5)**2.EQ.2) goto 470
22371 C...Set flag to indicate that this link has now been tried for this
22372 C...gluon. IP2 may be junction, which has several mothers.
22373  k(ip1,4+manti)=k(ip1,4+manti)+2*mstu(5)**2
22374  IF (k(ip2,2).NE.88) THEN
22375  k(ip2,5-manti)=k(ip2,5-manti)+2*mstu(5)**2
22376  ENDIF
22377 
22378 C...JCG1: Original colour tag of gluon on IP1 side
22379 C...JCG2: Original colour tag of gluon on IP2 side
22380 C...JCP1: Original colour tag of IP1 on gluon side
22381 C...JCP2: Original colour tag of IP2 on gluon side.
22382  jcg1=mco(igl,2-manti)
22383  jcg2=mco(igl,1+manti)
22384  jcp1=mco(ip1,1+manti)
22385  jcp2=mco(ip2,2-manti)
22386 
22387  CALL pymihg(jcp1,jcg1,jcp2,jcg2)
22388 C...Reject gluon attachments that give rise to singlet gluons.
22389  IF (maccpt.EQ.0) goto 470
22390 
22391 C...Update colours
22392  jcg1=mct(igl,2-manti)
22393  jcg2=mct(igl,1+manti)
22394  jcp1=mct(ip1,1+manti)
22395  jcp2=mct(ip2,2-manti)
22396 
22397 C...Select whether to accept this insertion
22398  IF (mstp(89).EQ.0) THEN
22399 C...Random insertions: no measure.
22400  rl=1d0
22401 C...For random ordering, we want to suppress beam remnant breakups
22402 C...already at this point.
22403  IF (ip1.GT.mint(53).AND.ip2.GT.mint(53)
22404  & .AND.mout(js).NE.0.AND.pyr(0).GT.parp80) THEN
22405  nmp1=0
22406  nmgl=0
22407  goto 470
22408  ENDIF
22409  ELSEIF (mstp(89).EQ.1) THEN
22410 C...Rapidity ordering:
22411 C...YGL = Rapidity of gluon.
22412  ygl=ymi(imgl)
22413 C...If fictitious gluon
22414  IF (ygl.EQ.100d0) THEN
22415  ygl=(3-2*js)*100d0
22416  ida1=mod(k(igl,4),mstu(5))
22417  ida2=mod(k(igl,5),mstu(5))
22418  DO 480 imt=1,nmi(js)
22419 C...Select (arbitrarily) the most central daughter.
22420  IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2)
22421  & THEN
22422  IF (abs(ygl).GT.abs(ymi(imt))) ygl=ymi(imt)
22423  ENDIF
22424  480 CONTINUE
22425  ENDIF
22426 C...YP1 = Rapidity IP1
22427  yp1=ymi(imp1)
22428 C...If fictitious gluon
22429  IF (yp1.EQ.100d0) THEN
22430  yp1=(3-2*js)*yp1
22431  ida1=mod(k(ip1,4),mstu(5))
22432  ida2=mod(k(ip1,5),mstu(5))
22433  DO 490 imt=1,nmi(js)
22434 C...Select (arbitrarily) the most central daughter.
22435  IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2)
22436  & THEN
22437  IF (abs(yp1).GT.abs(ymi(imt))) yp1=ymi(imt)
22438  ENDIF
22439  490 CONTINUE
22440  ENDIF
22441 C...YP2 = Rapidity of mother system
22442  IF (k(ip2,2).NE.88) THEN
22443  DO 500 imt=1,nmi(js)
22444  IF (imi(js,imt,1).EQ.ip2) yp2=ymi(imt)
22445  500 CONTINUE
22446 C...If fictitious gluon
22447  IF (yp2.EQ.100d0) THEN
22448  yp2=(3-2*js)*yp2
22449  ida1=mod(k(ip2,4),mstu(5))
22450  ida2=mod(k(ip2,5),mstu(5))
22451  DO 510 imt=1,nmi(js)
22452 C...Select (arbitrarily) the most central daughter.
22453  IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2
22454  & ) THEN
22455  IF (abs(yp2).GT.abs(ymi(imt))) yp2=ymi(imt)
22456  ENDIF
22457  510 CONTINUE
22458  ENDIF
22459 C...Assign (arbitrarily) 100D0 to junction also
22460  ELSE
22461  yp2=(3-2*js)*100d0
22462  ENDIF
22463  rl=abs(ygl-yp1)+abs(ygl-yp2)
22464  ELSEIF (mstp(89).EQ.2) THEN
22465 C...Lambda ordering:
22466 C...Compute lambda measure for this insertion.
22467  rl=1d0
22468  DO 520 ist=1,6
22469  istr(ist)=0
22470  520 CONTINUE
22471 C...If IP2 is junction, not caught below.
22472  IF (jcp2.EQ.0) THEN
22473  itju=mod(k(ip2,4)/mstu(5),mstu(5))
22474 C...Anti-junction is colour endpoint et vv., always on JCG2.
22475  istr(5-itju)=ip2
22476  ENDIF
22477  DO 530 i=mint(84)+1,n
22478  IF (k(i,1).LT.10) THEN
22479 C...The new string pieces
22480  IF (mct(i,1).EQ.jcg1) istr(1)=i
22481  IF (mct(i,2).EQ.jcg1) istr(2)=i
22482  IF (mct(i,1).EQ.jcg2) istr(3)=i
22483  IF (mct(i,2).EQ.jcg2) istr(4)=i
22484  ENDIF
22485  530 CONTINUE
22486 C...Also identify junctions as string endpoints.
22487  DO 540 i=mint(84)+1,n
22488  icmo=mod(k(i,4)/mstu(5),mstu(5))
22489  iamo=mod(k(i,5)/mstu(5),mstu(5))
22490 C...Find partons adjacent to junctions.
22491  IF (icmo.GT.0.AND.icmo.LE.n) THEN
22492  IF (k(icmo,1).EQ.42.AND.mct(i,1).EQ.jcg1.AND.istr(2)
22493  & .EQ.0) istr(2) = icmo
22494  IF (k(icmo,1).EQ.42.AND.mct(i,1).EQ.jcg2.AND.istr(4)
22495  & .EQ.0) istr(4) = icmo
22496  ENDIF
22497  IF (iamo.GT.0.AND.iamo.LE.n) THEN
22498  IF (k(iamo,1).EQ.42.AND.mct(i,2).EQ.jcg1.AND.istr(1)
22499  & .EQ.0) istr(1) = iamo
22500  IF (k(iamo,1).EQ.42.AND.mct(i,2).EQ.jcg2.AND.istr(3)
22501  & .EQ.0) istr(3) = iamo
22502  ENDIF
22503  540 CONTINUE
22504 C...The old string piece
22505  istr(5)=istr(1+2*manti)
22506  istr(6)=istr(4-2*manti)
22507  IF (istr(1).EQ.0.OR.istr(2).EQ.0.OR.istr(3).EQ.0.OR.
22508  & istr(4).EQ.0.OR.istr(5).EQ.0.OR.istr(6).EQ.0) THEN
22509 C...If one or more of the colour tags for this connection is/are still
22510 C...dangling, skip this attempt for the time being.
22511  rl=1d6
22512  ELSE
22513  rl=max(1d0,four(istr(1),istr(2)))*max(1d0,four(istr(3)
22514  & ,istr(4)))/max(1d0,four(istr(5),istr(6)))
22515  rl=log(rl)
22516  ENDIF
22517  ENDIF
22518 C...Allow some breadth to speed things up.
22519  IF (abs(1d0-rl/rlopt).LT.0.05d0) THEN
22520  nopt=nopt+1
22521  ELSEIF (rl.GT.rlopt) THEN
22522  goto 470
22523  ELSE
22524  nopt=1
22525  rlopt=rl
22526  ENDIF
22527 C...INSR(NOPT,1)=Gluon colour mother
22528 C...INSR(NOPT,2)=Gluon
22529 C...INSR(NOPT,3)=Gluon anticolour mother
22530  IF (nopt.GT.1000) goto 470
22531  insr(nopt,1+2*manti)=ip2
22532  insr(nopt,2)=igl
22533  insr(nopt,3-2*manti)=ip1
22534  IF (mstp(89).GT.0.OR.nopt.EQ.0) goto 470
22535  ENDIF
22536  IF (mstp(89).GT.0.OR.nopt.EQ.0) goto 460
22537  ENDIF
22538 C...Reset link test information.
22539  DO 550 i=mint(84)+1,n
22540  k(i,4)=mod(k(i,4),mstu(5)**2)
22541  k(i,5)=mod(k(i,5),mstu(5)**2)
22542  550 CONTINUE
22543  IF (mstp(89).GT.0.OR.nopt.EQ.0) goto 450
22544  ENDIF
22545 C...Now we have a list of best gluon insertions, none of which cause
22546 C...singlets to arise. If list is empty, try again a few times. Note:
22547 C...this should never happen if we have a meson with a gluon inserted
22548 C...in the beam remnant, since that breaks up the colour line.
22549  IF (nopt.EQ.0) THEN
22550 C...Abandon BR-g-BR suppression for retries. This is not serious, it
22551 C...just means we happened to start with trying a bad sequence.
22552  parp80=1d0
22553  IF (mretry.LE.10.AND.(itjunc(1).NE.0.OR.jst(1,3).EQ.0).and
22554  & .(itjunc(2).NE.0.OR.jst(2,3).EQ.0)) THEN
22555  mretry=mretry+1
22556  DO 590 js=1,2
22557  IF (itjunc(js).NE.0) THEN
22558  jst(js,1)=iv(js,1)
22559  jst(js,2)=iv(js,2)
22560  jst(js,3)=iv(js,3)
22561 C...Reset valence quark parent pointers
22562  DO 560 i=mint(53)+1,n
22563  IF (k(i,2).EQ.88.AND.k(i,3).EQ.js) iju=i
22564  560 CONTINUE
22565  manti=itjunc(js)-1
22566 C...Set (anti)colour mother = junction.
22567  DO 570 jv=1,3
22568  k(iv(js,jv),4+manti)=mod(k(iv(js,jv),4+manti),mstu(5))
22569  & +mstu(5)*iju
22570  570 CONTINUE
22571  ELSE
22572 C...Same for mesons. JST unchanged, so needn't be restored.
22573  iq=jst(js,1)
22574  iqbar=jst(js,2)
22575  k(iq,4)=mod(k(iq,4),mstu(5))+mstu(5)*iqbar
22576  k(iqbar,5)=mod(k(iqbar,5),mstu(5))+mstu(5)*iq
22577  ENDIF
22578 C...Also reset gluon parent pointers.
22579  ng(js)=0
22580  DO 580 im=1,nmi(js)
22581  i=imi(js,im,1)
22582  IF (k(i,2).EQ.21) THEN
22583  k(i,4)=mod(k(i,4),mstu(5))
22584  k(i,5)=mod(k(i,5),mstu(5))
22585  ng(js)=ng(js)+1
22586  ENDIF
22587  580 CONTINUE
22588  590 CONTINUE
22589 C...Reset colour tags
22590  DO 600 i=mint(84)+1,n
22591  mct(i,1)=mco(i,1)
22592  mct(i,2)=mco(i,2)
22593  600 CONTINUE
22594  goto 400
22595  ELSE
22596  IF(nerrpr.LT.5) THEN
22597  nerrpr=nerrpr+1
22598  CALL pylist(4)
22599  CALL pyerrm(19,'(PYMIHK:) No physical colour flow found!')
22600  WRITE(mstu(11),*) 'NG:', ng,' MOUT:', mout(js)
22601  ENDIF
22602 C...Kill event and start another.
22603  mint(51)=1
22604  RETURN
22605  ENDIF
22606  ELSE
22607 C...Select between insertions, suppressing insertions wholly in the BR.
22608  iin=pyr(0)*nopt+1
22609  610 iin=mod(iin,nopt)+1
22610  IF (insr(iin,1).GT.mint(53).AND.insr(iin,3).GT.mint(53)
22611  & .AND.mout(js).NE.0.AND.pyr(0).GT.parp80) goto 610
22612  ENDIF
22613 
22614 C...Now we know which gluon to insert where. Colour tags in JCCO and
22615 C...colour connection information should be updated, NG(JS) should be
22616 C...counted down, and a new loop performed if there are still gluons
22617 C...left on any side.
22618  icm=insr(iin,1)
22619  iacm=insr(iin,3)
22620  igl=insr(iin,2)
22621 C...JCG : Original gluon colour tag
22622 C...JCAG: Original gluon anticolour tag.
22623 C...JCM : Original anticolour tag of gluon colour mother
22624 C...JACM: Original colour tag of gluon anticolour mother
22625  jcg=mco(igl,1)
22626  jcm=mco(icm,2)
22627  jacg=mco(igl,2)
22628  jacm=mco(iacm,1)
22629 
22630  CALL pymihg(jacm,jacg,jcm,jcg)
22631  IF (maccpt.EQ.0) THEN
22632  IF(nerrpr.LT.5) THEN
22633  nerrpr=nerrpr+1
22634  CALL pylist(4)
22635  CALL pyerrm(11,'(PYMIHK:) Unphysical colour flow!')
22636  WRITE(mstu(11),*) 'attaching', igl,' between', icm, iacm
22637  ENDIF
22638 C...Kill event and start another.
22639  mint(51)=1
22640  RETURN
22641  ELSE
22642 C...If everything went fine, store new JCCN in JCCO.
22643  ncc=ncc+1
22644  DO 620 icc=1,ncc
22645  jcco(icc,1)=jccn(icc,1)
22646  jcco(icc,2)=jccn(icc,2)
22647  620 CONTINUE
22648  ENDIF
22649 
22650 C...One gluon attached is counted as equivalent to one end outside.
22651  mout(js)=1
22652 C...Set IGL colour mother = ICM.
22653  k(igl,4)=mod(k(igl,4),mstu(5))+mstu(5)*icm
22654 C...Set ICM anticolour mother = IGL colour.
22655  IF (k(icm,2).NE.88) THEN
22656  k(icm,5)=mod(k(icm,5),mstu(5))+mstu(5)*igl
22657  ELSE
22658 C...If ICM is junction, just update JST array for now.
22659  DO 630 msj=1,3
22660  IF (jst(js,msj).EQ.iacm) jst(js,msj)=igl
22661  630 CONTINUE
22662  ENDIF
22663 C...Set IGL anticolour mother = IACM.
22664  k(igl,5)=mod(k(igl,5),mstu(5))+mstu(5)*iacm
22665 C...Set IACM anticolour mother = IGL anticolour.
22666  IF (k(iacm,2).NE.88) THEN
22667  k(iacm,4)=mod(k(iacm,4),mstu(5))+mstu(5)*igl
22668  ELSE
22669 C...If IACM is junction, just update JST array for now.
22670  DO 640 msj=1,3
22671  IF (jst(js,msj).EQ.icm) jst(js,msj)=igl
22672  640 CONTINUE
22673  ENDIF
22674 C...Count down # unconnected gluons.
22675  ng(js)=ng(js)-1
22676  ENDIF
22677  IF (ng(1).GT.0.OR.ng(2).GT.0) goto 440
22678 
22679  DO 840 js=1,2
22680 C...Collapse fictitious gluons.
22681  DO 670 igl=mint(53)+1,n
22682  IF (k(igl,2).EQ.21.AND.k(igl,3).EQ.mint(83)+js.AND.
22683  & k(igl,1).EQ.14) THEN
22684  icm=k(igl,4)/mstu(5)
22685  iam=k(igl,5)/mstu(5)
22686  icd=mod(k(igl,4),mstu(5))
22687  iad=mod(k(igl,5),mstu(5))
22688 C...Set gluon daughters pointing to gluon mothers
22689  k(iad,5)=mod(k(iad,5),mstu(5))+mstu(5)*iam
22690  k(icd,4)=mod(k(icd,4),mstu(5))+mstu(5)*icm
22691 C...Set gluon mothers pointing to gluon daughters.
22692  IF (k(icm,2).NE.88) THEN
22693  k(icm,5)=mod(k(icm,5),mstu(5))+mstu(5)*icd
22694  ELSE
22695 C...Special case: mother=junction. Just update JST array for now.
22696  DO 650 msj=1,3
22697  IF (jst(js,msj).EQ.igl) jst(js,msj)=icd
22698  650 CONTINUE
22699  ENDIF
22700  IF (k(iam,2).NE.88) THEN
22701  k(iam,4)=mod(k(iam,4),mstu(5))+mstu(5)*iad
22702  ELSE
22703  DO 660 msj=1,3
22704  IF (jst(js,msj).EQ.igl) jst(js,msj)=iad
22705  660 CONTINUE
22706  ENDIF
22707  ENDIF
22708  670 CONTINUE
22709 
22710 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22711  im=nmi(js)+1
22712  680 im=im-1
22713  IF (im.GT.mint(31).AND.k(imi(js,im,1),2).NE.21) goto 680
22714  IF (im.GT.mint(31)) THEN
22715  nmi(js)=nmi(js)-1
22716  DO 690 imr=im,nmi(js)
22717  imi(js,imr,1)=imi(js,imr+1,1)
22718  imi(js,imr,2)=imi(js,imr+1,2)
22719  690 CONTINUE
22720  goto 680
22721  ENDIF
22722 
22723 C...Finally, connect junction.
22724  IF (itjunc(js).NE.0) THEN
22725  DO 700 i=mint(53)+1,n
22726  IF (k(i,2).EQ.88.AND.k(i,3).EQ.mint(83)+js) iju=i
22727  700 CONTINUE
22728 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22729  nbrjq =0
22730  nbrvq =0
22731  DO 720 msj=1,3
22732  idq(msj)=0
22733 C...Find jq with no glue inbetween inside beam remnant.
22734  IF (jst(js,msj).GT.mint(53).AND.iabs(k(jst(js,msj),2)).LE.5)
22735  & THEN
22736  nbrjq=nbrjq+1
22737 C...Set IDQ = -I if q non-valence and = +I if q valence.
22738  idq(nbrjq)=-jst(js,msj)
22739  DO 710 jv=1,3
22740  IF (iv(js,jv).EQ.jst(js,msj)) THEN
22741  idq(nbrjq)=jst(js,msj)
22742  nbrvq=nbrvq+1
22743  ENDIF
22744  710 CONTINUE
22745  ENDIF
22746  i12=mod(msj+1,2)
22747  i45=5
22748  IF (msj.EQ.3) i45=4
22749  k(iju,i45)=k(iju,i45)+(mstu(5)**i12)*jst(js,msj)
22750  720 CONTINUE
22751 
22752 C...Check if diquark can be formed.
22753  IF ((mstp(88).GE.0.AND.nbrvq.GE.2).OR.(nbrjq.GE.2.AND.mstp(88)
22754  & .GE.1)) THEN
22755 C...If there is less than 2 valence quarks connected to junction
22756 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22757  IF (nbrvq.LE.1) THEN
22758  ndiq=nbrvq
22759  730 jflip=nbrjq*pyr(0)+1
22760  IF (idq(jflip).LT.0) THEN
22761  idq(jflip)=-idq(jflip)
22762  ndiq=ndiq+1
22763  ENDIF
22764  IF (ndiq.LE.1) goto 730
22765  ENDIF
22766 C...Place selected quarks first in IDQ, ordered in flavour.
22767  DO 740 jdq=1,3
22768  IF (idq(jdq).LE.0) THEN
22769  itemp1 = idq(jdq)
22770  idq(jdq)= idq(3)
22771  idq(3) = -itemp1
22772  IF (iabs(k(idq(1),2)).LT.iabs(k(idq(2),2))) THEN
22773  itemp1 = idq(1)
22774  idq(1) = idq(2)
22775  idq(2) = itemp1
22776  ENDIF
22777  ENDIF
22778  740 CONTINUE
22779 C...Choose diquark spin.
22780  IF (nbrvq.EQ.2) THEN
22781 C...If the selected quarks are both valence, we may use SU(6) rules
22782 C...to figure out which spin the diquark has, by a subdivision of the
22783 C...original beam hadron into the selected diquark system plus a kicked
22784 C...out quark, IKO.
22785  jko=6
22786  DO 760 jdq=1,2
22787  DO 750 jv=1,3
22788  IF (idq(jdq).EQ.iv(js,jv)) jko=jko-jv
22789  750 CONTINUE
22790  760 CONTINUE
22791  iko=iv(js,jko)
22792  CALL pyspli(mint(10+js),k(iko,2),kfdum,kfdq)
22793  ELSE
22794 C...If one or more of the selected quarks are not valence, we cannot use
22795 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22796 C...flavours of the diquark already selected, we assume for now
22797 C...50:50 spin-1:spin-0 (where spin-0 possible).
22798  kfdq=1000*k(idq(1),2)+100*k(idq(2),2)
22799  is=3
22800  IF (k(idq(1),2).NE.k(idq(2),2).AND.
22801  & (1d0+3d0*parj(4))*pyr(0).LT.1d0) is=1
22802  kfdq=kfdq+isign(is,kfdq)
22803  ENDIF
22804 
22805 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22806 C...Note: third quark can per definition not also be valence,
22807 C...therefore we can only do this if we are allowed to use sea quarks.
22808  770 IF (idq(3).NE.0.AND.mstp(88).GE.2) THEN
22809  ntry=0
22810  780 ntry=ntry+1
22811  CALL pykfdi(kfdq,k(iabs(idq(3)),2),kfdum,kfbar)
22812  IF (kfbar.EQ.0.AND.ntry.LE.100) THEN
22813  goto 780
22814  ELSEIF(ntry.GT.100) THEN
22815 C...If no baryon can be found, give up and form diquark.
22816  idq(3)=0
22817  goto 770
22818  ELSE
22819 C...Replace junction by baryon.
22820  k(iju,1)=1
22821  k(iju,2)=kfbar
22822  k(iju,3)=mint(83)+js
22823  k(iju,4)=0
22824  k(iju,5)=0
22825  p(iju,5)=pymass(kfbar)
22826  DO 790 msj=1,3
22827 C...Prepare removal of participating quarks from ER.
22828  k(jst(js,msj),1)=-1
22829  790 CONTINUE
22830  ENDIF
22831  ELSE
22832 C...If collapse to baryon not possible or not allowed, replace junction
22833 C...by diquark. This way, collapsed gluons that were pointing at the
22834 C...junction will now point (correctly) at diquark.
22835  manti=itjunc(js)-1
22836  k(iju,1)=3
22837  k(iju,2)=kfdq
22838  k(iju,3)=mint(83)+js
22839  k(iju,4)=0
22840  k(iju,5)=0
22841  DO 800 msj=1,3
22842  ip=jst(js,msj)
22843  IF (ip.NE.idq(1).AND.ip.NE.idq(2)) THEN
22844  k(iju,4+manti)=0
22845  k(iju,5-manti)=ip*mstu(5)
22846  k(ip,4+manti)=mod(k(ip,4+manti),mstu(5))+
22847  & mstu(5)*iju
22848  mct(iju,2-manti)=mct(ip,1+manti)
22849  ELSE
22850 C...Prepare removal of participating quarks from ER.
22851  k(ip,1)=-1
22852  ENDIF
22853  800 CONTINUE
22854  ENDIF
22855 
22856 C...Update so ER pointers to collapsed quarks
22857 C...now go to collapsed object.
22858  DO 820 i=mint(84)+1,n
22859  IF ((k(i,3).EQ.mint(83)+js.OR.k(i,3).EQ.mint(83)+2+js).and
22860  & .k(i,1).GT.0) THEN
22861  DO 810 isid=4,5
22862  imo=k(i,isid)/mstu(5)
22863  ida=mod(k(i,isid),mstu(5))
22864  IF (imo.GT.0) THEN
22865  IF (k(imo,1).EQ.-1) imo=iju
22866  ENDIF
22867  IF (ida.GT.0) THEN
22868  IF (k(ida,1).EQ.-1) ida=iju
22869  ENDIF
22870  k(i,isid)=ida+mstu(5)*imo
22871  810 CONTINUE
22872  ENDIF
22873  820 CONTINUE
22874  ENDIF
22875  ENDIF
22876 
22877 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22878 C...(this only happens for baryons, where we want to force the gluon
22879 C...to sit next to the junction. Mesons handled above.)
22880  IF (nbrtot(js).EQ.0) THEN
22881  n=n+1
22882  DO 830 ix=1,5
22883  k(n,ix)=0
22884  p(n,ix)=0d0
22885  v(n,ix)=0d0
22886  830 CONTINUE
22887  igl=n
22888  k(igl,1)=3
22889  k(igl,2)=21
22890  k(igl,3)=mint(83)+js
22891  IF (itjunc(js).NE.0) THEN
22892 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22893  jleg=pyr(0)*nvsum(js)+1
22894  i1=jst(js,jleg)
22895  jst(js,jleg)=igl
22896  jct=mct(i1,itjunc(js))
22897  mct(igl,3-itjunc(js))=jct
22898  nct=nct+1
22899  mct(igl,itjunc(js))=nct
22900  manti=itjunc(js)-1
22901  ELSE
22902 C...Meson. Should not happen.
22903  CALL pyerrm(19,'(PYMIHK:) Empty meson beam remnant')
22904  IF(nerrpr.LT.5) THEN
22905  WRITE(mstu(11),*) 'This should not have been possible!'
22906  CALL pylist(4)
22907  nerrpr=nerrpr+1
22908  ENDIF
22909  mint(51)=1
22910  RETURN
22911  ENDIF
22912  i2=mod(k(i1,4+manti)/mstu(5),mstu(5))
22913  k(i1,4+manti)=mod(k(i1,4+manti),mstu(5))+mstu(5)*igl
22914  k(igl,5-manti)=mod(k(igl,5-manti),mstu(5))+mstu(5)*i1
22915  k(igl,4+manti)=mod(k(igl,4+manti),mstu(5))+mstu(5)*i2
22916  IF (k(i2,2).NE.88) THEN
22917  k(i2,5-manti)=mod(k(i2,5-manti),mstu(5))+mstu(5)*igl
22918  ELSE
22919  IF (mod(k(i2,4),mstu(5)).EQ.i1) THEN
22920  k(i2,4)=(k(i2,4)/mstu(5))*mstu(5)+igl
22921  ELSEIF(mod(k(i2,5)/mstu(5),mstu(5)).EQ.i1) THEN
22922  k(i2,5)=mod(k(i2,5),mstu(5))+mstu(5)*igl
22923  ELSE
22924  k(i2,5)=(k(i2,5)/mstu(5))*mstu(5)+igl
22925  ENDIF
22926  ENDIF
22927  ENDIF
22928  840 CONTINUE
22929 
22930 C...Remove collapsed quarks and junctions from ER and update IMI.
22931  CALL pyedit(11)
22932 
22933 C...Also update beam remnant part of IMI.
22934  nmi(1)=mint(31)
22935  nmi(2)=mint(31)
22936  DO 850 i=mint(53)+1,n
22937  IF (k(i,1).LE.0) goto 850
22938 C...Restore BR quark/diquark/baryon pointers in IMI.
22939  IF ((k(i,2).NE.21.OR.k(i,1).NE.14).AND.k(i,2).NE.88) THEN
22940  js=k(i,3)-mint(83)
22941  nmi(js)=nmi(js)+1
22942  imi(js,nmi(js),1)=i
22943  imi(js,nmi(js),2)=0
22944  ENDIF
22945  850 CONTINUE
22946 
22947 C...Restore companion information from collapsed gluons.
22948  DO 870 i=mint(53)+1,n
22949  IF (k(i,2).EQ.21.AND.k(i,1).EQ.14) THEN
22950  js=k(i,3)-mint(83)
22951  jcd=mod(k(i,4),mstu(5))
22952  jad=mod(k(i,5),mstu(5))
22953  DO 860 im=1,nmi(js)
22954  IF (imi(js,im,1).EQ.jcd) imc=im
22955  IF (imi(js,im,1).EQ.jad) ima=im
22956  860 CONTINUE
22957  imi(js,imc,2)=imi(js,ima,1)
22958  imi(js,ima,2)=imi(js,imc,1)
22959  ENDIF
22960  870 CONTINUE
22961 
22962 C...Renumber colour lines (since some have disappeared)
22963  jct=0
22964  jcd=0
22965  880 jct=jct+1
22966  mfound=0
22967  i=mint(84)
22968  890 i=i+1
22969  IF (i.EQ.n+1) THEN
22970  IF (mfound.EQ.0) jcd=jcd+1
22971  ELSEIF (mct(i,1).EQ.jct.AND.k(i,1).GE.1) THEN
22972  mct(i,1)=jct-jcd
22973  mfound=1
22974  ELSEIF (mct(i,2).EQ.jct.AND.k(i,1).GE.1) THEN
22975  mct(i,2)=jct-jcd
22976  mfound=1
22977  ENDIF
22978  IF (i.LE.n) goto 890
22979  IF (jct.LT.nct) goto 880
22980  nct=jct-jcd
22981 
22982 C...Reset hard interaction subsystems to their CM frames.
22983  IF (iboost.EQ.1) THEN
22984  DO 900 im=1,mint(31)
22985  beta=-(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
22986  CALL pyrobo(imisep(im-1)+1,imisep(im),0d0,0d0,0d0,0d0,beta)
22987  900 CONTINUE
22988 C...Zero beam remnant longitudinal momenta and energies
22989  DO 910 i=mint(53)+1,n
22990  p(i,3)=0d0
22991  p(i,4)=0d0
22992  910 CONTINUE
22993  ELSE
22994  CALL pyerrm(9
22995  & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22996 C...Kill event and start another.
22997  mint(51)=1
22998  RETURN
22999  ENDIF
23000 
23001  9999 RETURN
23002  END
23003 C*********************************************************************
23004 
23005 C...PYCTTR
23006 C...Adapted from PYPREP.
23007 C...Assigns LHA1 colour tags to coloured partons based on
23008 C...K(I,4) and K(I,5) colour connection record.
23009 C...KCS negative signifies that a previous tracing should be continued.
23010 C...(in case the tag to be continued is empty, the routine exits)
23011 C...Starts at I and ends at I or IEND.
23012 C...Special considerations for systems with junctions.
23013 C...Special: if IEND=-1, means trace this parton to its color partner,
23014 C... then exit. If no partner found, exit with 0.
23015 
23016  SUBROUTINE pycttr(I,KCS,IEND)
23017 C...Double precision and integer declarations.
23018  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23019  INTEGER pyk,pychge,pycomp
23020 C...Commonblocks.
23021  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23022  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23023  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
23024  common/pyint1/mint(400),vint(400)
23025 C...The common block of colour tags.
23026  common/pyctag/nct,mct(4000,2)
23027  SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/,/pyctag/
23028  DATA nerrpr/0/
23029  SAVE nerrpr
23030 
23031 C...Skip if parton not existing or does not have KCS
23032  IF (k(i,1).LE.0) goto 120
23033  kc=pycomp(k(i,2))
23034  IF (kc.EQ.0) goto 120
23035  kq=kchg(kc,2)
23036  IF (kq.EQ.0) goto 120
23037  IF (iabs(kq).EQ.1.AND.kq*(9-2*abs(kcs)).NE.isign(1,k(i,2)))
23038  & goto 120
23039 
23040  IF (kcs.GT.0) THEN
23041  nct=nct+1
23042 C...Set colour tag of first parton.
23043  mct(i,kcs-3)=nct
23044  ncs=nct
23045  ELSE
23046  kcs=-kcs
23047  ncs=mct(i,kcs-3)
23048  IF (ncs.EQ.0) goto 120
23049  ENDIF
23050 
23051  ia=i
23052  nstp=0
23053  100 nstp=nstp+1
23054  IF(nstp.GT.4*n) THEN
23055  CALL pyerrm(14,'(PYCTTR:) caught in infinite loop')
23056  goto 120
23057  ENDIF
23058 
23059 C...Finished if reached final-state triplet.
23060  IF(k(ia,1).EQ.3) THEN
23061  IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) goto 120
23062  ENDIF
23063 
23064 C...Also finished if reached junction.
23065  IF(k(ia,1).EQ.42) THEN
23066  goto 120
23067  ENDIF
23068 
23069 C...GOTO next parton in colour space.
23070  110 ib=ia
23071 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
23072  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))
23073  & .NE.0) THEN
23074  ia=mod(k(ib,kcs),mstu(5))
23075  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
23076  mrev=0
23077  ELSE
23078 C...If KCS mother traced or KCS mother nonexistent, switch colour.
23079  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
23080  & mstu(5)).EQ.0) THEN
23081  kcs=9-kcs
23082  nct=nct+1
23083  ncs=nct
23084 C...Assign new colour tag on other side of old parton.
23085  mct(ib,kcs-3)=nct
23086  ENDIF
23087 C...Goto (new) KCS mother, set mother traced tag
23088  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
23089  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
23090  mrev=1
23091  ENDIF
23092  IF(ia.LE.0.OR.ia.GT.n) THEN
23093  IF (iend.EQ.-1) THEN
23094  iend=0
23095  goto 120
23096  ENDIF
23097  CALL pyerrm(12,'(PYCTTR:) colour tag tracing failed')
23098  IF(nerrpr.LT.5) THEN
23099  write(*,*) 'began at ',i
23100  write(*,*) 'ended going from', ib, ' to', ia, ' KCS=',kcs,
23101  & ' NCS=',ncs,' MREV=',mrev
23102  CALL pylist(4)
23103  nerrpr=nerrpr+1
23104  ENDIF
23105  mint(51)=1
23106  RETURN
23107  ENDIF
23108  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
23109  & mstu(5)).EQ.ib) THEN
23110  IF(mrev.EQ.1) kcs=9-kcs
23111  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
23112 C...Set KSC mother traced tag for IA
23113  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
23114  ELSE
23115  IF(mrev.EQ.0) kcs=9-kcs
23116  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
23117 C...Set KCS daughter traced tag for IA
23118  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
23119  ENDIF
23120 C...Assign new colour tag
23121  mct(ia,kcs-3)=ncs
23122 C...Finish if IEND=-1 and found final-state color partner
23123  IF (iend.EQ.-1.AND.k(ia,1).LT.10) THEN
23124  iend=ia
23125  goto 120
23126  ENDIF
23127  IF (ia.NE.i.AND.ia.NE.iend) goto 100
23128 
23129  120 RETURN
23130  END
23131 
23132 *********************************************************************
23133 
23134 C...PYMIHG
23135 C...Collapse JCP1 and connecting tags to JCG1.
23136 C...Collapse JCP2 and connecting tags to JCG2.
23137 
23138  SUBROUTINE pymihg(JCP1,JCG1,JCP2,JCG2)
23139 C...Double precision and integer declarations.
23140  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23141  IMPLICIT INTEGER(i-n)
23142  INTEGER pyk,pychge,pycomp
23143 C...The event record
23144  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23145 C...Parameters
23146  common/pyint1/mint(400),vint(400)
23147  SAVE /pyjets/,/pyint1/
23148 C...Local variables
23149  COMMON /pycbls/mco(4000,2),ncc,jcco(4000,2),jccn(4000,2),maccpt
23150  COMMON /pyctag/nct,mct(4000,2)
23151  SAVE /pycbls/,/pyctag/
23152 
23153 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
23154 C...in temporary tag collapse array JCCN. Only break up one connection.
23155  maccpt=1
23156  mclps=0
23157  DO 100 icc=1,ncc
23158  jccn(icc,1)=jcco(icc,1)
23159  jccn(icc,2)=jcco(icc,2)
23160 C...If there was a mother, it was previously connected to JCP1.
23161 C...Should be changed to JCP2.
23162  IF (mclps.EQ.0) THEN
23163  IF (jccn(icc,1).EQ.max(jcp1,jcp2).AND.jccn(icc,2).EQ.min(jcp1
23164  & ,jcp2)) THEN
23165  jccn(icc,1)=max(jcg2,jcp2)
23166  jccn(icc,2)=min(jcg2,jcp2)
23167  mclps=1
23168  ENDIF
23169  ENDIF
23170  100 CONTINUE
23171 C...Also collapse colours on JCP1 side of JCG1
23172  IF (jcp1.NE.0) THEN
23173  jccn(ncc+1,1)=max(jcp1,jcg1)
23174  jccn(ncc+1,2)=min(jcp1,jcg1)
23175  ELSE
23176  jccn(ncc+1,1)=max(jcp2,jcg2)
23177  jccn(ncc+1,2)=min(jcp2,jcg2)
23178  ENDIF
23179 
23180 C...Initialize event record colour tag array MCT array to MCO.
23181  DO 110 i=mint(84)+1,n
23182  mct(i,1)=mco(i,1)
23183  mct(i,2)=mco(i,2)
23184  110 CONTINUE
23185 
23186 C...Collapse tags:
23187 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
23188 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
23189 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
23190 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
23191  DO 160 is=1,4
23192 C...Skip if junction.
23193  IF ((is.EQ.4.AND.jcp2.EQ.0).OR.(is.EQ.3).AND.jcp1.EQ.0) goto 160
23194 C...Define starting point in tag space.
23195 C...JCA = previous tag
23196 C...JCO = present tag
23197 C...JCN = new tag
23198  IF (mod(is,2).EQ.1) THEN
23199  jco=jcp1
23200  jcn=jcg1
23201  jcall=jcg1
23202  ELSEIF (mod(is,2).EQ.0) THEN
23203  jco=jcp2
23204  jcn=jcg2
23205  jcall=jcg2
23206  ENDIF
23207  itrace=0
23208  120 itrace=itrace+1
23209  IF (itrace.GT.1000) THEN
23210 C...NB: Proper error message should be defined here.
23211  CALL pyerrm(14
23212  & ,'(PYMIHG:) Inf loop when collapsing colours.')
23213  mint(57)=mint(57)+1
23214  mint(51)=1
23215  RETURN
23216  ENDIF
23217 C...Collapse all JCN tags to JCALL
23218  DO 130 i=mint(84)+1,n
23219  IF (mco(i,1).EQ.jcn) mct(i,1)=jcall
23220  IF (mco(i,2).EQ.jcn) mct(i,2)=jcall
23221  130 CONTINUE
23222 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
23223  IF (is.GT.2.AND.(jcn.EQ.jcall)) THEN
23224  jca=jcn
23225  jcn=jco
23226  ELSE
23227  jca=jco
23228  jco=jcn
23229  ENDIF
23230 C...If possible, step from JCO to new tag JCN not equal to JCA.
23231  DO 140 icc=1,ncc+1
23232  IF (jccn(icc,1).EQ.jco.AND.jccn(icc,2).NE.jca) jcn=
23233  & jccn(icc,2)
23234  IF (jccn(icc,2).EQ.jco.AND.jccn(icc,1).NE.jca) jcn=
23235  & jccn(icc,1)
23236  140 CONTINUE
23237 C...Iterate if new colour was arrived at, but don't go in circles.
23238  IF (jcn.NE.jco.AND.jcn.NE.jcall) goto 120
23239 C...Change all JCN tags in MCO to JCALL in MCT.
23240  DO 150 i=mint(84)+1,n
23241  IF (mco(i,1).EQ.jcn) mct(i,1)=jcall
23242  IF (mco(i,2).EQ.jcn) mct(i,2)=jcall
23243 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23244  IF (k(i,2).EQ.21.AND.mct(i,1).EQ.mct(i,2).AND.mct(i,1)
23245  & .NE.0) maccpt=0
23246  150 CONTINUE
23247  160 CONTINUE
23248 
23249  DO 200 jcl=nct,1,-1
23250  jca=0
23251  jcn=jcl
23252  170 jco=jcn
23253  DO 180 icc=1,ncc+1
23254  IF (jccn(icc,1).EQ.jco.AND.jccn(icc,2).NE.jca) jcn
23255  & =jccn(icc,2)
23256  IF (jccn(icc,2).EQ.jco.AND.jccn(icc,1).NE.jca) jcn
23257  & =jccn(icc,1)
23258  180 CONTINUE
23259 C...Overpaint all JCN with JCL
23260  IF (jcn.NE.jco.AND.jcn.NE.jcl) THEN
23261  DO 190 i=mint(84)+1,n
23262  IF (mct(i,1).EQ.jcn) mct(i,1)=jcl
23263  IF (mct(i,2).EQ.jcn) mct(i,2)=jcl
23264 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23265  IF (k(i,2).EQ.21.AND.mct(i,1).EQ.mct(i,2).AND.mct(i,1)
23266  & .NE.0) maccpt=0
23267  190 CONTINUE
23268  jca=jco
23269  goto 170
23270  ENDIF
23271  200 CONTINUE
23272 
23273  RETURN
23274  END
23275 
23276 C*********************************************************************
23277 
23278 C...PYMIRM
23279 C...Picks primordial kT and shares longitudinal momentum among
23280 C...beam remnants.
23281 
23282  SUBROUTINE pymirm
23283 
23284 C...Double precision and integer declarations.
23285  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23286  IMPLICIT INTEGER(i-n)
23287  INTEGER pyk,pychge,pycomp
23288 C...The event record
23289  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23290 C...Parameters
23291  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23292  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23293  common/pyint1/mint(400),vint(400)
23294 C...The common block of colour tags.
23295  common/pyctag/nct,mct(4000,2)
23296 C...The common block of dangling ends
23297  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
23298  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
23299  & xmi(2,240),pt2mi(240),imisep(0:240)
23300  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyintm/,/pyctag/
23301 C...Local variables
23302  dimension w(0:2,0:2),vb(3),nnxt(2),ivalq(2),icomq(2)
23303 C...W(I,J)| J=0 | 1 | 2 |
23304 C... I=0 | Wrem**2 | W+ | W- |
23305 C... 1 | W1**2 | W1+ | W1- |
23306 C... 2 | W2**2 | W2+ | W2- |
23307 C...4-product
23308  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)
23309 C...Tentative parametrization of <kT> as a function of Q.
23310  sigpt(q)=max(parj(21),2.1d0*q/(7d0+q))
23311 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
23312 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
23313  getpt(q,sigma)=min(sigma*sqrt(-log(pyr(0))),parp(93))
23314 C...Lambda kinematic function.
23315  flam(a,b,c)=a**2+b**2+c**2-2d0*(a*b+b*c+c*a)
23316 
23317 C...Beginning and end of beam remnant partons
23318  nout=mint(53)
23319  isub=mint(1)
23320 
23321 C...Loopback point if kinematic choices gives impossible configuration.
23322  ntry=0
23323  100 ntry=ntry+1
23324 
23325 C...Assign kT values on each side separately.
23326  DO 180 js=1,2
23327 
23328 C...First zero all kT on this side. Skip if no kT to generate.
23329  DO 110 im=1,nmi(js)
23330  p(imi(js,im,1),1)=0d0
23331  p(imi(js,im,1),2)=0d0
23332  110 CONTINUE
23333  IF(mstp(91).LE.0) goto 180
23334 
23335 C...Now assign kT to each (non-collapsed) parton in IMI.
23336  DO 170 im=1,nmi(js)
23337  i=imi(js,im,1)
23338 C...Select kT according to truncated gaussian or 1/kt6 tails.
23339 C...For first interaction, either use rms width = PARP(91) or fitted.
23340  IF (im.EQ.1) THEN
23341  sigma=parp(91)
23342  IF (mstp(91).GE.11.AND.mstp(91).LE.20) THEN
23343  q=sqrt(pt2mi(im))
23344  sigma=sigpt(q)
23345  ENDIF
23346  ELSE
23347 C...For subsequent interactions and BR partons use fragmentation width.
23348  sigma=parj(21)
23349  ENDIF
23350  phi=paru(2)*pyr(0)
23351  pt=0d0
23352  IF(ntry.LE.100) THEN
23353  111 IF (mstp(91).EQ.1.OR.mstp(91).EQ.11) THEN
23354  pt=getpt(q,sigma)
23355  ptx=pt*cos(phi)
23356  pty=pt*sin(phi)
23357  ELSEIF (mstp(91).EQ.2) THEN
23358  CALL pyerrm(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
23359  & 'available, using MSTP(91)=1.')
23360  CALL pygive('MSTP(91)=1')
23361  goto 111
23362  ELSEIF(mstp(91).EQ.3.OR.mstp(91).EQ.13) THEN
23363 C...Use distribution with kt**6 tails, rms width = PARP(91).
23364  eps=sqrt(3d0/2d0)*sigma
23365 C...Generate PTX and PTY separately, each propto 1/KT**6
23366  DO 119 ixy=1,2
23367 C...Decide which interval to try
23368  112 p12=1d0/(1d0+27d0/40d0*sigma**6/eps**6)
23369  IF (pyr(0).LT.p12) THEN
23370 C...Use flat approx with accept/reject up to EPS.
23371  pt=pyr(0)*eps
23372  wt=(3d0/2d0*sigma**2/(pt**2+3d0/2d0*sigma**2))**3
23373  IF (pyr(0).GT.wt) goto 112
23374  ELSE
23375 C...Above EPS, use 1/kt**6 approx with accept/reject.
23376  pt=eps/(pyr(0)**(1d0/5d0))
23377  wt=pt**6/(pt**2+3d0/2d0*sigma**2)**3
23378  IF (pyr(0).GT.wt) goto 112
23379  ENDIF
23380  msign=1
23381  IF (pyr(0).GT.0.5d0) msign=-1
23382  IF (ixy.EQ.1) ptx=msign*pt
23383  IF (ixy.EQ.2) pty=msign*pt
23384  119 CONTINUE
23385  ELSEIF (mstp(91).EQ.4.OR.mstp(91).EQ.14) THEN
23386  ptx=sigma*(sqrt(6d0)*pyr(0)-sqrt(3d0/2d0))
23387  pty=sigma*(sqrt(6d0)*pyr(0)-sqrt(3d0/2d0))
23388  ENDIF
23389 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
23390  pt=sqrt(ptx**2+pty**2)
23391  wt=1d0
23392  IF (pt.GT.parp(93)) wt=sqrt(parp(93)/pt)
23393  IF(isub.EQ.95.AND.im.EQ.1) wt=0d0
23394  ptx=ptx*wt
23395  pty=pty*wt
23396  pt=sqrt(ptx**2+pty**2)
23397  ENDIF
23398 
23399  p(i,1)=p(i,1)+ptx
23400  p(i,2)=p(i,2)+pty
23401 
23402 C...Compensation kicks, with varying degree of local anticorrelations.
23403  mcorr=mstp(90)
23404  IF (mcorr.EQ.0.OR.isub.EQ.95) THEN
23405  ptcx=-ptx/(nmi(js)-1)
23406  ptcy=-pty/(nmi(js)-1)
23407  IF(isub.EQ.95) THEN
23408  ptcx=-ptx/(nmi(js)-2)
23409  ptcy=-pty/(nmi(js)-2)
23410  ENDIF
23411  DO 120 imc=1,nmi(js)
23412  IF (imc.EQ.im) goto 120
23413  IF(isub.EQ.95.AND.imc.EQ.1) goto 120
23414  p(imi(js,imc,1),1)=p(imi(js,imc,1),1)+ptcx
23415  p(imi(js,imc,1),2)=p(imi(js,imc,1),2)+ptcy
23416  120 CONTINUE
23417  ELSEIF (mcorr.GE.1) THEN
23418  DO 140 msid=4,5
23419  nnxt(msid-3)=0
23420 C...Count up # of neighbours on either side
23421  imo=i
23422  130 imo=k(imo,msid)/mstu(5)
23423  IF (imo.EQ.0) goto 140
23424  nnxt(msid-3)=nnxt(msid-3)+1
23425 C...Stop at quarks and junctions
23426  IF (mcorr.EQ.1.AND.k(imo,2).EQ.21) goto 130
23427  140 CONTINUE
23428 C...How should compensation be shared when unequal numbers on the
23429 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
23430  nsum=nnxt(1)+nnxt(2)
23431  t1=0
23432  DO 160 msid=4,5
23433 C...Total momentum to be compensated on this side
23434  IF (nnxt(msid-3).EQ.0) goto 160
23435  ptcx=-(nnxt(msid-3)*ptx)/nsum
23436  ptcy=-(nnxt(msid-3)*pty)/nsum
23437 C...RS: compensation supression factor as we go out from parton I.
23438 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
23439 C...since (for now) MSTP(90) provides enough variability.
23440  rs=0.5d0
23441  fac=(1d0-rs)/(rs*(1-rs**nnxt(msid-3)))
23442  imo=i
23443  150 ida=imo
23444  imo=k(imo,msid)/mstu(5)
23445  IF (imo.EQ.0) goto 160
23446  fac=fac*rs
23447  IF (k(imo,2).NE.88) THEN
23448  p(imo,1)=p(imo,1)+fac*ptcx
23449  p(imo,2)=p(imo,2)+fac*ptcy
23450  IF (mcorr.EQ.1.AND.k(imo,2).EQ.21) goto 150
23451 C...If we reach junction, divide out the kT that would have been
23452 C...assigned to the junction on each of its other legs.
23453  ELSE
23454  l1=mod(k(imo,4),mstu(5))
23455  l2=k(imo,5)/mstu(5)
23456  l3=mod(k(imo,5),mstu(5))
23457  p(l1,1)=p(l1,1)+0.5d0*fac*ptcx
23458  p(l1,2)=p(l1,2)+0.5d0*fac*ptcy
23459  p(l2,1)=p(l2,1)+0.5d0*fac*ptcx
23460  p(l2,2)=p(l2,2)+0.5d0*fac*ptcy
23461  p(l3,1)=p(l3,1)+0.5d0*fac*ptcx
23462  p(l3,2)=p(l3,2)+0.5d0*fac*ptcy
23463  p(ida,1)=p(ida,1)-0.5d0*fac*ptcx
23464  p(ida,2)=p(ida,2)-0.5d0*fac*ptcy
23465  ENDIF
23466 
23467  160 CONTINUE
23468  ENDIF
23469  170 CONTINUE
23470 C...End assignment of kT values to initiators and remnants.
23471  180 CONTINUE
23472 
23473 C...Check kinematics constraints for non-BR partons.
23474  DO 190 im=1,mint(31)
23475  shat=xmi(1,im)*xmi(2,im)*vint(2)
23476  pt1=sqrt(p(imi(1,im,1),1)**2+p(imi(1,im,1),2)**2)
23477  pt2=sqrt(p(imi(2,im,1),1)**2+p(imi(2,im,1),2)**2)
23478  pt1pt2=p(imi(1,im,1),1)*p(imi(2,im,1),1)
23479  & +p(imi(1,im,1),2)*p(imi(2,im,1),2)
23480  IF (shat.LT.2d0*(pt1*pt2-pt1pt2).AND.ntry.LE.100) THEN
23481  IF(ntry.GE.100) THEN
23482 C...Kill this event and start another.
23483  CALL pyerrm(1,
23484  & '(PYMIRM:) No consistent (x,kT) sets found')
23485  mint(51)=1
23486  RETURN
23487  ENDIF
23488  goto 100
23489  ENDIF
23490  190 CONTINUE
23491 
23492 C...Calculate W+ and W- available for combined remnant system.
23493  w(0,1)=vint(1)
23494  w(0,2)=vint(1)
23495  DO 200 im=1,mint(31)
23496  pt2 = (p(imi(1,im,1),1)+p(imi(2,im,1),1))**2
23497  & +(p(imi(1,im,1),2)+p(imi(2,im,1),2))**2
23498  st=xmi(1,im)*xmi(2,im)*vint(2)+pt2
23499  w(0,1)=w(0,1)-sqrt(xmi(1,im)/xmi(2,im)*st)
23500  w(0,2)=w(0,2)-sqrt(xmi(2,im)/xmi(1,im)*st)
23501  200 CONTINUE
23502 C...Also store Wrem**2 = W+ * W-
23503  w(0,0)=w(0,1)*w(0,2)
23504 
23505  IF ((w(0,0).LT.0d0.OR.w(0,1)+w(0,2).LT.0d0).AND.ntry.LE.100) THEN
23506  IF(ntry.GE.100) THEN
23507 C...Kill this event and start another.
23508  CALL pyerrm(1,
23509  & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23510  mint(51)=1
23511  RETURN
23512  ENDIF
23513  goto 100
23514  ENDIF
23515 
23516 C...Assign unscaled x values to partons/hadrons in each of the
23517 C...beam remnants and calculate unscaled W+ and W- from them.
23518  ntryx=0
23519  210 ntryx=ntryx+1
23520  DO 280 js=1,2
23521  w(js,1)=0d0
23522  w(js,2)=0d0
23523  DO 270 im=mint(31)+1,nmi(js)
23524  i=imi(js,im,1)
23525  kf=k(i,2)
23526  kfa=iabs(kf)
23527  icomp=imi(js,im,2)
23528 
23529 C...Skip collapsed gluons and junctions. Reset.
23530  IF (kfa.EQ.21.AND.k(i,1).EQ.14) goto 270
23531  IF (kfa.EQ.88) goto 270
23532  x=0d0
23533  ivalq(1)=0
23534  ivalq(2)=0
23535  icomq(1)=0
23536  icomq(2)=0
23537 
23538 C...If gluon then only beam remnant, so takes all.
23539  IF(kfa.EQ.21) THEN
23540  x=1d0
23541 C...If valence quark then use parametrized valence distribution.
23542  ELSEIF(kfa.LE.6.AND.icomp.EQ.0) THEN
23543  ivalq(1)=kf
23544 C...If companion quark then derive from companion x.
23545  ELSEIF(kfa.LE.6) THEN
23546  icomq(1)=icomp
23547 C...If valence diquark then use two parametrized valence distributions.
23548  ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0.AND.
23549  & icomp.EQ.0) THEN
23550  ivalq(1)=isign(kfa/1000,kf)
23551  ivalq(2)=isign(mod(kfa/100,10),kf)
23552 C...If valence+sea diquark then combine valence + companion choices.
23553  ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0.AND.
23554  & icomp.LT.mstu(5)) THEN
23555  IF(kfa/1000.EQ.iabs(k(icomp,2))) THEN
23556  ivalq(1)=isign(mod(kfa/100,10),kf)
23557  ELSE
23558  ivalq(1)=isign(kfa/1000,kf)
23559  ENDIF
23560  icomq(1)=icomp
23561 C...Extra code: workaround for diquark made out of two sea
23562 C...quarks, but where not (yet) ICOMP > MSTU(5).
23563  DO 220 im1=1,mint(31)
23564  IF(imi(js,im1,2).EQ.i.AND.imi(js,im1,1).NE.icomp) THEN
23565  icomq(2)=imi(js,im1,1)
23566  ivalq(1)=0
23567  ENDIF
23568  220 CONTINUE
23569 C...If sea diquark then sum of two derived from companion x.
23570  ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0) THEN
23571  icomq(1)=mod(icomp,mstu(5))
23572  icomq(2)=icomp/mstu(5)
23573 C...If meson or baryon then use fragmentation function.
23574 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23575  ELSE
23576  kfl3=mod(kfa/10,10)
23577  IF(mod(kfa/1000,10).EQ.0) THEN
23578  kfl1=mod(kfa/100,10)
23579  ELSE
23580  kfl1=mod(kfa,10000)-10*kfl3-1
23581  IF(mod(kfa/1000,10).EQ.mod(kfa/100,10).AND.
23582  & mod(kfa,10).EQ.2) kfl1=kfl1+2
23583  ENDIF
23584  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
23585  CALL pyzdis(kfl1,kfl3,pr,x)
23586  ENDIF
23587 
23588  DO 260 iq=1,2
23589 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23590 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23591 C...In other baryons combine u and d from proton appropriately.
23592  IF(ivalq(iq).NE.0) THEN
23593  nval=0
23594  IF(kfival(js,1).EQ.ivalq(iq)) nval=nval+1
23595  IF(kfival(js,2).EQ.ivalq(iq)) nval=nval+1
23596  IF(kfival(js,3).EQ.ivalq(iq)) nval=nval+1
23597 C...Meson.
23598  IF(kfival(js,3).EQ.0) THEN
23599  mdu=0
23600 C...Baryon with three identical quarks: mix u and d forms.
23601  ELSEIF(nval.EQ.3) THEN
23602  mdu=int(pyr(0)+5d0/3d0)
23603 C...Baryon, one of two identical quarks: u form.
23604  ELSEIF(nval.EQ.2) THEN
23605  mdu=2
23606 C...Baryon with two identical quarks, but not the one picked: d form.
23607  ELSEIF(kfival(js,1).EQ.kfival(js,2).OR.kfival(js,2).EQ.
23608  & kfival(js,3).OR.kfival(js,1).EQ.kfival(js,3)) THEN
23609  mdu=1
23610 C...Baryon with three nonidentical quarks: mix u and d forms.
23611  ELSE
23612  mdu=int(pyr(0)+5d0/3d0)
23613  ENDIF
23614  xpow=0.8d0
23615  IF(mdu.EQ.1) xpow=3.5d0
23616  IF(mdu.EQ.2) xpow=2d0
23617  230 xx=pyr(0)**2
23618  IF((1d0-xx)**xpow.LT.pyr(0)) goto 230
23619  x=x+xx
23620  ENDIF
23621 
23622 C...Calculation of x of companion quark.
23623  IF(icomq(iq).NE.0) THEN
23624  xcomp=1d-4
23625  DO 240 im1=1,mint(31)
23626  IF(imi(js,im1,1).EQ.icomq(iq)) xcomp=xmi(js,im1)
23627  240 CONTINUE
23628  npow=max(0,min(4,mstp(87)))
23629  250 xx=xcomp*(1d0/(1d0-pyr(0)*(1d0-xcomp))-1d0)
23630  corr=((1d0-xcomp-xx)/(1d0-xcomp))**npow*
23631  & (xcomp**2+xx**2)/(xcomp+xx)**2
23632  IF(corr.LT.pyr(0)) goto 250
23633  x=x+xx
23634  ENDIF
23635  260 CONTINUE
23636 
23637 C...Optionally enchance x of composite systems (e.g. diquarks)
23638  IF (kfa.GT.100) x=parp(79)*x
23639 
23640 C...Store x. Also calculate light cone energies of each system.
23641  xmi(js,im)=x
23642  w(js,js)=w(js,js)+x
23643  w(js,3-js)=w(js,3-js)+(p(i,5)**2+p(i,1)**2+p(i,2)**2)/x
23644  270 CONTINUE
23645  w(js,js)=w(js,js)*w(0,js)
23646  w(js,3-js)=w(js,3-js)/w(0,js)
23647  w(js,0)=w(js,1)*w(js,2)
23648  280 CONTINUE
23649 
23650 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23651 C...insensitive to global rescalings of the BR x values).
23652  IF (sqrt(w(1,0))+sqrt(w(2,0)).GT.sqrt(w(0,0)).AND.ntryx.LE.100)
23653  & THEN
23654  goto 210
23655  ELSEIF (ntryx.GT.100.AND.ntry.LE.100) THEN
23656  goto 100
23657  ELSEIF (ntryx.GT.100) THEN
23658  CALL pyerrm(1,'(PYMIRM:) No consistent (x,kT) sets found')
23659  mint(57)=mint(57)+1
23660  mint(51)=1
23661  RETURN
23662  ENDIF
23663 
23664 C...Compute x rescaling factors
23665  comtrm=w(0,0)+sqrt(flam(w(0,0),w(1,0),w(2,0)))
23666  r1=(comtrm+w(1,0)-w(2,0))/(2d0*w(1,1)*w(0,2))
23667  r2=(comtrm+w(2,0)-w(1,0))/(2d0*w(2,2)*w(0,1))
23668 
23669  IF (r1.LT.0.OR.r2.LT.0) THEN
23670  CALL pyerrm(19,'(PYMIRM:) negative rescaling factors !')
23671  mint(57)=mint(57)+1
23672  mint(51)=1
23673  ENDIF
23674 
23675 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23676  w(1,1)=w(1,1)*r1
23677  w(1,2)=w(1,2)/r1
23678  w(2,1)=w(2,1)/r2
23679  w(2,2)=w(2,2)*r2
23680 
23681 C...Rescale BR x values.
23682  DO 290 im=mint(31)+1,max(nmi(1),nmi(2))
23683  xmi(1,im)=xmi(1,im)*r1
23684  xmi(2,im)=xmi(2,im)*r2
23685  290 CONTINUE
23686 
23687 C...Now we have a consistent set of x and kT values.
23688 C...First set up the initiators and their daughters correctly.
23689  DO 300 im=1,mint(31)
23690  i1=imi(1,im,1)
23691  i2=imi(2,im,1)
23692  st=xmi(1,im)*xmi(2,im)*vint(2)+(p(i1,1)+p(i2,1))**2+
23693  & (p(i1,2)+p(i2,2))**2
23694  pt12=p(i1,1)**2+p(i1,2)**2
23695  pt22=p(i2,1)**2+p(i2,2)**2
23696 C...p_z
23697  p(i1,3)=sqrt(flam(st,pt12,pt22)/(4d0*st))
23698  p(i2,3)=-p(i1,3)
23699 C...Energies (masses should be zero at this stage)
23700  p(i1,4)=sqrt(pt12+p(i1,3)**2)
23701  p(i2,4)=sqrt(pt22+p(i2,3)**2)
23702 
23703 C...Transverse 12 system initiator velocity:
23704  vb(1)=(p(i1,1)+p(i2,1))/sqrt(st)
23705  vb(2)=(p(i1,2)+p(i2,2))/sqrt(st)
23706 C...Boost to overall initiator system rest frame
23707  CALL pyrobo(i1,i1,0d0,0d0,-vb(1),-vb(2),0d0)
23708  CALL pyrobo(i2,i2,0d0,0d0,-vb(1),-vb(2),0d0)
23709 
23710 C...Compute phi,theta coordinates of I1 and rotate z axis.
23711  phi=pyangl(p(i1,1),p(i1,2))
23712  the=pyangl(p(i1,3),sqrt(p(i1,1)**2+p(i1,2)**2))
23713  imin=imisep(im-1)+1
23714 C...(include documentation lines if MI = 1)
23715  IF (im.EQ.1) imin=mint(83)+5
23716  imax=imisep(im)
23717 C...Rotate entire system in phi
23718  CALL pyrobo(imin,imax,0d0,-phi,0d0,0d0,0d0)
23719 C...Only rotate 12 system in theta
23720  CALL pyrobo(i1,i1,-the,0d0,0d0,0d0,0d0)
23721  CALL pyrobo(i2,i2,-the,0d0,0d0,0d0,0d0)
23722 
23723 C...Now boost entire system back to LAB
23724  vb(3)=(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
23725  CALL pyrobo(imin,imax,the,phi,vb(1),vb(2),0d0)
23726  CALL pyrobo(imin,imax,0d0,0d0,0d0,0d0,vb(3))
23727 
23728  300 CONTINUE
23729 
23730 
23731 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23732  DO 320 js=1,2
23733  DO 310 im=mint(31)+1,nmi(js)
23734  i=imi(js,im,1)
23735 C...Skip collapsed gluons and junctions.
23736  IF (k(i,2).EQ.21.AND.k(i,1).EQ.14) goto 310
23737  IF (kfa.EQ.88) goto 310
23738  rmt2=p(i,5)**2+p(i,1)**2+p(i,2)**2
23739  p(i,4)=0.5d0*(xmi(js,im)*w(0,js)+rmt2/(xmi(js,im)*w(0,js)))
23740  p(i,3)=0.5d0*(xmi(js,im)*w(0,js)-rmt2/(xmi(js,im)*w(0,js)))
23741  IF (js.EQ.2) p(i,3)=-p(i,3)
23742  310 CONTINUE
23743  320 CONTINUE
23744 
23745 
23746 C...Documentation lines
23747  DO 340 js=1,2
23748  in=mint(83)+js+2
23749  io=imi(js,1,1)
23750  k(in,1)=21
23751  k(in,2)=k(io,2)
23752  k(in,3)=mint(83)+js
23753  k(in,4)=0
23754  k(in,5)=0
23755  DO 330 j=1,5
23756  p(in,j)=p(io,j)
23757  v(in,j)=v(io,j)
23758  330 CONTINUE
23759  mct(in,1)=mct(io,1)
23760  mct(in,2)=mct(io,2)
23761  340 CONTINUE
23762 
23763 C...Final state colour reconnections.
23764  IF (mstp(95).NE.1.OR.mint(31).LE.1) goto 380
23765 
23766 C...Number of colour tags for which a recoupling will be tried.
23767  ntot=nct
23768 C...Number of recouplings to try
23769  mint(34)=0
23770  nrecp=0
23771  niter=0
23772  350 nrecp=mint(34)
23773  niter=niter+1
23774  iiter=0
23775  360 iiter=iiter+1
23776  IF (iiter.LE.parp(78)*ntot) THEN
23777 C...Select two colour tags at random
23778 C...NB: jj strings do not have colour tags assigned to them,
23779 C...thus they are as yet not affected by anything done here.
23780  jct=pyr(0)*nct+1
23781  kct=mod(int(jct+pyr(0)*nct),nct)+1
23782  ij1=0
23783  ij2=0
23784  ik1=0
23785  ik2=0
23786 C...Find final state partons with this (anti)colour
23787  DO 370 i=mint(84)+1,n
23788  IF (k(i,1).EQ.3) THEN
23789  IF (mct(i,1).EQ.jct) ij1=i
23790  IF (mct(i,2).EQ.jct) ij2=i
23791  IF (mct(i,1).EQ.kct) ik1=i
23792  IF (mct(i,2).EQ.kct) ik2=i
23793  ENDIF
23794  370 CONTINUE
23795 C...Only consider recouplings not involving junctions for now.
23796  IF (ij1.EQ.0.OR.ij2.EQ.0.OR.ik1.EQ.0.OR.ik2.EQ.0) goto 360
23797 
23798  rlo=2d0*four(ij1,ij2)*2d0*four(ik1,ik2)
23799  rln=2d0*four(ij1,ik2)*2d0*four(ik1,ij2)
23800  IF (rln.LT.rlo.AND.mct(ij2,1).NE.kct.AND.mct(ik2,1).NE.jct) THEN
23801  mct(ij2,2)=kct
23802  mct(ik2,2)=jct
23803 C...Count up number of reconnections
23804  mint(34)=mint(34)+1
23805  ENDIF
23806  IF (mint(34).LE.1000) THEN
23807  goto 360
23808  ELSE
23809  CALL pyerrm(4,'(PYMIRM:) caught in infinite loop')
23810  goto 380
23811  ENDIF
23812  ENDIF
23813  IF (nrecp.LT.mint(34)) goto 350
23814 
23815 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23816  380 mint(33)=1
23817 
23818  RETURN
23819  END
23820 
23821 C*********************************************************************
23822 
23823 C...PYFSCR
23824 C...Performs colour annealing.
23825 C...MSTP(95) : CR Type
23826 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23827 C... = 2 : Type I(no gg loops); hadron-hadron only
23828 C... = 3 : Type I(no gg loops); all beams
23829 C... = 4 : Type II(gg loops) ; hadron-hadron only
23830 C... = 5 : Type II(gg loops) ; all beams
23831 C... = 6 : Type S ; hadron-hadron only
23832 C... = 7 : Type S ; all beams
23833 C... = 8 : Type P ; hadron-hadron only
23834 C... = 9 : Type P ; all beams
23835 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23836 C...Type S is driven by starting only from free triplets, not octets.
23837 C...Type P is also driven by free triplets, but the reconnect probability
23838 C...is computed from the string density per unit rapidity, where the axis
23839 C...with respect to which the rapidity is computed is the Thrust axis of the
23840 C...event.
23841 C...A string piece remains unchanged with probability
23842 C... PKEEP = (1-PARP(78))**N
23843 C...This scaling corresponds to each string piece having to go through
23844 C...N other ones, each with probability PARP(78) for reconnection.
23845 C...For types I, II, and S, N is chosen simply as the number of multiple
23846 C...interactions, for a rough scaling with the general level of activity.
23847 C...For type P, N is chosen to be the number of string pieces in a given
23848 C...interval of rapidity (minus one, since the string doesn't reconnect
23849 C...with itself), and the reconnect probability is interpreted as the
23850 C...probability per unit rapidity.
23851 C...It also also possible to apply a dampening factor to the CR strength,
23852 C...using PARP(77), which will cause reconnections among high-pT string
23853 C...pieces to be suppressed.
23854 
23855  SUBROUTINE pyfscr(IP)
23856 C...Double precision and integer declarations.
23857  IMPLICIT DOUBLE PRECISION(a-h, o-z)
23858  INTEGER pyk,pychge,pycomp
23859 C...Commonblocks.
23860  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23861  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23862  common/pypars/mstp(200),parp(200),msti(200),pari(200)
23863  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
23864  common/pyint1/mint(400),vint(400)
23865 C...The common block of colour tags.
23866  common/pyctag/nct,mct(4000,2)
23867  SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/,/pyctag/,
23868  &/pypars/
23869 C...MCN: Temporary storage of new colour tags
23870  INTEGER mcn(4000,2)
23871 C...Arrays for storing color strings
23872  parameter(nbiny=100)
23873  INTEGER icr(4000),mscr(4000)
23874  INTEGER iopt(4000), nstry(nbiny)
23875  DOUBLE PRECISION rloptc(4000)
23876 
23877 C...Function to give four-product.
23878  four(i,j)=p(i,4)*p(j,4)
23879  & -p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)
23880 
23881 C...Check valid range of MSTP(95), local copy
23882  IF (mstp(95).LE.1.OR.mstp(95).GE.10) RETURN
23883  mstp95=mod(mstp(95),10)
23884 C...Set whether CR allowed inside resonance systems or not
23885 C...(not implemented yet)
23886 C MRESCR=1
23887 C IF (MSTP(95).GE.10) MRESCR=0
23888 
23889 C...Check whether colour tags already defined
23890  IF (mint(33).EQ.0) THEN
23891 C...Erase any existing colour tags for this event
23892  DO 100 i=1,n
23893  mct(i,1)=0
23894  mct(i,2)=0
23895  100 CONTINUE
23896 C...Create colour tags for this event
23897  DO 120 i=1,n
23898  IF (k(i,1).EQ.3) THEN
23899  DO 110 kcs=4,5
23900  kcsin=kcs
23901  IF (mct(i,kcsin-3).EQ.0) THEN
23902  CALL pycttr(i,kcsin,i)
23903  ENDIF
23904  110 CONTINUE
23905  ENDIF
23906  120 CONTINUE
23907 C...Instruct PYPREP to use colour tags
23908  mint(33)=1
23909  ENDIF
23910 
23911 C...For MSTP(95) even, only apply to hadron-hadron
23912  ka1=iabs(mint(11))
23913  ka2=iabs(mint(12))
23914  IF (mod(mstp(95),2).EQ.0.AND.(ka1.LT.100.OR.ka2.LT.100)) goto 9999
23915 
23916 C...Initialize new tag array (but do not delete old yet)
23917  lct=nct
23918  DO 130 i=max(1,ip),n
23919  mcn(i,1)=0
23920  mcn(i,2)=0
23921  130 CONTINUE
23922 
23923 C...For Paquis type, determine thrust axis (default along Z axis)
23924  tx=0d0
23925  ty=0d0
23926  tz=1d0
23927  IF (mstp95.GE.8) THEN
23928  CALL pythru(thrdum,obldum)
23929  tx = p(n+1,1)
23930  ty = p(n+1,2)
23931  tz = p(n+1,3)
23932  ENDIF
23933 
23934 C...For each final-state dipole, check whether string should be
23935 C...preserved.
23936  ncr=0
23937  ia=0
23938  ic=0
23939  rapmax=0.0
23940 
23941  ictmin=nct
23942  DO 150 ict=1,nct
23943  ia=0
23944  ic=0
23945  DO 140 i=max(1,ip),n
23946  IF (k(i,1).EQ.3.AND.mct(i,1).EQ.ict) ic=i
23947  IF (k(i,1).EQ.3.AND.mct(i,2).EQ.ict) ia=i
23948  140 CONTINUE
23949  IF (ic.NE.0.AND.ia.NE.0) THEN
23950 C...Save smallest NCT value so far
23951  ictmin = min(ictmin,ict)
23952 C...For Paquis algorithm, just store all string pieces for now
23953  IF (mstp95.GE.8) THEN
23954 C... Add coloured parton
23955  ncr=ncr+1
23956  icr(ncr)=ic
23957  mscr(ncr)=1
23958  iopt(ncr)=0
23959 C... Store rapidity (along Thrust axis) in RLOPT for the time being
23960 C... Add pion mass headroom to energy for this calculation
23961  eet = p(ic,4)*sqrt(1d0+(0.135d0/p(ic,4))**2)
23962  pzt = p(ic,1)*tx+p(ic,2)*ty+p(ic,3)*tz
23963  rloptc(ncr)=log((eet+pzt)/(eet-pzt))
23964 C... Add anti-coloured parton
23965  ncr = ncr+1
23966  icr(ncr) = ia
23967  mscr(ncr) = 2
23968  iopt(ncr) = 0
23969 C... Store rapidity (along Thrust axis) in RLOPT for the time being
23970  eet = p(ia,4)*sqrt(1d0+(0.135d0/p(ia,4))**2)
23971  pzt = p(ia,1)*tx+p(ia,2)*ty+p(ia,3)*tz
23972  rloptc(ncr)=log((eet+pzt)/(eet-pzt))
23973 C... Keep track of largest endpoint "rapidity"
23974  rapmax = max(rapmax,abs(rloptc(ncr)))
23975  rapmax = max(rapmax,abs(rloptc(ncr-1)))
23976  ELSE
23977  crmodf=1d0
23978 C... Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23979 C... (so far ignores the possibility that the whole "muck" may be moving.)
23980  IF (parp(77).GT.0d0) THEN
23981  pt2str=(p(ia,1)+p(ic,1))**2+(p(ia,2)+p(ic,2))**2
23982 C... For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23983  IF (ka1.LT.100.AND.ka2.LT.100) THEN
23984  p2str = pt2str + (p(ia,3)+p(ic,3))**2
23985  ELSE
23986  p2str = 3d0/2d0 * pt2str
23987  ENDIF
23988  rm2str=(p(ia,4)+p(ic,4))**2-(p(ia,3)+p(ic,3))**2-pt2str
23989  rm2str=max(rm2str,pmas(pycomp(111),1)**2)
23990 C... Estimate number of particles ~ log(M2), cut off at 1.
23991  rlogm2=max(1d0,log(rm2str))
23992  p2avg=p2str/rlogm2
23993 C... Supress reconnection probability by 1/(1+P77*P2AVG)
23994  crmodf=1d0/(1d0+parp(77)**2*p2avg)
23995  ENDIF
23996  pkeep=(1d0-parp(78)*crmodf)**mint(31)
23997  IF (pyr(0).LE.pkeep) THEN
23998  lct=lct+1
23999  mcn(ic,1)=lct
24000  mcn(ia,2)=lct
24001  ELSE
24002 C... Add coloured parton
24003  ncr=ncr+1
24004  icr(ncr)=ic
24005  mscr(ncr)=1
24006  iopt(ncr)=0
24007  rloptc(ncr)=1d19
24008 C... Add anti-coloured parton
24009  ncr=ncr+1
24010  icr(ncr)=ia
24011  mscr(ncr)=2
24012  iopt(ncr)=0
24013  rloptc(ncr)=1d19
24014  ENDIF
24015  ENDIF
24016  ENDIF
24017  150 CONTINUE
24018 
24019 C...PAQUIS TYPE
24020  IF (mstp95.GE.8) THEN
24021 C... For Paquis type, make "histogram" of string densities along thrust axis
24022  rapmin = -rapmax
24023  drap = 2*rapmax/(1d0*nbiny)
24024 C... Explicitly zero histogram bin content
24025  DO 160 ibiny=1,nbiny
24026  nstry(ibiny)=0
24027  160 CONTINUE
24028  DO 180 istr=1,ncr-1,2
24029  ic = icr(istr)
24030  ia = icr(istr+1)
24031  y1 = min(rloptc(istr),rloptc(istr+1))
24032  y2 = max(rloptc(istr),rloptc(istr+1))
24033  DO 170 ibiny=1,nbiny
24034  ybinlo = rapmin + (ibiny-1)*drap
24035 C... If bin inside string piece, add 1 in this bin
24036 C... (Strictly speaking: if it starts before midpoint and ends after midpoint)
24037  IF (y1.LE.ybinlo+0.5*drap.AND.y2.GE.ybinlo+0.5*drap)
24038  & nstry(ibiny) = nstry(ibiny) + 1
24039  170 CONTINUE
24040  180 CONTINUE
24041 C... Loop over pieces to find individual reconnect probability
24042  DO 200 is=1,ncr-1,2
24043  dnsum = 0d0
24044  dnavg = 0d0
24045 C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX
24046  rbinlo = (min(rloptc(is),rloptc(is+1))-rapmin)/drap + 0.5
24047  rbinhi = (max(rloptc(is),rloptc(is+1))-rapmin)/drap + 0.5
24048 C...Make sure integer bin numbers lie inside proper range
24049  ibinlo = max(1,min(nbiny,nint(rbinlo)))
24050  ibinhi = max(1,min(nbiny,nint(rbinhi)))
24051 C...Size of rapidity bins (is < DRAP if piece smaller than one bin)
24052 C...(also smaller than DRAP if a one-unit wide piece is stretched
24053 C... over 2 bins, thus making the computation more accurate)
24054  drapav = (rbinhi-rbinlo)/(ibinhi-ibinlo+1)*drap
24055 C... Decide whether to suppress reconnections in high-pT string pieces
24056  crmodf = 1d0
24057  IF (parp(77).GT.0d0) THEN
24058 C... Total string piece energy, momentum squared, and components
24059  ees = p(icr(is),4) + p(icr(is+1),4)
24060  pps2 = (p(icr(is),1)+ p(icr(is+1),1))**2
24061  & + (p(icr(is),2)+ p(icr(is+1),2))**2
24062  & + (p(icr(is),3)+ p(icr(is+1),3))**2
24063  pzts = p(icr(is),1)*tx+p(icr(is),2)*ty+p(icr(is),3)*tz
24064  & + p(icr(is+1),1)*tx+p(icr(is+1),2)*ty+p(icr(is+1),3)*tz
24065  ptts = sqrt(pps2 - pzts**2)
24066 C... Mass of string piece in units of mpi (at least 1)
24067  rmpi2 = 0.135d0
24068  rm2str = max(rmpi2,ees**2 - pps2)
24069 C... Estimate number of pions ~ log(M2) (at least 1)
24070  rnpi = log(rm2str/rmpi2)+1d0
24071  pt2avg = (ptts / rnpi)**2
24072 C... Supress reconnection probability by 1/(1+P77*P2AVG)
24073  crmodf=1d0/(1d0+parp(77)**2*pt2avg)
24074  ENDIF
24075  pkeep = 1.0
24076  DO 190 ibiny=ibinlo,ibinhi
24077 C DNSUM = DNSUM + 1D0
24078  dnovl = max(0,nstry(ibiny)-1)
24079  pkeep = pkeep * (1d0-crmodf*parp(78))**(drapav*dnovl)
24080 C DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
24081  190 CONTINUE
24082 C DNAVG = DNAVG / DNSUM
24083 C... If keeping string piece, save
24084  IF (pyr(0).LE.pkeep) THEN
24085  lct = lct+1
24086  mcn(icr(is),1)=lct
24087  mcn(icr(is+1),2)=lct
24088  ENDIF
24089  200 CONTINUE
24090  ENDIF
24091 
24092 C...Skip if there is only one possibility
24093  IF (ncr.LE.2) THEN
24094  goto 9999
24095  ENDIF
24096 
24097 C...Reorder, so ordered in I (in order to correspond to old algorithm)
24098  nloop=0
24099  210 nloop=nloop+1
24100  mord=1
24101  DO 220 ic1=1,ncr-1
24102  i1=icr(ic1)
24103  i2=icr(ic1+1)
24104  IF (i1.GT.i2) THEN
24105  it=i1
24106  mst=mscr(ic1)
24107  icr(ic1)=i2
24108  mscr(ic1)=mscr(ic1+1)
24109  icr(ic1+1)=it
24110  mscr(ic1+1)=mst
24111  mord=0
24112  ENDIF
24113  220 CONTINUE
24114 C...Max do 1000 reordering loops
24115  IF (mord.EQ.0.AND.nloop.LE.1000) goto 210
24116 
24117 C...PS: 03 May 2010
24118 C...For Seattle and Paquis types, check if there is a dangling tag
24119 C...Needed for special case when entire reconnected state was one or
24120 C...more gluon loops in original topology in which case these CR
24121 C...algorithms need to be told they shouldn't look for a dangling tag.
24122  m3free=0
24123  IF (mstp95.GE.6.AND.mstp95.LE.9) THEN
24124  DO 230 ic1=1,ncr
24125  i1=icr(ic1)
24126 C...Color charge
24127  mci=kchg(pycomp(k(i1,2)),2)*isign(1,k(i1,2))
24128  IF (mci.EQ.1.AND.mcn(i1,1).EQ.0) m3free=1
24129  IF (mci.EQ.-1.AND.mcn(i1,2).EQ.0) m3free=1
24130  IF (mci.EQ.2) THEN
24131  IF (mcn(i1,1).NE.0.AND.mcn(i1,2).EQ.0) m3free=1
24132  IF (mcn(i1,2).NE.0.AND.mcn(i1,1).EQ.0) m3free=1
24133  ENDIF
24134  230 CONTINUE
24135  ENDIF
24136 
24137 C...Loop over CR partons
24138 C...(Ignore junctions for now.)
24139  nloop=0
24140  240 nloop=nloop+1
24141  rlmax=0d0
24142  icrmax=0
24143 C...Loop over coloured partons
24144  DO 260 ic1=1,ncr
24145 C...Retrieve parton Event Record index and Colour Side
24146  i=icr(ic1)
24147  msi=mscr(ic1)
24148 C...Skip already connected partons
24149  IF (mcn(i,msi).NE.0) goto 260
24150 C...Shorthand for colour charge
24151  mci=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
24152 C...For Seattle algorithm, only start from partons with one dangling
24153 C...colour tag (unless there aren't any, cf. M3FREE above.)
24154  IF (mstp(95).GE.6.AND.mstp(95).LE.9) THEN
24155  IF (mci.EQ.2.AND.mcn(i,1).EQ.0.AND.mcn(i,2).EQ.0
24156  & .AND.m3free.EQ.1) THEN
24157  goto 260
24158  ENDIF
24159  ENDIF
24160 C...Retrieve saved optimal partner
24161  io=iopt(ic1)
24162  IF (io.NE.0) THEN
24163 C...Reject saved optimal partner if latter is now connected
24164 C...(Also reject if using model S1, since saved partner may
24165 C...now give rise to gg loop.)
24166  IF (mcn(io,3-msi).NE.0.OR.mstp(95).LE.3) THEN
24167  iopt(ic1)=0
24168  rloptc(ic1)=1d19
24169  ENDIF
24170  ENDIF
24171  rlopt=rloptc(ic1)
24172 C...Search for new optimal partner if necessary
24173  IF (iopt(ic1).EQ.0) THEN
24174  mbropt=0
24175  mggopt=0
24176  rlopt=1d19
24177 C...Loop over partons you can connect to
24178  DO 250 ic2=1,ncr
24179  j=icr(ic2)
24180  msj=mscr(ic2)
24181 C...Skip if already connected
24182  IF (mcn(j,msj).NE.0) goto 250
24183 C...Skip if this not colour-anticolour pair
24184  IF (msi.EQ.msj) goto 250
24185 C...And do not let gluons connect to themselves
24186  IF (i.EQ.j) goto 250
24187 C...Suppress direct connections between partons in same Beam Remnant
24188  mbrstr=0
24189  IF (k(i,3).LE.2.AND.k(i,3).GE.1.AND.k(i,3).EQ.k(j,3))
24190  & mbrstr=1
24191 C...Shorthand for colour charge
24192  mcj=kchg(pycomp(k(j,2)),2)*isign(1,k(j,2))
24193 C...Check for gluon loops
24194  mggstr=0
24195  IF (mcj.EQ.2.AND.mci.EQ.2) THEN
24196  IF (mcn(i,2).EQ.mcn(j,1).AND.mstp(95).LE.3.AND.
24197  & mcn(i,2).NE.0) mggstr=1
24198  ENDIF
24199 C...Save connection with smallest lambda measure
24200  rl=four(i,j)
24201 C...If best so far was a BR string and this is not, also save.
24202 C...If best so far was a gg string and this is not, also save.
24203 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
24204 C...string with a small Lambda measure as the last step, this connection
24205 C...will be saved regardless of whether other possibilities existed.
24206 C...I.e., there should really be a check whether another possibility has
24207 C...already been found, but since these models are now actively in use
24208 C...and uncertainties are anyway large, the algorithm is left as it is.
24209 C...(correction --> Pythia 8 ?)
24210  IF (rl.LT.rlopt.OR.(rl.EQ.rlopt.AND.pyr(0).LE.0.5d0)
24211  & .OR.(mbropt.EQ.1.AND.mbrstr.EQ.0)
24212  & .OR.(mggopt.EQ.1.AND.mggstr.EQ.0)) THEN
24213 C...Paquis type: fix problem above
24214  mpaq = 0
24215  IF (mstp95.GE.8.AND.rlopt.LE.1d18) THEN
24216  IF (mbrstr.EQ.1.AND.mbropt.EQ.0) mpaq=1
24217  IF (mggstr.EQ.1.AND.mggopt.EQ.0) mpaq=1
24218  ENDIF
24219  IF (mpaq.EQ.0) THEN
24220  rlopt=rl
24221  rloptc(ic1)=rlopt
24222  iopt(ic1)=j
24223  mbropt=mbrstr
24224  mggopt=mggstr
24225  ENDIF
24226  ENDIF
24227  250 CONTINUE
24228  ENDIF
24229  IF (iopt(ic1).NE.0) THEN
24230 C...Save pair with largest RLOPT so far
24231  IF (rlopt.GE.rlmax) THEN
24232  icrmax=ic1
24233  rlmax=rlopt
24234  ENDIF
24235  ENDIF
24236  260 CONTINUE
24237 C...Save and iterate
24238  icmax=0
24239  IF (icrmax.GT.0) THEN
24240  lct=lct+1
24241  ilmax=icr(icrmax)
24242  jlmax=iopt(icrmax)
24243  icmax=mscr(icrmax)
24244  jcmax=3-icmax
24245  mcn(ilmax,icmax)=lct
24246  mcn(jlmax,jcmax)=lct
24247  IF (nloop.LE.2*(n-ip)) THEN
24248  goto 240
24249  ELSE
24250  CALL pyerrm(31,' PYFSCR: infinite loop in color annealing')
24251  CALL pystop(11)
24252  ENDIF
24253  ELSE
24254 C...Save and exit. First check for leftover gluon(s)
24255  DO 290 i=max(1,ip),n
24256 C...Check colour charge
24257  mci=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
24258  IF (k(i,1).NE.3.OR.mci.NE.2) goto 290
24259  IF(mcn(i,1).EQ.0.AND.mcn(i,2).EQ.0) THEN
24260 C...Decide where to put left-over gluon (minimal insertion)
24261  icmax=0
24262  rlmax=1d19
24263 C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones
24264  DO 280 kct=ictmin,lct
24265  ic=0
24266  ia=0
24267  DO 270 it=max(1,ip),n
24268  IF (it.EQ.i.OR.k(it,1).NE.3) goto 270
24269  IF (mcn(it,1).EQ.kct) ic=it
24270  IF (mcn(it,2).EQ.kct) ia=it
24271  270 CONTINUE
24272 C...Skip if this color tag no longer present in event record
24273  IF (ic.EQ.0.OR.ia.EQ.0) goto 280
24274  rl=four(ic,i)*four(ia,i)
24275  IF (rl.LT.rlmax) THEN
24276  rlmax=rl
24277  icmax=ic
24278  iamax=ia
24279  ENDIF
24280  280 CONTINUE
24281  lct=lct+1
24282  mcn(i,1)=mcn(icmax,1)
24283  mcn(i,2)=lct
24284  mcn(icmax,1)=lct
24285  ENDIF
24286  290 CONTINUE
24287 C...Here we need to loop over entire event.
24288  DO 300 iz=max(1,ip),n
24289 C...Do not erase parton shower colour history
24290  IF (k(iz,1).NE.3) goto 300
24291 C...Check colour charge
24292  mci=kchg(pycomp(k(iz,2)),2)*isign(1,k(iz,2))
24293  IF (mci.EQ.0) goto 300
24294  IF (mcn(iz,1).NE.0) mct(iz,1)=mcn(iz,1)
24295  IF (mcn(iz,2).NE.0) mct(iz,2)=mcn(iz,2)
24296  300 CONTINUE
24297  ENDIF
24298 
24299  9999 RETURN
24300  END
24301 
24302 C*********************************************************************
24303 
24304 C...PYDIFF
24305 C...Handles diffractive and elastic scattering.
24306 
24307  SUBROUTINE pydiff
24308 
24309 C...Double precision and integer declarations.
24310  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24311  IMPLICIT INTEGER(i-n)
24312  INTEGER pyk,pychge,pycomp
24313 C...Commonblocks.
24314  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
24315  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24316  common/pypars/mstp(200),parp(200),msti(200),pari(200)
24317  common/pyint1/mint(400),vint(400)
24318  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
24319 
24320 C...Reset K, P and V vectors. Store incoming particles.
24321  DO 110 jt=1,mstp(126)+10
24322  i=mint(83)+jt
24323  DO 100 j=1,5
24324  k(i,j)=0
24325  p(i,j)=0d0
24326  v(i,j)=0d0
24327  100 CONTINUE
24328  110 CONTINUE
24329  n=mint(84)
24330  mint(3)=0
24331  mint(21)=0
24332  mint(22)=0
24333  mint(23)=0
24334  mint(24)=0
24335  mint(4)=4
24336  DO 130 jt=1,2
24337  i=mint(83)+jt
24338  k(i,1)=21
24339  k(i,2)=mint(10+jt)
24340  DO 120 j=1,5
24341  p(i,j)=vint(285+5*jt+j)
24342  120 CONTINUE
24343  130 CONTINUE
24344  mint(6)=2
24345 
24346 C...Subprocess; kinematics.
24347  sqlam=(vint(2)-vint(63)-vint(64))**2-4d0*vint(63)*vint(64)
24348  pz=sqrt(sqlam)/(2d0*vint(1))
24349  DO 200 jt=1,2
24350  i=mint(83)+jt
24351  pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2d0*vint(1))
24352  kfh=mint(102+jt)
24353 
24354 C...Elastically scattered particle. (Except elastic GVMD states.)
24355  IF(mint(16+jt).LE.0.AND.(mint(10+jt).NE.22.OR.
24356  & mint(106+jt).NE.3)) THEN
24357  n=n+1
24358  k(n,1)=1
24359  k(n,2)=kfh
24360  k(n,3)=i+2
24361  p(n,3)=pz*(-1)**(jt+1)
24362  p(n,4)=pe
24363  p(n,5)=sqrt(vint(62+jt))
24364 
24365 C...Decay rho from elastic scattering of gamma with sin**2(theta)
24366 C...distribution of decay products (in rho rest frame).
24367  IF(kfh.EQ.113.AND.mint(10+jt).EQ.22.AND.mstp(102).EQ.1) THEN
24368  nsav=n
24369  dbetaz=p(n,3)/sqrt(p(n,3)**2+p(n,5)**2)
24370  p(n,3)=0d0
24371  p(n,4)=p(n,5)
24372  CALL pydecy(nsav)
24373  IF(n.EQ.nsav+2.AND.iabs(k(nsav+1,2)).EQ.211) THEN
24374  phi=pyangl(p(nsav+1,1),p(nsav+1,2))
24375  CALL pyrobo(nsav+1,nsav+2,0d0,-phi,0d0,0d0,0d0)
24376  the=pyangl(p(nsav+1,3),p(nsav+1,1))
24377  CALL pyrobo(nsav+1,nsav+2,-the,0d0,0d0,0d0,0d0)
24378  140 cthe=2d0*pyr(0)-1d0
24379  IF(1d0-cthe**2.LT.pyr(0)) goto 140
24380  CALL pyrobo(nsav+1,nsav+2,acos(cthe),phi,0d0,0d0,0d0)
24381  ENDIF
24382  CALL pyrobo(nsav,nsav+2,0d0,0d0,0d0,0d0,dbetaz)
24383  ENDIF
24384 
24385 C...Diffracted particle: low-mass system to two particles.
24386  ELSEIF(vint(62+jt).LT.(vint(66+jt)+parp(103))**2) THEN
24387  n=n+2
24388  k(n-1,1)=1
24389  k(n,1)=1
24390  k(n-1,3)=i+2
24391  k(n,3)=i+2
24392  pmmas=sqrt(vint(62+jt))
24393  ntry=0
24394  150 ntry=ntry+1
24395  IF(ntry.LT.20) THEN
24396  mint(105)=mint(102+jt)
24397  mint(109)=mint(106+jt)
24398  CALL pyspli(kfh,21,kfl1,kfl2)
24399  CALL pykfdi(kfl1,0,kfl3,kf1)
24400  IF(kf1.EQ.0) goto 150
24401  CALL pykfdi(kfl2,-kfl3,kfldum,kf2)
24402  IF(kf2.EQ.0) goto 150
24403  ELSE
24404  kf1=kfh
24405  kf2=111
24406  ENDIF
24407  pm1=pymass(kf1)
24408  pm2=pymass(kf2)
24409  IF(pm1+pm2+parj(64).GT.pmmas) goto 150
24410  k(n-1,2)=kf1
24411  k(n,2)=kf2
24412  p(n-1,5)=pm1
24413  p(n,5)=pm2
24414  pzp=sqrt(max(0d0,(pmmas**2-pm1**2-pm2**2)**2-
24415  & 4d0*pm1**2*pm2**2))/(2d0*pmmas)
24416  p(n-1,3)=pzp
24417  p(n,3)=-pzp
24418  p(n-1,4)=sqrt(pm1**2+pzp**2)
24419  p(n,4)=sqrt(pm2**2+pzp**2)
24420  CALL pyrobo(n-1,n,acos(2d0*pyr(0)-1d0),paru(2)*pyr(0),
24421  & 0d0,0d0,0d0)
24422  dbetaz=pz*(-1)**(jt+1)/sqrt(pz**2+pmmas**2)
24423  CALL pyrobo(n-1,n,0d0,0d0,0d0,0d0,dbetaz)
24424 
24425 C...Diffracted particle: valence quark kicked out.
24426  ELSEIF(mstp(101).EQ.1.OR.(mstp(101).EQ.3.AND.pyr(0).LT.
24427  & parp(101))) THEN
24428  n=n+2
24429  k(n-1,1)=2
24430  k(n,1)=1
24431  k(n-1,3)=i+2
24432  k(n,3)=i+2
24433  mint(105)=mint(102+jt)
24434  mint(109)=mint(106+jt)
24435  CALL pyspli(kfh,21,k(n,2),k(n-1,2))
24436  p(n-1,5)=pymass(k(n-1,2))
24437  p(n,5)=pymass(k(n,2))
24438  sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-
24439  & 4d0*p(n-1,5)**2*p(n,5)**2
24440  p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-
24441  & p(n,5)**2))/(2d0*vint(62+jt))*(-1)**(jt+1)
24442  p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)
24443  p(n,3)=pz*(-1)**(jt+1)-p(n-1,3)
24444  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
24445 
24446 C...Diffracted particle: gluon kicked out.
24447  ELSE
24448  n=n+3
24449  k(n-2,1)=2
24450  k(n-1,1)=2
24451  k(n,1)=1
24452  k(n-2,3)=i+2
24453  k(n-1,3)=i+2
24454  k(n,3)=i+2
24455  mint(105)=mint(102+jt)
24456  mint(109)=mint(106+jt)
24457  CALL pyspli(kfh,21,k(n,2),k(n-2,2))
24458  k(n-1,2)=21
24459  p(n-2,5)=pymass(k(n-2,2))
24460  p(n-1,5)=0d0
24461  p(n,5)=pymass(k(n,2))
24462 C...Energy distribution for particle into two jets.
24463  160 imb=1
24464  IF(mod(kfh/1000,10).NE.0) imb=2
24465  chik=parp(92+2*imb)
24466  IF(mstp(92).LE.1) THEN
24467  IF(imb.EQ.1) chi=pyr(0)
24468  IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
24469  ELSEIF(mstp(92).EQ.2) THEN
24470  chi=1d0-pyr(0)**(1d0/(1d0+chik))
24471  ELSEIF(mstp(92).EQ.3) THEN
24472  cut=2d0*0.3d0/vint(1)
24473  170 chi=pyr(0)**2
24474  IF((chi**2/(chi**2+cut**2))**0.25d0*(1d0-chi)**chik.LT.
24475  & pyr(0)) goto 170
24476  ELSEIF(mstp(92).EQ.4) THEN
24477  cut=2d0*0.3d0/vint(1)
24478  cutr=(1d0+sqrt(1d0+cut**2))/cut
24479  180 chir=cut*cutr**pyr(0)
24480  chi=(chir**2-cut**2)/(2d0*chir)
24481  IF((1d0-chi)**chik.LT.pyr(0)) goto 180
24482  ELSE
24483  cut=2d0*0.3d0/vint(1)
24484  cuta=cut**(1d0-parp(98))
24485  cutb=(1d0+cut)**(1d0-parp(98))
24486  190 chi=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
24487  IF(((chi+cut)**2/(2d0*(chi**2+cut**2)))**
24488  & (0.5d0*parp(98))*(1d0-chi)**chik.LT.pyr(0)) goto 190
24489  ENDIF
24490  IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1d0-p(n-2,5)**2/
24491  & vint(62+jt)) goto 160
24492  sqm=p(n-2,5)**2/(1d0-chi)+p(n,5)**2/chi
24493  pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/
24494  & (2d0*vint(62+jt))
24495  pei=sqrt(pzi**2+sqm)
24496  pqqp=(1d0-chi)*(pei+pzi)
24497  p(n-2,3)=0.5d0*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)
24498  p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)
24499  p(n-1,4)=0.5d0*(vint(62+jt)-sqm)/(pei+pzi)
24500  p(n-1,3)=p(n-1,4)*(-1)**jt
24501  p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)
24502  p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
24503  ENDIF
24504 
24505 C...Documentation lines.
24506  k(i+2,1)=21
24507  IF(mint(16+jt).EQ.0) k(i+2,2)=kfh
24508  IF(mint(16+jt).NE.0.OR.(mint(10+jt).EQ.22.AND.
24509  & mint(106+jt).EQ.3)) k(i+2,2)=isign(9900000,kfh)+10*(kfh/10)
24510  k(i+2,3)=i
24511  p(i+2,3)=pz*(-1)**(jt+1)
24512  p(i+2,4)=pe
24513  p(i+2,5)=sqrt(vint(62+jt))
24514  200 CONTINUE
24515 
24516 C...Rotate outgoing partons/particles using cos(theta).
24517  IF(vint(23).LT.0.9d0) THEN
24518  CALL pyrobo(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0)
24519  ELSE
24520  CALL pyrobo(mint(83)+3,n,asin(vint(59)),vint(24),0d0,0d0,0d0)
24521  ENDIF
24522 
24523  RETURN
24524  END
24525 
24526 C*********************************************************************
24527 
24528 C...PYDISG
24529 C...Set up a DIS process as gamma* + f -> f, with beam remnant
24530 C...and showering added consecutively. Photon flux by the PYGAGA
24531 C...routine (if at all).
24532 
24533  SUBROUTINE pydisg
24534 
24535 C...Double precision and integer declarations.
24536  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24537  IMPLICIT INTEGER(i-n)
24538  INTEGER pyk,pychge,pycomp
24539 C...Parameter statement to help give large particle numbers.
24540  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
24541  &kexcit=4000000,kdimen=5000000)
24542 C...Commonblocks.
24543  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
24544  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24545  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24546  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
24547  common/pypars/mstp(200),parp(200),msti(200),pari(200)
24548  common/pyint1/mint(400),vint(400)
24549  SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
24550 C...Local arrays.
24551  dimension pms(4)
24552 
24553 C...Choice of subprocess, number of documentation lines
24554  idoc=7
24555  mint(3)=idoc-6
24556  mint(4)=idoc
24557  ipu1=mint(84)+1
24558  ipu2=mint(84)+2
24559  ipu3=mint(84)+3
24560  iside=1
24561  IF(mint(107).EQ.4) iside=2
24562 
24563 C...Reset K, P and V vectors. Store incoming particles
24564  DO 110 jt=1,mstp(126)+20
24565  i=mint(83)+jt
24566  DO 100 j=1,5
24567  k(i,j)=0
24568  p(i,j)=0d0
24569  v(i,j)=0d0
24570  100 CONTINUE
24571  110 CONTINUE
24572  DO 130 jt=1,2
24573  i=mint(83)+jt
24574  k(i,1)=21
24575  k(i,2)=mint(10+jt)
24576  DO 120 j=1,5
24577  p(i,j)=vint(285+5*jt+j)
24578  120 CONTINUE
24579  130 CONTINUE
24580  mint(6)=2
24581 
24582 C...Store incoming partons in hadronic CM-frame
24583  DO 140 jt=1,2
24584  i=mint(84)+jt
24585  k(i,1)=14
24586  k(i,2)=mint(14+jt)
24587  k(i,3)=mint(83)+2+jt
24588  140 CONTINUE
24589  IF(mint(15).EQ.22) THEN
24590  p(mint(84)+1,3)=0.5d0*(vint(1)+vint(307)/vint(1))
24591  p(mint(84)+1,4)=0.5d0*(vint(1)-vint(307)/vint(1))
24592  p(mint(84)+1,5)=-sqrt(vint(307))
24593  p(mint(84)+2,3)=-0.5d0*vint(307)/vint(1)
24594  p(mint(84)+2,4)=0.5d0*vint(307)/vint(1)
24595  kfres=mint(16)
24596  iside=2
24597  ELSE
24598  p(mint(84)+1,3)=0.5d0*vint(308)/vint(1)
24599  p(mint(84)+1,4)=0.5d0*vint(308)/vint(1)
24600  p(mint(84)+2,3)=-0.5d0*(vint(1)+vint(308)/vint(1))
24601  p(mint(84)+2,4)=0.5d0*(vint(1)-vint(308)/vint(1))
24602  p(mint(84)+1,5)=-sqrt(vint(308))
24603  kfres=mint(15)
24604  iside=1
24605  ENDIF
24606  sidesg=(-1d0)**(iside-1)
24607 
24608 C...Copy incoming partons to documentation lines.
24609  DO 170 jt=1,2
24610  i1=mint(83)+4+jt
24611  i2=mint(84)+jt
24612  k(i1,1)=21
24613  k(i1,2)=k(i2,2)
24614  k(i1,3)=i1-2
24615  DO 150 j=1,5
24616  p(i1,j)=p(i2,j)
24617  150 CONTINUE
24618 
24619 C...Second copy for partons before ISR shower, since no such.
24620  i1=mint(83)+2+jt
24621  k(i1,1)=21
24622  k(i1,2)=k(i2,2)
24623  k(i1,3)=i1-2
24624  DO 160 j=1,5
24625  p(i1,j)=p(i2,j)
24626  160 CONTINUE
24627  170 CONTINUE
24628 
24629 C...Define initial partons.
24630  ntry=0
24631  180 ntry=ntry+1
24632  IF(ntry.GT.100) THEN
24633  mint(51)=1
24634  RETURN
24635  ENDIF
24636 
24637 C...Scattered quark in hadronic CM frame.
24638  i=mint(83)+7
24639  k(ipu3,1)=3
24640  k(ipu3,2)=kfres
24641  k(ipu3,3)=i
24642  p(ipu3,5)=pymass(kfres)
24643  p(ipu3,3)=p(ipu1,3)+p(ipu2,3)
24644  p(ipu3,4)=p(ipu1,4)+p(ipu2,4)
24645  p(ipu3,5)=0d0
24646  k(i,1)=21
24647  k(i,2)=kfres
24648  k(i,3)=mint(83)+4+iside
24649  p(i,3)=p(ipu3,3)
24650  p(i,4)=p(ipu3,4)
24651  p(i,5)=p(ipu3,5)
24652  n=ipu3
24653  mint(21)=kfres
24654  mint(22)=0
24655 
24656 C...No primordial kT, or chosen according to truncated Gaussian or
24657 C...exponential, or (for photon) predetermined or power law.
24658  190 IF(mint(40+iside).EQ.2.AND.mint(10+iside).NE.22) THEN
24659  IF(mstp(91).LE.0) THEN
24660  pt=0d0
24661  ELSEIF(mstp(91).EQ.1) THEN
24662  pt=parp(91)*sqrt(-log(pyr(0)))
24663  ELSE
24664  rpt1=pyr(0)
24665  rpt2=pyr(0)
24666  pt=-parp(92)*log(rpt1*rpt2)
24667  ENDIF
24668  IF(pt.GT.parp(93)) goto 190
24669  ELSEIF(mint(106+iside).EQ.3) THEN
24670  pta=sqrt(vint(282+iside))
24671  ptb=0d0
24672  IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
24673  ptb=parp(99)*sqrt(-log(pyr(0)))
24674  ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
24675  rpt1=pyr(0)
24676  rpt2=pyr(0)
24677  ptb=-parp(99)*log(rpt1*rpt2)
24678  ENDIF
24679  IF(ptb.GT.parp(100)) goto 190
24680  pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
24681  IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
24682  ELSEIF(iabs(mint(14+iside)).LE.8.OR.mint(14+iside).EQ.21) THEN
24683  IF(mstp(93).LE.0) THEN
24684  pt=0d0
24685  ELSEIF(mstp(93).EQ.1) THEN
24686  pt=parp(99)*sqrt(-log(pyr(0)))
24687  ELSEIF(mstp(93).EQ.2) THEN
24688  rpt1=pyr(0)
24689  rpt2=pyr(0)
24690  pt=-parp(99)*log(rpt1*rpt2)
24691  ELSEIF(mstp(93).EQ.3) THEN
24692  ha=parp(99)**2
24693  hb=parp(100)**2
24694  pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
24695  ELSE
24696  ha=parp(99)**2
24697  hb=parp(100)**2
24698  IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
24699  pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
24700  ENDIF
24701  IF(pt.GT.parp(100)) goto 190
24702  ELSE
24703  pt=0d0
24704  ENDIF
24705  vint(156+iside)=pt
24706  phi=paru(2)*pyr(0)
24707  p(ipu3,1)=pt*cos(phi)
24708  p(ipu3,2)=pt*sin(phi)
24709  p(ipu3,4)=sqrt(p(ipu3,5)**2+pt**2+p(ipu3,3)**2)
24710  pms(3-iside)=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
24711  pcp=p(ipu3,4)+abs(p(ipu3,3))
24712 
24713 C...Find one or two beam remnants.
24714  mint(105)=mint(102+iside)
24715  mint(109)=mint(106+iside)
24716  CALL pyspli(mint(10+iside),mint(12+iside),kflch,kflsp)
24717  IF(mint(51).NE.0) THEN
24718  mint(51)=0
24719  goto 180
24720  ENDIF
24721 
24722 C...Store first remnant parton, with colour info and kinematics.
24723  i=n+1
24724  k(i,1)=1
24725  k(i,2)=kflsp
24726  k(i,3)=mint(83)+iside
24727  p(i,5)=pymass(k(i,2))
24728  kcol=kchg(pycomp(kflsp),2)
24729  IF(kcol.NE.0) THEN
24730  k(i,1)=3
24731  kfls=(3-kcol*isign(1,kflsp))/2
24732  k(i,kfls+3)=mstu(5)*ipu3
24733  k(ipu3,6-kfls)=mstu(5)*i
24734  icolr=i
24735  ENDIF
24736  IF(kflch.EQ.0) THEN
24737  p(i,1)=-p(ipu3,1)
24738  p(i,2)=-p(ipu3,2)
24739  pms(iside)=p(i,5)**2+p(i,1)**2+p(i,2)**2
24740  p(i,3)=-p(ipu3,3)
24741  p(i,4)=sqrt(pms(iside)+p(i,3)**2)
24742  prp=p(i,4)+abs(p(i,3))
24743 
24744 C...When extra remnant parton or hadron: store extra remnant.
24745  ELSE
24746  i=i+1
24747  k(i,1)=1
24748  k(i,2)=kflch
24749  k(i,3)=mint(83)+iside
24750  p(i,5)=pymass(k(i,2))
24751  kcol=kchg(pycomp(kflch),2)
24752  IF(kcol.NE.0) THEN
24753  k(i,1)=3
24754  kfls=(3-kcol*isign(1,kflch))/2
24755  k(i,kfls+3)=mstu(5)*ipu3
24756  k(ipu3,6-kfls)=mstu(5)*i
24757  icolr=i
24758  ENDIF
24759 
24760 C...Relative transverse momentum when two remnants.
24761  loop=0
24762  200 loop=loop+1
24763  CALL pyptdi(1,p(i-1,1),p(i-1,2))
24764  p(i-1,1)=p(i-1,1)-0.5d0*p(ipu3,1)
24765  p(i-1,2)=p(i-1,2)-0.5d0*p(ipu3,2)
24766  pms(3)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
24767  p(i,1)=-p(ipu3,1)-p(i-1,1)
24768  p(i,2)=-p(ipu3,2)-p(i-1,2)
24769  pms(4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
24770 
24771 C...Relative distribution of energy for particle into jet plus particle.
24772  imb=1
24773  IF(mod(mint(10+iside)/1000,10).NE.0) imb=2
24774  IF(mstp(94).LE.1) THEN
24775  IF(imb.EQ.1) chi=pyr(0)
24776  IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
24777  IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
24778  ELSEIF(mstp(94).EQ.2) THEN
24779  chi=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
24780  IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
24781  ELSEIF(mstp(94).EQ.3) THEN
24782  CALL pyzdis(1,0,pms(4),zz)
24783  chi=zz
24784  ELSE
24785  CALL pyzdis(1000,0,pms(4),zz)
24786  chi=zz
24787  ENDIF
24788 
24789 C...Construct total transverse mass; reject if too large.
24790  chi=max(1d-8,min(1d0-1d-8,chi))
24791  pms(iside)=pms(4)/chi+pms(3)/(1d0-chi)
24792  IF(pms(iside).GT.p(ipu3,4)**2) THEN
24793  IF(loop.LT.10) goto 200
24794  goto 180
24795  ENDIF
24796  vint(158+iside)=chi
24797 
24798 C...Subdivide longitudinal momentum according to value selected above.
24799  prp=sqrt(pms(iside)+p(ipu3,3)**2)+abs(p(ipu3,3))
24800  pw1=(1d0-chi)*prp
24801  p(i-1,4)=0.5d0*(pw1+pms(3)/pw1)
24802  p(i-1,3)=0.5d0*(pw1-pms(3)/pw1)*sidesg
24803  pw2=chi*prp
24804  p(i,4)=0.5d0*(pw2+pms(4)/pw2)
24805  p(i,3)=0.5d0*(pw2-pms(4)/pw2)*sidesg
24806  ENDIF
24807  n=i
24808 
24809 C...Boost current and remnant systems to correct frame.
24810  IF(sqrt(pms(1))+sqrt(pms(2)).GT.0.99d0*vint(1)) goto 180
24811  dsqlam=sqrt(max(0d0,(vint(2)-pms(1)-pms(2))**2-4d0*pms(1)*pms(2)))
24812  drkc=(vint(2)+pms(3-iside)-pms(iside)+dsqlam)/
24813  &(2d0*vint(1)*pcp)
24814  drkr=(vint(2)+pms(iside)-pms(3-iside)+dsqlam)/
24815  &(2d0*vint(1)*prp)
24816  dbec=-sidesg*(drkc**2-1d0)/(drkc**2+1d0)
24817  dber=sidesg*(drkr**2-1d0)/(drkr**2+1d0)
24818  CALL pyrobo(ipu3,ipu3,0d0,0d0,0d0,0d0,dbec)
24819  CALL pyrobo(ipu3+1,n,0d0,0d0,0d0,0d0,dber)
24820 
24821 C...Let current quark shower; recoil but no showering by colour partner.
24822  qmax=2d0*sqrt(vint(309-iside))
24823  mstj48=mstj(48)
24824  mstj(48)=1
24825  parj86=parj(86)
24826  parj(86)=0d0
24827  IF(mstp(71).EQ.1) CALL pyshow(ipu3,icolr,qmax)
24828  mstj(48)=mstj48
24829  parj(86)=parj86
24830 
24831  RETURN
24832  END
24833 
24834 C*********************************************************************
24835 
24836 C...PYDOCU
24837 C...Handles the documentation of the process in MSTI and PARI,
24838 C...and also computes cross-sections based on accumulated statistics.
24839 
24840  SUBROUTINE pydocu
24841 
24842 C...Double precision and integer declarations.
24843  IMPLICIT DOUBLE PRECISION(a-h, o-z)
24844  IMPLICIT INTEGER(i-n)
24845  INTEGER pyk,pychge,pycomp
24846 C...Commonblocks.
24847  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
24848  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24849  common/pypars/mstp(200),parp(200),msti(200),pari(200)
24850  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
24851  common/pyint1/mint(400),vint(400)
24852  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
24853  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
24854  SAVE /pyjets/,/pydat1/,/pysubs/,/pypars/,/pyint1/,/pyint2/,
24855  &/pyint5/
24856 
24857 C...Calculate Monte Carlo estimates of cross-sections.
24858  isub=mint(1)
24859  IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1
24860  ngen(0,3)=ngen(0,3)+1
24861  xsec(0,3)=0d0
24862  DO 100 i=1,500
24863  IF(i.EQ.96.OR.i.EQ.97) THEN
24864  xsec(i,3)=0d0
24865  ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR.
24866  & i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN
24867  xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
24868  & dble(ngen(96,2)))
24869  ELSEIF(msub(95).EQ.1.AND.i.GE.381.AND.i.LE.386) THEN
24870  xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
24871  & dble(ngen(96,2)))
24872  ELSEIF(msub(i).EQ.0.OR.ngen(i,1).EQ.0) THEN
24873  xsec(i,3)=0d0
24874  ELSEIF(ngen(i,2).EQ.0) THEN
24875  xsec(i,3)=xsec(i,2)*ngen(0,3)/(dble(ngen(i,1))*
24876  & dble(ngen(0,2)))
24877  ELSE
24878  xsec(i,3)=xsec(i,2)*ngen(i,3)/(dble(ngen(i,1))*
24879  & dble(ngen(i,2)))
24880  ENDIF
24881  xsec(0,3)=xsec(0,3)+xsec(i,3)
24882  100 CONTINUE
24883 
24884 C...Rescale to known low-pT cross-section for standard QCD processes.
24885  IF(msub(95).EQ.1) THEN
24886  xsech=xsec(11,3)+xsec(12,3)+xsec(13,3)+xsec(28,3)+xsec(53,3)+
24887  & xsec(68,3)+xsec(95,3)
24888  xsecw=xsec(97,2)/max(1d0,dble(ngen(97,1)))
24889  IF(xsech.GT.1d-20.AND.xsecw.GT.1d-20) THEN
24890  fac=xsecw/xsech
24891  xsec(11,3)=fac*xsec(11,3)
24892  xsec(12,3)=fac*xsec(12,3)
24893  xsec(13,3)=fac*xsec(13,3)
24894  xsec(28,3)=fac*xsec(28,3)
24895  xsec(53,3)=fac*xsec(53,3)
24896  xsec(68,3)=fac*xsec(68,3)
24897  xsec(95,3)=fac*xsec(95,3)
24898  xsec(0,3)=xsec(0,3)-xsech+xsecw
24899  ENDIF
24900  ENDIF
24901 
24902 C...Save information for gamma-p and gamma-gamma.
24903  IF(mint(121).GT.1) THEN
24904  iga=mint(122)
24905  CALL pysave(2,iga)
24906  CALL pysave(5,0)
24907  ENDIF
24908 
24909 C...Reset information on hard interaction.
24910  DO 110 j=1,200
24911  msti(j)=0
24912  pari(j)=0d0
24913  110 CONTINUE
24914 
24915 C...Copy integer valued information from MINT into MSTI.
24916  DO 120 j=1,32
24917  msti(j)=mint(j)
24918  120 CONTINUE
24919  IF(mint(121).GT.1) msti(9)=mint(122)
24920 
24921 C...Store cross-section variables in PARI.
24922  pari(1)=xsec(0,3)
24923  pari(2)=xsec(0,3)/mint(5)
24924  pari(7)=vint(97)
24925  pari(9)=vint(99)
24926  pari(10)=vint(100)
24927  vint(98)=vint(98)+vint(100)
24928  IF(mstp(142).EQ.1) pari(2)=xsec(0,3)/vint(98)
24929 
24930 C...Store kinematics variables in PARI.
24931  pari(11)=vint(1)
24932  pari(12)=vint(2)
24933  IF(isub.NE.95) THEN
24934  DO 130 j=13,26
24935  pari(j)=vint(30+j)
24936  130 CONTINUE
24937  pari(29)=vint(39)
24938  pari(30)=vint(40)
24939  pari(31)=vint(141)
24940  pari(32)=vint(142)
24941  pari(33)=vint(41)
24942  pari(34)=vint(42)
24943  pari(35)=pari(33)-pari(34)
24944  pari(36)=vint(21)
24945  pari(37)=vint(22)
24946  pari(38)=vint(26)
24947  pari(39)=vint(157)
24948  pari(40)=vint(158)
24949  pari(41)=vint(23)
24950  pari(42)=2d0*vint(47)/vint(1)
24951  ENDIF
24952 
24953 C...Store information on scattered partons in PARI.
24954  IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN
24955  DO 140 is=7,8
24956  i=mint(is)
24957  pari(36+is)=p(i,3)/vint(1)
24958  pari(38+is)=p(i,4)/vint(1)
24959  pr=max(1d-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)
24960  pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
24961  & sqrt(pr),1d20)),p(i,3))
24962  pr=max(1d-20,p(i,1)**2+p(i,2)**2)
24963  pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
24964  & sqrt(pr),1d20)),p(i,3))
24965  pari(44+is)=p(i,3)/sqrt(1d-20+p(i,1)**2+p(i,2)**2+p(i,3)**2)
24966  pari(46+is)=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
24967  pari(48+is)=pyangl(p(i,1),p(i,2))
24968  140 CONTINUE
24969  ENDIF
24970 
24971 C...Store sum up transverse and longitudinal momenta.
24972  pari(65)=2d0*pari(17)
24973  IF(isub.LE.90.OR.isub.GE.95) THEN
24974  DO 150 i=mstp(126)+1,n
24975  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150
24976  pt=sqrt(p(i,1)**2+p(i,2)**2)
24977  pari(69)=pari(69)+pt
24978  IF(i.LE.mint(52)) pari(66)=pari(66)+pt
24979  IF(i.GT.mint(52).AND.i.LE.mint(53)) pari(68)=pari(68)+pt
24980  150 CONTINUE
24981  pari(67)=pari(68)
24982  pari(71)=vint(151)
24983  pari(72)=vint(152)
24984  pari(73)=vint(151)
24985  pari(74)=vint(152)
24986  ELSE
24987  pari(66)=pari(65)
24988  pari(69)=pari(65)
24989  ENDIF
24990 
24991 C...Store various other pieces of information into PARI.
24992  pari(61)=vint(148)
24993  pari(75)=vint(155)
24994  pari(76)=vint(156)
24995  pari(77)=vint(159)
24996  pari(78)=vint(160)
24997  pari(81)=vint(138)
24998 
24999 C...Store information on lepton -> lepton + gamma in PYGAGA.
25000  msti(71)=mint(141)
25001  msti(72)=mint(142)
25002  pari(101)=vint(301)
25003  pari(102)=vint(302)
25004  DO 160 i=103,114
25005  pari(i)=vint(i+202)
25006  160 CONTINUE
25007 
25008 C...Set information for PYTABU.
25009  IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
25010  mstu(161)=mint(21)
25011  mstu(162)=0
25012  ELSEIF(iset(isub).EQ.5) THEN
25013  mstu(161)=mint(23)
25014  mstu(162)=0
25015  ELSE
25016  mstu(161)=mint(21)
25017  mstu(162)=mint(22)
25018  ENDIF
25019 
25020  RETURN
25021  END
25022 
25023 C*********************************************************************
25024 
25025 C...PYFRAM
25026 C...Performs transformations between different coordinate frames.
25027 
25028  SUBROUTINE pyfram(IFRAME)
25029 
25030 C...Double precision and integer declarations.
25031  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25032  IMPLICIT INTEGER(i-n)
25033  INTEGER pyk,pychge,pycomp
25034 C...Commonblocks.
25035  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
25036  common/pypars/mstp(200),parp(200),msti(200),pari(200)
25037  common/pyint1/mint(400),vint(400)
25038  SAVE /pydat1/,/pypars/,/pyint1/
25039 
25040 C...Check that transformation can and should be done.
25041  IF(iframe.EQ.1.OR.iframe.EQ.2.OR.(iframe.EQ.3.AND.
25042  &mint(91).EQ.1)) THEN
25043  IF(iframe.EQ.mint(6)) RETURN
25044  ELSE
25045  WRITE(mstu(11),5000) iframe,mint(6)
25046  RETURN
25047  ENDIF
25048 
25049  IF(mint(6).EQ.1) THEN
25050 C...Transform from fixed target or user specified frame to
25051 C...overall CM frame.
25052  CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
25053  CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
25054  CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
25055  ELSEIF(mint(6).EQ.3) THEN
25056 C...Transform from hadronic CM frame in DIS to overall CM frame.
25057  CALL pyrobo(0,0,-vint(221),-vint(222),-vint(223),-vint(224),
25058  & -vint(225))
25059  ENDIF
25060 
25061  IF(iframe.EQ.1) THEN
25062 C...Transform from overall CM frame to fixed target or user specified
25063 C...frame.
25064  CALL pyrobo(0,0,vint(6),vint(7),vint(8),vint(9),vint(10))
25065  ELSEIF(iframe.EQ.3) THEN
25066 C...Transform from overall CM frame to hadronic CM frame in DIS.
25067  CALL pyrobo(0,0,0d0,0d0,vint(223),vint(224),vint(225))
25068  CALL pyrobo(0,0,0d0,vint(222),0d0,0d0,0d0)
25069  CALL pyrobo(0,0,vint(221),0d0,0d0,0d0,0d0)
25070  ENDIF
25071 
25072 C...Set information about new frame.
25073  mint(6)=iframe
25074  msti(6)=iframe
25075 
25076  5000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,
25077  &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =',
25078  &1x,i5)
25079 
25080  RETURN
25081  END
25082 
25083 C*********************************************************************
25084 
25085 C...PYWIDT
25086 C...Calculates full and partial widths of resonances.
25087 
25088  SUBROUTINE pywidt(KFLR,SH,WDTP,WDTE)
25089 
25090 C...Double precision and integer declarations.
25091  IMPLICIT DOUBLE PRECISION(a-h, o-z)
25092  IMPLICIT INTEGER(i-n)
25093  INTEGER pyk,pychge,pycomp
25094 C...Parameter statement to help give large particle numbers.
25095  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
25096  &kexcit=4000000,kdimen=5000000)
25097 C...Commonblocks.
25098  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
25099  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
25100  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
25101  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
25102  common/pypars/mstp(200),parp(200),msti(200),pari(200)
25103  common/pyint1/mint(400),vint(400)
25104  common/pyint4/mwid(500),wids(500,5)
25105  common/pymssm/imss(0:99),rmss(0:99)
25106  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
25107  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
25108  common/pytcsm/itcm(0:99),rtcm(0:99)
25109  common/pypued/iued(0:99),rued(0:99)
25110  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
25111  &/pyint4/,/pymssm/,/pyssmt/,/pytcsm/,/pypued/
25112 C...Local arrays and saved variables.
25113  COMPLEX*16 zmixc(4,4),al,bl,ar,br,fl,fr
25114  dimension wdtp(0:400),wdte(0:400,0:5),mofsv(3,2),widwsv(3,2),
25115  &wid2sv(3,2),wdtpp(0:400),wdtep(0:400,0:5)
25116 C...UED: equivalences between ordered particles (451->475)
25117 C...and UED particle code (5 000 000 + id)
25118  parameter(kkflmi=451,kkflma=475)
25119  dimension chidel(3), iuedpr(25)
25120  dimension iuedeq(kkflma),mued(2)
25121  common/sw1/sw21,cw21
25122  DATA (iuedeq(i),i=kkflmi,kkflma)/
25123  & 6100001,6100002,6100003,6100004,6100005,6100006,
25124  & 5100001,5100002,5100003,5100004,5100005,5100006,
25125  & 6100011,6100013,6100015,
25126  & 5100012,5100011,5100014,5100013,5100016,5100015,
25127  & 5100021,5100022,5100023,5100024/
25128 C...Save local variables
25129  SAVE mofsv,widwsv,wid2sv
25130 C...Initial values
25131  DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
25132  DATA chidel/1.1d-03,1.d0,7.4d+2/
25133  DATA iuedpr/25*0/
25134 C...UED: inline functions used in kk width calculus
25135  fkac1(x,y)=1.-x**2/y**2
25136  fkac2(x,y)=2.+x**2/y**2
25137 
25138 C...Compressed code and sign; mass.
25139  kfla=iabs(kflr)
25140  kfls=isign(1,kflr)
25141  kc=pycomp(kfla)
25142  shr=sqrt(sh)
25143  pmr=pmas(kc,1)
25144 
25145 C...Reset width information.
25146  DO 110 i=0,mdcy(kc,3)
25147  wdtp(i)=0d0
25148  DO 100 j=0,5
25149  wdte(i,j)=0d0
25150  100 CONTINUE
25151  110 CONTINUE
25152 
25153 C...Allow for fudge factor to rescale resonance width.
25154  fudge=1d0
25155  IF(mstp(110).NE.0.AND.(mwid(kc).EQ.1.OR.mwid(kc).EQ.2.OR.
25156  &(mwid(kc).EQ.3.AND.mint(63).EQ.1))) THEN
25157  IF(mstp(110).EQ.kfla) THEN
25158  fudge=parp(110)
25159  ELSEIF(mstp(110).EQ.-1) THEN
25160  IF(kfla.NE.6.AND.kfla.NE.23.AND.kfla.NE.24) fudge=parp(110)
25161  ELSEIF(mstp(110).EQ.-2) THEN
25162  fudge=parp(110)
25163  ENDIF
25164  ENDIF
25165 
25166 C...Not to be treated as a resonance: return.
25167  IF((mwid(kc).LE.0.OR.mwid(kc).GE.4).AND.kfla.NE.21.AND.
25168  &kfla.NE.22) THEN
25169  wdtp(0)=1d0
25170  wdte(0,0)=1d0
25171  mint(61)=0
25172  mint(62)=0
25173  mint(63)=0
25174  RETURN
25175 
25176 C...Treatment as a resonance based on tabulated branching ratios.
25177  ELSEIF(mwid(kc).EQ.2.OR.(mwid(kc).EQ.3.AND.mint(63).EQ.0)) THEN
25178 C...Loop over possible decay channels; skip irrelevant ones.
25179  DO 120 i=1,mdcy(kc,3)
25180  idc=i+mdcy(kc,2)-1
25181  IF(mdme(idc,1).LT.0) goto 120
25182 
25183 C...Read out decay products and nominal masses.
25184  kfd1=kfdp(idc,1)
25185  kfc1=pycomp(kfd1)
25186 C...Skip dummy modes or unrecognized particles
25187  IF (kfd1.EQ.0.OR.kfc1.EQ.0) goto 120
25188  IF(kchg(kfc1,3).EQ.1) kfd1=kfls*kfd1
25189  pm1=pmas(kfc1,1)
25190  kfd2=kfdp(idc,2)
25191  kfc2=pycomp(kfd2)
25192  IF(kchg(kfc2,3).EQ.1) kfd2=kfls*kfd2
25193  pm2=pmas(kfc2,1)
25194  kfd3=kfdp(idc,3)
25195  pm3=0d0
25196  IF(kfd3.NE.0) THEN
25197  kfc3=pycomp(kfd3)
25198  IF(kchg(kfc3,3).EQ.1) kfd3=kfls*kfd3
25199  pm3=pmas(kfc3,1)
25200  ENDIF
25201 
25202 C...Naive partial width and alternative threshold factors.
25203  wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)
25204  IF(mdme(idc,2).GE.51.AND.mdme(idc,2).LE.53.AND.
25205  & pm1+pm2+pm3.GE.shr) THEN
25206  wdtp(i)=0d0
25207  ELSEIF(mdme(idc,2).EQ.52.AND.kfd3.EQ.0) THEN
25208  wdtp(i)=wdtp(i)*sqrt(max(0d0,(sh-pm1**2-pm2**2)**2-
25209  & 4d0*pm1**2*pm2**2))/sh
25210  ELSEIF(mdme(idc,2).EQ.52) THEN
25211  pma=max(pm1,pm2,pm3)
25212  pmc=min(pm1,pm2,pm3)
25213  pmb=pm1+pm2+pm3-pma-pmc
25214  pmbc=pmb+pmc+0.5d0*(shr-pma-pmc-pmc)
25215  pman=pma**2/sh
25216  pmbn=pmb**2/sh
25217  pmcn=pmc**2/sh
25218  pmbcn=pmbc**2/sh
25219  wdtp(i)=wdtp(i)*sqrt(max(0d0,
25220  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
25221  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
25222  & ((shr-pma)**2-(pmb+pmc)**2)*
25223  & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
25224  & ((1d0-pmbcn)*pmbcn*sh)
25225  ELSEIF(mdme(idc,2).EQ.53.AND.kfd3.EQ.0) THEN
25226  wdtp(i)=wdtp(i)*sqrt(
25227  & max(0d0,(sh-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2)/
25228  & max(1d-4,(pmr**2-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2))
25229  ELSEIF(mdme(idc,2).EQ.53) THEN
25230  pma=max(pm1,pm2,pm3)
25231  pmc=min(pm1,pm2,pm3)
25232  pmb=pm1+pm2+pm3-pma-pmc
25233  pmbc=pmb+pmc+0.5d0*(shr-pma-pmb-pmc)
25234  pman=pma**2/sh
25235  pmbn=pmb**2/sh
25236  pmcn=pmc**2/sh
25237  pmbcn=pmbc**2/sh
25238  facact=sqrt(max(0d0,
25239  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
25240  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
25241  & ((shr-pma)**2-(pmb+pmc)**2)*
25242  & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
25243  & ((1d0-pmbcn)*pmbcn*sh)
25244  pmbc=pmb+pmc+0.5d0*(pmr-pma-pmb-pmc)
25245  pman=pma**2/pmr**2
25246  pmbn=pmb**2/pmr**2
25247  pmcn=pmc**2/pmr**2
25248  pmbcn=pmbc**2/pmr**2
25249  facnom=sqrt(max(0d0,
25250  & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
25251  & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
25252  & ((pmr-pma)**2-(pmb+pmc)**2)*
25253  & (1d0+0.25d0*(pma+pmb+pmc)/pmr)/
25254  & ((1d0-pmbcn)*pmbcn*pmr**2)
25255  wdtp(i)=wdtp(i)*facact/max(1d-6,facnom)
25256  ENDIF
25257  wdtp(i)=fudge*wdtp(i)
25258  wdtp(0)=wdtp(0)+wdtp(i)
25259 
25260 C...Calculate secondary width (at most two identical/opposite).
25261  wid2=1d0
25262  IF(mdme(idc,1).GT.0) THEN
25263  IF(kfd2.EQ.kfd1) THEN
25264  IF(kchg(kfc1,3).EQ.0) THEN
25265  wid2=wids(kfc1,1)
25266  ELSEIF(kfd1.GT.0) THEN
25267  wid2=wids(kfc1,4)
25268  ELSE
25269  wid2=wids(kfc1,5)
25270  ENDIF
25271  IF(kfd3.GT.0) THEN
25272  wid2=wid2*wids(kfc3,2)
25273  ELSEIF(kfd3.LT.0) THEN
25274  wid2=wid2*wids(kfc3,3)
25275  ENDIF
25276  ELSEIF(kfd2.EQ.-kfd1) THEN
25277  wid2=wids(kfc1,1)
25278  IF(kfd3.GT.0) THEN
25279  wid2=wid2*wids(kfc3,2)
25280  ELSEIF(kfd3.LT.0) THEN
25281  wid2=wid2*wids(kfc3,3)
25282  ENDIF
25283  ELSEIF(kfd3.EQ.kfd1) THEN
25284  IF(kchg(kfc1,3).EQ.0) THEN
25285  wid2=wids(kfc1,1)
25286  ELSEIF(kfd1.GT.0) THEN
25287  wid2=wids(kfc1,4)
25288  ELSE
25289  wid2=wids(kfc1,5)
25290  ENDIF
25291  IF(kfd2.GT.0) THEN
25292  wid2=wid2*wids(kfc2,2)
25293  ELSEIF(kfd2.LT.0) THEN
25294  wid2=wid2*wids(kfc2,3)
25295  ENDIF
25296  ELSEIF(kfd3.EQ.-kfd1) THEN
25297  wid2=wids(kfc1,1)
25298  IF(kfd2.GT.0) THEN
25299  wid2=wid2*wids(kfc2,2)
25300  ELSEIF(kfd2.LT.0) THEN
25301  wid2=wid2*wids(kfc2,3)
25302  ENDIF
25303  ELSEIF(kfd3.EQ.kfd2) THEN
25304  IF(kchg(kfc2,3).EQ.0) THEN
25305  wid2=wids(kfc2,1)
25306  ELSEIF(kfd2.GT.0) THEN
25307  wid2=wids(kfc2,4)
25308  ELSE
25309  wid2=wids(kfc2,5)
25310  ENDIF
25311  IF(kfd1.GT.0) THEN
25312  wid2=wid2*wids(kfc1,2)
25313  ELSEIF(kfd1.LT.0) THEN
25314  wid2=wid2*wids(kfc1,3)
25315  ENDIF
25316  ELSEIF(kfd3.EQ.-kfd2) THEN
25317  wid2=wids(kfc2,1)
25318  IF(kfd1.GT.0) THEN
25319  wid2=wid2*wids(kfc1,2)
25320  ELSEIF(kfd1.LT.0) THEN
25321  wid2=wid2*wids(kfc1,3)
25322  ENDIF
25323  ELSE
25324  IF(kfd1.GT.0) THEN
25325  wid2=wids(kfc1,2)
25326  ELSE
25327  wid2=wids(kfc1,3)
25328  ENDIF
25329  IF(kfd2.GT.0) THEN
25330  wid2=wid2*wids(kfc2,2)
25331  ELSE
25332  wid2=wid2*wids(kfc2,3)
25333  ENDIF
25334  IF(kfd3.GT.0) THEN
25335  wid2=wid2*wids(kfc3,2)
25336  ELSEIF(kfd3.LT.0) THEN
25337  wid2=wid2*wids(kfc3,3)
25338  ENDIF
25339  ENDIF
25340 
25341 C...Store effective widths according to case.
25342 C...PS: bug fix 16/2 2012 to avoid problems caused by adding 0.0*NaN
25343  IF (wdtp(i).GT.0d0) THEN
25344  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25345  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))
25346  & +wdte(i,mdme(idc,1))
25347  wdte(i,0)=wdte(i,mdme(idc,1))
25348  wdte(0,0)=wdte(0,0)+wdte(i,0)
25349  ELSE
25350  wdte(i,mdme(idc,1))= 0d0
25351  wdte(i,0)= 0d0
25352  ENDIF
25353  ENDIF
25354  120 CONTINUE
25355 C...Return.
25356  mint(61)=0
25357  mint(62)=0
25358  mint(63)=0
25359  RETURN
25360  ENDIF
25361 
25362 C...Here begins detailed dynamical calculation of resonance widths.
25363 C...Shared treatment of Higgs states.
25364  kfhigg=25
25365  ihigg=1
25366  IF(kfla.EQ.35.OR.kfla.EQ.36) THEN
25367  kfhigg=kfla
25368  ihigg=kfla-33
25369  ENDIF
25370 
25371 C...Common electroweak and strong constants.
25372  xw=paru(102)
25373  xwv=xw
25374  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
25375  xw1=1d0-xw
25376  aem=pyalem(sh)
25377  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
25378  as=pyalps(sh)
25379  radc=1d0+as/paru(1)
25380 
25381  IF(kfla.EQ.6) THEN
25382 C...t quark.
25383  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
25384  radct=1d0-2.5d0*as/paru(1)
25385  DO 140 i=1,mdcy(kc,3)
25386  idc=i+mdcy(kc,2)-1
25387  IF(mdme(idc,1).LT.0) goto 140
25388  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25389  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25390  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 140
25391  wid2=1d0
25392  IF(i.GE.4.AND.i.LE.7) THEN
25393 C...t -> W + q; including approximate QCD correction factor.
25394  wdtp(i)=fac*vckm(3,i-3)*radct*
25395  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25396  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
25397  IF(kflr.GT.0) THEN
25398  wid2=wids(24,2)
25399  IF(i.EQ.7) wid2=wid2*wids(7,2)
25400  ELSE
25401  wid2=wids(24,3)
25402  IF(i.EQ.7) wid2=wid2*wids(7,3)
25403  ENDIF
25404  ELSEIF(i.EQ.9) THEN
25405 C...t -> H + b.
25406  rm2r=pymrun(kfdp(idc,2),sh)**2/sh
25407  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25408  & ((1d0+rm2-rm1)*(rm2r*paru(141)**2+1d0/paru(141)**2)+
25409  & 4d0*sqrt(rm2r*rm2))
25410  wid2=wids(37,2)
25411  IF(kflr.LT.0) wid2=wids(37,3)
25412 CMRENNA++
25413  ELSEIF(i.GE.10.AND.i.LE.13.AND.imss(1).NE.0) THEN
25414 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
25415  beta=atan(rmss(5))
25416  sinb=sin(beta)
25417  tanw=sqrt(paru(102)/(1d0-paru(102)))
25418  et=kchg(6,1)/3d0
25419  t3l=sign(0.5d0,et)
25420  kfc1=pycomp(kfdp(idc,1))
25421  kfc2=pycomp(kfdp(idc,2))
25422  pmnchi=pmas(kfc1,1)
25423  pmstop=pmas(kfc2,1)
25424  IF(shr.GT.pmnchi+pmstop) THEN
25425  iz=i-9
25426  DO 130 ik=1,4
25427  zmixc(iz,ik)=dcmplx(zmix(iz,ik),zmixi(iz,ik))
25428  130 CONTINUE
25429  al=shr*dconjg(zmixc(iz,4))/(2.0d0*pmas(24,1)*sinb)
25430  ar=-et*zmixc(iz,1)*tanw
25431  bl=t3l*(zmixc(iz,2)-zmixc(iz,1)*tanw)-ar
25432  br=al
25433  fl=sfmix(6,1)*al+sfmix(6,2)*ar
25434  fr=sfmix(6,1)*bl+sfmix(6,2)*br
25435  pcm=sqrt((sh-(pmnchi+pmstop)**2)*
25436  & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
25437  wdtp(i)=(0.5d0*pyalem(sh)/paru(102))*pcm*
25438  & ((abs(fl)**2+abs(fr)**2)*(sh+pmnchi**2-pmstop**2)+
25439  & smz(iz)*4d0*shr*dble(fl*dconjg(fr)))/sh
25440  IF(kflr.GT.0) THEN
25441  wid2=wids(kfc1,2)*wids(kfc2,2)
25442  ELSE
25443  wid2=wids(kfc1,2)*wids(kfc2,3)
25444  ENDIF
25445  ENDIF
25446  ELSEIF(i.EQ.14.AND.imss(1).NE.0) THEN
25447 C...t -> ~g + ~t
25448  kfc1=pycomp(kfdp(idc,1))
25449  kfc2=pycomp(kfdp(idc,2))
25450  pmnchi=pmas(kfc1,1)
25451  pmstop=pmas(kfc2,1)
25452  IF(shr.GT.pmnchi+pmstop) THEN
25453  rl=sfmix(6,1)
25454  rr=-sfmix(6,2)
25455  pcm=sqrt((sh-(pmnchi+pmstop)**2)*
25456  & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
25457  wdtp(i)=4d0/3d0*0.5d0*pyalps(sh)*pcm*((rl**2+rr**2)*
25458  & (sh+pmnchi**2-pmstop**2)+pmnchi*4d0*shr*rl*rr)/sh
25459  IF(kflr.GT.0) THEN
25460  wid2=wids(kfc1,2)*wids(kfc2,2)
25461  ELSE
25462  wid2=wids(kfc1,2)*wids(kfc2,3)
25463  ENDIF
25464  ENDIF
25465  ELSEIF(i.EQ.15.AND.imss(1).NE.0) THEN
25466 C...t -> ~gravitino + ~t
25467  xmp2=rmss(29)**2
25468  kfc1=pycomp(kfdp(idc,1))
25469  xmgr2=pmas(kfc1,1)**2
25470  wdtp(i)=sh**2*shr/(96d0*paru(1)*xmp2*xmgr2)*(1d0-rm2)**4
25471  kfc2=pycomp(kfdp(idc,2))
25472  wid2=wids(kfc2,2)
25473  IF(kflr.LT.0) wid2=wids(kfc2,3)
25474 CMRENNA--
25475  ENDIF
25476  wdtp(i)=fudge*wdtp(i)
25477  wdtp(0)=wdtp(0)+wdtp(i)
25478  IF(mdme(idc,1).GT.0) THEN
25479  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25480  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25481  wdte(i,0)=wdte(i,mdme(idc,1))
25482  wdte(0,0)=wdte(0,0)+wdte(i,0)
25483  ENDIF
25484  140 CONTINUE
25485 
25486  ELSEIF(kfla.EQ.7) THEN
25487 C...b' quark.
25488  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
25489  DO 150 i=1,mdcy(kc,3)
25490  idc=i+mdcy(kc,2)-1
25491  IF(mdme(idc,1).LT.0) goto 150
25492  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25493  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25494  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 150
25495  wid2=1d0
25496  IF(i.GE.4.AND.i.LE.7) THEN
25497 C...b' -> W + q.
25498  wdtp(i)=fac*vckm(i-3,4)*
25499  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25500  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
25501  IF(kflr.GT.0) THEN
25502  wid2=wids(24,3)
25503  IF(i.EQ.6) wid2=wid2*wids(6,2)
25504  IF(i.EQ.7) wid2=wid2*wids(8,2)
25505  ELSE
25506  wid2=wids(24,2)
25507  IF(i.EQ.6) wid2=wid2*wids(6,3)
25508  IF(i.EQ.7) wid2=wid2*wids(8,3)
25509  ENDIF
25510  wid2=wids(24,3)
25511  IF(kflr.LT.0) wid2=wids(24,2)
25512  ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
25513 C...b' -> H + q.
25514  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25515  & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
25516  IF(kflr.GT.0) THEN
25517  wid2=wids(37,3)
25518  IF(i.EQ.10) wid2=wid2*wids(6,2)
25519  ELSE
25520  wid2=wids(37,2)
25521  IF(i.EQ.10) wid2=wid2*wids(6,3)
25522  ENDIF
25523  ENDIF
25524  wdtp(i)=fudge*wdtp(i)
25525  wdtp(0)=wdtp(0)+wdtp(i)
25526  IF(mdme(idc,1).GT.0) THEN
25527  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25528  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25529  wdte(i,0)=wdte(i,mdme(idc,1))
25530  wdte(0,0)=wdte(0,0)+wdte(i,0)
25531  ENDIF
25532  150 CONTINUE
25533 
25534  ELSEIF(kfla.EQ.8) THEN
25535 C...t' quark.
25536  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
25537  DO 160 i=1,mdcy(kc,3)
25538  idc=i+mdcy(kc,2)-1
25539  IF(mdme(idc,1).LT.0) goto 160
25540  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25541  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25542  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 160
25543  wid2=1d0
25544  IF(i.GE.4.AND.i.LE.7) THEN
25545 C...t' -> W + q.
25546  wdtp(i)=fac*vckm(4,i-3)*
25547  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25548  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
25549  IF(kflr.GT.0) THEN
25550  wid2=wids(24,2)
25551  IF(i.EQ.7) wid2=wid2*wids(7,2)
25552  ELSE
25553  wid2=wids(24,3)
25554  IF(i.EQ.7) wid2=wid2*wids(7,3)
25555  ENDIF
25556  ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
25557 C...t' -> H + q.
25558  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25559  & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
25560  IF(kflr.GT.0) THEN
25561  wid2=wids(37,2)
25562  IF(i.EQ.10) wid2=wid2*wids(7,2)
25563  ELSE
25564  wid2=wids(37,3)
25565  IF(i.EQ.10) wid2=wid2*wids(7,3)
25566  ENDIF
25567  ENDIF
25568  wdtp(i)=fudge*wdtp(i)
25569  wdtp(0)=wdtp(0)+wdtp(i)
25570  IF(mdme(idc,1).GT.0) THEN
25571  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25572  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25573  wdte(i,0)=wdte(i,mdme(idc,1))
25574  wdte(0,0)=wdte(0,0)+wdte(i,0)
25575  ENDIF
25576  160 CONTINUE
25577 
25578  ELSEIF(kfla.EQ.17) THEN
25579 C...tau' lepton.
25580  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
25581  DO 170 i=1,mdcy(kc,3)
25582  idc=i+mdcy(kc,2)-1
25583  IF(mdme(idc,1).LT.0) goto 170
25584  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25585  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25586  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 170
25587  wid2=1d0
25588  IF(i.EQ.3) THEN
25589 C...tau' -> W + nu'_tau.
25590  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25591  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
25592  IF(kflr.GT.0) THEN
25593  wid2=wids(24,3)
25594  wid2=wid2*wids(18,2)
25595  ELSE
25596  wid2=wids(24,2)
25597  wid2=wid2*wids(18,3)
25598  ENDIF
25599  ELSEIF(i.EQ.5) THEN
25600 C...tau' -> H + nu'_tau.
25601  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25602  & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
25603  IF(kflr.GT.0) THEN
25604  wid2=wids(37,3)
25605  wid2=wid2*wids(18,2)
25606  ELSE
25607  wid2=wids(37,2)
25608  wid2=wid2*wids(18,3)
25609  ENDIF
25610  ENDIF
25611  wdtp(i)=fudge*wdtp(i)
25612  wdtp(0)=wdtp(0)+wdtp(i)
25613  IF(mdme(idc,1).GT.0) THEN
25614  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25615  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25616  wdte(i,0)=wdte(i,mdme(idc,1))
25617  wdte(0,0)=wdte(0,0)+wdte(i,0)
25618  ENDIF
25619  170 CONTINUE
25620 
25621  ELSEIF(kfla.EQ.18) THEN
25622 C...nu'_tau neutrino.
25623  fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
25624  DO 180 i=1,mdcy(kc,3)
25625  idc=i+mdcy(kc,2)-1
25626  IF(mdme(idc,1).LT.0) goto 180
25627  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25628  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25629  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 180
25630  wid2=1d0
25631  IF(i.EQ.2) THEN
25632 C...nu'_tau -> W + tau'.
25633  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25634  & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
25635  IF(kflr.GT.0) THEN
25636  wid2=wids(24,2)
25637  wid2=wid2*wids(17,2)
25638  ELSE
25639  wid2=wids(24,3)
25640  wid2=wid2*wids(17,3)
25641  ENDIF
25642  ELSEIF(i.EQ.3) THEN
25643 C...nu'_tau -> H + tau'.
25644  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
25645  & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
25646  IF(kflr.GT.0) THEN
25647  wid2=wids(37,2)
25648  wid2=wid2*wids(17,2)
25649  ELSE
25650  wid2=wids(37,3)
25651  wid2=wid2*wids(17,3)
25652  ENDIF
25653  ENDIF
25654  wdtp(i)=fudge*wdtp(i)
25655  wdtp(0)=wdtp(0)+wdtp(i)
25656  IF(mdme(idc,1).GT.0) THEN
25657  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25658  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25659  wdte(i,0)=wdte(i,mdme(idc,1))
25660  wdte(0,0)=wdte(0,0)+wdte(i,0)
25661  ENDIF
25662  180 CONTINUE
25663 
25664  ELSEIF(kfla.EQ.21) THEN
25665 C...QCD:
25666 C***Note that widths are not given in dimensional quantities here.
25667  DO 190 i=1,mdcy(kc,3)
25668  idc=i+mdcy(kc,2)-1
25669  IF(mdme(idc,1).LT.0) goto 190
25670  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25671  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25672  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 190
25673  wid2=1d0
25674  IF(i.LE.8) THEN
25675 C...QCD -> q + qbar
25676  wdtp(i)=(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
25677  IF(i.EQ.6) wid2=wids(6,1)
25678  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25679  ENDIF
25680  wdtp(i)=fudge*wdtp(i)
25681  wdtp(0)=wdtp(0)+wdtp(i)
25682  IF(mdme(idc,1).GT.0) THEN
25683  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25684  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25685  wdte(i,0)=wdte(i,mdme(idc,1))
25686  wdte(0,0)=wdte(0,0)+wdte(i,0)
25687  ENDIF
25688  190 CONTINUE
25689 
25690  ELSEIF(kfla.EQ.22) THEN
25691 C...QED photon.
25692 C***Note that widths are not given in dimensional quantities here.
25693  DO 200 i=1,mdcy(kc,3)
25694  idc=i+mdcy(kc,2)-1
25695  IF(mdme(idc,1).LT.0) goto 200
25696  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25697  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25698  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 200
25699  wid2=1d0
25700  IF(i.LE.8) THEN
25701 C...QED -> q + qbar.
25702  ef=kchg(i,1)/3d0
25703  fcof=3d0*radc
25704  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
25705  wdtp(i)=fcof*ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
25706  IF(i.EQ.6) wid2=wids(6,1)
25707  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25708  ELSEIF(i.LE.12) THEN
25709 C...QED -> l+ + l-.
25710  ef=kchg(9+2*(i-8),1)/3d0
25711  wdtp(i)=ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
25712  IF(i.EQ.12) wid2=wids(17,1)
25713  ENDIF
25714  wdtp(i)=fudge*wdtp(i)
25715  wdtp(0)=wdtp(0)+wdtp(i)
25716  IF(mdme(idc,1).GT.0) THEN
25717  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25718  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25719  wdte(i,0)=wdte(i,mdme(idc,1))
25720  wdte(0,0)=wdte(0,0)+wdte(i,0)
25721  ENDIF
25722  200 CONTINUE
25723 
25724  ELSEIF(kfla.EQ.23) THEN
25725 C...Z0:
25726  icase=1
25727  xwc=1d0/(16d0*xw*xw1)
25728  fac=(aem*xwc/3d0)*shr
25729  210 CONTINUE
25730  IF(mint(61).GE.1.AND.icase.EQ.2) THEN
25731  vint(111)=0d0
25732  vint(112)=0d0
25733  vint(114)=0d0
25734  ENDIF
25735  IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25736  kfi=iabs(mint(15))
25737  IF(kfi.GT.20) kfi=iabs(mint(16))
25738  ei=kchg(kfi,1)/3d0
25739  ai=sign(1d0,ei)
25740  vi=ai-4d0*ei*xwv
25741  sqmz=pmas(23,1)**2
25742  hz=shr*wdtp(0)
25743  IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=1d0
25744  IF(mstp(43).EQ.3) vint(112)=
25745  & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
25746  IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
25747  & xwc**2*sh**2/((sh-sqmz)**2+hz**2)
25748  ENDIF
25749  DO 220 i=1,mdcy(kc,3)
25750  idc=i+mdcy(kc,2)-1
25751  IF(mdme(idc,1).LT.0) goto 220
25752  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25753  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25754  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 220
25755  wid2=1d0
25756  IF(i.LE.8) THEN
25757 C...Z0 -> q + qbar
25758  ef=kchg(i,1)/3d0
25759  af=sign(1d0,ef+0.1d0)
25760  vf=af-4d0*ef*xwv
25761  fcof=3d0*radc
25762  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
25763  IF(i.EQ.6) wid2=wids(6,1)
25764  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25765  ELSEIF(i.LE.16) THEN
25766 C...Z0 -> l+ + l-, nu + nubar
25767  ef=kchg(i+2,1)/3d0
25768  af=sign(1d0,ef+0.1d0)
25769  vf=af-4d0*ef*xwv
25770  fcof=1d0
25771  IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
25772  ENDIF
25773  be34=sqrt(max(0d0,1d0-4d0*rm1))
25774  IF(icase.EQ.1) THEN
25775  wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
25776  & be34
25777  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25778  wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
25779  & ef*vf+(vi**2+ai**2)*vint(114)*vf**2)*(1d0+2d0*rm1)+
25780  & (vi**2+ai**2)*vint(114)*af**2*(1d0-4d0*rm1))*be34
25781  ELSEIF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25782  fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
25783  fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
25784  fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
25785  ENDIF
25786  IF(icase.EQ.1) wdtp(i)=fudge*wdtp(i)
25787  IF(icase.EQ.1) wdtp(0)=wdtp(0)+wdtp(i)
25788  IF(mdme(idc,1).GT.0) THEN
25789  IF((icase.EQ.1.AND.mint(61).NE.1).OR.
25790  & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
25791  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25792  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
25793  & wdte(i,mdme(idc,1))
25794  wdte(i,0)=wdte(i,mdme(idc,1))
25795  wdte(0,0)=wdte(0,0)+wdte(i,0)
25796  ENDIF
25797  IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25798  IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=
25799  & vint(111)+fggf*wid2
25800  IF(mstp(43).EQ.3) vint(112)=vint(112)+fgzf*wid2
25801  IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
25802  & vint(114)+fzzf*wid2
25803  ENDIF
25804  ENDIF
25805  220 CONTINUE
25806  IF(mint(61).GE.1) icase=3-icase
25807  IF(icase.EQ.2) goto 210
25808 
25809  ELSEIF(kfla.EQ.24) THEN
25810 C...W+/-:
25811  fac=(aem/(24d0*xw))*shr
25812  DO 230 i=1,mdcy(kc,3)
25813  idc=i+mdcy(kc,2)-1
25814  IF(mdme(idc,1).LT.0) goto 230
25815  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25816  rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25817  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 230
25818  wid2=1d0
25819  IF(i.LE.16) THEN
25820 C...W+/- -> q + qbar'
25821  fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
25822  IF(kflr.GT.0) THEN
25823  IF(mod(i,4).EQ.3) wid2=wids(6,2)
25824  IF(mod(i,4).EQ.0) wid2=wids(8,2)
25825  IF(i.GE.13) wid2=wid2*wids(7,3)
25826  ELSE
25827  IF(mod(i,4).EQ.3) wid2=wids(6,3)
25828  IF(mod(i,4).EQ.0) wid2=wids(8,3)
25829  IF(i.GE.13) wid2=wid2*wids(7,2)
25830  ENDIF
25831  ELSEIF(i.LE.20) THEN
25832 C...W+/- -> l+/- + nu
25833  fcof=1d0
25834  IF(kflr.GT.0) THEN
25835  IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
25836  ELSE
25837  IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
25838  ENDIF
25839  ENDIF
25840  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
25841  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25842  wdtp(i)=fudge*wdtp(i)
25843  wdtp(0)=wdtp(0)+wdtp(i)
25844  IF(mdme(idc,1).GT.0) THEN
25845  wdte(i,mdme(idc,1))=wdtp(i)*wid2
25846  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25847  wdte(i,0)=wdte(i,mdme(idc,1))
25848  wdte(0,0)=wdte(0,0)+wdte(i,0)
25849  ENDIF
25850  230 CONTINUE
25851 
25852  ELSEIF(kfla.EQ.25.OR.kfla.EQ.35.OR.kfla.EQ.36) THEN
25853 C...h0 (or H0, or A0):
25854  shfs=sh
25855  fac=(aem/(8d0*xw))*(shfs/pmas(24,1)**2)*shr
25856  DO 270 i=1,mdcy(kfhigg,3)
25857  idc=i+mdcy(kfhigg,2)-1
25858  IF(mdme(idc,1).LT.0) goto 270
25859  kfc1=pycomp(kfdp(idc,1))
25860  kfc2=pycomp(kfdp(idc,2))
25861  rm1=pmas(kfc1,1)**2/sh
25862  rm2=pmas(kfc2,1)**2/sh
25863  IF(i.NE.16.AND.i.NE.17.AND.sqrt(rm1)+sqrt(rm2).GT.1d0)
25864  & goto 270
25865  wid2=1d0
25866 
25867  IF(i.LE.8) THEN
25868 C...h0 -> q + qbar
25869  wdtp(i)=fac*3d0*(pymrun(kfdp(idc,1),sh)**2/shfs)*
25870  & sqrt(max(0d0,1d0-4d0*rm1))*radc
25871 C...A0 behaves like beta, ho and H0 like beta**3.
25872  IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
25873  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25874  IF(mod(i,2).EQ.1) wdtp(i)=wdtp(i)*paru(151+10*ihigg)**2
25875  IF(mod(i,2).EQ.0) wdtp(i)=wdtp(i)*paru(152+10*ihigg)**2
25876  IF(imss(1).NE.0.AND.kfc1.EQ.5) THEN
25877  wdtp(i)=wdtp(i)/(1d0+rmss(41))**2
25878  IF(ihigg.NE.3) THEN
25879  wdtp(i)=wdtp(i)*(1d0+rmss(41)*paru(152+10*ihigg)/
25880  & paru(151+10*ihigg))**2
25881  ENDIF
25882  ENDIF
25883  ENDIF
25884  IF(i.EQ.6) wid2=wids(6,1)
25885  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25886  ELSEIF(i.LE.12) THEN
25887 C...h0 -> l+ + l-
25888  wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))*(sh/shfs)
25889 C...A0 behaves like beta, ho and H0 like beta**3.
25890  IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
25891  IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
25892  & paru(153+10*ihigg)**2
25893  IF(i.EQ.12) wid2=wids(17,1)
25894 
25895  ELSEIF(i.EQ.13) THEN
25896 C...h0 -> g + g; quark loop contribution only
25897  etare=0d0
25898  etaim=0d0
25899  DO 240 j=1,2*mstp(1)
25900  eps=(2d0*pmas(j,1))**2/sh
25901 C...Loop integral; function of eps=4m^2/shat; different for A0.
25902  IF(eps.LE.1d0) THEN
25903  IF(eps.GT.1d-4) THEN
25904  root=sqrt(1d0-eps)
25905  rln=log((1d0+root)/(1d0-root))
25906  ELSE
25907  rln=log(4d0/eps-2d0)
25908  ENDIF
25909  phire=-0.25d0*(rln**2-paru(1)**2)
25910  phiim=0.5d0*paru(1)*rln
25911  ELSE
25912  phire=(asin(1d0/sqrt(eps)))**2
25913  phiim=0d0
25914  ENDIF
25915  IF(ihigg.LE.2) THEN
25916  etarej=-0.5d0*eps*(1d0+(1d0-eps)*phire)
25917  etaimj=-0.5d0*eps*(1d0-eps)*phiim
25918  ELSE
25919  etarej=-0.5d0*eps*phire
25920  etaimj=-0.5d0*eps*phiim
25921  ENDIF
25922 C...Couplings (=1 for standard model Higgs).
25923  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25924  IF(mod(j,2).EQ.1) THEN
25925  etarej=etarej*paru(151+10*ihigg)
25926  etaimj=etaimj*paru(151+10*ihigg)
25927  ELSE
25928  etarej=etarej*paru(152+10*ihigg)
25929  etaimj=etaimj*paru(152+10*ihigg)
25930  ENDIF
25931  ENDIF
25932  etare=etare+etarej
25933  etaim=etaim+etaimj
25934  240 CONTINUE
25935  eta2=etare**2+etaim**2
25936  wdtp(i)=fac*(as/paru(1))**2*eta2
25937 
25938  ELSEIF(i.EQ.14) THEN
25939 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25940  etare=0d0
25941  etaim=0d0
25942  jmax=3*mstp(1)+1
25943  IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
25944  DO 250 j=1,jmax
25945  IF(j.LE.2*mstp(1)) THEN
25946  ej=kchg(j,1)/3d0
25947  eps=(2d0*pmas(j,1))**2/sh
25948  ELSEIF(j.LE.3*mstp(1)) THEN
25949  jl=2*(j-2*mstp(1))-1
25950  ej=kchg(10+jl,1)/3d0
25951  eps=(2d0*pmas(10+jl,1))**2/sh
25952  ELSEIF(j.EQ.3*mstp(1)+1) THEN
25953  eps=(2d0*pmas(24,1))**2/sh
25954  ELSE
25955  eps=(2d0*pmas(37,1))**2/sh
25956  ENDIF
25957 C...Loop integral; function of eps=4m^2/shat.
25958  IF(eps.LE.1d0) THEN
25959  IF(eps.GT.1d-4) THEN
25960  root=sqrt(1d0-eps)
25961  rln=log((1d0+root)/(1d0-root))
25962  ELSE
25963  rln=log(4d0/eps-2d0)
25964  ENDIF
25965  phire=-0.25d0*(rln**2-paru(1)**2)
25966  phiim=0.5d0*paru(1)*rln
25967  ELSE
25968  phire=(asin(1d0/sqrt(eps)))**2
25969  phiim=0d0
25970  ENDIF
25971  IF(j.LE.3*mstp(1)) THEN
25972 C...Fermion loops: loop integral different for A0; charges.
25973  IF(ihigg.LE.2) THEN
25974  phipre=-0.5d0*eps*(1d0+(1d0-eps)*phire)
25975  phipim=-0.5d0*eps*(1d0-eps)*phiim
25976  ELSE
25977  phipre=-0.5d0*eps*phire
25978  phipim=-0.5d0*eps*phiim
25979  ENDIF
25980  IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
25981  ejc=3d0*ej**2
25982  ejh=paru(151+10*ihigg)
25983  ELSEIF(j.LE.2*mstp(1)) THEN
25984  ejc=3d0*ej**2
25985  ejh=paru(152+10*ihigg)
25986  ELSE
25987  ejc=ej**2
25988  ejh=paru(153+10*ihigg)
25989  ENDIF
25990  IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
25991  etarej=ejc*ejh*phipre
25992  etaimj=ejc*ejh*phipim
25993  ELSEIF(j.EQ.3*mstp(1)+1) THEN
25994 C...W loops: loop integral and charges.
25995  etarej=0.5d0+0.75d0*eps*(1d0+(2d0-eps)*phire)
25996  etaimj=0.75d0*eps*(2d0-eps)*phiim
25997  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25998  etarej=etarej*paru(155+10*ihigg)
25999  etaimj=etaimj*paru(155+10*ihigg)
26000  ENDIF
26001  ELSE
26002 C...Charged H loops: loop integral and charges.
26003  fachhh=(pmas(24,1)/pmas(37,1))**2*
26004  & paru(158+10*ihigg+2*(ihigg/3))
26005  etarej=eps*(1d0-eps*phire)*fachhh
26006  etaimj=-eps**2*phiim*fachhh
26007  ENDIF
26008  etare=etare+etarej
26009  etaim=etaim+etaimj
26010  250 CONTINUE
26011  eta2=etare**2+etaim**2
26012  wdtp(i)=fac*(aem/paru(1))**2*0.5d0*eta2
26013 
26014  ELSEIF(i.EQ.15) THEN
26015 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
26016  etare=0d0
26017  etaim=0d0
26018  jmax=3*mstp(1)+1
26019  IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
26020  DO 260 j=1,jmax
26021  IF(j.LE.2*mstp(1)) THEN
26022  ej=kchg(j,1)/3d0
26023  aj=sign(1d0,ej+0.1d0)
26024  vj=aj-4d0*ej*xwv
26025  eps=(2d0*pmas(j,1))**2/sh
26026  epsp=(2d0*pmas(j,1)/pmas(23,1))**2
26027  ELSEIF(j.LE.3*mstp(1)) THEN
26028  jl=2*(j-2*mstp(1))-1
26029  ej=kchg(10+jl,1)/3d0
26030  aj=sign(1d0,ej+0.1d0)
26031  vj=aj-4d0*ej*xwv
26032  eps=(2d0*pmas(10+jl,1))**2/sh
26033  epsp=(2d0*pmas(10+jl,1)/pmas(23,1))**2
26034  ELSE
26035  eps=(2d0*pmas(24,1))**2/sh
26036  epsp=(2d0*pmas(24,1)/pmas(23,1))**2
26037  ENDIF
26038 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
26039  IF(eps.LE.1d0) THEN
26040  root=sqrt(1d0-eps)
26041  IF(eps.GT.1d-4) THEN
26042  rln=log((1d0+root)/(1d0-root))
26043  ELSE
26044  rln=log(4d0/eps-2d0)
26045  ENDIF
26046  phire=-0.25d0*(rln**2-paru(1)**2)
26047  phiim=0.5d0*paru(1)*rln
26048  psire=0.5d0*root*rln
26049  psiim=-0.5d0*root*paru(1)
26050  ELSE
26051  phire=(asin(1d0/sqrt(eps)))**2
26052  phiim=0d0
26053  psire=sqrt(eps-1d0)*asin(1d0/sqrt(eps))
26054  psiim=0d0
26055  ENDIF
26056  IF(epsp.LE.1d0) THEN
26057  root=sqrt(1d0-epsp)
26058  IF(epsp.GT.1d-4) THEN
26059  rln=log((1d0+root)/(1d0-root))
26060  ELSE
26061  rln=log(4d0/epsp-2d0)
26062  ENDIF
26063  phirep=-0.25d0*(rln**2-paru(1)**2)
26064  phiimp=0.5d0*paru(1)*rln
26065  psirep=0.5d0*root*rln
26066  psiimp=-0.5d0*root*paru(1)
26067  ELSE
26068  phirep=(asin(1d0/sqrt(epsp)))**2
26069  phiimp=0d0
26070  psirep=sqrt(epsp-1d0)*asin(1d0/sqrt(epsp))
26071  psiimp=0d0
26072  ENDIF
26073  fxyre=eps*epsp/(8d0*(eps-epsp))*(1d0+eps*epsp/(eps-epsp)*
26074  & (phire-phirep)+2d0*eps/(eps-epsp)*(psire-psirep))
26075  fxyim=eps**2*epsp/(8d0*(eps-epsp)**2)*
26076  & (epsp*(phiim-phiimp)+2d0*(psiim-psiimp))
26077  f1re=-eps*epsp/(2d0*(eps-epsp))*(phire-phirep)
26078  f1im=-eps*epsp/(2d0*(eps-epsp))*(phiim-phiimp)
26079  IF(j.LE.3*mstp(1)) THEN
26080 C...Fermion loops: loop integral different for A0; charges.
26081  IF(ihigg.EQ.3) fxyre=0d0
26082  IF(ihigg.EQ.3) fxyim=0d0
26083  IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
26084  ejc=-3d0*ej*vj
26085  ejh=paru(151+10*ihigg)
26086  ELSEIF(j.LE.2*mstp(1)) THEN
26087  ejc=-3d0*ej*vj
26088  ejh=paru(152+10*ihigg)
26089  ELSE
26090  ejc=-ej*vj
26091  ejh=paru(153+10*ihigg)
26092  ENDIF
26093  IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
26094  etarej=ejc*ejh*(fxyre-0.25d0*f1re)
26095  etaimj=ejc*ejh*(fxyim-0.25d0*f1im)
26096  ELSEIF(j.EQ.3*mstp(1)+1) THEN
26097 C...W loops: loop integral and charges.
26098  heps=(1d0+2d0/eps)*xw/xw1-(5d0+2d0/eps)
26099  etarej=-xw1*((3d0-xw/xw1)*f1re+heps*fxyre)
26100  etaimj=-xw1*((3d0-xw/xw1)*f1im+heps*fxyim)
26101  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
26102  etarej=etarej*paru(155+10*ihigg)
26103  etaimj=etaimj*paru(155+10*ihigg)
26104  ENDIF
26105  ELSE
26106 C...Charged H loops: loop integral and charges.
26107  fachhh=(pmas(24,1)/pmas(37,1))**2*(1d0-2d0*xw)*
26108  & paru(158+10*ihigg+2*(ihigg/3))
26109  etarej=fachhh*fxyre
26110  etaimj=fachhh*fxyim
26111  ENDIF
26112  etare=etare+etarej
26113  etaim=etaim+etaimj
26114  260 CONTINUE
26115  eta2=(etare**2+etaim**2)/(xw*xw1)
26116  wdtp(i)=fac*(aem/paru(1))**2*(1d0-pmas(23,1)**2/sh)**3*eta2
26117  wid2=wids(23,2)
26118 
26119  ELSEIF(i.LE.17) THEN
26120 C...h0 -> Z0 + Z0, W+ + W-
26121  pm1=pmas(iabs(kfdp(idc,1)),1)
26122  pg1=pmas(iabs(kfdp(idc,1)),2)
26123  IF(mint(62).GE.1) THEN
26124  IF(mstp(42).EQ.0.OR.(4d0*(pm1+10d0*pg1)**2.LT.sh.AND.
26125  & ckin(46).LT.ckin(45).AND.ckin(48).LT.ckin(47).AND.
26126  & max(ckin(45),ckin(47)).LT.pm1-10d0*pg1)) THEN
26127  mofsv(ihigg,i-15)=0
26128  widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
26129  & 1d0-4d0*rm1))
26130  wid2=1d0
26131  ELSE
26132  mofsv(ihigg,i-15)=1
26133  rmas=sqrt(max(0d0,sh))
26134  CALL pyofsh(1,kfla,kfdp(idc,1),kfdp(idc,2),rmas,widw,
26135  & wid2)
26136  widwsv(ihigg,i-15)=widw
26137  wid2sv(ihigg,i-15)=wid2
26138  ENDIF
26139  ELSE
26140  IF(mofsv(ihigg,i-15).EQ.0) THEN
26141  widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
26142  & 1d0-4d0*rm1))
26143  wid2=1d0
26144  ELSE
26145  widw=widwsv(ihigg,i-15)
26146  wid2=wid2sv(ihigg,i-15)
26147  ENDIF
26148  ENDIF
26149  wdtp(i)=fac*widw/(2d0*(18-i))
26150  IF(mstp(49).NE.0) wdtp(i)=wdtp(i)*pmas(kfhigg,1)**2/shfs
26151  IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
26152  & paru(138+i+10*ihigg)**2
26153  wid2=wid2*wids(7+i,1)
26154 
26155  ELSEIF(i.EQ.18.AND.ihigg.GE.2) THEN
26156 C...H0 -> Z0 + h0, A0-> Z0 + h0
26157  wdtp(i)=fac*0.5d0*sqrt(max(0d0,
26158  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26159  IF(ihigg.EQ.2) THEN
26160  wdtp(i)=wdtp(i)*paru(179)**2
26161  ELSEIF(ihigg.EQ.3) THEN
26162  wdtp(i)=wdtp(i)*paru(186)**2
26163  ENDIF
26164  wid2=wids(23,2)*wids(25,2)
26165 
26166  ELSEIF(i.EQ.19.AND.ihigg.GE.2) THEN
26167 C...H0 -> h0 + h0, A0-> h0 + h0
26168  wdtp(i)=fac*0.25d0*
26169  & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
26170  IF(ihigg.EQ.2) THEN
26171  wdtp(i)=wdtp(i)*paru(176)**2
26172  ELSEIF(ihigg.EQ.3) THEN
26173  wdtp(i)=wdtp(i)*paru(169)**2
26174  ENDIF
26175  wid2=wids(25,1)
26176  ELSEIF((i.EQ.20.OR.i.EQ.21).AND.ihigg.GE.2) THEN
26177 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
26178  wdtp(i)=fac*0.5d0*sqrt(max(0d0,
26179  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26180  & *paru(195+ihigg)**2
26181  IF(i.EQ.20) THEN
26182  wid2=wids(24,2)*wids(37,3)
26183  ELSEIF(i.EQ.21) THEN
26184  wid2=wids(24,3)*wids(37,2)
26185  ENDIF
26186 
26187  ELSEIF(i.EQ.22.AND.ihigg.EQ.2) THEN
26188 C...H0 -> Z0 + A0.
26189  wdtp(i)=fac*0.5d0*paru(187)**2*sqrt(max(0d0,
26190  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26191  wid2=wids(36,2)*wids(23,2)
26192 
26193  ELSEIF(i.EQ.23.AND.ihigg.EQ.2) THEN
26194 C...H0 -> h0 + A0.
26195  wdtp(i)=fac*0.5d0*paru(180)**2*
26196  & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
26197  wid2=wids(25,2)*wids(36,2)
26198 
26199  ELSEIF(i.EQ.24.AND.ihigg.EQ.2) THEN
26200 C...H0 -> A0 + A0
26201  wdtp(i)=fac*0.25d0*paru(177)**2*
26202  & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
26203  wid2=wids(36,1)
26204 
26205 CMRENNA++
26206  ELSE
26207 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26208  rm10=rm1*sh/pmr**2
26209  rm20=rm2*sh/pmr**2
26210  wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
26211  wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
26212  IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
26213  wfac=0d0
26214  ELSE
26215  wfac=wfac/wfac0
26216  ENDIF
26217  wdtp(i)=pmas(kfla,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
26218 CMRENNA--
26219  IF(kfc2.EQ.kfc1) THEN
26220  wid2=wids(kfc1,1)
26221  ELSE
26222  ksgn1=2
26223  IF(kfdp(idc,1).LT.0) ksgn1=3
26224  ksgn2=2
26225  IF(kfdp(idc,2).LT.0) ksgn2=3
26226  wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
26227  ENDIF
26228  ENDIF
26229  wdtp(i)=fudge*wdtp(i)
26230  wdtp(0)=wdtp(0)+wdtp(i)
26231  IF(mdme(idc,1).GT.0) THEN
26232  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26233  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26234  wdte(i,0)=wdte(i,mdme(idc,1))
26235  wdte(0,0)=wdte(0,0)+wdte(i,0)
26236  ENDIF
26237  270 CONTINUE
26238 
26239  ELSEIF(kfla.EQ.32) THEN
26240 C...Z'0:
26241  icase=1
26242  xwc=1d0/(16d0*xw*xw1)
26243  fac=(aem*xwc/3d0)*shr
26244  vint(117)=0d0
26245  280 CONTINUE
26246  IF(mint(61).GE.1.AND.icase.EQ.2) THEN
26247  vint(111)=0d0
26248  vint(112)=0d0
26249  vint(113)=0d0
26250  vint(114)=0d0
26251  vint(115)=0d0
26252  vint(116)=0d0
26253  ENDIF
26254  IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
26255  kfai=iabs(mint(15))
26256  ei=kchg(kfai,1)/3d0
26257  ai=sign(1d0,ei+0.1d0)
26258  vi=ai-4d0*ei*xwv
26259  kfaic=1
26260  IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
26261  IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
26262  IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
26263  IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
26264  vpi=paru(119+2*kfaic)
26265  api=paru(120+2*kfaic)
26266  ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
26267  vpi=parj(178+2*kfaic)
26268  api=parj(179+2*kfaic)
26269  ELSE
26270  vpi=parj(186+2*kfaic)
26271  api=parj(187+2*kfaic)
26272  ENDIF
26273  sqmz=pmas(23,1)**2
26274  hz=shr*vint(117)
26275  sqmzp=pmas(32,1)**2
26276  hzp=shr*wdtp(0)
26277  IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
26278  & mstp(44).EQ.7) vint(111)=1d0
26279  IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=
26280  & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
26281  IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=
26282  & 2d0*xwc*sh*(sh-sqmzp)/((sh-sqmzp)**2+hzp**2)
26283  IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
26284  & mstp(44).EQ.7) vint(114)=xwc**2*sh**2/((sh-sqmz)**2+hz**2)
26285  IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=
26286  & 2d0*xwc**2*sh**2*((sh-sqmz)*(sh-sqmzp)+hz*hzp)/
26287  & (((sh-sqmz)**2+hz**2)*((sh-sqmzp)**2+hzp**2))
26288  IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
26289  & mstp(44).EQ.7) vint(116)=xwc**2*sh**2/((sh-sqmzp)**2+hzp**2)
26290  ENDIF
26291  DO 290 i=1,mdcy(kc,3)
26292  idc=i+mdcy(kc,2)-1
26293  IF(mdme(idc,1).LT.0) goto 290
26294  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26295  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26296  IF(sqrt(rm1)+sqrt(rm2).GT.1d0.OR.mdme(idc,1).LT.0) goto 290
26297  wid2=1d0
26298  IF(i.LE.16) THEN
26299  IF(i.LE.8) THEN
26300 C...Z'0 -> q + qbar
26301  ef=kchg(i,1)/3d0
26302  af=sign(1d0,ef+0.1d0)
26303  vf=af-4d0*ef*xwv
26304  IF(i.LE.2) THEN
26305  vpf=paru(123-2*mod(i,2))
26306  apf=paru(124-2*mod(i,2))
26307  ELSEIF(i.LE.4) THEN
26308  vpf=parj(182-2*mod(i,2))
26309  apf=parj(183-2*mod(i,2))
26310  ELSE
26311  vpf=parj(190-2*mod(i,2))
26312  apf=parj(191-2*mod(i,2))
26313  ENDIF
26314  fcof=3d0*radc
26315  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
26316  & pyhfth(sh,sh*rm1,1d0)
26317  IF(i.EQ.6) wid2=wids(6,1)
26318  IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
26319  ELSEIF(i.LE.16) THEN
26320 C...Z'0 -> l+ + l-, nu + nubar
26321  ef=kchg(i+2,1)/3d0
26322  af=sign(1d0,ef+0.1d0)
26323  vf=af-4d0*ef*xwv
26324  IF(i.LE.10) THEN
26325  vpf=paru(127-2*mod(i,2))
26326  apf=paru(128-2*mod(i,2))
26327  ELSEIF(i.LE.12) THEN
26328  vpf=parj(186-2*mod(i,2))
26329  apf=parj(187-2*mod(i,2))
26330  ELSE
26331  vpf=parj(194-2*mod(i,2))
26332  apf=parj(195-2*mod(i,2))
26333  ENDIF
26334  fcof=1d0
26335  IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
26336  ENDIF
26337  be34=sqrt(max(0d0,1d0-4d0*rm1))
26338  IF(icase.EQ.1) THEN
26339  wdtpz=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
26340  wdtp(i)=fac*fcof*(vpf**2*(1d0+2d0*rm1)+
26341  & apf**2*(1d0-4d0*rm1))*be34
26342  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
26343  wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
26344  & ef*vf+ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
26345  & vf**2+(vi*vpi+ai*api)*vint(115)*vf*vpf+(vpi**2+api**2)*
26346  & vint(116)*vpf**2)*(1d0+2d0*rm1)+((vi**2+ai**2)*vint(114)*
26347  & af**2+(vi*vpi+ai*api)*vint(115)*af*apf+(vpi**2+api**2)*
26348  & vint(116)*apf**2)*(1d0-4d0*rm1))*be34
26349  ELSEIF(mint(61).EQ.2) THEN
26350  fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
26351  fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
26352  fgzpf=fcof*ef*vpf*(1d0+2d0*rm1)*be34
26353  fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
26354  fzzpf=fcof*(vf*vpf*(1d0+2d0*rm1)+af*apf*(1d0-4d0*rm1))*
26355  & be34
26356  fzpzpf=fcof*(vpf**2*(1d0+2d0*rm1)+apf**2*(1d0-4d0*rm1))*
26357  & be34
26358  ENDIF
26359  ELSEIF(i.EQ.17) THEN
26360 C...Z'0 -> W+ + W-
26361  wdtpzp=paru(129)**2*xw1**2*
26362  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26363  & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
26364  IF(icase.EQ.1) THEN
26365  wdtpz=0d0
26366  wdtp(i)=fac*wdtpzp
26367  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
26368  wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
26369  ELSEIF(mint(61).EQ.2) THEN
26370  fggf=0d0
26371  fgzf=0d0
26372  fgzpf=0d0
26373  fzzf=0d0
26374  fzzpf=0d0
26375  fzpzpf=wdtpzp
26376  ENDIF
26377  wid2=wids(24,1)
26378  ELSEIF(i.EQ.18) THEN
26379 C...Z'0 -> H+ + H-
26380  czc=2d0*(1d0-2d0*xw)
26381  be34c=(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
26382  IF(icase.EQ.1) THEN
26383  wdtpz=0.25d0*paru(142)**2*czc**2*be34c
26384  wdtp(i)=fac*0.25d0*paru(143)**2*czc**2*be34c
26385  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
26386  wdtp(i)=fac*0.25d0*(ei**2*vint(111)+paru(142)*ei*vi*
26387  & vint(112)*czc+paru(143)*ei*vpi*vint(113)*czc+paru(142)**2*
26388  & (vi**2+ai**2)*vint(114)*czc**2+paru(142)*paru(143)*
26389  & (vi*vpi+ai*api)*vint(115)*czc**2+paru(143)**2*
26390  & (vpi**2+api**2)*vint(116)*czc**2)*be34c
26391  ELSEIF(mint(61).EQ.2) THEN
26392  fggf=0.25d0*be34c
26393  fgzf=0.25d0*paru(142)*czc*be34c
26394  fgzpf=0.25d0*paru(143)*czc*be34c
26395  fzzf=0.25d0*paru(142)**2*czc**2*be34c
26396  fzzpf=0.25d0*paru(142)*paru(143)*czc**2*be34c
26397  fzpzpf=0.25d0*paru(143)**2*czc**2*be34c
26398  ENDIF
26399  wid2=wids(37,1)
26400  ELSEIF(i.EQ.19) THEN
26401 C...Z'0 -> Z0 + gamma.
26402  ELSEIF(i.EQ.20) THEN
26403 C...Z'0 -> Z0 + h0
26404  flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26405  wdtpzp=paru(145)**2*4d0*abs(1d0-2d0*xw)*
26406  & (3d0*rm1+0.25d0*flam**2)*flam
26407  IF(icase.EQ.1) THEN
26408  wdtpz=0d0
26409  wdtp(i)=fac*wdtpzp
26410  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
26411  wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
26412  ELSEIF(mint(61).EQ.2) THEN
26413  fggf=0d0
26414  fgzf=0d0
26415  fgzpf=0d0
26416  fzzf=0d0
26417  fzzpf=0d0
26418  fzpzpf=wdtpzp
26419  ENDIF
26420  wid2=wids(23,2)*wids(25,2)
26421  ELSEIF(i.EQ.21.OR.i.EQ.22) THEN
26422 C...Z' -> h0 + A0 or H0 + A0.
26423  be34c=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26424  IF(i.EQ.21) THEN
26425  czah=paru(186)
26426  czpah=paru(188)
26427  ELSE
26428  czah=paru(187)
26429  czpah=paru(189)
26430  ENDIF
26431  IF(icase.EQ.1) THEN
26432  wdtpz=czah**2*be34c
26433  wdtp(i)=fac*czpah**2*be34c
26434  ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
26435  wdtp(i)=fac*(czah**2*(vi**2+ai**2)*vint(114)+czah*czpah*
26436  & (vi*vpi+ai*api)*vint(115)+czpah**2*(vpi**2+api**2)*
26437  & vint(116))*be34c
26438  ELSEIF(mint(61).EQ.2) THEN
26439  fggf=0d0
26440  fgzf=0d0
26441  fgzpf=0d0
26442  fzzf=czah**2*be34c
26443  fzzpf=czah*czpah*be34c
26444  fzpzpf=czpah**2*be34c
26445  ENDIF
26446  IF(i.EQ.21) wid2=wids(25,2)*wids(36,2)
26447  IF(i.EQ.22) wid2=wids(35,2)*wids(36,2)
26448  ENDIF
26449  IF(icase.EQ.1) THEN
26450  vint(117)=vint(117)+fac*wdtpz
26451  wdtp(i)=fudge*wdtp(i)
26452  wdtp(0)=wdtp(0)+wdtp(i)
26453  ENDIF
26454  IF(mdme(idc,1).GT.0) THEN
26455  IF((icase.EQ.1.AND.mint(61).NE.1).OR.
26456  & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
26457  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26458  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
26459  & wdte(i,mdme(idc,1))
26460  wdte(i,0)=wdte(i,mdme(idc,1))
26461  wdte(0,0)=wdte(0,0)+wdte(i,0)
26462  ENDIF
26463  IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
26464  IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
26465  & mstp(44).EQ.7) vint(111)=vint(111)+fggf*wid2
26466  IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=vint(112)+
26467  & fgzf*wid2
26468  IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=vint(113)+
26469  & fgzpf*wid2
26470  IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
26471  & mstp(44).EQ.7) vint(114)=vint(114)+fzzf*wid2
26472  IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=vint(115)+
26473  & fzzpf*wid2
26474  IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
26475  & mstp(44).EQ.7) vint(116)=vint(116)+fzpzpf*wid2
26476  ENDIF
26477  ENDIF
26478  290 CONTINUE
26479  IF(mint(61).GE.1) icase=3-icase
26480  IF(icase.EQ.2) goto 280
26481 
26482  ELSEIF(kfla.EQ.34) THEN
26483 C...W'+/-:
26484  fac=(aem/(24d0*xw))*shr
26485  DO 300 i=1,mdcy(kc,3)
26486  idc=i+mdcy(kc,2)-1
26487  IF(mdme(idc,1).LT.0) goto 300
26488  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26489  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26490  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 300
26491  wid2=1d0
26492  IF(i.LE.20) THEN
26493  IF(i.LE.16) THEN
26494 C...W'+/- -> q + qbar'
26495  ckmfac = vckm((i-1)/4+1,mod(i-1,4)+1)
26496  fcof=3d0*ckmfac*radc*(paru(131)**2+paru(132)**2)
26497  fcof2=3d0*ckmfac*radc*(paru(131)**2-paru(132)**2)
26498  IF(kflr.GT.0) THEN
26499  IF(mod(i,4).EQ.3) wid2=wids(6,2)
26500  IF(mod(i,4).EQ.0) wid2=wids(8,2)
26501  IF(i.GE.13) wid2=wid2*wids(7,3)
26502  ELSE
26503  IF(mod(i,4).EQ.3) wid2=wids(6,3)
26504  IF(mod(i,4).EQ.0) wid2=wids(8,3)
26505  IF(i.GE.13) wid2=wid2*wids(7,2)
26506  ENDIF
26507  ELSEIF(i.LE.20) THEN
26508 C...W'+/- -> l+/- + nu
26509  fcof=paru(133)**2+paru(134)**2
26510  fcof2=paru(133)**2-paru(134)**2
26511  IF(kflr.GT.0) THEN
26512  IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
26513  ELSE
26514  IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
26515  ENDIF
26516  ENDIF
26517  wdtp(i)=fac*0.5*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)
26518  & *sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26519  IF (rm1.GT.0d0.AND.rm2.GT.0d0) THEN
26520 C...PS 28/06/2010
26521 C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov
26522  wdtp(i)=wdtp(i) + fac*0.5*6d0*fcof2*sqrt(rm1*rm2)
26523  & *sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26524  ENDIF
26525  ELSEIF(i.EQ.21) THEN
26526 C...W'+/- -> W+/- + Z0
26527  wdtp(i)=fac*paru(135)**2*0.5d0*xw1*(rm1/rm2)*
26528  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26529  & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
26530  IF(kflr.GT.0) wid2=wids(24,2)*wids(23,2)
26531  IF(kflr.LT.0) wid2=wids(24,3)*wids(23,2)
26532  ELSEIF(i.EQ.23) THEN
26533 C...W'+/- -> W+/- + h0
26534  flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26535  wdtp(i)=fac*paru(146)**2*2d0*(3d0*rm1+0.25d0*flam**2)*flam
26536  IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
26537  IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
26538  ENDIF
26539  wdtp(i)=fudge*wdtp(i)
26540  wdtp(0)=wdtp(0)+wdtp(i)
26541  IF(mdme(idc,1).GT.0) THEN
26542  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26543  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26544  wdte(i,0)=wdte(i,mdme(idc,1))
26545  wdte(0,0)=wdte(0,0)+wdte(i,0)
26546  ENDIF
26547  300 CONTINUE
26548 
26549  ELSEIF(kfla.EQ.37) THEN
26550 C...H+/-:
26551 C IF(MSTP(49).EQ.0) THEN
26552  shfs=sh
26553 C ELSE
26554 C SHFS=PMAS(37,1)**2
26555 C ENDIF
26556  fac=(aem/(8d0*xw))*(shfs/pmas(24,1)**2)*shr
26557  DO 310 i=1,mdcy(kc,3)
26558  idc=i+mdcy(kc,2)-1
26559  IF(mdme(idc,1).LT.0) goto 310
26560  kfc1=pycomp(kfdp(idc,1))
26561  kfc2=pycomp(kfdp(idc,2))
26562  rm1=pmas(kfc1,1)**2/sh
26563  rm2=pmas(kfc2,1)**2/sh
26564  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 310
26565  wid2=1d0
26566  IF(i.LE.4) THEN
26567 C...H+/- -> q + qbar'
26568  rm1r=pymrun(kfdp(idc,1),sh)**2/sh
26569  rm2r=pymrun(kfdp(idc,2),sh)**2/sh
26570  wdtp(i)=fac*3d0*radc*max(0d0,(rm1r*paru(141)**2+
26571  & rm2r/paru(141)**2)*(1d0-rm1r-rm2r)-4d0*rm1r*rm2r)*
26572  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*(sh/shfs)
26573  IF(kflr.GT.0) THEN
26574  IF(i.EQ.3) wid2=wids(6,2)
26575  IF(i.EQ.4) wid2=wids(7,3)*wids(8,2)
26576  ELSE
26577  IF(i.EQ.3) wid2=wids(6,3)
26578  IF(i.EQ.4) wid2=wids(7,2)*wids(8,3)
26579  ENDIF
26580  ELSEIF(i.LE.8) THEN
26581 C...H+/- -> l+/- + nu
26582  wdtp(i)=fac*((rm1*paru(141)**2+rm2/paru(141)**2)*
26583  & (1d0-rm1-rm2)-4d0*rm1*rm2)*sqrt(max(0d0,
26584  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))*(sh/shfs)
26585  IF(kflr.GT.0) THEN
26586  IF(i.EQ.8) wid2=wids(17,3)*wids(18,2)
26587  ELSE
26588  IF(i.EQ.8) wid2=wids(17,2)*wids(18,3)
26589  ENDIF
26590  ELSEIF(i.EQ.9) THEN
26591 C...H+/- -> W+/- + h0.
26592  wdtp(i)=fac*paru(195)**2*0.5d0*sqrt(max(0d0,
26593  & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26594  IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
26595  IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
26596 
26597 CMRENNA++
26598  ELSE
26599 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26600  rm10=rm1*sh/pmr**2
26601  rm20=rm2*sh/pmr**2
26602  wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
26603  wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
26604  IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
26605  wfac=0d0
26606  ELSE
26607  wfac=wfac/wfac0
26608  ENDIF
26609  wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
26610 CMRENNA--
26611  ksgn1=2
26612  IF(kfls*kfdp(idc,1).LT.0.AND.kchg(kfc1,3).EQ.1) ksgn1=3
26613  ksgn2=2
26614  IF(kfls*kfdp(idc,2).LT.0.AND.kchg(kfc2,3).EQ.1) ksgn2=3
26615  wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
26616  ENDIF
26617  wdtp(i)=fudge*wdtp(i)
26618  wdtp(0)=wdtp(0)+wdtp(i)
26619  IF(mdme(idc,1).GT.0) THEN
26620  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26621  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26622  wdte(i,0)=wdte(i,mdme(idc,1))
26623  wdte(0,0)=wdte(0,0)+wdte(i,0)
26624  ENDIF
26625  310 CONTINUE
26626 
26627  ELSEIF(kfla.EQ.41) THEN
26628 C...R:
26629  fac=(aem/(12d0*xw))*shr
26630  DO 320 i=1,mdcy(kc,3)
26631  idc=i+mdcy(kc,2)-1
26632  IF(mdme(idc,1).LT.0) goto 320
26633  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26634  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26635  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 320
26636  wid2=1d0
26637  IF(i.LE.6) THEN
26638 C...R -> q + qbar'
26639  fcof=3d0*radc
26640  ELSEIF(i.LE.9) THEN
26641 C...R -> l+ + l'-
26642  fcof=1d0
26643  ENDIF
26644  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
26645  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26646  IF(kflr.GT.0) THEN
26647  IF(i.EQ.4) wid2=wids(6,3)
26648  IF(i.EQ.5) wid2=wids(7,3)
26649  IF(i.EQ.6) wid2=wids(6,2)*wids(8,3)
26650  IF(i.EQ.9) wid2=wids(17,3)
26651  ELSE
26652  IF(i.EQ.4) wid2=wids(6,2)
26653  IF(i.EQ.5) wid2=wids(7,2)
26654  IF(i.EQ.6) wid2=wids(6,3)*wids(8,2)
26655  IF(i.EQ.9) wid2=wids(17,2)
26656  ENDIF
26657  wdtp(i)=fudge*wdtp(i)
26658  wdtp(0)=wdtp(0)+wdtp(i)
26659  IF(mdme(idc,1).GT.0) THEN
26660  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26661  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26662  wdte(i,0)=wdte(i,mdme(idc,1))
26663  wdte(0,0)=wdte(0,0)+wdte(i,0)
26664  ENDIF
26665  320 CONTINUE
26666 
26667  ELSEIF(kfla.EQ.42) THEN
26668 C...LQ (leptoquark).
26669  fac=(aem/4d0)*paru(151)*shr
26670  DO 330 i=1,mdcy(kc,3)
26671  idc=i+mdcy(kc,2)-1
26672  IF(mdme(idc,1).LT.0) goto 330
26673  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26674  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26675  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 330
26676  wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26677  wid2=1d0
26678  ilqq=kfdp(idc,1)*isign(1,kflr)
26679  IF(ilqq.GE.6) wid2=wids(ilqq,2)
26680  IF(ilqq.LE.-6) wid2=wids(-ilqq,3)
26681  ilql=kfdp(idc,2)*isign(1,kflr)
26682  IF(ilql.GE.17) wid2=wid2*wids(ilql,2)
26683  IF(ilql.LE.-17) wid2=wid2*wids(-ilql,3)
26684  wdtp(i)=fudge*wdtp(i)
26685  wdtp(0)=wdtp(0)+wdtp(i)
26686  IF(mdme(idc,1).GT.0) THEN
26687  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26688  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26689  wdte(i,0)=wdte(i,mdme(idc,1))
26690  wdte(0,0)=wdte(0,0)+wdte(i,0)
26691  ENDIF
26692  330 CONTINUE
26693 
26694 C...UED: kk state width decays : flav: 451 476
26695  ELSEIF(iued(1).EQ.1.AND.
26696  & pycomp(abs(kfla)).GE.kkflmi.AND.
26697  & pycomp(abs(kfla)).LE.kkflma) THEN
26698  kcla=pycomp(kfla)
26699 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26700  rmflas=pmas(kcla,1)
26701  facsh=sh/pmas(kcla,1)**2
26702  alphem=pyalem(rmflas**2)
26703  alphs=pyalps(rmflas**2)
26704 
26705 C...uedcor parameters (alpha_s is calculated at mkk scale)
26706 C...alpha_em is calculated at z pole !
26707  alphem=paru(101)
26708  facsh=1.
26709 
26710  DO 1070 i=1,mdcy(kcla,3)
26711  idc=i+mdcy(kcla,2)-1
26712 
26713  IF(mdme(idc,1).LT.0) goto 1070
26714  kfc1=pycomp(abs(kfdp(idc,1)))
26715  kfc2=pycomp(abs(kfdp(idc,2)))
26716  rm1=pmas(kfc1,1)**2/sh
26717  rm2=pmas(kfc2,1)**2/sh
26718  IF(sqrt(rm1)+sqrt(rm2).GT.1d0)
26719  & goto 1070
26720  wid2=1d0
26721 
26722 C...N.B. RINV=RUED(1)
26723  rmkk=rued(1)
26724  rmwkk=pmas(475,1)
26725  rmzkk=pmas(474,1)
26726  sw2=paru(102)
26727  cw2=1.-sw2
26728  kkcla=kcla-kkflmi+1
26729  IF(abs(kfc1).GE.kkflmi)kkpart=kfc1
26730  IF(abs(kfc2).GE.kkflmi)kkpart=kfc2
26731  IF(kkcla.LE.6) THEN
26732 C...q*_S -> q + gamma* (in first time sw21=0)
26733  fac=0.25*alphem*rmflas*0.5*cw21/cw2*kchg(kcla,1)**2/9.
26734 C...Eventually change the following by enabling a choice of open or closed.
26735 C...Only the gamma_kk channel is open.
26736  IF(mod(i,2).EQ.0)
26737  + wdtp(i)=fac*fkac2(rmflas,rmkk)*fkac1(rmkk,rmflas)**2
26738  wdtp(i)=facsh*wdtp(i)
26739  wid2=wids(473,2)
26740  ELSEIF(kkcla.GT.6.AND.kkcla.LE.12)THEN
26741 C...q*_D -> q + Z*/W*
26742  fac=0.25*alphem*rmflas/(4.*sw2)
26743  gammaw=fac*fkac2(rmflas,rmwkk)*fkac1(rmwkk,rmflas)**2
26744  IF(i.EQ.1)THEN
26745 C...q*_D -> q + Z*
26746  wdtp(i)=0.5*gammaw
26747  wid2=wids(474,2)
26748  ELSEIF(i.EQ.2)THEN
26749 C...q*_D -> q + W*
26750  wdtp(i)=gammaw
26751  wid2=wids(475,2)
26752  ENDIF
26753  wdtp(i)=facsh*wdtp(i)
26754 C...q*_D -> q + gamma* is closed
26755  ELSEIF(kkcla.GT.12.AND.kkcla.LE.21)THEN
26756 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26757  fac=alphem/4.*rmflas/cw2/8.
26758  rmgakk=pmas(473,1)
26759  wdtp(i)=fac*fkac2(rmflas,rmgakk)*
26760  + fkac1(rmgakk,rmflas)**2
26761  wdtp(i)=facsh*wdtp(i)
26762  wid2=wids(473,2)
26763  ELSEIF(kkcla.EQ.22)THEN
26764  rmqst=pmas(kkpart,1)
26765  wid2=wids(kkpart,2)
26766 C...g* -> q*_S/q*_D + q
26767  fac=10.*alphs/12.*rmflas
26768  wdtp(i)=fac*fkac1(rmqst,rmflas)**2*fkac2(rmqst,rmflas)
26769  wdtp(i)=facsh*wdtp(i)
26770  ELSEIF(kkcla.EQ.23)THEN
26771 C...gamma* decays to graviton + gamma : initial value is used
26772  ichi=iued(4)/2
26773  wdtp(i)=rmflas*(rmflas/rued(2))**(iued(4)+2)
26774  & *chidel(ichi)
26775  ELSEIF(kkcla.EQ.24)THEN
26776 C...Z* -> l*_S + l is closed
26777 C... Z* -> l*_D + l
26778  IF(i.LE.3)goto 1070
26779 c... After closing the channels for a Z* decaying into positively charged
26780 C... KK lepton singlets, close the channels for a Z* decaying into negatively
26781 C... charged KK lepton singlets + positively charged SM particles
26782  IF(i.GE.10.AND.i.LE.12)goto 1070
26783  fac=3./2.*alphem/24./sw2*rmzkk
26784  rmlst=pmas(kkpart,1)
26785  wdtp(i)=fac*fkac1(rmlst,rmzkk)**2*fkac2(rmlst,rmzkk)
26786  wdtp(i)=facsh*wdtp(i)
26787  wid2=wids(kkpart,2)
26788  ELSEIF(kkcla.EQ.25)THEN
26789 C...W* -> l*_D lbar
26790  fac=3.*alphem/12./sw2*rmwkk
26791  rmlst=pmas(kkpart,1)
26792  wdtp(i)=fac*fkac1(rmlst,rmwkk)**2*fkac2(rmlst,rmwkk)
26793  wdtp(i)=facsh*wdtp(i)
26794  wid2=wids(kkpart,2)
26795  ENDIF
26796  wdtp(0)=wdtp(0)+wdtp(i)
26797  IF(mdme(idc,1).GT.0) THEN
26798  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26799  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26800  wdte(i,0)=wdte(i,mdme(idc,1))
26801  wdte(0,0)=wdte(0,0)+wdte(i,0)
26802  ENDIF
26803  1070 CONTINUE
26804  iuedpr(kkcla)=1
26805 
26806  ELSEIF(kfla.EQ.ktechn+111.OR.kfla.EQ.ktechn+221) THEN
26807 C...Techni-pi0 and techni-pi0':
26808  fac=(1d0/(32d0*paru(1)*rtcm(1)**2))*shr
26809  DO 340 i=1,mdcy(kc,3)
26810  idc=i+mdcy(kc,2)-1
26811  IF(mdme(idc,1).LT.0) goto 340
26812  pm1=pmas(pycomp(kfdp(idc,1)),1)
26813  pm2=pmas(pycomp(kfdp(idc,2)),1)
26814  rm1=pm1**2/sh
26815  rm2=pm2**2/sh
26816  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 340
26817  wid2=1d0
26818 C...pi_tc -> g + g
26819  IF(i.EQ.8) THEN
26820  facp=(as/(4d0*paru(1))*itcm(1)/rtcm(1))**2
26821  & /(8d0*paru(1))*sh*shr
26822  IF(kfla.EQ.ktechn+111) THEN
26823  facp=facp*rtcm(9)
26824  ELSE
26825  facp=facp*rtcm(10)
26826  ENDIF
26827  wdtp(i)=facp
26828  ELSE
26829 C...pi_tc -> f + fbar.
26830  fcof=1d0
26831  ika=iabs(kfdp(idc,1))
26832  IF(ika.LT.10) fcof=3d0*radc
26833  hm1=pm1
26834  hm2=pm2
26835  IF(ika.GE.4.AND.ika.LE.6) THEN
26836  fcof=fcof*rtcm(1+ika)**2
26837  hm1=pymrun(kfdp(idc,1),sh)
26838  hm2=pymrun(kfdp(idc,2),sh)
26839  ELSEIF(ika.EQ.15) THEN
26840  fcof=fcof*rtcm(8)**2
26841  ENDIF
26842  wdtp(i)=fac*fcof*(hm1+hm2)**2*
26843  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26844  ENDIF
26845  wdtp(i)=fudge*wdtp(i)
26846  wdtp(0)=wdtp(0)+wdtp(i)
26847  IF(mdme(idc,1).GT.0) THEN
26848  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26849  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26850  wdte(i,0)=wdte(i,mdme(idc,1))
26851  wdte(0,0)=wdte(0,0)+wdte(i,0)
26852  ENDIF
26853  340 CONTINUE
26854 
26855  ELSEIF(kfla.EQ.ktechn+211) THEN
26856 C...pi+_tc
26857  fac=(1d0/(32d0*paru(1)*rtcm(1)**2))*shr
26858  DO 350 i=1,mdcy(kc,3)
26859  idc=i+mdcy(kc,2)-1
26860  IF(mdme(idc,1).LT.0) goto 350
26861  pm1=pmas(pycomp(kfdp(idc,1)),1)
26862  pm2=pmas(pycomp(kfdp(idc,2)),1)
26863  pm3=0d0
26864  IF(i.EQ.5) pm3=pmas(pycomp(kfdp(idc,3)),1)
26865  rm1=pm1**2/sh
26866  rm2=pm2**2/sh
26867  rm3=pm3**2/sh
26868  IF(sqrt(rm1)+sqrt(rm2)+sqrt(rm3).GT.1d0) goto 350
26869  wid2=1d0
26870 C...pi_tc -> f + f'.
26871  fcof=1d0
26872  IF(iabs(kfdp(idc,1)).LT.10) fcof=3d0*radc
26873 C...pi_tc+ -> W b b~
26874  IF(i.EQ.5.AND.shr.LT.pmas(6,1)+pmas(5,1)) THEN
26875  fcof=3d0*radc
26876  xmt2=pmas(6,1)**2/sh
26877  facp=fac/(4d0*paru(1))*fcof*xmt2*rtcm(7)**2
26878  kfc3=pycomp(kfdp(idc,3))
26879  check = sqrt(rm1)+sqrt(rm2)+sqrt(rm3)
26880  check = sqrt(rm1)
26881  t0 = (1d0-check**2)*
26882  & (xmt2*(6d0*xmt2**2+3d0*xmt2*rm1-4d0*rm1**2)-
26883  & (5d0*xmt2**2+2d0*xmt2*rm1-8d0*rm1**2))/(4d0*xmt2**2)
26884  t1 = (1d0-xmt2)*(rm1-xmt2)*((xmt2**2+xmt2*rm1+4d0*rm1**2)
26885  & -3d0*xmt2**2*(xmt2+rm1))/(2d0*xmt2**3)
26886  t3 = rm1**2/xmt2**3*(3d0*xmt2-4d0*rm1+4d0*xmt2*rm1)
26887  wdtp(i)=facp*(t0 + t1*log((xmt2-check**2)/(xmt2-1d0))
26888  & +t3*log(check))
26889  IF(kflr.GT.0) THEN
26890  wid2=wids(24,2)
26891  ELSE
26892  wid2=wids(24,3)
26893  ENDIF
26894  ELSE
26895  fcof=1d0
26896  ika=iabs(kfdp(idc,1))
26897  IF(ika.LT.10) fcof=3d0*radc
26898  hm1=pm1
26899  hm2=pm2
26900  IF(i.GE.1.AND.i.LE.5) THEN
26901  IF(i.LE.2) THEN
26902  fcof=fcof*rtcm(5)**2
26903  ELSEIF(i.LE.4) THEN
26904  fcof=fcof*rtcm(6)**2
26905  ELSEIF(i.EQ.5) THEN
26906  fcof=fcof*rtcm(7)**2
26907  ENDIF
26908  hm1=pymrun(kfdp(idc,1),sh)
26909  hm2=pymrun(kfdp(idc,2),sh)
26910  ELSEIF(i.EQ.8) THEN
26911  fcof=fcof*rtcm(8)**2
26912  ENDIF
26913  wdtp(i)=fac*fcof*(hm1+hm2)**2*
26914  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26915  ENDIF
26916  wdtp(i)=fudge*wdtp(i)
26917  wdtp(0)=wdtp(0)+wdtp(i)
26918  IF(mdme(idc,1).GT.0) THEN
26919  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26920  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26921  wdte(i,0)=wdte(i,mdme(idc,1))
26922  wdte(0,0)=wdte(0,0)+wdte(i,0)
26923  ENDIF
26924  350 CONTINUE
26925 
26926  ELSEIF(kfla.EQ.ktechn+331) THEN
26927 C...Techni-eta.
26928  fac=(sh/parp(46)**2)*shr
26929  DO 360 i=1,mdcy(kc,3)
26930  idc=i+mdcy(kc,2)-1
26931  IF(mdme(idc,1).LT.0) goto 360
26932  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26933  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26934  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 360
26935  wid2=1d0
26936  IF(i.LE.2) THEN
26937  wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))/(4d0*paru(1))
26938  IF(i.EQ.2) wid2=wids(6,1)
26939  ELSE
26940  wdtp(i)=fac*5d0*as**2/(96d0*paru(1)**3)
26941  ENDIF
26942  wdtp(i)=fudge*wdtp(i)
26943  wdtp(0)=wdtp(0)+wdtp(i)
26944  IF(mdme(idc,1).GT.0) THEN
26945  wdte(i,mdme(idc,1))=wdtp(i)*wid2
26946  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26947  wdte(i,0)=wdte(i,mdme(idc,1))
26948  wdte(0,0)=wdte(0,0)+wdte(i,0)
26949  ENDIF
26950  360 CONTINUE
26951 
26952  ELSEIF(kfla.EQ.ktechn+113) THEN
26953 C...Techni-rho0:
26954  alprht=2.16d0*(3d0/itcm(1))
26955  fac=(alprht/12d0)*shr
26956  facf=(1d0/6d0)*(aem**2/alprht)*shr
26957  sqmz=pmas(23,1)**2
26958  sqmw=pmas(24,1)**2
26959  shp=sh
26960  CALL pywidx(23,shp,wdtpp,wdtep)
26961  gmmz=shr*wdtpp(0)
26962  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
26963  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
26964  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
26965  DO 370 i=1,mdcy(kc,3)
26966  idc=i+mdcy(kc,2)-1
26967  IF(mdme(idc,1).LT.0) goto 370
26968  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26969  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26970  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 370
26971  wid2=1d0
26972  IF(i.EQ.1) THEN
26973 C...rho_tc0 -> W+ + W-.
26974 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26975  wdtp(i)=fac*rtcm(3)**4*
26976  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26977  & 2d0*aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26978  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
26979  & rtcm(3)**2/4d0/xw/24d0/rtcm(13)**2*shr**3
26980  wid2=wids(24,1)
26981  ELSEIF(i.EQ.2) THEN
26982 C...rho_tc0 -> W+ + pi_tc-.
26983 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26984  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26985  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26986  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26987  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*rm1)*
26988  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26989  wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
26990  ELSEIF(i.EQ.3) THEN
26991 C...rho_tc0 -> pi_tc+ + W-.
26992  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26993  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26994  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26995  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*rm2)*
26996  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26997  wid2=wids(pycomp(ktechn+211),2)*wids(24,3)
26998  ELSEIF(i.EQ.4) THEN
26999 C...rho_tc0 -> pi_tc+ + pi_tc-.
27000  wdtp(i)=fac*(1d0-rtcm(3)**2)**2*
27001  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
27002  wid2=wids(pycomp(ktechn+211),1)
27003  ELSEIF(i.EQ.5) THEN
27004 C...rho_tc0 -> gamma + pi_tc0
27005  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27006  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
27007  & shr**3
27008  wid2=wids(pycomp(ktechn+111),2)
27009  ELSEIF(i.EQ.6) THEN
27010 C...rho_tc0 -> gamma + pi_tc0'
27011  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27012  & (1d0-rtcm(4)**2)/24d0/rtcm(12)**2*shr**3
27013  wid2=wids(pycomp(ktechn+221),2)
27014  ELSEIF(i.EQ.7) THEN
27015 C...rho_tc0 -> Z0 + pi_tc0
27016  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27017  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
27018  & xw/xw1*shr**3
27019  wid2=wids(23,2)*wids(pycomp(ktechn+111),2)
27020  ELSEIF(i.EQ.8) THEN
27021 C...rho_tc0 -> Z0 + pi_tc0'
27022  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27023  & (1d0-rtcm(4)**2)/24d0/rtcm(12)**2*(1d0-2d0*xw)**2/4d0/
27024  & xw/xw1*shr**3
27025  wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
27026  ELSEIF(i.EQ.9) THEN
27027 C...rho_tc0 -> gamma + Z0
27028  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27029  & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2/24d0/rtcm(12)**2*shr**3
27030  wid2=wids(23,2)
27031  ELSEIF(i.EQ.10) THEN
27032 C...rho_tc0 -> Z0 + Z0
27033  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27034  & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2*xw/xw1/24d0/rtcm(12)**2*
27035  & shr**3
27036  wid2=wids(23,1)
27037  ELSE
27038 C...rho_tc0 -> f + fbar.
27039  wid2=1d0
27040  IF(i.LE.18) THEN
27041  ia=i-10
27042  fcof=3d0*radc
27043  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
27044  ELSE
27045  ia=i-6
27046  fcof=1d0
27047  IF(ia.GE.17) wid2=wids(ia,1)
27048  ENDIF
27049  ei=kchg(ia,1)/3d0
27050  ai=sign(1d0,ei+0.1d0)
27051  vi=ai-4d0*ei*xwv
27052  vali=0.5d0*(vi+ai)
27053  vari=0.5d0*(vi-ai)
27054  wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
27055  & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
27056  & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
27057  & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
27058  ENDIF
27059  wdtp(i)=fudge*wdtp(i)
27060  wdtp(0)=wdtp(0)+wdtp(i)
27061  IF(mdme(idc,1).GT.0) THEN
27062  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27063  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27064  wdte(i,0)=wdte(i,mdme(idc,1))
27065  wdte(0,0)=wdte(0,0)+wdte(i,0)
27066  ENDIF
27067  370 CONTINUE
27068 
27069  ELSEIF(kfla.EQ.ktechn+213) THEN
27070 C...Techni-rho+/-:
27071  alprht=2.16d0*(3d0/itcm(1))
27072  fac=(alprht/12d0)*shr
27073  sqmz=pmas(23,1)**2
27074  sqmw=pmas(24,1)**2
27075  shp=sh
27076  CALL pywidx(24,shp,wdtpp,wdtep)
27077  gmmw=shr*wdtpp(0)
27078  facf=(1d0/12d0)*(aem**2/alprht)*shr*
27079  & (0.125d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
27080  DO 380 i=1,mdcy(kc,3)
27081  idc=i+mdcy(kc,2)-1
27082  IF(mdme(idc,1).LT.0) goto 380
27083  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27084  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27085  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 380
27086  wid2=1d0
27087  pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27088 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27089 c & /3D0*SHR**3
27090  IF(i.EQ.1) THEN
27091 C...rho_tc+ -> W+ + Z0.
27092 C......Goldstone
27093  wdtp(i)=fac*rtcm(3)**4*
27094  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
27095  va2=rtcm(3)**2*(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(12)**2
27096  aa2=rtcm(3)**2/rtcm(13)**2/4d0/xw/xw1
27097 C......W_L Z_T
27098  wdtp(i)=wdtp(i)+aem*pcm*(aa2*(pcm**2+1.5d0*rm2)+pcm**2*va2)
27099  & /3d0*shr**3
27100  va2=0d0
27101  aa2=rtcm(3)**2/rtcm(13)**2/4d0/xw
27102 C......W_T Z_L
27103  wdtp(i)=wdtp(i)+aem*pcm*(aa2*(pcm**2+1.5d0*rm1)+pcm**2*va2)
27104  & /3d0*shr**3
27105  IF(kflr.GT.0) THEN
27106  wid2=wids(24,2)*wids(23,2)
27107  ELSE
27108  wid2=wids(24,3)*wids(23,2)
27109  ENDIF
27110  ELSEIF(i.EQ.2) THEN
27111 C...rho_tc+ -> W+ + pi_tc0.
27112  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
27113  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
27114  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
27115  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
27116  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
27117  IF(kflr.GT.0) THEN
27118  wid2=wids(24,2)*wids(pycomp(ktechn+111),2)
27119  ELSE
27120  wid2=wids(24,3)*wids(pycomp(ktechn+111),2)
27121  ENDIF
27122  ELSEIF(i.EQ.3) THEN
27123 C...rho_tc+ -> pi_tc+ + Z0.
27124  wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
27125  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
27126  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
27127  & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmz/sh)*
27128  & (1d0-rtcm(3)**2)/4d0/xw/xw1/24d0/rtcm(13)**2*shr**3+
27129  & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27130  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
27131  & shr**3*xw/xw1
27132  IF(kflr.GT.0) THEN
27133  wid2=wids(pycomp(ktechn+211),2)*wids(23,2)
27134  ELSE
27135  wid2=wids(pycomp(ktechn+211),3)*wids(23,2)
27136  ENDIF
27137  ELSEIF(i.EQ.4) THEN
27138 C...rho_tc+ -> pi_tc+ + pi_tc0.
27139  wdtp(i)=fac*(1d0-rtcm(3)**2)**2*
27140  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
27141  IF(kflr.GT.0) THEN
27142  wid2=wids(pycomp(ktechn+211),2)*wids(pycomp(ktechn+111),2)
27143  ELSE
27144  wid2=wids(pycomp(ktechn+211),3)*wids(pycomp(ktechn+111),2)
27145  ENDIF
27146  ELSEIF(i.EQ.5) THEN
27147 C...rho_tc+ -> pi_tc+ + gamma
27148  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27149  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
27150  & shr**3
27151  IF(kflr.GT.0) THEN
27152  wid2=wids(pycomp(ktechn+211),2)
27153  ELSE
27154  wid2=wids(pycomp(ktechn+211),3)
27155  ENDIF
27156  ELSEIF(i.EQ.6) THEN
27157 C...rho_tc+ -> W+ + pi_tc0'
27158  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27159  & (1d0-rtcm(4)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3
27160  IF(kflr.GT.0) THEN
27161  wid2=wids(24,2)*wids(pycomp(ktechn+221),2)
27162  ELSE
27163  wid2=wids(24,3)*wids(pycomp(ktechn+221),2)
27164  ENDIF
27165  ELSEIF(i.EQ.7) THEN
27166 C...rho_tc+ -> W+ + gamma
27167  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27168  & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2/24d0/rtcm(12)**2*shr**3
27169  IF(kflr.GT.0) THEN
27170  wid2=wids(24,2)
27171  ELSE
27172  wid2=wids(24,3)
27173  ENDIF
27174  ELSE
27175 C...rho_tc+ -> f + fbar'.
27176  ia=i-7
27177  wid2=1d0
27178  IF(ia.LE.16) THEN
27179  fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
27180  IF(kflr.GT.0) THEN
27181  IF(mod(ia,4).EQ.3) wid2=wids(6,2)
27182  IF(mod(ia,4).EQ.0) wid2=wids(8,2)
27183  IF(ia.GE.13) wid2=wid2*wids(7,3)
27184  ELSE
27185  IF(mod(ia,4).EQ.3) wid2=wids(6,3)
27186  IF(mod(ia,4).EQ.0) wid2=wids(8,3)
27187  IF(ia.GE.13) wid2=wid2*wids(7,2)
27188  ENDIF
27189  ELSE
27190  fcof=1d0
27191  IF(kflr.GT.0) THEN
27192  IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
27193  ELSE
27194  IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
27195  ENDIF
27196  ENDIF
27197  wdtp(i)=facf*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
27198  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27199  ENDIF
27200  wdtp(i)=fudge*wdtp(i)
27201  wdtp(0)=wdtp(0)+wdtp(i)
27202  IF(mdme(idc,1).GT.0) THEN
27203  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27204  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27205  wdte(i,0)=wdte(i,mdme(idc,1))
27206  wdte(0,0)=wdte(0,0)+wdte(i,0)
27207  ENDIF
27208  380 CONTINUE
27209 
27210  ELSEIF(kfla.EQ.ktechn+223) THEN
27211 C...Techni-omega:
27212  alprht=2.16d0*(3d0/itcm(1))
27213  fac=(alprht/12d0)*shr
27214  facf=(1d0/6d0)*(aem**2/alprht)*shr*(2d0*rtcm(2)-1d0)**2
27215  sqmz=pmas(23,1)**2
27216  shp=sh
27217  CALL pywidx(23,shp,wdtpp,wdtep)
27218  gmmz=shr*wdtpp(0)
27219  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
27220  bwzi=-(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
27221  DO 390 i=1,mdcy(kc,3)
27222  idc=i+mdcy(kc,2)-1
27223  IF(mdme(idc,1).LT.0) goto 390
27224  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27225  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27226  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 390
27227  wid2=1d0
27228  IF(i.EQ.1) THEN
27229 C...omega_tc0 -> gamma + pi_tc0.
27230  wdtp(i)=aem/24d0/rtcm(12)**2*(1d0-rtcm(3)**2)*
27231  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*shr**3
27232  wid2=wids(pycomp(ktechn+111),2)
27233  ELSEIF(i.EQ.2) THEN
27234 C...omega_tc0 -> Z0 + pi_tc0
27235  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27236  & (1d0-rtcm(3)**2)/24d0/rtcm(12)**2*(1d0-2d0*xw)**2/4d0/
27237  & xw/xw1*shr**3
27238  wid2=wids(23,2)*wids(pycomp(ktechn+111),2)
27239  ELSEIF(i.EQ.3) THEN
27240 C...omega_tc0 -> gamma + pi_tc0'
27241  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27242  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(4)**2)/24d0/rtcm(12)**2*
27243  & shr**3
27244  wid2=wids(pycomp(ktechn+221),2)
27245  ELSEIF(i.EQ.4) THEN
27246 C...omega_tc0 -> Z0 + pi_tc0'
27247  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27248  & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(4)**2)/24d0/rtcm(12)**2*
27249  & xw/xw1*shr**3
27250  wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
27251  ELSEIF(i.EQ.5) THEN
27252 C...omega_tc0 -> W+ + pi_tc-
27253  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27254  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3+
27255  & fac*rtcm(3)**2*(1d0-rtcm(3)**2)*rtcm(11)**2*
27256  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
27257  wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
27258  ELSEIF(i.EQ.6) THEN
27259 C...omega_tc0 -> pi_tc+ + W-
27260  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27261  & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3+
27262  & fac*rtcm(3)**2*(1d0-rtcm(3)**2)*rtcm(11)**2*
27263  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
27264  wid2=wids(24,3)*wids(pycomp(ktechn+211),2)
27265  ELSEIF(i.EQ.7) THEN
27266 C...omega_tc0 -> W+ + W-.
27267 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
27268  wdtp(i)=fac*rtcm(3)**4*rtcm(11)**2*
27269  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
27270  & 2d0*aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27271  & rtcm(3)**2/4d0/xw/24d0/rtcm(12)**2*shr**3
27272  wid2=wids(24,1)
27273  ELSEIF(i.EQ.8) THEN
27274 C...omega_tc0 -> pi_tc+ + pi_tc-.
27275  wdtp(i)=fac*(1d0-rtcm(3)**2)**2*rtcm(11)**2*
27276  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
27277  wid2=wids(pycomp(ktechn+211),1)
27278 C...omega_tc0 -> gamma + Z0
27279  ELSEIF(i.EQ.9) THEN
27280  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27281  & rtcm(3)**2/24d0/rtcm(12)**2*shr**3
27282  wid2=wids(23,2)
27283 C...omega_tc0 -> Z0 + Z0
27284  ELSEIF(i.EQ.10) THEN
27285  wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
27286  & rtcm(3)**2*(xw1-xw)**2/xw/xw1/4d0
27287  & /24d0/rtcm(12)**2*shr**3
27288  wid2=wids(23,1)
27289  ELSE
27290 C...omega_tc0 -> f + fbar.
27291  wid2=1d0
27292  IF(i.LE.18) THEN
27293  ia=i-10
27294  fcof=3d0*radc
27295  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
27296  ELSE
27297  ia=i-8
27298  fcof=1d0
27299  IF(ia.GE.17) wid2=wids(ia,1)
27300  ENDIF
27301  ei=kchg(ia,1)/3d0
27302  ai=sign(1d0,ei+0.1d0)
27303  vi=ai-4d0*ei*xwv
27304  vali=-0.5d0*(vi+ai)
27305  vari=-0.5d0*(vi-ai)
27306  wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
27307  & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
27308  & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
27309  & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
27310  ENDIF
27311  wdtp(i)=fudge*wdtp(i)
27312  wdtp(0)=wdtp(0)+wdtp(i)
27313  IF(mdme(idc,1).GT.0) THEN
27314  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27315  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27316  wdte(i,0)=wdte(i,mdme(idc,1))
27317  wdte(0,0)=wdte(0,0)+wdte(i,0)
27318  ENDIF
27319  390 CONTINUE
27320 
27321 C.....V8 -> quark anti-quark
27322  ELSEIF(kfla.EQ.ktechn+100021) THEN
27323  fac=as/6d0*shr
27324  tant3=rtcm(21)
27325  IF(itcm(2).EQ.0) THEN
27326  imdl=1
27327  ELSEIF(itcm(2).EQ.1) THEN
27328  imdl=2
27329  ENDIF
27330  DO 400 i=1,mdcy(kc,3)
27331  idc=i+mdcy(kc,2)-1
27332  IF(mdme(idc,1).LT.0) goto 400
27333  pm1=pmas(pycomp(kfdp(idc,1)),1)
27334  rm1=pm1**2/sh
27335  IF(rm1.GT.0.25d0) goto 400
27336  wid2=1d0
27337  IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
27338  fmix=1d0/tant3**2
27339  ELSE
27340  fmix=tant3**2
27341  ENDIF
27342  wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*fmix
27343  IF(i.EQ.6) wid2=wids(6,1)
27344  wdtp(i)=fudge*wdtp(i)
27345  wdtp(0)=wdtp(0)+wdtp(i)
27346  IF(mdme(idc,1).GT.0) THEN
27347  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27348  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27349  wdte(i,0)=wdte(i,mdme(idc,1))
27350  wdte(0,0)=wdte(0,0)+wdte(i,0)
27351  ENDIF
27352  400 CONTINUE
27353 
27354  ELSEIF(kfla.EQ.ktechn+100111.OR.kfla.EQ.ktechn+200111) THEN
27355  fac=(1d0/(4d0*paru(1)*rtcm(1)**2))*shr
27356  clebf=0d0
27357  DO 410 i=1,mdcy(kc,3)
27358  idc=i+mdcy(kc,2)-1
27359  IF(mdme(idc,1).LT.0) goto 410
27360  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27361  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27362  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 410
27363  wid2=1d0
27364 C...pi_tc -> g + g
27365  IF(i.EQ.7) THEN
27366  IF(kfla.EQ.ktechn+100111) THEN
27367  clebg=4d0/3d0
27368  ELSE
27369  clebg=5d0/3d0
27370  ENDIF
27371  facp=(as/(8d0*paru(1))*itcm(1)/rtcm(1))**2
27372  & /(2d0*paru(1))*sh*shr*clebg
27373  wdtp(i)=facp
27374  ELSE
27375 C...pi_tc -> f + fbar.
27376  IF(i.EQ.6) wid2=wids(6,1)
27377  fcof=1d0
27378  ika=iabs(kfdp(idc,1))
27379  IF(ika.LT.10) fcof=3d0*radc
27380  hm1=pymrun(kfdp(idc,1),sh)
27381  wdtp(i)=fac*fcof*hm1**2*clebf*
27382  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27383  ENDIF
27384  wdtp(i)=fudge*wdtp(i)
27385  wdtp(0)=wdtp(0)+wdtp(i)
27386  IF(mdme(idc,1).GT.0) THEN
27387  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27388  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27389  wdte(i,0)=wdte(i,mdme(idc,1))
27390  wdte(0,0)=wdte(0,0)+wdte(i,0)
27391  ENDIF
27392  410 CONTINUE
27393 
27394  ELSEIF(kfla.GE.ktechn+100113.AND.kfla.LE.ktechn+400113) THEN
27395  fac=as/6d0*shr
27396  alprht=2.16d0*(3d0/itcm(1))
27397  tant3=rtcm(21)
27398  sin2t=2d0*tant3/(tant3**2+1d0)
27399  sint3=tant3/sqrt(tant3**2+1d0)
27400  csxpp=rtcm(22)
27401  rm82=rtcm(27)**2
27402  x12=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*cos(rtcm(30))+
27403  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*cos(rtcm(32)))/sqrt(2d0)
27404  x21=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*sin(rtcm(30))+
27405  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*sin(rtcm(32)))/sqrt(2d0)
27406  x11=(.25d0*(rtcm(29)**2+rtcm(31)**2+2d0)-
27407  & sint3**2)*2d0
27408  x22=(.25d0*(2d0-rtcm(29)**2-rtcm(31)**2)-
27409  & sint3**2)*2d0
27410  CALL pywidx(ktechn+100021,sh,wdtpp,wdtep)
27411 
27412  IF(wdtpp(0).GT.rtcm(33)*shr) wdtpp(0)=rtcm(33)*shr
27413  gmv8=shr*wdtpp(0)
27414  rmv8=pmas(pycomp(ktechn+100021),1)
27415  fv8re=sh*(sh-rmv8**2)/((sh-rmv8**2)**2+gmv8**2)
27416  fv8im=sh*gmv8/((sh-rmv8**2)**2+gmv8**2)
27417  IF(itcm(2).EQ.0) THEN
27418  imdl=1
27419  ELSE
27420  imdl=2
27421  ENDIF
27422  DO 420 i=1,mdcy(kc,3)
27423  IF(i.EQ.7.AND.(kfla.EQ.ktechn+200113.OR.
27424  & kfla.EQ.ktechn+300113)) goto 420
27425  idc=i+mdcy(kc,2)-1
27426  IF(mdme(idc,1).LT.0) goto 420
27427  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27428  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27429  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 420
27430  wid2=1d0
27431  IF(i.LE.6) THEN
27432  IF(i.EQ.6) wid2=wids(6,1)
27433  xig=1d0
27434  IF(kfla.EQ.ktechn+200113) THEN
27435  xig=0d0
27436  xij=x12
27437  ELSEIF(kfla.EQ.ktechn+300113) THEN
27438  xig=0d0
27439  xij=x21
27440  ELSEIF(kfla.EQ.ktechn+100113) THEN
27441  xij=x11
27442  ELSE
27443  xij=x22
27444  ENDIF
27445  IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
27446  fmix=1d0/tant3/sin2t
27447  ELSE
27448  fmix=-tant3/sin2t
27449  ENDIF
27450  xfac=(xig+fmix*xij*fv8re)**2+(fmix*xij*fv8im)**2
27451  wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*as/alprht*xfac
27452  ELSEIF(i.EQ.7) THEN
27453  wdtp(i)=shr*as**2/(4d0*alprht)
27454  ELSEIF(kfla.EQ.ktechn+400113.AND.i.LE.9) THEN
27455  psh=shr*(1d0-rm1)/2d0
27456  wdtp(i)=as/9d0*psh**3/rm82
27457  IF(i.EQ.8) THEN
27458  wdtp(i)=2d0*wdtp(i)*csxpp**2
27459  wid2=wids(pycomp(kfdp(idc,1)),2)
27460  ELSE
27461  wdtp(i)=5d0*wdtp(i)
27462  wid2=wids(pycomp(kfdp(idc,1)),2)
27463  ENDIF
27464  ENDIF
27465  wdtp(i)=fudge*wdtp(i)
27466  wdtp(0)=wdtp(0)+wdtp(i)
27467  IF(mdme(idc,1).GT.0) THEN
27468  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27469  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27470  wdte(i,0)=wdte(i,mdme(idc,1))
27471  wdte(0,0)=wdte(0,0)+wdte(i,0)
27472  ENDIF
27473  420 CONTINUE
27474 
27475  ELSEIF(kfla.EQ.kexcit+1) THEN
27476 C...d* excited quark.
27477  fac=(sh/rtcm(41)**2)*shr
27478  DO 430 i=1,mdcy(kc,3)
27479  idc=i+mdcy(kc,2)-1
27480  IF(mdme(idc,1).LT.0) goto 430
27481  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27482  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27483  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 430
27484  wid2=1d0
27485  IF(i.EQ.1) THEN
27486 C...d* -> g + d.
27487  wdtp(i)=fac*as*rtcm(45)**2/3d0
27488  wid2=1d0
27489  ELSEIF(i.EQ.2) THEN
27490 C...d* -> gamma + d.
27491  qf=-rtcm(43)/2d0+rtcm(44)/6d0
27492  wdtp(i)=fac*aem*qf**2/4d0
27493  wid2=1d0
27494  ELSEIF(i.EQ.3) THEN
27495 C...d* -> Z0 + d.
27496  qf=-rtcm(43)*xw1/2d0-rtcm(44)*xw/6d0
27497  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
27498  & (1d0-rm1)**2*(2d0+rm1)
27499  wid2=wids(23,2)
27500  ELSEIF(i.EQ.4) THEN
27501 C...d* -> W- + u.
27502  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
27503  & (1d0-rm1)**2*(2d0+rm1)
27504  IF(kflr.GT.0) wid2=wids(24,3)
27505  IF(kflr.LT.0) wid2=wids(24,2)
27506  ENDIF
27507  wdtp(i)=fudge*wdtp(i)
27508  wdtp(0)=wdtp(0)+wdtp(i)
27509  IF(mdme(idc,1).GT.0) THEN
27510  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27511  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27512  wdte(i,0)=wdte(i,mdme(idc,1))
27513  wdte(0,0)=wdte(0,0)+wdte(i,0)
27514  ENDIF
27515  430 CONTINUE
27516 
27517  ELSEIF(kfla.EQ.kexcit+2) THEN
27518 C...u* excited quark.
27519  fac=(sh/rtcm(41)**2)*shr
27520  DO 440 i=1,mdcy(kc,3)
27521  idc=i+mdcy(kc,2)-1
27522  IF(mdme(idc,1).LT.0) goto 440
27523  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27524  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27525  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 440
27526  wid2=1d0
27527  IF(i.EQ.1) THEN
27528 C...u* -> g + u.
27529  wdtp(i)=fac*as*rtcm(45)**2/3d0
27530  wid2=1d0
27531  ELSEIF(i.EQ.2) THEN
27532 C...u* -> gamma + u.
27533  qf=rtcm(43)/2d0+rtcm(44)/6d0
27534  wdtp(i)=fac*aem*qf**2/4d0
27535  wid2=1d0
27536  ELSEIF(i.EQ.3) THEN
27537 C...u* -> Z0 + u.
27538  qf=rtcm(43)*xw1/2d0-rtcm(44)*xw/6d0
27539  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
27540  & (1d0-rm1)**2*(2d0+rm1)
27541  wid2=wids(23,2)
27542  ELSEIF(i.EQ.4) THEN
27543 C...u* -> W+ + d.
27544  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
27545  & (1d0-rm1)**2*(2d0+rm1)
27546  IF(kflr.GT.0) wid2=wids(24,2)
27547  IF(kflr.LT.0) wid2=wids(24,3)
27548  ENDIF
27549  wdtp(i)=fudge*wdtp(i)
27550  wdtp(0)=wdtp(0)+wdtp(i)
27551  IF(mdme(idc,1).GT.0) THEN
27552  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27553  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27554  wdte(i,0)=wdte(i,mdme(idc,1))
27555  wdte(0,0)=wdte(0,0)+wdte(i,0)
27556  ENDIF
27557  440 CONTINUE
27558 
27559  ELSEIF(kfla.EQ.kexcit+11) THEN
27560 C...e* excited lepton.
27561  fac=(sh/rtcm(41)**2)*shr
27562  DO 450 i=1,mdcy(kc,3)
27563  idc=i+mdcy(kc,2)-1
27564  IF(mdme(idc,1).LT.0) goto 450
27565  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27566  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27567  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 450
27568  wid2=1d0
27569  IF(i.EQ.1) THEN
27570 C...e* -> gamma + e.
27571  qf=-rtcm(43)/2d0-rtcm(44)/2d0
27572  wdtp(i)=fac*aem*qf**2/4d0
27573  wid2=1d0
27574  ELSEIF(i.EQ.2) THEN
27575 C...e* -> Z0 + e.
27576  qf=-rtcm(43)*xw1/2d0+rtcm(44)*xw/2d0
27577  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
27578  & (1d0-rm1)**2*(2d0+rm1)
27579  wid2=wids(23,2)
27580  ELSEIF(i.EQ.3) THEN
27581 C...e* -> W- + nu.
27582  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
27583  & (1d0-rm1)**2*(2d0+rm1)
27584  IF(kflr.GT.0) wid2=wids(24,3)
27585  IF(kflr.LT.0) wid2=wids(24,2)
27586  ENDIF
27587  wdtp(i)=fudge*wdtp(i)
27588  wdtp(0)=wdtp(0)+wdtp(i)
27589  IF(mdme(idc,1).GT.0) THEN
27590  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27591  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27592  wdte(i,0)=wdte(i,mdme(idc,1))
27593  wdte(0,0)=wdte(0,0)+wdte(i,0)
27594  ENDIF
27595  450 CONTINUE
27596 
27597  ELSEIF(kfla.EQ.kexcit+12) THEN
27598 C...nu*_e excited neutrino.
27599  fac=(sh/rtcm(41)**2)*shr
27600  DO 460 i=1,mdcy(kc,3)
27601  idc=i+mdcy(kc,2)-1
27602  IF(mdme(idc,1).LT.0) goto 460
27603  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27604  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27605  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 460
27606  wid2=1d0
27607  IF(i.EQ.1) THEN
27608 C...nu*_e -> Z0 + nu*_e.
27609  qf=rtcm(43)*xw1/2d0+rtcm(44)*xw/2d0
27610  wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
27611  & (1d0-rm1)**2*(2d0+rm1)
27612  wid2=wids(23,2)
27613  ELSEIF(i.EQ.2) THEN
27614 C...nu*_e -> W+ + e.
27615  wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
27616  & (1d0-rm1)**2*(2d0+rm1)
27617  IF(kflr.GT.0) wid2=wids(24,2)
27618  IF(kflr.LT.0) wid2=wids(24,3)
27619  ENDIF
27620  wdtp(i)=fudge*wdtp(i)
27621  wdtp(0)=wdtp(0)+wdtp(i)
27622  IF(mdme(idc,1).GT.0) THEN
27623  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27624  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27625  wdte(i,0)=wdte(i,mdme(idc,1))
27626  wdte(0,0)=wdte(0,0)+wdte(i,0)
27627  ENDIF
27628  460 CONTINUE
27629 
27630  ELSEIF(kfla.EQ.kdimen+39) THEN
27631 C...G* (graviton resonance):
27632  fac=(parp(50)**2/paru(1))*shr
27633  DO 470 i=1,mdcy(kc,3)
27634  idc=i+mdcy(kc,2)-1
27635  IF(mdme(idc,1).LT.0) goto 470
27636  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27637  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27638  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 470
27639  wid2=1d0
27640  IF(i.LE.8) THEN
27641 C...G* -> q + qbar
27642  fcof=3d0*radc
27643  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
27644  & pyhfth(sh,sh*rm1,1d0)
27645  wdtp(i)=fac*fcof*sqrt(max(0d0,1d0-4d0*rm1))**3*
27646  & (1d0+8d0*rm1/3d0)/320d0
27647  IF(i.EQ.6) wid2=wids(6,1)
27648  IF(i.EQ.7.OR.i.EQ.8) wid2=wids(i,1)
27649  ELSEIF(i.LE.16) THEN
27650 C...G* -> l+ + l-, nu + nubar
27651  fcof=1d0
27652  wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))**3*
27653  & (1d0+8d0*rm1/3d0)/320d0
27654  IF(i.EQ.15.OR.i.EQ.16) wid2=wids(2+i,1)
27655  ELSEIF(i.EQ.17) THEN
27656 C...G* -> g + g.
27657  wdtp(i)=fac/20d0
27658  ELSEIF(i.EQ.18) THEN
27659 C...G* -> gamma + gamma.
27660  wdtp(i)=fac/160d0
27661  ELSEIF(i.EQ.19) THEN
27662 C...G* -> Z0 + Z0.
27663  wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))*(13d0/12d0+
27664  & 14d0*rm1/3d0+4d0*rm1**2)/160d0
27665  wid2=wids(23,1)
27666  ELSEIF(i.EQ.20) THEN
27667 C...G* -> W+ + W-.
27668  wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))*(13d0/12d0+
27669  & 14d0*rm1/3d0+4d0*rm1**2)/80d0
27670  wid2=wids(24,1)
27671  ENDIF
27672  wdtp(i)=fudge*wdtp(i)
27673  wdtp(0)=wdtp(0)+wdtp(i)
27674  IF(mdme(idc,1).GT.0) THEN
27675  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27676  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27677  wdte(i,0)=wdte(i,mdme(idc,1))
27678  wdte(0,0)=wdte(0,0)+wdte(i,0)
27679  ENDIF
27680  470 CONTINUE
27681 
27682  ELSEIF(kfla.EQ.9900012.OR.kfla.EQ.9900014.OR.kfla.EQ.9900016) THEN
27683 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27684  pmwr=max(1.001d0*shr,pmas(pycomp(9900024),1))
27685  fac=(aem**2/(768d0*paru(1)*xw**2))*shr**5/pmwr**4
27686  DO 480 i=1,mdcy(kc,3)
27687  idc=i+mdcy(kc,2)-1
27688  IF(mdme(idc,1).LT.0) goto 480
27689  pm1=pmas(pycomp(kfdp(idc,1)),1)
27690  pm2=pmas(pycomp(kfdp(idc,2)),1)
27691  pm3=pmas(pycomp(kfdp(idc,3)),1)
27692  IF(pm1+pm2+pm3.GE.shr) goto 480
27693  wid2=1d0
27694  IF(i.LE.9) THEN
27695 C...nu_lR -> l- qbar q'
27696  fcof=3d0*radc*vckm((i-1)/3+1,mod(i-1,3)+1)
27697  IF(mod(i,3).EQ.0) wid2=wids(6,2)
27698  ELSEIF(i.LE.18) THEN
27699 C...nu_lR -> l+ q qbar'
27700  fcof=3d0*radc*vckm((i-10)/3+1,mod(i-10,3)+1)
27701  IF(mod(i-9,3).EQ.0) wid2=wids(6,3)
27702  ELSE
27703 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27704  fcof=1d0
27705  wid2=wids(pycomp(kfdp(idc,3)),2)
27706  ENDIF
27707  x=(pm1+pm2+pm3)/shr
27708  fx=1d0-8d0*x**2+8d0*x**6-x**8-24d0*x**4*log(x)
27709  y=(shr/pmwr)**2
27710  fy=(12d0*(1d0-y)*log(1d0-y)+12d0*y-6d0*y**2-2d0*y**3)/y**4
27711  wdtp(i)=fac*fcof*fx*fy
27712  wdtp(i)=fudge*wdtp(i)
27713  wdtp(0)=wdtp(0)+wdtp(i)
27714  IF(mdme(idc,1).GT.0) THEN
27715  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27716  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27717  wdte(i,0)=wdte(i,mdme(idc,1))
27718  wdte(0,0)=wdte(0,0)+wdte(i,0)
27719  ENDIF
27720  480 CONTINUE
27721 
27722  ELSEIF(kfla.EQ.9900023) THEN
27723 C...Z_R0:
27724  fac=(aem/(48d0*xw*xw1*(1d0-2d0*xw)))*shr
27725  DO 490 i=1,mdcy(kc,3)
27726  idc=i+mdcy(kc,2)-1
27727  IF(mdme(idc,1).LT.0) goto 490
27728  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27729  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27730  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 490
27731  wid2=1d0
27732  symmet=1d0
27733  IF(i.LE.6) THEN
27734 C...Z_R0 -> q + qbar
27735  ef=kchg(i,1)/3d0
27736  af=sign(1d0,ef+0.1d0)*(1d0-2d0*xw)
27737  vf=sign(1d0,ef+0.1d0)-4d0*ef*xw
27738  fcof=3d0*radc
27739  IF(i.EQ.6) wid2=wids(6,1)
27740  ELSEIF(i.EQ.7.OR.i.EQ.10.OR.i.EQ.13) THEN
27741 C...Z_R0 -> l+ + l-
27742  af=-(1d0-2d0*xw)
27743  vf=-1d0+4d0*xw
27744  fcof=1d0
27745  ELSEIF(i.EQ.8.OR.i.EQ.11.OR.i.EQ.14) THEN
27746 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27747  af=-2d0*xw
27748  vf=0d0
27749  fcof=1d0
27750  symmet=0.5d0
27751  ELSEIF(i.LE.15) THEN
27752 C...Z0 -> nu_R + nu_R, assumed Majorana.
27753  af=2d0*xw1
27754  vf=0d0
27755  fcof=1d0
27756  wid2=wids(pycomp(kfdp(idc,1)),1)
27757  symmet=0.5d0
27758  ENDIF
27759  wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
27760  & sqrt(max(0d0,1d0-4d0*rm1))*symmet
27761  wdtp(i)=fudge*wdtp(i)
27762  wdtp(0)=wdtp(0)+wdtp(i)
27763  IF(mdme(idc,1).GT.0) THEN
27764  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27765  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27766  wdte(i,0)=wdte(i,mdme(idc,1))
27767  wdte(0,0)=wdte(0,0)+wdte(i,0)
27768  ENDIF
27769  490 CONTINUE
27770 
27771  ELSEIF(kfla.EQ.9900024) THEN
27772 C...W_R+/-:
27773  fac=(aem/(24d0*xw))*shr
27774  DO 500 i=1,mdcy(kc,3)
27775  idc=i+mdcy(kc,2)-1
27776  IF(mdme(idc,1).LT.0) goto 500
27777  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27778  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27779  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 500
27780  wid2=1d0
27781  IF(i.LE.9) THEN
27782 C...W_R+/- -> q + qbar'
27783  fcof=3d0*radc*vckm((i-1)/3+1,mod(i-1,3)+1)
27784  IF(kflr.GT.0) THEN
27785  IF(mod(i,3).EQ.0) wid2=wids(6,2)
27786  ELSE
27787  IF(mod(i,3).EQ.0) wid2=wids(6,3)
27788  ENDIF
27789  ELSEIF(i.LE.12) THEN
27790 C...W_R+/- -> l+/- + nu_R
27791  fcof=1d0
27792  ENDIF
27793  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
27794  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27795  wdtp(i)=fudge*wdtp(i)
27796  wdtp(0)=wdtp(0)+wdtp(i)
27797  IF(mdme(idc,1).GT.0) THEN
27798  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27799  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27800  wdte(i,0)=wdte(i,mdme(idc,1))
27801  wdte(0,0)=wdte(0,0)+wdte(i,0)
27802  ENDIF
27803  500 CONTINUE
27804 
27805  ELSEIF(kfla.EQ.9900041) THEN
27806 C...H_L++/--:
27807  fac=(1d0/(8d0*paru(1)))*shr
27808  DO 510 i=1,mdcy(kc,3)
27809  idc=i+mdcy(kc,2)-1
27810  IF(mdme(idc,1).LT.0) goto 510
27811  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27812  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27813  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 510
27814  wid2=1d0
27815  IF(i.LE.6) THEN
27816 C...H_L++/-- -> l+/- + l'+/-
27817  fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
27818  & (iabs(kfdp(idc,2))-9)/2)**2
27819  IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
27820  ELSEIF(i.EQ.7) THEN
27821 C...H_L++/-- -> W_L+/- + W_L+/-
27822  fcof=0.5d0*parp(190)**4*parp(192)**2/pmas(24,1)**2*
27823  & (3d0*rm1+0.25d0/rm1-1d0)
27824  wid2=wids(24,4+(1-kfls)/2)
27825  ENDIF
27826  wdtp(i)=fac*fcof*
27827  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27828  wdtp(i)=fudge*wdtp(i)
27829  wdtp(0)=wdtp(0)+wdtp(i)
27830  IF(mdme(idc,1).GT.0) THEN
27831  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27832  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27833  wdte(i,0)=wdte(i,mdme(idc,1))
27834  wdte(0,0)=wdte(0,0)+wdte(i,0)
27835  ENDIF
27836  510 CONTINUE
27837 
27838  ELSEIF(kfla.EQ.9900042) THEN
27839 C...H_R++/--:
27840  fac=(1d0/(8d0*paru(1)))*shr
27841  DO 520 i=1,mdcy(kc,3)
27842  idc=i+mdcy(kc,2)-1
27843  IF(mdme(idc,1).LT.0) goto 520
27844  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27845  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27846  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 520
27847  wid2=1d0
27848  IF(i.LE.6) THEN
27849 C...H_R++/-- -> l+/- + l'+/-
27850  fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
27851  & (iabs(kfdp(idc,2))-9)/2)**2
27852  IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
27853  ELSEIF(i.EQ.7) THEN
27854 C...H_R++/-- -> W_R+/- + W_R+/-
27855  fcof=parp(191)**2*(3d0*rm1+0.25d0/rm1-1d0)
27856  wid2=wids(pycomp(9900024),4+(1-kfls)/2)
27857  ENDIF
27858  wdtp(i)=fac*fcof*
27859  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27860  wdtp(i)=fudge*wdtp(i)
27861  wdtp(0)=wdtp(0)+wdtp(i)
27862  IF(mdme(idc,1).GT.0) THEN
27863  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27864  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27865  wdte(i,0)=wdte(i,mdme(idc,1))
27866  wdte(0,0)=wdte(0,0)+wdte(i,0)
27867  ENDIF
27868  520 CONTINUE
27869 
27870  ELSEIF(kfla.EQ.ktechn+115) THEN
27871 C...Techni-a2:
27872 C...Need to update to alpha_rho
27873  alprht=2.16d0*(3d0/itcm(1))*rtcm(47)**2
27874  fac=(alprht/12d0)*shr
27875  facf=(1d0/6d0)*(aem**2/alprht)*shr
27876  sqmz=pmas(23,1)**2
27877  sqmw=pmas(24,1)**2
27878  shp=sh
27879  CALL pywidx(23,shp,wdtpp,wdtep)
27880  gmmz=shr*wdtpp(0)
27881  xwrht=1d0/(4d0*xw*(1d0-xw))
27882  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
27883  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
27884  DO 530 i=1,mdcy(kc,3)
27885  idc=i+mdcy(kc,2)-1
27886  IF(mdme(idc,1).LT.0) goto 530
27887  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27888  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27889  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 530
27890  wid2=1d0
27891  pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27892  IF(i.LE.4) THEN
27893  facpv=pcm**2
27894  facpa=pcm**2+1.5d0*rm1
27895  va2=0d0
27896  aa2=0d0
27897 C...a2_tc0 -> W+ + W-
27898  IF(i.EQ.1) THEN
27899  aa2=2d0*rtcm(3)**2/4d0/xw/rtcm(49)**2
27900 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27901  wid2=wids(24,1)
27902 C...a2_tc0 -> W+ + pi_tc- + c.c.
27903  ELSEIF(i.EQ.2.OR.i.EQ.3) THEN
27904  aa2=(1d0-rtcm(3)**2)/4d0/xw/rtcm(49)**2
27905  IF(i.EQ.6) THEN
27906  wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
27907  ELSE
27908  wid2=wids(24,3)*wids(pycomp(ktechn+211),2)
27909  ENDIF
27910  ELSEIF(i.EQ.4) THEN
27911 C...a2_tc0 -> Z0 + pi_tc0'
27912  va2=(1d0-rtcm(4)**2)/4d0/xw/xw1/rtcm(48)**2
27913  wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
27914  ENDIF
27915  wdtp(i)=aem*shr**3*pcm/3d0*(va2*facpv+aa2*facpa)
27916  ELSEIF(i.GE.5.AND.i.LE.10) THEN
27917  facpv=pcm**2*(1d0+rm1+rm2)+3d0*rm1*rm2
27918  facpa=pcm**2*(1d0+rm1+rm2)
27919  va2=0d0
27920  aa2=0d0
27921  IF(i.EQ.5) THEN
27922 C...a_T^0 -> gamma rho_T^0
27923  va2=(2d0*rtcm(2)-1d0)**2/rtcm(50)**4
27924  wid2=wids(pycomp(ktechn+113),2)
27925  ELSEIF(i.EQ.6) THEN
27926 C...a_T^0 -> gamma omega_T
27927  va2=1d0/rtcm(50)**4
27928  wid2=wids(pycomp(ktechn+223),2)
27929  ELSEIF(i.EQ.7.OR.i.EQ.8) THEN
27930 C...a_T^0 -> W^+- rho_T^-+
27931  aa2=.25d0/xw/rtcm(51)**4
27932  IF(i.EQ.7) THEN
27933  wid2=wids(24,2)*wids(pycomp(ktechn+213),3)
27934  ELSE
27935  wid2=wids(24,3)*wids(pycomp(ktechn+213),2)
27936  ENDIF
27937  ELSEIF(i.EQ.9) THEN
27938 C...a_T^0 -> Z^0 rho_T^0
27939  va2=(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(50)**4
27940  wid2=wids(23,2)*wids(pycomp(ktechn+113),2)
27941  ELSEIF(i.EQ.10) THEN
27942 C...a_T^0 -> Z^0 omega_T
27943  va2=.25d0*(1d0-2d0*xw)**2/xw/xw1/rtcm(50)**4
27944  wid2=wids(23,2)*wids(pycomp(ktechn+223),2)
27945  ENDIF
27946  wdtp(i)=aem*shr**5*pcm/12d0*(va2*facpv+aa2*facpa)
27947  ELSE
27948 C...a2_tc0 -> f + fbar.
27949  wid2=1d0
27950  IF(i.LE.18) THEN
27951  ia=i-10
27952  fcof=3d0*radc
27953  IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
27954  ELSE
27955  ia=i-8
27956  fcof=1d0
27957  IF(ia.GE.17) wid2=wids(ia,1)
27958  ENDIF
27959  ei=kchg(ia,1)/3d0
27960  ai=sign(1d0,ei+0.1d0)
27961  vi=ai-4d0*ei*xwv
27962  vali=0.5d0*(vi+ai)
27963  vari=0.5d0*(vi-ai)
27964  wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
27965  & ((vali*bwzr)**2+(vali*bwzi)**2+
27966  & (vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
27967  & (vali*bwzr)*(vari*bwzr)+vali*vari*bwzi**2))
27968  ENDIF
27969  wdtp(i)=fudge*wdtp(i)
27970  wdtp(0)=wdtp(0)+wdtp(i)
27971  IF(mdme(idc,1).GT.0) THEN
27972  wdte(i,mdme(idc,1))=wdtp(i)*wid2
27973  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27974  wdte(i,0)=wdte(i,mdme(idc,1))
27975  wdte(0,0)=wdte(0,0)+wdte(i,0)
27976  ENDIF
27977  530 CONTINUE
27978 
27979  ELSEIF(kfla.EQ.ktechn+215) THEN
27980 C...Techni-a2+/-:
27981  alprht=2.16d0*(3d0/itcm(1))*rtcm(47)**2
27982  fac=(alprht/12d0)*shr
27983  sqmz=pmas(23,1)**2
27984  sqmw=pmas(24,1)**2
27985  shp=sh
27986  CALL pywidx(24,shp,wdtpp,wdtep)
27987  gmmw=shr*wdtpp(0)
27988  facf=(1d0/12d0)*(aem**2/alprht)*shr*
27989  & (0.125d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
27990  DO 540 i=1,mdcy(kc,3)
27991  idc=i+mdcy(kc,2)-1
27992  IF(mdme(idc,1).LT.0) goto 540
27993  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27994  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27995  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 540
27996  wid2=1d0
27997  pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27998  IF(kflr.GT.0) THEN
27999  ichann=2
28000  ELSE
28001  ichann=3
28002  ENDIF
28003  IF(i.LE.7) THEN
28004  aa2=0
28005  va2=0
28006 C...a2_tc+ -> gamma + W+.
28007  IF(i.EQ.1) THEN
28008  aa2=rtcm(3)**2/rtcm(49)**2
28009  wid2=wids(24,ichann)
28010 C...a2_tc+ -> gamma + pi_tc+.
28011  ELSEIF(i.EQ.2) THEN
28012  aa2=(1d0-rtcm(3)**2)/rtcm(49)**2
28013  wid2=wids(pycomp(ktechn+211),ichann)
28014 C...a2_tc+ -> W+ + Z
28015  ELSEIF(i.EQ.3) THEN
28016  aa2=rtcm(3)**2*(1d0/4d0/xw1 +
28017  & (xw-xw1)**2/4./xw/xw1)/rtcm(49)**2
28018  wid2=wids(24,ichann)*wids(23,2)
28019 C...a2_tc+ -> W+ + pi_tc0.
28020  ELSEIF(i.EQ.4) THEN
28021  aa2=(1d0-rtcm(3)**2)/4d0/xw/rtcm(49)**2
28022  wid2=wids(24,ichann)*wids(pycomp(ktechn+111),2)
28023 C...a2_tc+ -> W+ + pi_tc'0.
28024  ELSEIF(i.EQ.5) THEN
28025  va2=(1d0-rtcm(4)**2)/4d0/xw/rtcm(48)**2
28026  wid2=wids(24,ichann)*wids(pycomp(ktechn+221),2)
28027 C...a2_tc+ -> Z0 + pi_tc+.
28028  ELSEIF(i.EQ.6) THEN
28029  aa2=(1d0-rtcm(3)**2)/4d0/xw/xw1*(1d0-2d0*xw)**2/
28030  & rtcm(49)**2
28031  wid2=wids(23,2)*wids(pycomp(ktechn+211),ichann)
28032  ENDIF
28033  wdtp(i)=aem*pcm*(aa2*(pcm**2+1.5d0*rm1)+pcm**2*va2)
28034  & /3d0*shr**3
28035  ELSEIF(i.LE.10) THEN
28036  facpv=pcm**2*(1d0+rm1+rm2)+3d0*rm1*rm2
28037  facpa=pcm**2*(1d0+rm1+rm2)
28038  va2=0d0
28039  aa2=0d0
28040 C...a2_tc+ -> gamma + rho_tc+
28041  IF(i.EQ.7) THEN
28042  va2=(2d0*rtcm(2)-1d0)**2/rtcm(50)**4
28043  wid2=wids(pycomp(ktechn+213),ichann)
28044 C...a2_tc+ -> W+ + rho_T^0
28045  ELSEIF(i.EQ.8) THEN
28046  aa2=1d0/(4d0*xw)/rtcm(51)**4
28047  wid2=wids(24,ichann)*wids(pycomp(ktechn+113),2)
28048 C...a2_tc+ -> W+ + omega_T
28049  ELSEIF(i.EQ.9) THEN
28050  va2=.25d0/xw/rtcm(50)**4
28051  wid2=wids(24,ichann)*wids(pycomp(ktechn+223),2)
28052 C...a2_tc+ -> Z^0 + rho_T^+
28053  ELSEIF(i.EQ.10) THEN
28054  va2=(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(50)**4
28055  aa2=1d0/(4d0*xw*xw1)/rtcm(51)**4
28056  wid2=wids(23,2)*wids(pycomp(ktechn+213),ichann)
28057  ENDIF
28058  wdtp(i)=aem*shr**5*pcm/12d0*(va2*facpv+aa2*facpa)
28059  ELSE
28060 C...a2_tc+ -> f + fbar'.
28061  ia=i-10
28062  wid2=1d0
28063  IF(ia.LE.16) THEN
28064  fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
28065  IF(kflr.GT.0) THEN
28066  IF(mod(ia,4).EQ.3) wid2=wids(6,2)
28067  IF(mod(ia,4).EQ.0) wid2=wids(8,2)
28068  IF(ia.GE.13) wid2=wid2*wids(7,3)
28069  ELSE
28070  IF(mod(ia,4).EQ.3) wid2=wids(6,3)
28071  IF(mod(ia,4).EQ.0) wid2=wids(8,3)
28072  IF(ia.GE.13) wid2=wid2*wids(7,2)
28073  ENDIF
28074  ELSE
28075  fcof=1d0
28076  IF(kflr.GT.0) THEN
28077  IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
28078  ELSE
28079  IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
28080  ENDIF
28081  ENDIF
28082  wdtp(i)=facf*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
28083  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
28084  ENDIF
28085  wdtp(i)=fudge*wdtp(i)
28086  wdtp(0)=wdtp(0)+wdtp(i)
28087  IF(mdme(idc,1).GT.0) THEN
28088  wdte(i,mdme(idc,1))=wdtp(i)*wid2
28089  wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
28090  wdte(i,0)=wdte(i,mdme(idc,1))
28091  wdte(0,0)=wdte(0,0)+wdte(i,0)
28092  ENDIF
28093  540 CONTINUE
28094 
28095  ENDIF
28096  mint(61)=0
28097  mint(62)=0
28098  mint(63)=0
28099  RETURN
28100  END
28101 
28102 C***********************************************************************
28103 
28104 C...PYOFSH
28105 C...Calculates partial width and differential cross-section maxima
28106 C...of channels/processes not allowed on mass-shell, and selects
28107 C...masses in such channels/processes.
28108 
28109  SUBROUTINE pyofsh(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
28110 
28111 C...Double precision and integer declarations.
28112  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28113  IMPLICIT INTEGER(i-n)
28114  INTEGER pyk,pychge,pycomp
28115 C...Commonblocks.
28116  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28117  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28118  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
28119  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
28120  common/pypars/mstp(200),parp(200),msti(200),pari(200)
28121  common/pyint1/mint(400),vint(400)
28122  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
28123  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
28124  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
28125  &/pyint2/,/pyint5/
28126 C...Local arrays.
28127  dimension kfd(2),mbw(2),pmd(2),pgd(2),pmg(2),pml(2),pmu(2),
28128  &pmh(2),atl(2),atu(2),ath(2),rmg(2),inx1(100),xpt1(100),
28129  &fpt1(100),inx2(100),xpt2(100),fpt2(100),wdtp(0:400),
28130  &wdte(0:400,0:5)
28131 
28132 C...Find if particles equal, maximum mass, matrix elements, etc.
28133  mint(51)=0
28134  isub=mint(1)
28135  kfd(1)=iabs(kfd1)
28136  kfd(2)=iabs(kfd2)
28137  meql=0
28138  IF(kfd(1).EQ.kfd(2)) meql=1
28139  mlm=0
28140  IF(mofsh.GE.2.AND.meql.EQ.1) mlm=int(1.5d0+pyr(0))
28141  IF(mofsh.LE.2.OR.mofsh.EQ.5) THEN
28142  noff=44
28143  pmmx=pmmo
28144  ELSE
28145  noff=40
28146  pmmx=vint(1)
28147  IF(ckin(2).GT.ckin(1)) pmmx=min(ckin(2),vint(1))
28148  ENDIF
28149  mmed=0
28150 C IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
28151  IF((kfmo.EQ.25.OR.kfmo.EQ.35).AND.meql.EQ.1.AND.
28152  &(kfd(1).EQ.23.OR.kfd(1).EQ.24)) mmed=1
28153  IF(kfmo.EQ.36.AND.meql.EQ.1.AND.
28154  &(kfd(1).EQ.23.OR.kfd(1).EQ.24)) mmed=4
28155  IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(1).EQ.23.OR.
28156  &kfd(1).EQ.24).AND.(kfd(2).EQ.23.OR.kfd(2).EQ.24)) mmed=2
28157  IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(2).EQ.25.OR.
28158  &kfd(2).EQ.35.OR.kfd(2).EQ.36)) mmed=3
28159  loop=1
28160 
28161 C...Find where Breit-Wigners are required, else select discrete masses.
28162  100 DO 110 i=1,2
28163  kfca=pycomp(kfd(i))
28164  IF(kfca.GT.0) THEN
28165  pmd(i)=pmas(kfca,1)
28166  pgd(i)=pmas(kfca,2)
28167  ELSE
28168  pmd(i)=0d0
28169  pgd(i)=0d0
28170  ENDIF
28171  IF(mstp(42).LE.0.OR.pgd(i).LT.parp(41)) THEN
28172  mbw(i)=0
28173  pmg(i)=pmd(i)
28174  rmg(i)=(pmg(i)/pmmx)**2
28175  ELSE
28176  mbw(i)=1
28177  ENDIF
28178  110 CONTINUE
28179 
28180 C...Find allowed mass range and Breit-Wigner parameters.
28181  DO 120 i=1,2
28182  IF(mofsh.EQ.1.AND.loop.EQ.1.AND.mbw(i).EQ.1) THEN
28183  pml(i)=parp(42)
28184  pmu(i)=pmmx-parp(42)
28185  IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
28186  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
28187  ELSEIF(mbw(i).EQ.1.AND.mofsh.NE.5) THEN
28188  ilm=i
28189  IF(mlm.EQ.2) ilm=3-i
28190  pml(i)=max(ckin(noff+2*ilm-1),parp(42))
28191  IF(mbw(3-i).EQ.0) THEN
28192  pmu(i)=pmmx-pmd(3-i)
28193  ELSE
28194  pmu(i)=pmmx-max(ckin(noff+5-2*ilm),parp(42))
28195  ENDIF
28196  IF(ckin(noff+2*ilm).GT.ckin(noff+2*ilm-1)) pmu(i)=
28197  & min(pmu(i),ckin(noff+2*ilm))
28198  IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
28199  IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
28200  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
28201  IF(mbw(i).EQ.1) THEN
28202  atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
28203  atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
28204  IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
28205  & pgd(i)))
28206  ENDIF
28207  ELSEIF(mbw(i).EQ.1.AND.mofsh.EQ.5) THEN
28208  ilm=i
28209  IF(mlm.EQ.2) ilm=3-i
28210  pml(i)=max(ckin(48+i),parp(42))
28211  pmu(i)=pmmx-max(ckin(51-i),parp(42))
28212  IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
28213  IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
28214  IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
28215  IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
28216  IF(mbw(i).EQ.1) THEN
28217  atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
28218  atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
28219  IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
28220  & pgd(i)))
28221  ENDIF
28222  ENDIF
28223  120 CONTINUE
28224  IF(mbw(1).LT.0.OR.mbw(2).LT.0.OR.(mbw(1).EQ.0.AND.mbw(2).EQ.0))
28225  &THEN
28226  CALL pyerrm(3,'(PYOFSH:) no allowed decay product masses')
28227  mint(51)=1
28228  RETURN
28229  ENDIF
28230 
28231 C...Calculation of partial width of resonance.
28232  IF(mofsh.EQ.1) THEN
28233 
28234 C..If only one integration, pick that to be the inner.
28235  IF(mbw(1).EQ.0) THEN
28236  pm2=pmd(1)
28237  pmd(1)=pmd(2)
28238  pgd(1)=pgd(2)
28239  pml(1)=pml(2)
28240  pmu(1)=pmu(2)
28241  ELSEIF(mbw(2).EQ.0) THEN
28242  pm2=pmd(2)
28243  ENDIF
28244 
28245 C...Start outer loop of integration.
28246  IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
28247  atl2=atan((pml(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
28248  atu2=atan((pmu(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
28249  npt2=1
28250  xpt2(1)=1d0
28251  inx2(1)=0
28252  fmax2=0d0
28253  ENDIF
28254  130 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
28255  pm2s=pmd(2)**2+pmd(2)*pgd(2)*tan(atl2+xpt2(npt2)*(atu2-atl2))
28256  pm2=min(pmu(2),max(pml(2),sqrt(max(0d0,pm2s))))
28257  ENDIF
28258  rm2=(pm2/pmmx)**2
28259 
28260 C...Start inner loop of integration.
28261  pml1=pml(1)
28262  pmu1=min(pmu(1),pmmx-pm2)
28263  IF(meql.EQ.1) pmu1=min(pmu1,pm2)
28264  atl1=atan((pml1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
28265  atu1=atan((pmu1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
28266  IF(pml1+parj(64).GE.pmu1.OR.atl1+1d-7.GE.atu1) THEN
28267  func2=0d0
28268  goto 180
28269  ENDIF
28270  npt1=1
28271  xpt1(1)=1d0
28272  inx1(1)=0
28273  fmax1=0d0
28274  140 pm1s=pmd(1)**2+pmd(1)*pgd(1)*tan(atl1+xpt1(npt1)*(atu1-atl1))
28275  pm1=min(pmu1,max(pml1,sqrt(max(0d0,pm1s))))
28276  rm1=(pm1/pmmx)**2
28277 
28278 C...Evaluate function value - inner loop.
28279  func1=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
28280  IF(mmed.EQ.1) func1=func1*((1d0-rm1-rm2)**2+8d0*rm1*rm2)
28281  IF(mmed.EQ.4) func1=func1**3*rm1*rm2
28282  IF(mmed.EQ.2) func1=func1**3*(1d0+10d0*rm1+10d0*rm2+rm1**2+
28283  & rm2**2+10d0*rm1*rm2)
28284  IF(func1.GT.fmax1) fmax1=func1
28285  fpt1(npt1)=func1
28286 
28287 C...Go to next position in inner loop.
28288  IF(npt1.EQ.1) THEN
28289  npt1=npt1+1
28290  xpt1(npt1)=0d0
28291  inx1(npt1)=1
28292  goto 140
28293  ELSEIF(npt1.LE.8) THEN
28294  npt1=npt1+1
28295  IF(npt1.LE.4.OR.npt1.EQ.6) ish1=1
28296  ish1=ish1+1
28297  xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
28298  inx1(npt1)=inx1(ish1)
28299  inx1(ish1)=npt1
28300  goto 140
28301  ELSEIF(npt1.LT.100) THEN
28302  isn1=ish1
28303  150 ish1=ish1+1
28304  IF(ish1.GT.npt1) ish1=2
28305  IF(ish1.EQ.isn1) goto 160
28306  dfpt1=abs(fpt1(ish1)-fpt1(inx1(ish1)))
28307  IF(dfpt1.LT.parp(43)*fmax1) goto 150
28308  npt1=npt1+1
28309  xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
28310  inx1(npt1)=inx1(ish1)
28311  inx1(ish1)=npt1
28312  goto 140
28313  ENDIF
28314 
28315 C...Calculate integral over inner loop.
28316  160 fsum1=0d0
28317  DO 170 ipt1=2,npt1
28318  fsum1=fsum1+0.5d0*(fpt1(ipt1)+fpt1(inx1(ipt1)))*
28319  & (xpt1(inx1(ipt1))-xpt1(ipt1))
28320  170 CONTINUE
28321  func2=fsum1*(atu1-atl1)/paru(1)
28322  180 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
28323  IF(func2.GT.fmax2) fmax2=func2
28324  fpt2(npt2)=func2
28325 
28326 C...Go to next position in outer loop.
28327  IF(npt2.EQ.1) THEN
28328  npt2=npt2+1
28329  xpt2(npt2)=0d0
28330  inx2(npt2)=1
28331  goto 130
28332  ELSEIF(npt2.LE.8) THEN
28333  npt2=npt2+1
28334  IF(npt2.LE.4.OR.npt2.EQ.6) ish2=1
28335  ish2=ish2+1
28336  xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
28337  inx2(npt2)=inx2(ish2)
28338  inx2(ish2)=npt2
28339  goto 130
28340  ELSEIF(npt2.LT.100) THEN
28341  isn2=ish2
28342  190 ish2=ish2+1
28343  IF(ish2.GT.npt2) ish2=2
28344  IF(ish2.EQ.isn2) goto 200
28345  dfpt2=abs(fpt2(ish2)-fpt2(inx2(ish2)))
28346  IF(dfpt2.LT.parp(43)*fmax2) goto 190
28347  npt2=npt2+1
28348  xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
28349  inx2(npt2)=inx2(ish2)
28350  inx2(ish2)=npt2
28351  goto 130
28352  ENDIF
28353 
28354 C...Calculate integral over outer loop.
28355  200 fsum2=0d0
28356  DO 210 ipt2=2,npt2
28357  fsum2=fsum2+0.5d0*(fpt2(ipt2)+fpt2(inx2(ipt2)))*
28358  & (xpt2(inx2(ipt2))-xpt2(ipt2))
28359  210 CONTINUE
28360  fsum2=fsum2*(atu2-atl2)/paru(1)
28361  IF(meql.EQ.1) fsum2=2d0*fsum2
28362  ELSE
28363  fsum2=func2
28364  ENDIF
28365 
28366 C...Save result; second integration for user-selected mass range.
28367  IF(loop.EQ.1) widw=fsum2
28368  wid2=fsum2
28369  IF(loop.EQ.1.AND.(ckin(46).GE.ckin(45).OR.ckin(48).GE.ckin(47)
28370  & .OR.max(ckin(45),ckin(47)).GE.1.01d0*parp(42))) THEN
28371  loop=2
28372  goto 100
28373  ENDIF
28374  ret1=widw
28375  ret2=wid2/widw
28376 
28377 C...Select two decay product masses of a resonance.
28378  ELSEIF(mofsh.EQ.2.OR.mofsh.EQ.5) THEN
28379  220 DO 230 i=1,2
28380  IF(mbw(i).EQ.0) goto 230
28381  pmbw=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*
28382  & (atu(i)-atl(i)))
28383  pmg(i)=min(pmu(i),max(pml(i),sqrt(max(0d0,pmbw))))
28384  rmg(i)=(pmg(i)/pmmx)**2
28385  230 CONTINUE
28386  IF((meql.EQ.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
28387  & pmg(1)+pmg(2)+parj(64).GT.pmmx) goto 220
28388 
28389 C...Weight with matrix element (if none known, use beta factor).
28390  flam=sqrt(max(0d0,(1d0-rmg(1)-rmg(2))**2-4d0*rmg(1)*rmg(2)))
28391  IF(mmed.EQ.1) THEN
28392  wtbe=flam*((1d0-rmg(1)-rmg(2))**2+8d0*rmg(1)*rmg(2))
28393  ELSEIF(mmed.EQ.4) THEN
28394  wtbe=flam**3*rmg(1)*rmg(2)
28395  ELSEIF(mmed.EQ.2) THEN
28396  wtbe=flam**3*(1d0+10d0*rmg(1)+10d0*rmg(2)+rmg(1)**2+
28397  & rmg(2)**2+10d0*rmg(1)*rmg(2))
28398  ELSEIF(mmed.EQ.3) THEN
28399  wtbe=flam*(rmg(1)+flam**2/12d0)
28400  ELSE
28401  wtbe=flam
28402  ENDIF
28403  IF(wtbe.LT.pyr(0)) goto 220
28404  ret1=pmg(1)
28405  ret2=pmg(2)
28406 
28407 C...Find suitable set of masses for initialization of 2 -> 2 processes.
28408  ELSEIF(mofsh.EQ.3) THEN
28409  IF(mbw(1).NE.0.AND.mbw(2).EQ.0) THEN
28410  pmg(1)=min(pmd(1),0.5d0*(pml(1)+pmu(1)))
28411  pmg(2)=pmd(2)
28412  ELSEIF(mbw(2).NE.0.AND.mbw(1).EQ.0) THEN
28413  pmg(1)=pmd(1)
28414  pmg(2)=min(pmd(2),0.5d0*(pml(2)+pmu(2)))
28415  ELSE
28416  idiv=-1
28417  240 idiv=idiv+1
28418  pmg(1)=min(pmd(1),0.1d0*(idiv*pml(1)+(10-idiv)*pmu(1)))
28419  pmg(2)=min(pmd(2),0.1d0*(idiv*pml(2)+(10-idiv)*pmu(2)))
28420  IF(idiv.LE.9.AND.pmg(1)+pmg(2).GT.0.9d0*pmmx) goto 240
28421  ENDIF
28422  ret1=pmg(1)
28423  ret2=pmg(2)
28424 
28425 C...Evaluate importance of excluded tails of Breit-Wigners.
28426  IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
28427  & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
28428  IF(meql.LE.1) THEN
28429  vint(80)=1d0
28430  DO 250 i=1,2
28431  IF(mbw(i).NE.0) vint(80)=vint(80)*1.25d0*(atu(i)-atl(i))/
28432  & paru(1)
28433  250 CONTINUE
28434  ELSE
28435  vint(80)=(1.25d0/paru(1))**2*max((atu(1)-atl(1))*
28436  & (ath(2)-atl(2)),(ath(1)-atl(1))*(atu(2)-atl(2)))
28437  ENDIF
28438  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.30.OR.isub.EQ.35).AND.
28439  & mstp(43).NE.2) vint(80)=2d0*vint(80)
28440  IF(isub.EQ.22.AND.mstp(43).NE.2) vint(80)=4d0*vint(80)
28441  IF(meql.GE.1) vint(80)=2d0*vint(80)
28442 
28443 C...Pick one particle to be the lighter (if improves efficiency).
28444  ELSEIF(mofsh.EQ.4) THEN
28445  IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
28446  & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
28447  260 IF(meql.EQ.2) mlm=int(1.5d0+pyr(0))
28448 
28449 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
28450  DO 270 i=1,2
28451  IF(mbw(i).EQ.0) goto 270
28452  pmv=pmu(i)
28453  IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
28454  atv=atu(i)
28455  IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
28456  rbr=pyr(0)
28457  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
28458  & isub.EQ.35).AND.mstp(43).NE.2) rbr=2d0*rbr
28459  IF(rbr.LT.0.8d0) THEN
28460  pmsr=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*(atv-atl(i)))
28461  pmg(i)=min(pmv,max(pml(i),sqrt(max(0d0,pmsr))))
28462  ELSEIF(rbr.LT.0.9d0) THEN
28463  pmg(i)=sqrt(max(0d0,pml(i)**2+pyr(0)*(pmv**2-pml(i)**2)))
28464  ELSEIF(rbr.LT.1.5d0) THEN
28465  pmg(i)=pml(i)*(pmv/pml(i))**pyr(0)
28466  ELSE
28467  pmg(i)=sqrt(max(0d0,pml(i)**2*pmv**2/(pml(i)**2+pyr(0)*
28468  & (pmv**2-pml(i)**2))))
28469  ENDIF
28470  270 CONTINUE
28471  IF((meql.GE.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
28472  & pmg(1)+pmg(2)+parj(64).GT.pmmx) THEN
28473  IF(mint(48).EQ.1.AND.mstp(171).EQ.0) THEN
28474  ngen(0,1)=ngen(0,1)+1
28475  ngen(mint(1),1)=ngen(mint(1),1)+1
28476  goto 260
28477  ELSE
28478  mint(51)=1
28479  RETURN
28480  ENDIF
28481  ENDIF
28482  ret1=pmg(1)
28483  ret2=pmg(2)
28484 
28485 C...Give weight for selected mass distribution.
28486  vint(80)=1d0
28487  DO 280 i=1,2
28488  IF(mbw(i).EQ.0) goto 280
28489  pmv=pmu(i)
28490  IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
28491  atv=atu(i)
28492  IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
28493  f0=pmd(i)*pgd(i)/((pmg(i)**2-pmd(i)**2)**2+
28494  & (pmd(i)*pgd(i))**2)/paru(1)
28495  f1=1d0
28496  f2=1d0/pmg(i)**2
28497  f3=1d0/pmg(i)**4
28498  fi0=(atv-atl(i))/paru(1)
28499  fi1=pmv**2-pml(i)**2
28500  fi2=2d0*log(pmv/pml(i))
28501  fi3=1d0/pml(i)**2-1d0/pmv**2
28502  IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
28503  & isub.EQ.35).AND.mstp(43).NE.2) THEN
28504  vint(80)=vint(80)*20d0/(8d0+(fi0/f0)*(f1/fi1+6d0*f2/fi2+
28505  & 5d0*f3/fi3))
28506  ELSE
28507  vint(80)=vint(80)*10d0/(8d0+(fi0/f0)*(f1/fi1+f2/fi2))
28508  ENDIF
28509  vint(80)=vint(80)*fi0
28510  280 CONTINUE
28511  IF(meql.GE.1) vint(80)=2d0*vint(80)
28512  ENDIF
28513 
28514  RETURN
28515  END
28516 
28517 C***********************************************************************
28518 
28519 C...PYRECO
28520 C...Handles the possibility of colour reconnection in W+W- events,
28521 C...Based on the main scenarios of the Sjostrand and Khoze study:
28522 C...I, II, II', intermediate and instantaneous; plus one model
28523 C...along the lines of the Gustafson and Hakkinen: GH.
28524 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
28525 C...is as if first resonance is W+ and second W-.
28526 
28527  SUBROUTINE pyreco(IW1,IW2,NSD1,NAFT1)
28528 
28529 C...Double precision and integer declarations.
28530  IMPLICIT DOUBLE PRECISION(a-h, o-z)
28531  IMPLICIT INTEGER(i-n)
28532  INTEGER pyk,pychge,pycomp
28533 C...Parameter value; number of points in MC integration.
28534  parameter(npt=100)
28535 C...Commonblocks.
28536  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
28537  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28538  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28539  common/pypars/mstp(200),parp(200),msti(200),pari(200)
28540  common/pyint1/mint(400),vint(400)
28541  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
28542 C...Local arrays.
28543  dimension nbeg(2),nend(2),inp(50),inm(50),beww(3),xp(3),xm(3),
28544  &v1(3),v2(3),betp(50,4),dirp(50,3),betm(50,4),dirm(50,3),
28545  &xd(4),xb(4),iap(npt),iam(npt),wta(npt),v1p(3),v2p(3),v1m(3),
28546  &v2m(3),q(4,3),xpp(3),xmm(3),ipc(20),imc(20),tc(0:20),tpc(20),
28547  &tmc(20),ijoin(100)
28548 
28549 C...Functions to give four-product and to do determinants.
28550  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)
28551  deter(i,j,l)=q(i,1)*q(j,2)*q(l,3)-q(i,1)*q(l,2)*q(j,3)+
28552  &q(j,1)*q(l,2)*q(i,3)-q(j,1)*q(i,2)*q(l,3)+
28553  &q(l,1)*q(i,2)*q(j,3)-q(l,1)*q(j,2)*q(i,3)
28554 
28555 C...Only allow fraction of recoupling for GH, intermediate and
28556 C...instantaneous.
28557  IF(mstp(115).EQ.5.OR.mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
28558  IF(pyr(0).GT.parp(120)) RETURN
28559  ENDIF
28560  isub=mint(1)
28561 
28562 C...Common part for scenarios I, II, II', and GH.
28563  IF(mstp(115).EQ.1.OR.mstp(115).EQ.2.OR.mstp(115).EQ.3.OR.
28564  &mstp(115).EQ.5) THEN
28565 
28566 C...Read out frequently-used parameters.
28567  pi=paru(1)
28568  hbar=paru(3)
28569  pmw=pmas(24,1)
28570  IF(isub.EQ.22) pmw=pmas(23,1)
28571  pgw=pmas(24,2)
28572  IF(isub.EQ.22) pgw=pmas(23,2)
28573  tfrag=parp(115)
28574  rhad=parp(116)
28575  fact=parp(117)
28576  blowr=parp(118)
28577  blowt=parp(119)
28578 
28579 C...Find range of decay products of the W's.
28580 C...Background: the W's are stored in IW1 and IW2.
28581 C...Their direct decay products in NSD1+1 through NSD1+4.
28582 C...Products after shower (if any) in NSD1+5 through NAFT1
28583 C...for first W and in NAFT1+1 through N for the second.
28584  IF(naft1.GT.nsd1+4) THEN
28585  nbeg(1)=nsd1+5
28586  nend(1)=naft1
28587  ELSE
28588  nbeg(1)=nsd1+1
28589  nend(1)=nsd1+2
28590  ENDIF
28591  IF(n.GT.naft1) THEN
28592  nbeg(2)=naft1+1
28593  nend(2)=n
28594  ELSE
28595  nbeg(2)=nsd1+3
28596  nend(2)=nsd1+4
28597  ENDIF
28598 
28599 C...Rearrange parton shower products along strings.
28600  nold=n
28601  CALL pyprep(nsd1+1)
28602  IF(mint(51).NE.0) RETURN
28603 
28604 C...Find partons pointing back to W+ and W-; store them with quark
28605 C...end of string first.
28606  nnp=0
28607  nnm=0
28608  isgp=0
28609  isgm=0
28610  DO 120 i=nold+1,n
28611  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 120
28612  IF(iabs(k(i,2)).GE.22) goto 120
28613  IF(k(i,3).GE.nbeg(1).AND.k(i,3).LE.nend(1)) THEN
28614  IF(isgp.EQ.0) isgp=isign(1,k(i,2))
28615  nnp=nnp+1
28616  IF(isgp.EQ.1) THEN
28617  inp(nnp)=i
28618  ELSE
28619  DO 100 i1=nnp,2,-1
28620  inp(i1)=inp(i1-1)
28621  100 CONTINUE
28622  inp(1)=i
28623  ENDIF
28624  IF(k(i,1).EQ.1) isgp=0
28625  ELSEIF(k(i,3).GE.nbeg(2).AND.k(i,3).LE.nend(2)) THEN
28626  IF(isgm.EQ.0) isgm=isign(1,k(i,2))
28627  nnm=nnm+1
28628  IF(isgm.EQ.1) THEN
28629  inm(nnm)=i
28630  ELSE
28631  DO 110 i1=nnm,2,-1
28632  inm(i1)=inm(i1-1)
28633  110 CONTINUE
28634  inm(1)=i
28635  ENDIF
28636  IF(k(i,1).EQ.1) isgm=0
28637  ENDIF
28638  120 CONTINUE
28639 
28640 C...Boost to W+W- rest frame (not strictly needed).
28641  DO 130 j=1,3
28642  beww(j)=(p(iw1,j)+p(iw2,j))/(p(iw1,4)+p(iw2,4))
28643  130 CONTINUE
28644  CALL pyrobo(iw1,iw1,0d0,0d0,-beww(1),-beww(2),-beww(3))
28645  CALL pyrobo(iw2,iw2,0d0,0d0,-beww(1),-beww(2),-beww(3))
28646  CALL pyrobo(nold+1,n,0d0,0d0,-beww(1),-beww(2),-beww(3))
28647 
28648 C...Select decay vertices of W+ and W-.
28649  tp=hbar*(-log(pyr(0)))*p(iw1,4)/
28650  & sqrt((p(iw1,5)**2-pmw**2)**2+(p(iw1,5)**2*pgw/pmw)**2)
28651  tm=hbar*(-log(pyr(0)))*p(iw2,4)/
28652  & sqrt((p(iw2,5)**2-pmw**2)**2+(p(iw2,5)**2*pgw/pmw)**2)
28653  gtmax=max(tp,tm)
28654  DO 140 j=1,3
28655  xp(j)=tp*p(iw1,j)/p(iw1,4)
28656  xm(j)=tm*p(iw2,j)/p(iw2,4)
28657  140 CONTINUE
28658 
28659 C...Begin scenario I specifics.
28660  IF(mstp(115).EQ.1) THEN
28661 
28662 C...Reconstruct velocity and direction of W+ string pieces.
28663  DO 170 iip=1,nnp-1
28664  IF(k(inp(iip),2).LT.0) goto 170
28665  i1=inp(iip)
28666  i2=inp(iip+1)
28667  p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
28668  p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
28669  DO 150 j=1,3
28670  v1(j)=p(i1,j)/p1a
28671  v2(j)=p(i2,j)/p2a
28672  betp(iip,j)=0.5d0*(v1(j)+v2(j))
28673  dirp(iip,j)=v1(j)-v2(j)
28674  150 CONTINUE
28675  betp(iip,4)=1d0/sqrt(1d0-betp(iip,1)**2-betp(iip,2)**2-
28676  & betp(iip,3)**2)
28677  dirl=sqrt(dirp(iip,1)**2+dirp(iip,2)**2+dirp(iip,3)**2)
28678  DO 160 j=1,3
28679  dirp(iip,j)=dirp(iip,j)/dirl
28680  160 CONTINUE
28681  170 CONTINUE
28682 
28683 C...Reconstruct velocity and direction of W- string pieces.
28684  DO 200 iim=1,nnm-1
28685  IF(k(inm(iim),2).LT.0) goto 200
28686  i1=inm(iim)
28687  i2=inm(iim+1)
28688  p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
28689  p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
28690  DO 180 j=1,3
28691  v1(j)=p(i1,j)/p1a
28692  v2(j)=p(i2,j)/p2a
28693  betm(iim,j)=0.5d0*(v1(j)+v2(j))
28694  dirm(iim,j)=v1(j)-v2(j)
28695  180 CONTINUE
28696  betm(iim,4)=1d0/sqrt(1d0-betm(iim,1)**2-betm(iim,2)**2-
28697  & betm(iim,3)**2)
28698  dirl=sqrt(dirm(iim,1)**2+dirm(iim,2)**2+dirm(iim,3)**2)
28699  DO 190 j=1,3
28700  dirm(iim,j)=dirm(iim,j)/dirl
28701  190 CONTINUE
28702  200 CONTINUE
28703 
28704 C...Loop over number of space-time points.
28705  nacc=0
28706  sum=0d0
28707  DO 250 ipt=1,npt
28708 
28709 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28710  r=sqrt(-log(pyr(0)))
28711  phi=2d0*pi*pyr(0)
28712  x=blowr*rhad*r*cos(phi)
28713  y=blowr*rhad*r*sin(phi)
28714  r=sqrt(-log(pyr(0)))
28715  phi=2d0*pi*pyr(0)
28716  z=blowr*rhad*r*cos(phi)
28717  t=gtmax+blowt*sqrt(0.5d0)*tfrag*r*abs(sin(phi))
28718 
28719 C...Reject impossible points. Weight for sample distribution.
28720  IF(t**2-x**2-y**2-z**2.LT.0d0) goto 250
28721  wtsmp=exp(-(x**2+y**2+z**2)/(blowr*rhad)**2)*
28722  & exp(-2d0*(t-gtmax)**2/(blowt*tfrag)**2)
28723 
28724 C...Loop over W+ string pieces and find one with largest weight.
28725  imaxp=0
28726  wtmaxp=1d-10
28727  xd(1)=x-xp(1)
28728  xd(2)=y-xp(2)
28729  xd(3)=z-xp(3)
28730  xd(4)=t-tp
28731  DO 220 iip=1,nnp-1
28732  IF(k(inp(iip),2).LT.0) goto 220
28733  bed=betp(iip,1)*xd(1)+betp(iip,2)*xd(2)+betp(iip,3)*xd(3)
28734  bedg=betp(iip,4)*(betp(iip,4)*bed/(1d0+betp(iip,4))-xd(4))
28735  DO 210 j=1,3
28736  xb(j)=xd(j)+bedg*betp(iip,j)
28737  210 CONTINUE
28738  xb(4)=betp(iip,4)*(xd(4)-bed)
28739  sr2=xb(1)**2+xb(2)**2+xb(3)**2
28740  sz2=(dirp(iip,1)*xb(1)+dirp(iip,2)*xb(2)+
28741  & dirp(iip,3)*xb(3))**2
28742  wtp=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
28743  & tfrag**2)
28744  IF(xb(4)-sqrt(sr2).LT.0d0) wtp=0d0
28745  IF(wtp.GT.wtmaxp) THEN
28746  imaxp=iip
28747  wtmaxp=wtp
28748  ENDIF
28749  220 CONTINUE
28750 
28751 C...Loop over W- string pieces and find one with largest weight.
28752  imaxm=0
28753  wtmaxm=1d-10
28754  xd(1)=x-xm(1)
28755  xd(2)=y-xm(2)
28756  xd(3)=z-xm(3)
28757  xd(4)=t-tm
28758  DO 240 iim=1,nnm-1
28759  IF(k(inm(iim),2).LT.0) goto 240
28760  bed=betm(iim,1)*xd(1)+betm(iim,2)*xd(2)+betm(iim,3)*xd(3)
28761  bedg=betm(iim,4)*(betm(iim,4)*bed/(1d0+betm(iim,4))-xd(4))
28762  DO 230 j=1,3
28763  xb(j)=xd(j)+bedg*betm(iim,j)
28764  230 CONTINUE
28765  xb(4)=betm(iim,4)*(xd(4)-bed)
28766  sr2=xb(1)**2+xb(2)**2+xb(3)**2
28767  sz2=(dirm(iim,1)*xb(1)+dirm(iim,2)*xb(2)+
28768  & dirm(iim,3)*xb(3))**2
28769  wtm=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
28770  & tfrag**2)
28771  IF(xb(4)-sqrt(sr2).LT.0d0) wtm=0d0
28772  IF(wtm.GT.wtmaxm) THEN
28773  imaxm=iim
28774  wtmaxm=wtm
28775  ENDIF
28776  240 CONTINUE
28777 
28778 C...Result of integration.
28779  wt=0d0
28780  IF(imaxp.NE.0.AND.imaxm.NE.0) THEN
28781  wt=wtmaxp*wtmaxm/wtsmp
28782  sum=sum+wt
28783  nacc=nacc+1
28784  iap(nacc)=imaxp
28785  iam(nacc)=imaxm
28786  wta(nacc)=wt
28787  ENDIF
28788  250 CONTINUE
28789  res=blowr**3*blowt*sum/npt
28790 
28791 C...Decide whether to reconnect and, if so, where.
28792  iacc=0
28793  prec=1d0-exp(-fact*res)
28794  IF(prec.GT.pyr(0)) THEN
28795  rsum=pyr(0)*sum
28796  DO 260 ia=1,nacc
28797  iacc=ia
28798  rsum=rsum-wta(ia)
28799  IF(rsum.LE.0d0) goto 270
28800  260 CONTINUE
28801  270 iip=iap(iacc)
28802  iim=iam(iacc)
28803  ENDIF
28804 
28805 C...Begin scenario II and II' specifics.
28806  ELSEIF(mstp(115).EQ.2.OR.mstp(115).EQ.3) THEN
28807 
28808 C...Loop through all string pieces, one from W+ and one from W-.
28809  ncross=0
28810  tc(0)=0d0
28811  DO 340 iip=1,nnp-1
28812  IF(k(inp(iip),2).LT.0) goto 340
28813  i1p=inp(iip)
28814  i2p=inp(iip+1)
28815  DO 330 iim=1,nnm-1
28816  IF(k(inm(iim),2).LT.0) goto 330
28817  i1m=inm(iim)
28818  i2m=inm(iim+1)
28819 
28820 C...Find endpoint velocity vectors.
28821  DO 280 j=1,3
28822  v1p(j)=p(i1p,j)/p(i1p,4)
28823  v2p(j)=p(i2p,j)/p(i2p,4)
28824  v1m(j)=p(i1m,j)/p(i1m,4)
28825  v2m(j)=p(i2m,j)/p(i2m,4)
28826  280 CONTINUE
28827 
28828 C...Define q matrix and find t.
28829  DO 290 j=1,3
28830  q(1,j)=v2p(j)-v1p(j)
28831  q(2,j)=-(v2m(j)-v1m(j))
28832  q(3,j)=xp(j)-xm(j)-tp*v1p(j)+tm*v1m(j)
28833  q(4,j)=v1p(j)-v1m(j)
28834  290 CONTINUE
28835  t=-deter(1,2,3)/deter(1,2,4)
28836 
28837 C...Find alpha and beta; i.e. coordinates of crossing point.
28838  s11=q(1,1)*(t-tp)
28839  s12=q(2,1)*(t-tm)
28840  s13=q(3,1)+q(4,1)*t
28841  s21=q(1,2)*(t-tp)
28842  s22=q(2,2)*(t-tm)
28843  s23=q(3,2)+q(4,2)*t
28844  den=s11*s22-s12*s21
28845  alp=(s12*s23-s22*s13)/den
28846  bet=(s21*s13-s11*s23)/den
28847 
28848 C...Check if solution acceptable.
28849  iansw=1
28850  IF(t.LT.gtmax) iansw=0
28851  IF(alp.LT.0d0.OR.alp.GT.1d0) iansw=0
28852  IF(bet.LT.0d0.OR.bet.GT.1d0) iansw=0
28853 
28854 C...Find point of crossing and check that not inconsistent.
28855  DO 300 j=1,3
28856  xpp(j)=xp(j)+(v1p(j)+alp*(v2p(j)-v1p(j)))*(t-tp)
28857  xmm(j)=xm(j)+(v1m(j)+bet*(v2m(j)-v1m(j)))*(t-tm)
28858  300 CONTINUE
28859  d2pm=(xpp(1)-xmm(1))**2+(xpp(2)-xmm(2))**2+
28860  & (xpp(3)-xmm(3))**2
28861  d2p=xpp(1)**2+xpp(2)**2+xpp(3)**2
28862  d2m=xmm(1)**2+xmm(2)**2+xmm(3)**2
28863  IF(d2pm.GT.1d-4*(d2p+d2m)) iansw=-1
28864 
28865 C...Find string eigentimes at crossing.
28866  IF(iansw.EQ.1) THEN
28867  taup=sqrt(max(0d0,(t-tp)**2-(xpp(1)-xp(1))**2-
28868  & (xpp(2)-xp(2))**2-(xpp(3)-xp(3))**2))
28869  taum=sqrt(max(0d0,(t-tm)**2-(xmm(1)-xm(1))**2-
28870  & (xmm(2)-xm(2))**2-(xmm(3)-xm(3))**2))
28871  ELSE
28872  taup=0d0
28873  taum=0d0
28874  ENDIF
28875 
28876 C...Order crossings by time. End loop over crossings.
28877  IF(iansw.EQ.1.AND.ncross.LT.20) THEN
28878  ncross=ncross+1
28879  DO 310 i1=ncross,1,-1
28880  IF(t.GT.tc(i1-1).OR.i1.EQ.1) THEN
28881  ipc(i1)=iip
28882  imc(i1)=iim
28883  tc(i1)=t
28884  tpc(i1)=taup
28885  tmc(i1)=taum
28886  goto 320
28887  ELSE
28888  ipc(i1)=ipc(i1-1)
28889  imc(i1)=imc(i1-1)
28890  tc(i1)=tc(i1-1)
28891  tpc(i1)=tpc(i1-1)
28892  tmc(i1)=tmc(i1-1)
28893  ENDIF
28894  310 CONTINUE
28895  320 CONTINUE
28896  ENDIF
28897  330 CONTINUE
28898  340 CONTINUE
28899 
28900 C...Loop over crossings; find first (if any) acceptable one.
28901  iacc=0
28902  IF(ncross.GE.1) THEN
28903  DO 350 ic=1,ncross
28904  pnfrag=exp(-(tpc(ic)**2+tmc(ic)**2)/tfrag**2)
28905  IF(pnfrag.GT.pyr(0)) THEN
28906 C...Scenario II: only compare with fragmentation time.
28907  IF(mstp(115).EQ.2) THEN
28908  iacc=ic
28909  iip=ipc(iacc)
28910  iim=imc(iacc)
28911  goto 360
28912 C...Scenario II': also require that string length decreases.
28913  ELSE
28914  iip=ipc(ic)
28915  iim=imc(ic)
28916  i1p=inp(iip)
28917  i2p=inp(iip+1)
28918  i1m=inm(iim)
28919  i2m=inm(iim+1)
28920  elold=four(i1p,i2p)*four(i1m,i2m)
28921  elnew=four(i1p,i2m)*four(i1m,i2p)
28922  IF(elnew.LT.elold) THEN
28923  iacc=ic
28924  iip=ipc(iacc)
28925  iim=imc(iacc)
28926  goto 360
28927  ENDIF
28928  ENDIF
28929  ENDIF
28930  350 CONTINUE
28931  360 CONTINUE
28932  ENDIF
28933 
28934 C...Begin scenario GH specifics.
28935  ELSEIF(mstp(115).EQ.5) THEN
28936 
28937 C...Loop through all string pieces, one from W+ and one from W-.
28938  iacc=0
28939  elmin=1d0
28940  DO 380 iip=1,nnp-1
28941  IF(k(inp(iip),2).LT.0) goto 380
28942  i1p=inp(iip)
28943  i2p=inp(iip+1)
28944  DO 370 iim=1,nnm-1
28945  IF(k(inm(iim),2).LT.0) goto 370
28946  i1m=inm(iim)
28947  i2m=inm(iim+1)
28948 
28949 C...Look for largest decrease of (exponent of) Lambda measure.
28950  elold=four(i1p,i2p)*four(i1m,i2m)
28951  elnew=four(i1p,i2m)*four(i1m,i2p)
28952  eldif=elnew/max(1d-10,elold)
28953  IF(eldif.LT.elmin) THEN
28954  iacc=iip+iim
28955  elmin=eldif
28956  ipc(1)=iip
28957  imc(1)=iim
28958  ENDIF
28959  370 CONTINUE
28960  380 CONTINUE
28961  iip=ipc(1)
28962  iim=imc(1)
28963  ENDIF
28964 
28965 C...Common for scenarios I, II, II' and GH: reconnect strings.
28966  IF(iacc.NE.0) THEN
28967  mint(32)=1
28968  njoin=0
28969  DO 390 is=1,nnp+nnm
28970  njoin=njoin+1
28971  IF(is.LE.iip) THEN
28972  i=inp(is)
28973  ELSEIF(is.LE.iip+nnm-iim) THEN
28974  i=inm(is-iip+iim)
28975  ELSEIF(is.LE.iip+nnm) THEN
28976  i=inm(is-iip-nnm+iim)
28977  ELSE
28978  i=inp(is-nnm)
28979  ENDIF
28980  ijoin(njoin)=i
28981  IF(k(i,2).LT.0) THEN
28982  CALL pyjoin(njoin,ijoin)
28983  njoin=0
28984  ENDIF
28985  390 CONTINUE
28986 
28987 C...Restore original event record if no reconnection.
28988  ELSE
28989  DO 400 i=nsd1+1,nold
28990  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
28991  k(i,4)=mod(k(i,4),mstu(5)**2)
28992  k(i,5)=mod(k(i,5),mstu(5)**2)
28993  ENDIF
28994  400 CONTINUE
28995  DO 410 i=nold+1,n
28996  k(k(i,3),1)=3
28997  410 CONTINUE
28998  n=nold
28999  ENDIF
29000 
29001 C...Boost back system.
29002  CALL pyrobo(iw1,iw1,0d0,0d0,beww(1),beww(2),beww(3))
29003  CALL pyrobo(iw2,iw2,0d0,0d0,beww(1),beww(2),beww(3))
29004  IF(n.GT.nold) CALL pyrobo(nold+1,n,0d0,0d0,
29005  & beww(1),beww(2),beww(3))
29006 
29007 C...Common part for intermediate and instantaneous scenarios.
29008  ELSEIF(mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
29009  mint(32)=1
29010 
29011 C...Remove old shower products and reset showering ones.
29012  n=nsd1+4
29013  DO 420 i=nsd1+1,nsd1+4
29014  k(i,1)=3
29015  k(i,4)=mod(k(i,4),mstu(5)**2)
29016  k(i,5)=mod(k(i,5),mstu(5)**2)
29017  420 CONTINUE
29018 
29019 C...Identify quark-antiquark pairs.
29020  iq1=nsd1+1
29021  iq2=nsd1+2
29022  iq3=nsd1+3
29023  IF(k(iq1,2)*k(iq3,2).LT.0) iq3=nsd1+4
29024  iq4=2*nsd1+7-iq3
29025 
29026 C...Reconnect strings.
29027  ijoin(1)=iq1
29028  ijoin(2)=iq4
29029  CALL pyjoin(2,ijoin)
29030  ijoin(1)=iq3
29031  ijoin(2)=iq2
29032  CALL pyjoin(2,ijoin)
29033 
29034 C...Do new parton showers in intermediate scenario.
29035  IF(mstp(71).GE.1.AND.mstp(115).EQ.11) THEN
29036  mstj50=mstj(50)
29037  mstj(50)=0
29038  CALL pyshow(iq1,iq2,p(iw1,5))
29039  CALL pyshow(iq3,iq4,p(iw2,5))
29040  mstj(50)=mstj50
29041 
29042 C...Do new parton showers in instantaneous scenario.
29043  ELSEIF(mstp(71).GE.1.AND.mstp(115).EQ.12) THEN
29044  ppm2=(p(iq1,4)+p(iq4,4))**2-(p(iq1,1)+p(iq4,1))**2-
29045  & (p(iq1,2)+p(iq4,2))**2-(p(iq1,3)+p(iq4,3))**2
29046  ppm=sqrt(max(0d0,ppm2))
29047  CALL pyshow(iq1,iq4,ppm)
29048  ppm2=(p(iq3,4)+p(iq2,4))**2-(p(iq3,1)+p(iq2,1))**2-
29049  & (p(iq3,2)+p(iq2,2))**2-(p(iq3,3)+p(iq2,3))**2
29050  ppm=sqrt(max(0d0,ppm2))
29051  CALL pyshow(iq3,iq2,ppm)
29052  ENDIF
29053  ENDIF
29054 
29055  RETURN
29056  END
29057 
29058 C***********************************************************************
29059 
29060 C...PYKLIM
29061 C...Checks generated variables against pre-set kinematical limits;
29062 C...also calculates limits on variables used in generation.
29063 
29064  SUBROUTINE pyklim(ILIM)
29065 
29066 C...Double precision and integer declarations.
29067  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29068  IMPLICIT INTEGER(i-n)
29069  INTEGER pyk,pychge,pycomp
29070 C...Commonblocks.
29071  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
29072  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29073  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29074  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
29075  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
29076  common/pypars/mstp(200),parp(200),msti(200),pari(200)
29077  common/pyint1/mint(400),vint(400)
29078  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
29079  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
29080  &/pyint1/,/pyint2/
29081 
29082 C...Common kinematical expressions.
29083  mint(51)=0
29084  isub=mint(1)
29085  istsb=iset(isub)
29086  IF(isub.EQ.96) goto 100
29087  sqm3=vint(63)
29088  sqm4=vint(64)
29089  IF(ilim.NE.0) THEN
29090  IF(abs(sqm3).LT.1d-4.AND.abs(sqm4).LT.1d-4) THEN
29091  ckin09=max(ckin(9),ckin(13))
29092  ckin10=min(ckin(10),ckin(14))
29093  ckin11=max(ckin(11),ckin(15))
29094  ckin12=min(ckin(12),ckin(16))
29095  ELSE
29096  ckin09=max(ckin(9),min(0d0,ckin(13)))
29097  ckin10=min(ckin(10),max(0d0,ckin(14)))
29098  ckin11=max(ckin(11),min(0d0,ckin(15)))
29099  ckin12=min(ckin(12),max(0d0,ckin(16)))
29100  ENDIF
29101  ENDIF
29102  IF(ilim.NE.1) THEN
29103  tau=vint(21)
29104  rm3=sqm3/(tau*vint(2))
29105  rm4=sqm4/(tau*vint(2))
29106  be34=sqrt(max(1d-20,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
29107  ENDIF
29108  pthmin=ckin(3)
29109  IF(min(sqm3,sqm4).LT.ckin(6)**2.AND.istsb.NE.1.AND.istsb.NE.3)
29110  &pthmin=max(ckin(3),ckin(5))
29111 
29112  IF(ilim.EQ.0) THEN
29113 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
29114 C...pre-set kinematical limits.
29115  yst=vint(22)
29116  cth=vint(23)
29117  taup=vint(26)
29118  taue=tau
29119  IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
29120  x1=sqrt(taue)*exp(yst)
29121  x2=sqrt(taue)*exp(-yst)
29122  xf=x1-x2
29123  IF(mint(47).NE.1) THEN
29124  IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1
29125  IF(ckin(2).GE.0d0.AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1
29126  IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1
29127  IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1
29128  ENDIF
29129  IF(mint(45).NE.1) THEN
29130  IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1
29131  ENDIF
29132  IF(mint(46).NE.1) THEN
29133  IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1
29134  ENDIF
29135  IF(mint(45).EQ.2) THEN
29136  IF(x1.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
29137  ENDIF
29138  IF(mint(46).EQ.2) THEN
29139  IF(x2.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
29140  ENDIF
29141  IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
29142  pth=0.5d0*be34*sqrt(tau*vint(2)*max(0d0,1d0-cth**2))
29143  expy3=max(1d-20,(1d0+rm3-rm4+be34*cth)/
29144  & max(1d-20,(1d0+rm3-rm4-be34*cth)))
29145  expy4=max(1d-20,(1d0-rm3+rm4-be34*cth)/
29146  & max(1d-20,(1d0-rm3+rm4+be34*cth)))
29147  y3=yst+0.5d0*log(expy3)
29148  y4=yst+0.5d0*log(expy4)
29149  ylarge=max(y3,y4)
29150  ysmall=min(y3,y4)
29151  etalar=20d0
29152  etasma=-20d0
29153  sth=sqrt(max(0d0,1d0-cth**2))
29154  exsq3=sqrt(max(1d-20,((1d0+rm3-rm4)*cosh(yst)+be34*sinh(yst)*
29155  & cth)**2-4d0*rm3))
29156  exsq4=sqrt(max(1d-20,((1d0-rm3+rm4)*cosh(yst)-be34*sinh(yst)*
29157  & cth)**2-4d0*rm4))
29158  IF(sth.GE.1d-10) THEN
29159  expet3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+exsq3)/
29160  & (be34*sth)
29161  expet4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+exsq4)/
29162  & (be34*sth)
29163  eta3=log(min(1d10,max(1d-10,expet3)))
29164  eta4=log(min(1d10,max(1d-10,expet4)))
29165  etalar=max(eta3,eta4)
29166  etasma=min(eta3,eta4)
29167  ENDIF
29168  cts3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/exsq3
29169  cts4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/exsq4
29170  ctslar=min(1d0,max(-1d0,cts3,cts4))
29171  ctssma=max(-1d0,min(1d0,cts3,cts4))
29172  sh=tau*vint(2)
29173  rpts=4d0*vint(71)**2/sh
29174  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
29175  rm34=max(1d-20,2d0*rm3*rm4)
29176  IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
29177  & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
29178  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
29179  tha=0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)
29180  uha=0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
29181  IF(pth.LT.pthmin) mint(51)=1
29182  IF(ckin(4).GE.0d0.AND.pth.GT.ckin(4)) mint(51)=1
29183  IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1
29184  IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1
29185  IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1
29186  IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1
29187  IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1
29188  IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1
29189  IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1
29190  IF(tha.LT.ckin(35)) mint(51)=1
29191  IF(ckin(36).GE.0d0.AND.tha.GT.ckin(36)) mint(51)=1
29192  IF(uha.LT.ckin(37)) mint(51)=1
29193  IF(ckin(38).GE.0d0.AND.uha.GT.ckin(38)) mint(51)=1
29194  ENDIF
29195  IF(istsb.GE.3.AND.istsb.LE.5) THEN
29196  IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1
29197  IF(ckin(32).GE.0d0.AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1
29198  ENDIF
29199 
29200 C...Additional cuts on W2 (approximately) in DIS.
29201  IF(isub.EQ.10.AND.mint(43).GE.2) THEN
29202  xbj=x2
29203  IF(iabs(mint(12)).LT.20) xbj=x1
29204  q2bj=tha
29205  w2bj=q2bj*(1d0-xbj)/xbj
29206  IF(w2bj.LT.ckin(39)) mint(51)=1
29207  IF(ckin(40).GT.0d0.AND.w2bj.GT.ckin(40)) mint(51)=1
29208  ENDIF
29209 
29210  ELSEIF(ilim.EQ.1) THEN
29211 C...Calculate limits on tau
29212 C...0) due to definition
29213  taumn0=0d0
29214  taumx0=1d0
29215 C...1) due to limits on subsystem mass
29216  taumn1=ckin(1)**2/vint(2)
29217  taumx1=1d0
29218  IF(ckin(2).GE.0d0) taumx1=ckin(2)**2/vint(2)
29219 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
29220  tm3=sqrt(sqm3+pthmin**2)
29221  tm4=sqrt(sqm4+pthmin**2)
29222  ydcosh=1d0
29223  IF(ckin09.GT.ckin12) ydcosh=cosh(ckin09-ckin12)
29224  taumn2=(tm3**2+2d0*tm3*tm4*ydcosh+tm4**2)/vint(2)
29225  taumx2=1d0
29226 C...3) due to limits on pT-hat and cos(theta-hat)
29227  cth2mn=min(ckin(27)**2,ckin(28)**2)
29228  cth2mx=max(ckin(27)**2,ckin(28)**2)
29229  taumn3=0d0
29230  IF(ckin(27)*ckin(28).GT.0d0) taumn3=
29231  & (sqrt(sqm3+pthmin**2/(1d0-cth2mn))+
29232  & sqrt(sqm4+pthmin**2/(1d0-cth2mn)))**2/vint(2)
29233  taumx3=1d0
29234  IF(ckin(4).GE.0d0.AND.cth2mx.LT.1d0) taumx3=
29235  & (sqrt(sqm3+ckin(4)**2/(1d0-cth2mx))+
29236  & sqrt(sqm4+ckin(4)**2/(1d0-cth2mx)))**2/vint(2)
29237 C...4) due to limits on x1 and x2
29238  taumn4=ckin(21)*ckin(23)
29239  taumx4=ckin(22)*ckin(24)
29240 C...5) due to limits on xF
29241  taumn5=0d0
29242  taumx5=max(1d0-ckin(25),1d0+ckin(26))
29243 C...6) due to limits on that and uhat
29244  taumn6=(sqm3+sqm4+ckin(35)+ckin(37))/vint(2)
29245  taumx6=1d0
29246  IF(ckin(36).GT.0d0.AND.ckin(38).GT.0d0) taumx6=
29247  & (sqm3+sqm4+ckin(36)+ckin(38))/vint(2)
29248 
29249 C...Net effect of all separate limits.
29250  vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5,taumn6)
29251  vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5,taumx6)
29252  IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
29253  vint(11)=1d0-1d-9
29254  vint(31)=1d0+1d-9
29255  ELSEIF(mint(47).EQ.5) THEN
29256  vint(31)=min(vint(31),1d0-2d-10)
29257  ELSEIF(mint(47).GE.6) THEN
29258  vint(31)=min(vint(31),1d0-1d-10)
29259  ENDIF
29260  IF(vint(31).LE.vint(11)) mint(51)=1
29261 
29262  ELSEIF(ilim.EQ.2) THEN
29263 C...Calculate limits on y*
29264  taue=tau
29265  IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
29266  taurt=sqrt(taue)
29267 C...0) due to kinematics
29268  ystmn0=log(taurt)
29269  ystmx0=-ystmn0
29270 C...1) due to explicit limits
29271  ystmn1=ckin(7)
29272  ystmx1=ckin(8)
29273 C...2) due to limits on x1
29274  ystmn2=log(max(taue,ckin(21))/taurt)
29275  ystmx2=log(max(taue,ckin(22))/taurt)
29276 C...3) due to limits on x2
29277  ystmn3=-log(max(taue,ckin(24))/taurt)
29278  ystmx3=-log(max(taue,ckin(23))/taurt)
29279 C...4) due to limits on xF
29280  yepmn4=0.5d0*abs(ckin(25))/taurt
29281  ystmn4=sign(log(max(1d-20,sqrt(1d0+yepmn4**2)+yepmn4)),ckin(25))
29282  yepmx4=0.5d0*abs(ckin(26))/taurt
29283  ystmx4=sign(log(max(1d-20,sqrt(1d0+yepmx4**2)+yepmx4)),ckin(26))
29284 C...5) due to simultaneous limits on y-large and y-small
29285  yepsmn=(rm3-rm4)*sinh(ckin09-ckin11)
29286  yepsmx=(rm3-rm4)*sinh(ckin10-ckin12)
29287  ydifmn=abs(log(max(1d-20,sqrt(1d0+yepsmn**2)-yepsmn)))
29288  ydifmx=abs(log(max(1d-20,sqrt(1d0+yepsmx**2)-yepsmx)))
29289  ystmn5=0.5d0*(ckin09+ckin11-ydifmn)
29290  ystmx5=0.5d0*(ckin10+ckin12+ydifmx)
29291 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
29292 C... y-small
29293  cthlim=sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*taue*vint(2))))
29294  rzmn=be34*max(ckin(27),-cthlim)
29295  rzmx=be34*min(ckin(28),cthlim)
29296  yex3mx=(1d0+rm3-rm4+rzmx)/max(1d-10,1d0+rm3-rm4-rzmx)
29297  yex4mx=(1d0+rm4-rm3-rzmn)/max(1d-10,1d0+rm4-rm3+rzmn)
29298  yex3mn=max(1d-10,1d0+rm3-rm4+rzmn)/(1d0+rm3-rm4-rzmn)
29299  yex4mn=max(1d-10,1d0+rm4-rm3-rzmx)/(1d0+rm4-rm3+rzmx)
29300  ystmn6=ckin09-0.5d0*log(max(yex3mx,yex4mx))
29301  ystmx6=ckin12-0.5d0*log(min(yex3mn,yex4mn))
29302 
29303 C...Net effect of all separate limits.
29304  vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)
29305  vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)
29306  IF(mint(47).EQ.1) THEN
29307  vint(12)=-1d-9
29308  vint(32)=1d-9
29309  ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
29310  vint(12)=(1d0-1d-9)*ystmx0
29311  vint(32)=(1d0+1d-9)*ystmx0
29312  ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
29313  vint(12)=-(1d0+1d-9)*ystmx0
29314  vint(32)=-(1d0-1d-9)*ystmx0
29315  ELSEIF(mint(47).EQ.5) THEN
29316  ystee=log((1d0-1d-10)/taurt)
29317  vint(12)=max(vint(12),-ystee)
29318  vint(32)=min(vint(32),ystee)
29319  ENDIF
29320  IF(vint(32).LE.vint(12)) mint(51)=1
29321 
29322  ELSEIF(ilim.EQ.3) THEN
29323 C...Calculate limits on cos(theta-hat)
29324  yst=vint(22)
29325 C...0) due to definition
29326  ctnmn0=-1d0
29327  ctnmx0=0d0
29328  ctpmn0=0d0
29329  ctpmx0=1d0
29330 C...1) due to explicit limits
29331  ctnmn1=min(0d0,ckin(27))
29332  ctnmx1=min(0d0,ckin(28))
29333  ctpmn1=max(0d0,ckin(27))
29334  ctpmx1=max(0d0,ckin(28))
29335 C...2) due to limits on pT-hat
29336  ctnmn2=-sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*tau*vint(2))))
29337  ctpmx2=-ctnmn2
29338  ctnmx2=0d0
29339  ctpmn2=0d0
29340  IF(ckin(4).GE.0d0) THEN
29341  ctnmx2=-sqrt(max(0d0,1d0-4d0*ckin(4)**2/
29342  & (be34**2*tau*vint(2))))
29343  ctpmn2=-ctnmx2
29344  ENDIF
29345 C...3) due to limits on y-large and y-small
29346  ctnmn3=min(0d0,max((1d0+rm3-rm4)/be34*tanh(ckin11-yst),
29347  & -(1d0-rm3+rm4)/be34*tanh(ckin10-yst)))
29348  ctnmx3=min(0d0,(1d0+rm3-rm4)/be34*tanh(ckin12-yst),
29349  & -(1d0-rm3+rm4)/be34*tanh(ckin09-yst))
29350  ctpmn3=max(0d0,(1d0+rm3-rm4)/be34*tanh(ckin09-yst),
29351  & -(1d0-rm3+rm4)/be34*tanh(ckin12-yst))
29352  ctpmx3=max(0d0,min((1d0+rm3-rm4)/be34*tanh(ckin10-yst),
29353  & -(1d0-rm3+rm4)/be34*tanh(ckin11-yst)))
29354 C...4) due to limits on that
29355  ctnmn4=-1d0
29356  ctnmx4=0d0
29357  ctpmn4=0d0
29358  ctpmx4=1d0
29359  sh=tau*vint(2)
29360  IF(ckin(35).GT.0d0) THEN
29361  ctlim=(1d0-rm3-rm4-2d0*ckin(35)/sh)/be34
29362  IF(ctlim.GT.0d0) THEN
29363  ctpmx4=ctlim
29364  ELSE
29365  ctpmx4=0d0
29366  ctnmx4=ctlim
29367  ENDIF
29368  ENDIF
29369  IF(ckin(36).GT.0d0) THEN
29370  ctlim=(1d0-rm3-rm4-2d0*ckin(36)/sh)/be34
29371  IF(ctlim.LT.0d0) THEN
29372  ctnmn4=ctlim
29373  ELSE
29374  ctnmn4=0d0
29375  ctpmn4=ctlim
29376  ENDIF
29377  ENDIF
29378 C...5) due to limits on uhat
29379  ctnmn5=-1d0
29380  ctnmx5=0d0
29381  ctpmn5=0d0
29382  ctpmx5=1d0
29383  IF(ckin(37).GT.0d0) THEN
29384  ctlim=(2d0*ckin(37)/sh-(1d0-rm3-rm4))/be34
29385  IF(ctlim.LT.0d0) THEN
29386  ctnmn5=ctlim
29387  ELSE
29388  ctnmn5=0d0
29389  ctpmn5=ctlim
29390  ENDIF
29391  ENDIF
29392  IF(ckin(38).GT.0d0) THEN
29393  ctlim=(2d0*ckin(38)/sh-(1d0-rm3-rm4))/be34
29394  IF(ctlim.GT.0d0) THEN
29395  ctpmx5=ctlim
29396  ELSE
29397  ctpmx5=0d0
29398  ctnmx5=ctlim
29399  ENDIF
29400  ENDIF
29401 
29402 C...Net effect of all separate limits.
29403  vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3,ctnmn4,ctnmn5)
29404  vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3,ctnmx4,ctnmx5)
29405  vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3,ctpmn4,ctpmn5)
29406  vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3,ctpmx4,ctpmx5)
29407  IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1
29408 
29409  IF(vint(14).GT.vint(34)) vint(34)=vint(14)
29410  IF(vint(13).GT.vint(33)) vint(33)=vint(13)
29411 
29412  ELSEIF(ilim.EQ.4) THEN
29413 C...Calculate limits on tau'
29414 C...0) due to kinematics
29415  tapmn0=tau
29416  IF(istsb.EQ.5.AND.vint(201).GT.0d0) THEN
29417  pqrat=(vint(201)+vint(206))/vint(1)
29418  tapmn0=(sqrt(tau)+pqrat)**2
29419  ENDIF
29420  tapmx0=1d0
29421 C...1) due to explicit limits
29422  tapmn1=ckin(31)**2/vint(2)
29423  tapmx1=1d0
29424  IF(ckin(32).GE.0d0) tapmx1=ckin(32)**2/vint(2)
29425 
29426 C...Net effect of all separate limits.
29427  vint(16)=max(tapmn0,tapmn1)
29428  vint(36)=min(tapmx0,tapmx1)
29429  IF(mint(47).EQ.1) THEN
29430  vint(16)=1d0-1d-9
29431  vint(36)=1d0+1d-9
29432  ELSEIF(mint(47).EQ.5) THEN
29433  vint(36)=min(vint(36),1d0-2d-10)
29434  ELSEIF(mint(47).EQ.6.OR.mint(47).EQ.7) THEN
29435  vint(36)=min(vint(36),1d0-1d-10)
29436  ENDIF
29437  IF(vint(36).LE.vint(16)) mint(51)=1
29438 
29439  ENDIF
29440  RETURN
29441 
29442 C...Special case for low-pT and multiple interactions:
29443 C...effective kinematical limits for tau, y*, cos(theta-hat).
29444  100 IF(ilim.EQ.0) THEN
29445  ELSEIF(ilim.EQ.1) THEN
29446  IF(mstp(82).LE.1) THEN
29447  vint(11)=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
29448  & vint(2)
29449  ELSE
29450  vint(11)=(parp(82)*(vint(1)/parp(89))**parp(90))**2/vint(2)
29451  ENDIF
29452  vint(31)=1d0
29453  ELSEIF(ilim.EQ.2) THEN
29454  vint(12)=0.5d0*log(vint(21))
29455  vint(32)=-vint(12)
29456  ELSEIF(ilim.EQ.3) THEN
29457  IF(mstp(82).LE.1) THEN
29458  st2eff=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
29459  & (vint(21)*vint(2))
29460  ELSE
29461  st2eff=0.01d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
29462  & (vint(21)*vint(2))
29463  ENDIF
29464  vint(13)=-sqrt(max(0d0,1d0-st2eff))
29465  vint(33)=0d0
29466  vint(14)=0d0
29467  vint(34)=-vint(13)
29468  ENDIF
29469 
29470  RETURN
29471  END
29472 
29473 C*********************************************************************
29474 
29475 C...PYKMAP
29476 C...Maps a uniform distribution into a distribution of a kinematical
29477 C...variable according to one of the possibilities allowed. It is
29478 C...assumed that kinematical limits have been set by a PYKLIM call.
29479 
29480  SUBROUTINE pykmap(IVAR,MVAR,VVAR)
29481 
29482 C...Double precision and integer declarations.
29483  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29484  IMPLICIT INTEGER(i-n)
29485  INTEGER pyk,pychge,pycomp
29486 C...Commonblocks.
29487  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29488  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29489  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
29490  common/pypars/mstp(200),parp(200),msti(200),pari(200)
29491  common/pyint1/mint(400),vint(400)
29492  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
29493  SAVE /pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,/pyint2/
29494 
29495 C...Convert VVAR to tau variable.
29496  isub=mint(1)
29497  istsb=iset(isub)
29498  IF(ivar.EQ.1) THEN
29499  taumin=vint(11)
29500  taumax=vint(31)
29501  IF(mvar.EQ.3.OR.mvar.EQ.4) THEN
29502  taure=vint(73)
29503  gamre=vint(74)
29504  ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN
29505  taure=vint(75)
29506  gamre=vint(76)
29507  ELSEIF(mvar.EQ.8.OR.mvar.EQ.9) THEN
29508  taure=vint(77)
29509  gamre=vint(78)
29510  ENDIF
29511  IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
29512  tau=1d0
29513  ELSEIF(mvar.EQ.1) THEN
29514  tau=taumin*(taumax/taumin)**vvar
29515  ELSEIF(mvar.EQ.2) THEN
29516  tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)
29517  ELSEIF(mvar.EQ.3.OR.mvar.EQ.5.OR.mvar.EQ.8) THEN
29518  ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax
29519  tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin)
29520  ELSEIF(mvar.EQ.4.OR.mvar.EQ.6.OR.mvar.EQ.9) THEN
29521  aupp=atan((taumax-taure)/gamre)
29522  alow=atan((taumin-taure)/gamre)
29523  tau=taure+gamre*tan(alow+(aupp-alow)*vvar)
29524  ELSEIF(mint(47).EQ.5) THEN
29525  aupp=log(max(2d-10,1d0-taumax))
29526  alow=log(max(2d-10,1d0-taumin))
29527  tau=1d0-exp(aupp+vvar*(alow-aupp))
29528  ELSE
29529  aupp=log(max(1d-10,1d0-taumax))
29530  alow=log(max(1d-10,1d0-taumin))
29531  tau=1d0-exp(aupp+vvar*(alow-aupp))
29532  ENDIF
29533  vint(21)=min(taumax,max(taumin,tau))
29534 
29535 C...Convert VVAR to y* variable.
29536  ELSEIF(ivar.EQ.2) THEN
29537  ystmin=vint(12)
29538  ystmax=vint(32)
29539  taue=vint(21)
29540  IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
29541  IF(mint(47).EQ.1) THEN
29542  yst=0d0
29543  ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
29544  yst=-0.5d0*log(taue)
29545  ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
29546  yst=0.5d0*log(taue)
29547  ELSEIF(mvar.EQ.1) THEN
29548  yst=ystmin+(ystmax-ystmin)*sqrt(vvar)
29549  ELSEIF(mvar.EQ.2) THEN
29550  yst=ystmax-(ystmax-ystmin)*sqrt(1d0-vvar)
29551  ELSEIF(mvar.EQ.3) THEN
29552  aupp=atan(exp(ystmax))
29553  alow=atan(exp(ystmin))
29554  yst=log(tan(alow+(aupp-alow)*vvar))
29555  ELSEIF(mvar.EQ.4) THEN
29556  yst0=-0.5d0*log(taue)
29557  aupp=log(max(1d-10,exp(yst0-ystmin)-1d0))
29558  alow=log(max(1d-10,exp(yst0-ystmax)-1d0))
29559  yst=yst0-log(1d0+exp(alow+vvar*(aupp-alow)))
29560  ELSE
29561  yst0=-0.5d0*log(taue)
29562  aupp=log(max(1d-10,exp(yst0+ystmin)-1d0))
29563  alow=log(max(1d-10,exp(yst0+ystmax)-1d0))
29564  yst=log(1d0+exp(aupp+vvar*(alow-aupp)))-yst0
29565  ENDIF
29566  vint(22)=min(ystmax,max(ystmin,yst))
29567 
29568 C...Convert VVAR to cos(theta-hat) variable.
29569  ELSEIF(ivar.EQ.3) THEN
29570  rm34=max(1d-20,2d0*vint(63)*vint(64)/(vint(21)*vint(2))**2)
29571  rsqm=1d0+rm34
29572  IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
29573  & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
29574  ctnmin=vint(13)
29575  ctnmax=vint(33)
29576  ctpmin=vint(14)
29577  ctpmax=vint(34)
29578  IF(mvar.EQ.1) THEN
29579  aneg=ctnmax-ctnmin
29580  apos=ctpmax-ctpmin
29581  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
29582  vctn=vvar*(aneg+apos)/aneg
29583  cth=ctnmin+(ctnmax-ctnmin)*vctn
29584  ELSE
29585  vctp=(vvar*(aneg+apos)-aneg)/apos
29586  cth=ctpmin+(ctpmax-ctpmin)*vctp
29587  ENDIF
29588  ELSEIF(mvar.EQ.2) THEN
29589  rmnmin=max(rm34,rsqm-ctnmin)
29590  rmnmax=max(rm34,rsqm-ctnmax)
29591  rmpmin=max(rm34,rsqm-ctpmin)
29592  rmpmax=max(rm34,rsqm-ctpmax)
29593  aneg=log(rmnmin/rmnmax)
29594  apos=log(rmpmin/rmpmax)
29595  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
29596  vctn=vvar*(aneg+apos)/aneg
29597  cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn
29598  ELSE
29599  vctp=(vvar*(aneg+apos)-aneg)/apos
29600  cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp
29601  ENDIF
29602  ELSEIF(mvar.EQ.3) THEN
29603  rmnmin=max(rm34,rsqm+ctnmin)
29604  rmnmax=max(rm34,rsqm+ctnmax)
29605  rmpmin=max(rm34,rsqm+ctpmin)
29606  rmpmax=max(rm34,rsqm+ctpmax)
29607  aneg=log(rmnmax/rmnmin)
29608  apos=log(rmpmax/rmpmin)
29609  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
29610  vctn=vvar*(aneg+apos)/aneg
29611  cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm
29612  ELSE
29613  vctp=(vvar*(aneg+apos)-aneg)/apos
29614  cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm
29615  ENDIF
29616  ELSEIF(mvar.EQ.4) THEN
29617  rmnmin=max(rm34,rsqm-ctnmin)
29618  rmnmax=max(rm34,rsqm-ctnmax)
29619  rmpmin=max(rm34,rsqm-ctpmin)
29620  rmpmax=max(rm34,rsqm-ctpmax)
29621  aneg=1d0/rmnmax-1d0/rmnmin
29622  apos=1d0/rmpmax-1d0/rmpmin
29623  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
29624  vctn=vvar*(aneg+apos)/aneg
29625  cth=rsqm-1d0/(1d0/rmnmin+aneg*vctn)
29626  ELSE
29627  vctp=(vvar*(aneg+apos)-aneg)/apos
29628  cth=rsqm-1d0/(1d0/rmpmin+apos*vctp)
29629  ENDIF
29630  ELSEIF(mvar.EQ.5) THEN
29631  rmnmin=max(rm34,rsqm+ctnmin)
29632  rmnmax=max(rm34,rsqm+ctnmax)
29633  rmpmin=max(rm34,rsqm+ctpmin)
29634  rmpmax=max(rm34,rsqm+ctpmax)
29635  aneg=1d0/rmnmin-1d0/rmnmax
29636  apos=1d0/rmpmin-1d0/rmpmax
29637  IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
29638  vctn=vvar*(aneg+apos)/aneg
29639  cth=1d0/(1d0/rmnmin-aneg*vctn)-rsqm
29640  ELSE
29641  vctp=(vvar*(aneg+apos)-aneg)/apos
29642  cth=1d0/(1d0/rmpmin-apos*vctp)-rsqm
29643  ENDIF
29644  ENDIF
29645  IF(cth.LT.0d0) cth=min(ctnmax,max(ctnmin,cth))
29646  IF(cth.GT.0d0) cth=min(ctpmax,max(ctpmin,cth))
29647  vint(23)=cth
29648 
29649 C...Convert VVAR to tau' variable.
29650  ELSEIF(ivar.EQ.4) THEN
29651  tau=vint(21)
29652  taupmn=vint(16)
29653  taupmx=vint(36)
29654  IF(mint(47).EQ.1) THEN
29655  taup=1d0
29656  ELSEIF(mvar.EQ.1) THEN
29657  taup=taupmn*(taupmx/taupmn)**vvar
29658  ELSEIF(mvar.EQ.2) THEN
29659  aupp=(1d0-tau/taupmx)**4
29660  alow=(1d0-tau/taupmn)**4
29661  taup=tau/max(1d-10,1d0-(alow+(aupp-alow)*vvar)**0.25d0)
29662  ELSEIF(mint(47).EQ.5) THEN
29663  aupp=log(max(2d-10,1d0-taupmx))
29664  alow=log(max(2d-10,1d0-taupmn))
29665  taup=1d0-exp(aupp+vvar*(alow-aupp))
29666  ELSE
29667  aupp=log(max(1d-10,1d0-taupmx))
29668  alow=log(max(1d-10,1d0-taupmn))
29669  taup=1d0-exp(aupp+vvar*(alow-aupp))
29670  ENDIF
29671  vint(26)=min(taupmx,max(taupmn,taup))
29672 
29673 C...Selection of extra variables needed in 2 -> 3 process:
29674 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29675 C...Since no options are available, the functions of PYKLIM
29676 C...and PYKMAP are joint for these choices.
29677  ELSEIF(ivar.EQ.5) THEN
29678 
29679 C...Read out total energy and particle masses.
29680  mint(51)=0
29681  mptpk=1
29682  IF(isub.EQ.123.OR.isub.EQ.124.OR.isub.EQ.173.OR.isub.EQ.174
29683  & .OR.isub.EQ.178.OR.isub.EQ.179.OR.isub.EQ.351.OR.isub.EQ.352)
29684  & mptpk=2
29685  shp=vint(26)*vint(2)
29686  shpr=sqrt(shp)
29687  pm1=vint(201)
29688  pm2=vint(206)
29689  pm3=sqrt(vint(21))*vint(1)
29690  IF(pm1+pm2+pm3.GT.0.9999d0*shpr) THEN
29691  mint(51)=1
29692  RETURN
29693  ENDIF
29694  pmrs1=vint(204)**2
29695  pmrs2=vint(209)**2
29696 
29697 C...Specify coefficients of pT choice; upper and lower limits.
29698  IF(mptpk.EQ.1) THEN
29699  hwt1=0.4d0
29700  hwt2=0.4d0
29701  ELSE
29702  hwt1=0.05d0
29703  hwt2=0.05d0
29704  ENDIF
29705  hwt3=1d0-hwt1-hwt2
29706  ptsmx1=((shp-pm1**2-(pm2+pm3)**2)**2-(2d0*pm1*(pm2+pm3))**2)/
29707  & (4d0*shp)
29708  IF(ckin(52).GT.0d0) ptsmx1=min(ptsmx1,ckin(52)**2)
29709  ptsmn1=ckin(51)**2
29710  ptsmx2=((shp-pm2**2-(pm1+pm3)**2)**2-(2d0*pm2*(pm1+pm3))**2)/
29711  & (4d0*shp)
29712  IF(ckin(54).GT.0d0) ptsmx2=min(ptsmx2,ckin(54)**2)
29713  ptsmn2=ckin(53)**2
29714 
29715 C...Select transverse momenta according to
29716 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29717  hmx=pmrs1+ptsmx1
29718  hmn=pmrs1+ptsmn1
29719  IF(hmx.LT.1.0001d0*hmn) THEN
29720  mint(51)=1
29721  RETURN
29722  ENDIF
29723  hde=ptsmx1-ptsmn1
29724  rpt=pyr(0)
29725  IF(rpt.LT.hwt1) THEN
29726  pts1=ptsmn1+pyr(0)*hde
29727  ELSEIF(rpt.LT.hwt1+hwt2) THEN
29728  pts1=max(ptsmn1,hmn*(hmx/hmn)**pyr(0)-pmrs1)
29729  ELSE
29730  pts1=max(ptsmn1,hmn*hmx/(hmn+pyr(0)*hde)-pmrs1)
29731  ENDIF
29732  wtpts1=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs1+pts1))+
29733  & hwt3*hmn*hmx/(pmrs1+pts1)**2)
29734  hmx=pmrs2+ptsmx2
29735  hmn=pmrs2+ptsmn2
29736  IF(hmx.LT.1.0001d0*hmn) THEN
29737  mint(51)=1
29738  RETURN
29739  ENDIF
29740  hde=ptsmx2-ptsmn2
29741  rpt=pyr(0)
29742  IF(rpt.LT.hwt1) THEN
29743  pts2=ptsmn2+pyr(0)*hde
29744  ELSEIF(rpt.LT.hwt1+hwt2) THEN
29745  pts2=max(ptsmn2,hmn*(hmx/hmn)**pyr(0)-pmrs2)
29746  ELSE
29747  pts2=max(ptsmn2,hmn*hmx/(hmn+pyr(0)*hde)-pmrs2)
29748  ENDIF
29749  wtpts2=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs2+pts2))+
29750  & hwt3*hmn*hmx/(pmrs2+pts2)**2)
29751 
29752 C...Select azimuthal angles and check pT choice.
29753  phi1=paru(2)*pyr(0)
29754  phi2=paru(2)*pyr(0)
29755  phir=phi2-phi1
29756  pts3=max(0d0,pts1+pts2+2d0*sqrt(pts1*pts2)*cos(phir))
29757  IF(pts3.LT.ckin(55)**2.OR.(ckin(56).GT.0d0.AND.pts3.GT.
29758  & ckin(56)**2)) THEN
29759  mint(51)=1
29760  RETURN
29761  ENDIF
29762 
29763 C...Calculate transverse masses and check phase space not closed.
29764  pms1=pm1**2+pts1
29765  pms2=pm2**2+pts2
29766  pms3=pm3**2+pts3
29767  pmt1=sqrt(pms1)
29768  pmt2=sqrt(pms2)
29769  pmt3=sqrt(pms3)
29770  pm12=(pmt1+pmt2)**2
29771  IF(pmt1+pmt2+pmt3.GT.0.9999d0*shpr) THEN
29772  mint(51)=1
29773  RETURN
29774  ENDIF
29775 
29776 C...Select rapidity for particle 3 and check phase space not closed.
29777  y3max=log((shp+pms3-pm12+sqrt(max(0d0,(shp-pms3-pm12)**2-
29778  & 4d0*pms3*pm12)))/(2d0*shpr*pmt3))
29779  IF(y3max.LT.1d-6) THEN
29780  mint(51)=1
29781  RETURN
29782  ENDIF
29783  y3=(2d0*pyr(0)-1d0)*0.999999d0*y3max
29784  pz3=pmt3*sinh(y3)
29785  pe3=pmt3*cosh(y3)
29786 
29787 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29788  pz12=-pz3
29789  pe12=shpr-pe3
29790  pms12=pe12**2-pz12**2
29791  sql12=sqrt(max(0d0,(pms12-pms1-pms2)**2-4d0*pms1*pms2))
29792  IF(sql12.LT.1d-6*shp) THEN
29793  mint(51)=1
29794  RETURN
29795  ENDIF
29796  pmm1=pms12+pms1-pms2
29797  pmm2=pms12+pms2-pms1
29798  tfac=-shpr/(2d0*pms12)
29799  t1p=tfac*(pe12-pz12)*(pmm1-sql12)
29800  t1n=tfac*(pe12-pz12)*(pmm1+sql12)
29801  t2p=tfac*(pe12+pz12)*(pmm2-sql12)
29802  t2n=tfac*(pe12+pz12)*(pmm2+sql12)
29803 
29804 C...Construct relative mirror weights and make choice.
29805  IF(mptpk.EQ.1.OR.isub.EQ.351.OR.isub.EQ.352) THEN
29806  wtpu=1d0
29807  wtnu=1d0
29808  ELSE
29809  wtpu=1d0/((t1p-pmrs1)*(t2p-pmrs2))**2
29810  wtnu=1d0/((t1n-pmrs1)*(t2n-pmrs2))**2
29811  ENDIF
29812  wtp=wtpu/(wtpu+wtnu)
29813  wtn=wtnu/(wtpu+wtnu)
29814  eps=1d0
29815  IF(wtn.GT.pyr(0)) eps=-1d0
29816 
29817 C...Store result of variable choice and associated weights.
29818  vint(202)=pts1
29819  vint(207)=pts2
29820  vint(203)=phi1
29821  vint(208)=phi2
29822  vint(205)=wtpts1
29823  vint(210)=wtpts2
29824  vint(211)=y3
29825  vint(212)=y3max
29826  vint(213)=eps
29827  IF(eps.GT.0d0) THEN
29828  vint(214)=1d0/wtp
29829  vint(215)=t1p
29830  vint(216)=t2p
29831  ELSE
29832  vint(214)=1d0/wtn
29833  vint(215)=t1n
29834  vint(216)=t2n
29835  ENDIF
29836  vint(217)=-0.5d0*tfac*(pe12-pz12)*(pmm2+eps*sql12)
29837  vint(218)=-0.5d0*tfac*(pe12+pz12)*(pmm1+eps*sql12)
29838  vint(219)=0.5d0*(pms12-pts3)
29839  vint(220)=sql12
29840  ENDIF
29841 
29842  RETURN
29843  END
29844 
29845 C***********************************************************************
29846 
29847 C...PYSIGH
29848 C...Differential matrix elements for all included subprocesses
29849 C...Note that what is coded is (disregarding the COMFAC factor)
29850 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29851 C...when d(sigma-hat) is given in the zero-width limit, the delta
29852 C...function in tau is replaced by a (modified) Breit-Wigner:
29853 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29854 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29855 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29856 C...i.e., dimensionless quantities
29857 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29858 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29859 C...(2pi)^4 delta^4(P - sum p_i)
29860 C...COMFAC contains the factor pi/s (or equivalent) and
29861 C...the conversion factor from GeV^-2 to mb
29862 
29863  SUBROUTINE pysigh(NCHN,SIGS)
29864 
29865 C...Double precision and integer declarations
29866  IMPLICIT DOUBLE PRECISION(a-h, o-z)
29867  IMPLICIT INTEGER(i-n)
29868  INTEGER pyk,pychge,pycomp
29869 C...Parameter statement to help give large particle numbers.
29870  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
29871  &kexcit=4000000,kdimen=5000000)
29872 C...Commonblocks
29873  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
29874  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29875  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29876  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
29877  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
29878  common/pypars/mstp(200),parp(200),msti(200),pari(200)
29879  common/pyint1/mint(400),vint(400)
29880  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
29881  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
29882  common/pyint4/mwid(500),wids(500,5)
29883  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
29884  common/pyint7/sigt(0:6,0:6,0:5)
29885  common/pymssm/imss(0:99),rmss(0:99)
29886  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
29887  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
29888  common/pytcsm/itcm(0:99),rtcm(0:99)
29889  common/pypued/iued(0:99),rued(0:99)
29890  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
29891  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
29892  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
29893  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
29894  common/pytcco/coefx(194:380,2)
29895  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
29896  &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,
29897  &/pymssm/,/pyssmt/,/pytcsm/,/pypued/,/pysgcm/,/pytcco/
29898 C...Local arrays and complex variables
29899  dimension xpq(-25:25)
29900 
29901 C...Map of processes onto which routine to call
29902 C...in order to evaluate cross section:
29903 C...0 = not implemented;
29904 C...1 = standard QCD (including photons);
29905 C...2 = heavy flavours;
29906 C...3 = W/Z;
29907 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29908 C...5 = SUSY;
29909 C...6 = Technicolor;
29910 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29911 C...8 = Universal Extra Dimensions
29912  dimension mappr(500)
29913  DATA (mappr(i),i=1,180)/
29914  & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29915  1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29916  2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29917  3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29918  4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29919  5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29920  6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29921  7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29922  8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29923  9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29924  & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29925  1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29926  2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29927  3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29928  4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29929  5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29930  6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29931  7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29932  DATA (mappr(i),i=181,500)/
29933  8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29934  9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29935  & 100*5,
29936  & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29937  & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29938  1 20*0,
29939  4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29940  5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29941  6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29942  7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29943  8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29944  9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29945  & 4, 4, 18*0,
29946  2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29947  3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29948  4 20*0,
29949  6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29950  7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29951  8 7, 7, 18*0/
29952 
29953 C...Reset number of channels and cross-section
29954  nchn=0
29955  sigs=0d0
29956 
29957 C...Read process to consider.
29958  isub=mint(1)
29959  isubsv=isub
29960  map=mappr(isub)
29961 
29962 C...Read kinematical variables and limits
29963  istsb=iset(isubsv)
29964  taumin=vint(11)
29965  ystmin=vint(12)
29966  ctnmin=vint(13)
29967  ctpmin=vint(14)
29968  taupmn=vint(16)
29969  tau=vint(21)
29970  yst=vint(22)
29971  cth=vint(23)
29972  xt2=vint(25)
29973  taup=vint(26)
29974  taumax=vint(31)
29975  ystmax=vint(32)
29976  ctnmax=vint(33)
29977  ctpmax=vint(34)
29978  taupmx=vint(36)
29979 
29980 C...Derive kinematical quantities
29981  taue=tau
29982  IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
29983  x(1)=sqrt(taue)*exp(yst)
29984  x(2)=sqrt(taue)*exp(-yst)
29985  IF(mint(45).EQ.2.AND.istsb.GE.1) THEN
29986  IF(x(1).GT.1d0-1d-7) RETURN
29987  ELSEIF(mint(45).EQ.3) THEN
29988  x(1)=min(1d0-1.1d-10,x(1))
29989  ENDIF
29990  IF(mint(46).EQ.2.AND.istsb.GE.1) THEN
29991  IF(x(2).GT.1d0-1d-7) RETURN
29992  ELSEIF(mint(46).EQ.3) THEN
29993  x(2)=min(1d0-1.1d-10,x(2))
29994  ENDIF
29995  sh=max(1d0,tau*vint(2))
29996  sqm3=vint(63)
29997  sqm4=vint(64)
29998  rm3=sqm3/sh
29999  rm4=sqm4/sh
30000  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
30001  rpts=4d0*vint(71)**2/sh
30002  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
30003  rm34=max(1d-20,2d0*rm3*rm4)
30004  rsqm=1d0+rm34
30005  IF(2d0*vint(71)**2/max(1d0,vint(21)*vint(2)).LT.0.0001d0)
30006  &rm34=max(rm34,2d0*vint(71)**2/max(1d0,vint(21)*vint(2)))
30007  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
30008  IF(istsb.EQ.0) THEN
30009  th=vint(45)
30010  uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
30011  sqpth=max(vint(71)**2,0.25d0*sh*be34**2*vint(59)**2)
30012  ELSE
30013 C...Kinematics with incoming masses tricky: now depends on how
30014 C...subprocess has been set up w.r.t. order of incoming partons.
30015  rm1=0d0
30016  IF(mint(15).EQ.22.AND.vint(3).LT.0d0) rm1=-vint(3)**2/sh
30017  rm2=0d0
30018  IF(mint(16).EQ.22.AND.vint(4).LT.0d0) rm2=-vint(4)**2/sh
30019  IF(isub.EQ.35) THEN
30020  rm2=min(rm1,rm2)
30021  rm1=0d0
30022  ENDIF
30023  be12=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
30024  tucom=(1d0-rm1-rm2)*(1d0-rm3-rm4)
30025  th=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm4-2d0*rm2*rm3-
30026  & be12*be34*cth)
30027  uh=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm3-2d0*rm2*rm4+
30028  & be12*be34*cth)
30029  sqpth=max(vint(71)**2,0.25d0*sh*be34**2*(1d0-cth**2))
30030  ENDIF
30031  shr=sqrt(sh)
30032  sh2=sh**2
30033  th2=th**2
30034  uh2=uh**2
30035 
30036 C...Choice of Q2 scale for hard process (e.g. alpha_s).
30037  IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
30038  q2=sh
30039  ELSEIF(istsb.EQ.8) THEN
30040  IF(mint(107).EQ.4) q2=vint(307)
30041  IF(mint(108).EQ.4) q2=vint(308)
30042  ELSEIF(mod(istsb,2).EQ.0.OR.istsb.EQ.9) THEN
30043  q2in1=0d0
30044  IF(mint(11).EQ.22.AND.vint(3).LT.0d0) q2in1=vint(3)**2
30045  q2in2=0d0
30046  IF(mint(12).EQ.22.AND.vint(4).LT.0d0) q2in2=vint(4)**2
30047  IF(mstp(32).EQ.1) THEN
30048  q2=2d0*sh*th*uh/(sh**2+th**2+uh**2)
30049  ELSEIF(mstp(32).EQ.2) THEN
30050  q2=sqpth+0.5d0*(sqm3+sqm4)
30051  ELSEIF(mstp(32).EQ.3) THEN
30052  q2=min(-th,-uh)
30053  ELSEIF(mstp(32).EQ.4) THEN
30054  q2=sh
30055  ELSEIF(mstp(32).EQ.5) THEN
30056  q2=-th
30057  ELSEIF(mstp(32).EQ.6) THEN
30058  xsf1=x(1)
30059  IF(istsb.EQ.9) xsf1=x(1)/vint(143)
30060  xsf2=x(2)
30061  IF(istsb.EQ.9) xsf2=x(2)/vint(144)
30062  q2=(1d0+xsf1*q2in1/sh+xsf2*q2in2/sh)*
30063  & (sqpth+0.5d0*(sqm3+sqm4))
30064  ELSEIF(mstp(32).EQ.7) THEN
30065  q2=(1d0+q2in1/sh+q2in2/sh)*(sqpth+0.5d0*(sqm3+sqm4))
30066  ELSEIF(mstp(32).EQ.8) THEN
30067  q2=sqpth+0.5d0*(q2in1+q2in2+sqm3+sqm4)
30068  ELSEIF(mstp(32).EQ.9) THEN
30069  q2=sqpth+q2in1+q2in2+sqm3+sqm4
30070  ELSEIF(mstp(32).EQ.10) THEN
30071  q2=vint(2)
30072 C..Begin JA 040914
30073  ELSEIF(mstp(32).EQ.11) THEN
30074  q2=0.25*(sqm3+sqm4+2*sqrt(sqm3*sqm4))
30075  ELSEIF(mstp(32).EQ.12) THEN
30076  q2=parp(193)
30077 C..End JA
30078  ELSEIF(mstp(32).EQ.13) THEN
30079  q2=sqpth
30080  ENDIF
30081  IF(mint(35).LE.2.AND.istsb.EQ.9) q2=sqpth
30082  IF(istsb.EQ.9.AND.mstp(82).GE.2) q2=q2+
30083  & (parp(82)*(vint(1)/parp(89))**parp(90))**2
30084  ENDIF
30085 
30086 C...Choice of Q2 scale for parton densities.
30087  q2sf=q2
30088 C..Begin JA 040914
30089  IF(mstp(32).EQ.12.AND.(mod(istsb,2).EQ.0.OR.istsb.EQ.9)
30090  & .OR.mstp(39).EQ.8.AND.(istsb.GE.3.AND.istsb.LE.5))
30091  & q2=parp(194)
30092 C..End JA
30093  IF(istsb.GE.3.AND.istsb.LE.5) THEN
30094  q2sf=pmas(23,1)**2
30095  IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77.OR.isub.EQ.124.OR.
30096  & isub.EQ.174.OR.isub.EQ.179.OR.isub.EQ.351) q2sf=pmas(24,1)**2
30097  IF(isub.EQ.352) q2sf=pmas(pycomp(9900024),1)**2
30098  IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
30099  & isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402) THEN
30100  q2sf=pmas(pycomp(kfpr(isubsv,2)),1)**2
30101  IF(mstp(39).EQ.2) q2sf=
30102  & max(vint(201)**2+vint(202),vint(206)**2+vint(207))
30103  IF(mstp(39).EQ.3) q2sf=sh
30104  IF(mstp(39).EQ.4) q2sf=vint(26)*vint(2)
30105  IF(mstp(39).EQ.5) q2sf=pmas(pycomp(kfpr(isubsv,1)),1)**2
30106 C..Begin JA 040914
30107  IF(mstp(39).EQ.6) q2sf=0.25*(vint(201)+sqrt(sh))**2
30108  IF(mstp(39).EQ.7) q2sf=
30109  & (vint(201)**2+vint(202)+vint(206)**2+vint(207))/2d0
30110  IF(mstp(39).EQ.8) q2sf=parp(193)
30111 C..End JA
30112  ENDIF
30113  ENDIF
30114  IF(mint(35).GE.3.AND.istsb.EQ.9) q2sf=sqpth
30115 
30116  q2ps=q2sf
30117  q2sf=q2sf*parp(34)
30118  IF(mstp(69).GE.1.AND.mint(47).EQ.5) q2sf=vint(2)
30119  IF(mstp(69).GE.2) q2sf=vint(2)
30120 
30121 C...Identify to which class(es) subprocess belongs
30122  ismecr=0
30123  isqcd=0
30124  isjets=0
30125  IF (isubsv.EQ.1.OR.isubsv.EQ.2.OR.isubsv.EQ.3.OR.
30126  & isubsv.EQ.102.OR.isubsv.EQ.141.OR.isubsv.EQ.142.OR.
30127  & isubsv.EQ.144.OR.isubsv.EQ.151.OR.isubsv.EQ.152.OR.
30128  & isubsv.EQ.156.OR.isubsv.EQ.157) ismecr=1
30129  IF (isubsv.EQ.11.OR.isubsv.EQ.12.OR.isubsv.EQ.13.OR.
30130  & isubsv.EQ.28.OR.isubsv.EQ.53.OR.isubsv.EQ.68) isqcd=1
30131  IF ((isubsv.EQ.81.OR.isubsv.EQ.82).AND.mint(55).LE.5) isqcd=1
30132  IF (isubsv.GE.381.AND.isubsv.LE.386) isqcd=1
30133  IF ((isubsv.EQ.387.OR.isubsv.EQ.388).AND.mint(55).LE.5) isqcd=1
30134  IF (istsb.EQ.9) isqcd=1
30135  IF ((isubsv.GE.86.AND.isubsv.LE.89).OR.isubsv.EQ.107.OR.
30136  & (isubsv.GE.14.AND.isubsv.LE.16).OR.(isubsv.GE.29.AND.
30137  & isubsv.LE.32).OR.(isubsv.GE.111.AND.isubsv.LE.113).OR.
30138  & isubsv.EQ.115.OR.(isubsv.GE.183.AND.isubsv.LE.185).OR.
30139  & (isubsv.GE.188.AND.isubsv.LE.190).OR.isubsv.EQ.161.OR.
30140  & isubsv.EQ.167.OR.isubsv.EQ.168.OR.(isubsv.GE.393.AND.
30141  & isubsv.LE.395).OR.(isubsv.GE.421.AND.isubsv.LE.439).OR.
30142  & (isubsv.GE.461.AND.isubsv.LE.479)) isjets=1
30143 C...WBF is special case of ISJETS
30144  IF (isubsv.EQ.5.OR.isubsv.EQ.8.OR.
30145  & (isubsv.GE.71.AND.isubsv.LE.73).OR.
30146  & isubsv.EQ.76.OR.isubsv.EQ.77.OR.
30147  & (isubsv.GE.121.AND.isubsv.LE.124).OR.
30148  & isubsv.EQ.173.OR.isubsv.EQ.174.OR.
30149  & isubsv.EQ.178.OR.isubsv.EQ.179.OR.
30150  & isubsv.EQ.181.OR.isubsv.EQ.182.OR.
30151  & isubsv.EQ.186.OR.isubsv.EQ.187.OR.
30152  & isubsv.EQ.351.OR.isubsv.EQ.352) isjets=2
30153 C...Some processes with photons also belong here.
30154  IF (isubsv.EQ.10.OR.(isubsv.GE.18.AND.isubsv.LE.20).OR.
30155  & (isubsv.GE.33.AND.isubsv.LE.36).OR.isubsv.EQ.54.OR.
30156  & isubsv.EQ.58.OR.isubsv.EQ.69.OR.isubsv.EQ.70.OR.
30157  & isubsv.EQ.80.OR.(isubsv.GE.83.AND.isubsv.LE.85).OR.
30158  & (isubsv.GE.106.AND.isubsv.LE.110).OR.isubsv.EQ.114.OR.
30159  & (isubsv.GE.131.AND.isubsv.LE.140)) isjets=3
30160 
30161 C...Choice of Q2 scale for parton-shower activity.
30162  IF(mstp(22).GE.1.AND.(isub.EQ.10.OR.isub.EQ.83).AND.
30163  &(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
30164  xbj=x(2)
30165  IF(mint(43).EQ.3) xbj=x(1)
30166  IF(mstp(22).EQ.1) THEN
30167  q2ps=-th
30168  ELSEIF(mstp(22).EQ.2) THEN
30169  q2ps=((1d0-xbj)/xbj)*(-th)
30170  ELSEIF(mstp(22).EQ.3) THEN
30171  q2ps=sqrt((1d0-xbj)/xbj)*(-th)
30172  ELSE
30173  q2ps=(1d0-xbj)*max(1d0,-log(xbj))*(-th)
30174  ENDIF
30175  ENDIF
30176 C...For multiple interactions, start from scale defined above
30177 C...For all other QCD or "+jets"-type events, start shower from pThard.
30178  IF (isjets.EQ.1.OR.isqcd.EQ.1.AND.istsb.NE.9) q2ps=sqpth
30179  IF((mstp(68).EQ.1.OR.mstp(68).EQ.3).AND.ismecr.EQ.1) THEN
30180 C...Max shower scale = s for ME corrected processes.
30181 C...(pT-ordering: max pT2 is s/4)
30182  q2ps=vint(2)
30183  IF (mint(35).GE.3) q2ps=q2ps*0.25d0
30184  ELSEIF(mstp(68).GE.2.AND.isqcd.EQ.0.AND.isjets.EQ.0) THEN
30185 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
30186 C...(pT-ordering: max pT2 is s/4)
30187  q2ps=vint(2)
30188  IF (mint(35).GE.3) q2ps=q2ps*0.25d0
30189  ENDIF
30190  IF(mint(35).EQ.2.AND.istsb.EQ.9) q2ps=sqpth
30191 
30192 C...Elastic and diffractive events not associated with scales so set 0.
30193  IF(isubsv.GE.91.AND.isubsv.LE.94) THEN
30194  q2sf=0d0
30195  q2ps=0d0
30196  ENDIF
30197 
30198 C...Store derived kinematical quantities
30199  vint(41)=x(1)
30200  vint(42)=x(2)
30201  vint(44)=sh
30202  vint(43)=sqrt(sh)
30203  vint(45)=th
30204  vint(46)=uh
30205  IF(istsb.NE.8) vint(48)=sqpth
30206  IF(istsb.NE.8) vint(47)=sqrt(sqpth)
30207  vint(50)=taup*vint(2)
30208  vint(49)=sqrt(max(0d0,vint(50)))
30209  vint(52)=q2
30210  vint(51)=sqrt(q2)
30211  vint(54)=q2sf
30212  vint(53)=sqrt(q2sf)
30213  vint(56)=q2ps
30214  vint(55)=sqrt(q2ps)
30215 
30216 C...Set starting scale for multiple interactions
30217  IF (isubsv.EQ.95) THEN
30218  xt2gmx=0d0
30219  ELSEIF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isubsv.NE.11.AND.
30220  & isubsv.NE.12.AND.isubsv.NE.13.AND.isubsv.NE.28.AND.
30221  & isubsv.NE.53.AND.isubsv.NE.68.AND.isubsv.NE.95.AND.
30222  & isubsv.NE.96)) THEN
30223 C...All accessible phase space allowed.
30224  xt2gmx=(1d0-vint(41))*(1d0-vint(42))
30225  ELSE
30226 C...Scale of hard process sets limit.
30227 C...2 -> 1. Limit is tau = x1*x2.
30228 C...2 -> 2. Limit is XT2 for hard process + FS masses.
30229 C...2 -> n > 2. Limit is tau' = tau of outer process.
30230  xt2gmx=vint(25)
30231  IF(istsb.EQ.1) xt2gmx=vint(21)
30232  IF(istsb.EQ.2)
30233  & xt2gmx=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
30234  IF(istsb.GE.3.AND.istsb.LE.5) xt2gmx=vint(26)
30235  ENDIF
30236  vint(62)=0.25d0*xt2gmx*vint(2)
30237  vint(61)=sqrt(max(0d0,vint(62)))
30238 
30239 C...Calculate parton distributions
30240  IF(istsb.LE.0) goto 160
30241  IF(mint(47).GE.2) THEN
30242  DO 110 i=3-min(2,mint(45)),min(2,mint(46))
30243  xsf=x(i)
30244  IF(istsb.EQ.9) xsf=x(i)/vint(142+i)
30245  IF(isub.EQ.99) THEN
30246  IF(mint(140+i).EQ.0) THEN
30247  xsf=vint(309-i)/(vint(2)+vint(309-i)-vint(i+2)**2)
30248  ELSE
30249  xsf=vint(309-i)/(vint(2)+vint(307)+vint(308))
30250  ENDIF
30251  vint(40+i)=xsf
30252  q2sf=vint(309-i)
30253  ENDIF
30254  mint(105)=mint(102+i)
30255  mint(109)=mint(106+i)
30256  vint(120)=vint(2+i)
30257 C...Default is to use standard PDFs, but for interactions after the first
30258 C...in the new multiple-parton-interactions framework, set which side to
30259 C...evaluate the MPI-modified PDFs on.
30260  mint(30)=0
30261  IF (mint(31).GE.1) mint(30)=i
30262  IF(mstp(57).LE.1) THEN
30263  CALL pypdfu(mint(10+i),xsf,q2sf,xpq)
30264  ELSE
30265  CALL pypdfl(mint(10+i),xsf,q2sf,xpq)
30266  ENDIF
30267 C...Safety margin against heavy flavour very close to threshold,
30268 C...e.g. caused by mismatch in c and b masses.
30269  IF(q2sf.LT.1.1*pmas(4,1)**2) THEN
30270  xpq(4)=0d0
30271  xpq(-4)=0d0
30272  ENDIF
30273  IF(q2sf.LT.1.1*pmas(5,1)**2) THEN
30274  xpq(5)=0d0
30275  xpq(-5)=0d0
30276  ENDIF
30277  DO 100 kfl=-25,25
30278  xsfx(i,kfl)=xpq(kfl)
30279  100 CONTINUE
30280  110 CONTINUE
30281  ENDIF
30282 
30283 C...Calculate alpha_em, alpha_strong and K-factor
30284  xw=paru(102)
30285  xwv=xw
30286  IF(mstp(8).GE.2.OR.(isub.GE.71.AND.isub.LE.77)) xw=
30287  &1d0-(pmas(24,1)/pmas(23,1))**2
30288  xw1=1d0-xw
30289  xwc=1d0/(16d0*xw*xw1)
30290  aem=pyalem(q2)
30291  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
30292  IF(mstp(33).NE.3) as=pyalps(parp(34)*q2)
30293  fack=1d0
30294  faca=1d0
30295  IF(mstp(33).EQ.1) THEN
30296  fack=parp(31)
30297  ELSEIF(mstp(33).EQ.2) THEN
30298  fack=parp(31)
30299  faca=parp(32)/parp(31)
30300  ELSEIF(mstp(33).EQ.3) THEN
30301  q2as=parp(33)*q2
30302  IF(istsb.EQ.9.AND.mstp(82).GE.2) q2as=q2as+
30303  & paru(112)*parp(82)*(vint(1)/parp(89))**parp(90)
30304  as=pyalps(q2as)
30305 C...PS (12 Feb 2010)
30306 C...New options MSTP(33) = 10 and 11
30307 C... 10: use K-factor = PARP(32) only for process 96 (MPI)
30308 C... 11: as for 10, but also use K-factor = PARP(31) for other procs
30309  ELSEIF(mstp(33).GE.10) THEN
30310  IF (isub.EQ.96) THEN
30311  fack = parp(32)
30312  ELSEIF (isub.NE.96.AND.mstp(33).EQ.11) THEN
30313  fack = parp(31)
30314  ENDIF
30315  ENDIF
30316  vint(138)=1d0
30317  vint(57)=aem
30318  vint(58)=as
30319 
30320 C...Set flags for allowed reacting partons/leptons
30321  DO 140 i=1,2
30322  DO 120 j=-25,25
30323  kfac(i,j)=0
30324  120 CONTINUE
30325  IF(mint(44+i).EQ.1) THEN
30326  kfac(i,mint(10+i))=1
30327  ELSEIF(mint(40+i).EQ.1.AND.mstp(12).EQ.0) THEN
30328  kfac(i,mint(10+i))=1
30329  kfac(i,22)=1
30330  kfac(i,24)=1
30331  kfac(i,-24)=1
30332  ELSE
30333  DO 130 j=-25,25
30334  kfac(i,j)=kfin(i,j)
30335  IF(iabs(j).GT.mstp(58).AND.iabs(j).LE.10) kfac(i,j)=0
30336  IF(xsfx(i,j).LT.1d-10) kfac(i,j)=0
30337  130 CONTINUE
30338  ENDIF
30339  140 CONTINUE
30340 
30341 C...Lower and upper limit for fermion flavour loops
30342  mmin1=0
30343  mmax1=0
30344  mmin2=0
30345  mmax2=0
30346  DO 150 j=-20,20
30347  IF(kfac(1,-j).EQ.1) mmin1=-j
30348  IF(kfac(1,j).EQ.1) mmax1=j
30349  IF(kfac(2,-j).EQ.1) mmin2=-j
30350  IF(kfac(2,j).EQ.1) mmax2=j
30351  150 CONTINUE
30352  mmina=min(mmin1,mmin2)
30353  mmaxa=max(mmax1,mmax2)
30354 
30355 C...Common resonance mass and width combinations
30356  sqmz=pmas(23,1)**2
30357  sqmw=pmas(24,1)**2
30358  gmmz=pmas(23,1)*pmas(23,2)
30359  gmmw=pmas(24,1)*pmas(24,2)
30360 
30361 C...Polarization factors...implemented so far for W+W-(25)
30362  polr=(1d0+parj(132))*(1d0-parj(131))
30363  poll=(1d0-parj(132))*(1d0+parj(131))
30364  polrr=(1d0+parj(132))*(1d0+parj(131))
30365  polll=(1d0-parj(132))*(1d0-parj(131))
30366 
30367 C...Phase space integral in tau
30368  comfac=paru(1)*paru(5)/vint(2)
30369  IF(mint(41).EQ.2.AND.mint(42).EQ.2) comfac=comfac*fack
30370  IF((mint(47).GE.2.OR.(istsb.GE.3.AND.istsb.LE.5)).AND.
30371  &istsb.NE.8.AND.istsb.NE.9) THEN
30372  atau1=log(taumax/taumin)
30373  atau2=(taumax-taumin)/(taumax*taumin)
30374  h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/tau
30375  IF(mint(72).GE.1) THEN
30376  taur1=vint(73)
30377  gamr1=vint(74)
30378  ataud=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))
30379  atau3=ataud/taur1
30380  IF(ataud.GT.1d-10) h1=h1+
30381  & (atau1/atau3)*coef(isubsv,3)/(tau+taur1)
30382  ataud=atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1)
30383  atau4=ataud/gamr1
30384  IF(ataud.GT.1d-10) h1=h1+
30385  & (atau1/atau4)*coef(isubsv,4)*tau/((tau-taur1)**2+gamr1**2)
30386  ENDIF
30387  IF(mint(72).GE.2) THEN
30388  taur2=vint(75)
30389  gamr2=vint(76)
30390  ataud=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))
30391  atau5=ataud/taur2
30392  IF(ataud.GT.1d-10) h1=h1+
30393  & (atau1/atau5)*coef(isubsv,5)/(tau+taur2)
30394  ataud=atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2)
30395  atau6=ataud/gamr2
30396  IF(ataud.GT.1d-10) h1=h1+
30397  & (atau1/atau6)*coef(isubsv,6)*tau/((tau-taur2)**2+gamr2**2)
30398  ENDIF
30399  IF(mint(72).EQ.3) THEN
30400  taur3=vint(77)
30401  gamr3=vint(78)
30402  ataud=log(taumax/taumin*(taumin+taur3)/(taumax+taur3))
30403  atau50=ataud/taur3
30404  IF(ataud.GT.1d-10) h1=h1+
30405  & (atau1/atau50)*coefx(isubsv,1)/(tau+taur3)
30406  ataud=atan((taumax-taur3)/gamr3)-atan((taumin-taur3)/gamr3)
30407  atau60=ataud/gamr3
30408  IF(ataud.GT.1d-10) h1=h1+
30409  & (atau1/atau60)*coefx(isubsv,2)*tau/((tau-taur3)**2+gamr3**2)
30410  ENDIF
30411  IF(mint(47).EQ.5.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
30412  atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
30413  IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
30414  & max(2d-10,1d0-tau)
30415  ELSEIF(mint(47).GE.6.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
30416  atau7=log(max(1d-10,1d0-taumin)/max(1d-10,1d0-taumax))
30417  IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
30418  & max(1d-10,1d0-tau)
30419  ENDIF
30420  comfac=comfac*atau1/(tau*h1)
30421  ENDIF
30422 
30423 C...Phase space integral in y*
30424  IF((mint(47).EQ.4.OR.mint(47).EQ.5).AND.istsb.NE.8.AND.istsb.NE.9)
30425  &THEN
30426  ayst0=ystmax-ystmin
30427  IF(ayst0.LT.1d-10) THEN
30428  comfac=0d0
30429  ELSE
30430  ayst1=0.5d0*(ystmax-ystmin)**2
30431  ayst2=ayst1
30432  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
30433  h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
30434  & (ayst0/ayst2)*coef(isubsv,9)*(ystmax-yst)+
30435  & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
30436  IF(mint(45).EQ.3) THEN
30437  yst0=-0.5d0*log(taue)
30438  ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
30439  & max(1d-10,exp(yst0-ystmax)-1d0))
30440  IF(ayst4.GT.1d-10) h2=h2+(ayst0/ayst4)*coef(isubsv,11)/
30441  & max(1d-10,1d0-exp(yst-yst0))
30442  ENDIF
30443  IF(mint(46).EQ.3) THEN
30444  yst0=-0.5d0*log(taue)
30445  ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
30446  & max(1d-10,exp(yst0+ystmin)-1d0))
30447  IF(ayst5.GT.1d-10) h2=h2+(ayst0/ayst5)*coef(isubsv,12)/
30448  & max(1d-10,1d0-exp(-yst-yst0))
30449  ENDIF
30450  comfac=comfac*ayst0/h2
30451  ENDIF
30452  ENDIF
30453 
30454 C...2 -> 1 processes: reduction in angular part of phase space integral
30455 C...for case of decaying resonance
30456  acth0=ctnmax-ctnmin+ctpmax-ctpmin
30457  IF((istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5)) THEN
30458  IF(mdcy(pycomp(kfpr(isubsv,1)),1).EQ.1) THEN
30459  IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37.OR.
30460  & kfpr(isub,1).EQ.39) THEN
30461  comfac=comfac*0.5d0*acth0
30462  ELSE
30463  comfac=comfac*0.125d0*(3d0*acth0+ctnmax**3-ctnmin**3+
30464  & ctpmax**3-ctpmin**3)
30465  ENDIF
30466  ENDIF
30467 
30468 C...2 -> 2 processes: angular part of phase space integral
30469  ELSEIF(istsb.EQ.2.OR.istsb.EQ.4) THEN
30470  acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/
30471  & (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))
30472  acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/
30473  & (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))
30474  acth3=1d0/max(rm34,rsqm-ctnmax)-1d0/max(rm34,rsqm-ctnmin)+
30475  & 1d0/max(rm34,rsqm-ctpmax)-1d0/max(rm34,rsqm-ctpmin)
30476  acth4=1d0/max(rm34,rsqm+ctnmin)-1d0/max(rm34,rsqm+ctnmax)+
30477  & 1d0/max(rm34,rsqm+ctpmin)-1d0/max(rm34,rsqm+ctpmax)
30478  h3=coef(isubsv,13)+
30479  & (acth0/acth1)*coef(isubsv,14)/max(rm34,rsqm-cth)+
30480  & (acth0/acth2)*coef(isubsv,15)/max(rm34,rsqm+cth)+
30481  & (acth0/acth3)*coef(isubsv,16)/max(rm34,rsqm-cth)**2+
30482  & (acth0/acth4)*coef(isubsv,17)/max(rm34,rsqm+cth)**2
30483  comfac=comfac*acth0*0.5d0*be34/h3
30484 
30485 C...2 -> 2 processes: take into account final state Breit-Wigners
30486  comfac=comfac*vint(80)
30487  ENDIF
30488 
30489 C...2 -> 3, 4 processes: phace space integral in tau'
30490  IF(mint(47).GE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN
30491  ataup1=log(taupmx/taupmn)
30492  ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
30493  h4=coef(isubsv,18)+
30494  & (ataup1/ataup2)*coef(isubsv,19)*(1d0-tau/taup)**3/taup
30495  IF(mint(47).EQ.5) THEN
30496  ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
30497  h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(2d-10,1d0-taup)
30498  ELSEIF(mint(47).GE.6) THEN
30499  ataup3=log(max(1d-10,1d0-taupmn)/max(1d-10,1d0-taupmx))
30500  h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(1d-10,1d0-taup)
30501  ENDIF
30502  comfac=comfac*ataup1/h4
30503  ENDIF
30504 
30505 C...2 -> 3, 4 processes: effective W/Z parton distributions
30506  IF(istsb.EQ.3.OR.istsb.EQ.4) THEN
30507  IF(1d0-tau/taup.GT.1d-4) THEN
30508  fzw=(1d0+tau/taup)*log(taup/tau)-2d0*(1d0-tau/taup)
30509  ELSE
30510  fzw=1d0/6d0*(1d0-tau/taup)**3*tau/taup
30511  ENDIF
30512  comfac=comfac*fzw
30513  ENDIF
30514 
30515 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
30516  IF(istsb.EQ.5) THEN
30517  comfac=comfac*vint(205)*vint(210)*vint(212)*vint(214)/
30518  & (128d0*paru(1)**4*vint(220))*(tau**2/taup)
30519  ENDIF
30520 
30521 C...Phase space integral for low-pT and multiple interactions
30522  IF(istsb.EQ.9) THEN
30523  comfac=paru(1)*paru(5)*fack*0.5d0*vint(2)/sh2
30524  atau1=log(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)
30525  atau2=2d0*atan(1d0/xt2-1d0)/sqrt(xt2)
30526  h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/sqrt(tau)
30527  comfac=comfac*atau1/h1
30528  ayst0=ystmax-ystmin
30529  ayst1=0.5d0*(ystmax-ystmin)**2
30530  ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
30531  h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
30532  & (ayst0/ayst1)*coef(isubsv,9)*(ystmax-yst)+
30533  & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
30534  comfac=comfac*ayst0/h2
30535  IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1d0/vint(149)-1d0)
30536 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
30537 C...introduced to make cross-section finite for xT2 -> 0
30538  IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*
30539  & (1d0+vint(149)))
30540  ENDIF
30541 
30542 C...Real gamma + gamma: include factor 2 when different nature
30543  160 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
30544  &mstp(14).LE.10) comfac=2d0*comfac
30545 
30546 C...Extra factors to include the effects of
30547 C...longitudinal resolved photons (but not direct or DIS ones).
30548  DO 170 isde=1,2
30549  IF(mint(10+isde).EQ.22.AND.mint(106+isde).GE.1.AND.
30550  & mint(106+isde).LE.3) THEN
30551  vint(314+isde)=1d0
30552  xy=parp(166+isde)
30553  IF(mstp(16).EQ.0) THEN
30554  IF(vint(304+isde).GT.0d0.AND.vint(304+isde).LT.1d0)
30555  & xy=vint(304+isde)
30556  ELSE
30557  IF(vint(308+isde).GT.0d0.AND.vint(308+isde).LT.1d0)
30558  & xy=vint(308+isde)
30559  ENDIF
30560  q2ga=vint(306+isde)
30561  IF(mstp(17).GT.0.AND.xy.GT.0d0.AND.xy.LT.1d0.AND.
30562  & q2ga.GT.0d0) THEN
30563  reduce=0d0
30564  IF(mstp(17).EQ.1) THEN
30565  reduce=4d0*q2*q2ga/(q2+q2ga)**2
30566  ELSEIF(mstp(17).EQ.2) THEN
30567  reduce=4d0*q2ga/(q2+q2ga)
30568  ELSEIF(mstp(17).EQ.3) THEN
30569  pmvirt=pmas(pycomp(113),1)
30570  reduce=4d0*q2ga/(pmvirt**2+q2ga)
30571  ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.1) THEN
30572  pmvirt=pmas(pycomp(113),1)
30573  reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
30574  ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.2) THEN
30575  pmvirt=pmas(pycomp(113),1)
30576  reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
30577  ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.3) THEN
30578  pmvsmn=4d0*parp(15)**2
30579  pmvsmx=4d0*vint(154)**2
30580  redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
30581  redlon=(3d0*pmvsmn+q2ga)/(pmvsmn+q2ga)**3-
30582  & (3d0*pmvsmx+q2ga)/(pmvsmx+q2ga)**3
30583  reduce=4d0*(q2ga/6d0)*redlon/redtra
30584  ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.1) THEN
30585  pmvirt=pmas(pycomp(113),1)
30586  reduce=4d0*q2ga/(pmvirt**2+q2ga)
30587  ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.2) THEN
30588  pmvirt=pmas(pycomp(113),1)
30589  reduce=4d0*q2ga/(pmvirt**2+q2ga)
30590  ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.3) THEN
30591  pmvsmn=4d0*parp(15)**2
30592  pmvsmx=4d0*vint(154)**2
30593  redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
30594  redlon=1d0/(pmvsmn+q2ga)**2-1d0/(pmvsmx+q2ga)**2
30595  reduce=4d0*(q2ga/2d0)*redlon/redtra
30596  ENDIF
30597  beamas=pymass(11)
30598  IF(vint(302+isde).GT.0d0) beamas=vint(302+isde)
30599  fraclt=1d0/(1d0+xy**2/2d0/(1d0-xy)*
30600  & (1d0-2d0*beamas**2/q2ga))
30601  vint(314+isde)=1d0+parp(165)*reduce*fraclt
30602  ENDIF
30603  ELSE
30604  vint(314+isde)=1d0
30605  ENDIF
30606  comfac=comfac*vint(314+isde)
30607  170 CONTINUE
30608 
30609 C...Evaluate cross sections - done in separate routines by kind
30610 C...of physics, to keep PYSIGH of sensible size.
30611  IF(map.EQ.1) THEN
30612 C...Standard QCD (including photons).
30613  CALL pysgqc(nchn,sigs)
30614  ELSEIF(map.EQ.2) THEN
30615 C...Heavy flavours.
30616  CALL pysghf(nchn,sigs)
30617  ELSEIF(map.EQ.3) THEN
30618 C...W/Z.
30619  CALL pysgwz(nchn,sigs)
30620  ELSEIF(map.EQ.4) THEN
30621 C...Higgs (2 doublets; including longitudinal W/Z scattering).
30622  CALL pysghg(nchn,sigs)
30623  ELSEIF(map.EQ.5) THEN
30624 C...SUSY.
30625  CALL pysgsu(nchn,sigs)
30626  ELSEIF(map.EQ.6) THEN
30627 C...Technicolor.
30628  CALL pysgtc(nchn,sigs)
30629  ELSEIF(map.EQ.7) THEN
30630 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
30631  CALL pysgex(nchn,sigs)
30632  ELSEIF(map.EQ.8) THEN
30633 C... Universal Extra Dimensions
30634  CALL pyxued(nchn,sigs)
30635  ENDIF
30636 
30637 C...Multiply with parton distributions
30638  IF(isub.LE.90.OR.isub.GE.96) THEN
30639  DO 180 ichn=1,nchn
30640  IF(mint(45).GE.2) THEN
30641  kfl1=isig(ichn,1)
30642  sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)
30643  ENDIF
30644  IF(mint(46).GE.2) THEN
30645  kfl2=isig(ichn,2)
30646  sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)
30647  ENDIF
30648  sigs=sigs+sigh(ichn)
30649  180 CONTINUE
30650  ENDIF
30651 
30652  RETURN
30653  END
30654 
30655 C*********************************************************************
30656 
30657 C...PYSGQC
30658 C...Subprocess cross sections for QCD processes,
30659 C...including photons.
30660 C...Auxiliary to PYSIGH.
30661 
30662  SUBROUTINE pysgqc(NCHN,SIGS)
30663 
30664 C...Double precision and integer declarations
30665  IMPLICIT DOUBLE PRECISION(a-h, o-z)
30666  IMPLICIT INTEGER(i-n)
30667  INTEGER pyk,pychge,pycomp
30668 C...Parameter statement to help give large particle numbers.
30669  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
30670  &kexcit=4000000,kdimen=5000000)
30671 C...Commonblocks
30672  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30673  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30674  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
30675  common/pypars/mstp(200),parp(200),msti(200),pari(200)
30676  common/pyint1/mint(400),vint(400)
30677  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
30678  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
30679  common/pyint4/mwid(500),wids(500,5)
30680  common/pyint7/sigt(0:6,0:6,0:5)
30681  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
30682  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
30683  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
30684  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
30685  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
30686  &/pyint3/,/pyint4/,/pyint7/,/pysgcm/
30687 C...Local arrays
30688  dimension wdtp(0:400),wdte(0:400,0:5)
30689 
30690 C...Differential cross section expressions.
30691 
30692  IF(isub.LE.20) THEN
30693  IF(isub.EQ.10) THEN
30694 C...f + f' -> f + f' (gamma/Z/W exchange)
30695  facggf=comfac*aem**2*2d0*(sh2+uh2)/th2
30696  facgzf=comfac*aem**2*xwc*4d0*sh2/(th*(th-sqmz))
30697  faczzf=comfac*(aem*xwc)**2*2d0*sh2/(th-sqmz)**2
30698  facwwf=comfac*(0.5d0*aem/xw)**2*sh2/(th-sqmw)**2
30699  DO 110 i=mmin1,mmax1
30700  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 110
30701  ia=iabs(i)
30702  DO 100 j=mmin2,mmax2
30703  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 100
30704  ja=iabs(j)
30705 C...Electroweak couplings
30706  ei=kchg(ia,1)*isign(1,i)/3d0
30707  ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
30708  vi=ai-4d0*ei*xwv
30709  ej=kchg(ja,1)*isign(1,j)/3d0
30710  aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
30711  vj=aj-4d0*ej*xwv
30712  epsij=isign(1,i*j)
30713 C...gamma/Z exchange, only gamma exchange, or only Z exchange
30714  IF(mstp(21).GE.1.AND.mstp(21).LE.4) THEN
30715  IF(mstp(21).EQ.1.OR.mstp(21).EQ.4) THEN
30716  facncf=facggf*ei**2*ej**2+facgzf*ei*ej*
30717  & (vi*vj*(1d0+uh2/sh2)+ai*aj*epsij*(1d0-uh2/sh2))+
30718  & faczzf*((vi**2+ai**2)*(vj**2+aj**2)*(1d0+uh2/sh2)+
30719  & 4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
30720  ELSEIF(mstp(21).EQ.2) THEN
30721  facncf=facggf*ei**2*ej**2
30722  ELSE
30723  facncf=faczzf*((vi**2+ai**2)*(vj**2+aj**2)*
30724  & (1d0+uh2/sh2)+4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
30725  ENDIF
30726 C...Extrafactor 2 for only one incoming neutrino spin state.
30727  IF(ia.GT.10.AND.mod(ia,2).EQ.0) facncf=2d0*facncf
30728  IF(ja.GT.10.AND.mod(ja,2).EQ.0) facncf=2d0*facncf
30729  nchn=nchn+1
30730  isig(nchn,1)=i
30731  isig(nchn,2)=j
30732  isig(nchn,3)=1
30733  sigh(nchn)=facncf
30734  ENDIF
30735 C...W exchange
30736  IF((mstp(21).EQ.1.OR.mstp(21).EQ.5).AND.ai*aj.LT.0d0) THEN
30737  facccf=facwwf*vint(180+i)*vint(180+j)
30738  IF(epsij.LT.0d0) facccf=facccf*uh2/sh2
30739  IF(ia.GT.10.AND.mod(ia,2).EQ.0) facccf=2d0*facccf
30740  IF(ja.GT.10.AND.mod(ja,2).EQ.0) facccf=2d0*facccf
30741  nchn=nchn+1
30742  isig(nchn,1)=i
30743  isig(nchn,2)=j
30744  isig(nchn,3)=2
30745  sigh(nchn)=facccf
30746  ENDIF
30747  100 CONTINUE
30748  110 CONTINUE
30749 
30750  ELSEIF(isub.EQ.11) THEN
30751 C...f + f' -> f + f' (g exchange)
30752  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
30753  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
30754  & mstp(34)*2d0/3d0*uh2/(sh*th))
30755  facqq2=comfac*as**2*4d0/9d0*((sh2+th2)/uh2-
30756  & mstp(34)*2d0/3d0*sh2/(th*uh))
30757  DO 130 i=mmin1,mmax1
30758  ia=iabs(i)
30759  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 130
30760  DO 120 j=mmin2,mmax2
30761  ja=iabs(j)
30762  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 120
30763  nchn=nchn+1
30764  isig(nchn,1)=i
30765  isig(nchn,2)=j
30766  isig(nchn,3)=1
30767  sigh(nchn)=facqq1
30768  IF(i.EQ.-j) sigh(nchn)=facqqb
30769  IF(i.EQ.j) THEN
30770  sigh(nchn)=0.5d0*sigh(nchn)
30771  nchn=nchn+1
30772  isig(nchn,1)=i
30773  isig(nchn,2)=j
30774  isig(nchn,3)=2
30775  sigh(nchn)=0.5d0*facqq2
30776  ENDIF
30777  120 CONTINUE
30778  130 CONTINUE
30779 
30780  ELSEIF(isub.EQ.12) THEN
30781 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30782  CALL pywidt(21,sh,wdtp,wdte)
30783  facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
30784  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
30785  DO 140 i=mmina,mmaxa
30786  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30787  & kfac(1,i)*kfac(2,-i).EQ.0) goto 140
30788  nchn=nchn+1
30789  isig(nchn,1)=i
30790  isig(nchn,2)=-i
30791  isig(nchn,3)=1
30792  sigh(nchn)=facqqb
30793  140 CONTINUE
30794 
30795  ELSEIF(isub.EQ.13) THEN
30796 C...f + fbar -> g + g (q + qbar -> g + g only)
30797  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30798  & uh2/sh2)
30799  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30800  & th2/sh2)
30801  DO 150 i=mmina,mmaxa
30802  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30803  & kfac(1,i)*kfac(2,-i).EQ.0) goto 150
30804  nchn=nchn+1
30805  isig(nchn,1)=i
30806  isig(nchn,2)=-i
30807  isig(nchn,3)=1
30808  sigh(nchn)=0.5d0*facgg1
30809  nchn=nchn+1
30810  isig(nchn,1)=i
30811  isig(nchn,2)=-i
30812  isig(nchn,3)=2
30813  sigh(nchn)=0.5d0*facgg2
30814  150 CONTINUE
30815 
30816  ELSEIF(isub.EQ.14) THEN
30817 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30818  facgg=comfac*as*aem*8d0/9d0*(th2+uh2)/(th*uh)
30819  DO 160 i=mmina,mmaxa
30820  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30821  & kfac(1,i)*kfac(2,-i).EQ.0) goto 160
30822  ei=kchg(iabs(i),1)/3d0
30823  nchn=nchn+1
30824  isig(nchn,1)=i
30825  isig(nchn,2)=-i
30826  isig(nchn,3)=1
30827  sigh(nchn)=facgg*ei**2
30828  160 CONTINUE
30829 
30830  ELSEIF(isub.EQ.18) THEN
30831 C...f + fbar -> gamma + gamma
30832  facgg=comfac*aem**2*2d0*(th2+uh2)/(th*uh)
30833  DO 170 i=mmina,mmaxa
30834  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 170
30835  ei=kchg(iabs(i),1)/3d0
30836  fcoi=1d0
30837  IF(iabs(i).LE.10) fcoi=faca/3d0
30838  nchn=nchn+1
30839  isig(nchn,1)=i
30840  isig(nchn,2)=-i
30841  isig(nchn,3)=1
30842  sigh(nchn)=0.5d0*facgg*fcoi*ei**4
30843  170 CONTINUE
30844  ENDIF
30845 
30846  ELSEIF(isub.LE.40) THEN
30847  IF(isub.EQ.28) THEN
30848 C...f + g -> f + g (q + g -> q + g only)
30849  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
30850  & uh/sh)*faca
30851  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
30852  & sh/uh)
30853  DO 190 i=mmina,mmaxa
30854  IF(i.EQ.0.OR.iabs(i).GT.10) goto 190
30855  DO 180 isde=1,2
30856  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 180
30857  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 180
30858  nchn=nchn+1
30859  isig(nchn,isde)=i
30860  isig(nchn,3-isde)=21
30861  isig(nchn,3)=1
30862  sigh(nchn)=facqg1
30863  nchn=nchn+1
30864  isig(nchn,isde)=i
30865  isig(nchn,3-isde)=21
30866  isig(nchn,3)=2
30867  sigh(nchn)=facqg2
30868  180 CONTINUE
30869  190 CONTINUE
30870 
30871  ELSEIF(isub.EQ.29) THEN
30872 C...f + g -> f + gamma (q + g -> q + gamma only)
30873  fgq=comfac*faca*as*aem*1d0/3d0*(sh2+uh2)/(-sh*uh)
30874  DO 210 i=mmina,mmaxa
30875  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 210
30876  ei=kchg(iabs(i),1)/3d0
30877  facgq=fgq*ei**2
30878  DO 200 isde=1,2
30879  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 200
30880  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 200
30881  nchn=nchn+1
30882  isig(nchn,isde)=i
30883  isig(nchn,3-isde)=21
30884  isig(nchn,3)=1
30885  sigh(nchn)=facgq
30886  200 CONTINUE
30887  210 CONTINUE
30888 
30889  ELSEIF(isub.EQ.33) THEN
30890 C...f + gamma -> f + g (q + gamma -> q + g only)
30891  fgq=comfac*as*aem*8d0/3d0*(sh2+uh2)/(-sh*uh)
30892  DO 230 i=mmina,mmaxa
30893  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 230
30894  ei=kchg(iabs(i),1)/3d0
30895  facgq=fgq*ei**2
30896  DO 220 isde=1,2
30897  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 220
30898  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 220
30899  nchn=nchn+1
30900  isig(nchn,isde)=i
30901  isig(nchn,3-isde)=22
30902  isig(nchn,3)=1
30903  sigh(nchn)=facgq
30904  220 CONTINUE
30905  230 CONTINUE
30906 
30907  ELSEIF(isub.EQ.34) THEN
30908 C...f + gamma -> f + gamma
30909  fgq=comfac*aem**2*2d0*(sh2+uh2)/(-sh*uh)
30910  DO 250 i=mmina,mmaxa
30911  IF(i.EQ.0) goto 250
30912  ei=kchg(iabs(i),1)/3d0
30913  facgq=fgq*ei**4
30914  DO 240 isde=1,2
30915  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 240
30916  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 240
30917  nchn=nchn+1
30918  isig(nchn,isde)=i
30919  isig(nchn,3-isde)=22
30920  isig(nchn,3)=1
30921  sigh(nchn)=facgq
30922  240 CONTINUE
30923  250 CONTINUE
30924  ENDIF
30925 
30926  ELSEIF(isub.LE.80) THEN
30927  IF(isub.EQ.53) THEN
30928 C...g + g -> f + fbar (g + g -> q + qbar only)
30929  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 270
30930  idc0=mdcy(21,2)-1
30931 C...Begin by d, u, s flavours.
30932  flavwt=0d0
30933  IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
30934  & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
30935  IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
30936  & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
30937  IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
30938  & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
30939  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30940  & uh2/sh2)*flavwt*faca
30941  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30942  & th2/sh2)*flavwt*faca
30943  nchn=nchn+1
30944  isig(nchn,1)=21
30945  isig(nchn,2)=21
30946  isig(nchn,3)=1
30947  sigh(nchn)=facqq1
30948  nchn=nchn+1
30949  isig(nchn,1)=21
30950  isig(nchn,2)=21
30951  isig(nchn,3)=2
30952  sigh(nchn)=facqq2
30953 C...Next c and b flavours: modified that and uhat for fixed
30954 C...cos(theta-hat).
30955  DO 260 ifl=4,5
30956  sqmavg=pmas(ifl,1)**2
30957  IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
30958  be34=sqrt(1d0-4d0*sqmavg/sh)
30959  thq=-0.5d0*sh*(1d0-be34*cth)
30960  uhq=-0.5d0*sh*(1d0+be34*cth)
30961  thuhq=thq*uhq-sqmavg*sh
30962  IF(mstp(34).EQ.0) THEN
30963  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
30964  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
30965  ELSE
30966  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30967  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
30968  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30969  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
30970  ENDIF
30971  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
30972  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
30973  nchn=nchn+1
30974  isig(nchn,1)=21
30975  isig(nchn,2)=21
30976  isig(nchn,3)=1+2*(ifl-3)
30977  sigh(nchn)=facqq1
30978  nchn=nchn+1
30979  isig(nchn,1)=21
30980  isig(nchn,2)=21
30981  isig(nchn,3)=2+2*(ifl-3)
30982  sigh(nchn)=facqq2
30983  ENDIF
30984  260 CONTINUE
30985  270 CONTINUE
30986 
30987  ELSEIF(isub.EQ.54) THEN
30988 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30989  CALL pywidt(21,sh,wdtp,wdte)
30990  wdtesu=0d0
30991  DO 280 i=1,min(8,mdcy(21,3))
30992  ef=kchg(i,1)/3d0
30993  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30994  & wdte(i,4))
30995  280 CONTINUE
30996  facqq=comfac*aem*as*wdtesu*(th2+uh2)/(th*uh)
30997  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
30998  nchn=nchn+1
30999  isig(nchn,1)=21
31000  isig(nchn,2)=22
31001  isig(nchn,3)=1
31002  sigh(nchn)=facqq
31003  ENDIF
31004  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31005  nchn=nchn+1
31006  isig(nchn,1)=22
31007  isig(nchn,2)=21
31008  isig(nchn,3)=1
31009  sigh(nchn)=facqq
31010  ENDIF
31011 
31012  ELSEIF(isub.EQ.58) THEN
31013 C...gamma + gamma -> f + fbar
31014  CALL pywidt(22,sh,wdtp,wdte)
31015  wdtesu=0d0
31016  DO 290 i=1,min(12,mdcy(22,3))
31017  IF(i.LE.8) ef= kchg(i,1)/3d0
31018  IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
31019  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
31020  & wdte(i,4))
31021  290 CONTINUE
31022  facff=comfac*aem**2*wdtesu*2d0*(th2+uh2)/(th*uh)
31023  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31024  nchn=nchn+1
31025  isig(nchn,1)=22
31026  isig(nchn,2)=22
31027  isig(nchn,3)=1
31028  sigh(nchn)=facff
31029  ENDIF
31030 
31031  ELSEIF(isub.EQ.68) THEN
31032 C...g + g -> g + g
31033  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 300
31034  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+2d0*th/sh+
31035  & th2/sh2)*faca
31036  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+2d0*sh/uh+
31037  & sh2/uh2)*faca
31038  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+2d0*uh/th+
31039  & uh2/th2)
31040  nchn=nchn+1
31041  isig(nchn,1)=21
31042  isig(nchn,2)=21
31043  isig(nchn,3)=1
31044  sigh(nchn)=0.5d0*facgg1
31045  nchn=nchn+1
31046  isig(nchn,1)=21
31047  isig(nchn,2)=21
31048  isig(nchn,3)=2
31049  sigh(nchn)=0.5d0*facgg2
31050  nchn=nchn+1
31051  isig(nchn,1)=21
31052  isig(nchn,2)=21
31053  isig(nchn,3)=3
31054  sigh(nchn)=0.5d0*facgg3
31055  300 CONTINUE
31056 
31057  ELSEIF(isub.EQ.80) THEN
31058 C...q + gamma -> q' + pi+/-
31059  fqpi=comfac*(2d0*aem/9d0)*(-sh/th)*(1d0/sh2+1d0/th2)
31060  assh=pyalps(max(0.5d0,0.5d0*sh))
31061  q2fpsh=0.55d0/log(max(2d0,2d0*sh))
31062  delsh=uh*sqrt(assh*q2fpsh)
31063  asuh=pyalps(max(0.5d0,-0.5d0*uh))
31064  q2fpuh=0.55d0/log(max(2d0,-2d0*uh))
31065  deluh=sh*sqrt(asuh*q2fpuh)
31066  DO 320 i=max(-2,mmina),min(2,mmaxa)
31067  IF(i.EQ.0) goto 320
31068  ei=kchg(iabs(i),1)/3d0
31069  ej=sign(1d0-abs(ei),ei)
31070  DO 310 isde=1,2
31071  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 310
31072  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 310
31073  nchn=nchn+1
31074  isig(nchn,isde)=i
31075  isig(nchn,3-isde)=22
31076  isig(nchn,3)=1
31077  sigh(nchn)=fqpi*(ei*delsh+ej*deluh)**2
31078  310 CONTINUE
31079  320 CONTINUE
31080  ENDIF
31081 
31082  ELSEIF(isub.LE.100) THEN
31083  IF(isub.EQ.91) THEN
31084 C...Elastic scattering
31085  sigs=vint(315)*vint(316)*sigt(0,0,1)
31086 
31087  ELSEIF(isub.EQ.92) THEN
31088 C...Single diffractive scattering (first side, i.e. XB)
31089  sigs=vint(315)*vint(316)*sigt(0,0,2)
31090 
31091  ELSEIF(isub.EQ.93) THEN
31092 C...Single diffractive scattering (second side, i.e. AX)
31093  sigs=vint(315)*vint(316)*sigt(0,0,3)
31094 
31095  ELSEIF(isub.EQ.94) THEN
31096 C...Double diffractive scattering
31097  sigs=vint(315)*vint(316)*sigt(0,0,4)
31098 
31099  ELSEIF(isub.EQ.95) THEN
31100 C...Low-pT scattering
31101  sigs=vint(315)*vint(316)*sigt(0,0,5)
31102 
31103  ELSEIF(isub.EQ.96) THEN
31104 C...Multiple interactions: sum of QCD processes
31105  CALL pywidt(21,sh,wdtp,wdte)
31106 
31107 C...q + q' -> q + q'
31108  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
31109  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
31110  & mstp(34)*2d0/3d0*uh2/(sh*th))
31111  facqq2=comfac*as**2*4d0/9d0*(sh2+th2)/uh2
31112  facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
31113  ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
31114  DO 340 i=-5,5
31115  IF(i.EQ.0) goto 340
31116  DO 330 j=-5,5
31117  IF(j.EQ.0) goto 330
31118  nchn=nchn+1
31119  isig(nchn,1)=i
31120  isig(nchn,2)=j
31121  isig(nchn,3)=111
31122  sigh(nchn)=facqq1
31123  IF(i.EQ.-j) sigh(nchn)=facqqb
31124  IF(i.EQ.j) THEN
31125  sigh(nchn)=0.5d0*facqq1*ratqqi
31126  nchn=nchn+1
31127  isig(nchn,1)=i
31128  isig(nchn,2)=j
31129  isig(nchn,3)=112
31130  sigh(nchn)=0.5d0*facqq2*ratqqi
31131  ENDIF
31132  330 CONTINUE
31133  340 CONTINUE
31134 
31135 C...q + qbar -> q' + qbar' or g + g
31136  facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
31137  & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))
31138  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
31139  & uh2/sh2)
31140  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
31141  & th2/sh2)
31142  DO 350 i=-5,5
31143  IF(i.EQ.0) goto 350
31144  nchn=nchn+1
31145  isig(nchn,1)=i
31146  isig(nchn,2)=-i
31147  isig(nchn,3)=121
31148  sigh(nchn)=facqqb
31149  nchn=nchn+1
31150  isig(nchn,1)=i
31151  isig(nchn,2)=-i
31152  isig(nchn,3)=131
31153  sigh(nchn)=0.5d0*facgg1
31154  nchn=nchn+1
31155  isig(nchn,1)=i
31156  isig(nchn,2)=-i
31157  isig(nchn,3)=132
31158  sigh(nchn)=0.5d0*facgg2
31159  350 CONTINUE
31160 
31161 C...q + g -> q + g
31162  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
31163  & uh/sh)*faca
31164  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
31165  & sh/uh)
31166  DO 370 i=-5,5
31167  IF(i.EQ.0) goto 370
31168  DO 360 isde=1,2
31169  nchn=nchn+1
31170  isig(nchn,isde)=i
31171  isig(nchn,3-isde)=21
31172  isig(nchn,3)=281
31173  sigh(nchn)=facqg1
31174  nchn=nchn+1
31175  isig(nchn,isde)=i
31176  isig(nchn,3-isde)=21
31177  isig(nchn,3)=282
31178  sigh(nchn)=facqg2
31179  360 CONTINUE
31180  370 CONTINUE
31181 
31182 C...g + g -> q + qbar (only d, u, s)
31183  idc0=mdcy(21,2)-1
31184  flavwt=0d0
31185  IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
31186  & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
31187  IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
31188  & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
31189  IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
31190  & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
31191  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
31192  & uh2/sh2)*flavwt*faca
31193  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
31194  & th2/sh2)*flavwt*faca
31195  nchn=nchn+1
31196  isig(nchn,1)=21
31197  isig(nchn,2)=21
31198  isig(nchn,3)=531
31199  sigh(nchn)=facqq1
31200  nchn=nchn+1
31201  isig(nchn,1)=21
31202  isig(nchn,2)=21
31203  isig(nchn,3)=532
31204  sigh(nchn)=facqq2
31205 
31206 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
31207 C...cos(theta-hat)
31208  DO 380 ifl=4,5
31209  sqmavg=pmas(ifl,1)**2
31210  IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
31211  be34=sqrt(1d0-4d0*sqmavg/sh)
31212  thq=-0.5d0*sh*(1d0-be34*cth)
31213  uhq=-0.5d0*sh*(1d0+be34*cth)
31214  thuhq=thq*uhq-sqmavg*sh
31215  IF(mstp(34).EQ.0) THEN
31216  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
31217  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
31218  ELSE
31219  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
31220  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
31221  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
31222  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
31223  ENDIF
31224  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
31225  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
31226  nchn=nchn+1
31227  isig(nchn,1)=21
31228  isig(nchn,2)=21
31229  isig(nchn,3)=531+2*(ifl-3)
31230  sigh(nchn)=facqq1
31231  nchn=nchn+1
31232  isig(nchn,1)=21
31233  isig(nchn,2)=21
31234  isig(nchn,3)=532+2*(ifl-3)
31235  sigh(nchn)=facqq2
31236  ENDIF
31237  380 CONTINUE
31238 
31239 C...g + g -> g + g
31240  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
31241  & 2d0*th/sh+th2/sh2)*faca
31242  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
31243  & 2d0*sh/uh+sh2/uh2)*faca
31244  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3+
31245  & 2d0*uh/th+uh2/th2)
31246  nchn=nchn+1
31247  isig(nchn,1)=21
31248  isig(nchn,2)=21
31249  isig(nchn,3)=681
31250  sigh(nchn)=0.5d0*facgg1
31251  nchn=nchn+1
31252  isig(nchn,1)=21
31253  isig(nchn,2)=21
31254  isig(nchn,3)=682
31255  sigh(nchn)=0.5d0*facgg2
31256  nchn=nchn+1
31257  isig(nchn,1)=21
31258  isig(nchn,2)=21
31259  isig(nchn,3)=683
31260  sigh(nchn)=0.5d0*facgg3
31261 
31262  ELSEIF(isub.EQ.99) THEN
31263 C...f + gamma* -> f.
31264  IF(mint(107).EQ.4) THEN
31265  q2ga=vint(307)
31266  p2ga=vint(308)
31267  isde=2
31268  ELSE
31269  q2ga=vint(308)
31270  p2ga=vint(307)
31271  isde=1
31272  ENDIF
31273  comfac=paru(5)*4d0*paru(1)**2*paru(101)*vint(315)*vint(316)
31274  pm2rho=pmas(pycomp(113),1)**2
31275  IF(mstp(19).EQ.0) THEN
31276  comfac=comfac/q2ga
31277  ELSEIF(mstp(19).EQ.1) THEN
31278  comfac=comfac/(q2ga+pm2rho)
31279  ELSEIF(mstp(19).EQ.2) THEN
31280  comfac=comfac*q2ga/(q2ga+pm2rho)**2
31281  ELSE
31282  comfac=comfac*q2ga/(q2ga+pm2rho)**2
31283  w2ga=vint(2)
31284  IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
31285  rdrds=4.1d-3*w2ga**2.167d0/((q2ga+0.15d0*w2ga)**2*
31286  & q2ga**0.75d0)*(1d0+0.11d0*q2ga*p2ga/(1d0+0.02d0*p2ga**2))
31287  xga=q2ga/(w2ga+vint(307)+vint(308))
31288  ELSE
31289  rdrds=1.5d-4*w2ga**2.167d0/((q2ga+0.041d0*w2ga)**2*
31290  & q2ga**0.57d0)
31291  xga=q2ga/(w2ga+q2ga-pmas(pycomp(mint(10+isde)),1)**2)
31292  ENDIF
31293  comfac=comfac*exp(-max(1d-10,rdrds))
31294  IF(mstp(19).EQ.4) comfac=comfac/max(1d-2,1d0-xga)
31295  ENDIF
31296  DO 390 i=mmina,mmaxa
31297  IF(i.EQ.0.OR.kfac(isde,i).EQ.0) goto 390
31298  IF(iabs(i).LT.10.AND.iabs(i).GT.mstp(58)) goto 390
31299  ei=kchg(iabs(i),1)/3d0
31300  nchn=nchn+1
31301  isig(nchn,isde)=i
31302  isig(nchn,3-isde)=22
31303  isig(nchn,3)=1
31304  sigh(nchn)=comfac*ei**2
31305  390 CONTINUE
31306  ENDIF
31307 
31308  ELSE
31309  IF(isub.EQ.114.OR.isub.EQ.115) THEN
31310 C...g + g -> gamma + gamma or g + g -> g + gamma
31311  a0stur=0d0
31312  a0stui=0d0
31313  a0tsur=0d0
31314  a0tsui=0d0
31315  a0utsr=0d0
31316  a0utsi=0d0
31317  a1stur=0d0
31318  a1stui=0d0
31319  a2stur=0d0
31320  a2stui=0d0
31321  alst=log(-sh/th)
31322  alsu=log(-sh/uh)
31323  altu=log(th/uh)
31324  imax=2*mstp(1)
31325  IF(mstp(38).GE.1.AND.mstp(38).LE.8) imax=mstp(38)
31326  DO 400 i=1,imax
31327  ei=kchg(iabs(i),1)/3d0
31328  eiwt=ei**2
31329  IF(isub.EQ.115) eiwt=ei
31330  sqmq=pmas(i,1)**2
31331  epss=4d0*sqmq/sh
31332  epst=4d0*sqmq/th
31333  epsu=4d0*sqmq/uh
31334  IF((mstp(38).GE.1.AND.mstp(38).LE.8).OR.epss.LT.1d-4) THEN
31335  b0stur=1d0+(th-uh)/sh*altu+0.5d0*(th2+uh2)/sh2*(altu**2+
31336  & paru(1)**2)
31337  b0stui=0d0
31338  b0tsur=1d0+(sh-uh)/th*alsu+0.5d0*(sh2+uh2)/th2*alsu**2
31339  b0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*alsu)
31340  b0utsr=1d0+(sh-th)/uh*alst+0.5d0*(sh2+th2)/uh2*alst**2
31341  b0utsi=-paru(1)*((sh-th)/uh+(sh2+th2)/uh2*alst)
31342  b1stur=-1d0
31343  b1stui=0d0
31344  b2stur=-1d0
31345  b2stui=0d0
31346  ELSE
31347  CALL pywaux(1,epss,w1sr,w1si)
31348  CALL pywaux(1,epst,w1tr,w1ti)
31349  CALL pywaux(1,epsu,w1ur,w1ui)
31350  CALL pywaux(2,epss,w2sr,w2si)
31351  CALL pywaux(2,epst,w2tr,w2ti)
31352  CALL pywaux(2,epsu,w2ur,w2ui)
31353  CALL pyi3au(epss,th/uh,y3stur,y3stui)
31354  CALL pyi3au(epss,uh/th,y3sutr,y3suti)
31355  CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
31356  CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
31357  CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
31358  CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
31359  b0stur=1d0+(1d0+2d0*th/sh)*w1tr+(1d0+2d0*uh/sh)*w1ur+
31360  & 0.5d0*((th2+uh2)/sh2-epss)*(w2tr+w2ur)-
31361  & 0.25d0*epst*(1d0-0.5d0*epss)*(y3sutr+y3tusr)-
31362  & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stur+y3utsr)+
31363  & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
31364  & 0.5d0*epst*epsu)*(y3tsur+y3ustr)
31365  b0stui=(1d0+2d0*th/sh)*w1ti+(1d0+2d0*uh/sh)*w1ui+
31366  & 0.5d0*((th2+uh2)/sh2-epss)*(w2ti+w2ui)-
31367  & 0.25d0*epst*(1d0-0.5d0*epss)*(y3suti+y3tusi)-
31368  & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stui+y3utsi)+
31369  & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
31370  & 0.5d0*epst*epsu)*(y3tsui+y3usti)
31371  b0tsur=1d0+(1d0+2d0*sh/th)*w1sr+(1d0+2d0*uh/th)*w1ur+
31372  & 0.5d0*((sh2+uh2)/th2-epst)*(w2sr+w2ur)-
31373  & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusr+y3sutr)-
31374  & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsur+y3ustr)+
31375  & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
31376  & 0.5d0*epss*epsu)*(y3stur+y3utsr)
31377  b0tsui=(1d0+2d0*sh/th)*w1si+(1d0+2d0*uh/th)*w1ui+
31378  & 0.5d0*((sh2+uh2)/th2-epst)*(w2si+w2ui)-
31379  & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusi+y3suti)-
31380  & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsui+y3usti)+
31381  & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
31382  & 0.5d0*epss*epsu)*(y3stui+y3utsi)
31383  b0utsr=1d0+(1d0+2d0*th/uh)*w1tr+(1d0+2d0*sh/uh)*w1sr+
31384  & 0.5d0*((th2+sh2)/uh2-epsu)*(w2tr+w2sr)-
31385  & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3ustr+y3tsur)-
31386  & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsr+y3stur)+
31387  & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
31388  & 0.5d0*epst*epss)*(y3tusr+y3sutr)
31389  b0utsi=(1d0+2d0*th/uh)*w1ti+(1d0+2d0*sh/uh)*w1si+
31390  & 0.5d0*((th2+sh2)/uh2-epsu)*(w2ti+w2si)-
31391  & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3usti+y3tsui)-
31392  & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsi+y3stui)+
31393  & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
31394  & 0.5d0*epst*epss)*(y3tusi+y3suti)
31395  b1stur=-1d0-0.25d0*(epss+epst+epsu)*(w2sr+w2tr+w2ur)+
31396  & 0.25d0*(epsu+0.5d0*epss*epst)*(y3sutr+y3tusr)+
31397  & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stur+y3utsr)+
31398  & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsur+y3ustr)
31399  b1stui=-0.25d0*(epss+epst+epsu)*(w2si+w2ti+w2ui)+
31400  & 0.25d0*(epsu+0.5d0*epss*epst)*(y3suti+y3tusi)+
31401  & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stui+y3utsi)+
31402  & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsui+y3usti)
31403  b2stur=-1d0+0.125d0*epss*epst*(y3sutr+y3tusr)+
31404  & 0.125d0*epss*epsu*(y3stur+y3utsr)+
31405  & 0.125d0*epst*epsu*(y3tsur+y3ustr)
31406  b2stui=0.125d0*epss*epst*(y3suti+y3tusi)+
31407  & 0.125d0*epss*epsu*(y3stui+y3utsi)+
31408  & 0.125d0*epst*epsu*(y3tsui+y3usti)
31409  ENDIF
31410  a0stur=a0stur+eiwt*b0stur
31411  a0stui=a0stui+eiwt*b0stui
31412  a0tsur=a0tsur+eiwt*b0tsur
31413  a0tsui=a0tsui+eiwt*b0tsui
31414  a0utsr=a0utsr+eiwt*b0utsr
31415  a0utsi=a0utsi+eiwt*b0utsi
31416  a1stur=a1stur+eiwt*b1stur
31417  a1stui=a1stui+eiwt*b1stui
31418  a2stur=a2stur+eiwt*b2stur
31419  a2stui=a2stui+eiwt*b2stui
31420  400 CONTINUE
31421  asqsum=a0stur**2+a0stui**2+a0tsur**2+a0tsui**2+a0utsr**2+
31422  & a0utsi**2+4d0*a1stur**2+4d0*a1stui**2+a2stur**2+a2stui**2
31423  facgg=comfac*faca/(16d0*paru(1)**2)*as**2*aem**2*asqsum
31424  facgp=comfac*faca*5d0/(192d0*paru(1)**2)*as**3*aem*asqsum
31425  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 410
31426  nchn=nchn+1
31427  isig(nchn,1)=21
31428  isig(nchn,2)=21
31429  isig(nchn,3)=1
31430  IF(isub.EQ.114) sigh(nchn)=0.5d0*facgg
31431  IF(isub.EQ.115) sigh(nchn)=facgp
31432  410 CONTINUE
31433 
31434  ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
31435 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
31436  ph=0d0
31437  IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
31438  & ph=vint(3)**2
31439  IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
31440  & ph=vint(4)**2
31441  IF(isub.EQ.131) THEN
31442  fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**2*
31443  & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
31444  ELSE
31445  fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
31446  ENDIF
31447  DO 430 i=mmina,mmaxa
31448  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 430
31449  ei=kchg(iabs(i),1)/3d0
31450  facgq=fgq*ei**2
31451  DO 420 isde=1,2
31452  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 420
31453  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 420
31454  nchn=nchn+1
31455  isig(nchn,isde)=i
31456  isig(nchn,3-isde)=22
31457  isig(nchn,3)=1
31458  sigh(nchn)=facgq
31459  420 CONTINUE
31460  430 CONTINUE
31461 
31462  ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
31463 C...f + gamma*_(T,L) -> f + gamma
31464  ph=0d0
31465  IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
31466  & ph=vint(3)**2
31467  IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
31468  & ph=vint(4)**2
31469  IF(isub.EQ.133) THEN
31470  fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**2*
31471  & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
31472  ELSE
31473  fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
31474  ENDIF
31475  DO 450 i=mmina,mmaxa
31476  IF(i.EQ.0) goto 450
31477  ei=kchg(iabs(i),1)/3d0
31478  facgq=fgq*ei**4
31479  DO 440 isde=1,2
31480  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 440
31481  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 440
31482  nchn=nchn+1
31483  isig(nchn,isde)=i
31484  isig(nchn,3-isde)=22
31485  isig(nchn,3)=1
31486  sigh(nchn)=facgq
31487  440 CONTINUE
31488  450 CONTINUE
31489 
31490  ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
31491 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
31492  ph=0d0
31493  IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
31494  & ph=vint(3)**2
31495  IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
31496  & ph=vint(4)**2
31497  CALL pywidt(21,sh,wdtp,wdte)
31498  wdtesu=0d0
31499  DO 460 i=1,min(8,mdcy(21,3))
31500  ef=kchg(i,1)/3d0
31501  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
31502  & wdte(i,4))
31503  460 CONTINUE
31504  IF(isub.EQ.135) THEN
31505  facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**2*
31506  & ((th2+uh2-2d0*ph*sh)/(th*uh)+4d0*ph*sh/(sh+ph)**2)
31507  ELSE
31508  facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**4*8d0*ph*sh
31509  ENDIF
31510  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
31511  nchn=nchn+1
31512  isig(nchn,1)=21
31513  isig(nchn,2)=22
31514  isig(nchn,3)=1
31515  sigh(nchn)=facqq
31516  ENDIF
31517  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31518  nchn=nchn+1
31519  isig(nchn,1)=22
31520  isig(nchn,2)=21
31521  isig(nchn,3)=1
31522  sigh(nchn)=facqq
31523  ENDIF
31524 
31525  ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
31526 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
31527  ph1=0d0
31528  IF(vint(3).LT.0d0) ph1=vint(3)**2
31529  ph2=0d0
31530  IF(vint(4).LT.0d0) ph2=vint(4)**2
31531  CALL pywidt(22,sh,wdtp,wdte)
31532  wdtesu=0d0
31533  DO 470 i=1,min(12,mdcy(22,3))
31534  IF(i.LE.8) ef= kchg(i,1)/3d0
31535  IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
31536  wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
31537  & wdte(i,4))
31538  470 CONTINUE
31539  dlamb2=(th+uh)**2-4d0*ph1*ph2
31540  IF(isub.EQ.137) THEN
31541  fparam=-sh*(th+uh)/dlamb2
31542  facff=comfac*aem**2*wdtesu*2d0*sh2/(dlamb2*th2*uh2)*
31543  & (th*uh-ph1*ph2)*((th2+uh2)*(1d0-2d0*fparam*(1d0-fparam))-
31544  & 2d0*ph1*ph2*fparam**2)
31545  ELSEIF(isub.EQ.138) THEN
31546  facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
31547  & ph2*(4d0*(th*uh-ph1*ph2)*(th*uh+ph1*sh*(th-uh)**2/dlamb2)+
31548  & 2d0*ph1**2*(th-uh)**2)
31549  ELSEIF(isub.EQ.139) THEN
31550  facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
31551  & ph1*(4d0*(th*uh-ph1*ph2)*(th*uh+ph2*sh*(th-uh)**2/dlamb2)+
31552  & 2d0*ph2**2*(th-uh)**2)
31553  ELSE
31554  facff=comfac*aem**2*wdtesu*32d0*sh2**2/(dlamb2**3*th2*uh2)*
31555  & ph1*ph2*(th*uh-ph1*ph2)*(th-uh)**2
31556  ENDIF
31557  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31558  nchn=nchn+1
31559  isig(nchn,1)=22
31560  isig(nchn,2)=22
31561  isig(nchn,3)=1
31562  sigh(nchn)=facff
31563  ENDIF
31564 
31565  ENDIF
31566  ENDIF
31567 
31568  RETURN
31569  END
31570 
31571 C*********************************************************************
31572 
31573 C...PYSGHF
31574 C...Subprocess cross sections for heavy flavour production,
31575 C...open and closed.
31576 C...Auxiliary to PYSIGH.
31577 
31578  SUBROUTINE pysghf(NCHN,SIGS)
31579 
31580 C...Double precision and integer declarations
31581  IMPLICIT DOUBLE PRECISION(a-h, o-z)
31582  IMPLICIT INTEGER(i-n)
31583  INTEGER pyk,pychge,pycomp
31584 C...Parameter statement to help give large particle numbers.
31585  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
31586  &kexcit=4000000,kdimen=5000000)
31587 C...Commonblocks
31588  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
31589  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
31590  common/pypars/mstp(200),parp(200),msti(200),pari(200)
31591  common/pyint1/mint(400),vint(400)
31592  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
31593  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
31594  common/pyint4/mwid(500),wids(500,5)
31595  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
31596  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
31597  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
31598  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
31599  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
31600  &/pyint4/,/pysgcm/
31601 C...Local arrays
31602  dimension wdtp(0:400),wdte(0:400,0:5)
31603 
31604 C...Determine where are charmonium/bottomonium wave function parameters.
31605  ionium=140
31606  IF(isub.GE.461.AND.isub.LE.479) ionium=145
31607 
31608 C...Convert bottomonium process into equivalent charmonium ones.
31609  IF(isub.GE.461.AND.isub.LE.479) isub=isub-40
31610 
31611 C...Differential cross section expressions.
31612 
31613  IF(isub.LE.100) THEN
31614  IF(isub.EQ.81) THEN
31615 C...q + qbar -> Q + Qbar
31616  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
31617  thq=-0.5d0*sh*(1d0-be34*cth)
31618  uhq=-0.5d0*sh*(1d0+be34*cth)
31619  facqqb=comfac*as**2*4d0/9d0*((thq**2+uhq**2)/sh2+
31620  & 2d0*sqmavg/sh)
31621  IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqmavg,0d0)
31622  wid2=1d0
31623  IF(mint(55).EQ.6) wid2=wids(6,1)
31624  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
31625  facqqb=facqqb*wid2
31626  DO 100 i=mmina,mmaxa
31627  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
31628  & kfac(1,i)*kfac(2,-i).EQ.0) goto 100
31629  nchn=nchn+1
31630  isig(nchn,1)=i
31631  isig(nchn,2)=-i
31632  isig(nchn,3)=1
31633  sigh(nchn)=facqqb
31634  100 CONTINUE
31635 
31636  ELSEIF(isub.EQ.82) THEN
31637 C...g + g -> Q + Qbar
31638  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
31639  thq=-0.5d0*sh*(1d0-be34*cth)
31640  uhq=-0.5d0*sh*(1d0+be34*cth)
31641  thuhq=thq*uhq-sqmavg*sh
31642  IF(mstp(34).EQ.0) THEN
31643  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
31644  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
31645  ELSE
31646  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
31647  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
31648  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
31649  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
31650  ENDIF
31651  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1
31652  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2
31653  IF(mstp(35).GE.1) THEN
31654  fatre=pyhfth(sh,sqmavg,2d0/7d0)
31655  facqq1=facqq1*fatre
31656  facqq2=facqq2*fatre
31657  ENDIF
31658  wid2=1d0
31659  IF(mint(55).EQ.6) wid2=wids(6,1)
31660  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
31661  facqq1=facqq1*wid2
31662  facqq2=facqq2*wid2
31663  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 110
31664  nchn=nchn+1
31665  isig(nchn,1)=21
31666  isig(nchn,2)=21
31667  isig(nchn,3)=1
31668  sigh(nchn)=facqq1
31669  nchn=nchn+1
31670  isig(nchn,1)=21
31671  isig(nchn,2)=21
31672  isig(nchn,3)=2
31673  sigh(nchn)=facqq2
31674  110 CONTINUE
31675 
31676  ELSEIF(isub.EQ.83) THEN
31677 C...f + q -> f' + Q
31678  facqqs=comfac*(0.5d0*aem/xw)**2*sh*(sh-sqm3)/(sqmw-th)**2
31679  facqqu=comfac*(0.5d0*aem/xw)**2*uh*(uh-sqm3)/(sqmw-th)**2
31680  DO 130 i=mmin1,mmax1
31681  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 130
31682  DO 120 j=mmin2,mmax2
31683  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 120
31684  IF(i*j.GT.0.AND.mod(iabs(i+j),2).EQ.0) goto 120
31685  IF(i*j.LT.0.AND.mod(iabs(i+j),2).EQ.1) goto 120
31686  IF(iabs(i).LT.mint(55).AND.mod(iabs(i+mint(55)),2).EQ.1)
31687  & THEN
31688  nchn=nchn+1
31689  isig(nchn,1)=i
31690  isig(nchn,2)=j
31691  isig(nchn,3)=1
31692  IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
31693  & (iabs(i)+1)/2)*vint(180+j)
31694  IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(i)/2,
31695  & (mint(55)+1)/2)*vint(180+j)
31696  wid2=1d0
31697  IF(i.GT.0) THEN
31698  IF(mint(55).EQ.6) wid2=wids(6,2)
31699  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
31700  & wids(mint(55),2)
31701  ELSE
31702  IF(mint(55).EQ.6) wid2=wids(6,3)
31703  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
31704  & wids(mint(55),3)
31705  ENDIF
31706  IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
31707  IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
31708  ENDIF
31709  IF(iabs(j).LT.mint(55).AND.mod(iabs(j+mint(55)),2).EQ.1)
31710  & THEN
31711  nchn=nchn+1
31712  isig(nchn,1)=i
31713  isig(nchn,2)=j
31714  isig(nchn,3)=2
31715  IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
31716  & (iabs(j)+1)/2)*vint(180+i)
31717  IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(j)/2,
31718  & (mint(55)+1)/2)*vint(180+i)
31719  wid2=1d0
31720  IF(j.GT.0) THEN
31721  IF(mint(55).EQ.6) wid2=wids(6,2)
31722  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
31723  & wids(mint(55),2)
31724  ELSE
31725  IF(mint(55).EQ.6) wid2=wids(6,3)
31726  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
31727  & wids(mint(55),3)
31728  ENDIF
31729  IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
31730  IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
31731  ENDIF
31732  120 CONTINUE
31733  130 CONTINUE
31734 
31735  ELSEIF(isub.EQ.84) THEN
31736 C...g + gamma -> Q + Qbar
31737  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
31738  thq=-0.5d0*sh*(1d0-be34*cth)
31739  uhq=-0.5d0*sh*(1d0+be34*cth)
31740  facqq=comfac*as*aem*(kchg(iabs(mint(55)),1)/3d0)**2*
31741  & (thq**2+uhq**2+4d0*sqmavg*sh*(1d0-sqmavg*sh/(thq*uhq)))/
31742  & (thq*uhq)
31743  IF(mstp(35).GE.1) facqq=facqq*pyhfth(sh,sqmavg,0d0)
31744  wid2=1d0
31745  IF(mint(55).EQ.6) wid2=wids(6,1)
31746  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
31747  facqq=facqq*wid2
31748  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
31749  nchn=nchn+1
31750  isig(nchn,1)=21
31751  isig(nchn,2)=22
31752  isig(nchn,3)=1
31753  sigh(nchn)=facqq
31754  ENDIF
31755  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31756  nchn=nchn+1
31757  isig(nchn,1)=22
31758  isig(nchn,2)=21
31759  isig(nchn,3)=1
31760  sigh(nchn)=facqq
31761  ENDIF
31762 
31763  ELSEIF(isub.EQ.85) THEN
31764 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31765  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
31766  thq=-0.5d0*sh*(1d0-be34*cth)
31767  uhq=-0.5d0*sh*(1d0+be34*cth)
31768  facff=comfac*aem**2*(kchg(iabs(mint(56)),1)/3d0)**4*2d0*
31769  & ((1d0-parj(131)*parj(132))*(thq*uhq-sqmavg*sh)*
31770  & (uhq**2+thq**2+2d0*sqmavg*sh)+(1d0+parj(131)*parj(132))*
31771  & sqmavg*sh**2*(sh-2d0*sqmavg))/(thq*uhq)**2
31772  IF(iabs(mint(56)).LT.10) facff=3d0*facff
31773  IF(iabs(mint(56)).LT.10.AND.mstp(35).GE.1)
31774  & facff=facff*pyhfth(sh,sqmavg,1d0)
31775  wid2=1d0
31776  IF(mint(56).EQ.6) wid2=wids(6,1)
31777  IF(mint(56).EQ.7.OR.mint(56).EQ.8) wid2=wids(mint(56),1)
31778  IF(mint(56).EQ.17) wid2=wids(17,1)
31779  facff=facff*wid2
31780  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31781  nchn=nchn+1
31782  isig(nchn,1)=22
31783  isig(nchn,2)=22
31784  isig(nchn,3)=1
31785  sigh(nchn)=facff
31786  ENDIF
31787 
31788  ELSEIF(isub.EQ.86) THEN
31789 C...g + g -> J/Psi + g
31790  facqqg=comfac*as**3*(5d0/9d0)*parp(38)*sqrt(sqm3)*
31791  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31792  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31793  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31794  nchn=nchn+1
31795  isig(nchn,1)=21
31796  isig(nchn,2)=21
31797  isig(nchn,3)=1
31798  sigh(nchn)=facqqg
31799  ENDIF
31800 
31801  ELSEIF(isub.EQ.87) THEN
31802 C...g + g -> chi_0c + g
31803  pgtw=(sh*th+th*uh+uh*sh)/sh2
31804  qgtw=(sh*th*uh)/sh**3
31805  rgtw=sqm3/sh
31806  facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31807  & (9d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
31808  & 6d0*rgtw*pgtw**3*qgtw*(2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)-
31809  & pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)+
31810  & 2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)+6d0*rgtw**2*qgtw**4)/
31811  & (qgtw*(qgtw-rgtw*pgtw)**4)
31812  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31813  nchn=nchn+1
31814  isig(nchn,1)=21
31815  isig(nchn,2)=21
31816  isig(nchn,3)=1
31817  sigh(nchn)=facqqg
31818  ENDIF
31819 
31820  ELSEIF(isub.EQ.88) THEN
31821 C...g + g -> chi_1c + g
31822  pgtw=(sh*th+th*uh+uh*sh)/sh2
31823  qgtw=(sh*th*uh)/sh**3
31824  rgtw=sqm3/sh
31825  facqqg=comfac*as**3*12d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31826  & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)+2d0*qgtw*(-rgtw**4+
31827  & 5d0*rgtw**2*pgtw+pgtw**2)-15d0*rgtw*qgtw**2)/
31828  & (qgtw-rgtw*pgtw)**4
31829  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31830  nchn=nchn+1
31831  isig(nchn,1)=21
31832  isig(nchn,2)=21
31833  isig(nchn,3)=1
31834  sigh(nchn)=facqqg
31835  ENDIF
31836 
31837  ELSEIF(isub.EQ.89) THEN
31838 C...g + g -> chi_2c + g
31839  pgtw=(sh*th+th*uh+uh*sh)/sh2
31840  qgtw=(sh*th*uh)/sh**3
31841  rgtw=sqm3/sh
31842  facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31843  & (12d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
31844  & 3d0*rgtw*pgtw**3*qgtw*(8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)+
31845  & 2d0*pgtw**2*qgtw**2*(-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)+
31846  & rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)+12d0*rgtw**2*
31847  & qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
31848  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31849  nchn=nchn+1
31850  isig(nchn,1)=21
31851  isig(nchn,2)=21
31852  isig(nchn,3)=1
31853  sigh(nchn)=facqqg
31854  ENDIF
31855  ENDIF
31856 
31857  ELSEIF(isub.LE.200) THEN
31858  IF(isub.EQ.104) THEN
31859 C...g + g -> chi_c0.
31860  kc=pycomp(10441)
31861  facbw=comfac*12d0*as**2*parp(39)*pmas(kc,2)/
31862  & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
31863  IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
31864  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31865  nchn=nchn+1
31866  isig(nchn,1)=21
31867  isig(nchn,2)=21
31868  isig(nchn,3)=1
31869  sigh(nchn)=facbw
31870  ENDIF
31871 
31872  ELSEIF(isub.EQ.105) THEN
31873 C...g + g -> chi_c2.
31874  kc=pycomp(445)
31875  facbw=comfac*16d0*as**2*parp(39)*pmas(kc,2)/
31876  & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
31877  IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
31878  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31879  nchn=nchn+1
31880  isig(nchn,1)=21
31881  isig(nchn,2)=21
31882  isig(nchn,3)=1
31883  sigh(nchn)=facbw
31884  ENDIF
31885 
31886  ELSEIF(isub.EQ.106) THEN
31887 C...g + g -> J/Psi + gamma.
31888  eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31889  facqqg=comfac*aem*eq**2*as**2*(4d0/3d0)*parp(38)*sqrt(sqm3)*
31890  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31891  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31892  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31893  nchn=nchn+1
31894  isig(nchn,1)=21
31895  isig(nchn,2)=21
31896  isig(nchn,3)=1
31897  sigh(nchn)=facqqg
31898  ENDIF
31899 
31900  ELSEIF(isub.EQ.107) THEN
31901 C...g + gamma -> J/Psi + g.
31902  eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31903  facqqg=comfac*aem*eq**2*as**2*(32d0/3d0)*parp(38)*sqrt(sqm3)*
31904  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31905  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31906  IF(kfac(1,21)*kfac(2,22).NE.0) THEN
31907  nchn=nchn+1
31908  isig(nchn,1)=21
31909  isig(nchn,2)=22
31910  isig(nchn,3)=1
31911  sigh(nchn)=facqqg
31912  ENDIF
31913  IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31914  nchn=nchn+1
31915  isig(nchn,1)=22
31916  isig(nchn,2)=21
31917  isig(nchn,3)=1
31918  sigh(nchn)=facqqg
31919  ENDIF
31920 
31921  ELSEIF(isub.EQ.108) THEN
31922 C...gamma + gamma -> J/Psi + gamma.
31923  eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31924  facqqg=comfac*aem**3*eq**6*384d0*parp(38)*sqrt(sqm3)*
31925  & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31926  & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31927  IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31928  nchn=nchn+1
31929  isig(nchn,1)=22
31930  isig(nchn,2)=22
31931  isig(nchn,3)=1
31932  sigh(nchn)=facqqg
31933  ENDIF
31934  ENDIF
31935 
31936 C...QUARKONIA+++
31937 C...Additional code by Stefan Wolf
31938  ELSE
31939 
31940 C...Common code for quarkonium production.
31941  shth=sh+th
31942  thuh=th+uh
31943  uhsh=uh+sh
31944  shth2=shth**2
31945  thuh2=thuh**2
31946  uhsh2=uhsh**2
31947  IF ( (isub.GE.421.AND.isub.LE.424).OR.
31948  & (isub.GE.431.AND.isub.LE.433)) THEN
31949  sqmqq=sqm3
31950  ELSEIF((isub.GE.425.AND.isub.LE.430).OR.
31951  & (isub.GE.434.AND.isub.LE.439)) THEN
31952  sqmqq=sqm4
31953  ENDIF
31954  sqmqqr=sqrt(sqmqq)
31955  IF(mstp(145).EQ.1) THEN
31956  IF ( (isub.GE.421.AND.isub.LE.427).OR.
31957  & (isub.GE.431.AND.isub.LE.436)) THEN
31958  aq=uhsh/(2d0*x(1)) + shth/(2d0*x(2))
31959  bq=uhsh/(2d0*x(1)) - shth/(2d0*x(2))
31960  atilk1=x(1)*vint(2)/2d0-uhsh/(2d0*sqmqq)*aq
31961  atilk2=x(2)*vint(2)/2d0-shth/(2d0*sqmqq)*aq
31962  btilk1=-x(1)*vint(2)/2d0-uhsh/(2d0*sqmqq)*bq
31963  btilk2=x(2)*vint(2)/2d0-shth/(2d0*sqmqq)*bq
31964  ELSEIF( (isub.GE.428.AND.isub.LE.430).OR.
31965  & isub.GE.437) THEN
31966  aq=shth/(2d0*x(1)) + uhsh/(2d0*x(2))
31967  bq=shth/(2d0*x(1)) - uhsh/(2d0*x(2))
31968  atilk1=x(1)*vint(2)/2d0-shth/(2d0*sqmqq)*aq
31969  atilk2=x(2)*vint(2)/2d0-uhsh/(2d0*sqmqq)*aq
31970  btilk1=-x(1)*vint(2)/2d0-shth/(2d0*sqmqq)*bq
31971  btilk2=x(2)*vint(2)/2d0-uhsh/(2d0*sqmqq)*bq
31972  ENDIF
31973  aq2=aq**2
31974  bq2=bq**2
31975  smqq2=sqmqq*vint(2)
31976 C...Polarisation frames
31977  IF(mstp(146).EQ.1) THEN
31978 C...Recoil frame
31979  polh1=sqrt(aq2-smqq2)
31980  polh2=sqrt(vint(2)*(aq2-bq2-smqq2))
31981  az=-sqmqqr/polh1
31982  bz=0d0
31983  ax=aq*bq/(polh1*polh2)
31984  bx=-polh1/polh2
31985  ELSEIF(mstp(146).EQ.2) THEN
31986 C...Gottfried Jackson frame
31987  polh1=aq+bq
31988  polh2=polh1*sqrt(vint(2)*(aq2-bq2-smqq2))
31989  az=sqmqqr/polh1
31990  bz=az
31991  ax=-(bq2+aq*bq+smqq2)/polh2
31992  bx=(aq2+aq*bq-smqq2)/polh2
31993  ELSEIF(mstp(146).EQ.3) THEN
31994 C...Target frame
31995  polh1=aq-bq
31996  polh2=polh1*sqrt(vint(2)*(aq2-bq2-smqq2))
31997  az=-sqmqqr/polh1
31998  bz=-az
31999  ax=-(bq2-aq*bq+smqq2)/polh2
32000  bx=-(aq2-aq*bq-smqq2)/polh2
32001  ELSEIF(mstp(146).EQ.4) THEN
32002 C...Collins Soper frame
32003  polh1=aq2-bq2
32004  polh2=sqrt(vint(2)*polh1)
32005  az=-bq/polh2
32006  bz=aq/polh2
32007  ax=-sqmqqr*aq/sqrt(polh1*(polh1-smqq2))
32008  bx=sqmqqr*bq/sqrt(polh1*(polh1-smqq2))
32009  ENDIF
32010 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
32011  el1k10=az*atilk1+bz*btilk1
32012  el1k20=az*atilk2+bz*btilk2
32013  el2k10=el1k10
32014  el2k20=el1k20
32015  el1k11=1d0/sqrt(2d0)*(ax*atilk1+bx*btilk1)
32016  el1k21=1d0/sqrt(2d0)*(ax*atilk2+bx*btilk2)
32017  el2k11=el1k11
32018  el2k21=el1k21
32019  ENDIF
32020 
32021  IF(isub.EQ.421) THEN
32022 C...g + g -> QQ~[3S11] + g
32023  IF(mstp(145).EQ.0) THEN
32024 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32025 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
32026  facqqg=comfac*paru(1)*as**3*(10d0/81d0)*sqmqqr*
32027  & (sh2*thuh2+th2*uhsh2+uh2*shth2)/shth2/thuh2/uhsh2
32028 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32029 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
32030  ELSE
32031  ff=-paru(1)*as**3*(10d0/81d0)*sqmqqr/thuh2/shth2/uhsh2
32032  aa=(shth2*uh2+uhsh2*th2+thuh2*sh2)/2d0
32033  bb=2d0*(sh2+th2)
32034  cc=2d0*(sh2+uh2)
32035  dd=2d0*sh2
32036  IF(mstp(147).EQ.0) THEN
32037  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32038  & +dd*(el1k10*el2k20+el1k20*el2k10))
32039  ELSEIF(mstp(147).EQ.1) THEN
32040  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32041  & +dd*(el1k11*el2k21+el1k21*el2k11)))
32042  ELSEIF(mstp(147).EQ.3) THEN
32043  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32044  & +dd*(el1k10*el2k20+el1k20*el2k10))
32045  ELSEIF(mstp(147).EQ.4) THEN
32046  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32047  & +dd*(el1k11*el2k21+el1k21*el2k11))
32048  ELSEIF(mstp(147).EQ.5) THEN
32049  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
32050  & +dd*(el1k11*el2k20+el1k21*el2k10))
32051  ELSEIF(mstp(147).EQ.6) THEN
32052  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32053  & +dd*(el1k11*el2k21+el1k21*el2k11))
32054  ENDIF
32055  facqqg=comfac*ff*facqqg
32056  ENDIF
32057  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32058  nchn=nchn+1
32059  isig(nchn,1)=21
32060  isig(nchn,2)=21
32061  isig(nchn,3)=1
32062  sigh(nchn)=facqqg*parp(ionium+1)
32063  ENDIF
32064 
32065  ELSEIF(isub.EQ.422) THEN
32066 C...g + g -> QQ~[3S18] + g
32067  IF(mstp(145).EQ.0) THEN
32068  facqqg=-comfac*paru(1)*as**3*(1d0/72d0)*
32069  & (16d0*sqmqq**2-27d0*(shth2+thuh2+uhsh2))/
32070  & (sqmqq*sqmqqr)*
32071  & ((sh2*thuh2+th2*uhsh2+uh2*shth2)/shth2/thuh2/uhsh2)
32072  ELSE
32073  ff=paru(1)*as**3*(16d0*sqmqq**2-27d0*(shth2+thuh2+uhsh2))/
32074  & (72d0*sqmqq*sqmqqr*shth2*thuh2*uhsh2)
32075  aa=(shth2*uh2+uhsh2*th2+thuh2*sh2)/2d0
32076  bb=2d0*(sh2+th2)
32077  cc=2d0*(sh2+uh2)
32078  dd=2d0*sh2
32079  IF(mstp(147).EQ.0) THEN
32080  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32081  & +dd*(el1k10*el2k20+el1k20*el2k10))
32082  ELSEIF(mstp(147).EQ.1) THEN
32083  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32084  & +dd*(el1k11*el2k21+el1k21*el2k11)))
32085  ELSEIF(mstp(147).EQ.3) THEN
32086  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32087  & +dd*(el1k10*el2k20+el1k20*el2k10))
32088  ELSEIF(mstp(147).EQ.4) THEN
32089  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32090  & +dd*(el1k11*el2k21+el1k21*el2k11))
32091  ELSEIF(mstp(147).EQ.5) THEN
32092  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
32093  & +dd*(el1k11*el2k20+el1k21*el2k10))
32094  ELSEIF(mstp(147).EQ.6) THEN
32095  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32096  & +dd*(el1k11*el2k21+el1k21*el2k11))
32097  ENDIF
32098  facqqg=comfac*ff*facqqg
32099  ENDIF
32100 C...Split total contribution into different colour flows just like
32101 C...in g g -> g g (recalculate kinematics for massless partons).
32102  thp=-0.5d0*sh*(1d0-cth)
32103  uhp=-0.5d0*sh*(1d0+cth)
32104  facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
32105  facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
32106  facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
32107  facggs=facgg1+facgg2+facgg3
32108  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32109  nchn=nchn+1
32110  isig(nchn,1)=21
32111  isig(nchn,2)=21
32112  isig(nchn,3)=1
32113  sigh(nchn)=facqqg*parp(ionium+2)*facgg1/facggs
32114  nchn=nchn+1
32115  isig(nchn,1)=21
32116  isig(nchn,2)=21
32117  isig(nchn,3)=2
32118  sigh(nchn)=facqqg*parp(ionium+2)*facgg2/facggs
32119  nchn=nchn+1
32120  isig(nchn,1)=21
32121  isig(nchn,2)=21
32122  isig(nchn,3)=3
32123  sigh(nchn)=facqqg*parp(ionium+2)*facgg3/facggs
32124  ENDIF
32125 
32126  ELSEIF(isub.EQ.423) THEN
32127 C...g + g -> QQ~[1S08] + g
32128  IF(mstp(145).EQ.0) THEN
32129 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
32130 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
32131 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
32132 * & (SHTH2*THUH2*UHSH2)
32133  facqqg=comfac*paru(1)*as**3*(5d0/16d0)*sqmqqr*
32134  & (uh2/(thuh2*uhsh2)+sh2/(shth2*uhsh2)+
32135  & th2/(shth2*thuh2))*
32136  & (12d0+(shth2**2+thuh2**2+uhsh2**2)/(sqmqq*sh*th*uh))
32137  ELSE
32138  fa=paru(1)*as**3*(5d0/48d0)*sqmqqr*
32139  & (uh2/(thuh2*uhsh2)+sh2/(shth2*uhsh2)+
32140  & th2/(shth2*thuh2))*
32141  & (12d0+(shth2**2+thuh2**2+uhsh2**2)/(sqmqq*sh*th*uh))
32142  IF(mstp(147).EQ.0) THEN
32143  facqqg=comfac*fa
32144  ELSEIF(mstp(147).EQ.1) THEN
32145  facqqg=comfac*2d0*fa
32146  ELSEIF(mstp(147).EQ.3) THEN
32147  facqqg=comfac*fa
32148  ELSEIF(mstp(147).EQ.4) THEN
32149  facqqg=comfac*fa
32150  ELSEIF(mstp(147).EQ.5) THEN
32151  facqqg=0d0
32152  ELSEIF(mstp(147).EQ.6) THEN
32153  facqqg=0d0
32154  ENDIF
32155  ENDIF
32156 C...Split total contribution into different colour flows just like
32157 C...in g g -> g g (recalculate kinematics for massless partons).
32158  thp=-0.5d0*sh*(1d0-cth)
32159  uhp=-0.5d0*sh*(1d0+cth)
32160  facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
32161  facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
32162  facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
32163  facggs=facgg1+facgg2+facgg3
32164  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32165  nchn=nchn+1
32166  isig(nchn,1)=21
32167  isig(nchn,2)=21
32168  isig(nchn,3)=1
32169  sigh(nchn)=facqqg*parp(ionium+3)*facgg1/facggs
32170  nchn=nchn+1
32171  isig(nchn,1)=21
32172  isig(nchn,2)=21
32173  isig(nchn,3)=2
32174  sigh(nchn)=facqqg*parp(ionium+3)*facgg2/facggs
32175  nchn=nchn+1
32176  isig(nchn,1)=21
32177  isig(nchn,2)=21
32178  isig(nchn,3)=3
32179  sigh(nchn)=facqqg*parp(ionium+3)*facgg3/facggs
32180  ENDIF
32181 
32182  ELSEIF(isub.EQ.424) THEN
32183 C...g + g -> QQ~[3PJ8] + g
32184  poly=sh2+sh*th+th2
32185  IF(mstp(145).EQ.0) THEN
32186  facqqg=comfac*5d0*paru(1)*as**3*(3d0*sh*th*shth*poly**4
32187  & -sqmqq*poly**2*(7d0*sh**6+36d0*sh**5*th+45d0*sh**4*th2
32188  & +28d0*sh**3*th**3+45d0*sh2*th**4+36d0*sh*th**5
32189  & +7d0*th**6)
32190  & +sqmqq**2*shth*(35d0*sh**8+169d0*sh**7*th
32191  & +299d0*sh**6*th2+401d0*sh**5*th**3+418d0*sh**4*th**4
32192  & +401d0*sh**3*th**5+299d0*sh2*th**6+169d0*sh*th**7
32193  & +35d0*th**8)
32194  & -sqmqq**3*(84d0*sh**8+432d0*sh**7*th+905d0*sh**6*th2
32195  & +1287d0*sh**5*th**3+1436d0*sh**4*th**4
32196  & +1287d0*sh**3*th**5+905d0*sh2*th**6+432d0*sh*th**7
32197  & +84d0*th**8)
32198  & +sqmqq**4*shth*(126d0*sh**6+451d0*sh**5*th
32199  & +677d0*sh**4*th2+836d0*sh**3*th**3+677d0*sh2*th**4
32200  & +451d0*sh*th**5+126d0*th**6)
32201  & -3d0*sqmqq**5*(42d0*sh**6+171d0*sh**5*th
32202  & +304d0*sh**4*th2+362d0*sh**3*th**3+304d0*sh2*th**4
32203  & +171d0*sh*th**5+42d0*th**6)
32204  & +2d0*sqmqq**6*shth*(42d0*sh**4+106d0*sh**3*th
32205  & +119d0*sh2*th2+106d0*sh*th**3+42d0*th**4)
32206  & -sqmqq**7*(35d0*sh**4+99d0*sh**3*th+120d0*sh2*th2
32207  & +99d0*sh*th**3+35d0*th**4)
32208  & +7d0*sqmqq**8*shth*poly)/
32209  & (sh*th*uh*sqmqqr*sqmqq*
32210  & shth*shth2*thuh*thuh2*uhsh*uhsh2)
32211  ELSE
32212  ff=-5d0*paru(1)*as**3/(sh2*th2*uh2
32213  & *sqmqqr*sqmqq*shth*shth2*thuh*thuh2*uhsh*uhsh2)
32214  aa=sh*th*uh*(sh*th*shth*poly**4
32215  & -sqmqq*shth2*poly**2*
32216  & (sh**4+6d0*sh**3*th-6d0*sh2*th2+6d0*sh*th**3+th**4)
32217  & +sqmqq**2*shth*(5d0*sh**8+35d0*sh**7*th+49d0*sh**6*th2
32218  & +57d0*sh**5*th**3+46d0*sh**4*th**4+57d0*sh**3*th**5
32219  & +49d0*sh2*th**6+35d0*sh*th**7+5d0*th**8)
32220  & -sqmqq**3*(16d0*sh**8+104d0*sh**7*th+215d0*sh**6*th2
32221  & +291d0*sh**5*th**3+316d0*sh**4*th**4+291d0*sh**3*th**5
32222  & +215d0*sh2*th**6+104d0*sh*th**7+16d0*th**8)
32223  & +sqmqq**4*shth*(34d0*sh**6+145d0*sh**5*th
32224  & +211d0*sh**4*th2+262d0*sh**3*th**3+211d0*sh2*th**4
32225  & +145d0*sh*th**5+34d0*th**6)
32226  & -sqmqq**5*(44d0*sh**6+193d0*sh**5*th+346d0*sh**4*th2
32227  & +410d0*sh**3*th**3+346d0*sh2*th**4+193d0*sh*th**5
32228  & +44d0*th**6)
32229  & +2d0*sqmqq**6*shth*(17d0*sh**4+45d0*sh**3*th
32230  & +49d0*sh2*th2+45d0*sh*th**3+17d0*th**4)
32231  & -sqmqq**7*(3d0*sh2+2d0*sh*th+3d0*th2)
32232  & *(5d0*sh2+11d0*sh*th+5d0*th2)
32233  & +3d0*sqmqq**8*shth*poly)
32234  bb=4d0*shth2*poly**3
32235  & *(sh**4+sh**3*th-sh2*th2+sh*th**3+th**4)
32236  & -sqmqq*shth*(20d0*sh**10+84d0*sh**9*th+166d0*sh**8*th2
32237  & +231d0*sh**7*th**3+250d0*sh**6*th**4+250d0*sh**5*th**5
32238  & +250d0*sh**4*th**6+231d0*sh**3*th**7+166d0*sh2*th**8
32239  & +84d0*sh*th**9+20d0*th**10)
32240  & +sqmqq**2*shth2*(40d0*sh**8+86d0*sh**7*th
32241  & +66d0*sh**6*th2+67d0*sh**5*th**3+6d0*sh**4*th**4
32242  & +67d0*sh**3*th**5+66d0*sh2*th**6+86d0*sh*th**7
32243  & +40d0*th**8)
32244  & -sqmqq**3*shth*(40d0*sh**8+57d0*sh**7*th
32245  & -110d0*sh**6*th2-263d0*sh**5*th**3-384d0*sh**4*th**4
32246  & -263d0*sh**3*th**5-110d0*sh2*th**6+57d0*sh*th**7
32247  & +40d0*th**8)
32248  & +sqmqq**4*(20d0*sh**8-33d0*sh**7*th-368d0*sh**6*th2
32249  & -751d0*sh**5*th**3-920d0*sh**4*th**4-751d0*sh**3*th**5
32250  & -368d0*sh2*th**6-33d0*sh*th**7+20d0*th**8)
32251  & -sqmqq**5*shth*(4d0*sh**6-81d0*sh**5*th-242d0*sh**4*th2
32252  & -250d0*sh**3*th**3-242d0*sh2*th**4-81d0*sh*th**5
32253  & +4d0*th**6)
32254  & -sqmqq**6*sh*th*(41d0*sh**4+120d0*sh**3*th
32255  & +142d0*sh2*th2+120d0*sh*th**3+41d0*th**4)
32256  & +8d0*sqmqq**7*sh*th*shth*poly
32257  cc=4d0*th2*poly**3
32258  & *(-sh**4-2d0*sh**3*th+2d0*sh2*th2+3d0*sh*th**3+th**4)
32259  & -sqmqq*th2*(-20d0*sh**9-56d0*sh**8*th-24d0*sh**7*th2
32260  & +147d0*sh**6*th**3+409d0*sh**5*th**4+599d0*sh**4*th**5
32261  & +571d0*sh**3*th**6+370d0*sh2*th**7+148d0*sh*th**8
32262  & +28d0*th**9)
32263  & +sqmqq**2*(4d0*sh**10+20d0*sh**9*th-16d0*sh**8*th2
32264  & -48d0*sh**7*th**3+150d0*sh**6*th**4+611d0*sh**5*th**5
32265  & +1060d0*sh**4*th**6+1155d0*sh**3*th**7+854d0*sh2*th**8
32266  & +394d0*sh*th**9+84d0*th**10)
32267  & -sqmqq**3*shth*(20d0*sh**8+68d0*sh**7*th-20d0*sh**6*th2
32268  & +32d0*sh**5*th**3+286d0*sh**4*th**4+577d0*sh**3*th**5
32269  & +618d0*sh2*th**6+443d0*sh*th**7+140d0*th**8)
32270  & +sqmqq**4*(40d0*sh**8+152d0*sh**7*th+94d0*sh**6*th2
32271  & +38d0*sh**5*th**3+290d0*sh**4*th**4+631d0*sh**3*th**5
32272  & +738d0*sh2*th**6+513d0*sh*th**7+140d0*th**8)
32273  & -sqmqq**5*(40d0*sh**7+129d0*sh**6*th+53d0*sh**5*th2
32274  & +7d0*sh**4*th**3+129d0*sh**3*th**4+264d0*sh2*th**5
32275  & +266d0*sh*th**6+84d0*th**7)
32276  & +sqmqq**6*(20d0*sh**6+55d0*sh**5*th+2d0*sh**4*th2
32277  & -15d0*sh**3*th**3+30d0*sh2*th**4+76d0*sh*th**5
32278  & +28d0*th**6)
32279  & -sqmqq**7*shth*(4d0*sh**4+7d0*sh**3*th-14d0*sh2*th2
32280  & +7d0*sh*th**3+4*th**4)
32281  & +sqmqq**8*sh*(sh-th)**2*th
32282  dd=2d0*th2*shth2*poly**3
32283  & *(-sh2+2*sh*th+2*th2)
32284  & +sqmqq*(4d0*sh**11+22d0*sh**10*th+70d0*sh**9*th2
32285  & +115d0*sh**8*th**3+71d0*sh**7*th**4-119d0*sh**6*th**5
32286  & -381d0*sh**5*th**6-552d0*sh**4*th**7-512d0*sh**3*th**8
32287  & -320d0*sh2*th**9-126d0*sh*th**10-24d0*th**11)
32288  & -sqmqq**2*shth*(20d0*sh**9+84d0*sh**8*th
32289  & +212d0*sh**7*th2+247d0*sh**6*th**3+105d0*sh**5*th**4
32290  & -178d0*sh**4*th**5-380d0*sh**3*th**6-364d0*sh2*th**7
32291  & -210d0*sh*th**8-60d0*th**9)
32292  & +sqmqq**3*shth*(40d0*sh**8+159d0*sh**7*th
32293  & +374d0*sh**6*th2+404d0*sh**5*th**3+192d0*sh**4*th**4
32294  & -141d0*sh**3*th**5-264d0*sh2*th**6-216d0*sh*th**7
32295  & -80d0*th**8)
32296  & -sqmqq**4*(40d0*sh**8+197d0*sh**7*th+506d0*sh**6*th2
32297  & +672d0*sh**5*th**3+460d0*sh**4*th**4+79d0*sh**3*th**5
32298  & -138d0*sh2*th**6-164d0*sh*th**7-60d0*th**8)
32299  & +sqmqq**5*(20d0*sh**7+107d0*sh**6*th+267d0*sh**5*th2
32300  & +307d0*sh**4*th**3+185d0*sh**3*th**4+56d0*sh2*th**5
32301  & -30d0*sh*th**6-24d0*th**7)
32302  & -sqmqq**6*(4d0*sh**6+31d0*sh**5*th+74d0*sh**4*th2
32303  & +71d0*sh**3*th**3+46d0*sh2*th**4+10d0*sh*th**5
32304  & -4d0*th**6)
32305  & +4d0*sqmqq**7*sh*th*shth*poly
32306  IF(mstp(147).EQ.0) THEN
32307  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32308  & +dd*(el1k10*el2k20+el1k20*el2k10))
32309  ELSEIF(mstp(147).EQ.1) THEN
32310  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32311  & +dd*(el1k11*el2k21+el1k21*el2k11)))
32312  ELSEIF(mstp(147).EQ.3) THEN
32313  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32314  & +dd*(el1k10*el2k20+el1k20*el2k10))
32315  ELSEIF(mstp(147).EQ.4) THEN
32316  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32317  & +dd*(el1k11*el2k21+el1k21*el2k11))
32318  ELSEIF(mstp(147).EQ.5) THEN
32319  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
32320  & +dd*(el1k11*el2k20+el1k21*el2k10))
32321  ELSEIF(mstp(147).EQ.6) THEN
32322  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32323  & +dd*(el1k11*el2k21+el1k21*el2k11))
32324  ENDIF
32325  facqqg=comfac*ff*facqqg
32326  ENDIF
32327 C...Split total contribution into different colour flows just like
32328 C...in g g -> g g (recalculate kinematics for massless partons).
32329  thp=-0.5d0*sh*(1d0-cth)
32330  uhp=-0.5d0*sh*(1d0+cth)
32331  facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
32332  facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
32333  facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
32334  facggs=facgg1+facgg2+facgg3
32335  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32336  nchn=nchn+1
32337  isig(nchn,1)=21
32338  isig(nchn,2)=21
32339  isig(nchn,3)=1
32340  sigh(nchn)=facqqg*parp(ionium+4)*facgg1/facggs
32341  nchn=nchn+1
32342  isig(nchn,1)=21
32343  isig(nchn,2)=21
32344  isig(nchn,3)=2
32345  sigh(nchn)=facqqg*parp(ionium+4)*facgg2/facggs
32346  nchn=nchn+1
32347  isig(nchn,1)=21
32348  isig(nchn,2)=21
32349  isig(nchn,3)=3
32350  sigh(nchn)=facqqg*parp(ionium+4)*facgg3/facggs
32351  ENDIF
32352 
32353  ELSEIF(isub.EQ.425) THEN
32354 C...q + g -> q + QQ~[3S18]
32355  IF(mstp(145).EQ.0) THEN
32356  facqqg=-comfac*paru(1)*as**3*(1d0/27d0)*
32357  & (4d0*(sh2+uh2)-sh*uh)*(shth2+thuh2)/
32358  & (sqmqq*sqmqqr*sh*uh*uhsh2)
32359  ELSE
32360  ff=paru(1)*as**3*(4d0*(sh2+uh2)-sh*uh)/
32361  & (54d0*sqmqq*sqmqqr*sh*uh*uhsh2)
32362  aa=shth2+thuh2
32363  bb=4d0
32364  cc=8d0
32365  dd=4d0
32366  IF(mstp(147).EQ.0) THEN
32367  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32368  & +dd*(el1k10*el2k20+el1k20*el2k10))
32369  ELSEIF(mstp(147).EQ.1) THEN
32370  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32371  & +dd*(el1k11*el2k21+el1k21*el2k11)))
32372  ELSEIF(mstp(147).EQ.3) THEN
32373  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32374  & +dd*(el1k10*el2k20+el1k20*el2k10))
32375  ELSEIF(mstp(147).EQ.4) THEN
32376  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32377  & +dd*(el1k11*el2k21+el1k21*el2k11))
32378  ELSEIF(mstp(147).EQ.5) THEN
32379  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
32380  & +dd*(el1k11*el2k20+el1k21*el2k10))
32381  ELSEIF(mstp(147).EQ.6) THEN
32382  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32383  & +dd*(el1k11*el2k21+el1k21*el2k11))
32384  ENDIF
32385  facqqg=comfac*ff*facqqg
32386  ENDIF
32387 C...Split total contribution into different colour flows just like
32388 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32389 C...(recalculate kinematics for massless partons).
32390  thp=-0.5d0*sh*(1d0-cth)
32391  uhp=-0.5d0*sh*(1d0+cth)
32392  facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
32393  facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
32394  facqgs=facqg1+facqg2
32395  DO 2442 i=mmina,mmaxa
32396  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 2442
32397  DO 2441 isde=1,2
32398  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 2441
32399  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 2441
32400  nchn=nchn+1
32401  isig(nchn,isde)=i
32402  isig(nchn,3-isde)=21
32403  isig(nchn,3)=1
32404  sigh(nchn)=facqqg*parp(ionium+2)*facqg1/facqgs
32405  nchn=nchn+1
32406  isig(nchn,isde)=i
32407  isig(nchn,3-isde)=21
32408  isig(nchn,3)=2
32409  sigh(nchn)=facqqg*parp(ionium+2)*facqg2/facqgs
32410  2441 CONTINUE
32411  2442 CONTINUE
32412 
32413  ELSEIF(isub.EQ.426) THEN
32414 C...q + g -> q + QQ~[1S08]
32415  IF(mstp(145).EQ.0) THEN
32416  facqqg=-comfac*paru(1)*as**3*(5d0/18d0)*
32417  & (sh2+uh2)/(sqmqqr*th*uhsh2)
32418  ELSE
32419  fa=-paru(1)*as**3*(5d0/54d0)*(sh2+uh2)/(sqmqqr*th*uhsh2)
32420  IF(mstp(147).EQ.0) THEN
32421  facqqg=comfac*fa
32422  ELSEIF(mstp(147).EQ.1) THEN
32423  facqqg=comfac*2d0*fa
32424  ELSEIF(mstp(147).EQ.3) THEN
32425  facqqg=comfac*fa
32426  ELSEIF(mstp(147).EQ.4) THEN
32427  facqqg=comfac*fa
32428  ELSEIF(mstp(147).EQ.5) THEN
32429  facqqg=0d0
32430  ELSEIF(mstp(147).EQ.6) THEN
32431  facqqg=0d0
32432  ENDIF
32433  ENDIF
32434 C...Split total contribution into different colour flows just like
32435 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32436 C...(recalculate kinematics for massless partons).
32437  thp=-0.5d0*sh*(1d0-cth)
32438  uhp=-0.5d0*sh*(1d0+cth)
32439  facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
32440  facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
32441  facqgs=facqg1+facqg2
32442  DO 2444 i=mmina,mmaxa
32443  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 2444
32444  DO 2443 isde=1,2
32445  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 2443
32446  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 2443
32447  nchn=nchn+1
32448  isig(nchn,isde)=i
32449  isig(nchn,3-isde)=21
32450  isig(nchn,3)=1
32451  sigh(nchn)=facqqg*parp(ionium+3)*facqg1/facqgs
32452  nchn=nchn+1
32453  isig(nchn,isde)=i
32454  isig(nchn,3-isde)=21
32455  isig(nchn,3)=2
32456  sigh(nchn)=facqqg*parp(ionium+3)*facqg2/facqgs
32457  2443 CONTINUE
32458  2444 CONTINUE
32459 
32460  ELSEIF(isub.EQ.427) THEN
32461 C...q + g -> q + QQ~[3PJ8]
32462  IF(mstp(145).EQ.0) THEN
32463  facqqg=-comfac*paru(1)*as**3*(10d0/9d0)*
32464  & ((7d0*uhsh+8d0*th)*(sh2+uh2)
32465  & +4d0*th*(2d0*sqmqq**2-shth2-thuh2))/
32466  & (sqmqq*sqmqqr*th*uhsh2*uhsh)
32467  ELSE
32468  ff=10d0*paru(1)*as**3/
32469  & (9d0*sqmqq*sqmqqr*th2*uhsh2*uhsh)
32470  aa=th*uhsh*(2d0*sqmqq**2+shth2+thuh2)
32471  bb=8d0*(shth2+th*uh)
32472  cc=8d0*uhsh*(shth+thuh)
32473  dd=4d0*(2d0*sqmqq*sh+th*uhsh)
32474  IF(mstp(147).EQ.0) THEN
32475  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32476  & +dd*(el1k10*el2k20+el1k20*el2k10))
32477  ELSEIF(mstp(147).EQ.1) THEN
32478  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32479  & +dd*(el1k11*el2k21+el1k21*el2k11)))
32480  ELSEIF(mstp(147).EQ.3) THEN
32481  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32482  & +dd*(el1k10*el2k20+el1k20*el2k10))
32483  ELSEIF(mstp(147).EQ.4) THEN
32484  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32485  & +dd*(el1k11*el2k21+el1k21*el2k11))
32486  ELSEIF(mstp(147).EQ.5) THEN
32487  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
32488  & +dd*(el1k11*el2k20+el1k21*el2k10))
32489  ELSEIF(mstp(147).EQ.6) THEN
32490  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32491  & +dd*(el1k11*el2k21+el1k21*el2k11))
32492  ENDIF
32493  facqqg=comfac*ff*facqqg
32494  ENDIF
32495 C...Split total contribution into different colour flows just like
32496 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32497 C...(recalculate kinematics for massless partons).
32498  thp=-0.5d0*sh*(1d0-cth)
32499  uhp=-0.5d0*sh*(1d0+cth)
32500  facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
32501  facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
32502  facqgs=facqg1+facqg2
32503  DO 2446 i=mmina,mmaxa
32504  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 2446
32505  DO 2445 isde=1,2
32506  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 2445
32507  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 2445
32508  nchn=nchn+1
32509  isig(nchn,isde)=i
32510  isig(nchn,3-isde)=21
32511  isig(nchn,3)=1
32512  sigh(nchn)=facqqg*parp(ionium+4)*facqg1/facqgs
32513  nchn=nchn+1
32514  isig(nchn,isde)=i
32515  isig(nchn,3-isde)=21
32516  isig(nchn,3)=2
32517  sigh(nchn)=facqqg*parp(ionium+4)*facqg2/facqgs
32518  2445 CONTINUE
32519  2446 CONTINUE
32520 
32521  ELSEIF(isub.EQ.428) THEN
32522 C...q + q~ -> g + QQ~[3S18]
32523  IF(mstp(145).EQ.0) THEN
32524  facqqg=comfac*paru(1)*as**3*(8d0/81d0)*
32525  & (4d0*(th2+uh2)-th*uh)*(shth2+uhsh2)/
32526  & (sqmqq*sqmqqr*th*uh*thuh2)
32527  ELSE
32528  ff=-4d0*paru(1)*as**3*(4d0*(th2+uh2)-th*uh)/
32529  & (81d0*sqmqq*sqmqqr*th*uh*thuh2)
32530  aa=shth2+uhsh2
32531  bb=4d0
32532  cc=4d0
32533  dd=0d0
32534  IF(mstp(147).EQ.0) THEN
32535  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32536  & +dd*(el1k10*el2k20+el1k20*el2k10))
32537  ELSEIF(mstp(147).EQ.1) THEN
32538  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32539  & +dd*(el1k11*el2k21+el1k21*el2k11)))
32540  ELSEIF(mstp(147).EQ.3) THEN
32541  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32542  & +dd*(el1k10*el2k20+el1k20*el2k10))
32543  ELSEIF(mstp(147).EQ.4) THEN
32544  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32545  & +dd*(el1k11*el2k21+el1k21*el2k11))
32546  ELSEIF(mstp(147).EQ.5) THEN
32547  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
32548  & +dd*(el1k11*el2k20+el1k21*el2k10))
32549  ELSEIF(mstp(147).EQ.6) THEN
32550  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32551  & +dd*(el1k11*el2k21+el1k21*el2k11))
32552  ENDIF
32553  facqqg=comfac*ff*facqqg
32554  ENDIF
32555 C...Split total contribution into different colour flows just like
32556 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32557 C...(recalculate kinematics for massless partons).
32558  thp=-0.5d0*sh*(1d0-cth)
32559  uhp=-0.5d0*sh*(1d0+cth)
32560  facgg1=uh/th-9d0/4d0*uh2/sh2
32561  facgg2=th/uh-9d0/4d0*th2/sh2
32562  facggs=facgg1+facgg2
32563  DO 2447 i=mmina,mmaxa
32564  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32565  & kfac(1,i)*kfac(2,-i).EQ.0) goto 2447
32566  nchn=nchn+1
32567  isig(nchn,1)=i
32568  isig(nchn,2)=-i
32569  isig(nchn,3)=1
32570  sigh(nchn)=facqqg*parp(ionium+2)*facgg1/facggs
32571  nchn=nchn+1
32572  isig(nchn,1)=i
32573  isig(nchn,2)=-i
32574  isig(nchn,3)=2
32575  sigh(nchn)=facqqg*parp(ionium+2)*facgg2/facggs
32576  2447 CONTINUE
32577 
32578  ELSEIF(isub.EQ.429) THEN
32579 C...q + q~ -> g + QQ~[1S08]
32580  IF(mstp(145).EQ.0) THEN
32581  facqqg=comfac*paru(1)*as**3*(20d0/27d0)*
32582  & (th2+uh2)/(sqmqqr*sh*thuh2)
32583  ELSE
32584  fa=paru(1)*as**3*(20d0/81d0)*(th2+uh2)/(sqmqqr*sh*thuh2)
32585  IF(mstp(147).EQ.0) THEN
32586  facqqg=comfac*fa
32587  ELSEIF(mstp(147).EQ.1) THEN
32588  facqqg=comfac*2d0*fa
32589  ELSEIF(mstp(147).EQ.3) THEN
32590  facqqg=comfac*fa
32591  ELSEIF(mstp(147).EQ.4) THEN
32592  facqqg=comfac*fa
32593  ELSEIF(mstp(147).EQ.5) THEN
32594  facqqg=0d0
32595  ELSEIF(mstp(147).EQ.6) THEN
32596  facqqg=0d0
32597  ENDIF
32598  ENDIF
32599 C...Split total contribution into different colour flows just like
32600 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32601 C...(recalculate kinematics for massless partons).
32602  thp=-0.5d0*sh*(1d0-cth)
32603  uhp=-0.5d0*sh*(1d0+cth)
32604  facgg1=uh/th-9d0/4d0*uh2/sh2
32605  facgg2=th/uh-9d0/4d0*th2/sh2
32606  facggs=facgg1+facgg2
32607  DO 2448 i=mmina,mmaxa
32608  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32609  & kfac(1,i)*kfac(2,-i).EQ.0) goto 2448
32610  nchn=nchn+1
32611  isig(nchn,1)=i
32612  isig(nchn,2)=-i
32613  isig(nchn,3)=1
32614  sigh(nchn)=facqqg*parp(ionium+3)*facgg1/facggs
32615  nchn=nchn+1
32616  isig(nchn,1)=i
32617  isig(nchn,2)=-i
32618  isig(nchn,3)=2
32619  sigh(nchn)=facqqg*parp(ionium+3)*facgg2/facggs
32620  2448 CONTINUE
32621 
32622  ELSEIF(isub.EQ.430) THEN
32623 C...q + q~ -> g + QQ~[3PJ8]
32624  IF(mstp(145).EQ.0) THEN
32625  facqqg=comfac*paru(1)*as**3*(80d0/27d0)*
32626  & ((7d0*thuh+8d0*sh)*(th2+uh2)
32627  & +4d0*sh*(2d0*sqmqq**2-shth2-uhsh2))/
32628  & (sqmqq*sqmqqr*sh*thuh2*thuh)
32629  ELSE
32630  ff=-80d0*paru(1)*as**3/(27d0*sqmqq*sqmqqr*sh2*thuh2*thuh)
32631  aa=sh*thuh*(2d0*sqmqq**2+shth2+uhsh2)
32632  bb=8d0*(uhsh2+sh*th)
32633  cc=8d0*(shth2+sh*uh)
32634  dd=4d0*(shth2+uhsh2+sh*sqmqq-sqmqq**2)
32635  IF(mstp(147).EQ.0) THEN
32636  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32637  & +dd*(el1k10*el2k20+el1k20*el2k10))
32638  ELSEIF(mstp(147).EQ.1) THEN
32639  facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32640  & +dd*(el1k11*el2k21+el1k21*el2k11)))
32641  ELSEIF(mstp(147).EQ.3) THEN
32642  facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
32643  & +dd*(el1k10*el2k20+el1k20*el2k10))
32644  ELSEIF(mstp(147).EQ.4) THEN
32645  facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32646  & +dd*(el1k11*el2k21+el1k21*el2k11))
32647  ELSEIF(mstp(147).EQ.5) THEN
32648  facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
32649  & +dd*(el1k11*el2k20+el1k21*el2k10))
32650  ELSEIF(mstp(147).EQ.6) THEN
32651  facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
32652  & +dd*(el1k11*el2k21+el1k21*el2k11))
32653  ENDIF
32654  facqqg=comfac*ff*facqqg
32655  ENDIF
32656 C...Split total contribution into different colour flows just like
32657 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32658 C...(recalculate kinematics for massless partons).
32659  thp=-0.5d0*sh*(1d0-cth)
32660  uhp=-0.5d0*sh*(1d0+cth)
32661  facgg1=uh/th-9d0/4d0*uh2/sh2
32662  facgg2=th/uh-9d0/4d0*th2/sh2
32663  facggs=facgg1+facgg2
32664  DO 2449 i=mmina,mmaxa
32665  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32666  & kfac(1,i)*kfac(2,-i).EQ.0) goto 2449
32667  nchn=nchn+1
32668  isig(nchn,1)=i
32669  isig(nchn,2)=-i
32670  isig(nchn,3)=1
32671  sigh(nchn)=facqqg*parp(ionium+4)*facgg1/facggs
32672  nchn=nchn+1
32673  isig(nchn,1)=i
32674  isig(nchn,2)=-i
32675  isig(nchn,3)=2
32676  sigh(nchn)=facqqg*parp(ionium+4)*facgg2/facggs
32677  2449 CONTINUE
32678 
32679  ELSEIF(isub.EQ.431) THEN
32680 C...g + g -> QQ~[3P01] + g
32681  pgtw=(sh*th+th*uh+uh*sh)/sh2
32682  qgtw=(sh*th*uh)/sh**3
32683  rgtw=sqmqq/sh
32684  IF(mstp(145).EQ.0) THEN
32685  facqqg=comfac*paru(1)*as**3*8d0/(9d0*sqmqqr*sh)*
32686  & (9d0*rgtw**2*pgtw**4*
32687  & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
32688  & -6d0*rgtw*pgtw**3*qgtw*
32689  & (2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)
32690  & -pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)
32691  & +2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)
32692  & +6d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
32693  ELSE
32694  fc1=paru(1)*as**3*8d0/(27d0*sqmqqr*sh)*
32695  & (9d0*rgtw**2*pgtw**4*
32696  & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
32697  & -6d0*rgtw*pgtw**3*qgtw*
32698  & (2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)
32699  & -pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)
32700  & +2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)
32701  & +6d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
32702  IF(mstp(147).EQ.0) THEN
32703  facqqg=comfac*fc1
32704  ELSEIF(mstp(147).EQ.1) THEN
32705  facqqg=comfac*2d0*fc1
32706  ELSEIF(mstp(147).EQ.3) THEN
32707  facqqg=comfac*fc1
32708  ELSEIF(mstp(147).EQ.4) THEN
32709  facqqg=comfac*fc1
32710  ELSEIF(mstp(147).EQ.5) THEN
32711  facqqg=0d0
32712  ELSEIF(mstp(147).EQ.6) THEN
32713  facqqg=0d0
32714  ENDIF
32715  ENDIF
32716  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32717  nchn=nchn+1
32718  isig(nchn,1)=21
32719  isig(nchn,2)=21
32720  isig(nchn,3)=1
32721  sigh(nchn)=facqqg*parp(ionium+5)
32722  ENDIF
32723 
32724  ELSEIF(isub.EQ.432) THEN
32725 C...g + g -> QQ~[3P11] + g
32726  pgtw=(sh*th+th*uh+uh*sh)/sh2
32727  qgtw=(sh*th*uh)/sh**3
32728  rgtw=sqmqq/sh
32729  IF(mstp(145).EQ.0) THEN
32730  facqqg=comfac*paru(1)*as**3*8d0/(3d0*sqmqqr*sh)*
32731  & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)
32732  & +2d0*qgtw*(-rgtw**4+5d0*rgtw**2*pgtw+pgtw**2)
32733  & -15d0*rgtw*qgtw**2)/(qgtw-rgtw*pgtw)**4
32734  ELSE
32735  ff=4d0/3d0*paru(1)*as**3*sqmqqr/shth2**2/thuh2**2/uhsh2**2
32736  c1=(4d0*pgtw**5+23d0*pgtw**2*qgtw**2
32737  & +(-14d0*pgtw**3*qgtw+3d0*qgtw**3)*rgtw
32738  & -(pgtw**4+2d0*pgtw*qgtw**2)*rgtw**2
32739  & +3d0*pgtw**2*qgtw*rgtw**3)*sh2**5
32740  c2=2d0*shth2*(sh2*thuh*(sh*thuh*(sh-th)*(sh-uh)
32741  & -th*uh*(th-uh)**2)+sh2**2*(th-uh)*(th2+uh2-sh*thuh)
32742  & *(pgtw**2-qgtw*(sh+2d0*uh)/sh))
32743  c3=2d0*uhsh2*(sh2*thuh*(sh*thuh*(sh-th)*(sh-uh)
32744  & -th*uh*(th-uh)**2)-sh2**2*(th-uh)*(th2+uh2-sh*thuh)
32745  & *(pgtw**2-qgtw*(sh+2d0*th)/sh))
32746  c4=-4d0*thuh*(th-uh)**2*
32747  & (th**3*uh**3+sh2**2*(2d0*th+uh)*(th+2d0*uh)
32748  & -sh2*th*uh*(th2+uh2))
32749  & +4d0*thuh2*(sh**3*(sh2**2+th2**2+uh2**2)
32750  & -sh*th*uh*(sh2**2+th*uh*(th2-3d0*th*uh+uh2)
32751  & +sh2*(5d0*thuh2-17d0*th*uh)))
32752  IF(mstp(147).EQ.0) THEN
32753  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32754  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32755  ELSEIF(mstp(147).EQ.1) THEN
32756  facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32757  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32758  ELSEIF(mstp(147).EQ.3) THEN
32759  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32760  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32761  ELSEIF(mstp(147).EQ.4) THEN
32762  facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32763  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32764  ELSEIF(mstp(147).EQ.5) THEN
32765  facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32766  & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32767  ELSEIF(mstp(147).EQ.6) THEN
32768  facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32769  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32770  ENDIF
32771  facqqg=comfac*ff*facqqg
32772  ENDIF
32773  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32774  nchn=nchn+1
32775  isig(nchn,1)=21
32776  isig(nchn,2)=21
32777  isig(nchn,3)=1
32778  sigh(nchn)=facqqg*parp(ionium+5)
32779  ENDIF
32780 
32781  ELSEIF(isub.EQ.433) THEN
32782 C...g + g -> QQ~[3P21] + g
32783  pgtw=(sh*th+th*uh+uh*sh)/sh2
32784  qgtw=(sh*th*uh)/sh**3
32785  rgtw=sqmqq/sh
32786  IF(mstp(145).EQ.0) THEN
32787  facqqg=comfac*paru(1)*as**3*8d0/(9d0*sqmqqr*sh)*
32788  & (12d0*rgtw**2*pgtw**4*
32789  & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
32790  & -3d0*rgtw*pgtw**3*qgtw*
32791  & (8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)
32792  & +2d0*pgtw**2*qgtw**2*
32793  & (-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)
32794  & +rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)
32795  & +12d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
32796  ELSE
32797  ff=(16d0*paru(1)*as**3*sqmqq*sqmqqr)/
32798  & (3d0*sh2*th2*uh2*shth2**2*thuh2**2*uhsh2**2)
32799  c1=pgtw**2*qgtw*(pgtw*rgtw-qgtw)**2*(rgtw**2-2d0*pgtw)
32800  & *sh*sh2**7
32801  c2=2d0*shth2*(-sh2**3*th2**3-sh**5*th**5*uh*shth
32802  & +sh2**2*th2**2*uh2*(8d0*shth2-5d0*sh*th)
32803  & +sh**3*th**3*uh**3*shth*(17d0*shth2-2d0*sh*th)
32804  & +sh2*th2*uh2**2*(105d0*sh2*th2+64d0*sh*th*(sh2+th2)
32805  & +10d0*(sh2**2+th2**2))
32806  & +sh2*th2*uh**5*shth*(32d0*shth2+7d0*sh*th)
32807  & -uh2**3*(sh2**3-87d0*sh**3*th**3+th2**3
32808  & -45d0*sh2*th2*(sh2+th2)-5d0*sh*th*(sh2**2+th2**2))
32809  & +sh*th*uh**7*shth*(7d0*shth2+12d0*sh*th)
32810  & +4d0*sh*th*uh2**4*shth2)
32811  c3=2d0*uhsh2*(-sh2**3*uh2**3-sh**5*uh**5*th*uhsh
32812  & +sh2**2*uh2**2*th2*(8d0*uhsh2-5d0*sh*uh)
32813  & +sh**3*uh**3*th**3*uhsh*(17d0*uhsh2-2d0*sh*uh)
32814  & +sh2*uh2*th2**2*(105d0*sh2*uh2+64d0*sh*uh*(sh2+uh2)
32815  & +10d0*(sh2**2+uh2**2))
32816  & +sh2*uh2*th**5*uhsh*(32d0*uhsh2+7d0*sh*uh)
32817  & -th2**3*(sh2**3-87d0*sh**3*uh**3+uh2**3
32818  & -45d0*sh2*uh2*(sh2+uh2)-5d0*sh*uh*(sh2**2+uh2**2))
32819  & +sh*uh*th**7*uhsh*(7d0*uhsh2+12d0*sh*uh)
32820  & +4d0*sh*uh*th2**4*uhsh2)
32821  c4=-2d0*shth*uhsh*(-2d0*th2**3*uh2**3
32822  & -sh**5*th2*uh2*thuh*(5d0*th+3d0*uh)*(3d0*th+5d0*uh)
32823  & +sh2**3*(2d0*th+uh)*(th+2d0*uh)*(th2-uh2)**2
32824  & -sh*th2**2*uh2**2*thuh*(5d0*thuh2-4d0*th*uh)
32825  & -sh2*th**3*uh**3*thuh2*(13d0*thuh2-16d0*th*uh)
32826  & -sh**3*th2*uh2*(92d0*th2*uh2*thuh
32827  & +53d0*th*uh*(th**3+uh**3)+11d0*(th**5+uh**5))
32828  & -sh2**2*th*uh*(114d0*th**3*uh**3
32829  & +83d0*th2*uh2*(th2+uh2)+28d0*th*uh*(th2**2+uh2**2)
32830  & +3d0*(th2**3+uh2**3)))
32831  c5=4d0*sh*th*uh2*shth2*(2d0*sh*th+sh*uh+th*uh)**2
32832  & *(2d0*uh*sqmqq**2+shth*(sh*th-uh2))
32833  c6=4d0*sh*uh*th2*uhsh2*(2d0*sh*uh+sh*th+th*uh)**2
32834  & *(2d0*th*sqmqq**2+uhsh*(sh*uh-th2))
32835  c7=4d0*sh*th*uh2*shth*(sh2**2*th**3*(11d0*sh+16d0*th)
32836  & +sh**3*th2*uh*(31d0*sh2+83d0*sh*th+61d0*th2)
32837  & +sh2*th*uh2*(19d0*sh**3+110d0*sh2*th+156d0*sh*th2+
32838  & 82d0*th**3)
32839  & +sh*th*uh**3*(43d0*sh**3+132d0*sh2*th+124d0*sh*th2
32840  & +45d0*th**3)
32841  & +th*uh2**2*(37d0*sh**3+68d0*sh2*th+43d0*sh*th2+
32842  & 8d0*th**3)
32843  & +th*uh**5*(11d0*sh2+13d0*sh*th+5d0*th2)
32844  & +sh**3*uh**3*(3d0*uhsh2-2d0*sh*uh)
32845  & +th**5*uhsh*(5d0*uhsh2+2d0*sh*uh))
32846  c8=4d0*sh*uh*th2*uhsh*(sh2**2*uh**3*(11d0*sh+16d0*uh)
32847  & +sh**3*uh2*th*(31d0*sh2+83d0*sh*uh+61d0*uh2)
32848  & +sh2*uh*th2*(19d0*sh**3+110d0*sh2*uh+156d0*sh*uh2+
32849  & 82d0*uh**3)
32850  & +sh*uh*th**3*(43d0*sh**3+132d0*sh2*uh+124d0*sh*uh2
32851  & +45d0*uh**3)
32852  & +uh*th2**2*(37d0*sh**3+68d0*sh2*uh+43d0*sh*uh2+
32853  & 8d0*uh**3)
32854  & +uh*th**5*(11d0*sh2+13d0*sh*uh+5d0*uh2)
32855  & +sh**3*th**3*(3d0*shth2-2d0*sh*th)
32856  & +uh**5*shth*(5d0*shth2+2d0*sh*th))
32857  c9=4d0*shth*uhsh*(2d0*th**5*uh**5*thuh
32858  & +4d0*sh*th2**2*uh2**2*thuh2
32859  & -sh2*th**3*uh**3*thuh*(th2+uh2)
32860  & -2d0*sh**3*th2*uh2*(thuh2**2+2d0*th*uh*thuh2-th2*uh2)
32861  & +sh2**2*th*uh*thuh*(-th*uh*thuh2+3d0*(th2**2+uh2**2))
32862  & +sh**5*(4d0*th2*uh2*(thuh2-th*uh)
32863  & +5d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3)))
32864  c0=-4d0*(2d0*th2**3*uh2**3*sqmqq
32865  & -sh2*th2**2*uh2**2*thuh*(19d0*thuh2-4d0*th*uh)
32866  & -sh**3*th**3*uh**3*thuh2*(32d0*thuh2+29d0*th*uh)
32867  & -sh2**2*th2*uh2*thuh*(264d0*th2*uh2
32868  & +136d0*th*uh*(th2+uh2)+15d0*(th2**2+uh2**2))
32869  & +sh**5*th*uh*(-428d0*th**3*uh**3
32870  & -256d0*th2*uh2*(th2+uh2)-43d0*th*uh*(th2**2+uh2**2)
32871  & +2d0*(th2**3+uh2**3))
32872  & +sh**7*(-46d0*th**3*uh**3-21d0*th2*uh2*(th2+uh2)
32873  & +2d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3))
32874  & +sh2**3*thuh*(-134*th**3*uh**3-53d0*th2*uh2*(th2+uh2)
32875  & +4d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3)))
32876  IF(mstp(147).EQ.0) THEN
32877  facqqg=1d0/3d0*(c1*3d0
32878  & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
32879  & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
32880  & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
32881  & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
32882  & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
32883  & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
32884  & *(el1k10*el2k20-el1k11*el2k21)
32885  & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
32886  & *(el1k10*el2k20-el1k11*el2k21)
32887  & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
32888  & *(el1k20*el2k20-el1k21*el2k21)
32889  & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
32890  ELSEIF(mstp(147).EQ.1) THEN
32891  facqqg=c1*2d0
32892  & -c2*(el1k10*el2k10+el1k11*el2k11)
32893  & -c3*(el1k20*el2k20+el1k21*el2k21)
32894  & -c4*(el1k10*el2k20+el1k11*el2k21)
32895  & +c5*4d0*el1k10*el2k10*el1k11*el2k11
32896  & +c6*4d0*el1k20*el2k20*el1k21*el2k21
32897  & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
32898  & +el1k10*el2k20*el1k11*el2k11)
32899  & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
32900  & +el1k10*el2k20*el1k21*el2k21)
32901  & +c9*4d0*el1k10*el2k20*el1k11*el2k21
32902  & +c0*(el1k10*el2k10*el1k21*el2k21
32903  & +2d0*el1k10*el2k20*el1k11*el2k21
32904  & +el1k20*el2k20*el1k11*el2k11)
32905  ELSEIF(mstp(147).EQ.2) THEN
32906  facqqg=2d0*(c1
32907  & -c2*el1k11*el2k11
32908  & -c3*el1k21*el2k21
32909  & -c4*el1k11*el2k21
32910  & +c5*(el1k11*el2k11)**2
32911  & +c6*(el1k21*el2k21)**2
32912  & +c7*el1k11*el2k11*el1k11*el2k21
32913  & +c8*el1k21*el2k21*el1k11*el2k21
32914  & +(c9+c0)*(el1k11*el2k21)**2)
32915  ENDIF
32916  facqqg=comfac*ff*facqqg
32917  ENDIF
32918  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32919  nchn=nchn+1
32920  isig(nchn,1)=21
32921  isig(nchn,2)=21
32922  isig(nchn,3)=1
32923  sigh(nchn)=facqqg*parp(ionium+5)
32924  ENDIF
32925 
32926  ELSEIF(isub.EQ.434) THEN
32927 C...q + g -> q + QQ~[3P01]
32928  IF(mstp(145).EQ.0) THEN
32929  facqqg=-comfac*paru(1)*as**3*(16d0/81d0)*
32930  & (th-3d0*sqmqq)**2*(sh2+uh2)/(sqmqqr*th*uhsh2**2)
32931  ELSE
32932  fa=-paru(1)*as**3*(16d0/243d0)*
32933  & (th-3d0*sqmqq)**2*(sh2+uh2)/(sqmqqr*th*uhsh2**2)
32934  IF(mstp(147).EQ.0) THEN
32935  facqqg=comfac*fa
32936  ELSEIF(mstp(147).EQ.1) THEN
32937  facqqg=comfac*2d0*fa
32938  ELSEIF(mstp(147).EQ.3) THEN
32939  facqqg=comfac*fa
32940  ELSEIF(mstp(147).EQ.4) THEN
32941  facqqg=comfac*fa
32942  ELSEIF(mstp(147).EQ.5) THEN
32943  facqqg=0d0
32944  ELSEIF(mstp(147).EQ.6) THEN
32945  facqqg=0d0
32946  ENDIF
32947  ENDIF
32948  DO 2452 i=mmina,mmaxa
32949  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 2452
32950  DO 2451 isde=1,2
32951  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 2451
32952  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 2451
32953  nchn=nchn+1
32954  isig(nchn,isde)=i
32955  isig(nchn,3-isde)=21
32956  isig(nchn,3)=1
32957  sigh(nchn)=facqqg*parp(ionium+5)
32958  2451 CONTINUE
32959  2452 CONTINUE
32960 
32961  ELSEIF(isub.EQ.435) THEN
32962 C...q + g -> q + QQ~[3P11]
32963  IF(mstp(145).EQ.0) THEN
32964  facqqg=-comfac*paru(1)*as**3*(32d0/27d0)*
32965  & (4d0*sqmqq*sh*uh+th*(sh2+uh2))/(sqmqqr*uhsh2**2)
32966  ELSE
32967  ff=(64d0*paru(1)*as**3*sqmqqr)/(27d0*uhsh2**2)
32968  c1=sh*uh
32969  c2=2d0*sh
32970  c3=0d0
32971  c4=2d0*(sh-uh)
32972  IF(mstp(147).EQ.0) THEN
32973  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32974  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32975  ELSEIF(mstp(147).EQ.1) THEN
32976  facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32977  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32978  ELSEIF(mstp(147).EQ.3) THEN
32979  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32980  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32981  ELSEIF(mstp(147).EQ.4) THEN
32982  facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32983  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32984  ELSEIF(mstp(147).EQ.5) THEN
32985  facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32986  & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32987  ELSEIF(mstp(147).EQ.6) THEN
32988  facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32989  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32990  ENDIF
32991  facqqg=comfac*ff*facqqg
32992  ENDIF
32993  DO 2454 i=mmina,mmaxa
32994  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 2454
32995  DO 2453 isde=1,2
32996  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 2453
32997  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 2453
32998  nchn=nchn+1
32999  isig(nchn,isde)=i
33000  isig(nchn,3-isde)=21
33001  isig(nchn,3)=1
33002  sigh(nchn)=facqqg*parp(ionium+5)
33003  2453 CONTINUE
33004  2454 CONTINUE
33005 
33006  ELSEIF(isub.EQ.436) THEN
33007 C...q + g -> q + QQ~[3P21]
33008  IF(mstp(145).EQ.0) THEN
33009  facqqg=-comfac*paru(1)*as**3*(32d0/81d0)*
33010  & ((6d0*sqmqq**2+th2)*uhsh2
33011  & -2d0*sh*uh*(th2+6d0*sqmqq*uhsh))/
33012  & (sqmqqr*th*uhsh2**2)
33013  ELSE
33014  ff=-(32d0*paru(1)*as**3*sqmqq*sqmqqr)/(27d0*th2*uhsh2**2)
33015  c1=th*uhsh2
33016  c2=4d0*(sh2+th2+2d0*th*uhsh)
33017  c3=4d0*uhsh2
33018  c4=8d0*sh*uhsh
33019  c5=8d0*th
33020  c6=0d0
33021  c7=16d0*th
33022  c8=0d0
33023  c9=-16d0*uhsh
33024  c0=16d0*sqmqq
33025  IF(mstp(147).EQ.0) THEN
33026  facqqg=1d0/3d0*(c1*3d0
33027  & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
33028  & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
33029  & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
33030  & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
33031  & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
33032  & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
33033  & *(el1k10*el2k20-el1k11*el2k21)
33034  & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
33035  & *(el1k10*el2k20-el1k11*el2k21)
33036  & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
33037  & *(el1k20*el2k20-el1k21*el2k21)
33038  & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
33039  ELSEIF(mstp(147).EQ.1) THEN
33040  facqqg=c1*2d0
33041  & -c2*(el1k10*el2k10+el1k11*el2k11)
33042  & -c3*(el1k20*el2k20+el1k21*el2k21)
33043  & -c4*(el1k10*el2k20+el1k11*el2k21)
33044  & +c5*4d0*el1k10*el2k10*el1k11*el2k11
33045  & +c6*4d0*el1k20*el2k20*el1k21*el2k21
33046  & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
33047  & +el1k10*el2k20*el1k11*el2k11)
33048  & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
33049  & +el1k10*el2k20*el1k21*el2k21)
33050  & +c9*4d0*el1k10*el2k20*el1k11*el2k21
33051  & +c0*(el1k10*el2k10*el1k21*el2k21
33052  & +2d0*el1k10*el2k20*el1k11*el2k21
33053  & +el1k20*el2k20*el1k11*el2k11)
33054  ELSEIF(mstp(147).EQ.2) THEN
33055  facqqg=2d0*(c1
33056  & -c2*el1k11*el2k11
33057  & -c3*el1k21*el2k21
33058  & -c4*el1k11*el2k21
33059  & +c5*(el1k11*el2k11)**2
33060  & +c6*(el1k21*el2k21)**2
33061  & +c7*el1k11*el2k11*el1k11*el2k21
33062  & +c8*el1k21*el2k21*el1k11*el2k21
33063  & +(c9+c0)*(el1k11*el2k21)**2)
33064  ENDIF
33065  facqqg=comfac*ff*facqqg
33066  ENDIF
33067  DO 2456 i=mmina,mmaxa
33068  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 2456
33069  DO 2455 isde=1,2
33070  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 2455
33071  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 2455
33072  nchn=nchn+1
33073  isig(nchn,isde)=i
33074  isig(nchn,3-isde)=21
33075  isig(nchn,3)=1
33076  sigh(nchn)=facqqg*parp(ionium+5)
33077  2455 CONTINUE
33078  2456 CONTINUE
33079 
33080  ELSEIF(isub.EQ.437) THEN
33081 C...q + q~ -> g + QQ~[3P01]
33082  IF(mstp(145).EQ.0) THEN
33083  facqqg=comfac*paru(1)*as**3*(128d0/243d0)*
33084  & (sh-3d0*sqmqq)**2*(th2+uh2)/(sqmqqr*sh*thuh2**2)
33085  ELSE
33086  fa=paru(1)*as**3*(128d0/729d0)*
33087  & (sh-3d0*sqmqq)**2*(th2+uh2)/(sqmqqr*sh*thuh2**2)
33088  IF(mstp(147).EQ.0) THEN
33089  facqqg=comfac*fa
33090  ELSEIF(mstp(147).EQ.1) THEN
33091  facqqg=comfac*2d0*fa
33092  ELSEIF(mstp(147).EQ.3) THEN
33093  facqqg=comfac*fa
33094  ELSEIF(mstp(147).EQ.4) THEN
33095  facqqg=comfac*fa
33096  ELSEIF(mstp(147).EQ.5) THEN
33097  facqqg=0d0
33098  ELSEIF(mstp(147).EQ.6) THEN
33099  facqqg=0d0
33100  ENDIF
33101  ENDIF
33102  DO 2457 i=mmina,mmaxa
33103  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
33104  & kfac(1,i)*kfac(2,-i).EQ.0) goto 2457
33105  nchn=nchn+1
33106  isig(nchn,1)=i
33107  isig(nchn,2)=-i
33108  isig(nchn,3)=1
33109  sigh(nchn)=facqqg*parp(ionium+5)
33110  2457 CONTINUE
33111 
33112  ELSEIF(isub.EQ.438) THEN
33113 C...q + q~ -> g + QQ~[3P11]
33114  IF(mstp(145).EQ.0) THEN
33115  facqqg=comfac*paru(1)*as**3*256d0/81d0*
33116  & (4d0*sqmqq*th*uh+sh*(th2+uh2))/(sqmqqr*thuh2**2)
33117  ELSE
33118  ff=-(512d0*paru(1)*as**3*sqmqqr)/(81d0*thuh2**2)
33119  c1=th*uh
33120  c2=2d0*uh
33121  c3=2d0*th
33122  c4=2d0*thuh
33123  IF(mstp(147).EQ.0) THEN
33124  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
33125  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
33126  ELSEIF(mstp(147).EQ.1) THEN
33127  facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
33128  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
33129  ELSEIF(mstp(147).EQ.3) THEN
33130  facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
33131  & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
33132  ELSEIF(mstp(147).EQ.4) THEN
33133  facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
33134  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
33135  ELSEIF(mstp(147).EQ.5) THEN
33136  facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
33137  & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
33138  ELSEIF(mstp(147).EQ.6) THEN
33139  facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
33140  & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
33141  ENDIF
33142  facqqg=comfac*ff*facqqg
33143  ENDIF
33144  DO 2458 i=mmina,mmaxa
33145  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
33146  & kfac(1,i)*kfac(2,-i).EQ.0) goto 2458
33147  nchn=nchn+1
33148  isig(nchn,1)=i
33149  isig(nchn,2)=-i
33150  isig(nchn,3)=1
33151  sigh(nchn)=facqqg*parp(ionium+5)
33152  2458 CONTINUE
33153 
33154  ELSEIF(isub.EQ.439) THEN
33155 C...q + q~ -> g + QQ~[3P21]
33156  IF(mstp(145).EQ.0) THEN
33157  facqqg=comfac*paru(1)*as**3*(256d0/243d0)*
33158  & ((6d0*sqmqq**2+sh2)*thuh2
33159  & -2d0*th*uh*(sh2+6d0*sqmqq*thuh))/
33160  & (sqmqqr*sh*thuh2**2)
33161  ELSE
33162  ff=(256d0*paru(1)*as**3*sqmqq*sqmqqr)/(81d0*sh2*thuh2**2)
33163  c1=sh*thuh2
33164  c2=4d0*(sh2+uh2+2d0*sh*thuh)
33165  c3=4d0*(sh2+th2+2d0*sh*thuh)
33166  c4=8d0*(sh2-th*uh+2d0*sh*thuh)
33167  c5=8d0*sh
33168  c6=c5
33169  c7=16d0*sh
33170  c8=c7
33171  c9=-16d0*thuh
33172  c0=16d0*sqmqq
33173  IF(mstp(147).EQ.0) THEN
33174  facqqg=1d0/3d0*(c1*3d0
33175  & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
33176  & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
33177  & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
33178  & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
33179  & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
33180  & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
33181  & *(el1k10*el2k20-el1k11*el2k21)
33182  & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
33183  & *(el1k10*el2k20-el1k11*el2k21)
33184  & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
33185  & *(el1k20*el2k20-el1k21*el2k21)
33186  & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
33187  ELSEIF(mstp(147).EQ.1) THEN
33188  facqqg=c1*2d0
33189  & -c2*(el1k10*el2k10+el1k11*el2k11)
33190  & -c3*(el1k20*el2k20+el1k21*el2k21)
33191  & -c4*(el1k10*el2k20+el1k11*el2k21)
33192  & +c5*4d0*el1k10*el2k10*el1k11*el2k11
33193  & +c6*4d0*el1k20*el2k20*el1k21*el2k21
33194  & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
33195  & +el1k10*el2k20*el1k11*el2k11)
33196  & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
33197  & +el1k10*el2k20*el1k21*el2k21)
33198  & +c9*4d0*el1k10*el2k20*el1k11*el2k21
33199  & +c0*(el1k10*el2k10*el1k21*el2k21
33200  & +2d0*el1k10*el2k20*el1k11*el2k21
33201  & +el1k20*el2k20*el1k11*el2k11)
33202  ELSEIF(mstp(147).EQ.2) THEN
33203  facqqg=2d0*(c1
33204  & -c2*el1k11*el2k11
33205  & -c3*el1k21*el2k21
33206  & -c4*el1k11*el2k21
33207  & +c5*(el1k11*el2k11)**2
33208  & +c6*(el1k21*el2k21)**2
33209  & +c7*el1k11*el2k11*el1k11*el2k21
33210  & +c8*el1k21*el2k21*el1k11*el2k21
33211  & +(c9+c0)*(el1k11*el2k21)**2)
33212  ENDIF
33213  facqqg=comfac*ff*facqqg
33214  ENDIF
33215  DO 2459 i=mmina,mmaxa
33216  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
33217  & kfac(1,i)*kfac(2,-i).EQ.0) goto 2459
33218  nchn=nchn+1
33219  isig(nchn,1)=i
33220  isig(nchn,2)=-i
33221  isig(nchn,3)=1
33222  sigh(nchn)=facqqg*parp(ionium+5)
33223  2459 CONTINUE
33224  ENDIF
33225 C...QUARKONIA---
33226 
33227  ENDIF
33228 
33229  RETURN
33230  END
33231 
33232 C*********************************************************************
33233 
33234 C...PYSGWZ
33235 C...Subprocess cross sections for W/Z processes,
33236 C...except that longitudinal WW scattering is in Higgs sector.
33237 C...Auxiliary to PYSIGH.
33238 
33239  SUBROUTINE pysgwz(NCHN,SIGS)
33240 
33241 C...Double precision and integer declarations
33242  IMPLICIT DOUBLE PRECISION(a-h, o-z)
33243  IMPLICIT INTEGER(i-n)
33244  INTEGER pyk,pychge,pycomp
33245 C...Parameter statement to help give large particle numbers.
33246  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
33247  &kexcit=4000000,kdimen=5000000)
33248 C...Commonblocks
33249  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
33250  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
33251  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
33252  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
33253  common/pypars/mstp(200),parp(200),msti(200),pari(200)
33254  common/pyint1/mint(400),vint(400)
33255  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
33256  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
33257  common/pyint4/mwid(500),wids(500,5)
33258  common/pytcsm/itcm(0:99),rtcm(0:99)
33259  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
33260  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
33261  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
33262  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
33263  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
33264  &/pyint2/,/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
33265 C...Local arrays and complex numbers
33266  dimension wdtp(0:400),wdte(0:400,0:5),hgz(6,3),hl3(3),hr3(3),
33267  &hl4(3),hr4(3)
33268  COMPLEX*16 coulck,coulcp,coulcd,coulcr,coulcs
33269 
33270 C...Differential cross section expressions.
33271 
33272  IF(isub.LE.20) THEN
33273  IF(isub.EQ.1) THEN
33274 C...f + fbar -> gamma*/Z0
33275  mint(61)=2
33276  CALL pywidt(23,sh,wdtp,wdte)
33277  hs=shr*wdtp(0)
33278  facz=4d0*comfac*3d0
33279  hp0=aem/3d0*sh
33280  hp1=aem/3d0*xwc*sh
33281  DO 100 i=mmina,mmaxa
33282  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 100
33283  ei=kchg(iabs(i),1)/3d0
33284  ai=sign(1d0,ei)
33285  vi=ai-4d0*ei*xwv
33286  hi0=hp0
33287  IF(iabs(i).LE.10) hi0=hi0*faca/3d0
33288  hi1=hp1
33289  IF(iabs(i).LE.10) hi1=hi1*faca/3d0
33290  nchn=nchn+1
33291  isig(nchn,1)=i
33292  isig(nchn,2)=-i
33293  isig(nchn,3)=1
33294  sigh(nchn)=facz*(ei**2/sh2*hi0*hp0*vint(111)+
33295  & ei*vi*(1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*
33296  & (hi0*hp1+hi1*hp0)*vint(112)+(vi**2+ai**2)/
33297  & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114))
33298  100 CONTINUE
33299 
33300  ELSEIF(isub.EQ.2) THEN
33301 C...f + fbar' -> W+/-
33302  CALL pywidt(24,sh,wdtp,wdte)
33303  hs=shr*wdtp(0)
33304  facbw=4d0*comfac/((sh-sqmw)**2+hs**2)*3d0
33305  hp=aem/(24d0*xw)*sh
33306  DO 120 i=mmin1,mmax1
33307  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 120
33308  ia=iabs(i)
33309  DO 110 j=mmin2,mmax2
33310  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 110
33311  ja=iabs(j)
33312  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 110
33313  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
33314  & goto 110
33315  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
33316  hi=hp*2d0
33317  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
33318  nchn=nchn+1
33319  isig(nchn,1)=i
33320  isig(nchn,2)=j
33321  isig(nchn,3)=1
33322  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
33323  sigh(nchn)=hi*facbw*hf
33324  110 CONTINUE
33325  120 CONTINUE
33326 
33327  ELSEIF(isub.EQ.15) THEN
33328 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
33329  faczg=comfac*as*aem*(8d0/9d0)*(th2+uh2+2d0*sqm4*sh)/(th*uh)
33330 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33331  hfgg=0d0
33332  hfgz=0d0
33333  hfzz=0d0
33334  radc4=1d0+pyalps(sqm4)/paru(1)
33335  DO 130 i=1,min(16,mdcy(23,3))
33336  idc=i+mdcy(23,2)-1
33337  IF(mdme(idc,1).LT.0) goto 130
33338  imdm=0
33339  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33340  & imdm=1
33341  IF(i.LE.8) THEN
33342  ef=kchg(i,1)/3d0
33343  af=sign(1d0,ef+0.1d0)
33344  vf=af-4d0*ef*xwv
33345  ELSEIF(i.LE.16) THEN
33346  ef=kchg(i+2,1)/3d0
33347  af=sign(1d0,ef+0.1d0)
33348  vf=af-4d0*ef*xwv
33349  ENDIF
33350  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33351  IF(4d0*rm1.LT.1d0) THEN
33352  fcof=1d0
33353  IF(i.LE.8) fcof=3d0*radc4
33354  be34=sqrt(max(0d0,1d0-4d0*rm1))
33355  IF(imdm.EQ.1) THEN
33356  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33357  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33358  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33359  & af**2*(1d0-4d0*rm1))*be34
33360  ENDIF
33361  ENDIF
33362  130 CONTINUE
33363 C...Propagators: as simulated in PYOFSH and as desired
33364  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33365  mint15=mint(15)
33366  mint(15)=1
33367  mint(61)=1
33368  CALL pywidt(23,sqm4,wdtp,wdte)
33369  mint(15)=mint15
33370  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33371  hfgg=hfgg*hfaem*vint(111)/sqm4
33372  hfgz=hfgz*hfaem*vint(112)/sqm4
33373  hfzz=hfzz*hfaem*vint(114)/sqm4
33374 C...Loop over flavours; consider full gamma/Z structure
33375  DO 140 i=mmina,mmaxa
33376  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
33377  & kfac(1,i)*kfac(2,-i).EQ.0) goto 140
33378  ei=kchg(iabs(i),1)/3d0
33379  ai=sign(1d0,ei)
33380  vi=ai-4d0*ei*xwv
33381  nchn=nchn+1
33382  isig(nchn,1)=i
33383  isig(nchn,2)=-i
33384  isig(nchn,3)=1
33385  sigh(nchn)=faczg*(ei**2*hfgg+ei*vi*hfgz+
33386  & (vi**2+ai**2)*hfzz)/hbw4
33387  140 CONTINUE
33388 
33389  ELSEIF(isub.EQ.16) THEN
33390 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
33391  facwg=comfac*as*aem/xw*2d0/9d0*(th2+uh2+2d0*sqm4*sh)/(th*uh)
33392 C...Propagators: as simulated in PYOFSH and as desired
33393  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33394  CALL pywidt(24,sqm4,wdtp,wdte)
33395  gmmwc=sqrt(sqm4)*wdtp(0)
33396  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33397  facwg=facwg*hbw4c/hbw4
33398  DO 160 i=mmin1,mmax1
33399  ia=iabs(i)
33400  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 160
33401  DO 150 j=mmin2,mmax2
33402  ja=iabs(j)
33403  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 150
33404  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 150
33405  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
33406  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33407  fckm=vckm((ia+1)/2,(ja+1)/2)
33408  nchn=nchn+1
33409  isig(nchn,1)=i
33410  isig(nchn,2)=j
33411  isig(nchn,3)=1
33412  sigh(nchn)=facwg*fckm*widsc
33413  150 CONTINUE
33414  160 CONTINUE
33415 
33416  ELSEIF(isub.EQ.19) THEN
33417 C...f + fbar -> gamma + (gamma*/Z0)
33418  facgz=comfac*2d0*aem**2*(th2+uh2+2d0*sqm4*sh)/(th*uh)
33419 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33420  hfgg=0d0
33421  hfgz=0d0
33422  hfzz=0d0
33423  radc4=1d0+pyalps(sqm4)/paru(1)
33424  DO 170 i=1,min(16,mdcy(23,3))
33425  idc=i+mdcy(23,2)-1
33426  IF(mdme(idc,1).LT.0) goto 170
33427  imdm=0
33428  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33429  & imdm=1
33430  IF(i.LE.8) THEN
33431  ef=kchg(i,1)/3d0
33432  af=sign(1d0,ef+0.1d0)
33433  vf=af-4d0*ef*xwv
33434  ELSEIF(i.LE.16) THEN
33435  ef=kchg(i+2,1)/3d0
33436  af=sign(1d0,ef+0.1d0)
33437  vf=af-4d0*ef*xwv
33438  ENDIF
33439  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33440  IF(4d0*rm1.LT.1d0) THEN
33441  fcof=1d0
33442  IF(i.LE.8) fcof=3d0*radc4
33443  be34=sqrt(max(0d0,1d0-4d0*rm1))
33444  IF(imdm.EQ.1) THEN
33445  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33446  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33447  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33448  & af**2*(1d0-4d0*rm1))*be34
33449  ENDIF
33450  ENDIF
33451  170 CONTINUE
33452 C...Propagators: as simulated in PYOFSH and as desired
33453  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33454  mint15=mint(15)
33455  mint(15)=1
33456  mint(61)=1
33457  CALL pywidt(23,sqm4,wdtp,wdte)
33458  mint(15)=mint15
33459  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33460  hfgg=hfgg*hfaem*vint(111)/sqm4
33461  hfgz=hfgz*hfaem*vint(112)/sqm4
33462  hfzz=hfzz*hfaem*vint(114)/sqm4
33463 C...Loop over flavours; consider full gamma/Z structure
33464  DO 180 i=mmina,mmaxa
33465  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 180
33466  ei=kchg(iabs(i),1)/3d0
33467  ai=sign(1d0,ei)
33468  vi=ai-4d0*ei*xwv
33469  fcoi=1d0
33470  IF(iabs(i).LE.10) fcoi=faca/3d0
33471  nchn=nchn+1
33472  isig(nchn,1)=i
33473  isig(nchn,2)=-i
33474  isig(nchn,3)=1
33475  sigh(nchn)=facgz*fcoi*ei**2*(ei**2*hfgg+ei*vi*hfgz+
33476  & (vi**2+ai**2)*hfzz)/hbw4
33477  180 CONTINUE
33478 
33479  ELSEIF(isub.EQ.20) THEN
33480 C...f + fbar' -> gamma + W+/-
33481  facgw=comfac*0.5d0*aem**2/xw
33482 C...Propagators: as simulated in PYOFSH and as desired
33483  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33484  CALL pywidt(24,sqm4,wdtp,wdte)
33485  gmmwc=sqrt(sqm4)*wdtp(0)
33486  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33487  facgw=facgw*hbw4c/hbw4
33488 C...Anomalous couplings
33489  term1=(th2+uh2+2d0*sqm4*sh)/(th*uh)
33490  term2=0d0
33491  term3=0d0
33492  IF(itcm(5).GE.1.AND.itcm(5).LE.4) THEN
33493  term2=rtcm(46)*(th-uh)/(th+uh)
33494  term3=0.5d0*rtcm(46)**2*(th*uh+(th2+uh2)*sh/
33495  & (4d0*sqmw))/(th+uh)**2
33496  ENDIF
33497  DO 200 i=mmin1,mmax1
33498  ia=iabs(i)
33499  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 200
33500  DO 190 j=mmin2,mmax2
33501  ja=iabs(j)
33502  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 190
33503  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 190
33504  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
33505  & goto 190
33506  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
33507  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33508  IF(ia.LE.10) THEN
33509  facwr=uh/(th+uh)-1d0/3d0
33510  fckm=vckm((ia+1)/2,(ja+1)/2)
33511  fcoi=faca/3d0
33512  ELSE
33513  facwr=-th/(th+uh)
33514  fckm=1d0
33515  fcoi=1d0
33516  ENDIF
33517  facwk=term1*facwr**2+term2*facwr+term3
33518  nchn=nchn+1
33519  isig(nchn,1)=i
33520  isig(nchn,2)=j
33521  isig(nchn,3)=1
33522  sigh(nchn)=facgw*facwk*fcoi*fckm*widsc
33523  190 CONTINUE
33524  200 CONTINUE
33525  ENDIF
33526 
33527  ELSEIF(isub.LE.40) THEN
33528  IF(isub.EQ.22) THEN
33529 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
33530 C...Kinematics dependence
33531  faczz=comfac*aem**2*((th2+uh2+2d0*(sqm3+sqm4)*sh)/(th*uh)-
33532  & sqm3*sqm4*(1d0/th2+1d0/uh2))
33533 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33534  DO 220 i=1,6
33535  DO 210 j=1,3
33536  hgz(i,j)=0d0
33537  210 CONTINUE
33538  220 CONTINUE
33539  radc3=1d0+pyalps(sqm3)/paru(1)
33540  radc4=1d0+pyalps(sqm4)/paru(1)
33541  DO 230 i=1,min(16,mdcy(23,3))
33542  idc=i+mdcy(23,2)-1
33543  IF(mdme(idc,1).LT.0) goto 230
33544  imdm=0
33545  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2) imdm=1
33546  IF(mdme(idc,1).EQ.4.OR.mdme(idc,1).EQ.5) imdm=mdme(idc,1)-2
33547  IF(i.LE.8) THEN
33548  ef=kchg(i,1)/3d0
33549  af=sign(1d0,ef+0.1d0)
33550  vf=af-4d0*ef*xwv
33551  ELSEIF(i.LE.16) THEN
33552  ef=kchg(i+2,1)/3d0
33553  af=sign(1d0,ef+0.1d0)
33554  vf=af-4d0*ef*xwv
33555  ENDIF
33556  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm3
33557  IF(4d0*rm1.LT.1d0) THEN
33558  fcof=1d0
33559  IF(i.LE.8) fcof=3d0*radc3
33560  be34=sqrt(max(0d0,1d0-4d0*rm1))
33561  IF(imdm.GE.1) THEN
33562  hgz(1,imdm)=hgz(1,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
33563  hgz(2,imdm)=hgz(2,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
33564  hgz(3,imdm)=hgz(3,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
33565  & af**2*(1d0-4d0*rm1))*be34
33566  ENDIF
33567  ENDIF
33568  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33569  IF(4d0*rm1.LT.1d0) THEN
33570  fcof=1d0
33571  IF(i.LE.8) fcof=3d0*radc4
33572  be34=sqrt(max(0d0,1d0-4d0*rm1))
33573  IF(imdm.GE.1) THEN
33574  hgz(4,imdm)=hgz(4,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
33575  hgz(5,imdm)=hgz(5,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
33576  hgz(6,imdm)=hgz(6,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
33577  & af**2*(1d0-4d0*rm1))*be34
33578  ENDIF
33579  ENDIF
33580  230 CONTINUE
33581 C...Propagators: as simulated in PYOFSH and as desired
33582  hbw3=(1d0/paru(1))*gmmz/((sqm3-sqmz)**2+gmmz**2)
33583  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33584  mint15=mint(15)
33585  mint(15)=1
33586  mint(61)=1
33587  CALL pywidt(23,sqm3,wdtp,wdte)
33588  mint(15)=mint15
33589  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33590  DO 240 j=1,3
33591  hgz(1,j)=hgz(1,j)*hfaem*vint(111)/sqm3
33592  hgz(2,j)=hgz(2,j)*hfaem*vint(112)/sqm3
33593  hgz(3,j)=hgz(3,j)*hfaem*vint(114)/sqm3
33594  240 CONTINUE
33595  mint15=mint(15)
33596  mint(15)=1
33597  mint(61)=1
33598  CALL pywidt(23,sqm4,wdtp,wdte)
33599  mint(15)=mint15
33600  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33601  DO 250 j=1,3
33602  hgz(4,j)=hgz(4,j)*hfaem*vint(111)/sqm4
33603  hgz(5,j)=hgz(5,j)*hfaem*vint(112)/sqm4
33604  hgz(6,j)=hgz(6,j)*hfaem*vint(114)/sqm4
33605  250 CONTINUE
33606 C...Loop over flavours; separate left- and right-handed couplings
33607  DO 270 i=mmina,mmaxa
33608  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 270
33609  ei=kchg(iabs(i),1)/3d0
33610  ai=sign(1d0,ei)
33611  vi=ai-4d0*ei*xwv
33612  vali=vi-ai
33613  vari=vi+ai
33614  fcoi=1d0
33615  IF(iabs(i).LE.10) fcoi=faca/3d0
33616  DO 260 j=1,3
33617  hl3(j)=ei**2*hgz(1,j)+ei*vali*hgz(2,j)+vali**2*hgz(3,j)
33618  hr3(j)=ei**2*hgz(1,j)+ei*vari*hgz(2,j)+vari**2*hgz(3,j)
33619  hl4(j)=ei**2*hgz(4,j)+ei*vali*hgz(5,j)+vali**2*hgz(6,j)
33620  hr4(j)=ei**2*hgz(4,j)+ei*vari*hgz(5,j)+vari**2*hgz(6,j)
33621  260 CONTINUE
33622  faclr=hl3(1)*hl4(1)+hl3(1)*(hl4(2)+hl4(3))+
33623  & hl4(1)*(hl3(2)+hl3(3))+hl3(2)*hl4(3)+hl4(2)*hl3(3)+
33624  & hr3(1)*hr4(1)+hr3(1)*(hr4(2)+hr4(3))+
33625  & hr4(1)*(hr3(2)+hr3(3))+hr3(2)*hr4(3)+hr4(2)*hr3(3)
33626  nchn=nchn+1
33627  isig(nchn,1)=i
33628  isig(nchn,2)=-i
33629  isig(nchn,3)=1
33630  sigh(nchn)=0.5d0*faczz*fcoi*faclr/(hbw3*hbw4)
33631  270 CONTINUE
33632 
33633  ELSEIF(isub.EQ.23) THEN
33634 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
33635  faczw=comfac*0.5d0*(aem/xw)**2
33636  faczw=faczw*wids(23,2)
33637  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
33638  facbw=1d0/((sh-sqmw)**2+gmmw**2)
33639  DO 290 i=mmin1,mmax1
33640  ia=iabs(i)
33641  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 290
33642  DO 280 j=mmin2,mmax2
33643  ja=iabs(j)
33644  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 280
33645  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 280
33646  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
33647  & goto 280
33648  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
33649  ei=kchg(ia,1)/3d0
33650  ai=sign(1d0,ei+0.1d0)
33651  vi=ai-4d0*ei*xwv
33652  ej=kchg(ja,1)/3d0
33653  aj=sign(1d0,ej+0.1d0)
33654  vj=aj-4d0*ej*xwv
33655  IF(vi+ai.GT.0) THEN
33656  visav=vi
33657  aisav=ai
33658  vi=vj
33659  ai=aj
33660  vj=visav
33661  aj=aisav
33662  ENDIF
33663  fckm=1d0
33664  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
33665  fcoi=1d0
33666  IF(ia.LE.10) fcoi=faca/3d0
33667  nchn=nchn+1
33668  isig(nchn,1)=i
33669  isig(nchn,2)=j
33670  isig(nchn,3)=1
33671  sigh(nchn)=faczw*fcoi*fckm*(facbw*((9d0-8d0*xw)/4d0*thuh+
33672  & (8d0*xw-6d0)/4d0*sh*(sqm3+sqm4))+(thuh-sh*(sqm3+sqm4))*
33673  & (sh-sqmw)*facbw*0.5d0*((vj+aj)/th-(vi+ai)/uh)+
33674  & thuh/(16d0*xw1)*((vj+aj)**2/th2+(vi+ai)**2/uh2)+
33675  & sh*(sqm3+sqm4)/(8d0*xw1)*(vi+ai)*(vj+aj)/(th*uh))*
33676  & wids(24,(5-kchw)/2)
33677 C***Protect against slightly negative cross sections. (Reason yet to be
33678 C***sorted out. One possibility: addition of width to the W propagator.)
33679  sigh(nchn)=max(0d0,sigh(nchn))
33680  280 CONTINUE
33681  290 CONTINUE
33682 
33683  ELSEIF(isub.EQ.25) THEN
33684 C...f + fbar -> W+ + W-
33685 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33686  gmmzc=gmmz
33687  hbwzc=sh**2/((sh-sqmz)**2+gmmzc**2)
33688  hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
33689  CALL pywidt(24,sqm3,wdtp,wdte)
33690  gmmw3=sqrt(sqm3)*wdtp(0)
33691  hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
33692  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33693  CALL pywidt(24,sqm4,wdtp,wdte)
33694  gmmw4=sqrt(sqm4)*wdtp(0)
33695  hbw4c=gmmw4/((sqm4-sqmw)**2+gmmw4**2)
33696 C...Kinematical functions
33697  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
33698  thuh34=(2d0*sh*(sqm3+sqm4)+thuh)/(sqm3*sqm4)
33699  gs=(((sh-sqm3-sqm4)**2-4d0*sqm3*sqm4)*thuh34+12d0*thuh)/sh2
33700  gt=thuh34+4d0*thuh/th2
33701  gst=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/th)/sh
33702  gu=thuh34+4d0*thuh/uh2
33703  gsu=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/uh)/sh
33704 C...Common factors and couplings
33705  facww=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)
33706  facww=facww*wids(24,1)
33707  cgg=aem**2/2d0
33708  cgz=aem**2/(4d0*xw)*hbwzc*(1d0-sqmz/sh)
33709  czz=aem**2/(32d0*xw**2)*hbwzc
33710  cng=aem**2/(4d0*xw)
33711  cnz=aem**2/(16d0*xw**2)*hbwzc*(1d0-sqmz/sh)
33712  cnn=aem**2/(16d0*xw**2)
33713 C...Coulomb factor for W+W- pair
33714  IF(mstp(40).GE.1.AND.mstp(40).LE.3) THEN
33715  coule=(sh-4d0*sqmw)/(4d0*pmas(24,1))
33716  coulp=max(1d-10,0.5d0*be34*sqrt(sh))
33717  IF(coule.LT.100d0*pmas(24,2)) THEN
33718  coulp1=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
33719  & pmas(24,2)**2)-coule))
33720  ELSE
33721  coulp1=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/coule))
33722  ENDIF
33723  IF(coule.GT.-100d0*pmas(24,2)) THEN
33724  coulp2=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
33725  & pmas(24,2)**2)+coule))
33726  ELSE
33727  coulp2=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/
33728  & abs(coule)))
33729  ENDIF
33730  IF(mstp(40).EQ.1) THEN
33731  couldc=paru(1)-2d0*atan((coulp1**2+coulp2**2-coulp**2)/
33732  & max(1d-10,2d0*coulp*coulp1))
33733  faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
33734  ELSEIF(mstp(40).EQ.2) THEN
33735  coulck=dcmplx(dble(coulp1),dble(coulp2))
33736  coulcp=dcmplx(0d0,dble(coulp))
33737  coulcd=(coulck+coulcp)/(coulck-coulcp)
33738  coulcr=1d0+dble(paru(101)*sqrt(sh))/
33739  & (4d0*coulcp)*log(coulcd)
33740  coulcs=dcmplx(0d0,0d0)
33741  nstp=100
33742  DO 300 istp=1,nstp
33743  coulxx=(istp-0.5)/nstp
33744  coulcs=coulcs+(1d0/coulxx)*log((1d0+coulxx*coulcd)/
33745  & (1d0+coulxx/coulcd))
33746  300 CONTINUE
33747  coulcr=coulcr+dble(paru(101)**2*sh)/(16d0*coulcp*coulck)*
33748  & (coulcs/nstp)
33749  faccou=abs(coulcr)**2
33750  ELSEIF(mstp(40).EQ.3) THEN
33751  couldc=paru(1)-2d0*(1d0-be34)**2*atan((coulp1**2+
33752  & coulp2**2-coulp**2)/max(1d-10,2d0*coulp*coulp1))
33753  faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
33754  ENDIF
33755  ELSEIF(mstp(40).EQ.4) THEN
33756  faccou=1d0+0.5d0*paru(101)*paru(1)/max(1d-5,be34)
33757  ELSE
33758  faccou=1d0
33759  ENDIF
33760  vint(95)=faccou
33761  facww=facww*faccou
33762 C...Loop over allowed flavours
33763  DO 310 i=mmina,mmaxa
33764  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 310
33765  ei=kchg(iabs(i),1)/3d0
33766  ai=sign(1d0,ei+0.1d0)
33767  vi=ai-4d0*ei*xwv
33768  fcoi=1d0
33769  IF(iabs(i).LE.10) fcoi=faca/3d0
33770  IF(mstp(50).LE.0.OR.iabs(i).LE.10) THEN
33771  IF(ai.LT.0d0) THEN
33772  dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs+
33773  & (cng*ei+cnz*(vi+ai))*gst+cnn*gt
33774  ELSE
33775  dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs-
33776  & (cng*ei+cnz*(vi+ai))*gsu+cnn*gu
33777  ENDIF
33778  ELSE
33779  xmw02=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
33780  bet=sqrt(1d0-4d0*xmw02/sh)
33781  gat=1d0/sqrt(1d0-bet**2)
33782  sthe2=1d0-cth**2
33783  ampzg=bet**3*(16d0+(4d0*bet**2*gat**2+3d0/gat**2)*sthe2)
33784  ampnu=bet*(2d0+bet**2*gat**2*sthe2/2d0+
33785  & 2d0*bet**2*(1d0-bet**2)*sthe2/(1d0-2d0*bet*cth+bet**2)**2)
33786  ampng=bet*((1d0+bet**2)*(4d0+bet**2*gat**2*sthe2)+
33787  & 2d0*(1d0-bet**2)*(bet**2*sthe2-2d0*(1d0-bet**2))/
33788  & (1d0-2d0*bet*cth+bet**2))
33789  propi1=(0.25d0*sqmz/xmw02)*hbwzc*(1d0-sqmz/sh)
33790  propi2=(0.25d0*sqmz/xmw02)**2*hbwzc
33791  a0=(2d0*(xmw02/sqmz)-(1d0-bet**2)*xw)*poll
33792  a1=(2d0*(xmw02/sqmz)**2-2*xmw02/sqmz*(1d0-bet**2)*xw)*poll
33793  a2=(1d0-bet**2)**2*xw**2*(polr+poll)/2d0
33794  atot=ampnu*poll+(a1+a2)*propi2*ampzg-a0*propi1*ampng
33795  atot=atot*cnn/sqmw*sh/bet*2d0
33796  dsigww=atot
33797  ENDIF
33798  nchn=nchn+1
33799  isig(nchn,1)=i
33800  isig(nchn,2)=-i
33801  isig(nchn,3)=1
33802  sigh(nchn)=facww*fcoi*dsigww
33803  310 CONTINUE
33804 
33805  ELSEIF(isub.EQ.30) THEN
33806 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33807  fzq=comfac*faca*as*aem*(1d0/3d0)*(sh2+uh2+2d0*sqm4*th)/
33808  & (-sh*uh)
33809 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33810  hfgg=0d0
33811  hfgz=0d0
33812  hfzz=0d0
33813  radc4=1d0+pyalps(sqm4)/paru(1)
33814  DO 320 i=1,min(16,mdcy(23,3))
33815  idc=i+mdcy(23,2)-1
33816  IF(mdme(idc,1).LT.0) goto 320
33817  imdm=0
33818  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33819  & imdm=1
33820  IF(i.LE.8) THEN
33821  ef=kchg(i,1)/3d0
33822  af=sign(1d0,ef+0.1d0)
33823  vf=af-4d0*ef*xwv
33824  ELSEIF(i.LE.16) THEN
33825  ef=kchg(i+2,1)/3d0
33826  af=sign(1d0,ef+0.1d0)
33827  vf=af-4d0*ef*xwv
33828  ENDIF
33829  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33830  IF(4d0*rm1.LT.1d0) THEN
33831  fcof=1d0
33832  IF(i.LE.8) fcof=3d0*radc4
33833  be34=sqrt(max(0d0,1d0-4d0*rm1))
33834  IF(imdm.EQ.1) THEN
33835  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33836  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33837  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33838  & af**2*(1d0-4d0*rm1))*be34
33839  ENDIF
33840  ENDIF
33841  320 CONTINUE
33842 C...Propagators: as simulated in PYOFSH and as desired
33843  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33844  mint15=mint(15)
33845  mint(15)=1
33846  mint(61)=1
33847  CALL pywidt(23,sqm4,wdtp,wdte)
33848  mint(15)=mint15
33849  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33850  hfgg=hfgg*hfaem*vint(111)/sqm4
33851  hfgz=hfgz*hfaem*vint(112)/sqm4
33852  hfzz=hfzz*hfaem*vint(114)/sqm4
33853 C...Loop over flavours; consider full gamma/Z structure
33854  DO 340 i=mmina,mmaxa
33855  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 340
33856  ei=kchg(iabs(i),1)/3d0
33857  ai=sign(1d0,ei)
33858  vi=ai-4d0*ei*xwv
33859  faczq=fzq*(ei**2*hfgg+ei*vi*hfgz+
33860  & (vi**2+ai**2)*hfzz)/hbw4
33861  DO 330 isde=1,2
33862  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 330
33863  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 330
33864  nchn=nchn+1
33865  isig(nchn,isde)=i
33866  isig(nchn,3-isde)=21
33867  isig(nchn,3)=1
33868  sigh(nchn)=faczq
33869  330 CONTINUE
33870  340 CONTINUE
33871 
33872  ELSEIF(isub.EQ.31) THEN
33873 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33874  facwq=comfac*faca*as*aem/xw*1d0/12d0*
33875  & (sh2+uh2+2d0*sqm4*th)/(-sh*uh)
33876 C...Propagators: as simulated in PYOFSH and as desired
33877  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33878  CALL pywidt(24,sqm4,wdtp,wdte)
33879  gmmwc=sqrt(sqm4)*wdtp(0)
33880  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33881  facwq=facwq*hbw4c/hbw4
33882  DO 360 i=mmina,mmaxa
33883  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 360
33884  ia=iabs(i)
33885  kchw=isign(1,kchg(ia,1)*isign(1,i))
33886  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33887  DO 350 isde=1,2
33888  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 350
33889  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 350
33890  nchn=nchn+1
33891  isig(nchn,isde)=i
33892  isig(nchn,3-isde)=21
33893  isig(nchn,3)=1
33894  sigh(nchn)=facwq*vint(180+i)*widsc
33895  350 CONTINUE
33896  360 CONTINUE
33897 
33898  ELSEIF(isub.EQ.35) THEN
33899 C...f + gamma -> f + (gamma*/Z0)
33900  IF(mint(15).EQ.22.AND.vint(3).LT.0d0) THEN
33901  fzqn=sh2+uh2+2d0*(sqm4-vint(3)**2)*th
33902  fzqdtm=vint(3)**2*sqm4-sh*(uh-vint(4)**2)
33903  ELSEIF(mint(16).EQ.22.AND.vint(4).LT.0d0) THEN
33904  fzqn=sh2+uh2+2d0*(sqm4-vint(4)**2)*th
33905  fzqdtm=vint(4)**2*sqm4-sh*(uh-vint(3)**2)
33906  ELSE
33907  fzqn=sh2+uh2+2d0*sqm4*th
33908  fzqdtm=-sh*uh
33909  ENDIF
33910  fzqn=comfac*2d0*aem**2*max(0d0,fzqn)
33911 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33912  hfgg=0d0
33913  hfgz=0d0
33914  hfzz=0d0
33915  radc4=1d0+pyalps(sqm4)/paru(1)
33916  DO 370 i=1,min(16,mdcy(23,3))
33917  idc=i+mdcy(23,2)-1
33918  IF(mdme(idc,1).LT.0) goto 370
33919  imdm=0
33920  IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33921  & imdm=1
33922  IF(i.LE.8) THEN
33923  ef=kchg(i,1)/3d0
33924  af=sign(1d0,ef+0.1d0)
33925  vf=af-4d0*ef*xwv
33926  ELSEIF(i.LE.16) THEN
33927  ef=kchg(i+2,1)/3d0
33928  af=sign(1d0,ef+0.1d0)
33929  vf=af-4d0*ef*xwv
33930  ENDIF
33931  rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33932  IF(4d0*rm1.LT.1d0) THEN
33933  fcof=1d0
33934  IF(i.LE.8) fcof=3d0*radc4
33935  be34=sqrt(max(0d0,1d0-4d0*rm1))
33936  IF(imdm.EQ.1) THEN
33937  hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33938  hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33939  hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33940  & af**2*(1d0-4d0*rm1))*be34
33941  ENDIF
33942  ENDIF
33943  370 CONTINUE
33944 C...Propagators: as simulated in PYOFSH and as desired
33945  hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33946  mint15=mint(15)
33947  mint(15)=1
33948  mint(61)=1
33949  CALL pywidt(23,sqm4,wdtp,wdte)
33950  mint(15)=mint15
33951  hfaem=(paru(108)/paru(2))*(2d0/3d0)
33952  hfgg=hfgg*hfaem*vint(111)/sqm4
33953  hfgz=hfgz*hfaem*vint(112)/sqm4
33954  hfzz=hfzz*hfaem*vint(114)/sqm4
33955 C...Loop over flavours; consider full gamma/Z structure
33956  DO 390 i=mmina,mmaxa
33957  IF(i.EQ.0) goto 390
33958  ei=kchg(iabs(i),1)/3d0
33959  ai=sign(1d0,ei)
33960  vi=ai-4d0*ei*xwv
33961  faczq=ei**2*(ei**2*hfgg+ei*vi*hfgz+
33962  & (vi**2+ai**2)*hfzz)/hbw4
33963  fzqd=max(pmas(iabs(i),1)**2*sqm4,fzqdtm)
33964  DO 380 isde=1,2
33965  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 380
33966  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 380
33967  nchn=nchn+1
33968  isig(nchn,isde)=i
33969  isig(nchn,3-isde)=22
33970  isig(nchn,3)=1
33971  sigh(nchn)=faczq*fzqn/fzqd
33972  380 CONTINUE
33973  390 CONTINUE
33974 
33975  ELSEIF(isub.EQ.36) THEN
33976 C...f + gamma -> f' + W+/-
33977  fwq=comfac*aem**2/(2d0*xw)*
33978  & (sh2+uh2+2d0*sqm4*th)/(sqpth*sqm4-sh*uh)
33979 C...Propagators: as simulated in PYOFSH and as desired
33980  hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33981  CALL pywidt(24,sqm4,wdtp,wdte)
33982  gmmwc=sqrt(sqm4)*wdtp(0)
33983  hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33984  fwq=fwq*hbw4c/hbw4
33985  DO 410 i=mmina,mmaxa
33986  IF(i.EQ.0) goto 410
33987  ia=iabs(i)
33988  eia=abs(kchg(iabs(i),1)/3d0)
33989  facwq=fwq*(eia-sh/(sh+uh))**2
33990  kchw=isign(1,kchg(ia,1)*isign(1,i))
33991  widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33992  DO 400 isde=1,2
33993  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 400
33994  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 400
33995  nchn=nchn+1
33996  isig(nchn,isde)=i
33997  isig(nchn,3-isde)=22
33998  isig(nchn,3)=1
33999  sigh(nchn)=facwq*vint(180+i)*widsc
34000  400 CONTINUE
34001  410 CONTINUE
34002  ENDIF
34003 
34004  ELSEIF(isub.LE.100) THEN
34005  IF(isub.EQ.69) THEN
34006 C...gamma + gamma -> W+ + W-
34007  sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
34008  fprop=sh2/((sqmwe-th)*(sqmwe-uh))
34009  facww=comfac*6d0*aem**2*(1d0-fprop*(4d0/3d0+2d0*sqmwe/sh)+
34010  & fprop**2*(2d0/3d0+2d0*(sqmwe/sh)**2))*wids(24,1)
34011  IF(kfac(1,22)*kfac(2,22).EQ.0) goto 420
34012  nchn=nchn+1
34013  isig(nchn,1)=22
34014  isig(nchn,2)=22
34015  isig(nchn,3)=1
34016  sigh(nchn)=facww
34017  420 CONTINUE
34018 
34019  ELSEIF(isub.EQ.70) THEN
34020 C...gamma + W+/- -> Z0 + W+/-
34021  sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
34022  fprop=(th-sqmwe)**2/(-sh*(sqmwe-uh))
34023  faczw=comfac*6d0*aem**2*(xw1/xw)*
34024  & (1d0-fprop*(4d0/3d0+2d0*sqmwe/(th-sqmwe))+
34025  & fprop**2*(2d0/3d0+2d0*(sqmwe/(th-sqmwe))**2))*wids(23,2)
34026  DO 440 kchw=1,-1,-2
34027  DO 430 isde=1,2
34028  IF(kfac(isde,22)*kfac(3-isde,24*kchw).EQ.0) goto 430
34029  nchn=nchn+1
34030  isig(nchn,isde)=22
34031  isig(nchn,3-isde)=24*kchw
34032  isig(nchn,3)=1
34033  sigh(nchn)=faczw*wids(24,(5-kchw)/2)
34034  430 CONTINUE
34035  440 CONTINUE
34036  ENDIF
34037  ENDIF
34038 
34039  RETURN
34040  END
34041 
34042 C*********************************************************************
34043 
34044 C...PYSGHG
34045 C...Subprocess cross sections for Higgs processes,
34046 C...except Higgs pairs in PYSGSU, but including WW scattering.
34047 C...Auxiliary to PYSIGH.
34048 
34049  SUBROUTINE pysghg(NCHN,SIGS)
34050 
34051 C...Double precision and integer declarations
34052  IMPLICIT DOUBLE PRECISION(a-h, o-z)
34053  IMPLICIT INTEGER(i-n)
34054  INTEGER pyk,pychge,pycomp
34055 C...Parameter statement to help give large particle numbers.
34056  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
34057  &kexcit=4000000,kdimen=5000000)
34058 C...Commonblocks
34059  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34060  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34061  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
34062  common/pypars/mstp(200),parp(200),msti(200),pari(200)
34063  common/pyint1/mint(400),vint(400)
34064  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
34065  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
34066  common/pyint4/mwid(500),wids(500,5)
34067  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
34068  common/pymssm/imss(0:99),rmss(0:99)
34069  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
34070  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
34071  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
34072  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
34073  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
34074  &/pyint3/,/pyint4/,/pysubs/,/pymssm/,/pysgcm/
34075 C...Local arrays and complex variables
34076  dimension wdtp(0:400),wdte(0:400,0:5)
34077  COMPLEX*16 a004,a204,a114,a00u,a20u,a11u
34078  COMPLEX*16 cigtot,ciztot,f0alp,f1alp,f2alp,f0bet,f1bet,f2bet,fif
34079 
34080 C...Convert H or A process into equivalent h one
34081  ihigg=1
34082  kfhigg=25
34083  IF(isub.EQ.401.OR.isub.EQ.402) THEN
34084  kfhigg=kfpr(isub,1)
34085  END IF
34086  IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
34087  &isub.LE.190)) THEN
34088  ihigg=2
34089  IF(mod(isub-1,10).GE.5) ihigg=3
34090  kfhigg=33+ihigg
34091  IF(isub.EQ.151.OR.isub.EQ.156) isub=3
34092  IF(isub.EQ.152.OR.isub.EQ.157) isub=102
34093  IF(isub.EQ.153.OR.isub.EQ.158) isub=103
34094  IF(isub.EQ.171.OR.isub.EQ.176) isub=24
34095  IF(isub.EQ.172.OR.isub.EQ.177) isub=26
34096  IF(isub.EQ.173.OR.isub.EQ.178) isub=123
34097  IF(isub.EQ.174.OR.isub.EQ.179) isub=124
34098  IF(isub.EQ.181.OR.isub.EQ.186) isub=121
34099  IF(isub.EQ.182.OR.isub.EQ.187) isub=122
34100  IF(isub.EQ.183.OR.isub.EQ.188) isub=111
34101  IF(isub.EQ.184.OR.isub.EQ.189) isub=112
34102  IF(isub.EQ.185.OR.isub.EQ.190) isub=113
34103  ENDIF
34104  sqmh=pmas(kfhigg,1)**2
34105  gmmh=pmas(kfhigg,1)*pmas(kfhigg,2)
34106 
34107 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34108  IF((mstp(46).GE.3.AND.mstp(46).LE.6).AND.(isub.EQ.71.OR.isub.EQ.
34109  &72.OR.isub.EQ.73.OR.isub.EQ.76.OR.isub.EQ.77)) THEN
34110 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
34111  IF(mstp(46).LE.4) THEN
34112  hdtlh=log(pmas(25,1)/parp(44))
34113  hdtmr=(4.5d0*paru(1)/sqrt(3d0)-74d0/9d0)/8d0+hdtlh/12d0
34114  hdtnr=-1d0/18d0+hdtlh/6d0
34115  ELSE
34116  hdtnm=0.125d0*(1d0/(288d0*paru(1)**2)+(parp(47)/parp(45))**2)
34117  hdtlq=log(parp(45)/parp(44))
34118  hdtmr=-(4d0*paru(1))**2*0.5d0*hdtnm+hdtlq/12d0
34119  hdtnr=(4d0*paru(1))**2*hdtnm+hdtlq/6d0
34120  ENDIF
34121 
34122 C...Calculate lowest and next-to-lowest order partial wave amplitudes
34123  hdtv=1d0/(16d0*paru(1)*parp(47)**2)
34124  a00l=dble(hdtv*sh)
34125  a20l=-0.5d0*a00l
34126  a11l=a00l/6d0
34127  hdtls=log(sh/parp(44)**2)
34128  a004=dble((hdtv*sh)**2/(4d0*paru(1)))*
34129  & cmplx(dble((176d0*hdtmr+112d0*hdtnr)/3d0+11d0/27d0-
34130  & (50d0/9d0)*hdtls),dble(4d0*paru(1)))
34131  a204=dble((hdtv*sh)**2/(4d0*paru(1)))*
34132  & cmplx(dble(32d0*(hdtmr+2d0*hdtnr)/3d0+25d0/54d0-
34133  & (20d0/9d0)*hdtls),dble(paru(1)))
34134  a114=dble((hdtv*sh)**2/(6d0*paru(1)))*
34135  & cmplx(dble(4d0*(-2d0*hdtmr+hdtnr)-1d0/18d0),dble(paru(1)/6d0))
34136 
34137 C...Unitarize partial wave amplitudes with Pade or K-matrix method
34138  IF(mstp(46).EQ.3.OR.mstp(46).EQ.5) THEN
34139  a00u=a00l/(1d0-a004/a00l)
34140  a20u=a20l/(1d0-a204/a20l)
34141  a11u=a11l/(1d0-a114/a11l)
34142  ELSE
34143  a00u=(a00l+dble(a004))/(1d0-dcmplx(0.d0,a00l+dble(a004)))
34144  a20u=(a20l+dble(a204))/(1d0-dcmplx(0.d0,a20l+dble(a204)))
34145  a11u=(a11l+dble(a114))/(1d0-dcmplx(0.d0,a11l+dble(a114)))
34146  ENDIF
34147  ENDIF
34148 
34149 C...Differential cross section expressions.
34150 
34151  IF(isub.LE.60) THEN
34152  IF(isub.EQ.3) THEN
34153 C...f + fbar -> h0 (or H0, or A0)
34154  CALL pywidt(kfhigg,sh,wdtp,wdte)
34155  hs=shr*wdtp(0)
34156  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
34157  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34158  & facbw=0d0
34159  hp=aem/(8d0*xw)*sh/sqmw*sh
34160  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34161  DO 100 i=mmina,mmaxa
34162  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 100
34163  ia=iabs(i)
34164  rmq=pymrun(ia,sh)**2/sh
34165  hi=hp*rmq
34166  IF(ia.LE.10) hi=hp*rmq*faca/3d0
34167  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
34168  ikfi=1
34169  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
34170  IF(ia.GT.10) ikfi=3
34171  hi=hi*paru(150+10*ihigg+ikfi)**2
34172  IF(imss(1).NE.0.AND.ia.EQ.5) THEN
34173  hi=hi/(1d0+rmss(41))**2
34174  IF(ihigg.NE.3) THEN
34175  hi=hi*(1d0+rmss(41)*paru(152+10*ihigg)/
34176  & paru(151+10*ihigg))**2
34177  ENDIF
34178  ENDIF
34179  ENDIF
34180  nchn=nchn+1
34181  isig(nchn,1)=i
34182  isig(nchn,2)=-i
34183  isig(nchn,3)=1
34184  sigh(nchn)=hi*facbw*hf
34185  100 CONTINUE
34186 
34187  ELSEIF(isub.EQ.5) THEN
34188 C...Z0 + Z0 -> h0
34189  CALL pywidt(25,sh,wdtp,wdte)
34190  hs=shr*wdtp(0)
34191  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
34192  IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
34193  hp=aem/(8d0*xw)*sh/sqmw*sh
34194  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34195  hi=hp/4d0
34196  faci=8d0/(paru(1)**2*xw1)*(aem*xwc)**2
34197  DO 120 i=mmin1,mmax1
34198  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 120
34199  DO 110 j=mmin2,mmax2
34200  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 110
34201  ei=kchg(iabs(i),1)/3d0
34202  ai=sign(1d0,ei)
34203  vi=ai-4d0*ei*xwv
34204  ej=kchg(iabs(j),1)/3d0
34205  aj=sign(1d0,ej)
34206  vj=aj-4d0*ej*xwv
34207  nchn=nchn+1
34208  isig(nchn,1)=i
34209  isig(nchn,2)=j
34210  isig(nchn,3)=1
34211  sigh(nchn)=faci*(vi**2+ai**2)*(vj**2+aj**2)*hi*facbw*hf
34212  110 CONTINUE
34213  120 CONTINUE
34214 
34215  ELSEIF(isub.EQ.8) THEN
34216 C...W+ + W- -> h0
34217  CALL pywidt(25,sh,wdtp,wdte)
34218  hs=shr*wdtp(0)
34219  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
34220  IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
34221  hp=aem/(8d0*xw)*sh/sqmw*sh
34222  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34223  hi=hp/2d0
34224  faci=1d0/(4d0*paru(1)**2)*(aem/xw)**2
34225  DO 140 i=mmin1,mmax1
34226  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 140
34227  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
34228  DO 130 j=mmin2,mmax2
34229  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 130
34230  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
34231  IF(ei*ej.GT.0d0) goto 130
34232  nchn=nchn+1
34233  isig(nchn,1)=i
34234  isig(nchn,2)=j
34235  isig(nchn,3)=1
34236  sigh(nchn)=faci*vint(180+i)*vint(180+j)*hi*facbw*hf
34237  130 CONTINUE
34238  140 CONTINUE
34239 
34240  ELSEIF(isub.EQ.24) THEN
34241 C...f + fbar -> Z0 + h0 (or H0, or A0)
34242 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
34243  hbw3=gmmz/((sqm3-sqmz)**2+gmmz**2)
34244  CALL pywidt(23,sqm3,wdtp,wdte)
34245  gmmz3=sqrt(sqm3)*wdtp(0)
34246  hbw3c=gmmz3/((sqm3-sqmz)**2+gmmz3**2)
34247  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34248  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34249  gmmh4=sqrt(sqm4)*wdtp(0)
34250  hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
34251  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
34252  fachz=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*8d0*(aem*xwc)**2*
34253  & (thuh+2d0*sh*sqm3)/((sh-sqmz)**2+gmmz**2)
34254  fachz=fachz*wids(23,2)*wids(kfhigg,2)
34255  IF(mstp(4).GE.1.OR.ihigg.GE.2) fachz=fachz*
34256  & paru(154+10*ihigg)**2
34257  DO 150 i=mmina,mmaxa
34258  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 150
34259  ei=kchg(iabs(i),1)/3d0
34260  ai=sign(1d0,ei)
34261  vi=ai-4d0*ei*xwv
34262  fcoi=1d0
34263  IF(iabs(i).LE.10) fcoi=faca/3d0
34264  nchn=nchn+1
34265  isig(nchn,1)=i
34266  isig(nchn,2)=-i
34267  isig(nchn,3)=1
34268  sigh(nchn)=fachz*fcoi*(vi**2+ai**2)
34269  150 CONTINUE
34270 
34271  ELSEIF(isub.EQ.26) THEN
34272 C...f + fbar' -> W+/- + h0 (or H0, or A0)
34273 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
34274  hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
34275  CALL pywidt(24,sqm3,wdtp,wdte)
34276  gmmw3=sqrt(sqm3)*wdtp(0)
34277  hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
34278  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34279  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34280  gmmh4=sqrt(sqm4)*wdtp(0)
34281  hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
34282  thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
34283  fachw=comfac*0.125d0*(aem/xw)**2*(thuh+2d0*sh*sqm3)/
34284  & ((sh-sqmw)**2+gmmw**2)*(hbw3c/hbw3)*(hbw4c/hbw4)
34285  fachw=fachw*wids(kfhigg,2)
34286  IF(mstp(4).GE.1.OR.ihigg.GE.2) fachw=fachw*
34287  & paru(155+10*ihigg)**2
34288  DO 170 i=mmin1,mmax1
34289  ia=iabs(i)
34290  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 170
34291  DO 160 j=mmin2,mmax2
34292  ja=iabs(j)
34293  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(1,j).EQ.0) goto 160
34294  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 160
34295  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
34296  & goto 160
34297  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
34298  fckm=1d0
34299  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
34300  fcoi=1d0
34301  IF(ia.LE.10) fcoi=faca/3d0
34302  nchn=nchn+1
34303  isig(nchn,1)=i
34304  isig(nchn,2)=j
34305  isig(nchn,3)=1
34306  sigh(nchn)=fachw*fcoi*fckm*wids(24,(5-kchw)/2)
34307  160 CONTINUE
34308  170 CONTINUE
34309 
34310  ELSEIF(isub.EQ.32) THEN
34311 C...f + g -> f + h0 (q + g -> q + h0 only)
34312  fhcq=comfac*faca*as*aem/xw*1d0/24d0
34313 C...H propagator: as simulated in PYOFSH and as desired
34314  sqmhc=pmas(25,1)**2
34315  gmmhc=pmas(25,1)*pmas(25,2)
34316  hbw4=gmmhc/((sqm4-sqmhc)**2+gmmhc**2)
34317  CALL pywidt(25,sqm4,wdtp,wdte)
34318  gmmhcc=sqrt(sqm4)*wdtp(0)
34319  hbw4c=gmmhcc/((sqm4-sqmhc)**2+gmmhcc**2)
34320  fhcq=fhcq*hbw4c/hbw4
34321  DO 190 i=mmina,mmaxa
34322  ia=iabs(i)
34323  IF(ia.NE.5) goto 190
34324  sqml=pymrun(ia,sh)**2
34325  sqmq=pmas(ia,1)**2
34326  fachcq=fhcq*sqml/sqmw*
34327  & (sh/(sqmq-uh)+2d0*sqmq*(sqm4-uh)/(sqmq-uh)**2+(sqmq-uh)/sh-
34328  & 2d0*sqmq/(sqmq-uh)+2d0*(sqm4-uh)/(sqmq-uh)*
34329  & (sqm4-sqmq-sh)/sh)
34330  DO 180 isde=1,2
34331  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 180
34332  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 180
34333  nchn=nchn+1
34334  isig(nchn,isde)=i
34335  isig(nchn,3-isde)=21
34336  isig(nchn,3)=1
34337  sigh(nchn)=fachcq*wids(25,2)
34338  180 CONTINUE
34339  190 CONTINUE
34340  ENDIF
34341 
34342  ELSEIF(isub.LE.80) THEN
34343  IF(isub.EQ.71) THEN
34344 C...Z0 + Z0 -> Z0 + Z0
34345  IF(sh.LE.4.01d0*sqmz) goto 220
34346 
34347  IF(mstp(46).LE.2) THEN
34348 C...Exact scattering ME:s for on-mass-shell gauge bosons
34349  be2=1d0-4d0*sqmz/sh
34350  th=-0.5d0*sh*be2*(1d0-cth)
34351  uh=-0.5d0*sh*be2*(1d0+cth)
34352  IF(max(th,uh).GT.-1d0) goto 220
34353  shang=1d0/xw1*sqmw/sqmz*(1d0+be2)**2
34354  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
34355  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
34356  thang=1d0/xw1*sqmw/sqmz*(be2-cth)**2
34357  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
34358  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
34359  uhang=1d0/xw1*sqmw/sqmz*(be2+cth)**2
34360  auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
34361  auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
34362  faczz=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
34363  & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
34364  IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
34365  IF(mstp(46).EQ.1) faczz=faczz*((ashre+athre+auhre)**2+
34366  & (ashim+athim+auhim)**2)
34367  IF(mstp(46).EQ.2) faczz=0d0
34368 
34369  ELSE
34370 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34371  faczz=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
34372  & abs(a00u+2d0*a20u)**2
34373  ENDIF
34374  faczz=faczz*wids(23,1)
34375 
34376  DO 210 i=mmin1,mmax1
34377  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 210
34378  ei=kchg(iabs(i),1)/3d0
34379  ai=sign(1d0,ei)
34380  vi=ai-4d0*ei*xwv
34381  avi=ai**2+vi**2
34382  DO 200 j=mmin2,mmax2
34383  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 200
34384  ej=kchg(iabs(j),1)/3d0
34385  aj=sign(1d0,ej)
34386  vj=aj-4d0*ej*xwv
34387  avj=aj**2+vj**2
34388  nchn=nchn+1
34389  isig(nchn,1)=i
34390  isig(nchn,2)=j
34391  isig(nchn,3)=1
34392  sigh(nchn)=0.5d0*faczz*avi*avj
34393  200 CONTINUE
34394  210 CONTINUE
34395  220 CONTINUE
34396 
34397  ELSEIF(isub.EQ.72) THEN
34398 C...Z0 + Z0 -> W+ + W-
34399  IF(sh.LE.4.01d0*sqmz) goto 250
34400 
34401  IF(mstp(46).LE.2) THEN
34402 C...Exact scattering ME:s for on-mass-shell gauge bosons
34403  be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
34404  cth2=cth**2
34405  th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
34406  uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
34407  IF(max(th,uh).GT.-1d0) goto 250
34408  shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
34409  & (1d0-2d0*sqmz/sh)
34410  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
34411  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
34412  atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
34413  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
34414  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
34415  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
34416  & 2d0*(sqmw+sqmz)/sh*be2*cth))
34417  atwim=0d0
34418  auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
34419  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
34420  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
34421  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
34422  & 2d0*(sqmw+sqmz)/sh*be2*cth))
34423  auwim=0d0
34424  a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
34425  a4im=0d0
34426  facww=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
34427  & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
34428  IF(mstp(46).LE.0) facww=facww*(ashre**2+ashim**2)
34429  IF(mstp(46).EQ.1) facww=facww*((ashre+atwre+auwre+a4re)**2+
34430  & (ashim+atwim+auwim+a4im)**2)
34431  IF(mstp(46).EQ.2) facww=facww*((atwre+auwre+a4re)**2+
34432  & (atwim+auwim+a4im)**2)
34433 
34434  ELSE
34435 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34436  facww=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
34437  & abs(a00u-a20u)**2
34438  ENDIF
34439  facww=facww*wids(24,1)
34440 
34441  DO 240 i=mmin1,mmax1
34442  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 240
34443  ei=kchg(iabs(i),1)/3d0
34444  ai=sign(1d0,ei)
34445  vi=ai-4d0*ei*xwv
34446  avi=ai**2+vi**2
34447  DO 230 j=mmin2,mmax2
34448  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 230
34449  ej=kchg(iabs(j),1)/3d0
34450  aj=sign(1d0,ej)
34451  vj=aj-4d0*ej*xwv
34452  avj=aj**2+vj**2
34453  nchn=nchn+1
34454  isig(nchn,1)=i
34455  isig(nchn,2)=j
34456  isig(nchn,3)=1
34457  sigh(nchn)=facww*avi*avj
34458  230 CONTINUE
34459  240 CONTINUE
34460  250 CONTINUE
34461 
34462  ELSEIF(isub.EQ.73) THEN
34463 C...Z0 + W+/- -> Z0 + W+/-
34464  IF(sh.LE.2d0*sqmz+2d0*sqmw) goto 280
34465 
34466  IF(mstp(46).LE.2) THEN
34467 C...Exact scattering ME:s for on-mass-shell gauge bosons
34468  be2=1d0-2d0*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2
34469  ep1=1d0-(sqmz-sqmw)/sh
34470  ep2=1d0+(sqmz-sqmw)/sh
34471  th=-0.5d0*sh*be2*(1d0-cth)
34472  uh=(sqmz-sqmw)**2/sh-0.5d0*sh*be2*(1d0+cth)
34473  IF(max(th,uh).GT.-1d0) goto 280
34474  thang=(be2-ep1*cth)*(be2-ep2*cth)
34475  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
34476  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
34477  aswre=-xw1/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+
34478  & 1d0/4d0*(be2+ep1*ep2)**2*((ep1-ep2)**2-4d0*be2*cth)+
34479  & 2d0*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-
34480  & 1d0/16d0*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2)
34481  aswim=0d0
34482  auwre=xw1/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*
34483  & (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*
34484  & (be2+ep1*ep2*cth)*(2d0*ep2-ep2*cth+ep1)-
34485  & be2*(ep2+ep1*cth)**2*(be2-ep2**2*cth)-1d0/8d0*
34486  & (be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2d0*be2*(1d0-cth))+
34487  & 1d0/32d0*sh/sqmw*(be2+ep1*ep2*cth)**2*
34488  & (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)*
34489  & (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*
34490  & (2d0*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*
34491  & (be2-ep1**2*cth)-1d0/8d0*(be2+ep1*ep2*cth)**2*
34492  & ((ep1+ep2)**2+2d0*be2*(1d0-cth))+1d0/32d0*sh/sqmw*
34493  & (be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2)
34494  auwim=0d0
34495  a4re=xw1/sqmz*(ep1**2*ep2**2*(cth**2-1d0)-
34496  & 2d0*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2d0*be2*ep1*ep2)
34497  a4im=0d0
34498  faczw=comfac*1d0/(4096d0*paru(1)**2*4d0*xw1)*(aem/xw)**4*
34499  & (sh/sqmw)**2*sqrt(sqmz/sqmw)*sh2
34500  IF(mstp(46).LE.0) faczw=0d0
34501  IF(mstp(46).EQ.1) faczw=faczw*((athre+aswre+auwre+a4re)**2+
34502  & (athim+aswim+auwim+a4im)**2)
34503  IF(mstp(46).EQ.2) faczw=faczw*((aswre+auwre+a4re)**2+
34504  & (aswim+auwim+a4im)**2)
34505 
34506  ELSE
34507 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34508  faczw=comfac*aem**2/(64d0*paru(1)**2*xw**2*xw1)*16d0*
34509  & abs(a20u+3d0*a11u*dble(cth))**2
34510  ENDIF
34511  faczw=faczw*wids(23,2)
34512 
34513  DO 270 i=mmin1,mmax1
34514  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 270
34515  ei=kchg(iabs(i),1)/3d0
34516  ai=sign(1d0,ei)
34517  vi=ai-4d0*ei*xwv
34518  avi=ai**2+vi**2
34519  kchwi=isign(1,kchg(iabs(i),1)*isign(1,i))
34520  DO 260 j=mmin2,mmax2
34521  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 260
34522  ej=kchg(iabs(j),1)/3d0
34523  aj=sign(1d0,ej)
34524  vj=ai-4d0*ej*xwv
34525  avj=aj**2+vj**2
34526  kchwj=isign(1,kchg(iabs(j),1)*isign(1,j))
34527  nchn=nchn+1
34528  isig(nchn,1)=i
34529  isig(nchn,2)=j
34530  isig(nchn,3)=1
34531  sigh(nchn)=faczw*avi*vint(180+j)*wids(24,(5-kchwj)/2)
34532  nchn=nchn+1
34533  isig(nchn,1)=i
34534  isig(nchn,2)=j
34535  isig(nchn,3)=2
34536  sigh(nchn)=faczw*vint(180+i)*wids(24,(5-kchwi)/2)*avj
34537  260 CONTINUE
34538  270 CONTINUE
34539  280 CONTINUE
34540 
34541  ELSEIF(isub.EQ.75) THEN
34542 C...W+ + W- -> gamma + gamma
34543 
34544  ELSEIF(isub.EQ.76) THEN
34545 C...W+ + W- -> Z0 + Z0
34546  IF(sh.LE.4.01d0*sqmz) goto 310
34547 
34548  IF(mstp(46).LE.2) THEN
34549 C...Exact scattering ME:s for on-mass-shell gauge bosons
34550  be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
34551  cth2=cth**2
34552  th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
34553  uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
34554  IF(max(th,uh).GT.-1d0) goto 310
34555  shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
34556  & (1d0-2d0*sqmz/sh)
34557  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
34558  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
34559  atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
34560  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
34561  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
34562  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
34563  & 2d0*(sqmw+sqmz)/sh*be2*cth))
34564  atwim=0d0
34565  auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
34566  & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
34567  & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
34568  & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
34569  & 2d0*(sqmw+sqmz)/sh*be2*cth))
34570  auwim=0d0
34571  a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
34572  a4im=0d0
34573  faczz=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
34574  & (sh/sqmw)**2*sh2
34575  IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
34576  IF(mstp(46).EQ.1) faczz=faczz*((ashre+atwre+auwre+a4re)**2+
34577  & (ashim+atwim+auwim+a4im)**2)
34578  IF(mstp(46).EQ.2) faczz=faczz*((atwre+auwre+a4re)**2+
34579  & (atwim+auwim+a4im)**2)
34580 
34581  ELSE
34582 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34583  faczz=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
34584  & abs(a00u-a20u)**2
34585  ENDIF
34586  faczz=faczz*wids(23,1)
34587 
34588  DO 300 i=mmin1,mmax1
34589  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 300
34590  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
34591  DO 290 j=mmin2,mmax2
34592  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 290
34593  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
34594  IF(ei*ej.GT.0d0) goto 290
34595  nchn=nchn+1
34596  isig(nchn,1)=i
34597  isig(nchn,2)=j
34598  isig(nchn,3)=1
34599  sigh(nchn)=0.5d0*faczz*vint(180+i)*vint(180+j)
34600  290 CONTINUE
34601  300 CONTINUE
34602  310 CONTINUE
34603 
34604  ELSEIF(isub.EQ.77) THEN
34605 C...W+/- + W+/- -> W+/- + W+/-
34606  IF(sh.LE.4.01d0*sqmw) goto 340
34607 
34608  IF(mstp(46).LE.2) THEN
34609 C...Exact scattering ME:s for on-mass-shell gauge bosons
34610  be2=1d0-4d0*sqmw/sh
34611  be4=be2**2
34612  cth2=cth**2
34613  cth3=cth**3
34614  th=-0.5d0*sh*be2*(1d0-cth)
34615  uh=-0.5d0*sh*be2*(1d0+cth)
34616  IF(max(th,uh).GT.-1d0) goto 340
34617  shang=(1d0+be2)**2
34618  ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
34619  ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
34620  thang=(be2-cth)**2
34621  athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
34622  athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
34623  uhang=(be2+cth)**2
34624  auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
34625  auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
34626  sgzang=1d0/sqmw*be2*(3d0-be2)**2*cth
34627  asgre=xw*sgzang
34628  asgim=0d0
34629  aszre=xw1*sh/(sh-sqmz)*sgzang
34630  aszim=0d0
34631  tgzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)+be2*(4d0-10d0*be2+
34632  & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2+be2*cth3)
34633  atgre=0.5d0*xw*sh/th*tgzang
34634  atgim=0d0
34635  atzre=0.5d0*xw1*sh/(th-sqmz)*tgzang
34636  atzim=0d0
34637  ugzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)-be2*(4d0-10d0*be2+
34638  & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2-be2*cth3)
34639  augre=0.5d0*xw*sh/uh*ugzang
34640  augim=0d0
34641  auzre=0.5d0*xw1*sh/(uh-sqmz)*ugzang
34642  auzim=0d0
34643  a4are=1d0/sqmw*(1d0+2d0*be2-6d0*be2*cth-cth2)
34644  a4aim=0d0
34645  a4sre=2d0/sqmw*(1d0+2d0*be2-cth2)
34646  a4sim=0d0
34647  fww=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
34648  & (sh/sqmw)**2*sh2
34649  IF(mstp(46).LE.0) THEN
34650  awware=ashre
34651  awwaim=ashim
34652  awwsre=0d0
34653  awwsim=0d0
34654  ELSEIF(mstp(46).EQ.1) THEN
34655  awware=ashre+athre+asgre+aszre+atgre+atzre+a4are
34656  awwaim=ashim+athim+asgim+aszim+atgim+atzim+a4aim
34657  awwsre=-athre-auhre+atgre+atzre+augre+auzre+a4sre
34658  awwsim=-athim-auhim+atgim+atzim+augim+auzim+a4sim
34659  ELSE
34660  awware=asgre+aszre+atgre+atzre+a4are
34661  awwaim=asgim+aszim+atgim+atzim+a4aim
34662  awwsre=atgre+atzre+augre+auzre+a4sre
34663  awwsim=atgim+atzim+augim+auzim+a4sim
34664  ENDIF
34665  awwa2=awware**2+awwaim**2
34666  awws2=awwsre**2+awwsim**2
34667 
34668  ELSE
34669 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34670  fwwa=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
34671  & abs(a00u+0.5d0*a20u+4.5d0*a11u*dble(cth))**2
34672  fwws=comfac*(aem/(4d0*paru(1)*xw))**2*64d0*abs(a20u)**2
34673  ENDIF
34674 
34675  DO 330 i=mmin1,mmax1
34676  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 330
34677  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
34678  DO 320 j=mmin2,mmax2
34679  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 320
34680  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
34681  IF(ei*ej.LT.0d0) THEN
34682 C...W+W-
34683  IF(mstp(45).EQ.1) goto 320
34684  IF(mstp(46).LE.2) facww=fww*awwa2*wids(24,1)
34685  IF(mstp(46).GE.3) facww=fwwa*wids(24,1)
34686  ELSE
34687 C...W+W+/W-W-
34688  IF(mstp(45).EQ.2) goto 320
34689  IF(mstp(46).LE.2) facww=fww*awws2
34690  IF(mstp(46).GE.3) facww=fwws
34691  IF(ei.GT.0d0) facww=facww*wids(24,4)
34692  IF(ei.LT.0d0) facww=facww*wids(24,5)
34693  ENDIF
34694  nchn=nchn+1
34695  isig(nchn,1)=i
34696  isig(nchn,2)=j
34697  isig(nchn,3)=1
34698  sigh(nchn)=facww*vint(180+i)*vint(180+j)
34699  IF(ei*ej.GT.0d0) sigh(nchn)=0.5d0*sigh(nchn)
34700  320 CONTINUE
34701  330 CONTINUE
34702  340 CONTINUE
34703  ENDIF
34704 
34705  ELSEIF(isub.LE.120) THEN
34706  IF(isub.EQ.102) THEN
34707 C...g + g -> h0 (or H0, or A0)
34708  CALL pywidt(kfhigg,sh,wdtp,wdte)
34709  hs=shr*wdtp(0)
34710  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34711  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
34712  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34713  & facbw=0d0
34714 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34715  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34716  wdtp13=0d0
34717  DO 345 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34718  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34719  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34720  345 CONTINUE
34721  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34722  & '(PYSGHG:) did not find Higgs -> g g channel')
34723  hi=shr*wdtp13/32d0
34724  ELSE
34725  hi=shr*wdtp(13)/32d0
34726  ENDIF
34727  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 350
34728  nchn=nchn+1
34729  isig(nchn,1)=21
34730  isig(nchn,2)=21
34731  isig(nchn,3)=1
34732  sigh(nchn)=hi*facbw*hf
34733  350 CONTINUE
34734 
34735  ELSEIF(isub.EQ.103) THEN
34736 C...gamma + gamma -> h0 (or H0, or A0)
34737  CALL pywidt(kfhigg,sh,wdtp,wdte)
34738  hs=shr*wdtp(0)
34739  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34740  facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
34741  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34742  & facbw=0d0
34743 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34744  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34745  wdtp14=0d0
34746  DO 355 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34747  IF(kfdp(idc,1).EQ.22.AND.kfdp(idc,2).EQ.22.AND.
34748  & kfdp(idc,3).EQ.0) wdtp14=pmas(kfhigg,2)*brat(idc)
34749  355 CONTINUE
34750  IF(wdtp14.EQ.0d0) CALL pyerrm(26,
34751  & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34752  hi=shr*wdtp14*2d0
34753  ELSE
34754  hi=shr*wdtp(14)*2d0
34755  ENDIF
34756  IF(kfac(1,22)*kfac(2,22).EQ.0) goto 360
34757  nchn=nchn+1
34758  isig(nchn,1)=22
34759  isig(nchn,2)=22
34760  isig(nchn,3)=1
34761  sigh(nchn)=hi*facbw*hf
34762  360 CONTINUE
34763 
34764  ELSEIF(isub.EQ.110) THEN
34765 C...f + fbar -> gamma + h0
34766  thuh=max(th*uh,sh*ckin(3)**2)
34767  fachg=comfac*(3d0*aem**4)/(2d0*paru(1)**2*xw*sqmw)*sh*thuh
34768  fachg=fachg*wids(kfhigg,2)
34769 C...Calculate loop contributions for intermediate gamma* and Z0
34770  cigtot=dcmplx(0d0,0d0)
34771  ciztot=dcmplx(0d0,0d0)
34772  jmax=3*mstp(1)+1
34773  DO 370 j=1,jmax
34774  IF(j.LE.2*mstp(1)) THEN
34775  fnc=1d0
34776  ej=kchg(j,1)/3d0
34777  aj=sign(1d0,ej+0.1d0)
34778  vj=aj-4d0*ej*xwv
34779  balp=sqm4/(2d0*pmas(j,1))**2
34780  bbet=sh/(2d0*pmas(j,1))**2
34781  ELSEIF(j.LE.3*mstp(1)) THEN
34782  fnc=3d0
34783  jl=2*(j-2*mstp(1))-1
34784  ej=kchg(10+jl,1)/3d0
34785  aj=sign(1d0,ej+0.1d0)
34786  vj=aj-4d0*ej*xwv
34787  balp=sqm4/(2d0*pmas(10+jl,1))**2
34788  bbet=sh/(2d0*pmas(10+jl,1))**2
34789  ELSE
34790  balp=sqm4/(2d0*pmas(24,1))**2
34791  bbet=sh/(2d0*pmas(24,1))**2
34792  ENDIF
34793  babi=1d0/(balp-bbet)
34794  IF(balp.LT.1d0) THEN
34795  f0alp=dcmplx(dble(asin(sqrt(balp))),0d0)
34796  f1alp=f0alp**2
34797  ELSE
34798  f0alp=dcmplx(dble(log(sqrt(balp)+sqrt(balp-1d0))),
34799  & -dble(0.5d0*paru(1)))
34800  f1alp=-f0alp**2
34801  ENDIF
34802  f2alp=dble(sqrt(abs(balp-1d0)/balp))*f0alp
34803  IF(bbet.LT.1d0) THEN
34804  f0bet=dcmplx(dble(asin(sqrt(bbet))),0d0)
34805  f1bet=f0bet**2
34806  ELSE
34807  f0bet=dcmplx(dble(log(sqrt(bbet)+sqrt(bbet-1d0))),
34808  & -dble(0.5d0*paru(1)))
34809  f1bet=-f0bet**2
34810  ENDIF
34811  f2bet=dble(sqrt(abs(bbet-1d0)/bbet))*f0bet
34812  IF(j.LE.3*mstp(1)) THEN
34813  fif=dble(0.5d0*babi)+dble(babi**2)*(dble(0.5d0*(1d0-balp+
34814  & bbet))*(f1bet-f1alp)+dble(bbet)*(f2bet-f2alp))
34815  cigtot=cigtot+dble(fnc*ej**2)*fif
34816  ciztot=ciztot+dble(fnc*ej*vj)*fif
34817  ELSE
34818  txw=xw/xw1
34819  cigtot=cigtot-0.5*(dble(babi*(1.5d0+balp))+dble(babi**2)*
34820  & (dble(1.5d0-3d0*balp+4d0*bbet)*(f1bet-f1alp)+
34821  & dble(bbet*(2d0*balp+3d0))*(f2bet-f2alp)))
34822  ciztot=ciztot-dble(0.5d0*babi*xw1)*(dble(5d0-txw+2d0*balp*
34823  & (1d0-txw))*(1d0+dble(2d0*babi*bbet)*(f2bet-f2alp))+
34824  & dble(babi*(4d0*bbet*(3d0-txw)-(2d0*balp-1d0)*(5d0-txw)))*
34825  & (f1bet-f1alp))
34826  ENDIF
34827  370 CONTINUE
34828  cigtot=cigtot/dble(sh)
34829  ciztot=ciztot*dble(xwc)/dcmplx(dble(sh-sqmz),dble(gmmz))
34830 C...Loop over initial flavours
34831  DO 380 i=mmina,mmaxa
34832  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 380
34833  ei=kchg(iabs(i),1)/3d0
34834  ai=sign(1d0,ei)
34835  vi=ai-4d0*ei*xwv
34836  fcoi=1d0
34837  IF(iabs(i).LE.10) fcoi=faca/3d0
34838  nchn=nchn+1
34839  isig(nchn,1)=i
34840  isig(nchn,2)=-i
34841  isig(nchn,3)=1
34842  sigh(nchn)=fachg*fcoi*(abs(dble(ei)*cigtot+dble(vi)*
34843  & ciztot)**2+ai**2*abs(ciztot)**2)
34844  380 CONTINUE
34845 
34846  ELSEIF(isub.EQ.111) THEN
34847 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34848  IF(mstp(38).NE.0) THEN
34849 C...Simple case: only do gg <-> h exactly.
34850  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34851 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34852  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34853  wdtp13=0d0
34854  DO 385 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34855  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34856  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34857  385 CONTINUE
34858  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34859  & '(PYSGHG:) did not find Higgs -> g g channel')
34860  facgh=comfac*faca*(2d0/9d0)*as*(wdtp13/sqrt(sqm4))*
34861  & (th**2+uh**2)/(sh*sqm4)
34862  ELSE
34863  facgh=comfac*faca*(2d0/9d0)*as*(wdtp(13)/sqrt(sqm4))*
34864  & (th**2+uh**2)/(sh*sqm4)
34865  ENDIF
34866 C...Propagators: as simulated in PYOFSH and as desired
34867  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34868  gmmhc=sqrt(sqm4)*wdtp(0)
34869  hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34870  & ((sqm4-sqmh)**2+gmmhc**2)
34871  facgh=facgh*hbw4c/hbw4
34872  ELSE
34873 C...Messy case: do full loop integrals
34874  a5stur=0d0
34875  a5stui=0d0
34876  DO 390 i=1,2*mstp(1)
34877  sqmq=pmas(i,1)**2
34878  epss=4d0*sqmq/sh
34879  epsh=4d0*sqmq/sqmh
34880  CALL pywaux(1,epss,w1sr,w1si)
34881  CALL pywaux(1,epsh,w1hr,w1hi)
34882  CALL pywaux(2,epss,w2sr,w2si)
34883  CALL pywaux(2,epsh,w2hr,w2hi)
34884  a5stur=a5stur+epsh*(1d0+sh/(th+uh)*(w1sr-w1hr)+
34885  & (0.25d0-sqmq/(th+uh))*(w2sr-w2hr))
34886  a5stui=a5stui+epsh*(sh/(th+uh)*(w1si-w1hi)+
34887  & (0.25d0-sqmq/(th+uh))*(w2si-w2hi))
34888  390 CONTINUE
34889  facgh=comfac*faca/(144d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
34890  & sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)
34891  facgh=facgh*wids(25,2)
34892  ENDIF
34893  DO 400 i=mmina,mmaxa
34894  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
34895  & kfac(1,i)*kfac(2,-i).EQ.0) goto 400
34896  nchn=nchn+1
34897  isig(nchn,1)=i
34898  isig(nchn,2)=-i
34899  isig(nchn,3)=1
34900  sigh(nchn)=facgh
34901  400 CONTINUE
34902 
34903  ELSEIF(isub.EQ.112) THEN
34904 C...f + g -> f + h0 (q + g -> q + h0 only)
34905  IF(mstp(38).NE.0) THEN
34906 C...Simple case: only do gg <-> h exactly.
34907  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34908 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34909  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34910  wdtp13=0d0
34911  DO 405 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34912  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34913  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34914  405 CONTINUE
34915  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34916  & '(PYSGHG:) did not find Higgs -> g g channel')
34917  facqh=comfac*faca*(1d0/12d0)*as*(wdtp13/sqrt(sqm4))*
34918  & (sh**2+uh**2)/(-th*sqm4)
34919  ELSE
34920  facqh=comfac*faca*(1d0/12d0)*as*(wdtp(13)/sqrt(sqm4))*
34921  & (sh**2+uh**2)/(-th*sqm4)
34922  ENDIF
34923 C...Propagators: as simulated in PYOFSH and as desired
34924  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34925  gmmhc=sqrt(sqm4)*wdtp(0)
34926  hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34927  & ((sqm4-sqmh)**2+gmmhc**2)
34928  facqh=facqh*hbw4c/hbw4
34929  ELSE
34930 C...Messy case: do full loop integrals
34931  a5tsur=0d0
34932  a5tsui=0d0
34933  DO 410 i=1,2*mstp(1)
34934  sqmq=pmas(i,1)**2
34935  epst=4d0*sqmq/th
34936  epsh=4d0*sqmq/sqmh
34937  CALL pywaux(1,epst,w1tr,w1ti)
34938  CALL pywaux(1,epsh,w1hr,w1hi)
34939  CALL pywaux(2,epst,w2tr,w2ti)
34940  CALL pywaux(2,epsh,w2hr,w2hi)
34941  a5tsur=a5tsur+epsh*(1d0+th/(sh+uh)*(w1tr-w1hr)+
34942  & (0.25d0-sqmq/(sh+uh))*(w2tr-w2hr))
34943  a5tsui=a5tsui+epsh*(th/(sh+uh)*(w1ti-w1hi)+
34944  & (0.25d0-sqmq/(sh+uh))*(w2ti-w2hi))
34945  410 CONTINUE
34946  facqh=comfac*faca/(384d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
34947  & sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)
34948  facqh=facqh*wids(25,2)
34949  ENDIF
34950  DO 430 i=mmina,mmaxa
34951  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 430
34952  DO 420 isde=1,2
34953  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 420
34954  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 420
34955  nchn=nchn+1
34956  isig(nchn,isde)=i
34957  isig(nchn,3-isde)=21
34958  isig(nchn,3)=1
34959  sigh(nchn)=facqh
34960  420 CONTINUE
34961  430 CONTINUE
34962 
34963  ELSEIF(isub.EQ.113) THEN
34964 C...g + g -> g + h0
34965  IF(mstp(38).NE.0) THEN
34966 C...Simple case: only do gg <-> h exactly.
34967  CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34968 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34969  IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34970  wdtp13=0d0
34971  DO 435 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34972  IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34973  & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34974  435 CONTINUE
34975  IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34976  & '(PYSGHG:) did not find Higgs -> g g channel')
34977  facgh=comfac*faca*(3d0/16d0)*as*(wdtp13/sqrt(sqm4))*
34978  & (sh**4+th**4+uh**4+sqm4**4)/(sh*th*uh*sqm4)
34979  ELSE
34980  facgh=comfac*faca*(3d0/16d0)*as*(wdtp(13)/sqrt(sqm4))*
34981  & (sh**4+th**4+uh**4+sqm4**4)/(sh*th*uh*sqm4)
34982  ENDIF
34983 C...Propagators: as simulated in PYOFSH and as desired
34984  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34985  gmmhc=sqrt(sqm4)*wdtp(0)
34986  hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34987  & ((sqm4-sqmh)**2+gmmhc**2)
34988  facgh=facgh*hbw4c/hbw4
34989  ELSE
34990 C...Messy case: do full loop integrals
34991  a2stur=0d0
34992  a2stui=0d0
34993  a2ustr=0d0
34994  a2usti=0d0
34995  a2tusr=0d0
34996  a2tusi=0d0
34997  a4stur=0d0
34998  a4stui=0d0
34999  DO 440 i=1,2*mstp(1)
35000  sqmq=pmas(i,1)**2
35001  epss=4d0*sqmq/sh
35002  epst=4d0*sqmq/th
35003  epsu=4d0*sqmq/uh
35004  epsh=4d0*sqmq/sqmh
35005  IF(epsh.LT.1d-6) goto 440
35006  CALL pywaux(1,epss,w1sr,w1si)
35007  CALL pywaux(1,epst,w1tr,w1ti)
35008  CALL pywaux(1,epsu,w1ur,w1ui)
35009  CALL pywaux(1,epsh,w1hr,w1hi)
35010  CALL pywaux(2,epss,w2sr,w2si)
35011  CALL pywaux(2,epst,w2tr,w2ti)
35012  CALL pywaux(2,epsu,w2ur,w2ui)
35013  CALL pywaux(2,epsh,w2hr,w2hi)
35014  CALL pyi3au(epss,th/uh,y3stur,y3stui)
35015  CALL pyi3au(epss,uh/th,y3sutr,y3suti)
35016  CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
35017  CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
35018  CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
35019  CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
35020  CALL pyi3au(epsh,sqmh/sh*th/uh,yhstur,yhstui)
35021  CALL pyi3au(epsh,sqmh/sh*uh/th,yhsutr,yhsuti)
35022  CALL pyi3au(epsh,sqmh/th*sh/uh,yhtsur,yhtsui)
35023  CALL pyi3au(epsh,sqmh/th*uh/sh,yhtusr,yhtusi)
35024  CALL pyi3au(epsh,sqmh/uh*sh/th,yhustr,yhusti)
35025  CALL pyi3au(epsh,sqmh/uh*th/sh,yhutsr,yhutsi)
35026  w3stur=yhstur-y3stur-y3utsr
35027  w3stui=yhstui-y3stui-y3utsi
35028  w3sutr=yhsutr-y3sutr-y3tusr
35029  w3suti=yhsuti-y3suti-y3tusi
35030  w3tsur=yhtsur-y3tsur-y3ustr
35031  w3tsui=yhtsui-y3tsui-y3usti
35032  w3tusr=yhtusr-y3tusr-y3sutr
35033  w3tusi=yhtusi-y3tusi-y3suti
35034  w3ustr=yhustr-y3ustr-y3tsur
35035  w3usti=yhusti-y3usti-y3tsui
35036  w3utsr=yhutsr-y3utsr-y3stur
35037  w3utsi=yhutsi-y3utsi-y3stui
35038  b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2d0*th*uh*
35039  & (uh+2d0*sh)/(sh+uh)**2*(w1tr-w1hr)+(sqmq-sh/4d0)*
35040  & (0.5d0*w2sr+0.5d0*w2hr-w2tr+w3stur)+sh2*(2d0*sqmq/
35041  & (sh+uh)**2-0.5d0/(sh+uh))*(w2tr-w2hr)+0.5d0*th*uh/sh*
35042  & (w2hr-2d0*w2tr)+0.125d0*(sh-12d0*sqmq-4d0*th*uh/sh)*w3tsur)
35043  b2stui=sqmq/sqmh**2*(2d0*th*uh*(uh+2d0*sh)/(sh+uh)**2*
35044  & (w1ti-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ti+
35045  & w3stui)+sh2*(2d0*sqmq/(sh+uh)**2-0.5d0/(sh+uh))*
35046  & (w2ti-w2hi)+0.5d0*th*uh/sh*(w2hi-2d0*w2ti)+0.125d0*
35047  & (sh-12d0*sqmq-4d0*th*uh/sh)*w3tsui)
35048  b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2d0*uh*th*
35049  & (th+2d0*sh)/(sh+th)**2*(w1ur-w1hr)+(sqmq-sh/4d0)*
35050  & (0.5d0*w2sr+0.5d0*w2hr-w2ur+w3sutr)+sh2*(2d0*sqmq/
35051  & (sh+th)**2-0.5d0/(sh+th))*(w2ur-w2hr)+0.5d0*uh*th/sh*
35052  & (w2hr-2d0*w2ur)+0.125d0*(sh-12d0*sqmq-4d0*uh*th/sh)*w3ustr)
35053  b2suti=sqmq/sqmh**2*(2d0*uh*th*(th+2d0*sh)/(sh+th)**2*
35054  & (w1ui-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ui+
35055  & w3suti)+sh2*(2d0*sqmq/(sh+th)**2-0.5d0/(sh+th))*
35056  & (w2ui-w2hi)+0.5d0*uh*th/sh*(w2hi-2d0*w2ui)+0.125d0*
35057  & (sh-12d0*sqmq-4d0*uh*th/sh)*w3usti)
35058  b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2d0*sh*uh*
35059  & (uh+2d0*th)/(th+uh)**2*(w1sr-w1hr)+(sqmq-th/4d0)*
35060  & (0.5d0*w2tr+0.5d0*w2hr-w2sr+w3tsur)+th2*(2d0*sqmq/
35061  & (th+uh)**2-0.5d0/(th+uh))*(w2sr-w2hr)+0.5d0*sh*uh/th*
35062  & (w2hr-2d0*w2sr)+0.125d0*(th-12d0*sqmq-4d0*sh*uh/th)*w3stur)
35063  b2tsui=sqmq/sqmh**2*(2d0*sh*uh*(uh+2d0*th)/(th+uh)**2*
35064  & (w1si-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2si+
35065  & w3tsui)+th2*(2d0*sqmq/(th+uh)**2-0.5d0/(th+uh))*
35066  & (w2si-w2hi)+0.5d0*sh*uh/th*(w2hi-2d0*w2si)+0.125d0*
35067  & (th-12d0*sqmq-4d0*sh*uh/th)*w3stui)
35068  b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2d0*uh*sh*
35069  & (sh+2d0*th)/(th+sh)**2*(w1ur-w1hr)+(sqmq-th/4d0)*
35070  & (0.5d0*w2tr+0.5d0*w2hr-w2ur+w3tusr)+th2*(2d0*sqmq/
35071  & (th+sh)**2-0.5d0/(th+sh))*(w2ur-w2hr)+0.5d0*uh*sh/th*
35072  & (w2hr-2d0*w2ur)+0.125d0*(th-12d0*sqmq-4d0*uh*sh/th)*w3utsr)
35073  b2tusi=sqmq/sqmh**2*(2d0*uh*sh*(sh+2d0*th)/(th+sh)**2*
35074  & (w1ui-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2ui+
35075  & w3tusi)+th2*(2d0*sqmq/(th+sh)**2-0.5d0/(th+sh))*
35076  & (w2ui-w2hi)+0.5d0*uh*sh/th*(w2hi-2d0*w2ui)+0.125d0*
35077  & (th-12d0*sqmq-4d0*uh*sh/th)*w3utsi)
35078  b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2d0*sh*th*
35079  & (th+2d0*uh)/(uh+th)**2*(w1sr-w1hr)+(sqmq-uh/4d0)*
35080  & (0.5d0*w2ur+0.5d0*w2hr-w2sr+w3ustr)+uh2*(2d0*sqmq/
35081  & (uh+th)**2-0.5d0/(uh+th))*(w2sr-w2hr)+0.5d0*sh*th/uh*
35082  & (w2hr-2d0*w2sr)+0.125d0*(uh-12d0*sqmq-4d0*sh*th/uh)*w3sutr)
35083  b2usti=sqmq/sqmh**2*(2d0*sh*th*(th+2d0*uh)/(uh+th)**2*
35084  & (w1si-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2si+
35085  & w3usti)+uh2*(2d0*sqmq/(uh+th)**2-0.5d0/(uh+th))*
35086  & (w2si-w2hi)+0.5d0*sh*th/uh*(w2hi-2d0*w2si)+0.125d0*
35087  & (uh-12d0*sqmq-4d0*sh*th/uh)*w3suti)
35088  b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2d0*th*sh*
35089  & (sh+2d0*uh)/(uh+sh)**2*(w1tr-w1hr)+(sqmq-uh/4d0)*
35090  & (0.5d0*w2ur+0.5d0*w2hr-w2tr+w3utsr)+uh2*(2d0*sqmq/
35091  & (uh+sh)**2-0.5d0/(uh+sh))*(w2tr-w2hr)+0.5d0*th*sh/uh*
35092  & (w2hr-2d0*w2tr)+0.125d0*(uh-12d0*sqmq-4d0*th*sh/uh)*w3tusr)
35093  b2utsi=sqmq/sqmh**2*(2d0*th*sh*(sh+2d0*uh)/(uh+sh)**2*
35094  & (w1ti-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2ti+
35095  & w3utsi)+uh2*(2d0*sqmq/(uh+sh)**2-0.5d0/(uh+sh))*
35096  & (w2ti-w2hi)+0.5d0*th*sh/uh*(w2hi-2d0*w2ti)+0.125d0*
35097  & (uh-12d0*sqmq-4d0*th*sh/uh)*w3tusi)
35098  b4stur=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
35099  & (w2sr-w2hr+w3stur))
35100  b4stui=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2si-w2hi+w3stui)
35101  b4tusr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
35102  & (w2tr-w2hr+w3tusr))
35103  b4tusi=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ti-w2hi+w3tusi)
35104  b4ustr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
35105  & (w2ur-w2hr+w3ustr))
35106  b4usti=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ui-w2hi+w3usti)
35107  a2stur=a2stur+b2stur+b2sutr
35108  a2stui=a2stui+b2stui+b2suti
35109  a2ustr=a2ustr+b2ustr+b2utsr
35110  a2usti=a2usti+b2usti+b2utsi
35111  a2tusr=a2tusr+b2tusr+b2tsur
35112  a2tusi=a2tusi+b2tusi+b2tsui
35113  a4stur=a4stur+b4stur+b4ustr+b4tusr
35114  a4stui=a4stui+b4stui+b4usti+b4tusi
35115  440 CONTINUE
35116  facgh=comfac*faca*3d0/(128d0*paru(1)**2)*aem/xw*as**3*
35117  & sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+
35118  & a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)
35119  facgh=facgh*wids(25,2)
35120  ENDIF
35121  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 450
35122  nchn=nchn+1
35123  isig(nchn,1)=21
35124  isig(nchn,2)=21
35125  isig(nchn,3)=1
35126  sigh(nchn)=facgh
35127  450 CONTINUE
35128  ENDIF
35129 
35130  ELSEIF(isub.LE.170) THEN
35131  IF(isub.EQ.121) THEN
35132 C...g + g -> Q + Qbar + h0
35133  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 460
35134  ia=kfpr(isubsv,2)
35135  pmf=pymrun(ia,sh)
35136  facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
35137  & (0.5d0*pmf/pmas(24,1))**2
35138  wid2=1d0
35139  IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
35140  facqqh=facqqh*wid2
35141  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
35142  ikfi=1
35143  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
35144  IF(ia.GT.10) ikfi=3
35145  facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
35146  IF(imss(1).NE.0.AND.ia.EQ.5) THEN
35147  facqqh=facqqh/(1d0+rmss(41))**2
35148  IF(ihigg.NE.3) THEN
35149  facqqh=facqqh*(1d0+rmss(41)*paru(152+10*ihigg)/
35150  & paru(151+10*ihigg))**2
35151  ENDIF
35152  ENDIF
35153  ENDIF
35154  CALL pyqqbh(wtqqbh)
35155  CALL pywidt(kfhigg,sh,wdtp,wdte)
35156  hs=shr*wdtp(0)
35157  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
35158  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
35159  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
35160  & facbw=0d0
35161  nchn=nchn+1
35162  isig(nchn,1)=21
35163  isig(nchn,2)=21
35164  isig(nchn,3)=1
35165  sigh(nchn)=facqqh*wtqqbh*facbw
35166  460 CONTINUE
35167 
35168  ELSEIF(isub.EQ.122) THEN
35169 C...q + qbar -> Q + Qbar + h0
35170  ia=kfpr(isubsv,2)
35171  pmf=pymrun(ia,sh)
35172  facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
35173  & (0.5d0*pmf/pmas(24,1))**2
35174  wid2=1d0
35175  IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
35176  facqqh=facqqh*wid2
35177  IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
35178  ikfi=1
35179  IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
35180  IF(ia.GT.10) ikfi=3
35181  facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
35182  IF(imss(1).NE.0.AND.ia.EQ.5) THEN
35183  facqqh=facqqh/(1d0+rmss(41))**2
35184  IF(ihigg.NE.3) THEN
35185  facqqh=facqqh*(1d0+rmss(41)*paru(152+10*ihigg)/
35186  & paru(151+10*ihigg))**2
35187  ENDIF
35188  ENDIF
35189  ENDIF
35190  CALL pyqqbh(wtqqbh)
35191  CALL pywidt(kfhigg,sh,wdtp,wdte)
35192  hs=shr*wdtp(0)
35193  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
35194  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
35195  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
35196  & facbw=0d0
35197  DO 470 i=mmina,mmaxa
35198  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
35199  & kfac(1,i)*kfac(2,-i).EQ.0) goto 470
35200  nchn=nchn+1
35201  isig(nchn,1)=i
35202  isig(nchn,2)=-i
35203  isig(nchn,3)=1
35204  sigh(nchn)=facqqh*wtqqbh*facbw
35205  470 CONTINUE
35206 
35207  ELSEIF(isub.EQ.123) THEN
35208 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
35209 C...inner process)
35210  facnor=comfac*(4d0*paru(1)*aem/(xw*xw1))**3*sqmz/32d0
35211  IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
35212  & paru(154+10*ihigg)**2
35213  facprp=1d0/((vint(215)-vint(204)**2)*
35214  & (vint(216)-vint(209)**2))**2
35215  faczz1=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
35216  faczz2=facnor*facprp*vint(217)*vint(218)
35217  CALL pywidt(kfhigg,sh,wdtp,wdte)
35218  hs=shr*wdtp(0)
35219  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
35220  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
35221  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
35222  & facbw=0d0
35223  DO 490 i=mmin1,mmax1
35224  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 490
35225  ia=iabs(i)
35226  DO 480 j=mmin2,mmax2
35227  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 480
35228  ja=iabs(j)
35229  ei=kchg(ia,1)*isign(1,i)/3d0
35230  ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
35231  vi=ai-4d0*ei*xwv
35232  ej=kchg(ja,1)*isign(1,j)/3d0
35233  aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
35234  vj=aj-4d0*ej*xwv
35235  faclr1=(vi**2+ai**2)*(vj**2+aj**2)+4d0*vi*ai*vj*aj
35236  faclr2=(vi**2+ai**2)*(vj**2+aj**2)-4d0*vi*ai*vj*aj
35237  nchn=nchn+1
35238  isig(nchn,1)=i
35239  isig(nchn,2)=j
35240  isig(nchn,3)=1
35241  sigh(nchn)=(faclr1*faczz1+faclr2*faczz2)*facbw
35242  480 CONTINUE
35243  490 CONTINUE
35244 
35245  ELSEIF(isub.EQ.124) THEN
35246 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
35247 C...inner process)
35248  facnor=comfac*(4d0*paru(1)*aem/xw)**3*sqmw
35249  IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
35250  & paru(155+10*ihigg)**2
35251  facprp=1d0/((vint(215)-vint(204)**2)*
35252  & (vint(216)-vint(209)**2))**2
35253  facww=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
35254  CALL pywidt(kfhigg,sh,wdtp,wdte)
35255  hs=shr*wdtp(0)
35256  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
35257  facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
35258  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
35259  & facbw=0d0
35260  DO 510 i=mmin1,mmax1
35261  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 510
35262  ei=sign(1d0,dble(i))*kchg(iabs(i),1)
35263  DO 500 j=mmin2,mmax2
35264  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 500
35265  ej=sign(1d0,dble(j))*kchg(iabs(j),1)
35266  IF(ei*ej.GT.0d0) goto 500
35267  faclr=vint(180+i)*vint(180+j)
35268  nchn=nchn+1
35269  isig(nchn,1)=i
35270  isig(nchn,2)=j
35271  isig(nchn,3)=1
35272  sigh(nchn)=faclr*facww*facbw
35273  500 CONTINUE
35274  510 CONTINUE
35275 
35276  ELSEIF(isub.EQ.143) THEN
35277 C...f + fbar' -> H+/-
35278  sqmhc=pmas(37,1)**2
35279  CALL pywidt(37,sh,wdtp,wdte)
35280  hs=shr*wdtp(0)
35281  facbw=4d0*comfac/((sh-sqmhc)**2+hs**2)
35282  hp=aem/(8d0*xw)*sh/sqmw*sh
35283  DO 530 i=mmin1,mmax1
35284  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 530
35285  ia=iabs(i)
35286  im=(mod(ia,10)+1)/2
35287  DO 520 j=mmin2,mmax2
35288  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 520
35289  ja=iabs(j)
35290  jm=(mod(ja,10)+1)/2
35291  IF(i*j.GT.0.OR.ia.EQ.ja.OR.im.NE.jm) goto 520
35292  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
35293  & goto 520
35294  IF(mod(ia,2).EQ.0) THEN
35295  iu=ia
35296  il=ja
35297  ELSE
35298  iu=ja
35299  il=ia
35300  ENDIF
35301  rml=pymrun(il,sh)**2/sh
35302  rmu=pymrun(iu,sh)**2/sh
35303  hi=hp*(rml*paru(141)**2+rmu/paru(141)**2)
35304  IF(ia.LE.10) hi=hi*faca/3d0
35305  kchhc=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
35306  hf=shr*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
35307  nchn=nchn+1
35308  isig(nchn,1)=i
35309  isig(nchn,2)=j
35310  isig(nchn,3)=1
35311  sigh(nchn)=hi*facbw*hf
35312  520 CONTINUE
35313  530 CONTINUE
35314 
35315  ELSEIF(isub.EQ.161) THEN
35316 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
35317 C...(choice of only b and t to avoid kinematics problems)
35318  fhcq=comfac*faca*as*aem/xw*1d0/24
35319 C...H propagator: as simulated in PYOFSH and as desired
35320  sqmhc=pmas(37,1)**2
35321  gmmhc=pmas(37,1)*pmas(37,2)
35322  hbw4=gmmhc/((sqm4-sqmhc)**2+gmmhc**2)
35323  CALL pywidt(37,sqm4,wdtp,wdte)
35324  gmmhcc=sqrt(sqm4)*wdtp(0)
35325  hbw4c=gmmhcc/((sqm4-sqmhc)**2+gmmhcc**2)
35326  fhcq=fhcq*hbw4c/hbw4
35327  q2rm=sh
35328  IF(mstp(32).EQ.12) q2rm=parp(194)
35329  DO 550 i=mmina,mmaxa
35330  ia=iabs(i)
35331  IF(ia.NE.5) goto 550
35332  sqml=pymrun(ia,q2rm)**2
35333  iua=ia+mod(ia,2)
35334  sqmq=pymrun(iua,q2rm)**2
35335  fachcq=fhcq*(sqml*paru(141)**2+sqmq/paru(141)**2)/sqmw*
35336  & (sh/(sqmq-uh)+2d0*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh-
35337  & 2d0*sqmq/(sqmq-uh)+2d0*(sqmhc-uh)/(sqmq-uh)*
35338  & (sqmhc-sqmq-sh)/sh)
35339  kchhc=isign(1,kchg(ia,1)*isign(1,i))
35340  DO 540 isde=1,2
35341  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 540
35342  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 540
35343  nchn=nchn+1
35344  isig(nchn,isde)=i
35345  isig(nchn,3-isde)=21
35346  isig(nchn,3)=1
35347  sigh(nchn)=fachcq*wids(37,(5-kchhc)/2)
35348  IF(iua.EQ.6) sigh(nchn)=sigh(nchn)*wids(6,(5+kchhc)/2)
35349  540 CONTINUE
35350  550 CONTINUE
35351  ENDIF
35352 
35353  ELSEIF(isub.LE.402) THEN
35354  IF(isub.EQ.401) THEN
35355 C... g + g -> t + bbar + H-
35356  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 560
35357  ia=kfpr(isubsv,2)
35358  CALL pystbh(wttbh)
35359  CALL pywidt(kfhigg,sh,wdtp,wdte)
35360  hs=shr*wdtp(0)
35361  facbw=(1d0/paru(1))*vint(2)*hs/((sh-sqmh)**2+hs**2)
35362  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
35363  & facbw=0d0
35364  nchn=nchn+1
35365  isig(nchn,1)=21
35366  isig(nchn,2)=21
35367  isig(nchn,3)=1
35368  sigh(nchn)=2d0*comfac*wttbh*facbw
35369 c Since we don't know yet if H+ or H-, assume H+
35370 c when calculating suppression due to closed channels.
35371  sigh(nchn)=sigh(nchn)*wids(37,2)*wids(6,3)
35372  IF(abs(wids(37,2)-wids(37,3))
35373  & .GE.1d-6*(wids(37,2)+wids(37,3)).OR.
35374  & abs(wids(6,2)-wids(6,3))
35375  & .GE.1d-6*(wids(6,2)+wids(6,3))) THEN
35376  WRITE(*,*)'Error: Process 401 cannot handle different'
35377  WRITE(*,*)'decays for H+ and H- or t and tbar.'
35378  WRITE(*,*)'Execution stopped.'
35379  CALL pystop(108)
35380  END IF
35381  560 CONTINUE
35382 
35383  ELSEIF(isub.EQ.402) THEN
35384 C... q + qbar -> t + bbar + H-
35385  ia=kfpr(isubsv,2)
35386  CALL pystbh(wttbh)
35387  CALL pywidt(kfhigg,sh,wdtp,wdte)
35388  hs=shr*wdtp(0)
35389  facbw=(1d0/paru(1))*vint(2)*hs/((sh-sqmh)**2+hs**2)
35390  IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
35391  & facbw=0d0
35392  DO 570 i=mmina,mmaxa
35393  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
35394  & kfac(1,i)*kfac(2,-i).EQ.0) goto 570
35395  nchn=nchn+1
35396  isig(nchn,1)=i
35397  isig(nchn,2)=-i
35398  isig(nchn,3)=1
35399  sigh(nchn)=2d0*comfac*wttbh*facbw
35400 c Since we don't know yet if H+ or H-, assume H+
35401 c when calculating suppression due to closed channels.
35402  sigh(nchn)=sigh(nchn)*wids(37,2)*wids(6,3)
35403  IF(abs(wids(37,2)-wids(37,3))/(wids(37,2)+wids(37,3))
35404  & .GE.1d-6.OR.
35405  & abs(wids(6,2)-wids(6,3))/(wids(6,2)+wids(6,3))
35406  & .GE.1d-6) THEN
35407  WRITE(*,*)'Error: Process 402 cannot handle different'
35408  WRITE(*,*)'decays for H+ and H- or t and tbar.'
35409  WRITE(*,*)'Execution stopped.'
35410  CALL pystop(108)
35411  END IF
35412  570 CONTINUE
35413  ENDIF
35414  ENDIF
35415 
35416  RETURN
35417  END
35418 
35419 C*********************************************************************
35420 
35421 C...PYSGSU
35422 C...Subprocess cross sections for SUSY processes,
35423 C...including Higgs pair production.
35424 C...Auxiliary to PYSIGH.
35425 
35426  SUBROUTINE pysgsu(NCHN,SIGS)
35427 
35428 C...Double precision and integer declarations
35429  IMPLICIT DOUBLE PRECISION(a-h, o-z)
35430  IMPLICIT INTEGER(i-n)
35431  INTEGER pyk,pychge,pycomp
35432 C...Parameter statement to help give large particle numbers.
35433  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
35434  &kexcit=4000000,kdimen=5000000)
35435 C...Commonblocks
35436  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
35437  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
35438  common/pypars/mstp(200),parp(200),msti(200),pari(200)
35439  common/pyint1/mint(400),vint(400)
35440  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
35441  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
35442  common/pyint4/mwid(500),wids(500,5)
35443  common/pymssm/imss(0:99),rmss(0:99)
35444  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
35445  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
35446  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
35447  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
35448  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
35449  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
35450  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
35451  &/pyint4/,/pymssm/,/pyssmt/,/pysgcm/
35452 C...Local arrays and complex variables
35453  dimension wdtp(0:400),wdte(0:400,0:5)
35454  COMPLEX*16 olpp,orpp,olp,orp,ol,or,qll,qlr
35455  COMPLEX*16 qrr,qrl,glij,grij,propw,propz
35456  COMPLEX*16 zmixc(4,4),umixc(2,2),vmixc(2,2)
35457 
35458 CMRENNA++
35459 C...Z and W width, combinations of weak mixing angle
35460  zwid=pmas(23,2)
35461  wwid=pmas(24,2)
35462  tanw=sqrt(xw/xw1)
35463  ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
35464 
35465 C...Convert almost equivalent SUSY processes into each other
35466 C...Extract differences in flavours and couplings
35467 
35468 C...Sleptons and sneutrinos
35469  IF(isub.EQ.201.OR.isub.EQ.204.OR.isub.EQ.207) THEN
35470  kfid=mod(kfpr(isub,1),ksusy1)
35471  isub=201
35472  ilr=0
35473  ELSEIF(isub.EQ.202.OR.isub.EQ.205.OR.isub.EQ.208) THEN
35474  kfid=mod(kfpr(isub,1),ksusy1)
35475  isub=201
35476  ilr=1
35477  ELSEIF(isub.EQ.203.OR.isub.EQ.206.OR.isub.EQ.209) THEN
35478  kfid=mod(kfpr(isub,1),ksusy1)
35479  isub=203
35480  ELSEIF(isub.GE.210.AND.isub.LE.212) THEN
35481  IF(isub.EQ.210) THEN
35482  rkf=2.0d0
35483  ELSEIF(isub.EQ.211) THEN
35484  rkf=sfmix(15,1)**2
35485  ELSEIF(isub.EQ.212) THEN
35486  rkf=sfmix(15,2)**2
35487  ENDIF
35488  isub=210
35489  ELSEIF(isub.EQ.213.OR.isub.EQ.214) THEN
35490  IF(isub.EQ.213) THEN
35491  kfid=mod(kfpr(isub,1),ksusy1)
35492  rkf=2.0d0
35493  ELSEIF(isub.EQ.214) THEN
35494  kfid=16
35495  rkf=1.0d0
35496  ENDIF
35497  isub=213
35498 
35499 C...Neutralinos
35500  ELSEIF(isub.GE.216.AND.isub.LE.225) THEN
35501  IF(isub.EQ.216) THEN
35502  izid1=1
35503  izid2=1
35504  ELSEIF(isub.EQ.217) THEN
35505  izid1=2
35506  izid2=2
35507  ELSEIF(isub.EQ.218) THEN
35508  izid1=3
35509  izid2=3
35510  ELSEIF(isub.EQ.219) THEN
35511  izid1=4
35512  izid2=4
35513  ELSEIF(isub.EQ.220) THEN
35514  izid1=1
35515  izid2=2
35516  ELSEIF(isub.EQ.221) THEN
35517  izid1=1
35518  izid2=3
35519  ELSEIF(isub.EQ.222) THEN
35520  izid1=1
35521  izid2=4
35522  ELSEIF(isub.EQ.223) THEN
35523  izid1=2
35524  izid2=3
35525  ELSEIF(isub.EQ.224) THEN
35526  izid1=2
35527  izid2=4
35528  ELSEIF(isub.EQ.225) THEN
35529  izid1=3
35530  izid2=4
35531  ENDIF
35532  isub=216
35533 
35534 C...Charginos
35535  ELSEIF(isub.GE.226.AND.isub.LE.228) THEN
35536  IF(isub.EQ.226) THEN
35537  izid1=1
35538  izid2=1
35539  ELSEIF(isub.EQ.227) THEN
35540  izid1=2
35541  izid2=2
35542  ELSEIF(isub.EQ.228) THEN
35543  izid1=1
35544  izid2=2
35545  ENDIF
35546  isub=226
35547 
35548 C...Neutralino + chargino
35549  ELSEIF(isub.GE.229.AND.isub.LE.236) THEN
35550  IF(isub.EQ.229) THEN
35551  izid1=1
35552  izid2=1
35553  ELSEIF(isub.EQ.230) THEN
35554  izid1=1
35555  izid2=2
35556  ELSEIF(isub.EQ.231) THEN
35557  izid1=1
35558  izid2=3
35559  ELSEIF(isub.EQ.232) THEN
35560  izid1=1
35561  izid2=4
35562  ELSEIF(isub.EQ.233) THEN
35563  izid1=2
35564  izid2=1
35565  ELSEIF(isub.EQ.234) THEN
35566  izid1=2
35567  izid2=2
35568  ELSEIF(isub.EQ.235) THEN
35569  izid1=2
35570  izid2=3
35571  ELSEIF(isub.EQ.236) THEN
35572  izid1=2
35573  izid2=4
35574  ENDIF
35575  isub=229
35576 
35577 C...Gluino + neutralino
35578  ELSEIF(isub.GE.237.AND.isub.LE.240) THEN
35579  IF(isub.EQ.237) THEN
35580  izid=1
35581  ELSEIF(isub.EQ.238) THEN
35582  izid=2
35583  ELSEIF(isub.EQ.239) THEN
35584  izid=3
35585  ELSEIF(isub.EQ.240) THEN
35586  izid=4
35587  ENDIF
35588  isub=237
35589 
35590 C...Gluino + chargino
35591  ELSEIF(isub.GE.241.AND.isub.LE.242) THEN
35592  IF(isub.EQ.241) THEN
35593  izid=1
35594  ELSEIF(isub.EQ.242) THEN
35595  izid=2
35596  ENDIF
35597  isub=241
35598 
35599 C...Squark + neutralino
35600  ELSEIF(isub.GE.246.AND.isub.LE.253) THEN
35601  ilr=0
35602  IF(mod(isub,2).NE.0) ilr=1
35603  IF(isub.LE.247) THEN
35604  izid=1
35605  ELSEIF(isub.LE.249) THEN
35606  izid=2
35607  ELSEIF(isub.LE.251) THEN
35608  izid=3
35609  ELSEIF(isub.LE.253) THEN
35610  izid=4
35611  ENDIF
35612  isub=246
35613  rkf=5d0
35614 
35615 C...Squark + chargino
35616  ELSEIF(isub.GE.254.AND.isub.LE.257) THEN
35617  IF(isub.LE.255) THEN
35618  izid=1
35619  ELSEIF(isub.LE.257) THEN
35620  izid=2
35621  ENDIF
35622  IF(mod(isub,2).EQ.0) THEN
35623  ilr=0
35624  ELSE
35625  ilr=1
35626  ENDIF
35627  isub=254
35628  rkf=5d0
35629 
35630 C...Squark + gluino
35631  ELSEIF(isub.EQ.258.OR.isub.EQ.259) THEN
35632  isub=258
35633  rkf=4d0
35634 
35635 C...Stops
35636  ELSEIF(isub.EQ.261.OR.isub.EQ.262) THEN
35637  ilr=0
35638  IF(isub.EQ.262) ilr=1
35639  isub=261
35640  ELSEIF(isub.EQ.265) THEN
35641  isub=264
35642 
35643 C...Squarks
35644  ELSEIF(isub.GE.271.AND.isub.LE.280) THEN
35645  ilr=0
35646  IF(isub.LE.273) THEN
35647  IF(isub.EQ.273) ilr=1
35648  isub=271
35649  rkf=16d0
35650  ELSEIF(isub.LE.276) THEN
35651  IF(isub.EQ.276) ilr=1
35652  isub=274
35653  rkf=16d0
35654  ELSEIF(isub.LE.278) THEN
35655  IF(isub.EQ.278) ilr=1
35656  isub=277
35657  rkf=4d0
35658  ELSE
35659  IF(isub.EQ.280) ilr=1
35660  isub=279
35661  rkf=4d0
35662  ENDIF
35663 C...Sbottoms
35664  ELSEIF(isub.GE.281.AND.isub.LE.296) THEN
35665  ilr=0
35666  IF(isub.LE.283) THEN
35667  IF(isub.EQ.283) ilr=1
35668  isub=271
35669  rkf=4d0
35670  ELSEIF(isub.LE.286) THEN
35671  IF(isub.EQ.286) ilr=1
35672  isub=274
35673  rkf=4d0
35674  ELSEIF(isub.LE.288) THEN
35675  IF(isub.EQ.288) ilr=1
35676  isub=277
35677  rkf=1d0
35678  ELSEIF(isub.LE.290) THEN
35679  IF(isub.EQ.290) ilr=1
35680  isub=279
35681  rkf=1d0
35682  ELSEIF(isub.LE.293) THEN
35683  IF(isub.EQ.293) ilr=1
35684  isub=271
35685  rkf=1d0
35686  ELSEIF(isub.EQ.296) THEN
35687  ilr=1
35688  isub=274
35689  rkf=1d0
35690 C...Squark + gluino
35691  ELSEIF(isub.EQ.294.OR.isub.EQ.295) THEN
35692  isub=258
35693  rkf=1d0
35694  ENDIF
35695 C...H+/- + H0
35696  ELSEIF(isub.EQ.297.OR.isub.EQ.298) THEN
35697  IF(isub.EQ.297) THEN
35698  rkf=.5d0*paru(195)**2
35699  ELSEIF(isub.EQ.298) THEN
35700  rkf=.5d0*(1d0-paru(195)**2)
35701  ENDIF
35702  isub=210
35703 C...A0 + H0
35704  ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
35705  IF(isub.EQ.299) THEN
35706  rkf=paru(186)**2
35707  kfid=25
35708  ELSEIF(isub.EQ.300) THEN
35709  rkf=paru(187)**2
35710  kfid=35
35711  ENDIF
35712  isub=213
35713 C...H+ + H-
35714  ELSEIF(isub.EQ.301) THEN
35715  kfid=37
35716  rkf=1d0
35717  isub=201
35718  ENDIF
35719 
35720 C...Supersymmetric processes - all of type 2 -> 2 :
35721 C...correct final-state Breit-Wigners from fixed to running width.
35722  IF(mstp(42).GT.0) THEN
35723  DO 100 i=1,2
35724  kflw=kfpr(isubsv,i)
35725  kcw=pycomp(kflw)
35726  IF(pmas(kcw,2).LT.parp(41)) goto 100
35727  IF(i.EQ.1) sqmi=sqm3
35728  IF(i.EQ.2) sqmi=sqm4
35729  sqms=pmas(kcw,1)**2
35730  gmms=pmas(kcw,1)*pmas(kcw,2)
35731  hbws=gmms/((sqmi-sqms)**2+gmms**2)
35732  CALL pywidt(kflw,sqmi,wdtp,wdte)
35733  gmmi=sqrt(sqmi)*wdtp(0)
35734  hbwi=gmmi/((sqmi-sqms)**2+gmmi**2)
35735  comfac=comfac*(hbwi/hbws)
35736  100 CONTINUE
35737  ENDIF
35738 
35739 C...Differential cross section expressions.
35740 
35741  IF(isub.LE.210) THEN
35742  IF(isub.EQ.201) THEN
35743 C...f + fbar -> e_L + e_Lbar
35744  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35745  DO 130 i=mmin1,mmax1
35746  ia=iabs(i)
35747  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 130
35748  ei=kchg(ia,1)/3d0
35749  tt3i=sign(1d0,ei+1d-6)/2d0
35750  ej=-1d0
35751  tt3j=-1d0/2d0
35752  fcol=1d0
35753 C...Color factor for e+ e-
35754  IF(ia.GE.11) fcol=3d0
35755  IF(isubsv.EQ.301) THEN
35756  a1=1d0
35757  a2=0d0
35758  ELSEIF(ilr.EQ.1) THEN
35759  a1=sfmix(kfid,3)**2
35760  a2=sfmix(kfid,4)**2
35761  ELSEIF(ilr.EQ.0) THEN
35762  a1=sfmix(kfid,1)**2
35763  a2=sfmix(kfid,2)**2
35764  ENDIF
35765  xlq=(tt3j-ej*xw)*a1
35766  xrq=(-ej*xw)*a2
35767  xlf=(tt3i-ei*xw)
35768  xrf=(-ei*xw)
35769  taa=(ei*ej)**2*(poll+polr)
35770  tzz=(xlf**2*poll+xrf**2*polr)*(xlq+xrq)**2/xw**2/xw1**2
35771  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*zwid/sh**2)
35772  taz=2d0*ei*ej*(xlq+xrq)*(xlf*poll+xrf*polr)/xw/xw1
35773  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
35774  tnn=0.0d0
35775  tan=0.0d0
35776  tzn=0.0d0
35777  IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
35778  fac2=sqrt(2d0)
35779  tnn1=0d0
35780  tnn2=0d0
35781  tnn3=0d0
35782  DO 120 ii=1,4
35783  dk=1d0/(th-smz(ii)**2)
35784  flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
35785  & zmix(ii,1))
35786  frek=fac2*tanw*ei*zmix(ii,1)
35787  tnn1=tnn1+flek**2*dk
35788  tnn2=tnn2+frek**2*dk
35789  DO 110 jj=1,4
35790  dl=1d0/(th-smz(jj)**2)
35791  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
35792  & zmix(jj,1))
35793  frel=fac2*tanw*ej*zmix(jj,1)
35794  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
35795  110 CONTINUE
35796  120 CONTINUE
35797  tnn=(uh*th-sqm3*sqm4)*(a1**2*tnn1**2*poll+
35798  & a2**2*tnn2**2*polr)
35799  tnn=(tnn+sh*a1*a2*tnn3*((1d0-parj(131))*(1d0-parj(132))+
35800  & (1d0+parj(131))*(1d0+parj(132))))/4d0/xw**2
35801  tzn=(uh*th-sqm3*sqm4)*(xlq+xrq)*
35802  & (tnn1*xlf*a1*poll+tnn2*xrf*a2*polr)
35803  tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
35804  & (1d0-sqmz/sh)/sh
35805  tzn=tzn/xw**2/xw1
35806  tan=ei*ej*(uh*th-sqm3*sqm4)/sh*(a1*tnn1*poll+
35807  & a2*tnn2*polr)/xw
35808  ENDIF
35809  facqq1=comfac*aem**2*(taa+tzz+taz)*fcol/3d0
35810  facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh**2
35811  facqq2=comfac*aem**2*(tnn+tzn+tan)*fcol/3d0
35812  nchn=nchn+1
35813  isig(nchn,1)=i
35814  isig(nchn,2)=-i
35815  isig(nchn,3)=1
35816  sigh(nchn)=facqq1+facqq2
35817  130 CONTINUE
35818 
35819  ELSEIF(isub.EQ.203) THEN
35820 C...f + fbar -> e_L + e_Rbar
35821  DO 160 i=mmin1,mmax1
35822  ia=iabs(i)
35823  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 160
35824  ei=kchg(iabs(i),1)/3d0
35825  tt3i=sign(1d0,ei)/2d0
35826  ej=-1
35827  tt3j=-1d0/2d0
35828  fcol=1d0
35829 C...Color factor for e+ e-
35830  IF(ia.GE.11) fcol=3d0
35831  a1=sfmix(kfid,1)**2
35832  a2=sfmix(kfid,2)**2
35833  xlq=(tt3j-ej*xw)
35834  xrq=(-ej*xw)
35835  xlf=(tt3i-ei*xw)
35836  xrf=(-ei*xw)
35837  tzz=(xlf**2*poll+xrf**2*polr)*(xlq-xrq)**2
35838  & /xw**2/xw1**2*a1*a2
35839  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35840  tnn=0.0d0
35841  tzn=0.0d0
35842  tnna=0d0
35843  tnnb=0d0
35844  IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
35845  fac2=sqrt(2d0)
35846  tnn1=0d0
35847  tnn2=0d0
35848  tnn3=0d0
35849  DO 150 ii=1,4
35850  dk=1d0/(th-smz(ii)**2)
35851  flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
35852  & zmix(ii,1))
35853  frek=fac2*tanw*ei*zmix(ii,1)
35854  tnn1=tnn1+flek**2*dk
35855  tnn2=tnn2+frek**2*dk
35856  DO 140 jj=1,4
35857  dl=1d0/(th-smz(jj)**2)
35858  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
35859  & zmix(jj,1))
35860  frel=fac2*tanw*ej*zmix(jj,1)
35861  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
35862  140 CONTINUE
35863  150 CONTINUE
35864  tnn=(uh*th-sqm3*sqm4)*a1*a2*(tnn2**2*polr+tnn1**2*poll)
35865  tnna=(tnn+sh*(a1**2*polll+a2**2*polrr)*tnn3)/4d0
35866  tnnb=(tnn+sh*(a1**2*polrr+a2**2*polll)*tnn3)/4d0
35867  tzn=(uh*th-sqm3*sqm4)*a1*a2
35868  tzn=tzn*(xlq-xrq)*(xlf*tnn1*poll-xrf*tnn2*polr)/xw1
35869  tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
35870  & (1d0-sqmz/sh)/sh
35871  ENDIF
35872  facqq0=comfac*aem**2*tzz*fcol/3d0*(uh*th-sqm3*sqm4)/sh2
35873  facqq2=comfac*aem**2/xw**2*(tnna+tzn)*fcol/3d0
35874  facqq1=comfac*aem**2/xw**2*(tnnb+tzn)*fcol/3d0
35875 C%%%%%%%%%%%
35876  nchn=nchn+1
35877  isig(nchn,1)=i
35878  isig(nchn,2)=-i
35879  isig(nchn,3)=1
35880  sigh(nchn)=(facqq0+facqq1)*wids(pycomp(kfpr(isubsv,1)),2)*
35881  & wids(pycomp(kfpr(isubsv,2)),3)
35882  nchn=nchn+1
35883  isig(nchn,1)=i
35884  isig(nchn,2)=-i
35885  isig(nchn,3)=2
35886  sigh(nchn)=(facqq0+facqq2)*wids(pycomp(kfpr(isubsv,1)),3)*
35887  & wids(pycomp(kfpr(isubsv,2)),2)
35888  160 CONTINUE
35889 
35890  ELSEIF(isub.EQ.210) THEN
35891 C...q + qbar' -> W*- > ~l_L + ~nu_L
35892  fac0=rkf*comfac*aem**2/xw**2/12d0
35893  fac1=(th*uh-sqm3*sqm4)/((sh-sqmw)**2+wwid**2*sqmw)
35894  DO 180 i=mmin1,mmax1
35895  ia=iabs(i)
35896  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 180
35897  DO 170 j=mmin2,mmax2
35898  ja=iabs(j)
35899  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 170
35900  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 170
35901  fckm=3d0
35902  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
35903  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
35904  kchw=2
35905  IF(kchsum.LT.0) kchw=3
35906  nchn=nchn+1
35907  isig(nchn,1)=i
35908  isig(nchn,2)=j
35909  isig(nchn,3)=1
35910  IF(isubsv.EQ.297.OR.isubsv.EQ.298) THEN
35911  facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
35912  & wids(pycomp(kfpr(isubsv,2)),2)
35913  ELSE
35914  facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
35915  & wids(pycomp(kfpr(isubsv,2)),kchw)
35916  ENDIF
35917  sigh(nchn)=fac0*fac1*fckm*facr
35918  170 CONTINUE
35919  180 CONTINUE
35920  ENDIF
35921 
35922  ELSEIF(isub.LE.220) THEN
35923  IF(isub.EQ.213) THEN
35924 C...f + fbar -> ~nu_L + ~nu_Lbar
35925  IF(isubsv.EQ.299.OR.isubsv.EQ.300) THEN
35926  facr=wids(pycomp(kfpr(isubsv,1)),2)*
35927  & wids(pycomp(kfpr(isubsv,2)),2)
35928  ELSE
35929  facr=wids(pycomp(kfpr(isubsv,1)),1)
35930  ENDIF
35931  comfac=comfac*facr
35932  propz2=(sh-sqmz)**2+zwid**2*sqmz
35933  xll=0.5d0
35934  xlr=0.0d0
35935  DO 190 i=mmin1,mmax1
35936  ia=iabs(i)
35937  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 190
35938  ei=kchg(ia,1)/3d0
35939  fcol=1d0
35940 C...Color factor for e+ e-
35941  IF(ia.GE.11) fcol=3d0
35942  xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
35943  xrq=-ei*xw
35944  tzc=0.0d0
35945  tcc=0.0d0
35946  IF(ia.GE.11.AND.kfid.EQ.ia+1) THEN
35947  tzc=vmix(1,1)**2/(th-smw(1)**2)+vmix(2,1)**2/
35948  & (th-smw(2)**2)
35949  tcc=tzc**2
35950  tzc=tzc/xw1*(sh-sqmz)/propz2*xlq*xll
35951  ENDIF
35952  facqq1=(xlq**2+xrq**2)*(xll+xlr)**2/xw1**2/propz2
35953  facqq2=tzc+tcc/4d0
35954  nchn=nchn+1
35955  isig(nchn,1)=i
35956  isig(nchn,2)=-i
35957  isig(nchn,3)=1
35958  sigh(nchn)=(facqq1+facqq2)*rkf*(uh*th-sqm3*sqm4)*comfac
35959  & *aem**2*fcol/3d0/xw**2
35960  190 CONTINUE
35961 
35962  ELSEIF(isub.EQ.216) THEN
35963 C...q + qbar -> ~chi0_1 + ~chi0_1
35964  IF(izid1.EQ.izid2) THEN
35965  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35966  ELSE
35967  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
35968  & wids(pycomp(kfpr(isubsv,2)),2)
35969  ENDIF
35970  facxx=comfac*aem**2/3d0/xw**2
35971  IF(izid1.EQ.izid2) facxx=facxx/2d0
35972  zm12=sqm3
35973  zm22=sqm4
35974  wu2 = (uh-zm12)*(uh-zm22)
35975  wt2 = (th-zm12)*(th-zm22)
35976  ws2 = smz(izid1)*smz(izid2)*sh
35977  propz2 = (sh-sqmz)**2 + sqmz*zwid**2
35978  propz=dcmplx(sh-sqmz,-zwid*pmas(23,1))/dcmplx(propz2)
35979  DO 200 i=1,4
35980  zmixc(izid1,i)=dcmplx(zmix(izid1,i),zmixi(izid1,i))
35981  IF(izid2.NE.izid1) THEN
35982  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
35983  ENDIF
35984  200 CONTINUE
35985  olpp=(zmixc(izid1,3)*dconjg(zmixc(izid2,3))-
35986  & zmixc(izid1,4)*dconjg(zmixc(izid2,4)))/2d0
35987  orpp=dconjg(olpp)
35988  DO 210 i=mmina,mmaxa
35989  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 210
35990  ei=kchg(iabs(i),1)/3d0
35991  t3i=sign(1d0,ei+1d-6)/2d0
35992  xml2=pmas(pycomp(ksusy1+iabs(i)),1)**2
35993  xmr2=pmas(pycomp(ksusy2+iabs(i)),1)**2
35994  glij=(t3i*zmixc(izid1,2)-tanw*(t3i-ei)*zmixc(izid1,1))*
35995  & dconjg(t3i*zmixc(izid2,2)-tanw*(t3i-ei)*zmixc(izid2,1))
35996  grij=zmixc(izid1,1)*dconjg(zmixc(izid2,1))*(ei*tanw)**2
35997  qll=dcmplx((t3i-ei*xw)/xw1)*olpp*propz-glij/dcmplx(uh-xml2)
35998  qlr=-dcmplx((t3i-ei*xw)/xw1)*orpp*propz+dconjg(glij)
35999  & /dcmplx(th-xml2)
36000  qrl=-dcmplx((ei*xw)/xw1)*olpp*propz+grij/dcmplx(th-xmr2)
36001  qrr=dcmplx((ei*xw)/xw1)*orpp*propz
36002  & -dconjg(grij)/dcmplx(uh-xmr2)
36003  fcol=1d0
36004  IF(iabs(i).GE.11) fcol=3d0
36005  facgg1=(abs(qll)**2*poll+abs(qrr)**2*polr)*wu2+
36006  & (abs(qrl)**2*polr+abs(qlr)**2*poll)*wt2+
36007  & 2d0*dble(qlr*dconjg(qll)*poll+
36008  & qrl*dconjg(qrr)*polr)*ws2
36009  nchn=nchn+1
36010  isig(nchn,1)=i
36011  isig(nchn,2)=-i
36012  isig(nchn,3)=1
36013  sigh(nchn)=facxx*facgg1*fcol
36014  210 CONTINUE
36015  ENDIF
36016 
36017  ELSEIF(isub.LE.230) THEN
36018  IF(isub.EQ.226) THEN
36019 C...f + fbar -> ~chi+_1 + ~chi-_1
36020  facxx=comfac*aem**2/3d0
36021  zm12=sqm3
36022  zm22=sqm4
36023  wu2 = (uh-zm12)*(uh-zm22)
36024  wt2 = (th-zm12)*(th-zm22)
36025  ws2 = smw(izid1)*smw(izid2)*sh
36026  propz2 = (sh-sqmz)**2 + sqmz*zwid**2
36027  propz=dcmplx(sh-sqmz,-zwid*pmas(23,1))/dcmplx(propz2)
36028  diff=0d0
36029  IF(izid1.EQ.izid2) diff=1d0
36030  DO 220 i=1,2
36031  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
36032  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
36033  IF(izid2.NE.izid1) THEN
36034  vmixc(izid2,i)=dcmplx(vmix(izid2,i),vmixi(izid2,i))
36035  umixc(izid2,i)=dcmplx(umix(izid2,i),umixi(izid2,i))
36036  ENDIF
36037  220 CONTINUE
36038  olp=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))-
36039  & vmixc(izid2,2)*dconjg(vmixc(izid1,2))/2d0+dcmplx(xw*diff)
36040  orp=-umixc(izid1,1)*dconjg(umixc(izid2,1))-
36041  & umixc(izid1,2)*dconjg(umixc(izid2,2))/2d0+dcmplx(xw*diff)
36042  DO 230 i=mmina,mmaxa
36043  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 230
36044  ei=kchg(iabs(i),1)/3d0
36045  t3i=sign(1d0,ei+1d-6)/2d0
36046  qrl=dcmplx(-ei/sh*diff)-dcmplx(ei/xw1)*propz*orp
36047  qll=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*propz*orp
36048  qrr=dcmplx(-ei/sh*diff)-dcmplx(ei/xw1)*propz*olp
36049  IF(mod(i,2).EQ.0) THEN
36050  xml2=pmas(pycomp(ksusy1+iabs(i)-1),1)**2
36051  qlr=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*
36052  & propz*olp-umixc(izid2,1)*dconjg(umixc(izid1,1))*
36053  & dcmplx(t3i/xw/(th-xml2))
36054  ELSE
36055  xml2=pmas(pycomp(ksusy1+iabs(i)+1),1)**2
36056  qlr=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*
36057  & propz*olp-vmixc(izid2,1)*dconjg(vmixc(izid1,1))*
36058  & dcmplx(t3i/xw/(th-xml2))
36059  ENDIF
36060  fcol=1d0
36061  IF(iabs(i).GE.11) fcol=3d0
36062  facsum=((abs(qll)**2*poll+abs(qrr)**2*polr)*wu2+
36063  & (abs(qrl)**2*polr+abs(qlr)**2*poll)*wt2+
36064  & 2d0*dble(qlr*dconjg(qll)*poll+
36065  & qrl*dconjg(qrr)*polr)*ws2)*facxx*fcol
36066  nchn=nchn+1
36067  isig(nchn,1)=i
36068  isig(nchn,2)=-i
36069  isig(nchn,3)=1
36070  IF(izid1.EQ.izid2) THEN
36071  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),1)
36072  ELSE
36073  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),3)*
36074  & wids(pycomp(kfpr(isubsv,2)),2)
36075  nchn=nchn+1
36076  isig(nchn,1)=i
36077  isig(nchn,2)=-i
36078  isig(nchn,3)=2
36079  sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),2)*
36080  & wids(pycomp(kfpr(isubsv,2)),3)
36081  ENDIF
36082  230 CONTINUE
36083 
36084  ELSEIF(isub.EQ.229) THEN
36085 C...q + qbar' -> ~chi0_1 + ~chi+-_1
36086  facxx=comfac*aem**2/6d0/xw**2
36087  zm12=sqm3
36088  zm22=sqm4
36089  wu2 = (uh-zm12)*(uh-zm22)
36090  wt2 = (th-zm12)*(th-zm22)
36091  ws2 = smw(izid1)*smz(izid2)*sh
36092  rt2i = 1d0/sqrt(2d0)
36093  propw = dcmplx(sh-sqmw,-wwid*pmas(24,1))/
36094  & dcmplx((sh-sqmw)**2+wwid**2*sqmw,0d0)
36095  DO 240 i=1,2
36096  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
36097  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
36098  240 CONTINUE
36099  DO 250 i=1,4
36100  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
36101  250 CONTINUE
36102  ol=(dconjg(zmixc(izid2,2))*vmixc(izid1,1)-
36103  & dconjg(zmixc(izid2,4))*vmixc(izid1,2)*rt2i)*propw
36104  or=(zmixc(izid2,2)*dconjg(umixc(izid1,1))+
36105  & zmixc(izid2,3)*dconjg(umixc(izid1,2))*rt2i)*propw
36106 
36107  DO 270 i=mmin1,mmax1
36108  ia=iabs(i)
36109  IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 270
36110  ei=kchg(ia,1)/3d0
36111  t3i=sign(1d0,ei+1d-6)/2d0
36112  DO 260 j=mmin2,mmax2
36113  ja=iabs(j)
36114  IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 260
36115  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 260
36116  ej=kchg(ja,1)/3d0
36117  t3j=sign(1d0,ej+1d-6)/2d0
36118  fckm=3d0
36119  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
36120  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
36121  kchw=2
36122  IF(kchsum.LT.0) kchw=3
36123  IF(mod(ia,2).EQ.0) THEN
36124  zmi2 = pmas(pycomp(ksusy1+ia),1)**2
36125  zmj2 = pmas(pycomp(ksusy1+ja),1)**2
36126  qll=ol+vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ei-t3i)*
36127  & tanw+zmixc(izid2,2)*t3i)/dcmplx(uh-zmi2)
36128  qlr=or-dconjg(umixc(izid1,1))*(
36129  & zmixc(izid2,1)*(ej-t3j)*tanw+zmixc(izid2,2)*t3j)
36130  & /dcmplx(th-zmj2)
36131  ELSE
36132  zmi2 = pmas(pycomp(ksusy1+ja),1)**2
36133  zmj2 = pmas(pycomp(ksusy1+ia),1)**2
36134  qll=ol+vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ej-t3j)*
36135  & tanw+zmixc(izid2,2)*t3j)/dcmplx(uh-zmj2)
36136  qlr=or-dconjg(umixc(izid1,1))*(
36137  & zmixc(izid2,1)*(ei-t3i)*tanw+zmixc(izid2,2)*t3i)
36138  & /dcmplx(th-zmi2)
36139  ENDIF
36140  zintr=dble(qlr*dconjg(qll))
36141  facgg1=facxx*(abs(qll)**2*wu2+abs(qlr)**2*wt2+
36142  & 2d0*zintr*ws2)
36143  nchn=nchn+1
36144  isig(nchn,1)=i
36145  isig(nchn,2)=j
36146  isig(nchn,3)=1
36147  sigh(nchn)=facgg1*fckm*wids(pycomp(kfpr(isubsv,1)),2)*
36148  & wids(pycomp(kfpr(isubsv,2)),kchw)
36149  260 CONTINUE
36150  270 CONTINUE
36151  ENDIF
36152 
36153  ELSEIF(isub.LE.240) THEN
36154  IF(isub.EQ.237) THEN
36155 C...q + qbar -> gluino + ~chi0_1
36156  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
36157  & wids(pycomp(kfpr(isubsv,2)),2)
36158  asyuk=rmss(42)*as
36159  fac0=comfac*asyuk*aem*4d0/9d0/xw
36160  gm2=sqm3
36161  zm2=sqm4
36162  DO 280 i=mmina,mmaxa
36163  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
36164  & kfac(1,i)*kfac(2,-i).EQ.0) goto 280
36165  ei=kchg(iabs(i),1)/3d0
36166  ia=iabs(i)
36167  xlqc = -tanw*ei*zmix(izid,1)
36168  xrqc =(sign(1d0,ei)*zmix(izid,2)-tanw*
36169  & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
36170  xlq2=xlqc**2
36171  xrq2=xrqc**2
36172  xml2=pmas(pycomp(ksusy1+ia),1)**2
36173  xmr2=pmas(pycomp(ksusy2+ia),1)**2
36174  atkin=(th-gm2)*(th-zm2)/(th-xml2)**2
36175  aukin=(uh-gm2)*(uh-zm2)/(uh-xml2)**2
36176  atukin=smz(izid)*sqrt(gm2)*sh/(th-xml2)/(uh-xml2)
36177  sgchil=xlq2*(atkin+aukin-2d0*atukin)
36178  atkin=(th-gm2)*(th-zm2)/(th-xmr2)**2
36179  aukin=(uh-gm2)*(uh-zm2)/(uh-xmr2)**2
36180  atukin=smz(izid)*sqrt(gm2)*sh/(th-xmr2)/(uh-xmr2)
36181  sgchir=xrq2*(atkin+aukin-2d0*atukin)
36182  nchn=nchn+1
36183  isig(nchn,1)=i
36184  isig(nchn,2)=-i
36185  isig(nchn,3)=1
36186  sigh(nchn)=fac0*(sgchil+sgchir)
36187  280 CONTINUE
36188  ENDIF
36189 
36190  ELSEIF(isub.LE.250) THEN
36191  IF(isub.EQ.241) THEN
36192 C...q + qbar' -> ~chi+-_1 + gluino
36193  facwg=comfac*as*aem/xw*2d0/9d0
36194  gm2=sqm3
36195  zm2=sqm4
36196  fac01=2d0*umix(izid,1)*vmix(izid,1)
36197  fac0=umix(izid,1)**2
36198  fac1=vmix(izid,1)**2
36199  DO 300 i=mmin1,mmax1
36200  ia=iabs(i)
36201  IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 300
36202  DO 290 j=mmin2,mmax2
36203  ja=iabs(j)
36204  IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 290
36205  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 290
36206  fckm=1d0
36207  IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
36208  kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
36209  kchw=2
36210  IF(kchsum.LT.0) kchw=3
36211  xmu2=pmas(pycomp(ksusy1+2),1)**2
36212  xmd2=pmas(pycomp(ksusy1+1),1)**2
36213  atkin=(th-gm2)*(th-zm2)/(th-xmu2)**2
36214  aukin=(uh-gm2)*(uh-zm2)/(uh-xmd2)**2
36215  atukin=smw(izid)*sqrt(gm2)*sh/(th-xmu2)/(uh-xmd2)
36216  xmu2=pmas(pycomp(ksusy2+2),1)**2
36217  xmd2=pmas(pycomp(ksusy2+1),1)**2
36218  atkin=(atkin+(th-gm2)*(th-zm2)/(th-xmu2)**2)/2d0
36219  aukin=(aukin+(uh-gm2)*(uh-zm2)/(uh-xmd2)**2)/2d0
36220  atukin=(atukin+smw(izid)*sqrt(gm2)*
36221  & sh/(th-xmu2)/(uh-xmd2))/2d0
36222  nchn=nchn+1
36223  isig(nchn,1)=i
36224  isig(nchn,2)=j
36225  isig(nchn,3)=1
36226  sigh(nchn)=facwg*fckm*(fac0*atkin+fac1*aukin-
36227  & fac01*atukin)*wids(pycomp(kfpr(isubsv,1)),2)*
36228  & wids(pycomp(kfpr(isubsv,2)),kchw)
36229  290 CONTINUE
36230  300 CONTINUE
36231 
36232  ELSEIF(isub.EQ.243) THEN
36233 C...q + qbar -> gluino + gluino
36234  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
36235  xmt=sqm3-th
36236  xmu=sqm3-uh
36237  DO 310 i=mmina,mmaxa
36238  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
36239  & kfac(1,i)*kfac(2,-i).EQ.0) goto 310
36240  nchn=nchn+1
36241  xsu=pmas(pycomp(ksusy1+iabs(i)),1)**2-uh
36242  xst=pmas(pycomp(ksusy1+iabs(i)),1)**2-th
36243  facgg1=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
36244  & 2d0*sqm3*sh)/sh2 + rmss(42)**2*(4d0/9d0*(xmt**2/xst**2+
36245  & xmu**2/xsu**2) + sqm3*sh/xst/xsu/9d0) - rmss(42)*(
36246  & (xmt**2+sh*sqm3)/sh/xst + (xmu**2+sh*sqm3)/sh/xsu ))
36247  xsu=pmas(pycomp(ksusy2+iabs(i)),1)**2-uh
36248  xst=pmas(pycomp(ksusy2+iabs(i)),1)**2-th
36249  facgg2=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
36250  & 2d0*sqm3*sh)/sh2 + rmss(42)**2*(4d0/9d0*(xmt**2/xst**2+
36251  & xmu**2/xsu**2) + sqm3*sh/xst/xsu/9d0) - rmss(42)*(
36252  & (xmt**2+sh*sqm3)/sh/xst + (xmu**2+sh*sqm3)/sh/xsu ))
36253  isig(nchn,1)=i
36254  isig(nchn,2)=-i
36255  isig(nchn,3)=1
36256 C...1/2 for identical particles
36257  sigh(nchn)=0.25d0*(facgg1+facgg2)
36258  310 CONTINUE
36259 
36260  ELSEIF(isub.EQ.244) THEN
36261 C...g + g -> gluino + gluino
36262  comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
36263  xmt=sqm3-th
36264  xmu=sqm3-uh
36265  facqq1=comfac*as**2*9d0/4d0*(
36266  & (xmt*xmu-2d0*sqm3*(th+sqm3))/xmt**2 -
36267  & (xmt*xmu+sqm3*(uh-th))/sh/xmt )
36268  facqq2=comfac*as**2*9d0/4d0*(
36269  & (xmu*xmt-2d0*sqm3*(uh+sqm3))/xmu**2 -
36270  & (xmu*xmt+sqm3*(th-uh))/sh/xmu )
36271  facqq3=comfac*as**2*9d0/4d0*(2d0*xmt*xmu/sh2 +
36272  & sqm3*(sh-4d0*sqm3)/xmt/xmu)
36273  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 320
36274  nchn=nchn+1
36275  isig(nchn,1)=21
36276  isig(nchn,2)=21
36277  isig(nchn,3)=1
36278  sigh(nchn)=facqq1/2d0
36279  nchn=nchn+1
36280  isig(nchn,1)=21
36281  isig(nchn,2)=21
36282  isig(nchn,3)=2
36283  sigh(nchn)=facqq2/2d0
36284  nchn=nchn+1
36285  isig(nchn,1)=21
36286  isig(nchn,2)=21
36287  isig(nchn,3)=3
36288  sigh(nchn)=facqq3/2d0
36289  320 CONTINUE
36290 
36291  ELSEIF(isub.EQ.246) THEN
36292 C...g + q_j -> ~chi0_1 + ~q_j
36293  fac0=comfac*as*aem/6d0/xw
36294  zm2=sqm4
36295  qm2=sqm3
36296  faczq0=fac0*( (zm2-th)/sh +
36297  & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
36298  & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
36299  kfnsq=mod(kfpr(isubsv,1),ksusy1)
36300  DO 340 i=-kfnsq,kfnsq,2*kfnsq
36301  IF(i.LT.mmina.OR.i.GT.mmaxa) goto 340
36302  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 340
36303  ei=kchg(iabs(i),1)/3d0
36304  ia=iabs(i)
36305  xrqz = -tanw*ei*zmix(izid,1)
36306  xlqz =(sign(1d0,ei)*zmix(izid,2)-tanw*
36307  & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
36308  IF(ilr.EQ.0) THEN
36309  bs=xlqz**2*sfmix(ia,1)**2+xrqz**2*sfmix(ia,2)**2
36310  ELSE
36311  bs=xlqz**2*sfmix(ia,3)**2+xrqz**2*sfmix(ia,4)**2
36312  ENDIF
36313  faczq=faczq0*bs
36314  kchq=2
36315  IF(i.LT.0) kchq=3
36316  DO 330 isde=1,2
36317  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 330
36318  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 330
36319  nchn=nchn+1
36320  isig(nchn,isde)=i
36321  isig(nchn,3-isde)=21
36322  isig(nchn,3)=1
36323  sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
36324  & wids(pycomp(kfpr(isubsv,2)),2)
36325  330 CONTINUE
36326  340 CONTINUE
36327  ENDIF
36328 
36329  ELSEIF(isub.LE.260) THEN
36330  IF(isub.EQ.254) THEN
36331 C...g + q_j -> ~chi1_1 + ~q_i
36332  fac0=comfac*as*aem/12d0/xw
36333  zm2=sqm4
36334  qm2=sqm3
36335  au=umix(izid,1)**2
36336  ad=vmix(izid,1)**2
36337  faczq0=fac0*( (zm2-th)/sh +
36338  & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
36339  & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
36340  kfnsq1=mod(kfpr(isubsv,1),ksusy1)
36341  IF(mod(kfnsq1,2).EQ.0) THEN
36342  kfnsq=kfnsq1-1
36343  kchw=2
36344  ELSE
36345  kfnsq=kfnsq1+1
36346  kchw=3
36347  ENDIF
36348  DO 360 i=-kfnsq,kfnsq,2*kfnsq
36349  IF(i.LT.mmina.OR.i.GT.mmaxa) goto 360
36350  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 360
36351  ia=iabs(i)
36352  IF(mod(ia,2).EQ.0) THEN
36353  faczq=faczq0*au
36354  ELSE
36355  faczq=faczq0*ad
36356  ENDIF
36357  faczq=faczq*sfmix(kfnsq1,1+2*ilr)**2
36358  kchq=2
36359  IF(i.LT.0) kchq=3
36360  kchwq=kchw
36361  IF(i.LT.0) kchwq=5-kchw
36362  DO 350 isde=1,2
36363  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 350
36364  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 350
36365  nchn=nchn+1
36366  isig(nchn,isde)=i
36367  isig(nchn,3-isde)=21
36368  isig(nchn,3)=1
36369  sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
36370  & wids(pycomp(kfpr(isubsv,2)),kchwq)
36371  350 CONTINUE
36372  360 CONTINUE
36373 
36374  ELSEIF(isub.EQ.258) THEN
36375 C...g + q_j -> gluino + ~q_i
36376  xg2=sqm4
36377  xq2=sqm3
36378  xmt=xg2-th
36379  xmu=xg2-uh
36380  xst=xq2-th
36381  xsu=xq2-uh
36382  facqg1=0.5d0*4d0/9d0*xmt/sh + (xmt*sh+2d0*xg2*xst)/xmt**2 -
36383  & ( (sh-xq2+xg2)*(-xst)-sh*xg2 )/sh/(-xmt) +
36384  & 0.5d0*1d0/2d0*( xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst) +
36385  & (-xmu)*(th+xg2+2d0*xq2) )/2d0/xmt/xsu
36386  facqg2= 4d0/9d0*(-xmu)*(uh+xq2)/xsu**2 + 1d0/18d0*
36387  & (sh*(uh+xg2)
36388  & +2d0*(xq2-xg2)*xmu)/sh/(-xsu) + 0.5d0*4d0/9d0*xmt/sh +
36389  & 0.5d0*1d0/2d0*(xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst)+
36390  & (-xmu)*(th+xg2+2d0*xq2))/2d0/xmt/xsu
36391  asyuk=rmss(42)*as
36392  facqg1=comfac*as*asyuk*facqg1/2d0
36393  facqg2=comfac*as*asyuk*facqg2/2d0
36394  kfnsq=mod(kfpr(isubsv,1),ksusy1)
36395  DO 380 i=-kfnsq,kfnsq,2*kfnsq
36396  IF(i.LT.mmina.OR.i.GT.mmaxa) goto 380
36397  IF(i.EQ.0.OR.iabs(i).GT.10) goto 380
36398  kchq=2
36399  IF(i.LT.0) kchq=3
36400  facsel=rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
36401  & wids(pycomp(kfpr(isubsv,2)),2)
36402  DO 370 isde=1,2
36403  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 370
36404  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 370
36405  nchn=nchn+1
36406  isig(nchn,isde)=i
36407  isig(nchn,3-isde)=21
36408  isig(nchn,3)=1
36409  sigh(nchn)=facqg1*facsel
36410  nchn=nchn+1
36411  isig(nchn,isde)=i
36412  isig(nchn,3-isde)=21
36413  isig(nchn,3)=2
36414  sigh(nchn)=facqg2*facsel
36415  370 CONTINUE
36416  380 CONTINUE
36417  ENDIF
36418 
36419  ELSEIF(isub.LE.270) THEN
36420  IF(isub.EQ.261) THEN
36421 C...q_i + q_ibar -> ~t_1 + ~t_1bar
36422  facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )*
36423  & wids(pycomp(kfpr(isubsv,1)),1)
36424  kfnsq=mod(kfpr(isubsv,1),ksusy1)
36425  fac0=as**2*4d0/9d0
36426  DO 390 i=mmin1,mmax1
36427  ia=iabs(i)
36428  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 390
36429  IF(ia.GE.11.AND.ia.LE.18) THEN
36430  ei=kchg(ia,1)/3d0
36431  ej=kchg(kfnsq,1)/3d0
36432  t3i=sign(1d0,ei)/2d0
36433  t3j=sign(1d0,ej)/2d0
36434  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,2*ilr+1)**2
36435  xrq=2d0*(-ej*xw)*sfmix(kfnsq,2*ilr+2)**2
36436  xlf=2d0*(t3i-ei*xw)
36437  xrf=2d0*(-ei*xw)
36438  taa=0.5d0*(ei*ej)**2
36439  tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
36440  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
36441  taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
36442  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
36443  fac0=aem**2*12d0*(taa+tzz+taz)
36444  ENDIF
36445  nchn=nchn+1
36446  isig(nchn,1)=i
36447  isig(nchn,2)=-i
36448  isig(nchn,3)=1
36449  sigh(nchn)=facqq1*fac0
36450  390 CONTINUE
36451 
36452  ELSEIF(isub.EQ.263) THEN
36453 C...f + fbar -> ~t1 + ~t2bar
36454  DO 400 i=mmin1,mmax1
36455  ia=iabs(i)
36456  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 400
36457  ei=kchg(iabs(i),1)/3d0
36458  tt3i=sign(1d0,ei)/2d0
36459  ej=2d0/3d0
36460  tt3j=1d0/2d0
36461  fcol=1d0
36462 C...Color factor for e+ e-
36463  IF(ia.GE.11) fcol=3d0
36464  xlq=2d0*(tt3j-ej*xw)
36465  xrq=2d0*(-ej*xw)
36466  xlf=2d0*(tt3i-ei*xw)
36467  xrf=2d0*(-ei*xw)
36468  tzz=(xlf**2+xrf**2)*(xlq-xrq)**2/64d0/xw**2/xw1**2
36469  tzz=tzz*(sfmix(6,1)*sfmix(6,2))**2
36470  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
36471 C...Factor of 2 for t1 t2bar + t2 t1bar
36472 C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels.
36473  facqq1=comfac*aem**2*tzz*fcol*4d0
36474  facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh2
36475  nchn=nchn+1
36476  isig(nchn,1)=i
36477  isig(nchn,2)=-i
36478  isig(nchn,3)=1
36479  sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),2)*
36480  & wids(pycomp(kfpr(isubsv,2)),3)
36481  nchn=nchn+1
36482  isig(nchn,1)=i
36483  isig(nchn,2)=-i
36484  isig(nchn,3)=2
36485  sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),3)*
36486  & wids(pycomp(kfpr(isubsv,2)),2)
36487  400 CONTINUE
36488 
36489  ELSEIF(isub.EQ.264) THEN
36490 C...g + g -> ~t_1 + ~t_1bar
36491  xsu=sqm3-uh
36492  xst=sqm3-th
36493  fac0=comfac*as**2*(7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )*0.5d0*
36494  & wids(pycomp(kfpr(isubsv,1)),1)
36495  facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
36496  facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
36497  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 410
36498  nchn=nchn+1
36499  isig(nchn,1)=21
36500  isig(nchn,2)=21
36501  isig(nchn,3)=1
36502  sigh(nchn)=facqq1
36503  nchn=nchn+1
36504  isig(nchn,1)=21
36505  isig(nchn,2)=21
36506  isig(nchn,3)=2
36507  sigh(nchn)=facqq2
36508  410 CONTINUE
36509  ENDIF
36510 
36511  ELSEIF(isub.LE.280) THEN
36512  IF(isub.EQ.271) THEN
36513 C...q + q' -> ~q + ~q' (~g exchange)
36514  xmg2=pmas(pycomp(ksusy1+21),1)**2
36515  xmt=xmg2-th
36516  xmu=xmg2-uh
36517  xsu1=sqm3-uh
36518  xsu2=sqm4-uh
36519  xst1=sqm3-th
36520  xst2=sqm4-th
36521  asyuk=rmss(42)*as
36522  IF(ilr.EQ.1) THEN
36523  facqq1=comfac*asyuk**2*4d0/9d0*( -(xst1*xst2+sh*th)/xmt**2 )
36524  facqq2=comfac*asyuk**2*4d0/9d0*( -(xsu1*xsu2+sh*uh)/xmu**2 )
36525  facqqb=0.0d0
36526  ELSE
36527  facqq1=0.5d0*comfac*asyuk**2*4d0/9d0*( sh*xmg2/xmt**2 )
36528  facqq2=0.5d0*comfac*asyuk**2*4d0/9d0*( sh*xmg2/xmu**2 )
36529  facqqb=0.5d0*comfac*asyuk**2*4d0/9d0*( -2d0*sh*xmg2/3d0/
36530  & xmt/xmu )
36531  ENDIF
36532  kfnsqi=mod(kfpr(isubsv,1),ksusy1)
36533  kfnsqj=mod(kfpr(isubsv,2),ksusy1)
36534  DO 430 i=-kfnsqi,kfnsqi,2*kfnsqi
36535  IF(i.LT.mmin1.OR.i.GT.mmax1) goto 430
36536  ia=iabs(i)
36537  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 430
36538  kchq=2
36539  IF(i.LT.0) kchq=3
36540  DO 420 j=-kfnsqj,kfnsqj,2*kfnsqj
36541  IF(j.LT.mmin2.OR.j.GT.mmax2) goto 420
36542  ja=iabs(j)
36543  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 420
36544  IF(i*j.LT.0) goto 420
36545  nchn=nchn+1
36546  isig(nchn,1)=i
36547  isig(nchn,2)=j
36548  isig(nchn,3)=1
36549  sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
36550  & wids(pycomp(kfpr(isubsv,2)),kchq)
36551  IF(i.EQ.j) THEN
36552  IF(ilr.EQ.0) THEN
36553  sigh(nchn)=0.5d0*(facqq1+0.5d0*facqqb)*rkf*
36554  & wids(pycomp(kfpr(isubsv,1)),kchq+2)
36555  ELSE
36556  sigh(nchn)=0.5d0*facqq1*rkf*
36557  & wids(pycomp(kfpr(isubsv,1)),kchq)*
36558  & wids(pycomp(kfpr(isubsv,2)),kchq)
36559  ENDIF
36560  nchn=nchn+1
36561  isig(nchn,1)=i
36562  isig(nchn,2)=j
36563  isig(nchn,3)=2
36564  IF(ilr.EQ.0) THEN
36565  sigh(nchn)=0.5d0*(facqq2+0.5d0*facqqb)*rkf*
36566  & wids(pycomp(kfpr(isubsv,1)),kchq+2)
36567  ELSE
36568  sigh(nchn)=0.5d0*facqq2*rkf*
36569  & wids(pycomp(kfpr(isubsv,1)),kchq)*
36570  & wids(pycomp(kfpr(isubsv,2)),kchq)
36571  ENDIF
36572  ENDIF
36573  420 CONTINUE
36574  430 CONTINUE
36575 
36576  ELSEIF(isub.EQ.274) THEN
36577 C...q + qbar' -> ~q + ~qbar'
36578  xmg2=pmas(pycomp(ksusy1+21),1)**2
36579  xmt=xmg2-th
36580  xmu=xmg2-uh
36581  IF(ilr.EQ.0) THEN
36582 C...Mrenna...Normalization.and.1/XMT
36583  facqq1=comfac*as**2*2d0/9d0*(
36584  & (uh*th-sqm3*sqm4)/xmt**2 )*rmss(42)**2
36585  facqqb=comfac*as**2*4d0/9d0*(
36586  & (uh*th-sqm3*sqm4)/sh2 )
36587 C...Mrenna..Switched sign to agree with Eichten, Dawson, etc.
36588  facqqi=comfac*as**2*4d0/27d0*(
36589  & (uh*th-sqm3*sqm4)/sh/xmt )*rmss(42)
36590  facqqb=facqqb+facqq1+facqqi
36591  ELSE
36592  facqq1=comfac*as**2*4d0/9d0*( xmg2*sh/xmt**2 )*rmss(42)**2
36593  facqqb=facqq1
36594  ENDIF
36595  kfnsqi=mod(kfpr(isubsv,1),ksusy1)
36596  kfnsqj=mod(kfpr(isubsv,2),ksusy1)
36597  DO 450 i=-kfnsqi,kfnsqi,2*kfnsqi
36598  IF(i.LT.mmin1.OR.i.GT.mmax1) goto 450
36599  ia=iabs(i)
36600  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 450
36601  kchq=2
36602  IF(i.LT.0) kchq=3
36603  DO 440 j=-kfnsqj,kfnsqj,2*kfnsqj
36604  IF(j.LT.mmin2.OR.j.GT.mmax2) goto 440
36605  ja=iabs(j)
36606  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 440
36607  IF(i*j.GT.0) goto 440
36608  nchn=nchn+1
36609  isig(nchn,1)=i
36610  isig(nchn,2)=j
36611  isig(nchn,3)=1
36612  sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
36613  & wids(pycomp(kfpr(isubsv,2)),5-kchq)
36614  IF(ilr.EQ.0.AND.i.EQ.-j) sigh(nchn)=facqqb*rkf*
36615  & wids(pycomp(kfpr(isubsv,1)),1)
36616  440 CONTINUE
36617  450 CONTINUE
36618 
36619  ELSEIF(isub.EQ.277) THEN
36620 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
36621 C...if i .eq. j covered in 274
36622  facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )
36623  kfnsq=mod(kfpr(isubsv,1),ksusy1)
36624  fac0=0d0
36625  DO 460 i=mmin1,mmax1
36626  ia=iabs(i)
36627  IF(i.EQ.0.OR.(ia.GT.mstp(58).AND.ia.LE.10).OR.
36628  & kfac(1,i)*kfac(2,-i).EQ.0) goto 460
36629  IF(ia.EQ.kfnsq) goto 460
36630  IF(ia.EQ.11.OR.ia.EQ.13.OR.ia.EQ.15) THEN
36631  ei=kchg(ia,1)/3d0
36632  ej=kchg(kfnsq,1)/3d0
36633  t3j=sign(0.5d0,ej)
36634  t3i=sign(1d0,ei)/2d0
36635  IF(ilr.EQ.0) THEN
36636  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,1)
36637  xrq=2d0*(-ej*xw)*sfmix(kfnsq,2)
36638  ELSE
36639  xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,3)
36640  xrq=2d0*(-ej*xw)*sfmix(kfnsq,4)
36641  ENDIF
36642  xlf=2d0*(t3i-ei*xw)
36643  xrf=2d0*(-ei*xw)
36644  IF(ilr.EQ.0) THEN
36645  xrq=0d0
36646  ELSE
36647  xlq=0d0
36648  ENDIF
36649  taa=0.5d0*(ei*ej)**2
36650  tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
36651  tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
36652  taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
36653  taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
36654  fac0=aem**2*12d0*(taa+tzz+taz)
36655  ELSEIF(ia.LE.6) THEN
36656  fac0=as**2*8d0/9d0/2d0
36657  ENDIF
36658  nchn=nchn+1
36659  isig(nchn,1)=i
36660  isig(nchn,2)=-i
36661  isig(nchn,3)=1
36662  sigh(nchn)=facqq1*fac0*rkf*wids(pycomp(kfpr(isubsv,1)),1)
36663  460 CONTINUE
36664 
36665  ELSEIF(isub.EQ.279) THEN
36666 C...g + g -> ~q_j + ~q_jbar
36667  xsu=sqm3-uh
36668  xst=sqm3-th
36669 C...4=RKF because ~t ~tbar and ~b ~bbar treated separately
36670  fac0=rkf*comfac*as**2*( 7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )
36671  facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
36672  facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
36673  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 470
36674  nchn=nchn+1
36675  isig(nchn,1)=21
36676  isig(nchn,2)=21
36677  isig(nchn,3)=1
36678  sigh(nchn)=facqq1/2d0*wids(pycomp(kfpr(isubsv,1)),1)
36679  nchn=nchn+1
36680  isig(nchn,1)=21
36681  isig(nchn,2)=21
36682  isig(nchn,3)=2
36683  sigh(nchn)=facqq2/2d0*wids(pycomp(kfpr(isubsv,1)),1)
36684  470 CONTINUE
36685 
36686  ENDIF
36687  ENDIF
36688 CMRENNA--
36689 
36690  RETURN
36691  END
36692 
36693 C*********************************************************************
36694 
36695 C...PYSGTC
36696 C...Subprocess cross sections for Technicolor processes.
36697 C...Auxiliary to PYSIGH.
36698 
36699  SUBROUTINE pysgtc(NCHN,SIGS)
36700 
36701 C...Double precision and integer declarations
36702  IMPLICIT DOUBLE PRECISION(a-h, o-z)
36703  IMPLICIT INTEGER(i-n)
36704  INTEGER pyk,pychge,pycomp
36705 C...Parameter statement to help give large particle numbers.
36706  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
36707  &kexcit=4000000,kdimen=5000000)
36708 C...Commonblocks
36709  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
36710  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
36711  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
36712  common/pypars/mstp(200),parp(200),msti(200),pari(200)
36713  common/pyint1/mint(400),vint(400)
36714  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
36715  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
36716  common/pyint4/mwid(500),wids(500,5)
36717  common/pytcsm/itcm(0:99),rtcm(0:99)
36718  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
36719  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
36720  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
36721  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
36722  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
36723  &/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
36724 C...Local arrays and complex variables
36725  dimension wdtp(0:400),wdte(0:400,0:5)
36726  COMPLEX*16 ssmz,ssmr,ssmo,detd,f2l,f2r,darho,dzrho,daome,dzome
36727  COMPLEX*16 ssmx,daast,dzast,dwast
36728  COMPLEX*16 daa,dzz,daz,dww,dwrho
36729  COMPLEX*16 ztc(6,6),ytc(6,6),dggs,dggt,dggu,dgvs,dgvt,dgvu
36730  COMPLEX*16 dqqs,dqqt,dqqu,dqts,dqgs,dtgs
36731  COMPLEX*16 dvvs,dvvt,dvvu
36732  INTEGER indx(6)
36733 
36734 C...Combinations of weak mixing angle.
36735  tanw=sqrt(xw/xw1)
36736  ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
36737 
36738 C...Convert almost equivalent technicolor processes into
36739 C...a few basic processes, and set distinguishing parameters.
36740  IF(isub.GE.361.AND.isub.LE.380) THEN
36741  sqtv=rtcm(12)**2
36742  sqta=rtcm(13)**2
36743  sn2w=2d0*sqrt(xw*xw1)
36744  cs2w=1d0-2d0*xw
36745  ct2w=cs2w/sn2w
36746  csxi=cos(asin(rtcm(3)))
36747  csxip=cos(asin(rtcm(4)))
36748  qupd=2d0*rtcm(2)-1d0
36749  q2ud=rtcm(2)**2+(rtcm(2)-1d0)**2
36750  cab2=0d0
36751  vogp=0d0
36752  vrgp=0d0
36753  aogp=0d0
36754  argp=0d0
36755  vxgp=0d0
36756  axgp=0d0
36757  vagp=0d0
36758  vzgp=0d0
36759  vwgp=0d0
36760 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36761  IF(isub.EQ.361) THEN
36762  kfa=24
36763  kfb=24
36764  cab2=rtcm(3)**4
36765  axgp=-rtcm(3)/(2d0*sqrt(xw))/rtcm(49)
36766  argp=rtcm(3)/(2d0*sqrt(xw))/rtcm(13)
36767  vogp=rtcm(3)/(2d0*sqrt(xw))/rtcm(12)
36768 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36769  axgp = sqrt(2d0)*axgp
36770  argp = sqrt(2d0)*argp
36771  vogp = sqrt(2d0)*vogp
36772 C... rho_tc0 -> W_L pi_tc-
36773  ELSEIF(isub.EQ.362) THEN
36774  kfa=24
36775  kfb=ktechn+211
36776  isub=361
36777  cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36778 C... pi_tc pi_tc
36779  ELSEIF(isub.EQ.363) THEN
36780  kfa=ktechn+211
36781  kfb=ktechn+211
36782  isub=361
36783  cab2=(1d0-rtcm(3)**2)**2
36784 C... rho_tc0/omega_tc -> gamma pi_tc
36785  ELSEIF(isub.EQ.364) THEN
36786  kfa=22
36787  kfb=ktechn+111
36788  isub=361
36789  vogp=csxi/rtcm(12)
36790  vrgp=vogp*qupd
36791  vagp=2d0*qupd*csxi
36792  vzgp=qupd*csxi*(1d0-4d0*xw)/sn2w
36793 C... gamma pi_tc'
36794  ELSEIF(isub.EQ.365) THEN
36795  kfa=22
36796  kfb=ktechn+221
36797  isub=361
36798  vrgp=csxip/rtcm(12)
36799  vogp=vrgp*qupd
36800  vagp=2d0*q2ud*csxip
36801  vzgp=csxip/sn2w*(1d0-4d0*xw*q2ud)
36802 C... Z pi_tc
36803  ELSEIF(isub.EQ.366) THEN
36804  kfa=23
36805  kfb=ktechn+111
36806  isub=361
36807  vogp=csxi*ct2w/rtcm(12)
36808  vrgp=-qupd*csxi*tanw/rtcm(12)
36809  vagp=qupd*csxi*(1d0-4d0*xw)/sn2w
36810  vzgp=-qupd*csxi*cs2w/xw1
36811 C... Z pi_tc'
36812  ELSEIF(isub.EQ.367) THEN
36813  kfa=23
36814  kfb=ktechn+221
36815  isub=361
36816 C...RTCM(48) is the M_V for the techni-a
36817  vxgp=-csxip/sn2w/rtcm(48)
36818  vrgp=csxip*ct2w/rtcm(12)
36819  vogp=-qupd*csxip*tanw/rtcm(12)
36820  vagp=csxip*(1d0-4d0*q2ud*xw)/sn2w
36821  vzgp=2d0*csxip*(cs2w+4d0*q2ud*xw**2)/sn2w**2
36822 C... W_T pi_tc
36823  ELSEIF(isub.EQ.368) THEN
36824  kfa=24
36825  kfb=ktechn+211
36826  isub=361
36827 C...RTCM(49) is the M_A for the techni-a
36828  axgp=-csxi/(2d0*sqrt(xw))/rtcm(49)
36829  vogp=csxi/(2d0*sqrt(xw))/rtcm(12)
36830  argp=csxi/(2d0*sqrt(xw))/rtcm(13)
36831  vagp=qupd*csxi/(2d0*sqrt(xw))
36832  vzgp=-qupd*csxi/(2d0*sqrt(xw1))
36833 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36834  ELSEIF(isub.EQ.370) THEN
36835  kfa=24
36836  kfb=23
36837  cab2=rtcm(3)**4
36838  argp=-rtcm(3)/(2d0*sqrt(xw))/rtcm(13)
36839  axgp=rtcm(3)/(2d0*sqrt(xw))/rtcm(49)
36840 C... W_L pi_tc0
36841  ELSEIF(isub.EQ.371) THEN
36842  kfa=24
36843  kfb=ktechn+111
36844  isub=370
36845  cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36846 C... Z_L pi_tc+
36847  ELSEIF(isub.EQ.372) THEN
36848  kfa=ktechn+211
36849  kfb=23
36850  isub=370
36851  cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36852 C... pi_tc+ pi_tc0
36853  ELSEIF(isub.EQ.373) THEN
36854  kfa=ktechn+211
36855  kfb=ktechn+111
36856  isub=370
36857  cab2=(1d0-rtcm(3)**2)**2
36858 C... gamma pi_tc+
36859  ELSEIF(isub.EQ.374) THEN
36860  kfa=ktechn+211
36861  kfb=22
36862  isub=370
36863  vrgp=qupd*csxi/rtcm(12)
36864  vwgp=qupd*csxi/(2d0*sqrt(xw))
36865  axgp=-csxi/rtcm(49)
36866 C... Z_T pi_tc+
36867  ELSEIF(isub.EQ.375) THEN
36868  kfa=ktechn+211
36869  kfb=23
36870  isub=370
36871  vrgp=-qupd*csxi*tanw/rtcm(12)
36872  argp=csxi/(2d0*sqrt(xw*xw1))/rtcm(13)
36873  vwgp=-qupd*csxi/(2d0*sqrt(xw1))
36874  axgp=-csxi*ct2w/rtcm(49)
36875 C... W_T pi_tc0
36876  ELSEIF(isub.EQ.376) THEN
36877  kfa=24
36878  kfb=ktechn+111
36879  isub=370
36880  vrgp=0d0
36881  argp=-csxi/(2d0*sqrt(xw))/rtcm(13)
36882  axgp=csxi/(2d0*sqrt(xw))/rtcm(49)
36883 C... W_T pi_tc0'
36884  ELSEIF(isub.EQ.377) THEN
36885  kfa=24
36886  kfb=ktechn+221
36887  isub=370
36888  vrgp=csxip/(2d0*sqrt(xw))/rtcm(12)
36889  vwgp=csxip/(2d0*xw)
36890  vxgp=-csxip/(2d0*sqrt(xw))/rtcm(48)
36891 C... gamma W+
36892  ELSEIF(isub.EQ.378) THEN
36893  kfa=24
36894  kfb=22
36895  isub=370
36896  vrgp=qupd*rtcm(3)/rtcm(12)
36897  axgp=-rtcm(3)/rtcm(49)
36898 C... gamma Z
36899  ELSEIF(isub.EQ.379) THEN
36900  kfa=23
36901  kfb=22
36902  isub=361
36903  vogp=rtcm(3)/rtcm(12)
36904  vrgp=qupd*rtcm(3)/rtcm(12)
36905  ELSEIF(isub.EQ.380) THEN
36906  kfa=23
36907  kfb=23
36908  isub=361
36909  vogp=rtcm(3)*ct2w/rtcm(12)
36910  vrgp=-qupd*rtcm(3)*tanw/rtcm(12)
36911  ENDIF
36912  ENDIF
36913 
36914 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36915  IF(isub.GE.381.AND.isub.LE.388) THEN
36916  IF(itcm(5).LE.4) THEN
36917  sqdqqs=1d0/sh2
36918  sqdqqt=1d0/th2
36919  sqdqqu=1d0/uh2
36920  sqdggs=sqdqqs
36921  sqdggt=sqdqqt
36922  sqdggu=sqdqqu
36923  redggs=1d0/sh
36924  redggt=1d0/th
36925  redggu=1d0/uh
36926  redgtu=1d0/uh/th
36927  redgsu=1d0/sh/uh
36928  redgst=1d0/sh/th
36929  redqst=1d0/sh/th
36930  redqtu=1d0/uh/th
36931  sqdlgs=0d0
36932  sqdlgt=0d0
36933  sqdqts=sqdqqs
36934  ELSEIF(itcm(5).EQ.5) THEN
36935  tant3=rtcm(21)
36936  IF(itcm(2).EQ.0) THEN
36937  imdl=1
36938  ELSE
36939  imdl=2
36940  ENDIF
36941  alprht=2.16d0*(3d0/itcm(1))
36942  sin2t=2d0*tant3/(tant3**2+1d0)
36943  sint3=tant3/sqrt(tant3**2+1d0)
36944  xig=sqrt(pyalps(sh)/alprht)
36945  x12=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*cos(rtcm(30))+
36946  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*cos(rtcm(32)))/sqrt(2d0)/sin2t
36947  x21=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*sin(rtcm(30))+
36948  & rtcm(31)*sqrt(1d0-rtcm(31)**2)*sin(rtcm(32)))/sqrt(2d0)/sin2t
36949  x11=(.25d0*(rtcm(29)**2+rtcm(31)**2+2d0)-
36950  & sint3**2)*2d0/sin2t
36951  x22=(.25d0*(2d0-rtcm(29)**2-rtcm(31)**2)-
36952  & sint3**2)*2d0/sin2t
36953 
36954  sm1122=.5d0*(2d0-rtcm(29)**2-rtcm(31)**2)*rtcm(28)**2
36955  sm1112=x12*rtcm(28)**2*sin2t
36956  sm1121=-x21*rtcm(28)**2*sin2t
36957  sm2212=-sm1112
36958  sm2221=-sm1121
36959  sm1221=-.5d0*((1d0-rtcm(29)**2)*sin(2d0*rtcm(30))+
36960  & (1d0-rtcm(31)**2)*sin(2d0*rtcm(32)))*rtcm(28)**2
36961 
36962 C.........SH LOOP
36963  ztc(1,1)=dcmplx(sh,0d0)
36964  CALL pywidt(3100021,sh,wdtp,wdte)
36965  IF(wdtp(0).GT.rtcm(33)*shr) wdtp(0)=rtcm(33)*shr
36966  ztc(2,2)=dcmplx(sh-pmas(pycomp(3100021),1)**2,-shr*wdtp(0))
36967  CALL pywidt(3100113,sh,wdtp,wdte)
36968  ztc(3,3)=dcmplx(sh-pmas(pycomp(3100113),1)**2,-shr*wdtp(0))
36969  CALL pywidt(3400113,sh,wdtp,wdte)
36970  ztc(4,4)=dcmplx(sh-pmas(pycomp(3400113),1)**2,-shr*wdtp(0))
36971  CALL pywidt(3200113,sh,wdtp,wdte)
36972  ztc(5,5)=dcmplx(sh-pmas(pycomp(3200113),1)**2,-shr*wdtp(0))
36973  CALL pywidt(3300113,sh,wdtp,wdte)
36974  ztc(6,6)=dcmplx(sh-pmas(pycomp(3300113),1)**2,-shr*wdtp(0))
36975  ztc(1,2)=(0d0,0d0)
36976  ztc(1,3)=dcmplx(sh*xig,0d0)
36977  ztc(1,4)=ztc(1,3)
36978  ztc(1,5)=ztc(1,2)
36979  ztc(1,6)=ztc(1,2)
36980  ztc(2,3)=dcmplx(sh*xig*x11,0d0)
36981  ztc(2,4)=dcmplx(sh*xig*x22,0d0)
36982  ztc(2,5)=dcmplx(sh*xig*x12,0d0)
36983  ztc(2,6)=dcmplx(sh*xig*x21,0d0)
36984  ztc(3,4)=-sm1122
36985  ztc(3,5)=-sm1112
36986  ztc(3,6)=-sm1121
36987  ztc(4,5)=-sm2212
36988  ztc(4,6)=-sm2221
36989  ztc(5,6)=-sm1221
36990 
36991  DO 110 i=1,5
36992  DO 100 j=i+1,6
36993  ztc(j,i)=ztc(i,j)
36994  100 CONTINUE
36995  110 CONTINUE
36996  CALL pyldcm(ztc,6,6,indx,d)
36997  DO 130 i=1,6
36998  DO 120 j=1,6
36999  ytc(i,j)=(0d0,0d0)
37000  IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
37001  120 CONTINUE
37002  130 CONTINUE
37003 
37004  DO 140 i=1,6
37005  CALL pybksb(ztc,6,6,indx,ytc(1,i))
37006  140 CONTINUE
37007  dggs=ytc(1,1)
37008  dvvs=ytc(2,2)
37009  dgvs=ytc(1,2)
37010 
37011  xig=sqrt(pyalps(-th)/alprht)
37012 C.........TH LOOP
37013  ztc(1,1)=dcmplx(th)
37014  ztc(2,2)=dcmplx(th-pmas(pycomp(3100021),1)**2)
37015  ztc(3,3)=dcmplx(th-pmas(pycomp(3100113),1)**2)
37016  ztc(4,4)=dcmplx(th-pmas(pycomp(3400113),1)**2)
37017  ztc(5,5)=dcmplx(th-pmas(pycomp(3200113),1)**2)
37018  ztc(6,6)=dcmplx(th-pmas(pycomp(3300113),1)**2)
37019  ztc(1,2)=(0d0,0d0)
37020  ztc(1,3)=dcmplx(th*xig,0d0)
37021  ztc(1,4)=ztc(1,3)
37022  ztc(1,5)=ztc(1,2)
37023  ztc(1,6)=ztc(1,2)
37024  ztc(2,3)=dcmplx(th*xig*x11,0d0)
37025  ztc(2,4)=dcmplx(th*xig*x22,0d0)
37026  ztc(2,5)=dcmplx(th*xig*x12,0d0)
37027  ztc(2,6)=dcmplx(th*xig*x21,0d0)
37028  ztc(3,4)=-sm1122
37029  ztc(3,5)=-sm1112
37030  ztc(3,6)=-sm1121
37031  ztc(4,5)=-sm2212
37032  ztc(4,6)=-sm2221
37033  ztc(5,6)=-sm1221
37034  DO 160 i=1,5
37035  DO 150 j=i+1,6
37036  ztc(j,i)=ztc(i,j)
37037  150 CONTINUE
37038  160 CONTINUE
37039  CALL pyldcm(ztc,6,6,indx,d)
37040  DO 180 i=1,6
37041  DO 170 j=1,6
37042  ytc(i,j)=(0d0,0d0)
37043  IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
37044  170 CONTINUE
37045  180 CONTINUE
37046  DO 190 i=1,6
37047  CALL pybksb(ztc,6,6,indx,ytc(1,i))
37048  190 CONTINUE
37049  dggt=ytc(1,1)
37050  dvvt=ytc(2,2)
37051  dgvt=ytc(1,2)
37052 
37053  xig=sqrt(pyalps(-uh)/alprht)
37054 C.........UH LOOP
37055  ztc(1,1)=dcmplx(uh,0d0)
37056  ztc(2,2)=dcmplx(uh-pmas(pycomp(3100021),1)**2)
37057  ztc(3,3)=dcmplx(uh-pmas(pycomp(3100113),1)**2)
37058  ztc(4,4)=dcmplx(uh-pmas(pycomp(3400113),1)**2)
37059  ztc(5,5)=dcmplx(uh-pmas(pycomp(3200113),1)**2)
37060  ztc(6,6)=dcmplx(uh-pmas(pycomp(3300113),1)**2)
37061  ztc(1,2)=(0d0,0d0)
37062  ztc(1,3)=dcmplx(uh*xig,0d0)
37063  ztc(1,4)=ztc(1,3)
37064  ztc(1,5)=ztc(1,2)
37065  ztc(1,6)=ztc(1,2)
37066  ztc(2,3)=dcmplx(uh*xig*x11,0d0)
37067  ztc(2,4)=dcmplx(uh*xig*x22,0d0)
37068  ztc(2,5)=dcmplx(uh*xig*x12,0d0)
37069  ztc(2,6)=dcmplx(uh*xig*x21,0d0)
37070  ztc(3,4)=-sm1122
37071  ztc(3,5)=-sm1112
37072  ztc(3,6)=-sm1121
37073  ztc(4,5)=-sm2212
37074  ztc(4,6)=-sm2221
37075  ztc(5,6)=-sm1221
37076  DO 210 i=1,5
37077  DO 200 j=i+1,6
37078  ztc(j,i)=ztc(i,j)
37079  200 CONTINUE
37080  210 CONTINUE
37081  CALL pyldcm(ztc,6,6,indx,d)
37082  DO 230 i=1,6
37083  DO 220 j=1,6
37084  ytc(i,j)=(0d0,0d0)
37085  IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
37086  220 CONTINUE
37087  230 CONTINUE
37088  DO 240 i=1,6
37089  CALL pybksb(ztc,6,6,indx,ytc(1,i))
37090  240 CONTINUE
37091  dggu=ytc(1,1)
37092  dvvu=ytc(2,2)
37093  dgvu=ytc(1,2)
37094 
37095  IF(imdl.EQ.1) THEN
37096  dqqs=dggs+dvvs*dcmplx(tant3**2)-dgvs*dcmplx(2d0*tant3)
37097  dqqt=dggt+dvvt*dcmplx(tant3**2)-dgvt*dcmplx(2d0*tant3)
37098  dqqu=dggu+dvvu*dcmplx(tant3**2)-dgvu*dcmplx(2d0*tant3)
37099  dqts=dggs-dvvs-dgvs*dcmplx(tant3-1d0/tant3)
37100  dqgs=dggs-dgvs*dcmplx(tant3)
37101  dtgs=dggs+dgvs*dcmplx(1d0/tant3)
37102  ELSE
37103  dqqs=dggs+dvvs*dcmplx(1d0/tant3**2)+dgvs*dcmplx(2d0/tant3)
37104  dqqt=dggt+dvvt*dcmplx(1d0/tant3**2)+dgvt*dcmplx(2d0/tant3)
37105  dqqu=dggu+dvvu*dcmplx(1d0/tant3**2)+dgvu*dcmplx(2d0/tant3)
37106  dqts=dggs+dvvs*dcmplx(1d0/tant3**2)+dgvs*dcmplx(2d0/tant3)
37107  dqgs=dggs+dgvs*dcmplx(1d0/tant3)
37108  dtgs=dggs+dgvs*dcmplx(1d0/tant3)
37109  ENDIF
37110 
37111  sqdqts=abs(dqts)**2
37112  sqdqqs=abs(dqqs)**2
37113  sqdqqt=abs(dqqt)**2
37114  sqdqqu=abs(dqqu)**2
37115  sqdlgs=abs(dcmplx(sh)*dqgs-dcmplx(1d0))**2
37116  redlgs=dble(dqgs)
37117  sqdhgs=abs(dcmplx(sh)*dtgs-dcmplx(1d0))**2
37118  redhgs=dble(dtgs)
37119  sqdlgt=abs(dcmplx(th)*dggt-dcmplx(1d0))**2
37120 
37121  sqdggs=abs(dggs)**2
37122  sqdggt=abs(dggt)**2
37123  sqdggu=abs(dggu)**2
37124  redggs=dble(dggs)
37125  redggt=dble(dggt)
37126  redggu=dble(dggu)
37127  redgtu=dble(dggu*dconjg(dggt))
37128  redgsu=dble(dggu*dconjg(dggs))
37129  redgst=dble(dggs*dconjg(dggt))
37130  redqst=dble(dqqs*dconjg(dqqt))
37131  redqtu=dble(dqqt*dconjg(dqqu))
37132  ENDIF
37133  ENDIF
37134 
37135 
37136 C...Differential cross section expressions.
37137 
37138  IF(isub.LE.190) THEN
37139  IF(isub.EQ.149) THEN
37140 C...g + g -> eta_tc
37141  kctc=pycomp(ktechn+331)
37142  CALL pywidt(ktechn+331,sh,wdtp,wdte)
37143  hs=shr*wdtp(0)
37144  facbw=comfac*0.5d0/((sh-pmas(kctc,1)**2)**2+hs**2)
37145  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
37146  hp=sh
37147  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 250
37148  hi=hp*wdtp(3)
37149  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37150  nchn=nchn+1
37151  isig(nchn,1)=21
37152  isig(nchn,2)=21
37153  isig(nchn,3)=1
37154  sigh(nchn)=hi*facbw*hf
37155  250 CONTINUE
37156 
37157  ELSEIF(isub.EQ.165) THEN
37158 C...q + qbar -> l+ + l- (including contact term for compositeness)
37159  zratr=xwc*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
37160  zrati=xwc*sh*gmmz/((sh-sqmz)**2+gmmz**2)
37161  kff=iabs(kfpr(isub,1))
37162  ef=kchg(kff,1)/3d0
37163  af=sign(1d0,ef+0.1d0)
37164  vf=af-4d0*ef*xwv
37165  valf=vf+af
37166  varf=vf-af
37167  fcof=1d0
37168  IF(kff.LE.10) fcof=3d0
37169  wid2=1d0
37170  IF(kff.EQ.6) wid2=wids(6,1)
37171  IF(kff.EQ.7.OR.kff.EQ.8) wid2=wids(kff,1)
37172  IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
37173  DO 260 i=mmina,mmaxa
37174  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 260
37175  ei=kchg(iabs(i),1)/3d0
37176  ai=sign(1d0,ei+0.1d0)
37177  vi=ai-4d0*ei*xwv
37178  vali=vi+ai
37179  vari=vi-ai
37180  fcoi=1d0
37181  IF(iabs(i).LE.10) fcoi=faca/3d0
37182  IF((itcm(5).EQ.1.AND.iabs(i).LE.2).OR.itcm(5).EQ.2) THEN
37183  fgza=(ei*ef+vali*valf*zratr+rtcm(42)*sh/
37184  & (aem*rtcm(41)**2))**2+(vali*valf*zrati)**2+
37185  & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
37186  ELSE
37187  fgza=(ei*ef+vali*valf*zratr)**2+(vali*valf*zrati)**2+
37188  & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
37189  ENDIF
37190  fgzb=(ei*ef+vali*varf*zratr)**2+(vali*varf*zrati)**2+
37191  & (ei*ef+vari*valf*zratr)**2+(vari*valf*zrati)**2
37192  fgzab=aem**2*(fgza*uh2/sh2+fgzb*th2/sh2)
37193  IF((itcm(5).EQ.3.AND.iabs(i).EQ.2).OR.(itcm(5).EQ.4.AND.
37194  & mod(iabs(i),2).EQ.0)) fgzab=fgzab+sh2/(2d0*rtcm(41)**4)
37195  nchn=nchn+1
37196  isig(nchn,1)=i
37197  isig(nchn,2)=-i
37198  isig(nchn,3)=1
37199  sigh(nchn)=comfac*fcoi*fcof*fgzab*wid2
37200  260 CONTINUE
37201 
37202  ELSEIF(isub.EQ.166) THEN
37203 C...q + q'bar -> l + nu_l (including contact term for compositeness)
37204  wfac=(1d0/4d0)*(aem/xw)**2*uh2/((sh-sqmw)**2+gmmw**2)
37205  wcifac=wfac+sh2/(4d0*rtcm(41)**4)
37206  kff=iabs(kfpr(isub,1))
37207  fcof=1d0
37208  IF(kff.LE.10) fcof=3d0
37209  DO 280 i=mmin1,mmax1
37210  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 280
37211  ia=iabs(i)
37212  DO 270 j=mmin2,mmax2
37213  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 270
37214  ja=iabs(j)
37215  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 270
37216  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37217  & goto 270
37218  fcoi=1d0
37219  IF(ia.LE.10) fcoi=vckm((ia+1)/2,(ja+1)/2)*faca/3d0
37220  wid2=1d0
37221  IF((i.GT.0.AND.mod(i,2).EQ.0).OR.(j.GT.0.AND.
37222  & mod(j,2).EQ.0)) THEN
37223  IF(kff.EQ.5) wid2=wids(6,2)
37224  IF(kff.EQ.7) wid2=wids(8,2)*wids(7,3)
37225  IF(kff.EQ.17) wid2=wids(18,2)*wids(17,3)
37226  ELSE
37227  IF(kff.EQ.5) wid2=wids(6,3)
37228  IF(kff.EQ.7) wid2=wids(8,3)*wids(7,2)
37229  IF(kff.EQ.17) wid2=wids(18,3)*wids(17,2)
37230  ENDIF
37231  nchn=nchn+1
37232  isig(nchn,1)=i
37233  isig(nchn,2)=j
37234  isig(nchn,3)=1
37235  sigh(nchn)=comfac*fcoi*fcof*wfac*wid2
37236  IF((itcm(5).EQ.3.AND.ia.LE.2.AND.ja.LE.2).OR.itcm(5).EQ.4)
37237  & sigh(nchn)=comfac*fcoi*fcof*wcifac*wid2
37238  270 CONTINUE
37239  280 CONTINUE
37240  ENDIF
37241 
37242  ELSEIF(isub.LE.200) THEN
37243  IF(isub.EQ.191) THEN
37244 C...q + qbar -> rho_tc0.
37245  kctc=pycomp(ktechn+113)
37246  sqmrht=pmas(kctc,1)**2
37247  CALL pywidt(ktechn+113,sh,wdtp,wdte)
37248  hs=shr*wdtp(0)
37249  facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
37250  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
37251  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37252  alprht=2.16d0*(3d0/itcm(1))
37253  hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)
37254  xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
37255  bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
37256  bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
37257  DO 290 i=mmina,mmaxa
37258  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 290
37259  ia=iabs(i)
37260  ei=kchg(iabs(i),1)/3d0
37261  ai=sign(1d0,ei+0.1d0)
37262  vi=ai-4d0*ei*xwv
37263  vali=0.5d0*(vi+ai)
37264  vari=0.5d0*(vi-ai)
37265  hi=hp*((ei+vali*bwzr)**2+(vali*bwzi)**2+
37266  & (ei+vari*bwzr)**2+(vari*bwzi)**2)
37267  IF(ia.LE.10) hi=hi*faca/3d0
37268  nchn=nchn+1
37269  isig(nchn,1)=i
37270  isig(nchn,2)=-i
37271  isig(nchn,3)=1
37272  sigh(nchn)=hi*facbw*hf
37273  290 CONTINUE
37274 
37275  ELSEIF(isub.EQ.192) THEN
37276 C...q + qbar' -> rho_tc+/-.
37277  kctc=pycomp(ktechn+213)
37278  sqmrht=pmas(kctc,1)**2
37279  CALL pywidt(ktechn+213,sh,wdtp,wdte)
37280  hs=shr*wdtp(0)
37281  facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
37282  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
37283  alprht=2.16d0*(3d0/itcm(1))
37284  hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)*
37285  & (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
37286  DO 310 i=mmin1,mmax1
37287  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 310
37288  ia=iabs(i)
37289  DO 300 j=mmin2,mmax2
37290  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 300
37291  ja=iabs(j)
37292  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 300
37293  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37294  & goto 300
37295  kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37296  hf=shr*(wdte(0,1)+wdte(0,(5-kchr)/2)+wdte(0,4))
37297  hi=hp
37298  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
37299  nchn=nchn+1
37300  isig(nchn,1)=i
37301  isig(nchn,2)=j
37302  isig(nchn,3)=1
37303  sigh(nchn)=hi*facbw*hf
37304  300 CONTINUE
37305  310 CONTINUE
37306 
37307  ELSEIF(isub.EQ.193) THEN
37308 C...q + qbar -> omega_tc0.
37309  kctc=pycomp(ktechn+223)
37310  sqmomt=pmas(kctc,1)**2
37311  CALL pywidt(ktechn+223,sh,wdtp,wdte)
37312  hs=shr*wdtp(0)
37313  facbw=12d0*comfac/((sh-sqmomt)**2+hs**2)
37314  IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
37315  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37316  alprht=2.16d0*(3d0/itcm(1))
37317  hp=(1d0/6d0)*(aem**2/alprht)*(sqmomt**2/sh)*
37318  & (2d0*rtcm(2)-1d0)**2
37319  bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
37320  bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
37321  DO 320 i=mmina,mmaxa
37322  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 320
37323  ia=iabs(i)
37324  ei=kchg(iabs(i),1)/3d0
37325  ai=sign(1d0,ei+0.1d0)
37326  vi=ai-4d0*ei*xwv
37327  vali=0.5d0*(vi+ai)
37328  vari=0.5d0*(vi-ai)
37329  hi=hp*((ei-vali*bwzr)**2+(vali*bwzi)**2+
37330  & (ei-vari*bwzr)**2+(vari*bwzi)**2)
37331  IF(ia.LE.10) hi=hi*faca/3d0
37332  nchn=nchn+1
37333  isig(nchn,1)=i
37334  isig(nchn,2)=-i
37335  isig(nchn,3)=1
37336  sigh(nchn)=hi*facbw*hf
37337  320 CONTINUE
37338 
37339  ELSEIF(isub.EQ.194) THEN
37340 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
37341 C...Default final state is e+e-
37342  kfa=kfpr(isubsv,1)
37343  alprht=2.16d0*(3d0/itcm(1))
37344  hp=aem**2*comfac
37345 
37346  sn2w=2d0*sqrt(xw*xw1)
37347 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
37348 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
37349 
37350  qupd=2d0*rtcm(2)-1d0
37351  far=sqrt(aem/alprht)
37352  fao=far*qupd
37353  fzr=far*ct2w
37354  fzo=-fao*tanw
37355 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37356  fzx=-far/sn2w*rtcm(47)
37357  sfar=far**2
37358  sfao=fao**2
37359  sfzr=fzr**2
37360  sfzo=fzo**2
37361  sfzx=fzx**2
37362  CALL pywidt(23,sh,wdtp,wdte)
37363  ssmz=dcmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
37364  CALL pywidt(ktechn+113,sh,wdtp,wdte)
37365  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+113),1)**2/sh,wdtp(0)/shr)
37366  CALL pywidt(ktechn+223,sh,wdtp,wdte)
37367  ssmo=dcmplx(1d0-pmas(pycomp(ktechn+223),1)**2/sh,wdtp(0)/shr)
37368  CALL pywidt(ktechn+115,sh,wdtp,wdte)
37369  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+115),1)**2/sh,wdtp(0)/shr)
37370 C...Propagator including a_T^0
37371  detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
37372  $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
37373 C...Add in techni-a contribution
37374  detd=ssmx*detd-sfzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)
37375  daa=(-ssmx*(sfzo*ssmr+sfzr*ssmo-ssmo*ssmr*ssmz)-
37376  $ sfzx*ssmr*ssmo)/detd/sh
37377  dzz=-(sfao*ssmr+sfar*ssmo-ssmo*ssmr)/detd/sh*ssmx
37378  daz=(far*fzr*ssmo+fao*fzo*ssmr)/detd/sh*ssmx
37379 
37380  xwrht=1d0/(4d0*xw*(1d0-xw))
37381  kff=iabs(kfpr(isub,1))
37382  ef=kchg(kff,1)/3d0
37383  af=sign(1d0,ef+0.1d0)
37384  vf=af-4d0*ef*xwv
37385  valf=0.5d0*(vf+af)
37386  varf=0.5d0*(vf-af)
37387  fcof=1d0
37388  IF(kff.LE.10) fcof=3d0
37389 
37390  wid2=1d0
37391  IF(kff.GE.6.AND.kff.LE.8) wid2=wids(kff,1)
37392  IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
37393  dzz=dzz*dcmplx(xwrht,0d0)
37394  daz=daz*dcmplx(sqrt(xwrht),0d0)
37395 
37396  DO 330 i=mmina,mmaxa
37397  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 330
37398  ei=kchg(iabs(i),1)/3d0
37399  ai=sign(1d0,ei+0.1d0)
37400  vi=ai-4d0*ei*xwv
37401  vali=0.5d0*(vi+ai)
37402  vari=0.5d0*(vi-ai)
37403  fcoi=fcof
37404  IF(iabs(i).LE.10) fcoi=fcoi/3d0
37405  difll=abs(ei*ef*daa+vali*valf*dzz+daz*(ei*valf+ef*vali))**2
37406  difrr=abs(ei*ef*daa+vari*varf*dzz+daz*(ei*varf+ef*vari))**2
37407  diflr=abs(ei*ef*daa+vali*varf*dzz+daz*(ei*varf+ef*vali))**2
37408  difrl=abs(ei*ef*daa+vari*valf*dzz+daz*(ei*valf+ef*vari))**2
37409  facsig=(difll+difrr)*((uh-sqm4)**2+sh*sqm4)+
37410  & (diflr+difrl)*((th-sqm3)**2+sh*sqm3)
37411  nchn=nchn+1
37412  isig(nchn,1)=i
37413  isig(nchn,2)=-i
37414  isig(nchn,3)=1
37415  sigh(nchn)=hp*fcoi*facsig*wid2
37416  330 CONTINUE
37417 
37418  ELSEIF(isub.EQ.195) THEN
37419 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
37420  kfa=kfpr(isubsv,1)
37421  kfb=kfa+1
37422  alprht=2.16d0*(3d0/itcm(1))
37423  factc=comfac*(aem**2/12d0/xw**2)*(uh-sqm3)*(uh-sqm4)*3d0
37424 
37425  fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
37426 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37427 C
37428 C...Propagator including a_T^+
37429  fwx=-fwr*rtcm(47)
37430  CALL pywidt(24,sh,wdtp,wdte)
37431  ssmz=dcmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
37432  CALL pywidt(ktechn+213,sh,wdtp,wdte)
37433  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+213),1)**2/sh,wdtp(0)/shr)
37434  CALL pywidt(ktechn+215,sh,wdtp,wdte)
37435  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+215),1)**2/sh,wdtp(0)/shr)
37436  detd=ssmx*(ssmz*ssmr-dcmplx(fwr**2,0d0))-
37437  & dcmplx(fwx**2,0d0)*ssmr
37438  dww=ssmr*ssmx/detd/sh
37439  fcof=1d0
37440  IF(kfa.LE.8) fcof=3d0
37441  hp=factc*abs(dww)**2*fcof
37442 
37443  DO 350 i=mmin1,mmax1
37444  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 350
37445  ia=iabs(i)
37446  DO 340 j=mmin2,mmax2
37447  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 340
37448  ja=iabs(j)
37449  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 340
37450  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37451  & goto 340
37452  kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37453  hi=hp
37454  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
37455  nchn=nchn+1
37456  isig(nchn,1)=i
37457  isig(nchn,2)=j
37458  isig(nchn,3)=1
37459  sigh(nchn)=hi*wids(kfa,(5-kchr)/2)*wids(kfb,(5+kchr)/2)
37460  340 CONTINUE
37461  350 CONTINUE
37462  ENDIF
37463 
37464  ELSEIF(isub.LE.380) THEN
37465  alprht=2.16d0*(3d0/itcm(1))
37466  IF(isub.EQ.361) THEN
37467  far=sqrt(aem/alprht)
37468  fao=far*qupd
37469  fzr=far*ct2w
37470  fzo=-fao*tanw
37471 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37472  fzx=-far/sn2w*rtcm(47)
37473  sfar=far**2
37474  sfao=fao**2
37475  sfzr=fzr**2
37476  sfzo=fzo**2
37477  sfzx=fzx**2
37478  CALL pywidt(23,sh,wdtp,wdte)
37479  ssmz=dcmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
37480  CALL pywidt(ktechn+113,sh,wdtp,wdte)
37481  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+113),1)**2/sh,wdtp(0)/shr)
37482  CALL pywidt(ktechn+223,sh,wdtp,wdte)
37483  ssmo=dcmplx(1d0-pmas(pycomp(ktechn+223),1)**2/sh,wdtp(0)/shr)
37484  CALL pywidt(ktechn+115,sh,wdtp,wdte)
37485  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+115),1)**2/sh,wdtp(0)/shr)
37486  detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
37487  $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
37488 C...Add in techni-a contribution
37489  detd=ssmx*detd-sfzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)
37490  darho=-(ssmx*(-far*sfzo+fao*fzo*fzr+far*ssmo*ssmz)-
37491  $ sfzx*far*ssmo)/detd/sh
37492  dzrho=-(-fzr*sfao+fao*fzo*far+fzr*ssmo)/detd/sh*ssmx
37493  daome=-(ssmx*(-fao*sfzr+far*fzo*fzr+fao*ssmr*ssmz)-
37494  $ sfzx*fao*ssmr)/detd/sh
37495  dzome=-(-fzo*sfar+far*fao*fzr+fzo*ssmr)/detd/sh*ssmx
37496  daast=-fzx*(fao*fzo*ssmr+far*fzr*ssmo)/detd/sh
37497  dzast=-fzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)/detd/sh
37498  daa=(-ssmx*(sfzo*ssmr+sfzr*ssmo-ssmo*ssmr*ssmz)-
37499  $ sfzx*ssmr*ssmo)/detd/sh
37500  dzz=-(sfao*ssmr+sfar*ssmo-ssmo*ssmr)/detd/sh*ssmx
37501  daz=(far*fzr*ssmo+fao*fzo*ssmr)/detd/sh*ssmx
37502 
37503 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
37504 C...W+W-, W pi_tc, pi_T pi_T, etc.
37505  faca=(sh**2*be34**2-(th-uh)**2)
37506  vfac=(th**2+uh**2-2d0*sqm3*sqm4)
37507  afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)
37508  fanom=sqrt(paru(1)*aem)*itcm(1)/paru(2)**2/rtcm(1)
37509  hp=(1d0/24d0)*aem**2*comfac*3d0*sh
37510  DO 370 i=mmina,mmaxa
37511  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 370
37512  ia=iabs(i)
37513  ei=kchg(iabs(i),1)/3d0
37514  ai=sign(1d0,ei+0.1d0)
37515  vi=ai-4d0*ei*xwv
37516  vali=0.25d0*(vi+ai) ! = \zeta_{iL} in PRD67-115011
37517  vari=0.25d0*(vi-ai) ! = \zeta_{iR} in PRD67-115011
37518 C...........Eqs. (5) and (6) in LSTC-rates.pdf
37519  f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*vrgp
37520  f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*vogp
37521  f2l=f2l+(ei*daast+vali*dzast/sqrt(xw*xw1))*vxgp
37522  f2l=f2l+fanom*(vagp*(ei*daa+vali*daz/sqrt(xw*xw1))+
37523  $ vzgp*(ei*daz+vali*dzz/sqrt(xw*xw1)))
37524  f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*vrgp
37525  f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*vogp
37526  f2r=f2r+(ei*daast+vari*dzast/sqrt(xw*xw1))*vxgp
37527  f2r=f2r+fanom*(vagp*(ei*daa+vari*daz/sqrt(xw*xw1))+
37528  $ vzgp*(ei*daz+vari*dzz/sqrt(xw*xw1)))
37529  hi=(abs(f2l)**2+abs(f2r)**2)*vfac
37530 C...........Eqs. (5) and (7) in LSTC-rates.pdf
37531  f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*argp
37532  f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*aogp
37533  f2l=f2l+(ei*daast+vali*dzast/sqrt(xw*xw1))*axgp
37534  f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*argp
37535  f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*aogp
37536  f2r=f2r+(ei*daast+vari*dzast/sqrt(xw*xw1))*axgp
37537  hj=(abs(f2l)**2+abs(f2r)**2)*afac
37538 C
37539 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
37540 C
37541 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37542 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37543 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37544 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37545  f2l=ei*darho/far + vali*ct2w*dzrho/fzr/sqrt(xw*xw1)
37546  f2r=ei*darho/far + vari*ct2w*dzrho/fzr/sqrt(xw*xw1)
37547  hk=(abs(f2l)**2+abs(f2r)**2)*2d0*faca*cab2/sh
37548  hi=hi+hj+hk
37549  IF(ia.LE.10) hi=hi/3d0
37550  nchn=nchn+1
37551  isig(nchn,1)=i
37552  isig(nchn,2)=-i
37553  isig(nchn,3)=1
37554  IF(kfa.EQ.kfb) THEN
37555  sigh(nchn)=hi*hp*wids(pycomp(kfa),1)
37556  ELSEIF(isubsv.EQ.362.OR.isubsv.EQ.368) THEN
37557  sigh(nchn)=hi*hp*wids(pycomp(kfa),2)*wids(pycomp(kfb),3)
37558  nchn=nchn+1
37559  isig(nchn,1)=i
37560  isig(nchn,2)=-i
37561  isig(nchn,3)=2
37562  sigh(nchn)=hi*hp*wids(pycomp(kfa),3)*wids(pycomp(kfb),2)
37563  ELSE
37564  sigh(nchn)=hi*hp*wids(pycomp(kfa),2)*wids(pycomp(kfb),2)
37565  ENDIF
37566  370 CONTINUE
37567 
37568  ELSEIF(isub.EQ.370) THEN
37569 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
37570 C...f + fbar' -> gamma pi_tc, etc.
37571  faca=(sh**2*be34**2-(th-uh)**2)
37572  fanom=sqrt(paru(1)*aem)*itcm(1)/paru(2)**2/rtcm(1)
37573  vfac=(th**2+uh**2-2d0*sqm3*sqm4)
37574  afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)
37575  alprht=2.16d0*(3d0/itcm(1))
37576  fachp=(1d0/48d0)*aem**2/xw*comfac*3d0*sh
37577  fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
37578 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37579  fwx=-fwr*rtcm(47)
37580  CALL pywidt(24,sh,wdtp,wdte)
37581  ssmz=dcmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
37582  CALL pywidt(ktechn+213,sh,wdtp,wdte)
37583  ssmr=dcmplx(1d0-pmas(pycomp(ktechn+213),1)**2/sh,wdtp(0)/shr)
37584  CALL pywidt(ktechn+215,sh,wdtp,wdte)
37585  ssmx=dcmplx(1d0-pmas(pycomp(ktechn+215),1)**2/sh,wdtp(0)/shr)
37586  detd=ssmx*(ssmz*ssmr-dcmplx(fwr**2,0d0))-
37587  & dcmplx(fwx**2,0d0)*ssmr
37588  dww=ssmr*ssmx/detd/sh
37589  dwrho=-dcmplx(fwr,0d0)*ssmx/detd/sh
37590  dwast=-dcmplx(fwx,0d0)*ssmr/detd/sh
37591  hp=fachp*(afac*abs(dwrho*argp+dwast*axgp)**2+
37592  $ vfac*abs(fanom*dww*vwgp+dwrho*vrgp+dwast*vxgp)**2)
37593 C
37594 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
37595 C
37596 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
37597  hp=hp+.5d0*fachp*cab2*faca/xw/sh*abs(dwrho/fwr)**2
37598 C...Add in W_L Z_T axial and vector contributions.
37599  IF(isubsv.EQ.370) hp=hp+fachp*rtcm(3)**2*(
37600  $ (th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm4)* !AFAC w/ switched masses.
37601  $ abs(dwrho/rtcm(13)-dwast/rtcm(49)*cs2w)**2/sn2w**2+
37602  $ vfac*qupd**2*xw/xw1*abs(dwrho)**2/rtcm(12)**2)
37603  DO 410 i=mmin1,mmax1
37604  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 410
37605  ia=iabs(i)
37606  DO 400 j=mmin2,mmax2
37607  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 400
37608  ja=iabs(j)
37609  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 400
37610  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37611  & goto 400
37612  kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37613  hi=hp
37614  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
37615  nchn=nchn+1
37616  isig(nchn,1)=i
37617  isig(nchn,2)=j
37618  isig(nchn,3)=1
37619  IF(isubsv.EQ.374.OR.isubsv.EQ.378) THEN
37620  sigh(nchn)=hi*wids(pycomp(kfa),(5-kchr)/2)
37621  ELSE
37622  sigh(nchn)=hi*wids(pycomp(kfa),(5-kchr)/2)*
37623  & wids(pycomp(kfb),2)
37624  ENDIF
37625  400 CONTINUE
37626  410 CONTINUE
37627  ENDIF
37628 
37629  ELSEIF(isub.LE.390) THEN
37630  IF(isub.EQ.381) THEN
37631 C...f + f' -> f + f' (g exchange)
37632  facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)*sqdqqt
37633  facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)*sqdqqt*faca-
37634  & mstp(34)*2d0/3d0*uh2*redqst)
37635  facqq2=comfac*as**2*4d0/9d0*(sh2+th2)*sqdqqu
37636  facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
37637  ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
37638  IF(itcm(5).GE.1.AND.itcm(5).LE.4) THEN
37639 C...Modifications from contact interactions (compositeness)
37640  facci1=facqq1+comfac*(sh2/rtcm(41)**4)
37641  faccib=facqqb+comfac*(8d0/9d0)*(as*rtcm(42)/rtcm(41)**2)*
37642  & (uh2/th+uh2/sh)+comfac*(5d0/3d0)*(uh2/rtcm(41)**4)
37643  facci2=facqq2+comfac*(8d0/9d0)*(as*rtcm(42)/rtcm(41)**2)*
37644  & (sh2/th+sh2/uh)+comfac*(5d0/3d0)*(sh2/rtcm(41)**4)
37645  facci3=facqq1+comfac*(uh2/rtcm(41)**4)
37646  ratcii=(facci1+facci2+facqqi)/(facci1+facci2)
37647  ELSEIF(itcm(5).EQ.5) THEN
37648  facci1=facqq1
37649  faccib=facqqb
37650  facci2=facqq2
37651  facci3=facqq1
37652 CSM.......Check this change from
37653 CSM RATCII=1D0
37654  ratcii=ratqqi
37655  ENDIF
37656  DO 430 i=mmin1,mmax1
37657  ia=iabs(i)
37658  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 430
37659  DO 420 j=mmin2,mmax2
37660  ja=iabs(j)
37661  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 420
37662  nchn=nchn+1
37663  isig(nchn,1)=i
37664  isig(nchn,2)=j
37665  isig(nchn,3)=1
37666  IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.(ia.GE.3.OR.
37667  & ja.GE.3))) THEN
37668  sigh(nchn)=facqq1
37669  IF(i.EQ.-j) sigh(nchn)=facqqb
37670  ELSE
37671  sigh(nchn)=facci1
37672  IF(i*j.LT.0) sigh(nchn)=facci3
37673  IF(i.EQ.-j) sigh(nchn)=faccib
37674  ENDIF
37675  IF(i.EQ.j) THEN
37676  nchn=nchn+1
37677  isig(nchn,1)=i
37678  isig(nchn,2)=j
37679  isig(nchn,3)=2
37680  IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.ia.GE.3)) THEN
37681  sigh(nchn-1)=0.5d0*facqq1*ratqqi
37682  sigh(nchn)=0.5d0*facqq2*ratqqi
37683  ELSE
37684  sigh(nchn-1)=0.5d0*facci1*ratcii
37685  sigh(nchn)=0.5d0*facci2*ratcii
37686  ENDIF
37687  ENDIF
37688  420 CONTINUE
37689  430 CONTINUE
37690 
37691  ELSEIF(isub.EQ.382) THEN
37692 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37693  CALL pywidt(21,sh,wdtp,wdte)
37694  facqqf=comfac*as**2*4d0/9d0*(th2+uh2)
37695  facqqb=facqqf*sqdqqs*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37696  IF(itcm(5).EQ.1) THEN
37697 C...Modifications from contact interactions (compositeness)
37698  faccib=facqqb
37699  DO 440 i=1,2
37700  faccib=faccib+comfac*(uh2/rtcm(41)**4)*(wdte(i,1)+
37701  & wdte(i,2)+wdte(i,4))
37702  440 CONTINUE
37703  ELSEIF(itcm(5).GE.2.AND.itcm(5).LE.4) THEN
37704  faccib=facqqb+comfac*(uh2/rtcm(41)**4)*
37705  & (wdte(0,1)+wdte(0,2)+wdte(0,4))
37706  ELSEIF(itcm(5).EQ.5) THEN
37707  facqqb=facqqf*sqdqqs*(wdte(0,1)+wdte(0,2)+wdte(0,4)-
37708  & wdte(5,1)-wdte(5,2)-wdte(5,4))
37709  faccib=facqqf*sqdqts*(wdte(5,1)+wdte(5,2)+wdte(5,4))
37710  ENDIF
37711  DO 450 i=mmina,mmaxa
37712  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37713  & kfac(1,i)*kfac(2,-i).EQ.0) goto 450
37714  nchn=nchn+1
37715  isig(nchn,1)=i
37716  isig(nchn,2)=-i
37717  isig(nchn,3)=1
37718  IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.iabs(i).GE.3)) THEN
37719  sigh(nchn)=facqqb
37720  ELSEIF(itcm(5).EQ.5) THEN
37721  sigh(nchn)=facqqb
37722  nchn=nchn+1
37723  isig(nchn,1)=i
37724  isig(nchn,2)=-i
37725  isig(nchn,3)=2
37726  sigh(nchn)=faccib
37727  ELSE
37728  sigh(nchn)=faccib
37729  ENDIF
37730  450 CONTINUE
37731 
37732  ELSEIF(isub.EQ.383) THEN
37733 C...f + fbar -> g + g (q + qbar -> g + g only)
37734  facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
37735  & uh2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)
37736  facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
37737  & th2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)
37738  IF(itcm(5).EQ.5) THEN
37739  facgg3=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
37740  & uh2/sh2+9d0/4d0*th*uh/sh2*sqdhgs)
37741  facgg4=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
37742  & th2/sh2+9d0/4d0*th*uh/sh2*sqdhgs)
37743  ENDIF
37744  DO 460 i=mmina,mmaxa
37745  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37746  & kfac(1,i)*kfac(2,-i).EQ.0) goto 460
37747  nchn=nchn+1
37748  isig(nchn,1)=i
37749  isig(nchn,2)=-i
37750  isig(nchn,3)=1
37751  sigh(nchn)=0.5d0*facgg1
37752  IF(itcm(5).EQ.5.AND.iabs(i).EQ.5) sigh(nchn)=0.5d0*facgg3
37753  nchn=nchn+1
37754  isig(nchn,1)=i
37755  isig(nchn,2)=-i
37756  isig(nchn,3)=2
37757  sigh(nchn)=0.5d0*facgg2
37758  IF(itcm(5).EQ.5.AND.iabs(i).EQ.5) sigh(nchn)=0.5d0*facgg4
37759  460 CONTINUE
37760 
37761  ELSEIF(isub.EQ.384) THEN
37762 C...f + g -> f + g (q + g -> q + g only)
37763  facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
37764  & uh/sh-9d0/4d0*sh*uh/th2*sqdlgt)*faca
37765  facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
37766  & sh/uh-9d0/4d0*sh*uh/th2*sqdlgt)
37767  DO 480 i=mmina,mmaxa
37768  IF(i.EQ.0.OR.iabs(i).GT.10) goto 480
37769  DO 470 isde=1,2
37770  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 470
37771  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 470
37772  nchn=nchn+1
37773  isig(nchn,isde)=i
37774  isig(nchn,3-isde)=21
37775  isig(nchn,3)=1
37776  sigh(nchn)=facqg1
37777  nchn=nchn+1
37778  isig(nchn,isde)=i
37779  isig(nchn,3-isde)=21
37780  isig(nchn,3)=2
37781  sigh(nchn)=facqg2
37782  470 CONTINUE
37783  480 CONTINUE
37784 
37785  ELSEIF(isub.EQ.385) THEN
37786 C...g + g -> f + fbar (g + g -> q + qbar only)
37787  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 500
37788  idc0=mdcy(21,2)-1
37789 C...Begin by d, u, s flavours.
37790  flavwt=0d0
37791  IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
37792  & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
37793  IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
37794  & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
37795  IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
37796  & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
37797  facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
37798  & uh2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)*flavwt*faca
37799  facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
37800  & th2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)*flavwt*faca
37801  nchn=nchn+1
37802  isig(nchn,1)=21
37803  isig(nchn,2)=21
37804  isig(nchn,3)=1
37805  sigh(nchn)=facqq1
37806  nchn=nchn+1
37807  isig(nchn,1)=21
37808  isig(nchn,2)=21
37809  isig(nchn,3)=2
37810  sigh(nchn)=facqq2
37811 C...Next c and b flavours: modified that and uhat for fixed
37812 C...cos(theta-hat).
37813  DO 490 ifl=4,5
37814  sqmavg=pmas(ifl,1)**2
37815  IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
37816  be34=sqrt(1d0-4d0*sqmavg/sh)
37817  thq=-0.5d0*sh*(1d0-be34*cth)
37818  uhq=-0.5d0*sh*(1d0+be34*cth)
37819  thuhq=thq*uhq-sqmavg*sh
37820  IF(mstp(34).EQ.0) THEN
37821  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
37822  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
37823  ELSE
37824  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37825  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
37826  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37827  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
37828  ENDIF
37829  IF(itcm(5).GE.5) THEN
37830  IF(ifl.EQ.4) THEN
37831  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redlgs+
37832  & 2.25d0*thq*uhq/sh2*sqdlgs
37833  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redlgs+
37834  & 2.25d0*thq*uhq/sh2*sqdlgs
37835  ELSE
37836  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redhgs+
37837  & 2.25d0*thq*uhq/sh2*sqdhgs
37838  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redhgs+
37839  & 2.25d0*thq*uhq/sh2*sqdhgs
37840  ENDIF
37841  ENDIF
37842  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
37843  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
37844  nchn=nchn+1
37845  isig(nchn,1)=21
37846  isig(nchn,2)=21
37847  isig(nchn,3)=1+2*(ifl-3)
37848  sigh(nchn)=facqq1
37849  nchn=nchn+1
37850  isig(nchn,1)=21
37851  isig(nchn,2)=21
37852  isig(nchn,3)=2+2*(ifl-3)
37853  sigh(nchn)=facqq2
37854  ENDIF
37855  490 CONTINUE
37856  500 CONTINUE
37857 
37858  ELSEIF(isub.EQ.386) THEN
37859 C...g + g -> g + g
37860  IF(itcm(5).LE.4) THEN
37861  facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
37862  & 2d0*th/sh+th2/sh2)*faca
37863  facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
37864  & 2d0*sh/uh+sh2/uh2)*faca
37865  facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+
37866  & 2d0*uh/th+uh2/th2)
37867  ELSE
37868  gst= (12d0 + 40d0*th/sh + 56d0*th2/sh2 + 32d0*th**3/sh**3 +
37869  & 16d0*th**4/sh**4 + sqdggs*(4d0*sh2 + 16d0*sh*th + 16d0*th2)+
37870  & 4d0*redgst*(sh + 2d0*th)*
37871  & (2d0*sh**3 - 3d0*sh2*th - 2d0*sh*th2 + 2d0*th**3)/sh2 +
37872  & 2d0*redggs*(2d0*sh - 12d0*th2/sh - 8d0*th**3/sh2) +
37873  & 2d0*redggt*(4d0*sh - 22d0*th - 68d0*th2/sh - 60d0*th**3/sh2-
37874  & 32d0*th**4/sh**3 - 16d0*th**5/sh**4) +
37875  & sqdggt*(16d0*sh2 + 16d0*sh*th + 68d0*th2 + 144d0*th**3/sh +
37876  & 96d0*th**4/sh2 + 32d0*th**5/sh**3 + 16d0*th**6/sh**4))/16d0
37877  gsu= (12d0 + 40d0*uh/sh + 56d0*uh2/sh2 + 32d0*uh**3/sh**3 +
37878  & 16d0*uh**4/sh**4 + sqdggs*(4d0*sh2 + 16d0*sh*uh + 16d0*uh2)+
37879  & 4d0*redgsu*(sh + 2d0*uh)*
37880  & (2d0*sh**3 - 3d0*sh2*uh - 2d0*sh*uh2 + 2d0*uh**3)/sh2 +
37881  & 2d0*redggs*(2d0*sh - 12d0*uh2/sh - 8d0*uh**3/sh2) +
37882  & 2d0*redggu*(4d0*sh - 22d0*uh - 68d0*uh2/sh - 60d0*uh**3/sh2-
37883  & 32d0*uh**4/sh**3 - 16d0*uh**5/sh**4) +
37884  & sqdggu*(16d0*sh2 + 16d0*sh*uh + 68d0*uh2 + 144d0*uh**3/sh +
37885  & 96d0*uh**4/sh2 + 32d0*uh**5/sh**3 + 16d0*uh**6/sh**4))/16d0
37886  gut= (12d0 - 16d0*th*(th - uh)**2*uh/sh**4 +
37887  & 4d0*redggu*(2d0*th**5 - 15d0*th**4*uh - 48d0*th**3*uh2 -
37888  & 58d0*th2*uh**3 - 10d0*th*uh**4 + uh**5)/sh**4 +
37889  & 4d0*redggt*(th**5 - 10d0*th**4*uh - 58d0*th**3*uh2 -
37890  & 48d0*th2*uh**3 - 15d0*th*uh**4 + 2d0*uh**5)/sh**4 +
37891  & 4d0*sqdggu*(4d0*th**6 + 20d0*th**5*uh + 57d0*th**4*uh2 +
37892  & 72d0*th**3*uh**3+ 38d0*th2*uh**4+4d0*th*uh**5 +uh**6)/sh**4+
37893  & 4d0*sqdggt*(4d0*uh**6 + 4d0*th**5*uh + 38d0*th**4*uh2 +
37894  & 72d0*th**3*uh**3 +57d0*th2*uh**4+20d0*th*uh**5+th**6)/sh**4+
37895  & 2d0*redgtu*((th - uh)**2* (th**4 + 20d0*th**3*uh +
37896  & 30d0*th2*uh2 + 20d0*th*uh**3 + uh**4) +
37897  & sh2*(7d0*th**4 + 52d0*th**3*uh + 274d0*th2*uh2 +
37898  & 52d0*th*uh**3 + 7d0*uh**4))/(2d0*sh**4))/16d0
37899  facgg1=comfac*as**2*9d0/4d0*gst*faca
37900  facgg2=comfac*as**2*9d0/4d0*gsu*faca
37901  facgg3=comfac*as**2*9d0/4d0*gut
37902  ENDIF
37903  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 510
37904  nchn=nchn+1
37905  isig(nchn,1)=21
37906  isig(nchn,2)=21
37907  isig(nchn,3)=1
37908  sigh(nchn)=0.5d0*facgg1
37909  nchn=nchn+1
37910  isig(nchn,1)=21
37911  isig(nchn,2)=21
37912  isig(nchn,3)=2
37913  sigh(nchn)=0.5d0*facgg2
37914  nchn=nchn+1
37915  isig(nchn,1)=21
37916  isig(nchn,2)=21
37917  isig(nchn,3)=3
37918  sigh(nchn)=0.5d0*facgg3
37919  510 CONTINUE
37920 
37921  ELSEIF(isub.EQ.387) THEN
37922 C...q + qbar -> Q + Qbar
37923  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
37924  thq=-0.5d0*sh*(1d0-be34*cth)
37925  uhq=-0.5d0*sh*(1d0+be34*cth)
37926  facqqb=comfac*as**2*4d0/9d0*((thq**2+uhq**2)/sh2+
37927  & 2d0*sqmavg/sh)
37928  IF(itcm(5).GE.5) THEN
37929  IF(mint(55).EQ.5.OR.mint(55).EQ.6) THEN
37930  facqqb=facqqb*sh2*sqdqts
37931  ELSE
37932  facqqb=facqqb*sh2*sqdqqs
37933  ENDIF
37934  ENDIF
37935  IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqmavg,0d0)
37936  wid2=1d0
37937  IF(mint(55).EQ.6) wid2=wids(6,1)
37938  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
37939  facqqb=facqqb*wid2
37940  DO 520 i=mmina,mmaxa
37941  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37942  & kfac(1,i)*kfac(2,-i).EQ.0) goto 520
37943  nchn=nchn+1
37944  isig(nchn,1)=i
37945  isig(nchn,2)=-i
37946  isig(nchn,3)=1
37947  sigh(nchn)=facqqb
37948  520 CONTINUE
37949 
37950  ELSEIF(isub.EQ.388) THEN
37951 C...g + g -> Q + Qbar
37952  sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
37953  thq=-0.5d0*sh*(1d0-be34*cth)
37954  uhq=-0.5d0*sh*(1d0+be34*cth)
37955  thuhq=thq*uhq-sqmavg*sh
37956  IF(mstp(34).EQ.0) THEN
37957  facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
37958  facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
37959  ELSE
37960  facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37961  & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
37962  facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37963  & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
37964  ENDIF
37965  IF(itcm(5).GE.5) THEN
37966  IF(mint(55).EQ.5.OR.mint(55).EQ.6) THEN
37967  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redhgs+
37968  & 2.25d0*thq*uhq/sh2*sqdhgs
37969  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redhgs+
37970  & 2.25d0*thq*uhq/sh2*sqdhgs
37971  ELSE
37972  facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redlgs+
37973  & 2.25d0*thq*uhq/sh2*sqdlgs
37974  facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redlgs+
37975  & 2.25d0*thq*uhq/sh2*sqdlgs
37976  ENDIF
37977  ENDIF
37978  facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1
37979  facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2
37980  IF(mstp(35).GE.1) THEN
37981  fatre=pyhfth(sh,sqmavg,2d0/7d0)
37982  facqq1=facqq1*fatre
37983  facqq2=facqq2*fatre
37984  ENDIF
37985  wid2=1d0
37986  IF(mint(55).EQ.6) wid2=wids(6,1)
37987  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
37988  facqq1=facqq1*wid2
37989  facqq2=facqq2*wid2
37990  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 530
37991  nchn=nchn+1
37992  isig(nchn,1)=21
37993  isig(nchn,2)=21
37994  isig(nchn,3)=1
37995  sigh(nchn)=facqq1
37996  nchn=nchn+1
37997  isig(nchn,1)=21
37998  isig(nchn,2)=21
37999  isig(nchn,3)=2
38000  sigh(nchn)=facqq2
38001  530 CONTINUE
38002  ENDIF
38003  ENDIF
38004 
38005 CMRENNA--
38006 
38007  RETURN
38008  END
38009 
38010 C*********************************************************************
38011 
38012 C...PYSGEX
38013 C...Subprocess cross sections for assorted exotic processes,
38014 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
38015 C...Auxiliary to PYSIGH.
38016 
38017  SUBROUTINE pysgex(NCHN,SIGS)
38018 
38019 C...Double precision and integer declarations
38020  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38021  IMPLICIT INTEGER(i-n)
38022  INTEGER pyk,pychge,pycomp
38023 C...Parameter statement to help give large particle numbers.
38024  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
38025  &kexcit=4000000,kdimen=5000000)
38026 C...Commonblocks
38027  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38028  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38029  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
38030  common/pypars/mstp(200),parp(200),msti(200),pari(200)
38031  common/pyint1/mint(400),vint(400)
38032  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
38033  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
38034  common/pyint4/mwid(500),wids(500,5)
38035  common/pytcsm/itcm(0:99),rtcm(0:99)
38036  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
38037  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
38038  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
38039  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
38040  SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
38041  &/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
38042 C...Local arrays
38043  dimension wdtp(0:400),wdte(0:400,0:5)
38044 
38045 C...Differential cross section expressions.
38046 
38047  IF(isub.LE.160) THEN
38048  IF(isub.EQ.141) THEN
38049 C...f + fbar -> gamma*/Z0/Z'0
38050  sqmzp=pmas(32,1)**2
38051  mint(61)=2
38052  CALL pywidt(32,sh,wdtp,wdte)
38053  hp0=aem/3d0*sh
38054  hp1=aem/3d0*xwc*sh
38055  hp2=hp1
38056  hs=shr*vint(117)
38057  hsp=shr*wdtp(0)
38058  faczp=4d0*comfac*3d0
38059  DO 100 i=mmina,mmaxa
38060  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 100
38061  ei=kchg(iabs(i),1)/3d0
38062  ai=sign(1d0,ei)
38063  vi=ai-4d0*ei*xwv
38064  ia=iabs(i)
38065  IF(ia.LT.10) THEN
38066  IF(ia.LE.2) THEN
38067  vpi=paru(123-2*mod(iabs(i),2))
38068  api=paru(124-2*mod(iabs(i),2))
38069  ELSEIF(ia.LE.4) THEN
38070  vpi=parj(182-2*mod(iabs(i),2))
38071  api=parj(183-2*mod(iabs(i),2))
38072  ELSE
38073  vpi=parj(190-2*mod(iabs(i),2))
38074  api=parj(191-2*mod(iabs(i),2))
38075  ENDIF
38076  ELSE
38077  IF(ia.LE.12) THEN
38078  vpi=paru(127-2*mod(iabs(i),2))
38079  api=paru(128-2*mod(iabs(i),2))
38080  ELSEIF(ia.LE.14) THEN
38081  vpi=parj(186-2*mod(iabs(i),2))
38082  api=parj(187-2*mod(iabs(i),2))
38083  ELSE
38084  vpi=parj(194-2*mod(iabs(i),2))
38085  api=parj(195-2*mod(iabs(i),2))
38086  ENDIF
38087  ENDIF
38088  hi0=hp0
38089  IF(iabs(i).LE.10) hi0=hi0*faca/3d0
38090  hi1=hp1
38091  IF(iabs(i).LE.10) hi1=hi1*faca/3d0
38092  hi2=hp2
38093  IF(iabs(i).LE.10) hi2=hi2*faca/3d0
38094  nchn=nchn+1
38095  isig(nchn,1)=i
38096  isig(nchn,2)=-i
38097  isig(nchn,3)=1
38098 C...Special case: if only branching ratios known then use them.
38099  IF(mwid(32).EQ.2.AND.mstp(44).EQ.3) THEN
38100  hi=0d0
38101  IF(ia.LT.10) THEN
38102  hi=shr*wdtp(ia)*faca/9d0
38103  ELSEIF(ia.LT.20) THEN
38104  hi=shr*wdtp(ia-2)
38105  ENDIF
38106  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38107  sigh(nchn)=hi*faczp*hf/((sh-sqmzp)**2+hsp**2)
38108  ELSE
38109 C...Normal cross section.
38110  sigh(nchn)=faczp*(ei**2/sh2*hi0*hp0*vint(111)+ei*vi*
38111  & (1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*(hi0*hp1+hi1*hp0)*
38112  & vint(112)+ei*vpi*(1d0-sqmzp/sh)/((sh-sqmzp)**2+hsp**2)*
38113  & (hi0*hp2+hi2*hp0)*vint(113)+(vi**2+ai**2)/
38114  & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114)+(vi*vpi+ai*api)*
38115  & ((sh-sqmz)*(sh-sqmzp)+hs*hsp)/(((sh-sqmz)**2+hs**2)*
38116  & ((sh-sqmzp)**2+hsp**2))*(hi1*hp2+hi2*hp1)*vint(115)+
38117  & (vpi**2+api**2)/((sh-sqmzp)**2+hsp**2)*hi2*hp2*vint(116))
38118  ENDIF
38119  100 CONTINUE
38120 
38121  ELSEIF(isub.EQ.142) THEN
38122 C...f + fbar' -> W'+/-
38123  sqmwp=pmas(34,1)**2
38124  CALL pywidt(34,sh,wdtp,wdte)
38125  hs=shr*wdtp(0)
38126  facbw=4d0*comfac/((sh-sqmwp)**2+hs**2)*3d0
38127  hp=aem/(24d0*xw)*sh
38128  DO 120 i=mmin1,mmax1
38129  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 120
38130  ia=iabs(i)
38131  DO 110 j=mmin2,mmax2
38132  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 110
38133  ja=iabs(j)
38134  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 110
38135  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
38136  & goto 110
38137  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
38138 C...Special case: if only branching ratios known then use them.
38139  IF(mwid(34).EQ.2) THEN
38140  hi=0d0
38141  DO 105 idc=mdcy(34,2),mdcy(34,2)+mdcy(34,3)-1
38142  IF((ia.EQ.iabs(kfdp(idc,1)).AND.ja.EQ.
38143  & iabs(kfdp(idc,2))).OR.(ia.EQ.iabs(kfdp(idc,2))
38144  & .AND.ja.EQ.iabs(kfdp(idc,1))))
38145  & hi=shr*wdtp(idc+1-mdcy(34,2))
38146  105 CONTINUE
38147  IF(ia.LT.10) hi=hi*faca/9d0
38148  ELSE
38149 C...Normal cross section.
38150  hi=hp*(paru(133)**2+paru(134)**2)
38151  IF(ia.LE.10) hi=hp*(paru(131)**2+paru(132)**2)*
38152  & vckm((ia+1)/2,(ja+1)/2)*faca/3d0
38153  ENDIF
38154  nchn=nchn+1
38155  isig(nchn,1)=i
38156  isig(nchn,2)=j
38157  isig(nchn,3)=1
38158  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
38159  sigh(nchn)=hi*facbw*hf
38160  110 CONTINUE
38161  120 CONTINUE
38162 
38163  ELSEIF(isub.EQ.144) THEN
38164 C...f + fbar' -> R
38165  sqmr=pmas(41,1)**2
38166  CALL pywidt(41,sh,wdtp,wdte)
38167  hs=shr*wdtp(0)
38168  facbw=4d0*comfac/((sh-sqmr)**2+hs**2)*3d0
38169  hp=aem/(12d0*xw)*sh
38170  DO 140 i=mmin1,mmax1
38171  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 140
38172  ia=iabs(i)
38173  DO 130 j=mmin2,mmax2
38174  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 130
38175  ja=iabs(j)
38176  IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) goto 130
38177  hi=hp
38178  IF(ia.LE.10) hi=hi*faca/3d0
38179  hf=shr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))
38180  nchn=nchn+1
38181  isig(nchn,1)=i
38182  isig(nchn,2)=j
38183  isig(nchn,3)=1
38184  sigh(nchn)=hi*facbw*hf
38185  130 CONTINUE
38186  140 CONTINUE
38187 
38188  ELSEIF(isub.EQ.145) THEN
38189 C...q + l -> LQ (leptoquark)
38190  sqmlq=pmas(42,1)**2
38191  CALL pywidt(42,sh,wdtp,wdte)
38192  hs=shr*wdtp(0)
38193  facbw=4d0*comfac/((sh-sqmlq)**2+hs**2)
38194  IF(abs(shr-pmas(42,1)).GT.parp(48)*pmas(42,2)) facbw=0d0
38195  hp=aem/4d0*sh
38196  kflqq=kfdp(mdcy(42,2),1)
38197  kflql=kfdp(mdcy(42,2),2)
38198  DO 160 i=mmin1,mmax1
38199  IF(kfac(1,i).EQ.0) goto 160
38200  ia=iabs(i)
38201  IF(ia.NE.kflqq.AND.ia.NE.iabs(kflql)) goto 160
38202  DO 150 j=mmin2,mmax2
38203  IF(kfac(2,j).EQ.0) goto 150
38204  ja=iabs(j)
38205  IF(ja.NE.kflqq.AND.ja.NE.iabs(kflql)) goto 150
38206  IF(i*j.NE.kflqq*kflql) goto 150
38207  IF(ja.EQ.ia) goto 150
38208  IF(ia.EQ.kflqq) kchlq=isign(1,i)
38209  IF(ja.EQ.kflqq) kchlq=isign(1,j)
38210  hi=hp*paru(151)
38211  hf=shr*(wdte(0,1)+wdte(0,(5-kchlq)/2)+wdte(0,4))
38212  nchn=nchn+1
38213  isig(nchn,1)=i
38214  isig(nchn,2)=j
38215  isig(nchn,3)=1
38216  sigh(nchn)=hi*facbw*hf
38217  150 CONTINUE
38218  160 CONTINUE
38219 
38220  ELSEIF(isub.EQ.146) THEN
38221 C...e + gamma* -> e* (excited lepton)
38222  kfqstr=kfpr(isub,1)
38223  kcqstr=pycomp(kfqstr)
38224  kfqexc=mod(kfqstr,kexcit)
38225  CALL pywidt(kfqstr,sh,wdtp,wdte)
38226  hs=shr*wdtp(0)
38227  facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
38228  qf=-rtcm(43)/2d0-rtcm(44)/2d0
38229  facbw=facbw*aem*qf**2*sh/rtcm(41)**2
38230  IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
38231  & facbw=0d0
38232  hp=sh
38233  DO 180 i=-kfqexc,kfqexc,2*kfqexc
38234  DO 170 isde=1,2
38235  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 170
38236  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 170
38237  hi=hp
38238  IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38239  IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
38240  nchn=nchn+1
38241  isig(nchn,isde)=i
38242  isig(nchn,3-isde)=22
38243  isig(nchn,3)=1
38244  sigh(nchn)=hi*facbw*hf
38245  170 CONTINUE
38246  180 CONTINUE
38247 
38248  ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
38249 C...d + g -> d* and u + g -> u* (excited quarks)
38250  kfqstr=kfpr(isub,1)
38251  kcqstr=pycomp(kfqstr)
38252  kfqexc=mod(kfqstr,kexcit)
38253  CALL pywidt(kfqstr,sh,wdtp,wdte)
38254  hs=shr*wdtp(0)
38255  facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
38256  facbw=facbw*as*rtcm(45)**2*sh/(3d0*rtcm(41)**2)
38257  IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
38258  & facbw=0d0
38259  hp=sh
38260  DO 200 i=-kfqexc,kfqexc,2*kfqexc
38261  DO 190 isde=1,2
38262  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 190
38263  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 190
38264  hi=hp
38265  IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38266  IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
38267  nchn=nchn+1
38268  isig(nchn,isde)=i
38269  isig(nchn,3-isde)=21
38270  isig(nchn,3)=1
38271  sigh(nchn)=hi*facbw*hf
38272  190 CONTINUE
38273  200 CONTINUE
38274  ENDIF
38275 
38276  ELSEIF(isub.LE.190) THEN
38277  IF(isub.EQ.162) THEN
38278 C...q + g -> LQ + lbar; LQ=leptoquark
38279  sqmlq=pmas(42,1)**2
38280  faclq=comfac*faca*paru(151)*(as*aem/6d0)*(-th/sh)*
38281  & (uh2+sqmlq**2)/(uh-sqmlq)**2
38282  kflqq=kfdp(mdcy(42,2),1)
38283  DO 220 i=mmina,mmaxa
38284  IF(iabs(i).NE.kflqq) goto 220
38285  kchlq=isign(1,i)
38286  DO 210 isde=1,2
38287  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 210
38288  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 210
38289  nchn=nchn+1
38290  isig(nchn,isde)=i
38291  isig(nchn,3-isde)=21
38292  isig(nchn,3)=1
38293  sigh(nchn)=faclq*wids(42,(5-kchlq)/2)
38294  210 CONTINUE
38295  220 CONTINUE
38296 
38297  ELSEIF(isub.EQ.163) THEN
38298 C...g + g -> LQ + LQbar; LQ=leptoquark
38299  sqmlq=pmas(42,1)**2
38300  faclq=comfac*faca*wids(42,1)*(as**2/2d0)*
38301  & (7d0/48d0+3d0*(uh-th)**2/(16d0*sh2))*(1d0+2d0*sqmlq*th/
38302  & (th-sqmlq)**2+2d0*sqmlq*uh/(uh-sqmlq)**2+4d0*sqmlq**2/
38303  & ((th-sqmlq)*(uh-sqmlq)))
38304  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 230
38305  nchn=nchn+1
38306  isig(nchn,1)=21
38307  isig(nchn,2)=21
38308 C...Since don't know proper colour flow, randomize between alternatives
38309  isig(nchn,3)=int(1.5d0+pyr(0))
38310  sigh(nchn)=faclq
38311  230 CONTINUE
38312 
38313  ELSEIF(isub.EQ.164) THEN
38314 C...q + qbar -> LQ + LQbar; LQ=leptoquark
38315  delta=0.25d0*(sqm3-sqm4)**2/sh
38316  sqmlq=0.5d0*(sqm3+sqm4)-delta
38317  th=th-delta
38318  uh=uh-delta
38319 C SQMLQ=PMAS(42,1)**2
38320  faclqa=comfac*wids(42,1)*(as**2/9d0)*
38321  & (sh*(sh-4d0*sqmlq)-(uh-th)**2)/sh2
38322  faclqs=comfac*wids(42,1)*((paru(151)**2*aem**2/8d0)*
38323  & (-sh*th-(sqmlq-th)**2)/th2+(paru(151)*aem*as/18d0)*
38324  & ((sqmlq-th)*(uh-th)+sh*(sqmlq+th))/(sh*th))
38325  kflqq=kfdp(mdcy(42,2),1)
38326  DO 240 i=mmina,mmaxa
38327  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
38328  & kfac(1,i)*kfac(2,-i).EQ.0) goto 240
38329  nchn=nchn+1
38330  isig(nchn,1)=i
38331  isig(nchn,2)=-i
38332  isig(nchn,3)=1
38333  sigh(nchn)=faclqa
38334  IF(iabs(i).EQ.kflqq) sigh(nchn)=faclqa+faclqs
38335  240 CONTINUE
38336 
38337  ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
38338 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
38339  kfqstr=kfpr(isub,2)
38340  kcqstr=pycomp(kfqstr)
38341  kfqexc=mod(kfqstr,kexcit)
38342  facqsa=comfac*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)
38343  facqsb=comfac*0.25d0*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)*
38344  & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
38345 C...Propagators: as simulated in PYOFSH and as desired
38346  gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
38347  hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
38348  CALL pywidt(kfqstr,sqm4,wdtp,wdte)
38349  gmmqc=sqrt(sqm4)*wdtp(0)
38350  hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
38351  facqsa=facqsa*hbw4c/hbw4
38352  facqsb=facqsb*hbw4c/hbw4
38353 C...Branching ratios.
38354  brpos=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
38355  brneg=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
38356  DO 260 i=mmin1,mmax1
38357  ia=iabs(i)
38358  IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) goto 260
38359  DO 250 j=mmin2,mmax2
38360  ja=iabs(j)
38361  IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) goto 250
38362  IF(ia.EQ.kfqexc.AND.i.EQ.j) THEN
38363  nchn=nchn+1
38364  isig(nchn,1)=i
38365  isig(nchn,2)=j
38366  isig(nchn,3)=1
38367  IF(i.GT.0) sigh(nchn)=(4d0/3d0)*facqsa*brpos
38368  IF(i.LT.0) sigh(nchn)=(4d0/3d0)*facqsa*brneg
38369  nchn=nchn+1
38370  isig(nchn,1)=i
38371  isig(nchn,2)=j
38372  isig(nchn,3)=2
38373  IF(j.GT.0) sigh(nchn)=(4d0/3d0)*facqsa*brpos
38374  IF(j.LT.0) sigh(nchn)=(4d0/3d0)*facqsa*brneg
38375  ELSEIF((ia.EQ.kfqexc.OR.ja.EQ.kfqexc).AND.i*j.GT.0) THEN
38376  nchn=nchn+1
38377  isig(nchn,1)=i
38378  isig(nchn,2)=j
38379  isig(nchn,3)=1
38380  IF(ja.EQ.kfqexc) isig(nchn,3)=2
38381  IF(isig(nchn,isig(nchn,3)).GT.0) sigh(nchn)=facqsa*brpos
38382  IF(isig(nchn,isig(nchn,3)).LT.0) sigh(nchn)=facqsa*brneg
38383  ELSEIF(ia.EQ.kfqexc.AND.i.EQ.-j) THEN
38384  nchn=nchn+1
38385  isig(nchn,1)=i
38386  isig(nchn,2)=j
38387  isig(nchn,3)=1
38388  IF(i.GT.0) sigh(nchn)=(8d0/3d0)*facqsb*brpos
38389  IF(i.LT.0) sigh(nchn)=(8d0/3d0)*facqsb*brneg
38390  nchn=nchn+1
38391  isig(nchn,1)=i
38392  isig(nchn,2)=j
38393  isig(nchn,3)=2
38394  IF(j.GT.0) sigh(nchn)=(8d0/3d0)*facqsb*brpos
38395  IF(j.LT.0) sigh(nchn)=(8d0/3d0)*facqsb*brneg
38396  ELSEIF(i.EQ.-j) THEN
38397  nchn=nchn+1
38398  isig(nchn,1)=i
38399  isig(nchn,2)=j
38400  isig(nchn,3)=1
38401  IF(i.GT.0) sigh(nchn)=facqsb*brpos
38402  IF(i.LT.0) sigh(nchn)=facqsb*brneg
38403  nchn=nchn+1
38404  isig(nchn,1)=i
38405  isig(nchn,2)=j
38406  isig(nchn,3)=2
38407  IF(j.GT.0) sigh(nchn)=facqsb*brpos
38408  IF(j.LT.0) sigh(nchn)=facqsb*brneg
38409  ELSEIF(ia.EQ.kfqexc.OR.ja.EQ.kfqexc) THEN
38410  nchn=nchn+1
38411  isig(nchn,1)=i
38412  isig(nchn,2)=j
38413  isig(nchn,3)=1
38414  IF(ja.EQ.kfqexc) isig(nchn,3)=2
38415  IF(isig(nchn,isig(nchn,3)).GT.0) sigh(nchn)=facqsb*brpos
38416  IF(isig(nchn,isig(nchn,3)).LT.0) sigh(nchn)=facqsb*brneg
38417  ENDIF
38418  250 CONTINUE
38419  260 CONTINUE
38420 
38421  ELSEIF(isub.EQ.169) THEN
38422 C...q + qbar -> e + e* (excited lepton)
38423  kfqstr=kfpr(isub,2)
38424  kcqstr=pycomp(kfqstr)
38425  kfqexc=mod(kfqstr,kexcit)
38426  facqsb=(comfac/12d0)*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)*
38427  & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
38428 C...Propagators: as simulated in PYOFSH and as desired
38429  gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
38430  hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
38431  CALL pywidt(kfqstr,sqm4,wdtp,wdte)
38432  gmmqc=sqrt(sqm4)*wdtp(0)
38433  hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
38434  facqsb=facqsb*hbw4c/hbw4
38435 C...Branching ratios.
38436  brpos=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
38437  brneg=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
38438  DO 270 i=mmin1,mmax1
38439  ia=iabs(i)
38440  IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) goto 270
38441  j=-i
38442  ja=iabs(j)
38443  IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) goto 270
38444  nchn=nchn+1
38445  isig(nchn,1)=i
38446  isig(nchn,2)=j
38447  isig(nchn,3)=1
38448  IF(i.GT.0) sigh(nchn)=facqsb*brpos
38449  IF(i.LT.0) sigh(nchn)=facqsb*brneg
38450  nchn=nchn+1
38451  isig(nchn,1)=i
38452  isig(nchn,2)=j
38453  isig(nchn,3)=2
38454  IF(j.GT.0) sigh(nchn)=facqsb*brpos
38455  IF(j.LT.0) sigh(nchn)=facqsb*brneg
38456  270 CONTINUE
38457  ENDIF
38458 
38459  ELSEIF(isub.LE.360) THEN
38460  IF(isub.EQ.341.OR.isub.EQ.342) THEN
38461 C...l + l -> H_L++/-- or H_R++/--.
38462  kfres=kfpr(isub,1)
38463  kfrec=pycomp(kfres)
38464  CALL pywidt(kfres,sh,wdtp,wdte)
38465  hs=shr*wdtp(0)
38466  facbw=8d0*comfac/((sh-pmas(kfrec,1)**2)**2+hs**2)
38467  DO 290 i=mmin1,mmax1
38468  ia=iabs(i)
38469  IF((ia.NE.11.AND.ia.NE.13.AND.ia.NE.15).OR.kfac(1,i).EQ.0)
38470  & goto 290
38471  DO 280 j=mmin2,mmax2
38472  ja=iabs(j)
38473  IF((ja.NE.11.AND.ja.NE.13.AND.ja.NE.15).OR.kfac(2,j).EQ.0)
38474  & goto 280
38475  IF(i*j.LT.0) goto 280
38476  kchh=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
38477  nchn=nchn+1
38478  isig(nchn,1)=i
38479  isig(nchn,2)=j
38480  isig(nchn,3)=1
38481  hi=sh*parp(181+3*((ia-11)/2)+(ja-11)/2)**2/(8d0*paru(1))
38482  hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
38483  sigh(nchn)=hi*facbw*hf
38484  280 CONTINUE
38485  290 CONTINUE
38486 
38487  ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
38488 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
38489  kfres=kfpr(isub,1)
38490  kfrec=pycomp(kfres)
38491 C...Propagators: as simulated in PYOFSH and as desired
38492  hbw3=pmas(kfrec,1)*pmas(kfrec,2)/((sqm3-pmas(kfrec,1)**2)**2+
38493  & (pmas(kfrec,1)*pmas(kfrec,2))**2)
38494  CALL pywidt(kfres,sqm3,wdtp,wdte)
38495  gmmc=sqrt(sqm3)*wdtp(0)
38496  hbw3c=gmmc/((sqm3-pmas(kfrec,1)**2)**2+gmmc**2)
38497  fhcc=comfac*aem*hbw3c/hbw3
38498  DO 310 i=mmina,mmaxa
38499  ia=iabs(i)
38500  IF(ia.NE.11.AND.ia.NE.13.AND.ia.NE.15) goto 310
38501  sqml=pmas(ia,1)**2
38502  j=isign(kfpr(isub,2),-i)
38503  kchh=isign(2,kchg(ia,1)*isign(1,i))
38504  widsc=(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))/wdtp(0)
38505  smm1=8d0*(sh+th-sqm3)*(sh+th-2d0*sqm3-sqml-sqm4)/
38506  & (uh-sqm3)**2
38507  smm2=2d0*((2d0*sqm3-3d0*sqml)*sqm4+(sqml-2d0*sqm4)*th-
38508  & (th-sqm4)*sh)/(th-sqm4)**2
38509  smm3=2d0*((2d0*sqm3-3d0*sqm4+th)*sqml-(2d0*sqml-sqm4+th)*
38510  & sh)/(sh-sqml)**2
38511  smm12=4d0*((2d0*sqml-sqm4-2d0*sqm3+th)*sh+(th-3d0*sqm3-
38512  & 3d0*sqm4)*th+(2d0*sqm3-2d0*sqml+3d0*sqm4)*sqm3)/
38513  & ((uh-sqm3)*(th-sqm4))
38514  smm13=-4d0*((th+sqml-2d0*sqm4)*th-(sqm3+3d0*sqml-2d0*sqm4)*
38515  & sqm3+(sqm3+3d0*sqml+th)*sh-(th-sqm3+sh)**2)/
38516  & ((uh-sqm3)*(sh-sqml))
38517  smm23=-4d0*((sqml-sqm4+sqm3)*th-sqm3**2+sqm3*(sqml+sqm4)-
38518  & 3d0*sqml*sqm4-(sqml-sqm4-sqm3+th)*sh)/
38519  & ((sh-sqml)*(th-sqm4))
38520  smm=(sh/(sh-sqml))**2*(smm1+smm2+smm3+smm12+smm13+smm23)*
38521  & parp(181+3*((ia-11)/2)+(iabs(j)-11)/2)**2/(4d0*paru(1))
38522  DO 300 isde=1,2
38523  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 300
38524  IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 300
38525  nchn=nchn+1
38526  isig(nchn,isde)=i
38527  isig(nchn,3-isde)=22
38528  isig(nchn,3)=0
38529  sigh(nchn)=fhcc*smm*widsc
38530  300 CONTINUE
38531  310 CONTINUE
38532 
38533  ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
38534 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
38535  kfres=kfpr(isub,1)
38536  kfrec=pycomp(kfres)
38537  sqmh=pmas(kfrec,1)**2
38538  gmmh=pmas(kfrec,1)*pmas(kfrec,2)
38539 C...Propagators: H++/-- as simulated in PYOFSH and as desired
38540  hbw3=gmmh/((sqm3-sqmh)**2+gmmh**2)
38541  CALL pywidt(kfres,sqm3,wdtp,wdte)
38542  gmmh3=sqrt(sqm3)*wdtp(0)
38543  hbw3c=gmmh3/((sqm3-sqmh)**2+gmmh3**2)
38544  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
38545  CALL pywidt(kfres,sqm4,wdtp,wdte)
38546  gmmh4=sqrt(sqm4)*wdtp(0)
38547  hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
38548 C...Kinematical and coupling functions
38549  fachh=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*(th*uh-sqm3*sqm4)
38550  xwhh=(1d0-2d0*xwv)/(8d0*xwv*(1d0-xwv))
38551 C...Loop over allowed flavours
38552  DO 320 i=mmina,mmaxa
38553  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 320
38554  ei=kchg(iabs(i),1)/3d0
38555  ai=sign(1d0,ei+0.1d0)
38556  vi=ai-4d0*ei*xwv
38557  fcoi=1d0
38558  IF(iabs(i).LE.10) fcoi=faca/3d0
38559  IF(isub.EQ.349) THEN
38560  hbwz=1d0/((sh-sqmz)**2+gmmz**2)
38561  IF(iabs(i).LT.10) THEN
38562  dsighh=8d0*aem**2*(ei**2/sh2+
38563  & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
38564  & (vi**2+ai**2)*xwhh**2*hbwz)
38565  ELSE
38566  iaoff=181+3*((iabs(i)-11)/2)
38567  hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
38568  & (4d0*paru(1))
38569  dsighh=8d0*aem**2*(ei**2/sh2+
38570  & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
38571  & (vi**2+ai**2)*xwhh**2*hbwz)+
38572  & 8d0*aem*(ei*hsum/(sh*th)+
38573  & (vi+ai)*xwhh*hsum*(sh-sqmz)*hbwz/th)+
38574  & 4d0*hsum**2/th2
38575  ENDIF
38576  ELSE
38577  IF(iabs(i).LT.10) THEN
38578  dsighh=8d0*aem**2*ei**2/sh2
38579  ELSE
38580  iaoff=181+3*((iabs(i)-11)/2)
38581  hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
38582  & (4d0*paru(1))
38583  dsighh=8d0*aem**2*ei**2/sh2+8d0*aem*ei*hsum/(sh*th)+
38584  & 4d0*hsum**2/th2
38585  ENDIF
38586  ENDIF
38587  nchn=nchn+1
38588  isig(nchn,1)=i
38589  isig(nchn,2)=-i
38590  isig(nchn,3)=1
38591  sigh(nchn)=fachh*fcoi*dsighh
38592  320 CONTINUE
38593 
38594  ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
38595 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
38596  kfres=kfpr(isub,1)
38597  kfrec=pycomp(kfres)
38598  sqmh=pmas(kfrec,1)**2
38599  IF(isub.EQ.351) facnor=parp(190)**8*parp(192)**2
38600  IF(isub.EQ.352) facnor=parp(191)**6*2d0*
38601  & pmas(pycomp(9900024),1)**2
38602  facww=comfac*facnor*taup*vint(2)*vint(219)
38603  facprt=1d0/((vint(204)**2-vint(215))*
38604  & (vint(209)**2-vint(216)))
38605  facpru=1d0/((vint(204)**2+2d0*vint(217))*
38606  & (vint(209)**2+2d0*vint(218)))
38607  CALL pywidt(kfres,sh,wdtp,wdte)
38608  hs=shr*wdtp(0)
38609  facbw=(1d0/paru(1))*vint(2)/((sh-sqmh)**2+hs**2)
38610  IF(abs(shr-pmas(kfrec,1)).GT.parp(48)*pmas(kfrec,2))
38611  & facbw=0d0
38612  DO 340 i=mmin1,mmax1
38613  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 340
38614  IF(isub.EQ.352.AND.iabs(i).GT.10) goto 340
38615  kchwi=(1-2*mod(iabs(i),2))*isign(1,i)
38616  DO 330 j=mmin2,mmax2
38617  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 330
38618  IF(isub.EQ.352.AND.iabs(j).GT.10) goto 330
38619  kchwj=(1-2*mod(iabs(j),2))*isign(1,j)
38620  kchh=kchwi+kchwj
38621  IF(iabs(kchh).NE.2) goto 330
38622  faclr=vint(180+i)*vint(180+j)
38623  hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
38624  IF(i.EQ.j.AND.iabs(i).GT.10) THEN
38625  facprp=0.5d0*(facprt+facpru)**2
38626  ELSE
38627  facprp=facprt**2
38628  ENDIF
38629  nchn=nchn+1
38630  isig(nchn,1)=i
38631  isig(nchn,2)=j
38632  isig(nchn,3)=1
38633  sigh(nchn)=faclr*facww*facprp*facbw*hf
38634  330 CONTINUE
38635  340 CONTINUE
38636 
38637  ELSEIF(isub.EQ.353) THEN
38638 C...f + fbar -> Z_R0
38639  sqmzr=pmas(pycomp(kfpr(isub,1)),1)**2
38640  CALL pywidt(kfpr(isub,1),sh,wdtp,wdte)
38641  hs=shr*wdtp(0)
38642  facbw=4d0*comfac/((sh-sqmzr)**2+hs**2)*3d0
38643  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38644  hp=(aem/(3d0*(1d0-2d0*xw)))*xwc*sh
38645  DO 350 i=mmina,mmaxa
38646  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 350
38647  IF(iabs(i).LE.8) THEN
38648  ei=kchg(iabs(i),1)/3d0
38649  ai=sign(1d0,ei+0.1d0)*(1d0-2d0*xw)
38650  vi=sign(1d0,ei+0.1d0)-4d0*ei*xw
38651  ELSE
38652  ai=-(1d0-2d0*xw)
38653  vi=-1d0+4d0*xw
38654  ENDIF
38655  hi=hp*(vi**2+ai**2)
38656  IF(iabs(i).LE.10) hi=hi*faca/3d0
38657  nchn=nchn+1
38658  isig(nchn,1)=i
38659  isig(nchn,2)=-i
38660  isig(nchn,3)=1
38661  sigh(nchn)=hi*facbw*hf
38662  350 CONTINUE
38663 
38664  ELSEIF(isub.EQ.354) THEN
38665 C...f + fbar' -> W_R+/-
38666  sqmwr=pmas(pycomp(kfpr(isub,1)),1)**2
38667  CALL pywidt(kfpr(isub,1),sh,wdtp,wdte)
38668  hs=shr*wdtp(0)
38669  facbw=4d0*comfac/((sh-sqmwr)**2+hs**2)*3d0
38670  hp=aem/(24d0*xw)*sh
38671  DO 370 i=mmin1,mmax1
38672  IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 370
38673  ia=iabs(i)
38674  DO 360 j=mmin2,mmax2
38675  IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 360
38676  ja=iabs(j)
38677  IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 360
38678  IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
38679  & goto 360
38680  kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
38681  hi=hp*2d0
38682  IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
38683  nchn=nchn+1
38684  isig(nchn,1)=i
38685  isig(nchn,2)=j
38686  isig(nchn,3)=1
38687  hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
38688  sigh(nchn)=hi*facbw*hf
38689  360 CONTINUE
38690  370 CONTINUE
38691  ENDIF
38692 
38693  ELSEIF(isub.LE.400) THEN
38694  IF(isub.EQ.391) THEN
38695 C...f + fbar -> G*.
38696  kfgstr=kfpr(isub,1)
38697  kcgstr=pycomp(kfgstr)
38698  CALL pywidt(kfgstr,sh,wdtp,wdte)
38699  hs=shr*wdtp(0)
38700  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38701  facg=comfac*parp(50)**2/(16d0*paru(1))*sh*hf/
38702  & ((sh-pmas(kcgstr,1)**2)**2+hs**2)
38703 C...Modify cross section in wings of peak.
38704  facg = facg * sh**2 / pmas(kcgstr,1)**4
38705  DO 380 i=mmina,mmaxa
38706  IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 380
38707  hi=1d0
38708  IF(iabs(i).LE.10) hi=hi*faca/3d0
38709  nchn=nchn+1
38710  isig(nchn,1)=i
38711  isig(nchn,2)=-i
38712  isig(nchn,3)=1
38713  sigh(nchn)=facg*hi
38714  380 CONTINUE
38715 
38716  ELSEIF(isub.EQ.392) THEN
38717 C...g + g -> G*.
38718  kfgstr=kfpr(isub,1)
38719  kcgstr=pycomp(kfgstr)
38720  CALL pywidt(kfgstr,sh,wdtp,wdte)
38721  hs=shr*wdtp(0)
38722  hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38723  facg=comfac*parp(50)**2/(32d0*paru(1))*sh*hf/
38724  & ((sh-pmas(kcgstr,1)**2)**2+hs**2)
38725 C...Modify cross section in wings of peak.
38726  facg = facg * sh**2 / pmas(kcgstr,1)**4
38727  IF(kfac(1,21)*kfac(2,21).EQ.0) goto 390
38728  nchn=nchn+1
38729  isig(nchn,1)=21
38730  isig(nchn,2)=21
38731  isig(nchn,3)=1
38732  sigh(nchn)=facg
38733  390 CONTINUE
38734 
38735  ELSEIF(isub.EQ.393) THEN
38736 C...q + qbar -> g + G*.
38737  kfgstr=kfpr(isub,2)
38738  kcgstr=pycomp(kfgstr)
38739  facg=comfac*parp(50)**2*as*sh/(72d0*paru(1)*sqm4)*
38740  & (4d0*(th2+uh2)/sh2+9d0*(th+uh)/sh+(th2/uh+uh2/th)/sh+
38741  & 3d0*(4d0+th/uh+uh/th)+4d0*(sh/uh+sh/th)+
38742  & 2d0*sh2/(th*uh))
38743 C...Propagators: as simulated in PYOFSH and as desired
38744  gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
38745  hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
38746  CALL pywidt(kfgstr,sqm4,wdtp,wdte)
38747  hs=sqrt(sqm4)*wdtp(0)
38748  hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38749  hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
38750  facg=facg*hbw4c/hbw4
38751  DO 400 i=mmina,mmaxa
38752  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
38753  & kfac(1,i)*kfac(2,-i).EQ.0) goto 400
38754  nchn=nchn+1
38755  isig(nchn,1)=i
38756  isig(nchn,2)=-i
38757  isig(nchn,3)=1
38758  sigh(nchn)=facg
38759  400 CONTINUE
38760 
38761  ELSEIF(isub.EQ.394) THEN
38762 C...q + g -> q + G*.
38763  kfgstr=kfpr(isub,2)
38764  kcgstr=pycomp(kfgstr)
38765  facg=-comfac*parp(50)**2*as*sh/(192d0*paru(1)*sqm4)*
38766  & (4d0*(sh2+uh2)/(th*sh)+9d0*(sh+uh)/sh+sh/uh+uh2/sh2+
38767  & 3d0*th*(4d0+sh/uh+uh/sh)/sh+4d0*th2*(1d0/uh+1d0/sh)/sh+
38768  & 2d0*th2*th/(uh*sh2))
38769 C...Propagators: as simulated in PYOFSH and as desired
38770  gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
38771  hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
38772  CALL pywidt(kfgstr,sqm4,wdtp,wdte)
38773  hs=sqrt(sqm4)*wdtp(0)
38774  hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38775  hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
38776  facg=facg*hbw4c/hbw4
38777  DO 420 i=mmina,mmaxa
38778  IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 420
38779  DO 410 isde=1,2
38780  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 410
38781  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 410
38782  nchn=nchn+1
38783  isig(nchn,isde)=i
38784  isig(nchn,3-isde)=21
38785  isig(nchn,3)=1
38786  sigh(nchn)=facg
38787  410 CONTINUE
38788  420 CONTINUE
38789 
38790  ELSEIF(isub.EQ.395) THEN
38791 C...g + g -> g + G*.
38792  kfgstr=kfpr(isub,2)
38793  kcgstr=pycomp(kfgstr)
38794  facg=comfac*3d0*parp(50)**2*as*sh/(32d0*paru(1)*sqm4)*
38795  & ((th2+th*uh+uh2)**2/(sh2*th*uh)+2d0*(th2/uh+uh2/th)/sh+
38796  & 3d0*(th/uh+uh/th)+2d0*(sh/uh+sh/th)+sh2/(th*uh))
38797 C...Propagators: as simulated in PYOFSH and as desired
38798  gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
38799  hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
38800  CALL pywidt(kfgstr,sqm4,wdtp,wdte)
38801  hs=sqrt(sqm4)*wdtp(0)
38802  hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38803  hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
38804  facg=facg*hbw4c/hbw4
38805  IF(kfac(1,21)*kfac(2,21).NE.0) THEN
38806  nchn=nchn+1
38807  isig(nchn,1)=21
38808  isig(nchn,2)=21
38809  isig(nchn,3)=1
38810  sigh(nchn)=facg
38811  ENDIF
38812  ENDIF
38813  ELSEIF(isub.LE.500) THEN
38814  IF(isubsv.EQ.481) isub=482
38815 c... GENERIC 2->(1)->2
38816  IF(isub.EQ.482) THEN
38817  kfres=9900001
38818  kcres=pycomp(kfres)
38819  IF(kcres.EQ.0) RETURN
38820  idcy=mdcy(kcres,2)
38821  kcol=kchg(kcres,2)
38822  kcem=kchg(kcres,1)
38823  fact=comfac
38824  kcf1=pycomp(kfpr(isub,1))
38825  kcf2=pycomp(kfpr(isub,2))
38826  IF(isubsv.EQ.481) THEN
38827  sqmzr=pmas(kcres,1)**2
38828  CALL pywidt(kfres,sh,wdtp,wdte)
38829  hs=shr*wdtp(0)
38830  facbw=sh2/((sh-sqmzr)**2+hs**2)
38831  fact=fact*facbw
38832  ELSE
38833  sqmh=pmas(kcf1,1)**2
38834  gmmh=pmas(kcf1,1)*pmas(kcf1,2)
38835 C...Propagators: as simulated in PYOFSH and as desired
38836  hbw3=gmmh/((sqm3-sqmh)**2+gmmh**2)
38837  CALL pywidt(kfpr(isub,1),sqm3,wdtp,wdte)
38838  gmmh3=sqrt(sqm3)*wdtp(0)
38839  hbw3c=gmmh3/((sqm3-sqmh)**2+gmmh3**2)
38840  sqmh=pmas(kcf2,1)**2
38841  gmmh=pmas(kcf2,1)*pmas(kcf2,2)
38842  hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
38843  CALL pywidt(kfpr(isub,2),sqm4,wdtp,wdte)
38844  gmmh4=sqrt(sqm4)*wdtp(0)
38845  hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
38846  fact=fact*(hbw3c/hbw3)*(hbw4c/hbw4)
38847  ENDIF
38848 
38849  kci1=abs(pycomp(kfdp(idcy,1)))
38850  kci2=abs(pycomp(kfdp(idcy,2)))
38851  jcol1=sign(kchg(kcf1,2),kfpr(isub,1))
38852  jcol2=sign(kchg(kcf2,2),kfpr(isub,2))
38853  IF(kcol.EQ.0) THEN
38854  ncol=1
38855  ELSEIF(kci1.EQ.21.AND.kci2.EQ.21.AND.kcol.EQ.2) THEN
38856  IF(jcol1.EQ.2.AND.jcol2.EQ.2) THEN
38857  ncol=3
38858  ELSE
38859  ncol=2
38860  ENDIF
38861  ELSEIF(kcol.EQ.-1.OR.kcol.EQ.1) THEN
38862  ncol=2
38863  ELSEIF(kci1.EQ.21.AND.kci2.EQ.21.AND.jcol1.EQ.0.AND.
38864  $ jcol2.EQ.0) THEN
38865  ncol=1
38866  ELSEIF(kcol.EQ.2.AND.((jcol1.EQ.0.AND.jcol2.EQ.2).OR.
38867  $ (jcol1.EQ.2.AND.jcol2.EQ.0))) THEN
38868  ncol=1
38869  ELSE
38870  ncol=2
38871  ENDIF
38872  DO 440 i=mmin1,mmax1
38873  IF(kfac(1,i).EQ.0) goto 440
38874  ip=i
38875  IF(ip.EQ.0) ip=21
38876  ia=abs(ip)
38877  DO 430 j=mmin2,mmax2
38878  IF(kfac(2,j).EQ.0) goto 430
38879  jp=j
38880  IF(jp.EQ.0) jp=21
38881  ja=abs(jp)
38882  IF((ia.EQ.kci1.AND.ja.EQ.kci2).OR.
38883  $ (ja.EQ.kci1.AND.ia.EQ.kci2)) THEN
38884  kchw=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
38885  IF(abs(kchw).EQ.abs(kcem)) THEN
38886  DO ii=1,ncol
38887  nchn=nchn+1
38888  isig(nchn,1)=ip
38889  isig(nchn,2)=jp
38890  isig(nchn,3)=ii
38891  sigh(nchn)=fact/ncol
38892  ENDDO
38893  ENDIF
38894  ENDIF
38895  430 CONTINUE
38896  440 CONTINUE
38897  ENDIF
38898  ENDIF
38899 
38900  RETURN
38901  END
38902 
38903 C*********************************************************************
38904 
38905 C...PYPDFU
38906 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38907 C...parton distributions according to a few different parametrizations.
38908 C...Note that what is coded is x times the probability distribution,
38909 C...i.e. xq(x,Q2) etc.
38910 
38911  SUBROUTINE pypdfu(KF,X,Q2,XPQ)
38912 
38913 C...Double precision and integer declarations.
38914  IMPLICIT DOUBLE PRECISION(a-h, o-z)
38915  IMPLICIT INTEGER(i-n)
38916  INTEGER pyk,pychge,pycomp
38917 C...Commonblocks.
38918  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38919  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38920  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38921  common/pypars/mstp(200),parp(200),msti(200),pari(200)
38922  common/pyint1/mint(400),vint(400)
38923  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
38924  &xpdir(-6:6)
38925  common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
38926  common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
38927  & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
38928  & xmi(2,240),pt2mi(240),imisep(0:240)
38929  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint8/,
38930  &/pyint9/,/pyintm/
38931 C...Local arrays.
38932  dimension xpq(-25:25),xpel(-25:25),xpga(-6:6),vxpga(-6:6),
38933  &xppi(-6:6),xppr(-6:6),xpval(-6:6),ppar(6,2)
38934  SAVE ppar
38935 
38936 C...Interface to PDFLIB.
38937  common/w50513/xmin,xmax,q2min,q2max
38938  SAVE /w50513/
38939  DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu,
38940  &value(20),xmin,xmax,q2min,q2max
38941  CHARACTER*20 parm(20)
38942  DATA value/20*0d0/,parm/20*' '/
38943 
38944 C...Data related to Schuler-Sjostrand photon distributions.
38945  DATA alamga/0.2d0/, pmcga/1.3d0/, pmbga/4.6d0/
38946 
38947 C...Valence PDF momentum integral parametrizations PER PARTON!
38948  DATA (ppar(1,ipar),ipar=1,2) /0.385d0,1.60d0/
38949  DATA (ppar(2,ipar),ipar=1,2) /0.480d0,1.56d0/
38950  pavg(ifl,q2)=ppar(ifl,1)/(1d0+ppar(ifl,2)*
38951  &log(log(max(q2,1d0)/0.04d0)))
38952 
38953 C...Reset parton distributions.
38954  mint(92)=0
38955  DO 100 kfl=-25,25
38956  xpq(kfl)=0d0
38957  100 CONTINUE
38958  DO 110 kfl=-6,6
38959  xpval(kfl)=0d0
38960  110 CONTINUE
38961 
38962 C...Check x and particle species.
38963  IF(x.LE.0d0.OR.x.GE.1d0) THEN
38964  WRITE(mstu(11),5000) x
38965  goto 9999
38966  ENDIF
38967  kfa=iabs(kf)
38968  IF(kfa.NE.11.AND.kfa.NE.13.AND.kfa.NE.15.AND.kfa.NE.22.AND.
38969  &kfa.NE.211.AND.kfa.NE.2112.AND.kfa.NE.2212.AND.kfa.NE.3122.AND.
38970  &kfa.NE.3112.AND.kfa.NE.3212.AND.kfa.NE.3222.AND.kfa.NE.3312.AND.
38971  &kfa.NE.3322.AND.kfa.NE.3334.AND.kfa.NE.111.AND.kfa.NE.321.AND.
38972  &kfa.NE.310.AND.kfa.NE.130) THEN
38973  WRITE(mstu(11),5100) kf
38974  goto 9999
38975  ENDIF
38976 
38977 C...Electron (or muon or tau) parton distribution call.
38978  IF(kfa.EQ.11.OR.kfa.EQ.13.OR.kfa.EQ.15) THEN
38979  CALL pypdel(kfa,x,q2,xpel)
38980  DO 120 kfl=-25,25
38981  xpq(kfl)=xpel(kfl)
38982  120 CONTINUE
38983 
38984 C...Photon parton distribution call (VDM+anomalous).
38985  ELSEIF(kfa.EQ.22.AND.mint(109).LE.1) THEN
38986  IF(mstp(56).EQ.1.AND.mstp(55).EQ.1) THEN
38987  CALL pypdga(x,q2,xpga)
38988  DO 130 kfl=-6,6
38989  xpq(kfl)=xpga(kfl)
38990  130 CONTINUE
38991  xpvu=4d0*(xpq(2)-xpq(1))/3d0
38992  xpval(1)=xpvu/4d0
38993  xpval(2)=xpvu
38994  xpval(3)=min(xpq(3),xpvu/4d0)
38995  xpval(4)=min(xpq(4),xpvu)
38996  xpval(5)=min(xpq(5),xpvu/4d0)
38997  xpval(-1)=xpval(1)
38998  xpval(-2)=xpval(2)
38999  xpval(-3)=xpval(3)
39000  xpval(-4)=xpval(4)
39001  xpval(-5)=xpval(5)
39002  ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.5.AND.mstp(55).LE.8) THEN
39003  q2mx=q2
39004  p2mx=0.36d0
39005  IF(mstp(55).GE.7) p2mx=4.0d0
39006  IF(mstp(57).EQ.0) q2mx=p2mx
39007  p2=0d0
39008  IF(vint(120).LT.0d0) p2=vint(120)**2
39009  CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gam,xpga)
39010  DO 140 kfl=-6,6
39011  xpq(kfl)=xpga(kfl)
39012  xpval(kfl)=vxpdgm(kfl)
39013  140 CONTINUE
39014  vint(231)=p2mx
39015  ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.9.AND.mstp(55).LE.12) THEN
39016  q2mx=q2
39017  p2mx=0.36d0
39018  IF(mstp(55).GE.11) p2mx=4.0d0
39019  IF(mstp(57).EQ.0) q2mx=p2mx
39020  p2=0d0
39021  IF(vint(120).LT.0d0) p2=vint(120)**2
39022  CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gam,xpga)
39023  DO 150 kfl=-6,6
39024  xpq(kfl)=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
39025  xpval(kfl)=vxpvmd(kfl)+vxpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
39026  150 CONTINUE
39027  vint(231)=p2mx
39028  ELSEIF(mstp(56).EQ.2) THEN
39029 C...Call PDFLIB parton distributions.
39030  parm(1)='NPTYPE'
39031  value(1)=3
39032  parm(2)='NGROUP'
39033  value(2)=mstp(55)/1000
39034  parm(3)='NSET'
39035  value(3)=mod(mstp(55),1000)
39036  IF(mint(93).NE.3000000+mstp(55)) THEN
39037  CALL pdfset(parm,value)
39038  mint(93)=3000000+mstp(55)
39039  ENDIF
39040  xx=x
39041  qq2=max(0d0,q2min,q2)
39042  IF(mstp(57).EQ.0) qq2=q2min
39043  p2=0d0
39044  IF(vint(120).LT.0d0) p2=vint(120)**2
39045  ip2=mstp(60)
39046  IF(mstp(55).EQ.5004) THEN
39047  IF(5d0*p2.LT.qq2.AND.
39048  & qq2.GT.0.6d0.AND.qq2.LT.5d4.AND.
39049  & p2.GE.0d0.AND.p2.LT.10d0.AND.
39050  & xx.GT.1d-4.AND.xx.LT.1d0) THEN
39051  CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
39052  & bot,top,glu)
39053  ELSE
39054  upv=0d0
39055  dnv=0d0
39056  usea=0d0
39057  dsea=0d0
39058  str=0d0
39059  chm=0d0
39060  bot=0d0
39061  top=0d0
39062  glu=0d0
39063  ENDIF
39064  ELSE
39065  IF(p2.LT.qq2) THEN
39066  CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
39067  & bot,top,glu)
39068  ELSE
39069  upv=0d0
39070  dnv=0d0
39071  usea=0d0
39072  dsea=0d0
39073  str=0d0
39074  chm=0d0
39075  bot=0d0
39076  top=0d0
39077  glu=0d0
39078  ENDIF
39079  ENDIF
39080  vint(231)=q2min
39081  xpq(0)=glu
39082  xpq(1)=dnv
39083  xpq(-1)=dnv
39084  xpq(2)=upv
39085  xpq(-2)=upv
39086  xpq(3)=str
39087  xpq(-3)=str
39088  xpq(4)=chm
39089  xpq(-4)=chm
39090  xpq(5)=bot
39091  xpq(-5)=bot
39092  xpq(6)=top
39093  xpq(-6)=top
39094  xpvu=4d0*(xpq(2)-xpq(1))/3d0
39095  xpval(1)=xpvu/4d0
39096  xpval(2)=xpvu
39097  xpval(3)=min(xpq(3),xpvu/4d0)
39098  xpval(4)=min(xpq(4),xpvu)
39099  xpval(5)=min(xpq(5),xpvu/4d0)
39100  xpval(-1)=xpval(1)
39101  xpval(-2)=xpval(2)
39102  xpval(-3)=xpval(3)
39103  xpval(-4)=xpval(4)
39104  xpval(-5)=xpval(5)
39105  ELSE
39106  WRITE(mstu(11),5200) kf,mstp(56),mstp(55)
39107  ENDIF
39108 
39109 C...Pion/gammaVDM parton distribution call.
39110  ELSEIF(kfa.EQ.211.OR.kfa.EQ.111.OR.kfa.EQ.321.OR.kfa.EQ.130.OR.
39111  &kfa.EQ.310.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
39112  IF(kfa.EQ.22.AND.mstp(56).EQ.1.AND.mstp(55).GE.5.AND.
39113  & mstp(55).LE.12) THEN
39114  iset=1+mod(mstp(55)-1,4)
39115  q2mx=q2
39116  p2mx=0.36d0
39117  IF(iset.GE.3) 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(iset,x,q2mx,p2,mstp(60),f2gam,xpga)
39122  DO 160 kfl=-6,6
39123  xpq(kfl)=xpvmd(kfl)
39124  xpval(kfl)=vxpvmd(kfl)
39125  160 CONTINUE
39126  vint(231)=p2mx
39127  ELSEIF(mstp(54).EQ.1.AND.mstp(53).GE.1.AND.mstp(53).LE.3) THEN
39128  CALL pypdpi(x,q2,xppi)
39129  DO 170 kfl=-6,6
39130  xpq(kfl)=xppi(kfl)
39131  170 CONTINUE
39132  xpval(2)=xpq(2)-xpq(-2)
39133  xpval(-1)=xpq(-1)-xpq(1)
39134  ELSEIF(mstp(54).EQ.2) THEN
39135 C...Call PDFLIB parton distributions.
39136  parm(1)='NPTYPE'
39137  value(1)=2
39138  parm(2)='NGROUP'
39139  value(2)=mstp(53)/1000
39140  parm(3)='NSET'
39141  value(3)=mod(mstp(53),1000)
39142  IF(mint(93).NE.2000000+mstp(53)) THEN
39143  CALL pdfset(parm,value)
39144  mint(93)=2000000+mstp(53)
39145  ENDIF
39146  xx=x
39147  qq=sqrt(max(0d0,q2min,q2))
39148  IF(mstp(57).EQ.0) qq=sqrt(q2min)
39149  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
39150  vint(231)=q2min
39151  xpq(0)=glu
39152  xpq(1)=dsea
39153  xpq(-1)=upv+dsea
39154  xpq(2)=upv+usea
39155  xpq(-2)=usea
39156  xpq(3)=str
39157  xpq(-3)=str
39158  xpq(4)=chm
39159  xpq(-4)=chm
39160  xpq(5)=bot
39161  xpq(-5)=bot
39162  xpq(6)=top
39163  xpq(-6)=top
39164  xpval(2)=upv
39165  xpval(-1)=upv
39166  ELSE
39167  WRITE(mstu(11),5200) kf,mstp(54),mstp(53)
39168  ENDIF
39169 
39170 C...Anomalous photon parton distribution call.
39171  ELSEIF(kfa.EQ.22.AND.mint(109).EQ.3) THEN
39172  q2mx=q2
39173  p2mx=parp(15)**2
39174  IF(mstp(56).EQ.1.AND.mstp(55).LE.8) THEN
39175  IF(mstp(55).EQ.5.OR.mstp(55).EQ.6) p2mx=0.36d0
39176  IF(mstp(55).EQ.7.OR.mstp(55).EQ.8) p2mx=4.0d0
39177  IF(mstp(57).EQ.0) q2mx=p2mx
39178  p2=0d0
39179  IF(vint(120).LT.0d0) p2=vint(120)**2
39180  CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gm,xpga)
39181  DO 180 kfl=-6,6
39182  xpq(kfl)=xpanl(kfl)+xpanh(kfl)
39183  xpval(kfl)=vxpanl(kfl)+vxpanh(kfl)
39184  180 CONTINUE
39185  vint(231)=p2mx
39186  ELSEIF(mstp(56).EQ.1) THEN
39187  IF(mstp(55).EQ.9.OR.mstp(55).EQ.10) p2mx=0.36d0
39188  IF(mstp(55).EQ.11.OR.mstp(55).EQ.12) p2mx=4.0d0
39189  IF(mstp(57).EQ.0) q2mx=p2mx
39190  p2=0d0
39191  IF(vint(120).LT.0d0) p2=vint(120)**2
39192  CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gm,xpga)
39193  DO 190 kfl=-6,6
39194  xpq(kfl)=max(0d0,xpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
39195  xpval(kfl)=max(0d0,vxpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
39196  190 CONTINUE
39197  vint(231)=p2mx
39198  ELSEIF(mstp(56).EQ.2) THEN
39199  IF(mstp(57).EQ.0) q2mx=p2mx
39200  CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)
39201  DO 200 kfl=-6,6
39202  xpq(kfl)=xpga(kfl)
39203  xpval(kfl)=vxpga(kfl)
39204  200 CONTINUE
39205  vint(231)=p2mx
39206  ELSEIF(mstp(55).GE.1.AND.mstp(55).LE.5) THEN
39207  IF(mstp(57).EQ.0) q2mx=p2mx
39208  CALL pygvmd(0,mstp(55),x,q2mx,p2mx,parp(1),xpga,vxpga)
39209  DO 210 kfl=-6,6
39210  xpq(kfl)=xpga(kfl)
39211  xpval(kfl)=vxpga(kfl)
39212  210 CONTINUE
39213  vint(231)=p2mx
39214  ELSE
39215  220 rkf=11d0*pyr(0)
39216  kfr=1
39217  IF(rkf.GT.1d0) kfr=2
39218  IF(rkf.GT.5d0) kfr=3
39219  IF(rkf.GT.6d0) kfr=4
39220  IF(rkf.GT.10d0) kfr=5
39221  IF(kfr.EQ.4.AND.q2.LT.pmcga**2) goto 220
39222  IF(kfr.EQ.5.AND.q2.LT.pmbga**2) goto 220
39223  IF(mstp(57).EQ.0) q2mx=p2mx
39224  CALL pygvmd(0,kfr,x,q2mx,p2mx,parp(1),xpga,vxpga)
39225  DO 230 kfl=-6,6
39226  xpq(kfl)=xpga(kfl)
39227  xpval(kfl)=vxpga(kfl)
39228  230 CONTINUE
39229  vint(231)=p2mx
39230  ENDIF
39231 
39232 C...Proton parton distribution call.
39233  ELSE
39234  IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.20) THEN
39235  CALL pypdpr(x,q2,xppr)
39236  DO 240 kfl=-6,6
39237  xpq(kfl)=xppr(kfl)
39238  240 CONTINUE
39239 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
39240  xpval(1)=max(0d0,xpq(1)-xpq(-1))
39241  xpval(2)=max(0d0,xpq(2)-xpq(-2))
39242  ELSEIF(mstp(52).EQ.2) THEN
39243 C...Call PDFLIB parton distributions.
39244  parm(1)='NPTYPE'
39245  value(1)=1
39246  parm(2)='NGROUP'
39247  value(2)=mstp(51)/1000
39248  parm(3)='NSET'
39249  value(3)=mod(mstp(51),1000)
39250  IF(mint(93).NE.1000000+mstp(51)) THEN
39251  CALL pdfset(parm,value)
39252  mint(93)=1000000+mstp(51)
39253  ENDIF
39254  xx=x
39255  qq=sqrt(max(0d0,q2min,q2))
39256  IF(mstp(57).EQ.0) qq=sqrt(q2min)
39257  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
39258  vint(231)=q2min
39259  xpq(0)=glu
39260  xpq(1)=dnv+dsea
39261  xpq(-1)=dsea
39262  xpq(2)=upv+usea
39263  xpq(-2)=usea
39264  xpq(3)=str
39265  xpq(-3)=str
39266  xpq(4)=chm
39267  xpq(-4)=chm
39268  xpq(5)=bot
39269  xpq(-5)=bot
39270  xpq(6)=top
39271  xpq(-6)=top
39272  xpval(1)=dnv
39273  xpval(2)=upv
39274  ELSE
39275  WRITE(mstu(11),5200) kf,mstp(52),mstp(51)
39276  ENDIF
39277  ENDIF
39278 
39279 C...Isospin average for pi0/gammaVDM.
39280  IF(kfa.EQ.111.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
39281  IF(kfa.EQ.22.AND.mstp(55).GE.5.AND.mstp(55).LE.12) THEN
39282  xpv=xpq(2)-xpq(1)
39283  xpq(2)=xpq(1)
39284  xpq(-2)=xpq(-1)
39285  ELSE
39286  xps=0.5d0*(xpq(1)+xpq(-2))
39287  xpv=0.5d0*(xpq(2)+xpq(-1))-xps
39288  xpq(2)=xps
39289  xpq(-1)=xps
39290  ENDIF
39291  xpvl=0.5d0*(xpval(1)+xpval(2)+xpval(-1)+xpval(-2))+
39292  & xpval(3)+xpval(4)+xpval(5)
39293  DO 250 kfl=-6,6
39294  xpval(kfl)=0d0
39295  250 CONTINUE
39296  IF(kfa.EQ.22.AND.mint(105).LE.223) THEN
39297  xpq(1)=xpq(1)+0.2d0*xpv
39298  xpq(2)=xpq(2)+0.8d0*xpv
39299  xpval(1)=0.2d0*xpvl
39300  xpval(2)=0.8d0*xpvl
39301  ELSEIF(kfa.EQ.22.AND.mint(105).EQ.333) THEN
39302  xpq(3)=xpq(3)+xpv
39303  xpval(3)=xpvl
39304  ELSEIF(kfa.EQ.22.AND.mint(105).EQ.443) THEN
39305  xpq(4)=xpq(4)+xpv
39306  xpval(4)=xpvl
39307  IF(mstp(55).GE.9) THEN
39308  DO 260 kfl=-6,6
39309  xpq(kfl)=0d0
39310  260 CONTINUE
39311  ENDIF
39312  ELSE
39313  xpq(1)=xpq(1)+0.5d0*xpv
39314  xpq(2)=xpq(2)+0.5d0*xpv
39315  xpval(1)=0.5d0*xpvl
39316  xpval(2)=0.5d0*xpvl
39317  ENDIF
39318  DO 270 kfl=1,6
39319  xpq(-kfl)=xpq(kfl)
39320  xpval(-kfl)=xpval(kfl)
39321  270 CONTINUE
39322 
39323 C...Rescale for gammaVDM by effective gamma -> rho coupling.
39324 C+++Do not rescale?
39325  IF(kfa.EQ.22.AND.mint(109).EQ.2.AND..NOT.(mstp(56).EQ.1
39326  & .AND.mstp(55).GE.5.AND.mstp(55).LE.12)) THEN
39327  DO 280 kfl=-6,6
39328  xpq(kfl)=vint(281)*xpq(kfl)
39329  xpval(kfl)=vint(281)*xpval(kfl)
39330  280 CONTINUE
39331  vint(232)=vint(281)*xpv
39332  ENDIF
39333 
39334 C...Simple recipes for kaons.
39335  ELSEIF(kfa.EQ.321) THEN
39336  xpq(-3)=xpq(-3)+xpq(-1)-xpq(1)
39337  xpq(-1)=xpq(1)
39338  xpval(-3)=xpval(-1)
39339  xpval(-1)=0d0
39340  ELSEIF(kfa.EQ.130.OR.kfa.EQ.310) THEN
39341  xps=0.5d0*(xpq(1)+xpq(-2))
39342  xpv=0.5d0*(xpq(2)+xpq(-1))-xps
39343  xpq(2)=xps
39344  xpq(-1)=xps
39345  xpq(1)=xpq(1)+0.5d0*xpv
39346  xpq(-1)=xpq(-1)+0.5d0*xpv
39347  xpq(3)=xpq(3)+0.5d0*xpv
39348  xpq(-3)=xpq(-3)+0.5d0*xpv
39349  xpv=0.5d0*(xpval(2)+xpval(-1))
39350  xpval(2)=0d0
39351  xpval(-1)=0d0
39352  xpval(1)=0.5d0*xpv
39353  xpval(-1)=0.5d0*xpv
39354  xpval(3)=0.5d0*xpv
39355  xpval(-3)=0.5d0*xpv
39356 
39357 C...Isospin conjugation for neutron.
39358  ELSEIF(kfa.EQ.2112) THEN
39359  xpsv=xpq(1)
39360  xpq(1)=xpq(2)
39361  xpq(2)=xpsv
39362  xpsv=xpq(-1)
39363  xpq(-1)=xpq(-2)
39364  xpq(-2)=xpsv
39365  xpsv=xpval(1)
39366  xpval(1)=xpval(2)
39367  xpval(2)=xpsv
39368 
39369 C...Simple recipes for hyperon (average valence parton distribution).
39370  ELSEIF(kfa.EQ.3122.OR.kfa.EQ.3112.OR.kfa.EQ.3212.OR.kfa.EQ.3222
39371  & .OR.kfa.EQ.3312.OR.kfa.EQ.3322.OR.kfa.EQ.3334) THEN
39372  xpv=(xpq(1)+xpq(2)-xpq(-1)-xpq(-2))/3d0
39373  xps=0.5d0*(xpq(-1)+xpq(-2))
39374  xpq(1)=xps
39375  xpq(2)=xps
39376  xpq(-1)=xps
39377  xpq(-2)=xps
39378  xpq(kfa/1000)=xpq(kfa/1000)+xpv
39379  xpq(mod(kfa/100,10))=xpq(mod(kfa/100,10))+xpv
39380  xpq(mod(kfa/10,10))=xpq(mod(kfa/10,10))+xpv
39381  xpv=(xpval(1)+xpval(2))/3d0
39382  xpval(1)=0d0
39383  xpval(2)=0d0
39384  xpval(kfa/1000)=xpval(kfa/1000)+xpv
39385  xpval(mod(kfa/100,10))=xpval(mod(kfa/100,10))+xpv
39386  xpval(mod(kfa/10,10))=xpval(mod(kfa/10,10))+xpv
39387  ENDIF
39388 
39389 C...Charge conjugation for antiparticle.
39390  IF(kf.LT.0) THEN
39391  DO 290 kfl=1,25
39392  IF(kfl.EQ.21.OR.kfl.EQ.22.OR.kfl.EQ.23.OR.kfl.EQ.25) goto 290
39393  xpsv=xpq(kfl)
39394  xpq(kfl)=xpq(-kfl)
39395  xpq(-kfl)=xpsv
39396  290 CONTINUE
39397  DO 300 kfl=1,6
39398  xpsv=xpval(kfl)
39399  xpval(kfl)=xpval(-kfl)
39400  xpval(-kfl)=xpsv
39401  300 CONTINUE
39402  ENDIF
39403 
39404 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
39405 C...Set side.
39406  js=mint(30)
39407 C...Only reshape PDFs for the non-first interactions;
39408 C...But need valence/sea separation already from first interaction.
39409  IF ((js.EQ.1.OR.js.EQ.2).AND.mint(35).GE.2) THEN
39410  kfvsel=kfival(js,1)
39411 C...If valence quark kicked out of pi0 or gamma then that decides
39412 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
39413  IF(kfvsel.NE.0.AND.(kfa.EQ.111.OR.kfa.EQ.22)) THEN
39414  xpvl=0d0
39415  DO 310 kfl=1,6
39416  xpvl=xpvl+xpval(kfl)
39417  xpq(kfl)=max(0d0,xpq(kfl)-xpval(kfl))
39418  xpval(kfl)=0d0
39419  310 CONTINUE
39420  xpq(iabs(kfvsel))=xpq(iabs(kfvsel))+xpvl
39421  xpval(iabs(kfvsel))=xpvl
39422  DO 320 kfl=1,6
39423  xpq(-kfl)=xpq(kfl)
39424  xpval(-kfl)=xpval(kfl)
39425  320 CONTINUE
39426 
39427 C...If valence quark kicked out of K0S or K0S then that decides whether
39428 C...we should consider state as d sbar or s dbar.
39429  ELSEIF(kfvsel.NE.0.AND.(kfa.EQ.130.OR.kfa.EQ.310)) THEN
39430  kfs=1
39431  IF(kfvsel.EQ.-1.OR.kfvsel.EQ.3) kfs=-1
39432  xpq(kfs)=xpq(kfs)+xpval(-kfs)
39433  xpval(kfs)=xpval(kfs)+xpval(-kfs)
39434  xpq(-kfs)=max(0d0,xpq(-kfs)-xpval(-kfs))
39435  xpval(-kfs)=0d0
39436  kfs=-3*kfs
39437  xpq(kfs)=xpq(kfs)+xpval(-kfs)
39438  xpval(kfs)=xpval(kfs)+xpval(-kfs)
39439  xpq(-kfs)=max(0d0,xpq(-kfs)-xpval(-kfs))
39440  xpval(-kfs)=0d0
39441  ENDIF
39442 
39443 C...XPQ distributions are nominal for a (signed) beam particle
39444 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
39445  cmpfac=1d0
39446  nresc=0
39447  345 nresc=nresc+1
39448  pvctot(js,-1)=0d0
39449  pvctot(js, 0)=0d0
39450  pvctot(js, 1)=0d0
39451  DO 350 ifl=-6,6
39452  IF(ifl.EQ.0) goto 350
39453 
39454 C...Count up number of original IFL valence quarks.
39455  ivorg=0
39456  IF(kfival(js,1).EQ.ifl) ivorg=ivorg+1
39457  IF(kfival(js,2).EQ.ifl) ivorg=ivorg+1
39458  IF(kfival(js,3).EQ.ifl) ivorg=ivorg+1
39459 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
39460 C...bookkeep as if d dbar (for total momentum sum in valence sector).
39461  IF(kfival(js,1).EQ.0.AND.iabs(ifl).EQ.1) ivorg=1
39462 C...Count down number of remaining IFL valence quarks. Skip current
39463 C...interaction initiator.
39464  ivrem=ivorg
39465  DO 330 i1=1,nmi(js)
39466  IF (i1.EQ.mint(36)) goto 330
39467  IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
39468  & ivrem=ivrem-1
39469  330 CONTINUE
39470 
39471 C...Separate out original VALENCE and SEA content.
39472  val=xpval(ifl)
39473  sea=max(0d0,xpq(ifl)-val)
39474  xpsvc(ifl,0)=val
39475  xpsvc(ifl,-1)=sea
39476 
39477 C...Rescale valence content if changed.
39478  IF (ivorg.NE.0.AND.ivrem.NE.ivorg) xpsvc(ifl,0)=
39479  & (val*ivrem)/ivorg
39480 
39481 C...Momentum integrals of original and removed valence quarks.
39482  IF(ivorg.NE.0) THEN
39483 C...For p/n/pbar/nbar beams can split into d_val and u_val.
39484 C...Isospin conjugation for neutrons
39485  IF(kfa.EQ.2212.OR.kfa.EQ.2112) THEN
39486  iaflp=iabs(ifl)
39487  IF (kfa.EQ.2112) iaflp=3-iaflp
39488  vpavg=pavg(iaflp,q2)
39489 C...For other baryons average d_val and u_val, like for PDFs.
39490  ELSEIF(kfa.GT.1000) THEN
39491  vpavg=(pavg(1,q2)+2d0*pavg(2,q2))/3d0
39492 C...For mesons and photon average d_val and u_val and scale by 3/2.
39493 C...Very crude, especially for photon.
39494  ELSE
39495  vpavg=0.5d0*(pavg(1,q2)+2d0*pavg(2,q2))
39496  ENDIF
39497  pvctot(js,-1)=pvctot(js,-1)+ivorg*vpavg
39498  pvctot(js, 0)=pvctot(js, 0)+(ivorg-ivrem)*vpavg
39499  ENDIF
39500 
39501 C...Now add companions (at X with partner having been at Z=XASSOC).
39502 C...NOTE: due to the assumed simple x scaling, the partner was at what
39503 C...corresponds to a higher Z than XASSOC, if there were intermediate
39504 C...scatterings. Nothing done about that for the moment.
39505  DO 340 ivc=1,nvc(js,ifl)
39506 C...Skip companions that have been kicked out
39507  IF (xassoc(js,ifl,ivc).LE.0d0) THEN
39508  xpsvc(ifl,ivc)=0d0
39509  goto 340
39510  ELSE
39511 C...Momentum fraction of the partner quark.
39512 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
39513  xs=xassoc(js,ifl,ivc)
39514  xrem=vint(142+js)
39515  ys=xs/(xrem+xs)
39516 C...Momentum fraction of the companion quark.
39517 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
39518  y=x*(1d0-ys)
39519  xpsvc(ifl,ivc)=pyfcmp(y/cmpfac,ys/cmpfac,mstp(87))
39520 C...Add to momentum sum, with rescaling compensation factor.
39521  xcfac=(xrem+xs)/xrem*cmpfac
39522  pvctot(js,1)=pvctot(js,1)+xcfac*pypcmp(ys/cmpfac,mstp(87))
39523  ENDIF
39524  340 CONTINUE
39525  350 CONTINUE
39526 
39527 C...Wait until all flavours treated, then rescale seas and gluon.
39528  xpsvc(0,-1)=xpq(0)
39529  xpsvc(0,0)=0d0
39530  rsfac=1d0+(pvctot(js,0)-pvctot(js,1))/(1d0-pvctot(js,-1))
39531  IF (rsfac.LE.0d0) THEN
39532 C...First calculate factor needed to exactly restore pz cons.
39533  IF (nresc.EQ.1) cmpfac =
39534  & (1d0-(pvctot(js,-1)-pvctot(js,0)))/pvctot(js,1)
39535 C...Add a bit of headroom
39536  cmpfac=0.99*cmpfac
39537 C...Try a few times if more headroom is needed, then print error message.
39538  IF (nresc.LE.10) goto 345
39539  CALL pyerrm(15,
39540  & '(PYPDFU:) Negative reshaping factor persists!')
39541  WRITE(mstu(11),5300) (pvctot(js,itmp),itmp=-1,1), rsfac
39542  rsfac=0d0
39543  ENDIF
39544  DO 370 ifl=-6,6
39545  xpsvc(ifl,-1)=rsfac*xpsvc(ifl,-1)
39546 C...Also store resulting distributions in XPQ
39547  xpq(ifl)=0d0
39548  DO 360 isvc=-1,nvc(js,ifl)
39549  xpq(ifl)=xpq(ifl)+xpsvc(ifl,isvc)
39550  360 CONTINUE
39551  370 CONTINUE
39552 C...Save companion reweighting factor for PYPTIS.
39553  vint(140)=cmpfac
39554  ENDIF
39555 
39556 
39557 C...Allow gluon also in position 21.
39558  xpq(21)=xpq(0)
39559 
39560 C...Check positivity and reset above maximum allowed flavour.
39561  DO 380 kfl=-25,25
39562  xpq(kfl)=max(0d0,xpq(kfl))
39563  IF(iabs(kfl).GT.mstp(58).AND.iabs(kfl).LE.8) xpq(kfl)=0d0
39564  380 CONTINUE
39565 
39566 C...Formats for error printouts.
39567  5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
39568  5100 FORMAT(' Error: illegal particle code for parton distribution;',
39569  &' KF =',i5)
39570  5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
39571  &3i5)
39572  5300 FORMAT(' Original valence momentum fraction : ',f6.3/
39573  & ' Removed valence momentum fraction : ',f6.3/
39574  & ' Added companion momentum fraction : ',f6.3/
39575  & ' Resulting rescale factor : ',f6.3)
39576 
39577 C...Reset side pointer and return
39578  9999 mint(30)=0
39579 
39580  RETURN
39581  END
39582 
39583 C*********************************************************************
39584 
39585 C...PYPDFL
39586 C...Gives proton parton distribution at small x and/or Q^2 according to
39587 C...correct limiting behaviour.
39588 
39589  SUBROUTINE pypdfl(KF,X,Q2,XPQ)
39590 
39591 C...Double precision and integer declarations.
39592  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39593  IMPLICIT INTEGER(i-n)
39594  INTEGER pyk,pychge,pycomp
39595 C...Commonblocks.
39596  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39597  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
39598  common/pypars/mstp(200),parp(200),msti(200),pari(200)
39599  common/pyint1/mint(400),vint(400)
39600  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
39601 C...Local arrays.
39602  dimension xpq(-25:25),xpa(-25:25),xpb(-25:25),wtsb(-3:3)
39603  DATA rmr/0.92d0/,rmp/0.38d0/,wtsb/0.5d0,1d0,1d0,5d0,1d0,1d0,0.5d0/
39604 
39605 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
39606  mint(92)=0
39607  kfa=iabs(kf)
39608  iacc=0
39609  IF((kfa.EQ.2212.OR.kfa.EQ.2112).AND.mstp(57).GE.2) iacc=1
39610  IF(kfa.EQ.211.AND.mstp(57).GE.3) iacc=1
39611  IF(kfa.EQ.22.AND.mint(109).EQ.2.AND.mstp(57).GE.3) iacc=1
39612  IF(iacc.EQ.0) THEN
39613  CALL pypdfu(kf,x,q2,xpq)
39614  RETURN
39615  ENDIF
39616 
39617 C...Reset. Check x.
39618  DO 100 kfl=-25,25
39619  xpq(kfl)=0d0
39620  100 CONTINUE
39621  IF(x.LE.0d0.OR.x.GE.1d0) THEN
39622  WRITE(mstu(11),5000) x
39623  RETURN
39624  ENDIF
39625 
39626 C...Define valence content.
39627  kfc=kf
39628  nv1=2
39629  nv2=1
39630  IF(kf.EQ.2212) THEN
39631  kfv1=2
39632  kfv2=1
39633  ELSEIF(kf.EQ.-2212) THEN
39634  kfv1=-2
39635  kfv2=-1
39636  ELSEIF(kf.EQ.2112) THEN
39637  kfv1=1
39638  kfv2=2
39639  ELSEIF(kf.EQ.-2112) THEN
39640  kfv1=-1
39641  kfv2=-2
39642  ELSEIF(kf.EQ.211) THEN
39643  nv1=1
39644  kfv1=2
39645  kfv2=-1
39646  ELSEIF(kf.EQ.-211) THEN
39647  nv1=1
39648  kfv1=-2
39649  kfv2=1
39650  ELSEIF(mint(105).LE.223) THEN
39651  kfv1=1
39652  wtv1=0.2d0
39653  kfv2=2
39654  wtv2=0.8d0
39655  ELSEIF(mint(105).EQ.333) THEN
39656  kfv1=3
39657  wtv1=1.0d0
39658  kfv2=1
39659  wtv2=0.0d0
39660  ELSEIF(mint(105).EQ.443) THEN
39661  kfv1=4
39662  wtv1=1.0d0
39663  kfv2=1
39664  wtv2=0.0d0
39665  ENDIF
39666 
39667 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
39668  mint30=mint(30)
39669  CALL pypdfu(kfc,x,q2,xpa)
39670  q2mn=max(3d0,vint(231))
39671  q2b=2d0+0.052d0**2*exp(3.56d0*sqrt(max(0d0,-log(3d0*x))))
39672  xmn=exp(-(log((q2mn-2d0)/0.052d0**2)/3.56d0)**2)/3d0
39673 
39674 C...Large Q2 and large x: naive call is enough.
39675  IF(q2.GT.q2mn.AND.q2.GT.q2b) THEN
39676  DO 110 kfl=-25,25
39677  xpq(kfl)=xpa(kfl)
39678  110 CONTINUE
39679  mint(92)=1
39680 
39681 C...Small Q2 and large x: dampen boundary value.
39682  ELSEIF(x.GT.xmn) THEN
39683 
39684 C...Evaluate at boundary and define dampening factors.
39685  mint(30)=mint30
39686  CALL pypdfu(kfc,x,q2mn,xpa)
39687  fv=(q2*(q2mn+rmr)/(q2mn*(q2+rmr)))**(0.55d0*(1d0-x)/(1d0-xmn))
39688  fs=(q2*(q2mn+rmp)/(q2mn*(q2+rmp)))**1.08d0
39689 
39690 C...Separate valence and sea parts of parton distribution.
39691  IF(kfa.NE.22) THEN
39692  xfv1=xpa(kfv1)-xpa(-kfv1)
39693  xpa(kfv1)=xpa(-kfv1)
39694  xfv2=xpa(kfv2)-xpa(-kfv2)
39695  xpa(kfv2)=xpa(-kfv2)
39696  ELSE
39697  xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
39698  xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
39699  xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
39700  xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
39701  ENDIF
39702 
39703 C...Dampen valence and sea separately. Put back together.
39704  DO 120 kfl=-25,25
39705  xpq(kfl)=fs*xpa(kfl)
39706  120 CONTINUE
39707  IF(kfa.NE.22) THEN
39708  xpq(kfv1)=xpq(kfv1)+fv*xfv1
39709  xpq(kfv2)=xpq(kfv2)+fv*xfv2
39710  ELSE
39711  xpq(kfv1)=xpq(kfv1)+fv*wtv1*vint(232)
39712  xpq(-kfv1)=xpq(-kfv1)+fv*wtv1*vint(232)
39713  xpq(kfv2)=xpq(kfv2)+fv*wtv2*vint(232)
39714  xpq(-kfv2)=xpq(-kfv2)+fv*wtv2*vint(232)
39715  ENDIF
39716  mint(92)=2
39717 
39718 C...Large Q2 and small x: interpolate behaviour.
39719  ELSEIF(q2.GT.q2mn) THEN
39720 
39721 C...Evaluate at extremes and define coefficients for interpolation.
39722  mint(30)=mint30
39723  CALL pypdfu(kfc,xmn,q2mn,xpa)
39724  vi232a=vint(232)
39725  mint(30)=mint30
39726  CALL pypdfu(kfc,x,q2b,xpb)
39727  vi232b=vint(232)
39728  fla=log(q2b/q2)/log(q2b/q2mn)
39729  fva=(x/xmn)**0.45d0*fla
39730  fsa=(x/xmn)**(-0.08d0)*fla
39731  fb=1d0-fla
39732 
39733 C...Separate valence and sea parts of parton distribution.
39734  IF(kfa.NE.22) THEN
39735  xfva1=xpa(kfv1)-xpa(-kfv1)
39736  xpa(kfv1)=xpa(-kfv1)
39737  xfva2=xpa(kfv2)-xpa(-kfv2)
39738  xpa(kfv2)=xpa(-kfv2)
39739  xfvb1=xpb(kfv1)-xpb(-kfv1)
39740  xpb(kfv1)=xpb(-kfv1)
39741  xfvb2=xpb(kfv2)-xpb(-kfv2)
39742  xpb(kfv2)=xpb(-kfv2)
39743  ELSE
39744  xpa(kfv1)=xpa(kfv1)-wtv1*vi232a
39745  xpa(-kfv1)=xpa(-kfv1)-wtv1*vi232a
39746  xpa(kfv2)=xpa(kfv2)-wtv2*vi232a
39747  xpa(-kfv2)=xpa(-kfv2)-wtv2*vi232a
39748  xpb(kfv1)=xpb(kfv1)-wtv1*vi232b
39749  xpb(-kfv1)=xpb(-kfv1)-wtv1*vi232b
39750  xpb(kfv2)=xpb(kfv2)-wtv2*vi232b
39751  xpb(-kfv2)=xpb(-kfv2)-wtv2*vi232b
39752  ENDIF
39753 
39754 C...Interpolate for valence and sea. Put back together.
39755  DO 130 kfl=-25,25
39756  xpq(kfl)=fsa*xpa(kfl)+fb*xpb(kfl)
39757  130 CONTINUE
39758  IF(kfa.NE.22) THEN
39759  xpq(kfv1)=xpq(kfv1)+(fva*xfva1+fb*xfvb1)
39760  xpq(kfv2)=xpq(kfv2)+(fva*xfva2+fb*xfvb2)
39761  ELSE
39762  xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vi232a+fb*vi232b)
39763  xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vi232a+fb*vi232b)
39764  xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vi232a+fb*vi232b)
39765  xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vi232a+fb*vi232b)
39766  ENDIF
39767  mint(92)=3
39768 
39769 C...Small Q2 and small x: dampen boundary value and add term.
39770  ELSE
39771 
39772 C...Evaluate at boundary and define dampening factors.
39773  mint(30)=mint30
39774  CALL pypdfu(kfc,xmn,q2mn,xpa)
39775  fb=(xmn-x)*(q2mn-q2)/(xmn*q2mn)
39776  fa=1d0-fb
39777  fvc=(x/xmn)**0.45d0*(q2/(q2+rmr))**0.55d0
39778  fva=fvc*fa*((q2mn+rmr)/q2mn)**0.55d0
39779  fvb=fvc*fb*1.10d0*xmn**0.45d0*0.11d0
39780  fsc=(x/xmn)**(-0.08d0)*(q2/(q2+rmp))**1.08d0
39781  fsa=fsc*fa*((q2mn+rmp)/q2mn)**1.08d0
39782  fsb=fsc*fb*0.21d0*xmn**(-0.08d0)*0.21d0
39783 
39784 C...Separate valence and sea parts of parton distribution.
39785  IF(kfa.NE.22) THEN
39786  xfv1=xpa(kfv1)-xpa(-kfv1)
39787  xpa(kfv1)=xpa(-kfv1)
39788  xfv2=xpa(kfv2)-xpa(-kfv2)
39789  xpa(kfv2)=xpa(-kfv2)
39790  ELSE
39791  xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
39792  xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
39793  xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
39794  xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
39795  ENDIF
39796 
39797 C...Dampen valence and sea separately. Add constant terms.
39798 C...Put back together.
39799  DO 140 kfl=-25,25
39800  xpq(kfl)=fsa*xpa(kfl)
39801  140 CONTINUE
39802  IF(kfa.NE.22) THEN
39803  DO 150 kfl=-3,3
39804  xpq(kfl)=xpq(kfl)+fsb*wtsb(kfl)
39805  150 CONTINUE
39806  xpq(kfv1)=xpq(kfv1)+(fva*xfv1+fvb*nv1)
39807  xpq(kfv2)=xpq(kfv2)+(fva*xfv2+fvb*nv2)
39808  ELSE
39809  DO 160 kfl=-3,3
39810  xpq(kfl)=xpq(kfl)+vint(281)*fsb*wtsb(kfl)
39811  160 CONTINUE
39812  xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
39813  xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
39814  xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
39815  xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
39816  ENDIF
39817  xpq(21)=xpq(0)
39818  mint(92)=4
39819  ENDIF
39820 
39821 C...Format for error printout.
39822  5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
39823 
39824  RETURN
39825  END
39826 
39827 C*********************************************************************
39828 
39829 C...PYPDEL
39830 C...Gives electron (or muon, or tau) parton distribution.
39831 
39832  SUBROUTINE pypdel(KFA,X,Q2,XPEL)
39833 
39834 C...Double precision and integer declarations.
39835  IMPLICIT DOUBLE PRECISION(a-h, o-z)
39836  IMPLICIT INTEGER(i-n)
39837  INTEGER pyk,pychge,pycomp
39838 C...Commonblocks.
39839  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39840  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
39841  common/pypars/mstp(200),parp(200),msti(200),pari(200)
39842  common/pyint1/mint(400),vint(400)
39843  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
39844 C...Local arrays.
39845  dimension xpel(-25:25),xpga(-6:6),sxp(0:6)
39846 
39847 C...Interface to PDFLIB.
39848  common/w50513/xmin,xmax,q2min,q2max
39849  SAVE /w50513/
39850  DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu,
39851  &value(20),xmin,xmax,q2min,q2max
39852  CHARACTER*20 parm(20)
39853  DATA value/20*0d0/,parm/20*' '/
39854 
39855 C...Some common constants.
39856  DO 100 kfl=-25,25
39857  xpel(kfl)=0d0
39858  100 CONTINUE
39859  aem=paru(101)
39860  pme=pmas(11,1)
39861  IF(kfa.EQ.13) pme=pmas(13,1)
39862  IF(kfa.EQ.15) pme=pmas(15,1)
39863  xl=log(max(1d-10,x))
39864  x1l=log(max(1d-10,1d0-x))
39865  hle=log(max(3d0,q2/pme**2))
39866  hbe2=(aem/paru(1))*(hle-1d0)
39867 
39868 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39869 C...LEP 1, CERN 89-08, p. 34
39870  IF(mstp(59).LE.1) THEN
39871  hde=1d0+(aem/paru(1))*(1.5d0*hle+1.289868d0)+(aem/paru(1))**2*
39872  & (-2.164868d0*hle**2+9.840808d0*hle-10.130464d0)
39873  hee=hbe2*(1d0-x)**(hbe2-1d0)*sqrt(max(0d0,hde))-
39874  & 0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*(-4d0*x1l+3d0*xl)-
39875  & 4d0*xl/(1d0-x)-5d0-x)
39876  ELSE
39877  hee=hbe2*(1d0-x)**(hbe2-1d0)*exp(0.172784d0*hbe2)/
39878  & pygamm(1d0+hbe2)-0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*
39879  & (-4d0*x1l+3d0*xl)-4d0*xl/(1d0-x)-5d0-x)
39880  ENDIF
39881 C...Zero distribution for very large x and rescale it for intermediate.
39882  IF(x.GT.1d0-1d-10) THEN
39883  hee=0d0
39884  ELSEIF(x.GT.1d0-1d-7) THEN
39885  hee=hee*1000d0**hbe2/(1000d0**hbe2-1d0)
39886  ENDIF
39887  xpel(kfa)=x*hee
39888 
39889 C...Photon and (transverse) W- inside electron.
39890  aemp=pyalem(pme*sqrt(max(0d0,q2)))/paru(2)
39891  IF(mstp(13).LE.1) THEN
39892  hlg=hle
39893  ELSE
39894  hlg=log(max(1d0,(parp(13)/pme**2)*(1d0-x)/x**2))
39895  ENDIF
39896  xpel(22)=aemp*hlg*(1d0+(1d0-x)**2)
39897  hlw=log(1d0+q2/pmas(24,1)**2)/(4d0*paru(102))
39898  xpel(-24)=aemp*hlw*(1d0+(1d0-x)**2)
39899 
39900 C...Electron or positron inside photon inside electron.
39901  IF(kfa.EQ.11.AND.mstp(12).EQ.1) THEN
39902  xfsea=0.5d0*(aemp*(hle-1d0))**2*(4d0/3d0+x-x**2-4d0*x**3/3d0+
39903  & 2d0*x*(1d0+x)*xl)
39904  xpel(11)=xpel(11)+xfsea
39905  xpel(-11)=xfsea
39906 
39907 C...Initialize PDFLIB photon parton distributions.
39908  IF(mstp(56).EQ.2) THEN
39909  parm(1)='NPTYPE'
39910  value(1)=3
39911  parm(2)='NGROUP'
39912  value(2)=mstp(55)/1000
39913  parm(3)='NSET'
39914  value(3)=mod(mstp(55),1000)
39915  IF(mint(93).NE.3000000+mstp(55)) THEN
39916  CALL pdfset(parm,value)
39917  mint(93)=3000000+mstp(55)
39918  ENDIF
39919  ENDIF
39920 
39921 C...Quarks and gluons inside photon inside electron:
39922 C...numerical convolution required.
39923  DO 110 kfl=0,6
39924  sxp(kfl)=0d0
39925  110 CONTINUE
39926  sumxpp=0d0
39927  iter=-1
39928  120 iter=iter+1
39929  sumxp=sumxpp
39930  nstp=2**(iter-1)
39931  IF(iter.EQ.0) nstp=2
39932  DO 130 kfl=0,6
39933  sxp(kfl)=0.5d0*sxp(kfl)
39934  130 CONTINUE
39935  wtstp=0.5d0/nstp
39936  IF(iter.EQ.0) wtstp=0.5d0
39937 C...Pick grid of x_{gamma} values logarithmically even.
39938  DO 150 istp=1,nstp
39939  IF(iter.EQ.0) THEN
39940  xle=xl*(istp-1)
39941  ELSE
39942  xle=xl*(istp-0.5d0)/nstp
39943  ENDIF
39944  xe=min(1d0-1d-10,exp(xle))
39945  xg=min(1d0-1d-10,x/xe)
39946 C...Evaluate photon inside electron parton distribution for convolution.
39947  xpgp=1d0+(1d0-xe)**2
39948  IF(mstp(13).LE.1) THEN
39949  xpgp=xpgp*hle
39950  ELSE
39951  xpgp=xpgp*log(max(1d0,(parp(13)/pme**2)*(1d0-xe)/xe**2))
39952  ENDIF
39953 C...Evaluate photon parton distributions for convolution.
39954  IF(mstp(56).EQ.1) THEN
39955  IF(mstp(55).EQ.1) THEN
39956  CALL pypdga(xg,q2,xpga)
39957  ELSEIF(mstp(55).GE.5.AND.mstp(55).LE.8) THEN
39958  q2mx=q2
39959  p2mx=0.36d0
39960  IF(mstp(55).GE.7) p2mx=4.0d0
39961  IF(mstp(57).EQ.0) q2mx=p2mx
39962  p2=0d0
39963  IF(vint(120).LT.0d0) p2=vint(120)**2
39964  CALL pyggam(mstp(55)-4,xg,q2mx,p2,mstp(60),f2gam,xpga)
39965  vint(231)=p2mx
39966  ELSEIF(mstp(55).GE.9.AND.mstp(55).LE.12) THEN
39967  q2mx=q2
39968  p2mx=0.36d0
39969  IF(mstp(55).GE.11) p2mx=4.0d0
39970  IF(mstp(57).EQ.0) q2mx=p2mx
39971  p2=0d0
39972  IF(vint(120).LT.0d0) p2=vint(120)**2
39973  CALL pyggam(mstp(55)-8,xg,q2mx,p2,mstp(60),f2gam,xpga)
39974  vint(231)=p2mx
39975  ENDIF
39976  DO 140 kfl=0,5
39977  sxp(kfl)=sxp(kfl)+wtstp*xpgp*xpga(kfl)
39978  140 CONTINUE
39979  ELSEIF(mstp(56).EQ.2) THEN
39980 C...Call PDFLIB parton distributions.
39981  xx=xg
39982  qq=sqrt(max(0d0,q2min,q2))
39983  IF(mstp(57).EQ.0) qq=sqrt(q2min)
39984  CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
39985  sxp(0)=sxp(0)+wtstp*xpgp*glu
39986  sxp(1)=sxp(1)+wtstp*xpgp*dnv
39987  sxp(2)=sxp(2)+wtstp*xpgp*upv
39988  sxp(3)=sxp(3)+wtstp*xpgp*str
39989  sxp(4)=sxp(4)+wtstp*xpgp*chm
39990  sxp(5)=sxp(5)+wtstp*xpgp*bot
39991  sxp(6)=sxp(6)+wtstp*xpgp*top
39992  ENDIF
39993  150 CONTINUE
39994  sumxpp=sxp(0)+2d0*sxp(1)+2d0*sxp(2)
39995  IF(iter.LE.2.OR.(iter.LE.7.AND.abs(sumxpp-sumxp).GT.
39996  & parp(14)*(sumxpp+sumxp))) goto 120
39997 
39998 C...Put convolution into output arrays.
39999  fconv=aemp*(-xl)
40000  xpel(0)=fconv*sxp(0)
40001  DO 160 kfl=1,6
40002  xpel(kfl)=fconv*sxp(kfl)
40003  xpel(-kfl)=xpel(kfl)
40004  160 CONTINUE
40005  ENDIF
40006 
40007  RETURN
40008  END
40009 
40010 C*********************************************************************
40011 
40012 C...PYPDGA
40013 C...Gives photon parton distribution.
40014 
40015  SUBROUTINE pypdga(X,Q2,XPGA)
40016 
40017 C...Double precision and integer declarations.
40018  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40019  IMPLICIT INTEGER(i-n)
40020  INTEGER pyk,pychge,pycomp
40021 C...Commonblocks.
40022  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40023  common/pypars/mstp(200),parp(200),msti(200),pari(200)
40024  common/pyint1/mint(400),vint(400)
40025  SAVE /pydat1/,/pypars/,/pyint1/
40026 C...Local arrays.
40027  dimension xpga(-6:6),dgag(4,3),dgbg(4,3),dgcg(4,3),dgan(4,3),
40028  &dgbn(4,3),dgcn(4,3),dgdn(4,3),dgen(4,3),dgas(4,3),dgbs(4,3),
40029  &dgcs(4,3),dgds(4,3),dges(4,3)
40030 
40031 C...The following data lines are coefficients needed in the
40032 C...Drees and Grassie photon parton distribution parametrization.
40033  DATA dgag/-.207d0,.6158d0,1.074d0,0.d0,.8926d-2,.6594d0,
40034  &.4766d0,.1975d-1,.03197d0,1.018d0,.2461d0,.2707d-1/
40035  DATA dgbg/-.1987d0,.6257d0,8.352d0,5.024d0,.5085d-1,.2774d0,
40036  &-.3906d0,-.3212d0,-.618d-2,.9476d0,-.6094d0,-.1067d-1/
40037  DATA dgcg/5.119d0,-.2752d0,-6.993d0,2.298d0,-.2313d0,.1382d0,
40038  &6.542d0,.5162d0,-.1216d0,.9047d0,2.653d0,.2003d-2/
40039  DATA dgan/2.285d0,-.1526d-1,1330.d0,4.219d0,-.3711d0,1.061d0,
40040  &4.758d0,-.1503d-1,15.8d0,-.9464d0,-.5d0,-.2118d0/
40041  DATA dgbn/6.073d0,-.8132d0,-41.31d0,3.165d0,-.1717d0,.7815d0,
40042  &1.535d0,.7067d-2,2.742d0,-.7332d0,.7148d0,3.287d0/
40043  DATA dgcn/-.4202d0,.1778d-1,.9216d0,.18d0,.8766d-1,.2197d-1,
40044  &.1096d0,.204d0,.2917d-1,.4657d-1,.1785d0,.4811d-1/
40045  DATA dgdn/-.8083d-1,.6346d0,1.208d0,.203d0,-.8915d0,.2857d0,
40046  &2.973d0,.1185d0,-.342d-1,.7196d0,.7338d0,.8139d-1/
40047  DATA dgen/.5526d-1,1.136d0,.9512d0,.1163d-1,-.1816d0,.5866d0,
40048  &2.421d0,.4059d0,-.2302d-1,.9229d0,.5873d0,-.79d-4/
40049  DATA dgas/16.69d0,-.7916d0,1099.d0,4.428d0,-.1207d0,1.071d0,
40050  &1.977d0,-.8625d-2,6.734d0,-1.008d0,-.8594d-1,.7625d-1/
40051  DATA dgbs/.176d0,.4794d-1,1.047d0,.25d-1,25.d0,-1.648d0,
40052  &-.1563d-1,6.438d0,59.88d0,-2.983d0,4.48d0,.9686d0/
40053  DATA dgcs/-.208d-1,.3386d-2,4.853d0,.8404d0,-.123d-1,1.162d0,
40054  &.4824d0,-.11d-1,-.3226d-2,.8432d0,.3616d0,.1383d-2/
40055  DATA dgds/-.1685d-1,1.353d0,1.426d0,1.239d0,-.9194d-1,.7912d0,
40056  &.6397d0,2.327d0,-.3321d-1,.9475d0,-.3198d0,.2132d-1/
40057  DATA dges/-.1986d0,1.1d0,1.136d0,-.2779d0,.2015d-1,.9869d0,
40058  &-.7036d-1,.1694d-1,.1059d0,.6954d0,-.6663d0,.3683d0/
40059 
40060 C...Photon parton distribution from Drees and Grassie.
40061 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
40062  DO 100 kfl=-6,6
40063  xpga(kfl)=0d0
40064  100 CONTINUE
40065  vint(231)=1d0
40066  IF(mstp(57).LE.0) THEN
40067  t=log(1d0/0.16d0)
40068  ELSE
40069  t=log(min(1d4,max(1d0,q2))/0.16d0)
40070  ENDIF
40071  x1=1d0-x
40072  nf=3
40073  IF(q2.GT.25d0) nf=4
40074  IF(q2.GT.300d0) nf=5
40075  nfe=nf-2
40076  aem=paru(101)
40077 
40078 C...Evaluate gluon content.
40079  dga=dgag(1,nfe)*t**dgag(2,nfe)+dgag(3,nfe)*t**(-dgag(4,nfe))
40080  dgb=dgbg(1,nfe)*t**dgbg(2,nfe)+dgbg(3,nfe)*t**(-dgbg(4,nfe))
40081  dgc=dgcg(1,nfe)*t**dgcg(2,nfe)+dgcg(3,nfe)*t**(-dgcg(4,nfe))
40082  xpgl=dga*x**dgb*x1**dgc
40083 
40084 C...Evaluate up- and down-type quark content.
40085  dga=dgan(1,nfe)*t**dgan(2,nfe)+dgan(3,nfe)*t**(-dgan(4,nfe))
40086  dgb=dgbn(1,nfe)*t**dgbn(2,nfe)+dgbn(3,nfe)*t**(-dgbn(4,nfe))
40087  dgc=dgcn(1,nfe)*t**dgcn(2,nfe)+dgcn(3,nfe)*t**(-dgcn(4,nfe))
40088  dgd=dgdn(1,nfe)*t**dgdn(2,nfe)+dgdn(3,nfe)*t**(-dgdn(4,nfe))
40089  dge=dgen(1,nfe)*t**dgen(2,nfe)+dgen(3,nfe)*t**(-dgen(4,nfe))
40090  xpqn=x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
40091  dga=dgas(1,nfe)*t**dgas(2,nfe)+dgas(3,nfe)*t**(-dgas(4,nfe))
40092  dgb=dgbs(1,nfe)*t**dgbs(2,nfe)+dgbs(3,nfe)*t**(-dgbs(4,nfe))
40093  dgc=dgcs(1,nfe)*t**dgcs(2,nfe)+dgcs(3,nfe)*t**(-dgcs(4,nfe))
40094  dgd=dgds(1,nfe)*t**dgds(2,nfe)+dgds(3,nfe)*t**(-dgds(4,nfe))
40095  dge=dges(1,nfe)*t**dges(2,nfe)+dges(3,nfe)*t**(-dges(4,nfe))
40096  dgf=9d0
40097  IF(nf.EQ.4) dgf=10d0
40098  IF(nf.EQ.5) dgf=55d0/6d0
40099  xpqs=dgf*x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
40100  IF(nf.LE.3) THEN
40101  xpqu=(xpqs+9d0*xpqn)/6d0
40102  xpqd=(xpqs-4.5d0*xpqn)/6d0
40103  ELSEIF(nf.EQ.4) THEN
40104  xpqu=(xpqs+6d0*xpqn)/8d0
40105  xpqd=(xpqs-6d0*xpqn)/8d0
40106  ELSE
40107  xpqu=(xpqs+7.5d0*xpqn)/10d0
40108  xpqd=(xpqs-5d0*xpqn)/10d0
40109  ENDIF
40110 
40111 C...Put into output arrays.
40112  xpga(0)=aem*xpgl
40113  xpga(1)=aem*xpqd
40114  xpga(2)=aem*xpqu
40115  xpga(3)=aem*xpqd
40116  IF(nf.GE.4) xpga(4)=aem*xpqu
40117  IF(nf.GE.5) xpga(5)=aem*xpqd
40118  DO 110 kfl=1,6
40119  xpga(-kfl)=xpga(kfl)
40120  110 CONTINUE
40121 
40122  RETURN
40123  END
40124 
40125 C*********************************************************************
40126 
40127 C...PYGGAM
40128 C...Constructs the F2 and parton distributions of the photon
40129 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40130 C...For F2, c and b are included by the Bethe-Heitler formula;
40131 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40132 C...Contains the SaS sets 1D, 1M, 2D and 2M.
40133 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40134 
40135  SUBROUTINE pyggam(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40136 
40137 C...Double precision and integer declarations.
40138  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40139  IMPLICIT INTEGER(i-n)
40140  INTEGER pyk,pychge,pycomp
40141 C...Commonblocks.
40142  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
40143  &xpdir(-6:6)
40144  common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
40145  SAVE /pyint8/,/pyint9/
40146 C...Local arrays.
40147  dimension xpdfgm(-6:6),xpga(-6:6), vxpga(-6:6)
40148 C...Charm and bottom masses (low to compensate for J/psi etc.).
40149  DATA pmc/1.3d0/, pmb/4.6d0/
40150 C...alpha_em and alpha_em/(2*pi).
40151  DATA aem/0.007297d0/, aem2pi/0.0011614d0/
40152 C...Lambda value for 4 flavours.
40153  DATA alam/0.20d0/
40154 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40155  DATA fracu/0.8d0/
40156 C...VMD couplings f_V**2/(4*pi).
40157  DATA frho/2.20d0/, fomega/23.6d0/, fphi/18.4d0/
40158 C...Masses for rho (=omega) and phi.
40159  DATA pmrho/0.770d0/, pmphi/1.020d0/
40160 C...Number of points in integration for IP2=1.
40161  DATA nstep/100/
40162 
40163 C...Reset output.
40164  f2gm=0d0
40165  DO 100 kfl=-6,6
40166  xpdfgm(kfl)=0d0
40167  xpvmd(kfl)=0d0
40168  xpanl(kfl)=0d0
40169  xpanh(kfl)=0d0
40170  xpbeh(kfl)=0d0
40171  xpdir(kfl)=0d0
40172  vxpvmd(kfl)=0d0
40173  vxpanl(kfl)=0d0
40174  vxpanh(kfl)=0d0
40175  vxpdgm(kfl)=0d0
40176  100 CONTINUE
40177 
40178 C...Set Q0 cut-off parameter as function of set used.
40179  IF(iset.LE.2) THEN
40180  q0=0.6d0
40181  ELSE
40182  q0=2d0
40183  ENDIF
40184  q02=q0**2
40185 
40186 C...Scale choice for off-shell photon; common factors.
40187  q2a=q2
40188  facnor=1d0
40189  IF(ip2.EQ.1) THEN
40190  p2mx=p2+q02
40191  q2a=q2+p2*q02/max(q02,q2)
40192  facnor=log(q2/q02)/nstep
40193  ELSEIF(ip2.EQ.2) THEN
40194  p2mx=max(p2,q02)
40195  ELSEIF(ip2.EQ.3) THEN
40196  p2mx=p2+q02
40197  q2a=q2+p2*q02/max(q02,q2)
40198  ELSEIF(ip2.EQ.4) THEN
40199  p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
40200  & ((q2+p2)*(q02+p2)))
40201  ELSEIF(ip2.EQ.5) THEN
40202  p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
40203  & ((q2+p2)*(q02+p2)))
40204  p2mx=q0*sqrt(p2mxa)
40205  facnor=log(q2/p2mxa)/log(q2/p2mx)
40206  ELSEIF(ip2.EQ.6) THEN
40207  p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
40208  & ((q2+p2)*(q02+p2)))
40209  p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
40210  ELSE
40211  p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
40212  & ((q2+p2)*(q02+p2)))
40213  p2mx=q0*sqrt(p2mxa)
40214  p2mxb=p2mx
40215  p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
40216  p2mxb=max(0d0,1d0-p2/q2)*p2mxb+min(1d0,p2/q2)*p2mxa
40217  IF(abs(q2-q02).GT.1d-6) THEN
40218  facnor=log(q2/p2mxa)/log(q2/p2mxb)
40219  ELSEIF(p2.LT.q02) THEN
40220  facnor=q02**3/(q02+p2)/(q02**2-p2**2/2d0)
40221  ELSE
40222  facnor=1d0
40223  ENDIF
40224  ENDIF
40225 
40226 C...Call VMD parametrization for d quark and use to give rho, omega,
40227 C...phi. Note dipole dampening for off-shell photon.
40228  CALL pygvmd(iset,1,x,q2a,p2mx,alam,xpga,vxpga)
40229  xfval=vxpga(1)
40230  xpga(1)=xpga(2)
40231  xpga(-1)=xpga(-2)
40232  facud=aem*(1d0/frho+1d0/fomega)*(pmrho**2/(pmrho**2+p2))**2
40233  facs=aem*(1d0/fphi)*(pmphi**2/(pmphi**2+p2))**2
40234  DO 110 kfl=-5,5
40235  xpvmd(kfl)=(facud+facs)*xpga(kfl)
40236  110 CONTINUE
40237  xpvmd(1)=xpvmd(1)+(1d0-fracu)*facud*xfval
40238  xpvmd(2)=xpvmd(2)+fracu*facud*xfval
40239  xpvmd(3)=xpvmd(3)+facs*xfval
40240  xpvmd(-1)=xpvmd(-1)+(1d0-fracu)*facud*xfval
40241  xpvmd(-2)=xpvmd(-2)+fracu*facud*xfval
40242  xpvmd(-3)=xpvmd(-3)+facs*xfval
40243  vxpvmd(1)=(1d0-fracu)*facud*xfval
40244  vxpvmd(2)=fracu*facud*xfval
40245  vxpvmd(3)=facs*xfval
40246  vxpvmd(-1)=(1d0-fracu)*facud*xfval
40247  vxpvmd(-2)=fracu*facud*xfval
40248  vxpvmd(-3)=facs*xfval
40249 
40250  IF(ip2.NE.1) THEN
40251 C...Anomalous parametrizations for different strategies
40252 C...for off-shell photons; except full integration.
40253 
40254 C...Call anomalous parametrization for d + u + s.
40255  CALL pygano(-3,x,q2a,p2mx,alam,xpga,vxpga)
40256  DO 120 kfl=-5,5
40257  xpanl(kfl)=facnor*xpga(kfl)
40258  vxpanl(kfl)=facnor*vxpga(kfl)
40259  120 CONTINUE
40260 
40261 C...Call anomalous parametrization for c and b.
40262  CALL pygano(4,x,q2a,p2mx,alam,xpga,vxpga)
40263  DO 130 kfl=-5,5
40264  xpanh(kfl)=facnor*xpga(kfl)
40265  vxpanh(kfl)=facnor*vxpga(kfl)
40266  130 CONTINUE
40267  CALL pygano(5,x,q2a,p2mx,alam,xpga,vxpga)
40268  DO 140 kfl=-5,5
40269  xpanh(kfl)=xpanh(kfl)+facnor*xpga(kfl)
40270  vxpanh(kfl)=vxpanh(kfl)+facnor*vxpga(kfl)
40271  140 CONTINUE
40272 
40273  ELSE
40274 C...Special option: loop over flavours and integrate over k2.
40275  DO 170 kf=1,5
40276  DO 160 istep=1,nstep
40277  q2step=q02*(q2/q02)**((istep-0.5d0)/nstep)
40278  IF((kf.EQ.4.AND.q2step.LT.pmc**2).OR.
40279  & (kf.EQ.5.AND.q2step.LT.pmb**2)) goto 160
40280  CALL pygvmd(0,kf,x,q2,q2step,alam,xpga,vxpga)
40281  facq=aem2pi*(q2step/(q2step+p2))**2*facnor
40282  IF(mod(kf,2).EQ.0) facq=facq*(8d0/9d0)
40283  IF(mod(kf,2).EQ.1) facq=facq*(2d0/9d0)
40284  DO 150 kfl=-5,5
40285  IF(kf.LE.3) xpanl(kfl)=xpanl(kfl)+facq*xpga(kfl)
40286  IF(kf.GE.4) xpanh(kfl)=xpanh(kfl)+facq*xpga(kfl)
40287  IF(kf.LE.3) vxpanl(kfl)=vxpanl(kfl)+facq*vxpga(kfl)
40288  IF(kf.GE.4) vxpanh(kfl)=vxpanh(kfl)+facq*vxpga(kfl)
40289  150 CONTINUE
40290  160 CONTINUE
40291  170 CONTINUE
40292  ENDIF
40293 
40294 C...Call Bethe-Heitler term expression for charm and bottom.
40295  CALL pygbeh(4,x,q2,p2,pmc**2,xpbh)
40296  xpbeh(4)=xpbh
40297  xpbeh(-4)=xpbh
40298  CALL pygbeh(5,x,q2,p2,pmb**2,xpbh)
40299  xpbeh(5)=xpbh
40300  xpbeh(-5)=xpbh
40301 
40302 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40303  IF(iset.EQ.2.OR.iset.EQ.4) THEN
40304  CALL pygdir(x,q2,p2,q02,xpga)
40305  DO 180 kfl=-5,5
40306  xpdir(kfl)=xpga(kfl)
40307  180 CONTINUE
40308  ENDIF
40309 
40310 C...Store result in output array.
40311  DO 190 kfl=-5,5
40312  chsq=1d0/9d0
40313  IF(iabs(kfl).EQ.2.OR.iabs(kfl).EQ.4) chsq=4d0/9d0
40314  xpf2=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
40315  IF(kfl.NE.0) f2gm=f2gm+chsq*xpf2
40316  xpdfgm(kfl)=xpvmd(kfl)+xpanl(kfl)+xpanh(kfl)
40317  vxpdgm(kfl)=vxpvmd(kfl)+vxpanl(kfl)+vxpanh(kfl)
40318  190 CONTINUE
40319 
40320  RETURN
40321  END
40322 
40323 C*********************************************************************
40324 
40325 C...PYGVMD
40326 C...Evaluates the VMD parton distributions of a photon,
40327 C...evolved homogeneously from an initial scale P2 to Q2.
40328 C...Does not include dipole suppression factor.
40329 C...ISET is parton distribution set, see above;
40330 C...additionally ISET=0 is used for the evolution of an anomalous photon
40331 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40332 C...ALAM is the 4-flavour Lambda, which is automatically converted
40333 C...to 3- and 5-flavour equivalents as needed.
40334 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40335 
40336  SUBROUTINE pygvmd(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40337 
40338 C...Double precision and integer declarations.
40339  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40340  IMPLICIT INTEGER(i-n)
40341  INTEGER pyk,pychge,pycomp
40342 C...Local arrays and data.
40343  dimension xpga(-6:6), vxpga(-6:6)
40344  DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
40345 
40346 C...Reset output.
40347  DO 100 kfl=-6,6
40348  xpga(kfl)=0d0
40349  vxpga(kfl)=0d0
40350  100 CONTINUE
40351  kfa=iabs(kf)
40352 
40353 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40354  alam3=alam*(pmc/alam)**(2d0/27d0)
40355  alam5=alam*(alam/pmb)**(2d0/23d0)
40356  p2eff=max(p2,1.2d0*alam3**2)
40357  IF(kfa.EQ.4) p2eff=max(p2eff,pmc**2)
40358  IF(kfa.EQ.5) p2eff=max(p2eff,pmb**2)
40359  q2eff=max(q2,p2eff)
40360 
40361 C...Find number of flavours at lower and upper scale.
40362  nfp=4
40363  IF(p2eff.LT.pmc**2) nfp=3
40364  IF(p2eff.GT.pmb**2) nfp=5
40365  nfq=4
40366  IF(q2eff.LT.pmc**2) nfq=3
40367  IF(q2eff.GT.pmb**2) nfq=5
40368 
40369 C...Find s as sum of 3-, 4- and 5-flavour parts.
40370  s=0d0
40371  IF(nfp.EQ.3) THEN
40372  q2div=pmc**2
40373  IF(nfq.EQ.3) q2div=q2eff
40374  s=s+(6d0/27d0)*log(log(q2div/alam3**2)/log(p2eff/alam3**2))
40375  ENDIF
40376  IF(nfp.LE.4.AND.nfq.GE.4) THEN
40377  p2div=p2eff
40378  IF(nfp.EQ.3) p2div=pmc**2
40379  q2div=q2eff
40380  IF(nfq.EQ.5) q2div=pmb**2
40381  s=s+(6d0/25d0)*log(log(q2div/alam**2)/log(p2div/alam**2))
40382  ENDIF
40383  IF(nfq.EQ.5) THEN
40384  p2div=pmb**2
40385  IF(nfp.EQ.5) p2div=p2eff
40386  s=s+(6d0/23d0)*log(log(q2eff/alam5**2)/log(p2div/alam5**2))
40387  ENDIF
40388 
40389 C...Calculate frequent combinations of x and s.
40390  x1=1d0-x
40391  xl=-log(x)
40392  s2=s**2
40393  s3=s**3
40394  s4=s**4
40395 
40396 C...Evaluate homogeneous anomalous parton distributions below or
40397 C...above threshold.
40398  IF(iset.EQ.0) THEN
40399  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
40400  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
40401  xval = x * 1.5d0 * (x**2+x1**2)
40402  xglu = 0d0
40403  xsea = 0d0
40404  ELSE
40405  xval = (1.5d0/(1d0-0.197d0*s+4.33d0*s2)*x**2 +
40406  & (1.5d0+2.10d0*s)/(1d0+3.29d0*s)*x1**2 +
40407  & 5.23d0*s/(1d0+1.17d0*s+19.9d0*s3)*x*x1) *
40408  & x**(1d0/(1d0+1.5d0*s)) * (1d0-x**2)**(2.667d0*s)
40409  xglu = 4d0*s/(1d0+4.76d0*s+15.2d0*s2+29.3d0*s4) *
40410  & x**(-2.03d0*s/(1d0+2.44d0*s)) * (x1*xl)**(1.333d0*s) *
40411  & ((4d0*x**2+7d0*x+4d0)*x1/3d0 - 2d0*x*(1d0+x)*xl)
40412  xsea = s2/(1d0+4.54d0*s+8.19d0*s2+8.05d0*s3) *
40413  & x**(-1.54d0*s/(1d0+1.29d0*s)) * x1**(2.667d0*s) *
40414  & ((8d0-73d0*x+62d0*x**2)*x1/9d0 + (3d0-8d0*x**2/3d0)*x*xl +
40415  & (2d0*x-1d0)*x*xl**2)
40416  ENDIF
40417 
40418 C...Evaluate set 1D parton distributions below or above threshold.
40419  ELSEIF(iset.EQ.1) THEN
40420  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
40421  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
40422  xval = 1.294d0 * x**0.80d0 * x1**0.76d0
40423  xglu = 1.273d0 * x**0.40d0 * x1**1.76d0
40424  xsea = 0.100d0 * x1**3.76d0
40425  ELSE
40426  xval = 1.294d0/(1d0+0.252d0*s+3.079d0*s2) *
40427  & x**(0.80d0-0.13d0*s) * x1**(0.76d0+0.667d0*s) * xl**(2d0*s)
40428  xglu = 7.90d0*s/(1d0+5.50d0*s) * exp(-5.16d0*s) *
40429  & x**(-1.90d0*s/(1d0+3.60d0*s)) * x1**1.30d0 *
40430  & xl**(0.50d0+3d0*s) + 1.273d0 * exp(-10d0*s) *
40431  & x**0.40d0 * x1**(1.76d0+3d0*s)
40432  xsea = (0.1d0-0.397d0*s2+1.121d0*s3)/
40433  & (1d0+5.61d0*s2+5.26d0*s3) * x**(-7.32d0*s2/(1d0+10.3d0*s2)) *
40434  & x1**((3.76d0+15d0*s+12d0*s2)/(1d0+4d0*s))
40435  xsea0 = 0.100d0 * x1**3.76d0
40436  ENDIF
40437 
40438 C...Evaluate set 1M parton distributions below or above threshold.
40439  ELSEIF(iset.EQ.2) THEN
40440  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
40441  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
40442  xval = 0.8477d0 * x**0.51d0 * x1**1.37d0
40443  xglu = 3.42d0 * x**0.255d0 * x1**2.37d0
40444  xsea = 0d0
40445  ELSE
40446  xval = 0.8477d0/(1d0+1.37d0*s+2.18d0*s2+3.73d0*s3) *
40447  & x**(0.51d0+0.21d0*s) * x1**1.37d0 * xl**(2.667d0*s)
40448  xglu = 24d0*s/(1d0+9.6d0*s+0.92d0*s2+14.34d0*s3) *
40449  & exp(-5.94d0*s) * x**((-0.013d0-1.80d0*s)/(1d0+3.14d0*s)) *
40450  & x1**(2.37d0+0.4d0*s) * xl**(0.32d0+3.6d0*s) + 3.42d0 *
40451  & exp(-12d0*s) * x**0.255d0 * x1**(2.37d0+3d0*s)
40452  xsea = 0.842d0*s/(1d0+21.3d0*s-33.2d0*s2+229d0*s3) *
40453  & x**((0.13d0-2.90d0*s)/(1d0+5.44d0*s)) * x1**(3.45d0+0.5d0*s) *
40454  & xl**(2.8d0*s)
40455  xsea0 = 0d0
40456  ENDIF
40457 
40458 C...Evaluate set 2D parton distributions below or above threshold.
40459  ELSEIF(iset.EQ.3) THEN
40460  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
40461  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
40462  xval = x**0.46d0 * x1**0.64d0 + 0.76d0 * x
40463  xglu = 1.925d0 * x1**2
40464  xsea = 0.242d0 * x1**4
40465  ELSE
40466  xval = (1d0+0.186d0*s)/(1d0-0.209d0*s+1.495d0*s2) *
40467  & x**(0.46d0+0.25d0*s) *
40468  & x1**((0.64d0+0.14d0*s+5d0*s2)/(1d0+s)) * xl**(1.9d0*s) +
40469  & (0.76d0+0.4d0*s) * x * x1**(2.667d0*s)
40470  xglu = (1.925d0+5.55d0*s+147d0*s2)/(1d0-3.59d0*s+3.32d0*s2) *
40471  & exp(-18.67d0*s) *
40472  & x**((-5.81d0*s-5.34d0*s2)/(1d0+29d0*s-4.26d0*s2))
40473  & * x1**((2d0-5.9d0*s)/(1d0+1.7d0*s)) *
40474  & xl**(9.3d0*s/(1d0+1.7d0*s))
40475  xsea = (0.242d0-0.252d0*s+1.19d0*s2)/
40476  & (1d0-0.607d0*s+21.95d0*s2) *
40477  & x**(-12.1d0*s2/(1d0+2.62d0*s+16.7d0*s2)) * x1**4 * xl**s
40478  xsea0 = 0.242d0 * x1**4
40479  ENDIF
40480 
40481 C...Evaluate set 2M parton distributions below or above threshold.
40482  ELSEIF(iset.EQ.4) THEN
40483  IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
40484  & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
40485  xval = 1.168d0 * x**0.50d0 * x1**2.60d0 + 0.965d0 * x
40486  xglu = 1.808d0 * x1**2
40487  xsea = 0.209d0 * x1**4
40488  ELSE
40489  xval = (1.168d0+1.771d0*s+29.35d0*s2) * exp(-5.776d0*s) *
40490  & x**((0.5d0+0.208d0*s)/(1d0-0.794d0*s+1.516d0*s2)) *
40491  & x1**((2.6d0+7.6d0*s)/(1d0+5d0*s)) *
40492  & xl**(5.15d0*s/(1d0+2d0*s)) +
40493  & (0.965d0+22.35d0*s)/(1d0+18.4d0*s) * x * x1**(2.667d0*s)
40494  xglu = (1.808d0+29.9d0*s)/(1d0+26.4d0*s) * exp(-5.28d0*s) *
40495  & x**((-5.35d0*s-10.11d0*s2)/(1d0+31.71d0*s)) *
40496  & x1**((2d0-7.3d0*s+4d0*s2)/(1d0+2.5d0*s)) *
40497  & xl**(10.9d0*s/(1d0+2.5d0*s))
40498  xsea = (0.209d0+0.644d0*s2)/(1d0+0.319d0*s+17.6d0*s2) *
40499  & x**((-0.373d0*s-7.71d0*s2)/(1d0+0.815d0*s+11.0d0*s2)) *
40500  & x1**(4d0+s) * xl**(0.45d0*s)
40501  xsea0 = 0.209d0 * x1**4
40502  ENDIF
40503  ENDIF
40504 
40505 C...Threshold factors for c and b sea.
40506  sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
40507  xchm=0d0
40508  IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
40509  sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
40510  IF(iset.EQ.0) THEN
40511  xchm=xsea*(1d0-(sch/sll)**2)
40512  ELSE
40513  xchm=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sch/sll)
40514  ENDIF
40515  ENDIF
40516  xbot=0d0
40517  IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
40518  sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
40519  IF(iset.EQ.0) THEN
40520  xbot=xsea*(1d0-(sbt/sll)**2)
40521  ELSE
40522  xbot=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sbt/sll)
40523  ENDIF
40524  ENDIF
40525 
40526 C...Fill parton distributions.
40527  xpga(0)=xglu
40528  xpga(1)=xsea
40529  xpga(2)=xsea
40530  xpga(3)=xsea
40531  xpga(4)=xchm
40532  xpga(5)=xbot
40533  xpga(kfa)=xpga(kfa)+xval
40534  DO 110 kfl=1,5
40535  xpga(-kfl)=xpga(kfl)
40536  110 CONTINUE
40537  vxpga(kfa)=xval
40538  vxpga(-kfa)=xval
40539 
40540  RETURN
40541  END
40542 
40543 C*********************************************************************
40544 
40545 C...PYGANO
40546 C...Evaluates the parton distributions of the anomalous photon,
40547 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
40548 C...KF=0 gives the sum over (up to) 5 flavours,
40549 C...KF<0 limits to flavours up to abs(KF),
40550 C...KF>0 is for flavour KF only.
40551 C...ALAM is the 4-flavour Lambda, which is automatically converted
40552 C...to 3- and 5-flavour equivalents as needed.
40553 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40554 
40555  SUBROUTINE pygano(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40556 
40557 C...Double precision and integer declarations.
40558  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40559  IMPLICIT INTEGER(i-n)
40560  INTEGER pyk,pychge,pycomp
40561 C...Local arrays and data.
40562  dimension xpga(-6:6), vxpga(-6:6), alamsq(3:5)
40563  DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
40564 
40565 C...Reset output.
40566  DO 100 kfl=-6,6
40567  xpga(kfl)=0d0
40568  vxpga(kfl)=0d0
40569  100 CONTINUE
40570  IF(q2.LE.p2) RETURN
40571  kfa=iabs(kf)
40572 
40573 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40574  alamsq(3)=(alam*(pmc/alam)**(2d0/27d0))**2
40575  alamsq(4)=alam**2
40576  alamsq(5)=(alam*(alam/pmb)**(2d0/23d0))**2
40577  p2eff=max(p2,1.2d0*alamsq(3))
40578  IF(kf.EQ.4) p2eff=max(p2eff,pmc**2)
40579  IF(kf.EQ.5) p2eff=max(p2eff,pmb**2)
40580  q2eff=max(q2,p2eff)
40581  xl=-log(x)
40582 
40583 C...Find number of flavours at lower and upper scale.
40584  nfp=4
40585  IF(p2eff.LT.pmc**2) nfp=3
40586  IF(p2eff.GT.pmb**2) nfp=5
40587  nfq=4
40588  IF(q2eff.LT.pmc**2) nfq=3
40589  IF(q2eff.GT.pmb**2) nfq=5
40590 
40591 C...Define range of flavour loop.
40592  IF(kf.EQ.0) THEN
40593  kflmn=1
40594  kflmx=5
40595  ELSEIF(kf.LT.0) THEN
40596  kflmn=1
40597  kflmx=kfa
40598  ELSE
40599  kflmn=kfa
40600  kflmx=kfa
40601  ENDIF
40602 
40603 C...Loop over flavours the photon can branch into.
40604  DO 110 kfl=kflmn,kflmx
40605 
40606 C...Light flavours: calculate t range and (approximate) s range.
40607  IF(kfl.LE.3.AND.(kfl.EQ.1.OR.kfl.EQ.kf)) THEN
40608  tdiff=log(q2eff/p2eff)
40609  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
40610  & log(p2eff/alamsq(nfq)))
40611  IF(nfq.GT.nfp) THEN
40612  q2div=pmb**2
40613  IF(nfq.EQ.4) q2div=pmc**2
40614  snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
40615  & log(p2eff/alamsq(nfq)))
40616  snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
40617  & log(p2eff/alamsq(nfq-1)))
40618  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
40619  ENDIF
40620  IF(nfq.EQ.5.AND.nfp.EQ.3) THEN
40621  q2div=pmc**2
40622  snf4=(6d0/(33d0-2d0*4))*log(log(q2div/alamsq(4))/
40623  & log(p2eff/alamsq(4)))
40624  snf3=(6d0/(33d0-2d0*3))*log(log(q2div/alamsq(3))/
40625  & log(p2eff/alamsq(3)))
40626  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snf3-snf4)
40627  ENDIF
40628 
40629 C...u and s quark do not need a separate treatment when d has been done.
40630  ELSEIF(kfl.EQ.2.OR.kfl.EQ.3) THEN
40631 
40632 C...Charm: as above, but only include range above c threshold.
40633  ELSEIF(kfl.EQ.4) THEN
40634  IF(q2.LE.pmc**2) goto 110
40635  p2eff=max(p2eff,pmc**2)
40636  q2eff=max(q2eff,p2eff)
40637  tdiff=log(q2eff/p2eff)
40638  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
40639  & log(p2eff/alamsq(nfq)))
40640  IF(nfq.EQ.5.AND.nfp.EQ.4) THEN
40641  q2div=pmb**2
40642  snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
40643  & log(p2eff/alamsq(nfq)))
40644  snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
40645  & log(p2eff/alamsq(nfq-1)))
40646  s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
40647  ENDIF
40648 
40649 C...Bottom: as above, but only include range above b threshold.
40650  ELSEIF(kfl.EQ.5) THEN
40651  IF(q2.LE.pmb**2) goto 110
40652  p2eff=max(p2eff,pmb**2)
40653  q2eff=max(q2,p2eff)
40654  tdiff=log(q2eff/p2eff)
40655  s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
40656  & log(p2eff/alamsq(nfq)))
40657  ENDIF
40658 
40659 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
40660  chsq=1d0/9d0
40661  IF(kfl.EQ.2.OR.kfl.EQ.4) chsq=4d0/9d0
40662  fac=aem2pi*2d0*chsq*tdiff
40663 
40664 C...Evaluate parton distributions (normalized to unit momentum sum).
40665  IF(kfl.EQ.1.OR.kfl.EQ.4.OR.kfl.EQ.5.OR.kfl.EQ.kf) THEN
40666  xval= ((1.5d0+2.49d0*s+26.9d0*s**2)/(1d0+32.3d0*s**2)*x**2 +
40667  & (1.5d0-0.49d0*s+7.83d0*s**2)/(1d0+7.68d0*s**2)*(1d0-x)**2 +
40668  & 1.5d0*s/(1d0-3.2d0*s+7d0*s**2)*x*(1d0-x)) *
40669  & x**(1d0/(1d0+0.58d0*s)) * (1d0-x**2)**(2.5d0*s/(1d0+10d0*s))
40670  xglu= 2d0*s/(1d0+4d0*s+7d0*s**2) *
40671  & x**(-1.67d0*s/(1d0+2d0*s)) * (1d0-x**2)**(1.2d0*s) *
40672  & ((4d0*x**2+7d0*x+4d0)*(1d0-x)/3d0 - 2d0*x*(1d0+x)*xl)
40673  xsea= 0.333d0*s**2/(1d0+4.90d0*s+4.69d0*s**2+21.4d0*s**3) *
40674  & x**(-1.18d0*s/(1d0+1.22d0*s)) * (1d0-x)**(1.2d0*s) *
40675  & ((8d0-73d0*x+62d0*x**2)*(1d0-x)/9d0 +
40676  & (3d0-8d0*x**2/3d0)*x*xl + (2d0*x-1d0)*x*xl**2)
40677 
40678 C...Threshold factors for c and b sea.
40679  sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
40680  xchm=0d0
40681  IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
40682  sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
40683  xchm=xsea*(1d0-(sch/sll)**3)
40684  ENDIF
40685  xbot=0d0
40686  IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
40687  sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
40688  xbot=xsea*(1d0-(sbt/sll)**3)
40689  ENDIF
40690  ENDIF
40691 
40692 C...Add contribution of each valence flavour.
40693  xpga(0)=xpga(0)+fac*xglu
40694  xpga(1)=xpga(1)+fac*xsea
40695  xpga(2)=xpga(2)+fac*xsea
40696  xpga(3)=xpga(3)+fac*xsea
40697  xpga(4)=xpga(4)+fac*xchm
40698  xpga(5)=xpga(5)+fac*xbot
40699  xpga(kfl)=xpga(kfl)+fac*xval
40700  vxpga(kfl)=vxpga(kfl)+fac*xval
40701  110 CONTINUE
40702  DO 120 kfl=1,5
40703  xpga(-kfl)=xpga(kfl)
40704  vxpga(-kfl)=vxpga(kfl)
40705  120 CONTINUE
40706 
40707  RETURN
40708  END
40709 
40710 
40711 C*********************************************************************
40712 
40713 C...PYGBEH
40714 C...Evaluates the Bethe-Heitler cross section for heavy flavour
40715 C...production.
40716 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40717 
40718  SUBROUTINE pygbeh(KF,X,Q2,P2,PM2,XPBH)
40719 
40720 C...Double precision and integer declarations.
40721  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40722  IMPLICIT INTEGER(i-n)
40723  INTEGER pyk,pychge,pycomp
40724 
40725 C...Local data.
40726  DATA aem2pi/0.0011614d0/
40727 
40728 C...Reset output.
40729  xpbh=0d0
40730  sigbh=0d0
40731 
40732 C...Check kinematics limits.
40733  IF(x.GE.q2/(4d0*pm2+q2+p2)) RETURN
40734  w2=q2*(1d0-x)/x-p2
40735  beta2=1d0-4d0*pm2/w2
40736  IF(beta2.LT.1d-10) RETURN
40737  beta=sqrt(beta2)
40738  rmq=4d0*pm2/q2
40739 
40740 C...Simple case: P2 = 0.
40741  IF(p2.LT.1d-4) THEN
40742  IF(beta.LT.0.99d0) THEN
40743  xbl=log((1d0+beta)/(1d0-beta))
40744  ELSE
40745  xbl=log((1d0+beta)**2*w2/(4d0*pm2))
40746  ENDIF
40747  sigbh=beta*(8d0*x*(1d0-x)-1d0-rmq*x*(1d0-x))+
40748  & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)
40749 
40750 C...Complicated case: P2 > 0, based on approximation of
40751 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40752  ELSE
40753  rpq=1d0-4d0*x**2*p2/q2
40754  IF(rpq.GT.1d-10) THEN
40755  rpbe=sqrt(rpq*beta2)
40756  IF(rpbe.LT.0.99d0) THEN
40757  xbl=log((1d0+rpbe)/(1d0-rpbe))
40758  xbi=2d0*rpbe/(1d0-rpbe**2)
40759  ELSE
40760  rpbesn=4d0*pm2/w2+(4d0*x**2*p2/q2)*beta2
40761  xbl=log((1d0+rpbe)**2/rpbesn)
40762  xbi=2d0*rpbe/rpbesn
40763  ENDIF
40764  sigbh=beta*(6d0*x*(1d0-x)-1d0)+
40765  & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)+
40766  & xbi*(2d0*x/q2)*(pm2*x*(2d0-rmq)-p2*x)
40767  ENDIF
40768  ENDIF
40769 
40770 C...Multiply by charge-squared etc. to get parton distribution.
40771  chsq=1d0/9d0
40772  IF(iabs(kf).EQ.2.OR.iabs(kf).EQ.4) chsq=4d0/9d0
40773  xpbh=3d0*chsq*aem2pi*x*sigbh
40774 
40775  RETURN
40776  END
40777 
40778 C*********************************************************************
40779 
40780 C...PYGDIR
40781 C...Evaluates the direct contribution, i.e. the C^gamma term,
40782 C...as needed in MSbar parametrizations.
40783 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40784 
40785  SUBROUTINE pygdir(X,Q2,P2,Q02,XPGA)
40786 
40787 C...Double precision and integer declarations.
40788  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40789  IMPLICIT INTEGER(i-n)
40790  INTEGER pyk,pychge,pycomp
40791 C...Local array and data.
40792  dimension xpga(-6:6)
40793  DATA pmc/1.3d0/, pmb/4.6d0/, aem2pi/0.0011614d0/
40794 
40795 C...Reset output.
40796  DO 100 kfl=-6,6
40797  xpga(kfl)=0d0
40798  100 CONTINUE
40799 
40800 C...Evaluate common x-dependent expression.
40801  xtmp = (x**2+(1d0-x)**2) * (-log(x)) - 1d0
40802  cgam = 3d0*aem2pi*x * (xtmp*(1d0+p2/(p2+q02)) + 6d0*x*(1d0-x))
40803 
40804 C...d, u, s part by simple charge factor.
40805  xpga(1)=(1d0/9d0)*cgam
40806  xpga(2)=(4d0/9d0)*cgam
40807  xpga(3)=(1d0/9d0)*cgam
40808 
40809 C...Also fill for antiquarks.
40810  DO 110 kf=1,5
40811  xpga(-kf)=xpga(kf)
40812  110 CONTINUE
40813 
40814  RETURN
40815  END
40816 
40817 C*********************************************************************
40818 
40819 C...PYPDPI
40820 C...Gives pi+ parton distribution according to two different
40821 C...parametrizations.
40822 
40823  SUBROUTINE pypdpi(X,Q2,XPPI)
40824 
40825 C...Double precision and integer declarations.
40826  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40827  IMPLICIT INTEGER(i-n)
40828  INTEGER pyk,pychge,pycomp
40829 C...Commonblocks.
40830  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40831  common/pypars/mstp(200),parp(200),msti(200),pari(200)
40832  common/pyint1/mint(400),vint(400)
40833  SAVE /pydat1/,/pypars/,/pyint1/
40834 C...Local arrays.
40835  dimension xppi(-6:6),cow(3,5,4,2),xq(9),ts(6)
40836 
40837 C...The following data lines are coefficients needed in the
40838 C...Owens pion parton distribution parametrizations, see below.
40839 C...Expansion coefficients for up and down valence quark distributions.
40840  DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/
40841  &4.0000d-01, 7.0000d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40842  &-6.2120d-02, 6.4780d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40843  &-7.1090d-03, 1.3350d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
40844  DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/
40845  &4.0000d-01, 6.2800d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40846  &-5.9090d-02, 6.4360d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40847  &-6.5240d-03, 1.4510d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
40848 C...Expansion coefficients for gluon distribution.
40849  DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/
40850  &8.8800d-01, 0.0000d+00, 3.1100d+00, 6.0000d+00, 0.0000d+00,
40851  &-1.8020d+00, -1.5760d+00, -1.3170d-01, 2.8010d+00, -1.7280d+01,
40852  &1.8120d+00, 1.2000d+00, 5.0680d-01, -1.2160d+01, 2.0490d+01/
40853  DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/
40854  &7.9400d-01, 0.0000d+00, 2.8900d+00, 6.0000d+00, 0.0000d+00,
40855  &-9.1440d-01, -1.2370d+00, 5.9660d-01, -3.6710d+00, -8.1910d+00,
40856  &5.9660d-01, 6.5820d-01, -2.5500d-01, -2.3040d+00, 7.7580d+00/
40857 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40858  DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/
40859  &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
40860  &-2.4280d-01, -2.1200d-01, 8.6730d-01, 1.2660d+00, 2.3820d+00,
40861  &1.3860d-01, 3.6710d-03, 4.7470d-02, -2.2150d+00, 3.4820d-01/
40862  DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/
40863  &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
40864  &-1.4170d-01, -1.6970d-01, -2.4740d+00, -2.5340d+00, 5.6210d-01,
40865  &-1.7400d-01, -9.6230d-02, 1.5750d+00, 1.3780d+00, -2.7010d-01/
40866 C...Expansion coefficients for charm quark sea distribution.
40867  DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/
40868  &0.0000d+00, -2.2120d-02, 2.8940d+00, 0.0000d+00, 0.0000d+00,
40869  &7.9280d-02, -3.7850d-01, 9.4330d+00, 5.2480d+00, 8.3880d+00,
40870  &-6.1340d-02, -1.0880d-01, -1.0852d+01, -7.1870d+00, -1.1610d+01/
40871  DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/
40872  &0.0000d+00, -8.8200d-02, 1.9240d+00, 0.0000d+00, 0.0000d+00,
40873  &6.2290d-02, -2.8920d-01, 2.4240d-01, -4.4630d+00, -8.3670d-01,
40874  &-4.0990d-02, -1.0820d-01, 2.0360d+00, 5.2090d+00, -4.8400d-02/
40875 
40876 C...Euler's beta function, requires ordinary Gamma function
40877  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
40878 
40879 C...Reset output array.
40880  DO 100 kfl=-6,6
40881  xppi(kfl)=0d0
40882  100 CONTINUE
40883 
40884  IF(mstp(53).LE.2) THEN
40885 C...Pion parton distributions from Owens.
40886 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40887 
40888 C...Determine set, Lambda and s expansion variable.
40889  nset=mstp(53)
40890  IF(nset.EQ.1) alam=0.2d0
40891  IF(nset.EQ.2) alam=0.4d0
40892  vint(231)=4d0
40893  IF(mstp(57).LE.0) THEN
40894  sd=0d0
40895  ELSE
40896  q2in=min(2d3,max(4d0,q2))
40897  sd=log(log(q2in/alam**2)/log(4d0/alam**2))
40898  ENDIF
40899 
40900 C...Calculate parton distributions.
40901  DO 120 kfl=1,4
40902  DO 110 is=1,5
40903  ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+
40904  & cow(3,is,kfl,nset)*sd**2
40905  110 CONTINUE
40906  IF(kfl.EQ.1) THEN
40907  xq(kfl)=x**ts(1)*(1d0-x)**ts(2)/eulbet(ts(1),ts(2)+1d0)
40908  ELSE
40909  xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
40910  & ts(5)*x**2)
40911  ENDIF
40912  120 CONTINUE
40913 
40914 C...Put into output array.
40915  xppi(0)=xq(2)
40916  xppi(1)=xq(3)/6d0
40917  xppi(2)=xq(1)+xq(3)/6d0
40918  xppi(3)=xq(3)/6d0
40919  xppi(4)=xq(4)
40920  xppi(-1)=xq(1)+xq(3)/6d0
40921  xppi(-2)=xq(3)/6d0
40922  xppi(-3)=xq(3)/6d0
40923  xppi(-4)=xq(4)
40924 
40925 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40926 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40927 C...10^-5 < x < 1.
40928  ELSE
40929 
40930 C...Determine s expansion variable and some x expressions.
40931  vint(231)=0.25d0
40932  IF(mstp(57).LE.0) THEN
40933  sd=0d0
40934  ELSE
40935  q2in=min(1d8,max(0.25d0,q2))
40936  sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
40937  ENDIF
40938  sd2=sd**2
40939  xl=-log(x)
40940  xs=sqrt(x)
40941 
40942 C...Evaluate valence, gluon and sea distributions.
40943  xfval=(0.519d0+0.180d0*sd-0.011d0*sd2)*x**(0.499d0-0.027d0*sd)*
40944  & (1d0+(0.381d0-0.419d0*sd)*xs)*(1d0-x)**(0.367d0+0.563d0*sd)
40945  xfglu=(x**(0.482d0+0.341d0*sqrt(sd))*((0.678d0+0.877d0*
40946  & sd-0.175d0*sd2)+
40947  & (0.338d0-1.597d0*sd)*xs+(-0.233d0*sd+0.406d0*sd2)*x)+
40948  & sd**0.599d0*exp(-(0.618d0+2.070d0*sd)+sqrt(3.676d0*sd**1.263d0*
40949  & xl)))*
40950  & (1d0-x)**(0.390d0+1.053d0*sd)
40951  xfsea=sd**0.55d0*(1d0-0.748d0*xs+(0.313d0+0.935d0*sd)*x)*(1d0-
40952  & x)**3.359d0*
40953  & exp(-(4.433d0+1.301d0*sd)+sqrt((9.30d0-0.887d0*sd)*sd**0.56d0*
40954  & xl))/
40955  & xl**(2.538d0-0.763d0*sd)
40956  IF(sd.LE.0.888d0) THEN
40957  xfchm=0d0
40958  ELSE
40959  xfchm=(sd-0.888d0)**1.02d0*(1d0+1.008d0*x)*(1d0-x)**(1.208d0+
40960  & 0.771d0*sd)*
40961  & exp(-(4.40d0+1.493d0*sd)+sqrt((2.032d0+1.901d0*sd)*sd**0.39d0*
40962  & xl))
40963  ENDIF
40964  IF(sd.LE.1.351d0) THEN
40965  xfbot=0d0
40966  ELSE
40967  xfbot=(sd-1.351d0)**1.03d0*(1d0-x)**(0.697d0+0.855d0*sd)*
40968  & exp(-(4.51d0+1.490d0*sd)+sqrt((3.056d0+1.694d0*sd)*sd**0.39d0*
40969  & xl))
40970  ENDIF
40971 
40972 C...Put into output array.
40973  xppi(0)=xfglu
40974  xppi(1)=xfsea
40975  xppi(2)=xfsea
40976  xppi(3)=xfsea
40977  xppi(4)=xfchm
40978  xppi(5)=xfbot
40979  DO 130 kfl=1,5
40980  xppi(-kfl)=xppi(kfl)
40981  130 CONTINUE
40982  xppi(2)=xppi(2)+xfval
40983  xppi(-1)=xppi(-1)+xfval
40984  ENDIF
40985 
40986  RETURN
40987  END
40988 
40989 C*********************************************************************
40990 
40991 C...PYPDPR
40992 C...Gives proton parton distributions according to a few different
40993 C...parametrizations.
40994 
40995  SUBROUTINE pypdpr(X,Q2,XPPR)
40996 
40997 C...Double precision and integer declarations.
40998  IMPLICIT DOUBLE PRECISION(a-h, o-z)
40999  IMPLICIT INTEGER(i-n)
41000  INTEGER pyk,pychge,pycomp
41001 C...Commonblocks.
41002  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41003  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
41004  common/pypars/mstp(200),parp(200),msti(200),pari(200)
41005  common/pyint1/mint(400),vint(400)
41006  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
41007 C...Arrays and data.
41008  dimension xppr(-6:6),q2min(16)
41009  DATA q2min/ 2.56d0, 2.56d0, 2.56d0, 0.4d0, 0.4d0, 0.4d0,
41010  &1.0d0, 1.0d0, 2*0d0, 0.25d0, 5d0, 5d0, 4d0, 4d0, 0d0/
41011 
41012 C...Reset output array.
41013  DO 100 kfl=-6,6
41014  xppr(kfl)=0d0
41015  100 CONTINUE
41016 
41017 C...Common preliminaries.
41018  nset=max(1,min(16,mstp(51)))
41019  IF(nset.EQ.9.OR.nset.EQ.10) nset=6
41020  vint(231)=q2min(nset)
41021  IF(mstp(57).EQ.0) THEN
41022  q2l=q2min(nset)
41023  ELSE
41024  q2l=max(q2min(nset),q2)
41025  ENDIF
41026 
41027  IF(nset.GE.1.AND.nset.LE.3) THEN
41028 C...Interface to the CTEQ 3 parton distributions.
41029  qrt=sqrt(max(1d0,q2l))
41030 
41031 C...Loop over flavours.
41032  DO 110 i=-6,6
41033  IF(i.LE.0) THEN
41034  xppr(i)=pycteq(nset,i,x,qrt)
41035  ELSEIF(i.LE.2) THEN
41036  xppr(i)=pycteq(nset,i,x,qrt)+xppr(-i)
41037  ELSE
41038  xppr(i)=xppr(-i)
41039  ENDIF
41040  110 CONTINUE
41041 
41042  ELSEIF(nset.GE.4.AND.nset.LE.6) THEN
41043 C...Interface to the GRV 94 distributions.
41044  IF(nset.EQ.4) THEN
41045  CALL pygrvl(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
41046  ELSEIF(nset.EQ.5) THEN
41047  CALL pygrvm(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
41048  ELSE
41049  CALL pygrvd(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
41050  ENDIF
41051 
41052 C...Put into output array.
41053  xppr(0)=gl
41054  xppr(-1)=0.5d0*(udb+del)
41055  xppr(-2)=0.5d0*(udb-del)
41056  xppr(-3)=sb
41057  xppr(-4)=chm
41058  xppr(-5)=bot
41059  xppr(1)=dv+xppr(-1)
41060  xppr(2)=uv+xppr(-2)
41061  xppr(3)=sb
41062  xppr(4)=chm
41063  xppr(5)=bot
41064 
41065  ELSEIF(nset.EQ.7) THEN
41066 C...Interface to the CTEQ 5L parton distributions.
41067 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
41068 C...freezing x*f(x,Q2) at borders.
41069  qrt=sqrt(max(1d0,min(1d8,q2l)))
41070  xin=max(1d-6,min(1d0,x))
41071 
41072 C...Loop over flavours (with u <-> d notation mismatch).
41073  sumudb=pyct5l(-1,xin,qrt)
41074  ratudb=pyct5l(-2,xin,qrt)
41075  DO 120 i=-5,2
41076  IF(i.EQ.1) THEN
41077  xppr(i)=xin*pyct5l(2,xin,qrt)
41078  ELSEIF(i.EQ.2) THEN
41079  xppr(i)=xin*pyct5l(1,xin,qrt)
41080  ELSEIF(i.EQ.-1) THEN
41081  xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
41082  ELSEIF(i.EQ.-2) THEN
41083  xppr(i)=xin*sumudb/(1d0+ratudb)
41084  ELSE
41085  xppr(i)=xin*pyct5l(i,xin,qrt)
41086  IF(i.LT.0) xppr(-i)=xppr(i)
41087  ENDIF
41088  120 CONTINUE
41089 
41090  ELSEIF(nset.EQ.8) THEN
41091 C...Interface to the CTEQ 5M1 parton distributions.
41092  qrt=sqrt(max(1d0,min(1d8,q2l)))
41093  xin=max(1d-6,min(1d0,x))
41094 
41095 C...Loop over flavours (with u <-> d notation mismatch).
41096  sumudb=pyct5m(-1,xin,qrt)
41097  ratudb=pyct5m(-2,xin,qrt)
41098  DO 130 i=-5,2
41099  IF(i.EQ.1) THEN
41100  xppr(i)=xin*pyct5m(2,xin,qrt)
41101  ELSEIF(i.EQ.2) THEN
41102  xppr(i)=xin*pyct5m(1,xin,qrt)
41103  ELSEIF(i.EQ.-1) THEN
41104  xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
41105  ELSEIF(i.EQ.-2) THEN
41106  xppr(i)=xin*sumudb/(1d0+ratudb)
41107  ELSE
41108  xppr(i)=xin*pyct5m(i,xin,qrt)
41109  IF(i.LT.0) xppr(-i)=xppr(i)
41110  ENDIF
41111  130 CONTINUE
41112 
41113  ELSEIF(nset.GE.11.AND.nset.LE.15) THEN
41114 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
41115 C...obsolete but offers backwards compatibility.
41116  CALL pypdpo(x,q2l,xppr)
41117 
41118 C...Symmetric choice for debugging only
41119  ELSEIF(nset.EQ.16) THEN
41120  xppr(0)=.5d0/x
41121  xppr(1)=.05d0/x
41122  xppr(2)=.05d0/x
41123  xppr(3)=.05d0/x
41124  xppr(4)=.05d0/x
41125  xppr(5)=.05d0/x
41126  xppr(-1)=.05d0/x
41127  xppr(-2)=.05d0/x
41128  xppr(-3)=.05d0/x
41129  xppr(-4)=.05d0/x
41130  xppr(-5)=.05d0/x
41131 
41132  ENDIF
41133 
41134  RETURN
41135  END
41136 
41137 C*********************************************************************
41138 
41139 C...PYCTEQ
41140 C...Gives the CTEQ 3 parton distribution function sets in
41141 C...parametrized form, of October 24, 1994.
41142 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
41143 C...J. Qiu, W.K. Tung and H. Weerts.
41144 
41145  FUNCTION pycteq (ISET, IPRT, X, Q)
41146 
41147 C...Double precision declaration.
41148  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41149  IMPLICIT INTEGER(i-n)
41150 
41151 C...Data on Lambda values of fits, minimum Q and quark masses.
41152  dimension alm(3), qms(4:6)
41153  DATA alm / 0.177d0, 0.239d0, 0.247d0 /
41154  DATA qmn / 1.60d0 /, (qms(i), i=4,6) / 1.60d0, 5.00d0, 180.0d0 /
41155 
41156 C....Check flavour thresholds. Set up QI for SB.
41157  ip = iabs(iprt)
41158  IF(ip .GE. 4) THEN
41159  IF(q .LE. qms(ip)) THEN
41160  pycteq = 0d0
41161  RETURN
41162  ENDIF
41163  qi = qms(ip)
41164  ELSE
41165  qi = qmn
41166  ENDIF
41167 
41168 C...Use "standard lambda" of parametrization program for expansion.
41169  alam = alm(iset)
41170  sbl = log(q/alam) / log(qi/alam)
41171  sb = log(sbl)
41172  sb2 = sb*sb
41173  sb3 = sb2*sb
41174 
41175 C...Expansion for CTEQ3L.
41176  IF(iset .EQ. 1) THEN
41177  IF(iprt .EQ. 2) THEN
41178  a0=exp( 0.1907d+00+0.4205d-01*sb +0.2752d+00*sb2-
41179  & 0.3171d+00*sb3)
41180  a1= 0.4611d+00+0.2331d-01*sb -0.3403d-01*sb2+0.3174d-01*sb3
41181  a2= 0.3504d+01+0.5739d+00*sb +0.2676d+00*sb2-0.1553d+00*sb3
41182  a3= 0.7452d+01-0.6742d+01*sb +0.2849d+01*sb2-0.1964d+00*sb3
41183  a4= 0.1116d+01-0.3435d+00*sb +0.2865d+00*sb2-0.1288d+00*sb3
41184  a5= 0.6659d-01+0.2714d+00*sb -0.2688d+00*sb2+0.2763d+00*sb3
41185  ELSEIF(iprt .EQ. 1) THEN
41186  a0=exp( 0.1141d+00+0.4764d+00*sb -0.1745d+01*sb2+
41187  & 0.7728d+00*sb3)
41188  a1= 0.4275d+00-0.1290d+00*sb +0.3609d+00*sb2-0.1689d+00*sb3
41189  a2= 0.3000d+01+0.2946d+01*sb -0.4117d+01*sb2+0.1989d+01*sb3
41190  a3=-0.1302d+01+0.2322d+01*sb -0.4258d+01*sb2+0.2109d+01*sb3
41191  a4= 0.2586d+01-0.1920d+00*sb -0.3754d+00*sb2+0.2731d+00*sb3
41192  a5=-0.2251d+00-0.5374d+00*sb +0.2245d+01*sb2-0.1034d+01*sb3
41193  ELSEIF(iprt .EQ. 0) THEN
41194  a0=exp(-0.7631d+00-0.7241d+00*sb -0.1170d+01*sb2+
41195  & 0.5343d+00*sb3)
41196  a1=-0.3573d+00+0.3469d+00*sb -0.3396d+00*sb2+0.9188d-01*sb3
41197  a2= 0.5604d+01+0.7458d+00*sb -0.5082d+00*sb2+0.1844d+00*sb3
41198  a3= 0.1549d+02-0.1809d+02*sb +0.1162d+02*sb2-0.3483d+01*sb3
41199  a4= 0.9881d+00+0.1364d+00*sb -0.4421d+00*sb2+0.2051d+00*sb3
41200  a5=-0.9505d-01+0.3259d+01*sb -0.1547d+01*sb2+0.2918d+00*sb3
41201  ELSEIF(iprt .EQ. -1) THEN
41202  a0=exp(-0.2449d+01-0.3513d+01*sb +0.4529d+01*sb2-
41203  & 0.2031d+01*sb3)
41204  a1=-0.4050d+00+0.3411d+00*sb -0.3669d+00*sb2+0.1109d+00*sb3
41205  a2= 0.7470d+01-0.2982d+01*sb +0.5503d+01*sb2-0.2419d+01*sb3
41206  a3= 0.1503d+02+0.1638d+01*sb -0.8772d+01*sb2+0.3852d+01*sb3
41207  a4= 0.1137d+01-0.1006d+01*sb +0.1485d+01*sb2-0.6389d+00*sb3
41208  a5=-0.5299d+00+0.3160d+01*sb -0.3104d+01*sb2+0.1219d+01*sb3
41209  ELSEIF(iprt .EQ. -2) THEN
41210  a0=exp(-0.2740d+01-0.7987d-01*sb -0.9015d+00*sb2-
41211  & 0.9872d-01*sb3)
41212  a1=-0.3909d+00+0.1244d+00*sb -0.4487d-01*sb2+0.1277d-01*sb3
41213  a2= 0.9163d+01+0.2823d+00*sb -0.7720d+00*sb2-0.9360d-02*sb3
41214  a3= 0.1080d+02-0.3915d+01*sb -0.1153d+01*sb2+0.2649d+01*sb3
41215  a4= 0.9894d+00-0.1647d+00*sb -0.9426d-02*sb2+0.2945d-02*sb3
41216  a5=-0.3395d+00+0.6998d+00*sb +0.7000d+00*sb2-0.6730d-01*sb3
41217  ELSEIF(iprt .EQ. -3) THEN
41218  a0=exp(-0.3640d+01+0.1250d+01*sb -0.2914d+01*sb2+
41219  & 0.8390d+00*sb3)
41220  a1=-0.3595d+00-0.5259d-01*sb +0.3122d+00*sb2-0.1642d+00*sb3
41221  a2= 0.7305d+01+0.9727d+00*sb -0.9788d+00*sb2-0.5193d-01*sb3
41222  a3= 0.1198d+02-0.1799d+02*sb +0.2614d+02*sb2-0.1091d+02*sb3
41223  a4= 0.9882d+00-0.6101d+00*sb +0.9737d+00*sb2-0.4935d+00*sb3
41224  a5=-0.1186d+00-0.3231d+00*sb +0.3074d+01*sb2-0.1274d+01*sb3
41225  ELSEIF(iprt .EQ. -4) THEN
41226  a0=sb** 0.1122d+01*exp(-0.3718d+01-0.1335d+01*sb +
41227  & 0.1651d-01*sb2)
41228  a1=-0.4719d+00+0.7509d+00*sb -0.8420d+00*sb2+0.2901d+00*sb3
41229  a2= 0.6194d+01-0.1641d+01*sb +0.4907d+01*sb2-0.2523d+01*sb3
41230  a3= 0.4426d+01-0.4270d+01*sb +0.6581d+01*sb2-0.3474d+01*sb3
41231  a4= 0.2683d+00+0.9876d+00*sb -0.7612d+00*sb2+0.1780d+00*sb3
41232  a5=-0.4547d+00+0.4410d+01*sb -0.3712d+01*sb2+0.1245d+01*sb3
41233  ELSEIF(iprt .EQ. -5) THEN
41234  a0=sb** 0.9838d+00*exp(-0.2548d+01-0.7660d+01*sb +
41235  & 0.3702d+01*sb2)
41236  a1=-0.3122d+00-0.2120d+00*sb +0.5716d+00*sb2-0.3773d+00*sb3
41237  a2= 0.6257d+01-0.8214d-01*sb -0.2537d+01*sb2+0.2981d+01*sb3
41238  a3=-0.6723d+00+0.2131d+01*sb +0.9599d+01*sb2-0.7910d+01*sb3
41239  a4= 0.9169d-01+0.4295d-01*sb -0.5017d+00*sb2+0.3811d+00*sb3
41240  a5= 0.2402d+00+0.2656d+01*sb -0.1586d+01*sb2+0.2880d+00*sb3
41241  ELSEIF(iprt .EQ. -6) THEN
41242  a0=sb** 0.1001d+01*exp(-0.6934d+01+0.3050d+01*sb -
41243  & 0.6943d+00*sb2)
41244  a1=-0.1713d+00-0.5167d+00*sb +0.1241d+01*sb2-0.1703d+01*sb3
41245  a2= 0.6169d+01+0.3023d+01*sb -0.1972d+02*sb2+0.1069d+02*sb3
41246  a3= 0.4439d+01-0.1746d+02*sb +0.1225d+02*sb2+0.8350d+00*sb3
41247  a4= 0.5458d+00-0.4586d+00*sb +0.9089d+00*sb2-0.4049d+00*sb3
41248  a5= 0.3207d+01-0.3362d+01*sb +0.5877d+01*sb2-0.7659d+01*sb3
41249  ENDIF
41250 
41251 C...Expansion for CTEQ3M.
41252  ELSEIF(iset .EQ. 2) THEN
41253  IF(iprt .EQ. 2) THEN
41254  a0=exp( 0.2259d+00+0.1237d+00*sb +0.3035d+00*sb2-
41255  & 0.2935d+00*sb3)
41256  a1= 0.5085d+00+0.1651d-01*sb -0.3592d-01*sb2+0.2782d-01*sb3
41257  a2= 0.3732d+01+0.4901d+00*sb +0.2218d+00*sb2-0.1116d+00*sb3
41258  a3= 0.7011d+01-0.6620d+01*sb +0.2557d+01*sb2-0.1360d+00*sb3
41259  a4= 0.8969d+00-0.2429d+00*sb +0.1811d+00*sb2-0.6888d-01*sb3
41260  a5= 0.8636d-01+0.2558d+00*sb -0.3082d+00*sb2+0.2535d+00*sb3
41261  ELSEIF(iprt .EQ. 1) THEN
41262  a0=exp(-0.7266d+00-0.1584d+01*sb +0.1259d+01*sb2-
41263  & 0.4305d-01*sb3)
41264  a1= 0.5285d+00-0.3721d+00*sb +0.5150d+00*sb2-0.1697d+00*sb3
41265  a2= 0.4075d+01+0.8282d+00*sb -0.4496d+00*sb2+0.2107d+00*sb3
41266  a3= 0.3279d+01+0.5066d+01*sb -0.9134d+01*sb2+0.2897d+01*sb3
41267  a4= 0.4399d+00-0.5888d+00*sb +0.4802d+00*sb2-0.1664d+00*sb3
41268  a5= 0.3678d+00-0.8929d+00*sb +0.1592d+01*sb2-0.5713d+00*sb3
41269  ELSEIF(iprt .EQ. 0) THEN
41270  a0=exp(-0.2318d+00-0.9779d+00*sb -0.3783d+00*sb2+
41271  & 0.1037d-01*sb3)
41272  a1=-0.2916d+00+0.1754d+00*sb -0.1884d+00*sb2+0.6116d-01*sb3
41273  a2= 0.5349d+01+0.7460d+00*sb +0.2319d+00*sb2-0.2622d+00*sb3
41274  a3= 0.6920d+01-0.3454d+01*sb +0.2027d+01*sb2-0.7626d+00*sb3
41275  a4= 0.1013d+01+0.1423d+00*sb -0.1798d+00*sb2+0.1872d-01*sb3
41276  a5=-0.5465d-01+0.2303d+01*sb -0.9584d+00*sb2+0.3098d+00*sb3
41277  ELSEIF(iprt .EQ. -1) THEN
41278  a0=exp(-0.2328d+01-0.3061d+01*sb +0.3620d+01*sb2-
41279  & 0.1602d+01*sb3)
41280  a1=-0.3358d+00+0.3198d+00*sb -0.4210d+00*sb2+0.1571d+00*sb3
41281  a2= 0.8478d+01-0.3112d+01*sb +0.5243d+01*sb2-0.2255d+01*sb3
41282  a3= 0.1971d+02+0.3389d+00*sb -0.5268d+01*sb2+0.2099d+01*sb3
41283  a4= 0.1128d+01-0.4701d+00*sb +0.7779d+00*sb2-0.3506d+00*sb3
41284  a5=-0.4708d+00+0.3341d+01*sb -0.3375d+01*sb2+0.1353d+01*sb3
41285  ELSEIF(iprt .EQ. -2) THEN
41286  a0=exp(-0.2906d+01-0.1069d+00*sb -0.1055d+01*sb2+
41287  & 0.2496d+00*sb3)
41288  a1=-0.2875d+00+0.6571d-01*sb -0.1987d-01*sb2-0.1800d-02*sb3
41289  a2= 0.9854d+01-0.2715d+00*sb -0.7407d+00*sb2+0.2888d+00*sb3
41290  a3= 0.1583d+02-0.7687d+01*sb +0.3428d+01*sb2-0.3327d+00*sb3
41291  a4= 0.9763d+00+0.7599d-01*sb -0.2128d+00*sb2+0.6852d-01*sb3
41292  a5=-0.8444d-02+0.9434d+00*sb +0.4152d+00*sb2-0.1481d+00*sb3
41293  ELSEIF(iprt .EQ. -3) THEN
41294  a0=exp(-0.3780d+01+0.2499d+01*sb -0.4962d+01*sb2+
41295  & 0.1936d+01*sb3)
41296  a1=-0.2639d+00-0.1575d+00*sb +0.3584d+00*sb2-0.1646d+00*sb3
41297  a2= 0.8082d+01+0.2794d+01*sb -0.5438d+01*sb2+0.2321d+01*sb3
41298  a3= 0.1811d+02-0.2000d+02*sb +0.1951d+02*sb2-0.6904d+01*sb3
41299  a4= 0.9822d+00+0.4972d+00*sb -0.8690d+00*sb2+0.3415d+00*sb3
41300  a5= 0.1772d+00-0.6078d+00*sb +0.3341d+01*sb2-0.1473d+01*sb3
41301  ELSEIF(iprt .EQ. -4) THEN
41302  a0=sb** 0.1122d+01*exp(-0.4232d+01-0.1808d+01*sb +
41303  & 0.5348d+00*sb2)
41304  a1=-0.2824d+00+0.5846d+00*sb -0.7230d+00*sb2+0.2419d+00*sb3
41305  a2= 0.5683d+01-0.2948d+01*sb +0.5916d+01*sb2-0.2560d+01*sb3
41306  a3= 0.2051d+01+0.4795d+01*sb -0.4271d+01*sb2+0.4174d+00*sb3
41307  a4= 0.1737d+00+0.1717d+01*sb -0.1978d+01*sb2+0.6643d+00*sb3
41308  a5= 0.8689d+00+0.3500d+01*sb -0.3283d+01*sb2+0.1026d+01*sb3
41309  ELSEIF(iprt .EQ. -5) THEN
41310  a0=sb** 0.9906d+00*exp(-0.1496d+01-0.6576d+01*sb +
41311  & 0.1569d+01*sb2)
41312  a1=-0.2140d+00-0.6419d-01*sb -0.2741d-02*sb2+0.3185d-02*sb3
41313  a2= 0.5781d+01+0.1049d+00*sb -0.3930d+00*sb2+0.5174d+00*sb3
41314  a3=-0.9420d+00+0.5511d+00*sb +0.8817d+00*sb2+0.1903d+01*sb3
41315  a4= 0.2418d-01+0.4232d-01*sb -0.1244d-01*sb2-0.2365d-01*sb3
41316  a5= 0.7664d+00+0.1794d+01*sb -0.4917d+00*sb2-0.1284d+00*sb3
41317  ELSEIF(iprt .EQ. -6) THEN
41318  a0=sb** 0.1000d+01*exp(-0.8460d+01+0.1154d+01*sb +
41319  & 0.8838d+01*sb2)
41320  a1=-0.4316d-01-0.2976d+00*sb +0.3174d+00*sb2-0.1429d+01*sb3
41321  a2= 0.4910d+01+0.2273d+01*sb +0.5631d+01*sb2-0.1994d+02*sb3
41322  a3= 0.1190d+02-0.2000d+02*sb -0.2000d+02*sb2+0.1292d+02*sb3
41323  a4= 0.5771d+00-0.2552d+00*sb +0.7510d+00*sb2+0.6923d+00*sb3
41324  a5= 0.4402d+01-0.1627d+01*sb -0.2085d+01*sb2-0.6737d+01*sb3
41325  ENDIF
41326 
41327 C...Expansion for CTEQ3D.
41328  ELSEIF(iset .EQ. 3) THEN
41329  IF(iprt .EQ. 2) THEN
41330  a0=exp( 0.2148d+00+0.5814d-01*sb +0.2734d+00*sb2-
41331  & 0.2902d+00*sb3)
41332  a1= 0.4810d+00+0.1657d-01*sb -0.3800d-01*sb2+0.3125d-01*sb3
41333  a2= 0.3509d+01+0.3923d+00*sb +0.4010d+00*sb2-0.1932d+00*sb3
41334  a3= 0.7055d+01-0.6552d+01*sb +0.3466d+01*sb2-0.5657d+00*sb3
41335  a4= 0.1061d+01-0.3453d+00*sb +0.4089d+00*sb2-0.1817d+00*sb3
41336  a5= 0.8687d-01+0.2548d+00*sb -0.2967d+00*sb2+0.2647d+00*sb3
41337  ELSEIF(iprt .EQ. 1) THEN
41338  a0=exp( 0.3961d+00+0.4914d+00*sb -0.1728d+01*sb2+
41339  & 0.7257d+00*sb3)
41340  a1= 0.4162d+00-0.1419d+00*sb +0.3680d+00*sb2-0.1618d+00*sb3
41341  a2= 0.3248d+01+0.3028d+01*sb -0.4307d+01*sb2+0.1920d+01*sb3
41342  a3=-0.1100d+01+0.2184d+01*sb -0.3820d+01*sb2+0.1717d+01*sb3
41343  a4= 0.2082d+01-0.2756d+00*sb +0.3043d+00*sb2-0.1260d+00*sb3
41344  a5=-0.4822d+00-0.5706d+00*sb +0.2243d+01*sb2-0.9760d+00*sb3
41345  ELSEIF(iprt .EQ. 0) THEN
41346  a0=exp(-0.4665d+00-0.7554d+00*sb -0.3323d+00*sb2-
41347  & 0.2734d-04*sb3)
41348  a1=-0.3359d+00+0.2395d+00*sb -0.2377d+00*sb2+0.7059d-01*sb3
41349  a2= 0.5451d+01+0.6086d+00*sb +0.8606d-01*sb2-0.1425d+00*sb3
41350  a3= 0.1026d+02-0.9352d+01*sb +0.4879d+01*sb2-0.1150d+01*sb3
41351  a4= 0.9935d+00-0.5017d-01*sb -0.1707d-01*sb2-0.1464d-02*sb3
41352  a5=-0.4160d-01+0.2305d+01*sb -0.1063d+01*sb2+0.3211d+00*sb3
41353  ELSEIF(iprt .EQ. -1) THEN
41354  a0=exp(-0.2714d+01-0.2868d+01*sb +0.3700d+01*sb2-
41355  & 0.1671d+01*sb3)
41356  a1=-0.3893d+00+0.3341d+00*sb -0.3897d+00*sb2+0.1420d+00*sb3
41357  a2= 0.8359d+01-0.3267d+01*sb +0.5327d+01*sb2-0.2245d+01*sb3
41358  a3= 0.2359d+02-0.5669d+01*sb -0.4602d+01*sb2+0.3153d+01*sb3
41359  a4= 0.1106d+01-0.4745d+00*sb +0.7739d+00*sb2-0.3417d+00*sb3
41360  a5=-0.5557d+00+0.3433d+01*sb -0.3390d+01*sb2+0.1354d+01*sb3
41361  ELSEIF(iprt .EQ. -2) THEN
41362  a0=exp(-0.3323d+01+0.2296d+00*sb -0.1109d+01*sb2+
41363  & 0.2223d+00*sb3)
41364  a1=-0.3410d+00+0.8847d-01*sb -0.1111d-01*sb2-0.5927d-02*sb3
41365  a2= 0.9753d+01-0.5182d+00*sb -0.4670d+00*sb2+0.1921d+00*sb3
41366  a3= 0.1977d+02-0.1600d+02*sb +0.9481d+01*sb2-0.1864d+01*sb3
41367  a4= 0.9818d+00+0.2839d-02*sb -0.1188d+00*sb2+0.3584d-01*sb3
41368  a5=-0.7934d-01+0.1004d+01*sb +0.3704d+00*sb2-0.1220d+00*sb3
41369  ELSEIF(iprt .EQ. -3) THEN
41370  a0=exp(-0.3985d+01+0.2855d+01*sb -0.5208d+01*sb2+
41371  & 0.1937d+01*sb3)
41372  a1=-0.3337d+00-0.1150d+00*sb +0.3691d+00*sb2-0.1709d+00*sb3
41373  a2= 0.7968d+01+0.3641d+01*sb -0.6599d+01*sb2+0.2642d+01*sb3
41374  a3= 0.1873d+02-0.1999d+02*sb +0.1734d+02*sb2-0.5813d+01*sb3
41375  a4= 0.9731d+00+0.5082d+00*sb -0.8780d+00*sb2+0.3231d+00*sb3
41376  a5=-0.5542d-01-0.4189d+00*sb +0.3309d+01*sb2-0.1439d+01*sb3
41377  ELSEIF(iprt .EQ. -4) THEN
41378  a0=sb** 0.1105d+01*exp(-0.3952d+01-0.1901d+01*sb +
41379  & 0.5137d+00*sb2)
41380  a1=-0.3543d+00+0.6055d+00*sb -0.6941d+00*sb2+0.2278d+00*sb3
41381  a2= 0.5955d+01-0.2629d+01*sb +0.5337d+01*sb2-0.2300d+01*sb3
41382  a3= 0.1933d+01+0.4882d+01*sb -0.3810d+01*sb2+0.2290d+00*sb3
41383  a4= 0.1806d+00+0.1655d+01*sb -0.1893d+01*sb2+0.6395d+00*sb3
41384  a5= 0.4790d+00+0.3612d+01*sb -0.3152d+01*sb2+0.9684d+00*sb3
41385  ELSEIF(iprt .EQ. -5) THEN
41386  a0=sb** 0.9818d+00*exp(-0.1825d+01-0.7464d+01*sb +
41387  & 0.2143d+01*sb2)
41388  a1=-0.2604d+00-0.1400d+00*sb +0.1702d+00*sb2-0.8476d-01*sb3
41389  a2= 0.6005d+01+0.6275d+00*sb -0.2535d+01*sb2+0.2219d+01*sb3
41390  a3=-0.9067d+00+0.1149d+01*sb +0.1974d+01*sb2+0.4716d+01*sb3
41391  a4= 0.3915d-01+0.5945d-01*sb -0.9844d-01*sb2+0.2783d-01*sb3
41392  a5= 0.5500d+00+0.1994d+01*sb -0.6727d+00*sb2-0.1510d+00*sb3
41393  ELSEIF(iprt .EQ. -6) THEN
41394  a0=sb** 0.1002d+01*exp(-0.8553d+01+0.3793d+00*sb +
41395  & 0.9998d+01*sb2)
41396  a1=-0.5870d-01-0.2792d+00*sb +0.6526d+00*sb2-0.1984d+01*sb3
41397  a2= 0.4716d+01+0.4473d+00*sb +0.1128d+02*sb2-0.1937d+02*sb3
41398  a3= 0.1289d+02-0.1742d+02*sb -0.1983d+02*sb2-0.9274d+00*sb3
41399  a4= 0.5647d+00-0.2732d+00*sb +0.1074d+01*sb2+0.5981d+00*sb3
41400  a5= 0.4390d+01-0.1262d+01*sb -0.9026d+00*sb2-0.9394d+01*sb3
41401  ENDIF
41402  ENDIF
41403 
41404 C...Calculation of x * f(x, Q).
41405  pycteq = max(0d0, a0 *(x**a1) *((1d0-x)**a2) *(1d0+a3*(x**a4))
41406  & *(log(1d0+1d0/x))**a5 )
41407 
41408  RETURN
41409  END
41410 
41411 C*********************************************************************
41412 
41413 C...PYGRVL
41414 C...Gives the GRV 94 L (leading order) parton distribution function set
41415 C...in parametrized form.
41416 C...Authors: M. Glueck, E. Reya and A. Vogt.
41417 
41418  SUBROUTINE pygrvl (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41419 
41420 C...Double precision declaration.
41421  IMPLICIT DOUBLE PRECISION (a - z)
41422 
41423 C...Common expressions.
41424  mu2 = 0.23d0
41425  lam2 = 0.2322d0 * 0.2322d0
41426  s = log(log(q2/lam2) / log(mu2/lam2))
41427  ds = sqrt(s)
41428  s2 = s * s
41429  s3 = s2 * s
41430 
41431 C...uv :
41432  nu = 2.284d0 + 0.802d0 * s + 0.055d0 * s2
41433  aku = 0.590d0 - 0.024d0 * s
41434  bku = 0.131d0 + 0.063d0 * s
41435  au = -0.449d0 - 0.138d0 * s - 0.076d0 * s2
41436  bu = 0.213d0 + 2.669d0 * s - 0.728d0 * s2
41437  cu = 8.854d0 - 9.135d0 * s + 1.979d0 * s2
41438  du = 2.997d0 + 0.753d0 * s - 0.076d0 * s2
41439  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
41440 
41441 C...dv :
41442  nd = 0.371d0 + 0.083d0 * s + 0.039d0 * s2
41443  akd = 0.376d0
41444  bkd = 0.486d0 + 0.062d0 * s
41445  ad = -0.509d0 + 3.310d0 * s - 1.248d0 * s2
41446  bd = 12.41d0 - 10.52d0 * s + 2.267d0 * s2
41447  cd = 6.373d0 - 6.208d0 * s + 1.418d0 * s2
41448  dd = 3.691d0 + 0.799d0 * s - 0.071d0 * s2
41449  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
41450 
41451 C...del :
41452  ne = 0.082d0 + 0.014d0 * s + 0.008d0 * s2
41453  ake = 0.409d0 - 0.005d0 * s
41454  bke = 0.799d0 + 0.071d0 * s
41455  ae = -38.07d0 + 36.13d0 * s - 0.656d0 * s2
41456  be = 90.31d0 - 74.15d0 * s + 7.645d0 * s2
41457  ce = 0.0d0
41458  de = 7.486d0 + 1.217d0 * s - 0.159d0 * s2
41459  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
41460 
41461 C...udb :
41462  alx = 1.451d0
41463  bex = 0.271d0
41464  akx = 0.410d0 - 0.232d0 * s
41465  bkx = 0.534d0 - 0.457d0 * s
41466  agx = 0.890d0 - 0.140d0 * s
41467  bgx = -0.981d0
41468  cx = 0.320d0 + 0.683d0 * s
41469  dx = 4.752d0 + 1.164d0 * s + 0.286d0 * s2
41470  ex = 4.119d0 + 1.713d0 * s
41471  esx = 0.682d0 + 2.978d0 * s
41472  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
41473  & dx, ex, esx)
41474 
41475 C...sb :
41476  sts = 0d0
41477  als = 0.914d0
41478  bes = 0.577d0
41479  aks = 1.798d0 - 0.596d0 * s
41480  as = -5.548d0 + 3.669d0 * ds - 0.616d0 * s
41481  bs = 18.92d0 - 16.73d0 * ds + 5.168d0 * s
41482  dst = 6.379d0 - 0.350d0 * s + 0.142d0 * s2
41483  est = 3.981d0 + 1.638d0 * s
41484  ess = 6.402d0
41485  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
41486 
41487 C...cb :
41488  stc = 0.888d0
41489  alc = 1.01d0
41490  bec = 0.37d0
41491  akc = 0d0
41492  ac = 0d0
41493  bc = 4.24d0 - 0.804d0 * s
41494  dct = 3.46d0 - 1.076d0 * s
41495  ect = 4.61d0 + 1.49d0 * s
41496  esc = 2.555d0 + 1.961d0 * s
41497  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
41498 
41499 C...bb :
41500  stb = 1.351d0
41501  alb = 1.00d0
41502  beb = 0.51d0
41503  akb = 0d0
41504  ab = 0d0
41505  bb = 1.848d0
41506  dbt = 2.929d0 + 1.396d0 * s
41507  ebt = 4.71d0 + 1.514d0 * s
41508  esb = 4.02d0 + 1.239d0 * s
41509  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
41510 
41511 C...gl :
41512  alg = 0.524d0
41513  beg = 1.088d0
41514  akg = 1.742d0 - 0.930d0 * s
41515  bkg = - 0.399d0 * s2
41516  ag = 7.486d0 - 2.185d0 * s
41517  bg = 16.69d0 - 22.74d0 * s + 5.779d0 * s2
41518  cg = -25.59d0 + 29.71d0 * s - 7.296d0 * s2
41519  dg = 2.792d0 + 2.215d0 * s + 0.422d0 * s2 - 0.104d0 * s3
41520  eg = 0.807d0 + 2.005d0 * s
41521  esg = 3.841d0 + 0.316d0 * s
41522  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg,
41523  & dg, eg, esg)
41524 
41525  RETURN
41526  END
41527 
41528 C*********************************************************************
41529 
41530 C...PYGRVM
41531 C...Gives the GRV 94 M (MSbar) parton distribution function set
41532 C...in parametrized form.
41533 C...Authors: M. Glueck, E. Reya and A. Vogt.
41534 
41535  SUBROUTINE pygrvm (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41536 
41537 C...Double precision declaration.
41538  IMPLICIT DOUBLE PRECISION (a - z)
41539 
41540 C...Common expressions.
41541  mu2 = 0.34d0
41542  lam2 = 0.248d0 * 0.248d0
41543  s = log(log(q2/lam2) / log(mu2/lam2))
41544  ds = sqrt(s)
41545  s2 = s * s
41546  s3 = s2 * s
41547 
41548 C...uv :
41549  nu = 1.304d0 + 0.863d0 * s
41550  aku = 0.558d0 - 0.020d0 * s
41551  bku = 0.183d0 * s
41552  au = -0.113d0 + 0.283d0 * s - 0.321d0 * s2
41553  bu = 6.843d0 - 5.089d0 * s + 2.647d0 * s2 - 0.527d0 * s3
41554  cu = 7.771d0 - 10.09d0 * s + 2.630d0 * s2
41555  du = 3.315d0 + 1.145d0 * s - 0.583d0 * s2 + 0.154d0 * s3
41556  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
41557 
41558 C...dv :
41559  nd = 0.102d0 - 0.017d0 * s + 0.005d0 * s2
41560  akd = 0.270d0 - 0.019d0 * s
41561  bkd = 0.260d0
41562  ad = 2.393d0 + 6.228d0 * s - 0.881d0 * s2
41563  bd = 46.06d0 + 4.673d0 * s - 14.98d0 * s2 + 1.331d0 * s3
41564  cd = 17.83d0 - 53.47d0 * s + 21.24d0 * s2
41565  dd = 4.081d0 + 0.976d0 * s - 0.485d0 * s2 + 0.152d0 * s3
41566  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
41567 
41568 C...del :
41569  ne = 0.070d0 + 0.042d0 * s - 0.011d0 * s2 + 0.004d0 * s3
41570  ake = 0.409d0 - 0.007d0 * s
41571  bke = 0.782d0 + 0.082d0 * s
41572  ae = -29.65d0 + 26.49d0 * s + 5.429d0 * s2
41573  be = 90.20d0 - 74.97d0 * s + 4.526d0 * s2
41574  ce = 0.0d0
41575  de = 8.122d0 + 2.120d0 * s - 1.088d0 * s2 + 0.231d0 * s3
41576  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
41577 
41578 C...udb :
41579  alx = 0.877d0
41580  bex = 0.561d0
41581  akx = 0.275d0
41582  bkx = 0.0d0
41583  agx = 0.997d0
41584  bgx = 3.210d0 - 1.866d0 * s
41585  cx = 7.300d0
41586  dx = 9.010d0 + 0.896d0 * ds + 0.222d0 * s2
41587  ex = 3.077d0 + 1.446d0 * s
41588  esx = 3.173d0 - 2.445d0 * ds + 2.207d0 * s
41589  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
41590  & dx, ex, esx)
41591 
41592 C...sb :
41593  sts = 0d0
41594  als = 0.756d0
41595  bes = 0.216d0
41596  aks = 1.690d0 + 0.650d0 * ds - 0.922d0 * s
41597  as = -4.329d0 + 1.131d0 * s
41598  bs = 9.568d0 - 1.744d0 * s
41599  dst = 9.377d0 + 1.088d0 * ds - 1.320d0 * s + 0.130d0 * s2
41600  est = 3.031d0 + 1.639d0 * s
41601  ess = 5.837d0 + 0.815d0 * s
41602  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
41603 
41604 C...cb :
41605  stc = 0.820d0
41606  alc = 0.98d0
41607  bec = 0d0
41608  akc = -0.625d0 - 0.523d0 * s
41609  ac = 0d0
41610  bc = 1.896d0 + 1.616d0 * s
41611  dct = 4.12d0 + 0.683d0 * s
41612  ect = 4.36d0 + 1.328d0 * s
41613  esc = 0.677d0 + 0.679d0 * s
41614  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
41615 
41616 C...bb :
41617  stb = 1.297d0
41618  alb = 0.99d0
41619  beb = 0d0
41620  akb = - 0.193d0 * s
41621  ab = 0d0
41622  bb = 0d0
41623  dbt = 3.447d0 + 0.927d0 * s
41624  ebt = 4.68d0 + 1.259d0 * s
41625  esb = 1.892d0 + 2.199d0 * s
41626  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
41627 
41628 C...gl :
41629  alg = 1.014d0
41630  beg = 1.738d0
41631  akg = 1.724d0 + 0.157d0 * s
41632  bkg = 0.800d0 + 1.016d0 * s
41633  ag = 7.517d0 - 2.547d0 * s
41634  bg = 34.09d0 - 52.21d0 * ds + 17.47d0 * s
41635  cg = 4.039d0 + 1.491d0 * s
41636  dg = 3.404d0 + 0.830d0 * s
41637  eg = -1.112d0 + 3.438d0 * s - 0.302d0 * s2
41638  esg = 3.256d0 - 0.436d0 * s
41639  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
41640 
41641  RETURN
41642  END
41643 
41644 C*********************************************************************
41645 
41646 C...PYGRVD
41647 C...Gives the GRV 94 D (DIS) parton distribution function set
41648 C...in parametrized form.
41649 C...Authors: M. Glueck, E. Reya and A. Vogt.
41650 
41651  SUBROUTINE pygrvd (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41652 
41653 C...Double precision declaration.
41654  IMPLICIT DOUBLE PRECISION (a - z)
41655 
41656 C...Common expressions.
41657  mu2 = 0.34d0
41658  lam2 = 0.248d0 * 0.248d0
41659  s = log(log(q2/lam2) / log(mu2/lam2))
41660  ds = sqrt(s)
41661  s2 = s * s
41662  s3 = s2 * s
41663 
41664 C...uv :
41665  nu = 2.484d0 + 0.116d0 * s + 0.093d0 * s2
41666  aku = 0.563d0 - 0.025d0 * s
41667  bku = 0.054d0 + 0.154d0 * s
41668  au = -0.326d0 - 0.058d0 * s - 0.135d0 * s2
41669  bu = -3.322d0 + 8.259d0 * s - 3.119d0 * s2 + 0.291d0 * s3
41670  cu = 11.52d0 - 12.99d0 * s + 3.161d0 * s2
41671  du = 2.808d0 + 1.400d0 * s - 0.557d0 * s2 + 0.119d0 * s3
41672  uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
41673 
41674 C...dv :
41675  nd = 0.156d0 - 0.017d0 * s
41676  akd = 0.299d0 - 0.022d0 * s
41677  bkd = 0.259d0 - 0.015d0 * s
41678  ad = 3.445d0 + 1.278d0 * s + 0.326d0 * s2
41679  bd = -6.934d0 + 37.45d0 * s - 18.95d0 * s2 + 1.463d0 * s3
41680  cd = 55.45d0 - 69.92d0 * s + 20.78d0 * s2
41681  dd = 3.577d0 + 1.441d0 * s - 0.683d0 * s2 + 0.179d0 * s3
41682  dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
41683 
41684 C...del :
41685  ne = 0.099d0 + 0.019d0 * s + 0.002d0 * s2
41686  ake = 0.419d0 - 0.013d0 * s
41687  bke = 1.064d0 - 0.038d0 * s
41688  ae = -44.00d0 + 98.70d0 * s - 14.79d0 * s2
41689  be = 28.59d0 - 40.94d0 * s - 13.66d0 * s2 + 2.523d0 * s3
41690  ce = 84.57d0 - 108.8d0 * s + 31.52d0 * s2
41691  de = 7.469d0 + 2.480d0 * s - 0.866d0 * s2
41692  del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
41693 
41694 C...udb :
41695  alx = 1.215d0
41696  bex = 0.466d0
41697  akx = 0.326d0 + 0.150d0 * s
41698  bkx = 0.956d0 + 0.405d0 * s
41699  agx = 0.272d0
41700  bgx = 3.794d0 - 2.359d0 * ds
41701  cx = 2.014d0
41702  dx = 7.941d0 + 0.534d0 * ds - 0.940d0 * s + 0.410d0 * s2
41703  ex = 3.049d0 + 1.597d0 * s
41704  esx = 4.396d0 - 4.594d0 * ds + 3.268d0 * s
41705  udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
41706  & dx, ex, esx)
41707 
41708 C...sb :
41709  sts = 0d0
41710  als = 0.175d0
41711  bes = 0.344d0
41712  aks = 1.415d0 - 0.641d0 * ds
41713  as = 0.580d0 - 9.763d0 * ds + 6.795d0 * s - 0.558d0 * s2
41714  bs = 5.617d0 + 5.709d0 * ds - 3.972d0 * s
41715  dst = 13.78d0 - 9.581d0 * s + 5.370d0 * s2 - 0.996d0 * s3
41716  est = 4.546d0 + 0.372d0 * s2
41717  ess = 5.053d0 - 1.070d0 * s + 0.805d0 * s2
41718  sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
41719 
41720 C...cb :
41721  stc = 0.820d0
41722  alc = 0.98d0
41723  bec = 0d0
41724  akc = -0.625d0 - 0.523d0 * s
41725  ac = 0d0
41726  bc = 1.896d0 + 1.616d0 * s
41727  dct = 4.12d0 + 0.683d0 * s
41728  ect = 4.36d0 + 1.328d0 * s
41729  esc = 0.677d0 + 0.679d0 * s
41730  chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
41731 
41732 C...bb :
41733  stb = 1.297d0
41734  alb = 0.99d0
41735  beb = 0d0
41736  akb = - 0.193d0 * s
41737  ab = 0d0
41738  bb = 0d0
41739  dbt = 3.447d0 + 0.927d0 * s
41740  ebt = 4.68d0 + 1.259d0 * s
41741  esb = 1.892d0 + 2.199d0 * s
41742  bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
41743 
41744 C...gl :
41745  alg = 1.258d0
41746  beg = 1.846d0
41747  akg = 2.423d0
41748  bkg = 2.427d0 + 1.311d0 * s - 0.153d0 * s2
41749  ag = 25.09d0 - 7.935d0 * s
41750  bg = -14.84d0 - 124.3d0 * ds + 72.18d0 * s
41751  cg = 590.3d0 - 173.8d0 * s
41752  dg = 5.196d0 + 1.857d0 * s
41753  eg = -1.648d0 + 3.988d0 * s - 0.432d0 * s2
41754  esg = 3.232d0 - 0.542d0 * s
41755  gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
41756 
41757  RETURN
41758  END
41759 
41760 C*********************************************************************
41761 
41762 C...PYGRVV
41763 C...Auxiliary for the GRV 94 parton distribution functions
41764 C...for u and d valence and d-u sea.
41765 C...Authors: M. Glueck, E. Reya and A. Vogt.
41766 
41767  FUNCTION pygrvv (X, N, AK, BK, A, B, C, D)
41768 
41769 C...Double precision declaration.
41770  IMPLICIT DOUBLE PRECISION (a - z)
41771 
41772 C...Evaluation.
41773  dx = sqrt(x)
41774  pygrvv = n * x**ak * (1d0+ a*x**bk + x * (b + c*dx)) *
41775  & (1d0- x)**d
41776 
41777  RETURN
41778  END
41779 
41780 C*********************************************************************
41781 
41782 C...PYGRVW
41783 C...Auxiliary for the GRV 94 parton distribution functions
41784 C...for d+u sea and gluon.
41785 C...Authors: M. Glueck, E. Reya and A. Vogt.
41786 
41787  FUNCTION pygrvw (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41788 
41789 C...Double precision declaration.
41790  IMPLICIT DOUBLE PRECISION (a - z)
41791 
41792 C...Evaluation.
41793  lx = log(1d0/x)
41794  pygrvw = (x**ak * (a + x * (b + x*c)) * lx**bk + s**al
41795  & * exp(-e + sqrt(es * s**be * lx))) * (1d0- x)**d
41796 
41797  RETURN
41798  END
41799 
41800 C*********************************************************************
41801 
41802 C...PYGRVS
41803 C...Auxiliary for the GRV 94 parton distribution functions
41804 C...for s, c and b sea.
41805 C...Authors: M. Glueck, E. Reya and A. Vogt.
41806 
41807  FUNCTION pygrvs (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41808 
41809 C...Double precision declaration.
41810  IMPLICIT DOUBLE PRECISION (a - z)
41811 
41812 C...Evaluation.
41813  IF(s.LE.sth) THEN
41814  pygrvs = 0d0
41815  ELSE
41816  dx = sqrt(x)
41817  lx = log(1d0/x)
41818  pygrvs = (s - sth)**al / lx**ak * (1d0+ ag*dx + b*x) *
41819  & (1d0- x)**d * exp(-e + sqrt(es * s**be * lx))
41820  ENDIF
41821 
41822  RETURN
41823  END
41824 
41825 C*********************************************************************
41826 
41827 C...PYCT5L
41828 C...Auxiliary function for parametrization of CTEQ5L.
41829 C...Author: J. Pumplin 9/99.
41830 
41831 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41832 C...in Parametrized Form
41833 C... September 15, 1999
41834 C
41835 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41836 C... CTEQ5 PPARTON DISTRIBUTIONS"
41837 C...hep-ph/9903282
41838 
41839 C...The CTEQ5M1 set given here is an updated version of the original
41840 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41841 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41842 C...almost all applications.
41843 C...The improvement is in the QCD evolution which is now more
41844 C...accurate, and which agrees completely with the benchmark work
41845 C...of the HERA 96/97 Workshop.
41846 C...The differences between the parametrized and the corresponding
41847 C...table versions (on which it is based) are of similar order as
41848 C...between the two version.
41849 
41850 C...!! Because accurate parametrizations over a wide range of (x,Q)
41851 C...is hard to obtain, only the most widely used sets CTEQ5M and
41852 C...CTEQ5L are available in parametrized form for now.
41853 
41854 C...These parametrizations were obtained by Jon Pumplin.
41855 
41856 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41857 C -------------------------------------------------------------------
41858 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41859 C 3 CTEQ5L Leading Order 0.127 192 146
41860 C -------------------------------------------------------------------
41861 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41862 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41863 C...calibration.
41864 
41865 C...The two Iset value are adopted to agree with the standard table
41866 C...versions.
41867 
41868 C...Range of validity:
41869 C...The range of (x, Q) covered by this parametrization of the QCD
41870 C...evolved parton distributions is 1E-6 < x < 1 ;
41871 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41872 C...data only in a subset of that region; and the assumed DGLAP
41873 C...evolution is unlikely to be valid for all of it either.
41874 
41875 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41876 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41877 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41878 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41879 
41880  FUNCTION pyct5l(IFL,X,Q)
41881 
41882 C...Double precision declaration.
41883  IMPLICIT DOUBLE PRECISION(a-h, o-z)
41884  IMPLICIT INTEGER(i-n)
41885 
41886  parameter(nex=8, nlf=2)
41887  dimension am(0:nex,0:nlf,-5:2)
41888  dimension alfvec(-5:2), qmavec(-5:2)
41889  dimension mexvec(-5:2), mlfvec(-5:2)
41890  dimension ut1vec(-5:2), ut2vec(-5:2)
41891  dimension af(0:nex)
41892 
41893  DATA mexvec( 2) / 8 /
41894  DATA mlfvec( 2) / 2 /
41895  DATA ut1vec( 2) / 0.4971265e+01 /
41896  DATA ut2vec( 2) / -0.1105128e+01 /
41897  DATA alfvec( 2) / 0.2987216e+00 /
41898  DATA qmavec( 2) / 0.0000000e+00 /
41899  DATA (am( 0,k, 2),k=0, 2)
41900  & / 0.5292616e+01, -0.2751910e+01, -0.2488990e+01 /
41901  DATA (am( 1,k, 2),k=0, 2)
41902  & / 0.9714424e+00, 0.1011827e-01, -0.1023660e-01 /
41903  DATA (am( 2,k, 2),k=0, 2)
41904  & / -0.1651006e+02, 0.7959721e+01, 0.8810563e+01 /
41905  DATA (am( 3,k, 2),k=0, 2)
41906  & / -0.1643394e+02, 0.5892854e+01, 0.9348874e+01 /
41907  DATA (am( 4,k, 2),k=0, 2)
41908  & / 0.3067422e+02, 0.4235796e+01, -0.5112136e+00 /
41909  DATA (am( 5,k, 2),k=0, 2)
41910  & / 0.2352526e+02, -0.5305168e+01, -0.1169174e+02 /
41911  DATA (am( 6,k, 2),k=0, 2)
41912  & / -0.1095451e+02, 0.3006577e+01, 0.5638136e+01 /
41913  DATA (am( 7,k, 2),k=0, 2)
41914  & / -0.1172251e+02, -0.2183624e+01, 0.4955794e+01 /
41915  DATA (am( 8,k, 2),k=0, 2)
41916  & / 0.1662533e-01, 0.7622870e-02, -0.4895887e-03 /
41917 
41918  DATA mexvec( 1) / 8 /
41919  DATA mlfvec( 1) / 2 /
41920  DATA ut1vec( 1) / 0.2612618e+01 /
41921  DATA ut2vec( 1) / -0.1258304e+06 /
41922  DATA alfvec( 1) / 0.3407552e+00 /
41923  DATA qmavec( 1) / 0.0000000e+00 /
41924  DATA (am( 0,k, 1),k=0, 2)
41925  & / 0.9905300e+00, -0.4502235e+00, 0.1624441e+00 /
41926  DATA (am( 1,k, 1),k=0, 2)
41927  & / 0.8867534e+00, 0.1630829e-01, -0.4049085e-01 /
41928  DATA (am( 2,k, 1),k=0, 2)
41929  & / 0.8547974e+00, 0.3336301e+00, 0.1371388e+00 /
41930  DATA (am( 3,k, 1),k=0, 2)
41931  & / 0.2941113e+00, -0.1527905e+01, 0.2331879e+00 /
41932  DATA (am( 4,k, 1),k=0, 2)
41933  & / 0.3384235e+02, 0.3715315e+01, 0.8276930e+00 /
41934  DATA (am( 5,k, 1),k=0, 2)
41935  & / 0.6230115e+01, 0.3134639e+01, -0.1729099e+01 /
41936  DATA (am( 6,k, 1),k=0, 2)
41937  & / -0.1186928e+01, -0.3282460e+00, 0.1052020e+00 /
41938  DATA (am( 7,k, 1),k=0, 2)
41939  & / -0.8545702e+01, -0.6247947e+01, 0.3692561e+01 /
41940  DATA (am( 8,k, 1),k=0, 2)
41941  & / 0.1724598e-01, 0.7120465e-02, 0.4003646e-04 /
41942 
41943  DATA mexvec( 0) / 8 /
41944  DATA mlfvec( 0) / 2 /
41945  DATA ut1vec( 0) / -0.4656819e+00 /
41946  DATA ut2vec( 0) / -0.2742390e+03 /
41947  DATA alfvec( 0) / 0.4491863e+00 /
41948  DATA qmavec( 0) / 0.0000000e+00 /
41949  DATA (am( 0,k, 0),k=0, 2)
41950  & / 0.1193572e+03, -0.3886845e+01, -0.1133965e+01 /
41951  DATA (am( 1,k, 0),k=0, 2)
41952  & / -0.9421449e+02, 0.3995885e+01, 0.1607363e+01 /
41953  DATA (am( 2,k, 0),k=0, 2)
41954  & / 0.4206383e+01, 0.2485954e+00, 0.2497468e+00 /
41955  DATA (am( 3,k, 0),k=0, 2)
41956  & / 0.1210557e+03, -0.3015765e+01, -0.1423651e+01 /
41957  DATA (am( 4,k, 0),k=0, 2)
41958  & / -0.1013897e+03, -0.7113478e+00, 0.2621865e+00 /
41959  DATA (am( 5,k, 0),k=0, 2)
41960  & / -0.1312404e+01, -0.9297691e+00, -0.1562531e+00 /
41961  DATA (am( 6,k, 0),k=0, 2)
41962  & / 0.1627137e+01, 0.4954111e+00, -0.6387009e+00 /
41963  DATA (am( 7,k, 0),k=0, 2)
41964  & / 0.1537698e+00, -0.2487878e+00, 0.8305947e+00 /
41965  DATA (am( 8,k, 0),k=0, 2)
41966  & / 0.2496448e-01, 0.2457823e-02, 0.8234276e-03 /
41967 
41968  DATA mexvec(-1) / 8 /
41969  DATA mlfvec(-1) / 2 /
41970  DATA ut1vec(-1) / 0.3862583e+01 /
41971  DATA ut2vec(-1) / -0.1265969e+01 /
41972  DATA alfvec(-1) / 0.2457668e+00 /
41973  DATA qmavec(-1) / 0.0000000e+00 /
41974  DATA (am( 0,k,-1),k=0, 2)
41975  & / 0.2647441e+02, 0.1059277e+02, -0.9176654e+00 /
41976  DATA (am( 1,k,-1),k=0, 2)
41977  & / 0.1990636e+01, 0.8558918e-01, 0.4248667e-01 /
41978  DATA (am( 2,k,-1),k=0, 2)
41979  & / -0.1476095e+02, -0.3276255e+02, 0.1558110e+01 /
41980  DATA (am( 3,k,-1),k=0, 2)
41981  & / -0.2966889e+01, -0.3649037e+02, 0.1195914e+01 /
41982  DATA (am( 4,k,-1),k=0, 2)
41983  & / -0.1000519e+03, -0.2464635e+01, 0.1964849e+00 /
41984  DATA (am( 5,k,-1),k=0, 2)
41985  & / 0.3718331e+02, 0.4700389e+02, -0.2772142e+01 /
41986  DATA (am( 6,k,-1),k=0, 2)
41987  & / -0.1872722e+02, -0.2291189e+02, 0.1089052e+01 /
41988  DATA (am( 7,k,-1),k=0, 2)
41989  & / -0.1628146e+02, -0.1823993e+02, 0.2537369e+01 /
41990  DATA (am( 8,k,-1),k=0, 2)
41991  & / -0.1156300e+01, -0.1280495e+00, 0.5153245e-01 /
41992 
41993  DATA mexvec(-2) / 7 /
41994  DATA mlfvec(-2) / 2 /
41995  DATA ut1vec(-2) / 0.1895615e+00 /
41996  DATA ut2vec(-2) / -0.3069097e+01 /
41997  DATA alfvec(-2) / 0.5293999e+00 /
41998  DATA qmavec(-2) / 0.0000000e+00 /
41999  DATA (am( 0,k,-2),k=0, 2)
42000  & / -0.6556775e+00, 0.2490190e+00, 0.3966485e-01 /
42001  DATA (am( 1,k,-2),k=0, 2)
42002  & / 0.1305102e+01, -0.1188925e+00, -0.4600870e-02 /
42003  DATA (am( 2,k,-2),k=0, 2)
42004  & / -0.2371436e+01, 0.3566814e+00, -0.2834683e+00 /
42005  DATA (am( 3,k,-2),k=0, 2)
42006  & / -0.6152826e+01, 0.8339877e+00, -0.7233230e+00 /
42007  DATA (am( 4,k,-2),k=0, 2)
42008  & / -0.8346558e+01, 0.2892168e+01, 0.2137099e+00 /
42009  DATA (am( 5,k,-2),k=0, 2)
42010  & / 0.1279530e+02, 0.1021114e+00, 0.5787439e+00 /
42011  DATA (am( 6,k,-2),k=0, 2)
42012  & / 0.5858816e+00, -0.1940375e+01, -0.4029269e+00 /
42013  DATA (am( 7,k,-2),k=0, 2)
42014  & / -0.2795725e+02, -0.5263392e+00, 0.1290229e+01 /
42015 
42016  DATA mexvec(-3) / 7 /
42017  DATA mlfvec(-3) / 2 /
42018  DATA ut1vec(-3) / 0.3753257e+01 /
42019  DATA ut2vec(-3) / -0.1113085e+01 /
42020  DATA alfvec(-3) / 0.3713141e+00 /
42021  DATA qmavec(-3) / 0.0000000e+00 /
42022  DATA (am( 0,k,-3),k=0, 2)
42023  & / 0.1580931e+01, -0.2273826e+01, -0.1822245e+01 /
42024  DATA (am( 1,k,-3),k=0, 2)
42025  & / 0.2702644e+01, 0.6763243e+00, 0.7231586e-02 /
42026  DATA (am( 2,k,-3),k=0, 2)
42027  & / -0.1857924e+02, 0.3907500e+01, 0.5850109e+01 /
42028  DATA (am( 3,k,-3),k=0, 2)
42029  & / -0.3044793e+02, 0.2639332e+01, 0.5566644e+01 /
42030  DATA (am( 4,k,-3),k=0, 2)
42031  & / -0.4258011e+01, -0.5429244e+01, 0.4418946e+00 /
42032  DATA (am( 5,k,-3),k=0, 2)
42033  & / 0.3465259e+02, -0.5532604e+01, -0.4904153e+01 /
42034  DATA (am( 6,k,-3),k=0, 2)
42035  & / -0.1658858e+02, 0.2923275e+01, 0.2266286e+01 /
42036  DATA (am( 7,k,-3),k=0, 2)
42037  & / -0.1149263e+02, 0.2877475e+01, -0.7999105e+00 /
42038 
42039  DATA mexvec(-4) / 7 /
42040  DATA mlfvec(-4) / 2 /
42041  DATA ut1vec(-4) / 0.4400772e+01 /
42042  DATA ut2vec(-4) / -0.1356116e+01 /
42043  DATA alfvec(-4) / 0.3712017e-01 /
42044  DATA qmavec(-4) / 0.1300000e+01 /
42045  DATA (am( 0,k,-4),k=0, 2)
42046  & / -0.8293661e+00, -0.3982375e+01, -0.6494283e-01 /
42047  DATA (am( 1,k,-4),k=0, 2)
42048  & / 0.2754618e+01, 0.8338636e+00, -0.6885160e-01 /
42049  DATA (am( 2,k,-4),k=0, 2)
42050  & / -0.1657987e+02, 0.1439143e+02, -0.6887240e+00 /
42051  DATA (am( 3,k,-4),k=0, 2)
42052  & / -0.2800703e+02, 0.1535966e+02, -0.7377693e+00 /
42053  DATA (am( 4,k,-4),k=0, 2)
42054  & / -0.6460216e+01, -0.4783019e+01, 0.4913297e+00 /
42055  DATA (am( 5,k,-4),k=0, 2)
42056  & / 0.3141830e+02, -0.3178031e+02, 0.7136013e+01 /
42057  DATA (am( 6,k,-4),k=0, 2)
42058  & / -0.1802509e+02, 0.1862163e+02, -0.4632843e+01 /
42059  DATA (am( 7,k,-4),k=0, 2)
42060  & / -0.1240412e+02, 0.2565386e+02, -0.1066570e+02 /
42061 
42062  DATA mexvec(-5) / 6 /
42063  DATA mlfvec(-5) / 2 /
42064  DATA ut1vec(-5) / 0.5562568e+01 /
42065  DATA ut2vec(-5) / -0.1801317e+01 /
42066  DATA alfvec(-5) / 0.4952010e-02 /
42067  DATA qmavec(-5) / 0.4500000e+01 /
42068  DATA (am( 0,k,-5),k=0, 2)
42069  & / -0.6031237e+01, 0.1992727e+01, -0.1076331e+01 /
42070  DATA (am( 1,k,-5),k=0, 2)
42071  & / 0.2933912e+01, 0.5839674e+00, 0.7509435e-01 /
42072  DATA (am( 2,k,-5),k=0, 2)
42073  & / -0.8284919e+01, 0.1488593e+01, -0.8251678e+00 /
42074  DATA (am( 3,k,-5),k=0, 2)
42075  & / -0.1925986e+02, 0.2805753e+01, -0.3015446e+01 /
42076  DATA (am( 4,k,-5),k=0, 2)
42077  & / -0.9480483e+01, -0.9767837e+00, -0.1165544e+01 /
42078  DATA (am( 5,k,-5),k=0, 2)
42079  & / 0.2193195e+02, -0.1788518e+02, 0.9460908e+01 /
42080  DATA (am( 6,k,-5),k=0, 2)
42081  & / -0.1327377e+02, 0.1201754e+02, -0.6277844e+01 /
42082 
42083  IF(q .LE. qmavec(ifl)) THEN
42084  pyct5l = 0.d0
42085  RETURN
42086  ENDIF
42087 
42088  IF(x .GE. 1.d0) THEN
42089  pyct5l = 0.d0
42090  RETURN
42091  ENDIF
42092 
42093  tmp = log(q/alfvec(ifl))
42094  IF(tmp .LE. 0.d0) THEN
42095  pyct5l = 0.d0
42096  RETURN
42097  ENDIF
42098 
42099  sb = log(tmp)
42100  sb1 = sb - 1.2d0
42101  sb2 = sb1*sb1
42102 
42103  DO 110 i = 0, nex
42104  af(i) = 0.d0
42105  sbx = 1.d0
42106  DO 100 k = 0, mlfvec(ifl)
42107  af(i) = af(i) + sbx*am(i,k,ifl)
42108  sbx = sb1*sbx
42109  100 CONTINUE
42110  110 CONTINUE
42111 
42112  y = -log(x)
42113  u = log(x/0.00001d0)
42114 
42115  part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
42116  part2 = af(0)*(1.d0 - x) + af(3)*x
42117  part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
42118  part4 = ut1vec(ifl)*log(1.d0-x) +
42119  & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
42120 
42121  pyct5l = exp(log(x) + part1 + part2 + part3 + part4)
42122 
42123 C...Include threshold factor.
42124  pyct5l = pyct5l * (1.d0 - qmavec(ifl)/q)
42125 
42126  RETURN
42127  END
42128 
42129 C*********************************************************************
42130 
42131 C...PYCT5M
42132 C...Auxiliary function for parametrization of CTEQ5M1.
42133 C...Author: J. Pumplin 9/99.
42134 
42135  FUNCTION pyct5m(IFL,X,Q)
42136 
42137 C...Double precision declaration.
42138  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42139  IMPLICIT INTEGER(i-n)
42140 
42141  parameter(nex=8, nlf=2)
42142  dimension am(0:nex,0:nlf,-5:2)
42143  dimension alfvec(-5:2), qmavec(-5:2)
42144  dimension mexvec(-5:2), mlfvec(-5:2)
42145  dimension ut1vec(-5:2), ut2vec(-5:2)
42146  dimension af(0:nex)
42147 
42148  DATA mexvec( 2) / 8 /
42149  DATA mlfvec( 2) / 2 /
42150  DATA ut1vec( 2) / 0.5141718e+01 /
42151  DATA ut2vec( 2) / -0.1346944e+01 /
42152  DATA alfvec( 2) / 0.5260555e+00 /
42153  DATA qmavec( 2) / 0.0000000e+00 /
42154  DATA (am( 0,k, 2),k=0, 2)
42155  & / 0.4289071e+01, -0.2536870e+01, -0.1259948e+01 /
42156  DATA (am( 1,k, 2),k=0, 2)
42157  & / 0.9839410e+00, 0.4168426e-01, -0.5018952e-01 /
42158  DATA (am( 2,k, 2),k=0, 2)
42159  & / -0.1651961e+02, 0.9246261e+01, 0.5996400e+01 /
42160  DATA (am( 3,k, 2),k=0, 2)
42161  & / -0.2077936e+02, 0.9786469e+01, 0.7656465e+01 /
42162  DATA (am( 4,k, 2),k=0, 2)
42163  & / 0.3054926e+02, 0.1889536e+01, 0.1380541e+01 /
42164  DATA (am( 5,k, 2),k=0, 2)
42165  & / 0.3084695e+02, -0.1212303e+02, -0.1053551e+02 /
42166  DATA (am( 6,k, 2),k=0, 2)
42167  & / -0.1426778e+02, 0.6239537e+01, 0.5254819e+01 /
42168  DATA (am( 7,k, 2),k=0, 2)
42169  & / -0.1909811e+02, 0.3695678e+01, 0.5495729e+01 /
42170  DATA (am( 8,k, 2),k=0, 2)
42171  & / 0.1889751e-01, 0.5027193e-02, 0.6624896e-03 /
42172 
42173  DATA mexvec( 1) / 8 /
42174  DATA mlfvec( 1) / 2 /
42175  DATA ut1vec( 1) / 0.4138426e+01 /
42176  DATA ut2vec( 1) / -0.3221374e+01 /
42177  DATA alfvec( 1) / 0.4960962e+00 /
42178  DATA qmavec( 1) / 0.0000000e+00 /
42179  DATA (am( 0,k, 1),k=0, 2)
42180  & / 0.1332497e+01, -0.3703718e+00, 0.1288638e+00 /
42181  DATA (am( 1,k, 1),k=0, 2)
42182  & / 0.7544687e+00, 0.3255075e-01, -0.4706680e-01 /
42183  DATA (am( 2,k, 1),k=0, 2)
42184  & / -0.7638814e+00, 0.5008313e+00, -0.9237374e-01 /
42185  DATA (am( 3,k, 1),k=0, 2)
42186  & / -0.3689889e+00, -0.1055098e+01, -0.4645065e+00 /
42187  DATA (am( 4,k, 1),k=0, 2)
42188  & / 0.3991610e+02, 0.1979881e+01, 0.1775814e+01 /
42189  DATA (am( 5,k, 1),k=0, 2)
42190  & / 0.6201080e+01, 0.2046288e+01, 0.3804571e+00 /
42191  DATA (am( 6,k, 1),k=0, 2)
42192  & / -0.8027900e+00, -0.7011688e+00, -0.8049612e+00 /
42193  DATA (am( 7,k, 1),k=0, 2)
42194  & / -0.8631305e+01, -0.3981200e+01, 0.6970153e+00 /
42195  DATA (am( 8,k, 1),k=0, 2)
42196  & / 0.2371230e-01, 0.5372683e-02, 0.1118701e-02 /
42197 
42198  DATA mexvec( 0) / 8 /
42199  DATA mlfvec( 0) / 2 /
42200  DATA ut1vec( 0) / -0.1026789e+01 /
42201  DATA ut2vec( 0) / -0.9051707e+01 /
42202  DATA alfvec( 0) / 0.9462977e+00 /
42203  DATA qmavec( 0) / 0.0000000e+00 /
42204  DATA (am( 0,k, 0),k=0, 2)
42205  & / 0.1191990e+03, -0.8548739e+00, -0.1963040e+01 /
42206  DATA (am( 1,k, 0),k=0, 2)
42207  & / -0.9449972e+02, 0.1074771e+01, 0.2056055e+01 /
42208  DATA (am( 2,k, 0),k=0, 2)
42209  & / 0.3701064e+01, -0.1167947e-02, 0.1933573e+00 /
42210  DATA (am( 3,k, 0),k=0, 2)
42211  & / 0.1171345e+03, -0.1064540e+01, -0.1875312e+01 /
42212  DATA (am( 4,k, 0),k=0, 2)
42213  & / -0.1014453e+03, -0.5707427e+00, 0.4511242e-01 /
42214  DATA (am( 5,k, 0),k=0, 2)
42215  & / 0.6365168e+01, 0.1275354e+01, -0.4964081e+00 /
42216  DATA (am( 6,k, 0),k=0, 2)
42217  & / -0.3370693e+01, -0.1122020e+01, 0.5947751e-01 /
42218  DATA (am( 7,k, 0),k=0, 2)
42219  & / -0.5327270e+01, -0.9293556e+00, 0.6629940e+00 /
42220  DATA (am( 8,k, 0),k=0, 2)
42221  & / 0.2437513e-01, 0.1600939e-02, 0.6855336e-03 /
42222 
42223  DATA mexvec(-1) / 8 /
42224  DATA mlfvec(-1) / 2 /
42225  DATA ut1vec(-1) / 0.5243571e+01 /
42226  DATA ut2vec(-1) / -0.2870513e+01 /
42227  DATA alfvec(-1) / 0.6701448e+00 /
42228  DATA qmavec(-1) / 0.0000000e+00 /
42229  DATA (am( 0,k,-1),k=0, 2)
42230  & / 0.2428863e+02, 0.1907035e+01, -0.4606457e+00 /
42231  DATA (am( 1,k,-1),k=0, 2)
42232  & / 0.2006810e+01, -0.1265915e+00, 0.7153556e-02 /
42233  DATA (am( 2,k,-1),k=0, 2)
42234  & / -0.1884546e+02, -0.2339471e+01, 0.5740679e+01 /
42235  DATA (am( 3,k,-1),k=0, 2)
42236  & / -0.2527892e+02, -0.2044124e+01, 0.1280470e+02 /
42237  DATA (am( 4,k,-1),k=0, 2)
42238  & / -0.1013824e+03, -0.1594199e+01, 0.2216401e+00 /
42239  DATA (am( 5,k,-1),k=0, 2)
42240  & / 0.8070930e+02, 0.1792072e+01, -0.2164364e+02 /
42241  DATA (am( 6,k,-1),k=0, 2)
42242  & / -0.4641050e+02, 0.1977338e+00, 0.1273014e+02 /
42243  DATA (am( 7,k,-1),k=0, 2)
42244  & / -0.3910568e+02, 0.1719632e+01, 0.1086525e+02 /
42245  DATA (am( 8,k,-1),k=0, 2)
42246  & / -0.1185496e+01, -0.1905847e+00, -0.8744118e-03 /
42247 
42248  DATA mexvec(-2) / 7 /
42249  DATA mlfvec(-2) / 2 /
42250  DATA ut1vec(-2) / 0.4782210e+01 /
42251  DATA ut2vec(-2) / -0.1976856e+02 /
42252  DATA alfvec(-2) / 0.7558374e+00 /
42253  DATA qmavec(-2) / 0.0000000e+00 /
42254  DATA (am( 0,k,-2),k=0, 2)
42255  & / -0.6216935e+00, 0.2369963e+00, -0.7909949e-02 /
42256  DATA (am( 1,k,-2),k=0, 2)
42257  & / 0.1245440e+01, -0.1031510e+00, 0.4916523e-02 /
42258  DATA (am( 2,k,-2),k=0, 2)
42259  & / -0.7060824e+01, -0.3875283e-01, 0.1784981e+00 /
42260  DATA (am( 3,k,-2),k=0, 2)
42261  & / -0.7430595e+01, 0.1964572e+00, -0.1284999e+00 /
42262  DATA (am( 4,k,-2),k=0, 2)
42263  & / -0.6897810e+01, 0.2620543e+01, 0.8012553e-02 /
42264  DATA (am( 5,k,-2),k=0, 2)
42265  & / 0.1507713e+02, 0.2340307e-01, 0.2482535e+01 /
42266  DATA (am( 6,k,-2),k=0, 2)
42267  & / -0.1815341e+01, -0.1538698e+01, -0.2014208e+01 /
42268  DATA (am( 7,k,-2),k=0, 2)
42269  & / -0.2571932e+02, 0.2903941e+00, -0.2848206e+01 /
42270 
42271  DATA mexvec(-3) / 7 /
42272  DATA mlfvec(-3) / 2 /
42273  DATA ut1vec(-3) / 0.4518239e+01 /
42274  DATA ut2vec(-3) / -0.2690590e+01 /
42275  DATA alfvec(-3) / 0.6124079e+00 /
42276  DATA qmavec(-3) / 0.0000000e+00 /
42277  DATA (am( 0,k,-3),k=0, 2)
42278  & / -0.2734458e+01, -0.7245673e+00, -0.6351374e+00 /
42279  DATA (am( 1,k,-3),k=0, 2)
42280  & / 0.2927174e+01, 0.4822709e+00, -0.1088787e-01 /
42281  DATA (am( 2,k,-3),k=0, 2)
42282  & / -0.1771017e+02, -0.1416635e+01, 0.8467622e+01 /
42283  DATA (am( 3,k,-3),k=0, 2)
42284  & / -0.4972782e+02, -0.3348547e+01, 0.1767061e+02 /
42285  DATA (am( 4,k,-3),k=0, 2)
42286  & / -0.7102770e+01, -0.3205337e+01, 0.4101704e+00 /
42287  DATA (am( 5,k,-3),k=0, 2)
42288  & / 0.7169698e+02, -0.2205985e+01, -0.2463931e+02 /
42289  DATA (am( 6,k,-3),k=0, 2)
42290  & / -0.4090347e+02, 0.2103486e+01, 0.1416507e+02 /
42291  DATA (am( 7,k,-3),k=0, 2)
42292  & / -0.2952639e+02, 0.5376136e+01, 0.7825585e+01 /
42293 
42294  DATA mexvec(-4) / 7 /
42295  DATA mlfvec(-4) / 2 /
42296  DATA ut1vec(-4) / 0.2783230e+01 /
42297  DATA ut2vec(-4) / -0.1746328e+01 /
42298  DATA alfvec(-4) / 0.1115653e+01 /
42299  DATA qmavec(-4) / 0.1300000e+01 /
42300  DATA (am( 0,k,-4),k=0, 2)
42301  & / -0.1743872e+01, -0.1128921e+01, -0.2841969e+00 /
42302  DATA (am( 1,k,-4),k=0, 2)
42303  & / 0.3345755e+01, 0.3187765e+00, 0.1378124e+00 /
42304  DATA (am( 2,k,-4),k=0, 2)
42305  & / -0.2037615e+02, 0.4121687e+01, 0.2236520e+00 /
42306  DATA (am( 3,k,-4),k=0, 2)
42307  & / -0.4703104e+02, 0.5353087e+01, -0.1455347e+01 /
42308  DATA (am( 4,k,-4),k=0, 2)
42309  & / -0.1060230e+02, -0.1551122e+01, -0.1078863e+01 /
42310  DATA (am( 5,k,-4),k=0, 2)
42311  & / 0.5088892e+02, -0.8197304e+01, 0.8083451e+01 /
42312  DATA (am( 6,k,-4),k=0, 2)
42313  & / -0.2819070e+02, 0.4554086e+01, -0.5890995e+01 /
42314  DATA (am( 7,k,-4),k=0, 2)
42315  & / -0.1098238e+02, 0.2590096e+01, -0.8062879e+01 /
42316 
42317  DATA mexvec(-5) / 6 /
42318  DATA mlfvec(-5) / 2 /
42319  DATA ut1vec(-5) / 0.1619654e+02 /
42320  DATA ut2vec(-5) / -0.3367346e+01 /
42321  DATA alfvec(-5) / 0.5109891e-02 /
42322  DATA qmavec(-5) / 0.4500000e+01 /
42323  DATA (am( 0,k,-5),k=0, 2)
42324  & / -0.6800138e+01, 0.2493627e+01, -0.1075724e+01 /
42325  DATA (am( 1,k,-5),k=0, 2)
42326  & / 0.3036555e+01, 0.3324733e+00, 0.2008298e+00 /
42327  DATA (am( 2,k,-5),k=0, 2)
42328  & / -0.5203879e+01, -0.8493476e+01, -0.4523208e+01 /
42329  DATA (am( 3,k,-5),k=0, 2)
42330  & / -0.1524239e+01, -0.3411912e+01, -0.1771867e+02 /
42331  DATA (am( 4,k,-5),k=0, 2)
42332  & / -0.1099444e+02, 0.1320930e+01, -0.2353831e+01 /
42333  DATA (am( 5,k,-5),k=0, 2)
42334  & / 0.1699299e+02, -0.3565802e+02, 0.3566872e+02 /
42335  DATA (am( 6,k,-5),k=0, 2)
42336  & / -0.1465793e+02, 0.2703365e+02, -0.2176372e+02 /
42337 
42338  IF(q .LE. qmavec(ifl)) THEN
42339  pyct5m = 0.d0
42340  RETURN
42341  ENDIF
42342 
42343  IF(x .GE. 1.d0) THEN
42344  pyct5m = 0.d0
42345  RETURN
42346  ENDIF
42347 
42348  tmp = log(q/alfvec(ifl))
42349  IF(tmp .LE. 0.d0) THEN
42350  pyct5m = 0.d0
42351  RETURN
42352  ENDIF
42353 
42354  sb = log(tmp)
42355  sb1 = sb - 1.2d0
42356  sb2 = sb1*sb1
42357 
42358  DO 110 i = 0, nex
42359  af(i) = 0.d0
42360  sbx = 1.d0
42361  DO 100 k = 0, mlfvec(ifl)
42362  af(i) = af(i) + sbx*am(i,k,ifl)
42363  sbx = sb1*sbx
42364  100 CONTINUE
42365  110 CONTINUE
42366 
42367  y = -log(x)
42368  u = log(x/0.00001d0)
42369 
42370  part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
42371  part2 = af(0)*(1.d0 - x) + af(3)*x
42372  part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
42373  part4 = ut1vec(ifl)*log(1.d0-x) +
42374  & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
42375 
42376  pyct5m = exp(log(x) + part1 + part2 + part3 + part4)
42377 
42378 C...Include threshold factor.
42379  pyct5m = pyct5m * (1.d0 - qmavec(ifl)/q)
42380 
42381  RETURN
42382  END
42383 
42384 C*********************************************************************
42385 
42386 C...PYPDPO
42387 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
42388 C...a few older parametrizations, now obsolete but convenient for
42389 C...backwards checks.
42390 
42391  SUBROUTINE pypdpo(X,Q2,XPPR)
42392 
42393 C...Double precision and integer declarations.
42394  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42395  IMPLICIT INTEGER(i-n)
42396  INTEGER pyk,pychge,pycomp
42397 C...Commonblocks.
42398  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42399  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
42400  common/pypars/mstp(200),parp(200),msti(200),pari(200)
42401  common/pyint1/mint(400),vint(400)
42402  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
42403  dimension xppr(-6:6),xq(9),tx(6),tt(6),ts(6),nehlq(8,2),
42404  &cehlq(6,6,2,8,2),cdo(3,6,5,2)
42405 
42406 
42407 C...The following data lines are coefficients needed in the
42408 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
42409 C...parametrizations, see below.
42410 C...Powers of 1-x in different cases.
42411  DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
42412 C...Expansion coefficients for up valence quark distribution.
42413  DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/
42414  1 7.677d-01,-2.087d-01,-3.303d-01,-2.517d-02,-1.570d-02,-1.000d-04,
42415  2-5.326d-01,-2.661d-01, 3.201d-01, 1.192d-01, 2.434d-02, 7.620d-03,
42416  3 2.162d-01, 1.881d-01,-8.375d-02,-6.515d-02,-1.743d-02,-5.040d-03,
42417  4-9.211d-02,-9.952d-02, 1.373d-02, 2.506d-02, 8.770d-03, 2.550d-03,
42418  5 3.670d-02, 4.409d-02, 9.600d-04,-7.960d-03,-3.420d-03,-1.050d-03,
42419  6-1.549d-02,-2.026d-02,-3.060d-03, 2.220d-03, 1.240d-03, 4.100d-04,
42420  1 2.395d-01, 2.905d-01, 9.778d-02, 2.149d-02, 3.440d-03, 5.000d-04,
42421  2 1.751d-02,-6.090d-03,-2.687d-02,-1.916d-02,-7.970d-03,-2.750d-03,
42422  3-5.760d-03,-5.040d-03, 1.080d-03, 2.490d-03, 1.530d-03, 7.500d-04,
42423  4 1.740d-03, 1.960d-03, 3.000d-04,-3.400d-04,-2.900d-04,-1.800d-04,
42424  5-5.300d-04,-6.400d-04,-1.700d-04, 4.000d-05, 6.000d-05, 4.000d-05,
42425  6 1.700d-04, 2.200d-04, 8.000d-05, 1.000d-05,-1.000d-05,-1.000d-05/
42426  DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/
42427  1 7.237d-01,-2.189d-01,-2.995d-01,-1.909d-02,-1.477d-02, 2.500d-04,
42428  2-5.314d-01,-2.425d-01, 3.283d-01, 1.119d-01, 2.223d-02, 7.070d-03,
42429  3 2.289d-01, 1.890d-01,-9.859d-02,-6.900d-02,-1.747d-02,-5.080d-03,
42430  4-1.041d-01,-1.084d-01, 2.108d-02, 2.975d-02, 9.830d-03, 2.830d-03,
42431  5 4.394d-02, 5.116d-02,-1.410d-03,-1.055d-02,-4.230d-03,-1.270d-03,
42432  6-1.991d-02,-2.539d-02,-2.780d-03, 3.430d-03, 1.720d-03, 5.500d-04,
42433  1 2.410d-01, 2.884d-01, 9.369d-02, 1.900d-02, 2.530d-03, 2.400d-04,
42434  2 1.765d-02,-9.220d-03,-3.037d-02,-2.085d-02,-8.440d-03,-2.810d-03,
42435  3-6.450d-03,-5.260d-03, 1.720d-03, 3.110d-03, 1.830d-03, 8.700d-04,
42436  4 2.120d-03, 2.320d-03, 2.600d-04,-4.900d-04,-3.900d-04,-2.300d-04,
42437  5-6.900d-04,-8.200d-04,-2.000d-04, 7.000d-05, 9.000d-05, 6.000d-05,
42438  6 2.400d-04, 3.100d-04, 1.100d-04, 0.000d+00,-2.000d-05,-2.000d-05/
42439 C...Expansion coefficients for down valence quark distribution.
42440  DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/
42441  1 3.813d-01,-8.090d-02,-1.634d-01,-2.185d-02,-8.430d-03,-6.200d-04,
42442  2-2.948d-01,-1.435d-01, 1.665d-01, 6.638d-02, 1.473d-02, 4.080d-03,
42443  3 1.252d-01, 1.042d-01,-4.722d-02,-3.683d-02,-1.038d-02,-2.860d-03,
42444  4-5.478d-02,-5.678d-02, 8.900d-03, 1.484d-02, 5.340d-03, 1.520d-03,
42445  5 2.220d-02, 2.567d-02,-3.000d-05,-4.970d-03,-2.160d-03,-6.500d-04,
42446  6-9.530d-03,-1.204d-02,-1.510d-03, 1.510d-03, 8.300d-04, 2.700d-04,
42447  1 1.261d-01, 1.354d-01, 3.958d-02, 8.240d-03, 1.660d-03, 4.500d-04,
42448  2 3.890d-03,-1.159d-02,-1.625d-02,-9.610d-03,-3.710d-03,-1.260d-03,
42449  3-1.910d-03,-5.600d-04, 1.590d-03, 1.590d-03, 8.400d-04, 3.900d-04,
42450  4 6.400d-04, 4.900d-04,-1.500d-04,-2.900d-04,-1.800d-04,-1.000d-04,
42451  5-2.000d-04,-1.900d-04, 0.000d+00, 6.000d-05, 4.000d-05, 3.000d-05,
42452  6 7.000d-05, 8.000d-05, 2.000d-05,-1.000d-05,-1.000d-05,-1.000d-05/
42453  DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/
42454  1 3.578d-01,-8.622d-02,-1.480d-01,-1.840d-02,-7.820d-03,-4.500d-04,
42455  2-2.925d-01,-1.304d-01, 1.696d-01, 6.243d-02, 1.353d-02, 3.750d-03,
42456  3 1.318d-01, 1.041d-01,-5.486d-02,-3.872d-02,-1.038d-02,-2.850d-03,
42457  4-6.162d-02,-6.143d-02, 1.303d-02, 1.740d-02, 5.940d-03, 1.670d-03,
42458  5 2.643d-02, 2.957d-02,-1.490d-03,-6.450d-03,-2.630d-03,-7.700d-04,
42459  6-1.218d-02,-1.497d-02,-1.260d-03, 2.240d-03, 1.120d-03, 3.500d-04,
42460  1 1.263d-01, 1.334d-01, 3.732d-02, 7.070d-03, 1.260d-03, 3.400d-04,
42461  2 3.660d-03,-1.357d-02,-1.795d-02,-1.031d-02,-3.880d-03,-1.280d-03,
42462  3-2.100d-03,-3.600d-04, 2.050d-03, 1.920d-03, 9.800d-04, 4.400d-04,
42463  4 7.700d-04, 5.400d-04,-2.400d-04,-3.900d-04,-2.400d-04,-1.300d-04,
42464  5-2.600d-04,-2.300d-04, 2.000d-05, 9.000d-05, 6.000d-05, 4.000d-05,
42465  6 9.000d-05, 1.000d-04, 2.000d-05,-2.000d-05,-2.000d-05,-1.000d-05/
42466 C...Expansion coefficients for up and down sea quark distributions.
42467  DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/
42468  1 6.870d-02,-6.861d-02, 2.973d-02,-5.400d-03, 3.780d-03,-9.700d-04,
42469  2-1.802d-02, 1.400d-04, 6.490d-03,-8.540d-03, 1.220d-03,-1.750d-03,
42470  3-4.650d-03, 1.480d-03,-5.930d-03, 6.000d-04,-1.030d-03,-8.000d-05,
42471  4 6.440d-03, 2.570d-03, 2.830d-03, 1.150d-03, 7.100d-04, 3.300d-04,
42472  5-3.930d-03,-2.540d-03,-1.160d-03,-7.700d-04,-3.600d-04,-1.900d-04,
42473  6 2.340d-03, 1.930d-03, 5.300d-04, 3.700d-04, 1.600d-04, 9.000d-05,
42474  1 1.014d+00,-1.106d+00, 3.374d-01,-7.444d-02, 8.850d-03,-8.700d-04,
42475  2 9.233d-01,-1.285d+00, 4.475d-01,-9.786d-02, 1.419d-02,-1.120d-03,
42476  3 4.888d-02,-1.271d-01, 8.606d-02,-2.608d-02, 4.780d-03,-6.000d-04,
42477  4-2.691d-02, 4.887d-02,-1.771d-02, 1.620d-03, 2.500d-04,-6.000d-05,
42478  5 7.040d-03,-1.113d-02, 1.590d-03, 7.000d-04,-2.000d-04, 0.000d+00,
42479  6-1.710d-03, 2.290d-03, 3.800d-04,-3.500d-04, 4.000d-05, 1.000d-05/
42480  DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/
42481  1 1.008d-01,-7.100d-02, 1.973d-02,-5.710d-03, 2.930d-03,-9.900d-04,
42482  2-5.271d-02,-1.823d-02, 1.792d-02,-6.580d-03, 1.750d-03,-1.550d-03,
42483  3 1.220d-02, 1.763d-02,-8.690d-03,-8.800d-04,-1.160d-03,-2.100d-04,
42484  4-1.190d-03,-7.180d-03, 2.360d-03, 1.890d-03, 7.700d-04, 4.100d-04,
42485  5-9.100d-04, 2.040d-03,-3.100d-04,-1.050d-03,-4.000d-04,-2.400d-04,
42486  6 1.190d-03,-1.700d-04,-2.000d-04, 4.200d-04, 1.700d-04, 1.000d-04,
42487  1 1.081d+00,-1.189d+00, 3.868d-01,-8.617d-02, 1.115d-02,-1.180d-03,
42488  2 9.917d-01,-1.396d+00, 4.998d-01,-1.159d-01, 1.674d-02,-1.720d-03,
42489  3 5.099d-02,-1.338d-01, 9.173d-02,-2.885d-02, 5.890d-03,-6.500d-04,
42490  4-3.178d-02, 5.703d-02,-2.070d-02, 2.440d-03, 1.100d-04,-9.000d-05,
42491  5 8.970d-03,-1.392d-02, 2.050d-03, 6.500d-04,-2.300d-04, 2.000d-05,
42492  6-2.340d-03, 3.010d-03, 5.000d-04,-3.900d-04, 6.000d-05, 1.000d-05/
42493 C...Expansion coefficients for gluon distribution.
42494  DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/
42495  1 9.482d-01,-9.578d-01, 1.009d-01,-1.051d-01, 3.456d-02,-3.054d-02,
42496  2-9.627d-01, 5.379d-01, 3.368d-01,-9.525d-02, 1.488d-02,-2.051d-02,
42497  3 4.300d-01,-8.306d-02,-3.372d-01, 4.902d-02,-9.160d-03, 1.041d-02,
42498  4-1.925d-01,-1.790d-02, 2.183d-01, 7.490d-03, 4.140d-03,-1.860d-03,
42499  5 8.183d-02, 1.926d-02,-1.072d-01,-1.944d-02,-2.770d-03,-5.200d-04,
42500  6-3.884d-02,-1.234d-02, 5.410d-02, 1.879d-02, 3.350d-03, 1.040d-03,
42501  1 2.948d+01,-3.902d+01, 1.464d+01,-3.335d+00, 5.054d-01,-5.915d-02,
42502  2 2.559d+01,-3.955d+01, 1.661d+01,-4.299d+00, 6.904d-01,-8.243d-02,
42503  3-1.663d+00, 1.176d+00, 1.118d+00,-7.099d-01, 1.948d-01,-2.404d-02,
42504  4-2.168d-01, 8.170d-01,-7.169d-01, 1.851d-01,-1.924d-02,-3.250d-03,
42505  5 2.088d-01,-4.355d-01, 2.239d-01,-2.446d-02,-3.620d-03, 1.910d-03,
42506  6-9.097d-02, 1.601d-01,-5.681d-02,-2.500d-03, 2.580d-03,-4.700d-04/
42507  DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/
42508  1 2.367d+00, 4.453d-01, 3.660d-01, 9.467d-02, 1.341d-01, 1.661d-02,
42509  2-3.170d+00,-1.795d+00, 3.313d-02,-2.874d-01,-9.827d-02,-7.119d-02,
42510  3 1.823d+00, 1.457d+00,-2.465d-01, 3.739d-02, 6.090d-03, 1.814d-02,
42511  4-1.033d+00,-9.827d-01, 2.136d-01, 1.169d-01, 5.001d-02, 1.684d-02,
42512  5 5.133d-01, 5.259d-01,-1.173d-01,-1.139d-01,-4.988d-02,-2.021d-02,
42513  6-2.881d-01,-3.145d-01, 5.667d-02, 9.161d-02, 4.568d-02, 1.951d-02,
42514  1 3.036d+01,-4.062d+01, 1.578d+01,-3.699d+00, 6.020d-01,-7.031d-02,
42515  2 2.700d+01,-4.167d+01, 1.770d+01,-4.804d+00, 7.862d-01,-1.060d-01,
42516  3-1.909d+00, 1.357d+00, 1.127d+00,-7.181d-01, 2.232d-01,-2.481d-02,
42517  4-2.488d-01, 9.781d-01,-8.127d-01, 2.094d-01,-2.997d-02,-4.710d-03,
42518  5 2.506d-01,-5.427d-01, 2.672d-01,-3.103d-02,-1.800d-03, 2.870d-03,
42519  6-1.128d-01, 2.087d-01,-6.972d-02,-2.480d-03, 2.630d-03,-8.400d-04/
42520 C...Expansion coefficients for strange sea quark distribution.
42521  DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/
42522  1 4.968d-02,-4.173d-02, 2.102d-02,-3.270d-03, 3.240d-03,-6.700d-04,
42523  2-6.150d-03,-1.294d-02, 6.740d-03,-6.890d-03, 9.000d-04,-1.510d-03,
42524  3-8.580d-03, 5.050d-03,-4.900d-03,-1.600d-04,-9.400d-04,-1.500d-04,
42525  4 7.840d-03, 1.510d-03, 2.220d-03, 1.400d-03, 7.000d-04, 3.500d-04,
42526  5-4.410d-03,-2.220d-03,-8.900d-04,-8.500d-04,-3.600d-04,-2.000d-04,
42527  6 2.520d-03, 1.840d-03, 4.100d-04, 3.900d-04, 1.600d-04, 9.000d-05,
42528  1 9.235d-01,-1.085d+00, 3.464d-01,-7.210d-02, 9.140d-03,-9.100d-04,
42529  2 9.315d-01,-1.274d+00, 4.512d-01,-9.775d-02, 1.380d-02,-1.310d-03,
42530  3 4.739d-02,-1.296d-01, 8.482d-02,-2.642d-02, 4.760d-03,-5.700d-04,
42531  4-2.653d-02, 4.953d-02,-1.735d-02, 1.750d-03, 2.800d-04,-6.000d-05,
42532  5 6.940d-03,-1.132d-02, 1.480d-03, 6.500d-04,-2.100d-04, 0.000d+00,
42533  6-1.680d-03, 2.340d-03, 4.200d-04,-3.400d-04, 5.000d-05, 1.000d-05/
42534  DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/
42535  1 6.478d-02,-4.537d-02, 1.643d-02,-3.490d-03, 2.710d-03,-6.700d-04,
42536  2-2.223d-02,-2.126d-02, 1.247d-02,-6.290d-03, 1.120d-03,-1.440d-03,
42537  3-1.340d-03, 1.362d-02,-6.130d-03,-7.900d-04,-9.000d-04,-2.000d-04,
42538  4 5.080d-03,-3.610d-03, 1.700d-03, 1.830d-03, 6.800d-04, 4.000d-04,
42539  5-3.580d-03, 6.000d-05,-2.600d-04,-1.050d-03,-3.800d-04,-2.300d-04,
42540  6 2.420d-03, 9.300d-04,-1.000d-04, 4.500d-04, 1.700d-04, 1.100d-04,
42541  1 9.868d-01,-1.171d+00, 3.940d-01,-8.459d-02, 1.124d-02,-1.250d-03,
42542  2 1.001d+00,-1.383d+00, 5.044d-01,-1.152d-01, 1.658d-02,-1.830d-03,
42543  3 4.928d-02,-1.368d-01, 9.021d-02,-2.935d-02, 5.800d-03,-6.600d-04,
42544  4-3.133d-02, 5.785d-02,-2.023d-02, 2.630d-03, 1.600d-04,-8.000d-05,
42545  5 8.840d-03,-1.416d-02, 1.900d-03, 5.800d-04,-2.500d-04, 1.000d-05,
42546  6-2.300d-03, 3.080d-03, 5.500d-04,-3.700d-04, 7.000d-05, 1.000d-05/
42547 C...Expansion coefficients for charm sea quark distribution.
42548  DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/
42549  1 9.270d-03,-1.817d-02, 9.590d-03,-6.390d-03, 1.690d-03,-1.540d-03,
42550  2 5.710d-03,-1.188d-02, 6.090d-03,-4.650d-03, 1.240d-03,-1.310d-03,
42551  3-3.960d-03, 7.100d-03,-3.590d-03, 1.840d-03,-3.900d-04, 3.400d-04,
42552  4 1.120d-03,-1.960d-03, 1.120d-03,-4.800d-04, 1.000d-04,-4.000d-05,
42553  5 4.000d-05,-3.000d-05,-1.800d-04, 9.000d-05,-5.000d-05,-2.000d-05,
42554  6-4.200d-04, 7.300d-04,-1.600d-04, 5.000d-05, 5.000d-05, 5.000d-05,
42555  1 8.098d-01,-1.042d+00, 3.398d-01,-6.824d-02, 8.760d-03,-9.000d-04,
42556  2 8.961d-01,-1.217d+00, 4.339d-01,-9.287d-02, 1.304d-02,-1.290d-03,
42557  3 3.058d-02,-1.040d-01, 7.604d-02,-2.415d-02, 4.600d-03,-5.000d-04,
42558  4-2.451d-02, 4.432d-02,-1.651d-02, 1.430d-03, 1.200d-04,-1.000d-04,
42559  5 1.122d-02,-1.457d-02, 2.680d-03, 5.800d-04,-1.200d-04, 3.000d-05,
42560  6-7.730d-03, 7.330d-03,-7.600d-04,-2.400d-04, 1.000d-05, 0.000d+00/
42561  DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/
42562  1 9.980d-03,-1.945d-02, 1.055d-02,-6.870d-03, 1.860d-03,-1.560d-03,
42563  2 5.700d-03,-1.203d-02, 6.250d-03,-4.860d-03, 1.310d-03,-1.370d-03,
42564  3-4.490d-03, 7.990d-03,-4.170d-03, 2.050d-03,-4.400d-04, 3.300d-04,
42565  4 1.470d-03,-2.480d-03, 1.460d-03,-5.700d-04, 1.200d-04,-1.000d-05,
42566  5-9.000d-05, 1.500d-04,-3.200d-04, 1.200d-04,-6.000d-05,-4.000d-05,
42567  6-4.200d-04, 7.600d-04,-1.400d-04, 4.000d-05, 7.000d-05, 5.000d-05,
42568  1 8.698d-01,-1.131d+00, 3.836d-01,-8.111d-02, 1.048d-02,-1.300d-03,
42569  2 9.626d-01,-1.321d+00, 4.854d-01,-1.091d-01, 1.583d-02,-1.700d-03,
42570  3 3.057d-02,-1.088d-01, 8.022d-02,-2.676d-02, 5.590d-03,-5.600d-04,
42571  4-2.845d-02, 5.164d-02,-1.918d-02, 2.210d-03,-4.000d-05,-1.500d-04,
42572  5 1.311d-02,-1.751d-02, 3.310d-03, 5.100d-04,-1.200d-04, 5.000d-05,
42573  6-8.590d-03, 8.380d-03,-9.200d-04,-2.600d-04, 1.000d-05,-1.000d-05/
42574 C...Expansion coefficients for bottom sea quark distribution.
42575  DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/
42576  1 9.010d-03,-1.401d-02, 7.150d-03,-4.130d-03, 1.260d-03,-1.040d-03,
42577  2 6.280d-03,-9.320d-03, 4.780d-03,-2.890d-03, 9.100d-04,-8.200d-04,
42578  3-2.930d-03, 4.090d-03,-1.890d-03, 7.600d-04,-2.300d-04, 1.400d-04,
42579  4 3.900d-04,-1.200d-03, 4.400d-04,-2.500d-04, 2.000d-05,-2.000d-05,
42580  5 2.600d-04, 1.400d-04,-8.000d-05, 1.000d-04, 1.000d-05, 1.000d-05,
42581  6-2.600d-04, 3.200d-04, 1.000d-05,-1.000d-05, 1.000d-05,-1.000d-05,
42582  1 8.029d-01,-1.075d+00, 3.792d-01,-7.843d-02, 1.007d-02,-1.090d-03,
42583  2 7.903d-01,-1.099d+00, 4.153d-01,-9.301d-02, 1.317d-02,-1.410d-03,
42584  3-1.704d-02,-1.130d-02, 2.882d-02,-1.341d-02, 3.040d-03,-3.600d-04,
42585  4-7.200d-04, 7.230d-03,-5.160d-03, 1.080d-03,-5.000d-05,-4.000d-05,
42586  5 3.050d-03,-4.610d-03, 1.660d-03,-1.300d-04,-1.000d-05, 1.000d-05,
42587  6-4.360d-03, 5.230d-03,-1.610d-03, 2.000d-04,-2.000d-05, 0.000d+00/
42588  DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/
42589  1 8.980d-03,-1.459d-02, 7.510d-03,-4.410d-03, 1.310d-03,-1.070d-03,
42590  2 5.970d-03,-9.440d-03, 4.800d-03,-3.020d-03, 9.100d-04,-8.500d-04,
42591  3-3.050d-03, 4.440d-03,-2.100d-03, 8.500d-04,-2.400d-04, 1.400d-04,
42592  4 5.300d-04,-1.300d-03, 5.600d-04,-2.700d-04, 3.000d-05,-2.000d-05,
42593  5 2.000d-04, 1.400d-04,-1.100d-04, 1.000d-04, 0.000d+00, 0.000d+00,
42594  6-2.600d-04, 3.200d-04, 0.000d+00,-3.000d-05, 1.000d-05,-1.000d-05,
42595  1 8.672d-01,-1.174d+00, 4.265d-01,-9.252d-02, 1.244d-02,-1.460d-03,
42596  2 8.500d-01,-1.194d+00, 4.630d-01,-1.083d-01, 1.614d-02,-1.830d-03,
42597  3-2.241d-02,-5.630d-03, 2.815d-02,-1.425d-02, 3.520d-03,-4.300d-04,
42598  4-7.300d-04, 8.030d-03,-5.780d-03, 1.380d-03,-1.300d-04,-4.000d-05,
42599  5 3.460d-03,-5.380d-03, 1.960d-03,-2.100d-04, 1.000d-05, 1.000d-05,
42600  6-4.850d-03, 5.950d-03,-1.890d-03, 2.600d-04,-3.000d-05, 0.000d+00/
42601 C...Expansion coefficients for top sea quark distribution.
42602  DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/
42603  1 4.410d-03,-7.480d-03, 3.770d-03,-2.580d-03, 7.300d-04,-7.100d-04,
42604  2 3.840d-03,-6.050d-03, 3.030d-03,-2.030d-03, 5.800d-04,-5.900d-04,
42605  3-8.800d-04, 1.660d-03,-7.500d-04, 4.700d-04,-1.000d-04, 1.000d-04,
42606  4-8.000d-05,-1.500d-04, 1.200d-04,-9.000d-05, 3.000d-05, 0.000d+00,
42607  5 1.300d-04,-2.200d-04,-2.000d-05,-2.000d-05,-2.000d-05,-2.000d-05,
42608  6-7.000d-05, 1.900d-04,-4.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
42609  1 6.623d-01,-9.248d-01, 3.519d-01,-7.930d-02, 1.110d-02,-1.180d-03,
42610  2 6.380d-01,-9.062d-01, 3.582d-01,-8.479d-02, 1.265d-02,-1.390d-03,
42611  3-2.581d-02, 2.125d-02, 4.190d-03,-4.980d-03, 1.490d-03,-2.100d-04,
42612  4 7.100d-04, 5.300d-04,-1.270d-03, 3.900d-04,-5.000d-05,-1.000d-05,
42613  5 3.850d-03,-5.060d-03, 1.860d-03,-3.500d-04, 4.000d-05, 0.000d+00,
42614  6-3.530d-03, 4.460d-03,-1.500d-03, 2.700d-04,-3.000d-05, 0.000d+00/
42615  DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/
42616  1 4.260d-03,-7.530d-03, 3.830d-03,-2.680d-03, 7.600d-04,-7.300d-04,
42617  2 3.640d-03,-6.050d-03, 3.030d-03,-2.090d-03, 5.900d-04,-6.000d-04,
42618  3-9.200d-04, 1.710d-03,-8.200d-04, 5.000d-04,-1.200d-04, 1.000d-04,
42619  4-5.000d-05,-1.600d-04, 1.300d-04,-9.000d-05, 3.000d-05, 0.000d+00,
42620  5 1.300d-04,-2.100d-04,-1.000d-05,-2.000d-05,-2.000d-05,-1.000d-05,
42621  6-8.000d-05, 1.800d-04,-5.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
42622  1 7.146d-01,-1.007d+00, 3.932d-01,-9.246d-02, 1.366d-02,-1.540d-03,
42623  2 6.856d-01,-9.828d-01, 3.977d-01,-9.795d-02, 1.540d-02,-1.790d-03,
42624  3-3.053d-02, 2.758d-02, 2.150d-03,-4.880d-03, 1.640d-03,-2.500d-04,
42625  4 9.200d-04, 4.200d-04,-1.340d-03, 4.600d-04,-8.000d-05,-1.000d-05,
42626  5 4.230d-03,-5.660d-03, 2.140d-03,-4.300d-04, 6.000d-05, 0.000d+00,
42627  6-3.890d-03, 5.000d-03,-1.740d-03, 3.300d-04,-4.000d-05, 0.000d+00/
42628 
42629 C...The following data lines are coefficients needed in the
42630 C...Duke, Owens proton structure function parametrizations, see below.
42631 C...Expansion coefficients for (up+down) valence quark distribution.
42632  DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/
42633  1 4.190d-01, 3.460d+00, 4.400d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42634  2 4.000d-03, 7.240d-01,-4.860d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42635  3-7.000d-03,-6.600d-02, 1.330d+00, 0.000d+00, 0.000d+00, 0.000d+00/
42636  DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/
42637  1 3.740d-01, 3.330d+00, 6.030d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42638  2 1.400d-02, 7.530d-01,-6.220d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42639  3 0.000d+00,-7.600d-02, 1.560d+00, 0.000d+00, 0.000d+00, 0.000d+00/
42640 C...Expansion coefficients for down valence quark distribution.
42641  DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/
42642  1 7.630d-01, 4.000d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42643  2-2.370d-01, 6.270d-01,-4.210d-01, 0.000d+00, 0.000d+00, 0.000d+00,
42644  3 2.600d-02,-1.900d-02, 3.300d-02, 0.000d+00, 0.000d+00, 0.000d+00/
42645  DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/
42646  1 7.610d-01, 3.830d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42647  2-2.320d-01, 6.270d-01,-4.180d-01, 0.000d+00, 0.000d+00, 0.000d+00,
42648  3 2.300d-02,-1.900d-02, 3.600d-02, 0.000d+00, 0.000d+00, 0.000d+00/
42649 C...Expansion coefficients for (up+down+strange) sea quark distribution.
42650  DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/
42651  1 1.265d+00, 0.000d+00, 8.050d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42652  2-1.132d+00,-3.720d-01, 1.590d+00, 6.310d+00,-1.050d+01, 1.470d+01,
42653  3 2.930d-01,-2.900d-02,-1.530d-01,-2.730d-01,-3.170d+00, 9.800d+00/
42654  DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/
42655  1 1.670d+00, 0.000d+00, 9.150d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42656  2-1.920d+00,-2.730d-01, 5.300d-01, 1.570d+01,-1.010d+02, 2.230d+02,
42657  3 5.820d-01,-1.640d-01,-7.630d-01,-2.830d+00, 4.470d+01,-1.170d+02/
42658 C...Expansion coefficients for charm sea quark distribution.
42659  DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/
42660  1 0.000d+00,-3.600d-02, 6.350d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42661  2 1.350d-01,-2.220d-01, 3.260d+00,-3.030d+00, 1.740d+01,-1.790d+01,
42662  3-7.500d-02,-5.800d-02,-9.090d-01, 1.500d+00,-1.130d+01, 1.560d+01/
42663  DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/
42664  1 0.000d+00,-1.200d-01, 3.510d+00, 0.000d+00, 0.000d+00, 0.000d+00,
42665  2 6.700d-02,-2.330d-01, 3.660d+00,-4.740d-01, 9.500d+00,-1.660d+01,
42666  3-3.100d-02,-2.300d-02,-4.530d-01, 3.580d-01,-5.430d+00, 1.550d+01/
42667 C...Expansion coefficients for gluon distribution.
42668  DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/
42669  1 1.560d+00, 0.000d+00, 6.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
42670  2-1.710d+00,-9.490d-01, 1.440d+00,-7.190d+00,-1.650d+01, 1.530d+01,
42671  3 6.380d-01, 3.250d-01,-1.050d+00, 2.550d-01, 1.090d+01,-1.010d+01/
42672  DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/
42673  1 8.790d-01, 0.000d+00, 4.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
42674  2-9.710d-01,-1.160d+00, 1.230d+00,-5.640d+00,-7.540d+00,-5.960d-01,
42675  3 4.340d-01, 4.760d-01,-2.540d-01,-8.170d-01, 5.500d+00, 1.260d-01/
42676 
42677 C...Euler's beta function, requires ordinary Gamma function
42678  eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
42679 
42680 C...Leading order proton parton distributions from Glueck, Reya and
42681 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
42682 C...10^-5 < x < 1.
42683  IF(mstp(51).EQ.11) THEN
42684 
42685 C...Determine s expansion variable and some x expressions.
42686  q2in=min(1d8,max(0.25d0,q2))
42687  sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
42688  sd2=sd**2
42689  xl=-log(x)
42690  xs=sqrt(x)
42691 
42692 C...Evaluate valence, gluon and sea distributions.
42693  xfvud=(0.663d0+0.191d0*sd-0.041d0*sd2+0.031d0*sd**3)*
42694  & x**0.326d0*(1d0+(-1.97d0+6.74d0*sd-1.96d0*sd2)*xs+
42695  & (24.4d0-20.7d0*sd+4.08d0*sd2)*x)*
42696  & (1d0-x)**(2.86d0+0.70d0*sd-0.02d0*sd2)
42697  xfvdd=(0.579d0+0.283d0*sd+0.047d0*sd2)*x**(0.523d0-0.015d0*sd)*
42698  & (1d0+(2.22d0-0.59d0*sd-0.27d0*sd2)*xs+(5.95d0-6.19d0*sd+
42699  & 1.55d0*sd2)*x)*(1d0-x)**(3.57d0+0.94d0*sd-0.16d0*sd2)
42700  xfglu=(x**(1.00d0-0.17d0*sd)*((4.879d0*sd-1.383d0*sd2)+
42701  & (25.92d0-28.97d0*sd+5.596d0*sd2)*x+(-25.69d0+23.68d0*sd-
42702  & 1.975d0*sd2)*x**2)+sd**0.558d0*exp(-(0.595d0+2.138d0*sd)+
42703  & sqrt(4.066d0*sd**1.218d0*xl)))*
42704  & (1d0-x)**(2.537d0+1.718d0*sd+0.353d0*sd2)
42705  xfsea=(x**(0.412d0-0.171d0*sd)*(0.363d0-1.196d0*x+(1.029d0+
42706  & 1.785d0*sd-0.459d0*sd2)*x**2)*xl**(0.566d0-0.496d0*sd)+
42707  & sd**1.396d0*exp(-(3.838d0+1.944d0*sd)+sqrt(2.845d0*sd**1.331d0*
42708  & xl)))*(1d0-x)**(4.696d0+2.109d0*sd)
42709  xfstr=sd**0.803d0*(1d0+(-3.055d0+1.024d0*sd**0.67d0)*xs+
42710  & (27.4d0-20.0d0*sd**0.154d0)*x)*(1d0-x)**6.22d0*
42711  & exp(-(4.33d0+1.408d0*sd)+sqrt((8.27d0-0.437d0*sd)*
42712  & sd**0.563d0*xl))/xl**(2.082d0-0.577d0*sd)
42713  IF(sd.LE.0.888d0) THEN
42714  xfchm=0d0
42715  ELSE
42716  xfchm=(sd-0.888d0)**1.01d0*(1.+(4.24d0-0.804d0*sd)*x)*
42717  & (1d0-x)**(3.46d0+1.076d0*sd)*exp(-(4.61d0+1.49d0*sd)+
42718  & sqrt((2.555d0+1.961d0*sd)*sd**0.37d0*xl))
42719  ENDIF
42720  IF(sd.LE.1.351d0) THEN
42721  xfbot=0d0
42722  ELSE
42723  xfbot=(sd-1.351d0)*(1d0+1.848d0*x)*(1d0-x)**(2.929d0+
42724  & 1.396d0*sd)*exp(-(4.71d0+1.514d0*sd)+
42725  & sqrt((4.02d0+1.239d0*sd)*sd**0.51d0*xl))
42726  ENDIF
42727 
42728 C...Put into output array.
42729  xppr(0)=xfglu
42730  xppr(1)=xfvdd+xfsea
42731  xppr(2)=xfvud-xfvdd+xfsea
42732  xppr(3)=xfstr
42733  xppr(4)=xfchm
42734  xppr(5)=xfbot
42735  xppr(-1)=xfsea
42736  xppr(-2)=xfsea
42737  xppr(-3)=xfstr
42738  xppr(-4)=xfchm
42739  xppr(-5)=xfbot
42740 
42741 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
42742 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
42743  ELSEIF(mstp(51).EQ.12.OR.mstp(51).EQ.13) THEN
42744 
42745 C...Determine set, Lambda and x and t expansion variables.
42746  nset=mstp(51)-11
42747  IF(nset.EQ.1) alam=0.2d0
42748  IF(nset.EQ.2) alam=0.29d0
42749  tmin=log(5d0/alam**2)
42750  tmax=log(1d8/alam**2)
42751  t=log(max(1d0,q2/alam**2))
42752  vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
42753  nx=1
42754  IF(x.LE.0.1d0) nx=2
42755  IF(nx.EQ.1) vx=(2d0*x-1.1d0)/0.9d0
42756  IF(nx.EQ.2) vx=max(-1d0,(2d0*log(x)+11.51293d0)/6.90776d0)
42757 
42758 C...Chebyshev polynomials for x and t expansion.
42759  tx(1)=1d0
42760  tx(2)=vx
42761  tx(3)=2d0*vx**2-1d0
42762  tx(4)=4d0*vx**3-3d0*vx
42763  tx(5)=8d0*vx**4-8d0*vx**2+1d0
42764  tx(6)=16d0*vx**5-20d0*vx**3+5d0*vx
42765  tt(1)=1d0
42766  tt(2)=vt
42767  tt(3)=2d0*vt**2-1d0
42768  tt(4)=4d0*vt**3-3d0*vt
42769  tt(5)=8d0*vt**4-8d0*vt**2+1d0
42770  tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
42771 
42772 C...Calculate structure functions.
42773  DO 120 kfl=1,6
42774  xqsum=0d0
42775  DO 110 it=1,6
42776  DO 100 ix=1,6
42777  xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)
42778  100 CONTINUE
42779  110 CONTINUE
42780  xq(kfl)=xqsum*(1d0-x)**nehlq(kfl,nset)
42781  120 CONTINUE
42782 
42783 C...Put into output array.
42784  xppr(0)=xq(4)
42785  xppr(1)=xq(2)+xq(3)
42786  xppr(2)=xq(1)+xq(3)
42787  xppr(3)=xq(5)
42788  xppr(4)=xq(6)
42789  xppr(-1)=xq(3)
42790  xppr(-2)=xq(3)
42791  xppr(-3)=xq(5)
42792  xppr(-4)=xq(6)
42793 
42794 C...Special expansion for bottom (threshold effects).
42795  IF(mstp(58).GE.5) THEN
42796  IF(nset.EQ.1) tmin=8.1905d0
42797  IF(nset.EQ.2) tmin=7.4474d0
42798  IF(t.GT.tmin) THEN
42799  vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
42800  tt(1)=1d0
42801  tt(2)=vt
42802  tt(3)=2d0*vt**2-1d0
42803  tt(4)=4d0*vt**3-3d0*vt
42804  tt(5)=8d0*vt**4-8d0*vt**2+1d0
42805  tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
42806  xqsum=0d0
42807  DO 140 it=1,6
42808  DO 130 ix=1,6
42809  xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)
42810  130 CONTINUE
42811  140 CONTINUE
42812  xppr(5)=xqsum*(1d0-x)**nehlq(7,nset)
42813  xppr(-5)=xppr(5)
42814  ENDIF
42815  ENDIF
42816 
42817 C...Special expansion for top (threshold effects).
42818  IF(mstp(58).GE.6) THEN
42819  IF(nset.EQ.1) tmin=11.5528d0
42820  IF(nset.EQ.2) tmin=10.8097d0
42821  tmin=tmin+2d0*log(pmas(6,1)/30d0)
42822  tmax=tmax+2d0*log(pmas(6,1)/30d0)
42823  IF(t.GT.tmin) THEN
42824  vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
42825  tt(1)=1d0
42826  tt(2)=vt
42827  tt(3)=2d0*vt**2-1d0
42828  tt(4)=4d0*vt**3-3d0*vt
42829  tt(5)=8d0*vt**4-8d0*vt**2+1d0
42830  tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
42831  xqsum=0d0
42832  DO 160 it=1,6
42833  DO 150 ix=1,6
42834  xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)
42835  150 CONTINUE
42836  160 CONTINUE
42837  xppr(6)=xqsum*(1d0-x)**nehlq(8,nset)
42838  xppr(-6)=xppr(6)
42839  ENDIF
42840  ENDIF
42841 
42842 C...Proton parton distributions from Duke, Owens.
42843 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42844  ELSEIF(mstp(51).EQ.14.OR.mstp(51).EQ.15) THEN
42845 
42846 C...Determine set, Lambda and s expansion parameter.
42847  nset=mstp(51)-13
42848  IF(nset.EQ.1) alam=0.2d0
42849  IF(nset.EQ.2) alam=0.4d0
42850  q2in=min(1d6,max(4d0,q2))
42851  sd=log(log(q2in/alam**2)/log(4d0/alam**2))
42852 
42853 C...Calculate structure functions.
42854  DO 180 kfl=1,5
42855  DO 170 is=1,6
42856  ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+
42857  & cdo(3,is,kfl,nset)*sd**2
42858  170 CONTINUE
42859  IF(kfl.LE.2) THEN
42860  xq(kfl)=x**ts(1)*(1d0-x)**ts(2)*(1d0+ts(3)*x)/(eulbet(ts(1),
42861  & ts(2)+1d0)*(1d0+ts(3)*ts(1)/(ts(1)+ts(2)+1d0)))
42862  ELSE
42863  xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
42864  & ts(5)*x**2+ts(6)*x**3)
42865  ENDIF
42866  180 CONTINUE
42867 
42868 C...Put into output arrays.
42869  xppr(0)=xq(5)
42870  xppr(1)=xq(2)+xq(3)/6d0
42871  xppr(2)=3d0*xq(1)-xq(2)+xq(3)/6d0
42872  xppr(3)=xq(3)/6d0
42873  xppr(4)=xq(4)
42874  xppr(-1)=xq(3)/6d0
42875  xppr(-2)=xq(3)/6d0
42876  xppr(-3)=xq(3)/6d0
42877  xppr(-4)=xq(4)
42878 
42879  ENDIF
42880 
42881  RETURN
42882  END
42883 
42884 C*********************************************************************
42885 
42886 C...PYHFTH
42887 C...Gives threshold attractive/repulsive factor for heavy flavour
42888 C...production.
42889 
42890  FUNCTION pyhfth(SH,SQM,FRATT)
42891 
42892 C...Double precision and integer declarations.
42893  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42894  IMPLICIT INTEGER(i-n)
42895  INTEGER pyk,pychge,pycomp
42896 C...Commonblocks.
42897  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42898  common/pypars/mstp(200),parp(200),msti(200),pari(200)
42899  common/pyint1/mint(400),vint(400)
42900  SAVE /pydat1/,/pypars/,/pyint1/
42901 
42902 C...Value for alpha_strong.
42903  IF(mstp(35).LE.1) THEN
42904  alssg=parp(35)
42905  ELSE
42906  mst115=mstu(115)
42907  mstu(115)=mstp(36)
42908  q2bn=sqrt(max(1d0,sqm*((sqrt(sh)-2d0*sqrt(sqm))**2+
42909  & parp(36)**2)))
42910  alssg=pyalps(q2bn)
42911  mstu(115)=mst115
42912  ENDIF
42913 
42914 C...Evaluate attractive and repulsive factors.
42915  xattr=4d0*paru(1)*alssg/(3d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
42916  fattr=xattr/(1d0-exp(-min(50d0,xattr)))
42917  xrepu=paru(1)*alssg/(6d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
42918  frepu=xrepu/(exp(min(50d0,xrepu))-1d0)
42919  pyhfth=fratt*fattr+(1d0-fratt)*frepu
42920  vint(138)=pyhfth
42921 
42922  RETURN
42923  END
42924 
42925 C*********************************************************************
42926 
42927 C...PYSPLI
42928 C...Splits a hadron remnant into two (partons or hadron + parton)
42929 C...in case it is more complicated than just a quark or a diquark.
42930 
42931  SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)
42932 
42933 C...Double precision and integer declarations.
42934  IMPLICIT DOUBLE PRECISION(a-h, o-z)
42935  IMPLICIT INTEGER(i-n)
42936  INTEGER pyk,pychge,pycomp
42937 C...Commonblocks. PYDAT1 temporary
42938  common/pypars/mstp(200),parp(200),msti(200),pari(200)
42939  common/pyint1/mint(400),vint(400)
42940  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42941  SAVE /pypars/,/pyint1/,/pydat1/
42942 C...Local array.
42943  dimension kfl(3)
42944 
42945 C...Preliminaries. Parton composition.
42946  kfa=iabs(kf)
42947  kfs=isign(1,kf)
42948  kfl(1)=mod(kfa/1000,10)
42949  kfl(2)=mod(kfa/100,10)
42950  kfl(3)=mod(kfa/10,10)
42951  IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN
42952  kfl(2)=int(1.5d0+pyr(0))
42953  IF(mint(105).EQ.333) kfl(2)=3
42954  IF(mint(105).EQ.443) kfl(2)=4
42955  kfl(3)=kfl(2)
42956  ELSEIF((kfa.EQ.111.OR.kfa.EQ.113).AND.pyr(0).GT.0.5d0) THEN
42957  kfl(2)=2
42958  kfl(3)=2
42959  ELSEIF(kfa.EQ.223.AND.pyr(0).GT.0.5d0) THEN
42960  kfl(2)=1
42961  kfl(3)=1
42962  ELSEIF((kfa.EQ.130.OR.kfa.EQ.310).AND.pyr(0).GT.0.5d0) THEN
42963  kfl(2)=mod(kfa/10,10)
42964  kfl(3)=mod(kfa/100,10)
42965  ENDIF
42966  IF(kflin.NE.21.AND.kflin.NE.22.AND.kflin.NE.23) THEN
42967  kflr=kflin*kfs
42968  ELSE
42969  kflr=kflin
42970  ENDIF
42971  kflch=0
42972 
42973 C...Subdivide lepton.
42974  IF(kfa.GE.11.AND.kfa.LE.18) THEN
42975  IF(kflr.EQ.kfa) THEN
42976  kflsp=kfs*22
42977  ELSEIF(kflr.EQ.22) THEN
42978  kflsp=kfa
42979  ELSEIF(kflr.EQ.-24.AND.mod(kfa,2).EQ.1) THEN
42980  kflsp=kfa+1
42981  ELSEIF(kflr.EQ.24.AND.mod(kfa,2).EQ.0) THEN
42982  kflsp=kfa-1
42983  ELSEIF(kflr.EQ.21) THEN
42984  kflsp=kfa
42985  kflch=kfs*21
42986  ELSE
42987  kflsp=kfa
42988  kflch=-kflr
42989  ENDIF
42990 
42991 C...Subdivide photon.
42992  ELSEIF(kfa.EQ.22.AND.mint(109).NE.2) THEN
42993  IF(kflr.NE.21) THEN
42994  kflsp=-kflr
42995  ELSE
42996  ragr=0.75d0*pyr(0)
42997  kflsp=1
42998  IF(ragr.GT.0.125d0) kflsp=2
42999  IF(ragr.GT.0.625d0) kflsp=3
43000  IF(pyr(0).GT.0.5d0) kflsp=-kflsp
43001  kflch=-kflsp
43002  ENDIF
43003 
43004 C...Subdivide Reggeon or Pomeron.
43005  ELSEIF(kfa.EQ.110.OR.kfa.EQ.990) THEN
43006  IF(kflin.EQ.21) THEN
43007  kflsp=kfs*21
43008  ELSE
43009  kflsp=-kflin
43010  ENDIF
43011 
43012 C...Subdivide meson.
43013  ELSEIF(kfl(1).EQ.0) THEN
43014  kfl(2)=kfl(2)*(-1)**kfl(2)
43015  kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))
43016  IF(kflr.EQ.kfl(2)) THEN
43017  kflsp=kfl(3)
43018  ELSEIF(kflr.EQ.kfl(3)) THEN
43019  kflsp=kfl(2)
43020  ELSEIF(kflr.EQ.21.AND.pyr(0).GT.0.5d0) THEN
43021  kflsp=kfl(2)
43022  kflch=kfl(3)
43023  ELSEIF(kflr.EQ.21) THEN
43024  kflsp=kfl(3)
43025  kflch=kfl(2)
43026  ELSEIF(kflr*kfl(2).GT.0) THEN
43027  ntry=0
43028  100 ntry=ntry+1
43029  CALL pykfdi(-kflr,kfl(2),kfdump,kflch)
43030  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
43031  goto 100
43032  ELSEIF(kflch.EQ.0) THEN
43033  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
43034  mint(51)=1
43035  RETURN
43036  ENDIF
43037  kflsp=kfl(3)
43038  ELSE
43039  ntry=0
43040  110 ntry=ntry+1
43041  CALL pykfdi(-kflr,kfl(3),kfdump,kflch)
43042  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
43043  goto 110
43044  ELSEIF(kflch.EQ.0) THEN
43045  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
43046  mint(51)=1
43047  RETURN
43048  ENDIF
43049  kflsp=kfl(2)
43050  ENDIF
43051 
43052 C...Special case for extracting photon from baryon without splitting
43053 C...the latter. (Currently only used by external programs.)
43054  ELSEIF(kflin.EQ.22.AND.mstp(98).EQ.1) then
43055  kflsp=kfa
43056  kflch=0
43057 
43058 C...Subdivide baryon.
43059  ELSE
43060  nagr=0
43061  DO 120 j=1,3
43062  IF(kflr.EQ.kfl(j)) nagr=nagr+1
43063  120 CONTINUE
43064  IF(nagr.GE.1) THEN
43065  ragr=0.00001d0+(nagr-0.00002d0)*pyr(0)
43066  iagr=0
43067  DO 130 j=1,3
43068  IF(kflr.EQ.kfl(j)) ragr=ragr-1d0
43069  IF(iagr.EQ.0.AND.ragr.LE.0d0) iagr=j
43070  130 CONTINUE
43071  ELSE
43072  iagr=1.00001d0+2.99998d0*pyr(0)
43073  ENDIF
43074  id1=1
43075  IF(iagr.EQ.1) id1=2
43076  IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3
43077  id2=6-iagr-id1
43078  ksp=3
43079  IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN
43080  IF(iagr.NE.3.AND.pyr(0).GT.0.25d0) ksp=1
43081  ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN
43082  IF(iagr.NE.1.AND.pyr(0).GT.0.25d0) ksp=1
43083  ELSEIF(mod(kfa,10).EQ.2) THEN
43084  IF(iagr.EQ.1) ksp=1
43085  IF(iagr.NE.1.AND.pyr(0).GT.0.75d0) ksp=1
43086  ENDIF
43087  kflsp=1000*kfl(id1)+100*kfl(id2)+ksp
43088  IF(kflr.EQ.21) THEN
43089  kflch=kfl(iagr)
43090  ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN
43091  ntry=0
43092  140 ntry=ntry+1
43093  CALL pykfdi(-kflr,kfl(iagr),kfdump,kflch)
43094  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
43095  goto 140
43096  ELSEIF(kflch.EQ.0) THEN
43097  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
43098  mint(51)=1
43099  RETURN
43100  ENDIF
43101  ELSEIF(nagr.EQ.0) THEN
43102  ntry=0
43103  150 ntry=ntry+1
43104  CALL pykfdi(10000*kfl(id1)+kflsp,-kflr,kfdump,kflch)
43105  IF(kflch.EQ.0.AND.ntry.LT.100) THEN
43106  goto 150
43107  ELSEIF(kflch.EQ.0) THEN
43108  CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
43109  mint(51)=1
43110  RETURN
43111  ENDIF
43112  kflsp=kfl(iagr)
43113  ENDIF
43114  ENDIF
43115 
43116 C...Add on correct sign for result.
43117  kflch=kflch*kfs
43118  kflsp=kflsp*kfs
43119 
43120  RETURN
43121  END
43122 
43123 C*********************************************************************
43124 
43125 C...PYGAMM
43126 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
43127 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
43128 C...(Dover, 1965) 6.1.36.
43129 
43130  FUNCTION pygamm(X)
43131 
43132 C...Double precision and integer declarations.
43133  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43134  IMPLICIT INTEGER(i-n)
43135  INTEGER pyk,pychge,pycomp
43136 C...Local array and data.
43137  dimension b(8)
43138  DATA b/-0.577191652d0,0.988205891d0,-0.897056937d0,0.918206857d0,
43139  &-0.756704078d0,0.482199394d0,-0.193527818d0,0.035868343d0/
43140 
43141  nx=int(x)
43142  dx=x-nx
43143 
43144  pygamm=1d0
43145  dxp=1d0
43146  DO 100 i=1,8
43147  dxp=dxp*dx
43148  pygamm=pygamm+b(i)*dxp
43149  100 CONTINUE
43150  IF(x.LT.1d0) THEN
43151  pygamm=pygamm/x
43152  ELSE
43153  DO 110 ix=1,nx-1
43154  pygamm=(x-ix)*pygamm
43155  110 CONTINUE
43156  ENDIF
43157 
43158  RETURN
43159  END
43160 
43161 C***********************************************************************
43162 
43163 C...PYWAUX
43164 C...Calculates real and imaginary parts of the auxiliary functions W1
43165 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
43166 C...der Bij, Nucl. Phys. B297 (1988) 221.
43167 
43168  SUBROUTINE pywaux(IAUX,EPS,WRE,WIM)
43169 
43170 C...Double precision and integer declarations.
43171  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43172  IMPLICIT INTEGER(i-n)
43173  INTEGER pyk,pychge,pycomp
43174 C...Commonblocks.
43175  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43176  SAVE /pydat1/
43177 
43178  asinh(x)=log(x+sqrt(x**2+1d0))
43179  acosh(x)=log(x+sqrt(x**2-1d0))
43180 
43181  IF(eps.LT.0d0) THEN
43182  IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*asinh(sqrt(-1d0/eps))
43183  IF(iaux.EQ.2) wre=4d0*(asinh(sqrt(-1d0/eps)))**2
43184  wim=0d0
43185  ELSEIF(eps.LT.1d0) THEN
43186  IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*acosh(sqrt(1d0/eps))
43187  IF(iaux.EQ.2) wre=4d0*(acosh(sqrt(1d0/eps)))**2-paru(1)**2
43188  IF(iaux.EQ.1) wim=-paru(1)*sqrt(1d0-eps)
43189  IF(iaux.EQ.2) wim=-4d0*paru(1)*acosh(sqrt(1d0/eps))
43190  ELSE
43191  IF(iaux.EQ.1) wre=2d0*sqrt(eps-1d0)*asin(sqrt(1d0/eps))
43192  IF(iaux.EQ.2) wre=-4d0*(asin(sqrt(1d0/eps)))**2
43193  wim=0d0
43194  ENDIF
43195 
43196  RETURN
43197  END
43198 
43199 C***********************************************************************
43200 
43201 C...PYI3AU
43202 C...Calculates real and imaginary parts of the auxiliary function I3;
43203 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
43204 C...Nucl. Phys. B297 (1988) 221.
43205 
43206  SUBROUTINE pyi3au(EPS,RAT,Y3RE,Y3IM)
43207 
43208 C...Double precision and integer declarations.
43209  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43210  IMPLICIT INTEGER(i-n)
43211  INTEGER pyk,pychge,pycomp
43212 C...Commonblocks.
43213  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43214  SAVE /pydat1/
43215 
43216  be=0.5d0*(1d0+sqrt(1d0+rat*eps))
43217  IF(eps.LT.1d0) ga=0.5d0*(1d0+sqrt(1d0-eps))
43218 
43219  IF(eps.LT.0d0) THEN
43220  IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
43221  f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
43222  & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
43223  & pyspen(0.25d0*(rat+1d0)*eps/(1d0+0.25d0*rat*eps),0d0,1)-
43224  & pyspen((rat+1d0)/rat,0d0,1)+0.5d0*(log(1d0+0.25d0*rat*eps)**2-
43225  & log(0.25d0*rat*eps)**2)+log(1d0-0.25d0*eps)*
43226  & log((1d0+0.25d0*(rat-1d0)*eps)/(1d0+0.25d0*rat*eps))+
43227  & log(-0.25d0*eps)*log(0.25d0*rat*eps/(1d0+0.25d0*(rat-1d0)*
43228  & eps))
43229  ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
43230  f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
43231  & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
43232  & pyspen((be-1d0+0.25d0*eps)/be,0d0,1)-
43233  & pyspen((be-1d0+0.25d0*eps)/(be-1d0),0d0,1)+
43234  & 0.5d0*(log(be)**2-log(be-1d0)**2)+
43235  & log(1d0-0.25d0*eps)*log((be-0.25d0*eps)/be)+
43236  & log(-0.25d0*eps)*log((be-1d0)/(be-0.25d0*eps))
43237  ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
43238  f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
43239  & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
43240  & pyspen((1d0+0.25d0*rat*eps-ga)/(1d0+0.25d0*rat*eps),0d0,1)-
43241  & pyspen((1d0+0.25d0*rat*eps-ga)/(0.25d0*rat*eps),0d0,1)+
43242  & 0.5d0*(log(1d0+0.25d0*rat*eps)**2-log(0.25d0*rat*eps)**2)+
43243  & log(ga)*log((ga+0.25d0*rat*eps)/(1d0+0.25d0*rat*eps))+
43244  & log(ga-1d0)*log(0.25d0*rat*eps/(ga+0.25d0*rat*eps))
43245  ELSE
43246  f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
43247  & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen((be-ga)/be,0d0,1)-
43248  & pyspen((be-ga)/(be-1d0),0d0,1)+0.5d0*(log(be)**2-
43249  & log(be-1d0)**2)+log(ga)*log((ga+be-1d0)/be)+
43250  & log(ga-1d0)*log((be-1d0)/(ga+be-1d0))
43251  ENDIF
43252  f3im=0d0
43253  ELSEIF(eps.LT.1d0) THEN
43254  IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
43255  f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
43256  & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
43257  & pyspen((1d0-0.25d0*eps)/(-0.25d0*(rat+1d0)*eps),0d0,1)-
43258  & pyspen(1d0/(rat+1d0),0d0,1)+log((1d0-0.25d0*eps)/
43259  & (0.25d0*eps))*log((1d0+0.25d0*(rat-1d0)*eps)/
43260  & (0.25d0*(rat+1d0)*eps))
43261  f3im=-paru(1)*log((1d0+0.25d0*(rat-1d0)*eps)/
43262  & (0.25d0*(rat+1d0)*eps))
43263  ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
43264  f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
43265  & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
43266  & pyspen((1d0-0.25d0*eps)/(1d0-0.25d0*eps-be),0d0,1)-
43267  & pyspen(-0.25d0*eps/(1d0-0.25d0*eps-be),0d0,1)+
43268  & log((1d0-0.25d0*eps)/(0.25d0*eps))*
43269  & log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
43270  f3im=-paru(1)*log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
43271  ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
43272  f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
43273  & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
43274  & pyspen(ga/(ga-1d0-0.25d0*rat*eps),0d0,1)-
43275  & pyspen((ga-1d0)/(ga-1d0-0.25d0*rat*eps),0d0,1)+
43276  & log(ga/(1d0-ga))*log((ga+0.25d0*rat*eps)/
43277  & (1d0+0.25d0*rat*eps-ga))
43278  f3im=-paru(1)*log((ga+0.25d0*rat*eps)/
43279  & (1d0+0.25d0*rat*eps-ga))
43280  ELSE
43281  f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
43282  & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen(ga/(ga-be),0d0,1)-
43283  & pyspen((ga-1d0)/(ga-be),0d0,1)+log(ga/(1d0-ga))*
43284  & log((ga+be-1d0)/(be-ga))
43285  f3im=-paru(1)*log((ga+be-1d0)/(be-ga))
43286  ENDIF
43287  ELSE
43288  rsq=eps/(eps-1d0+(2d0*be-1d0)**2)
43289  rcthe=rsq*(1d0-2d0*be/eps)
43290  rsthe=sqrt(max(0d0,rsq-rcthe**2))
43291  rcphi=rsq*(1d0+2d0*(be-1d0)/eps)
43292  rsphi=sqrt(max(0d0,rsq-rcphi**2))
43293  r=sqrt(rsq)
43294  the=acos(max(-0.999999d0,min(0.999999d0,rcthe/r)))
43295  phi=acos(max(-0.999999d0,min(0.999999d0,rcphi/r)))
43296  f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-
43297  & pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+
43298  & (phi-the)*(phi+the-paru(1))
43299  f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-
43300  & pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)
43301  ENDIF
43302 
43303  y3re=2d0/(2d0*be-1d0)*f3re
43304  y3im=2d0/(2d0*be-1d0)*f3im
43305 
43306  RETURN
43307  END
43308 
43309 C***********************************************************************
43310 
43311 C...PYSPEN
43312 C...Calculates real and imaginary part of Spence function; see
43313 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
43314 
43315  FUNCTION pyspen(XREIN,XIMIN,IREIM)
43316 
43317 C...Double precision and integer declarations.
43318  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43319  IMPLICIT INTEGER(i-n)
43320  INTEGER pyk,pychge,pycomp
43321 C...Commonblocks.
43322  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43323  SAVE /pydat1/
43324 C...Local array and data.
43325  dimension b(0:14)
43326  DATA b/
43327  &1.000000d+00, -5.000000d-01, 1.666667d-01,
43328  &0.000000d+00, -3.333333d-02, 0.000000d+00,
43329  &2.380952d-02, 0.000000d+00, -3.333333d-02,
43330  &0.000000d+00, 7.575757d-02, 0.000000d+00,
43331  &-2.531135d-01, 0.000000d+00, 1.166667d+00/
43332 
43333  xre=xrein
43334  xim=ximin
43335  IF(abs(1d0-xre).LT.1d-6.AND.abs(xim).LT.1d-6) THEN
43336  IF(ireim.EQ.1) pyspen=paru(1)**2/6d0
43337  IF(ireim.EQ.2) pyspen=0d0
43338  RETURN
43339  ENDIF
43340 
43341  xmod=sqrt(xre**2+xim**2)
43342  IF(xmod.LT.1d-6) THEN
43343  IF(ireim.EQ.1) pyspen=0d0
43344  IF(ireim.EQ.2) pyspen=0d0
43345  RETURN
43346  ENDIF
43347 
43348  xarg=sign(acos(xre/xmod),xim)
43349  sp0re=0d0
43350  sp0im=0d0
43351  sgn=1d0
43352  IF(xmod.GT.1d0) THEN
43353  algxre=log(xmod)
43354  algxim=xarg-sign(paru(1),xarg)
43355  sp0re=-paru(1)**2/6d0-(algxre**2-algxim**2)/2d0
43356  sp0im=-algxre*algxim
43357  sgn=-1d0
43358  xmod=1d0/xmod
43359  xarg=-xarg
43360  xre=xmod*cos(xarg)
43361  xim=xmod*sin(xarg)
43362  ENDIF
43363  IF(xre.GT.0.5d0) THEN
43364  algxre=log(xmod)
43365  algxim=xarg
43366  xre=1d0-xre
43367  xim=-xim
43368  xmod=sqrt(xre**2+xim**2)
43369  xarg=sign(acos(xre/xmod),xim)
43370  algyre=log(xmod)
43371  algyim=xarg
43372  sp0re=sp0re+sgn*(paru(1)**2/6d0-(algxre*algyre-algxim*algyim))
43373  sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)
43374  sgn=-sgn
43375  ENDIF
43376 
43377  xre=1d0-xre
43378  xim=-xim
43379  xmod=sqrt(xre**2+xim**2)
43380  xarg=sign(acos(xre/xmod),xim)
43381  zre=-log(xmod)
43382  zim=-xarg
43383 
43384  spre=0d0
43385  spim=0d0
43386  savere=1d0
43387  saveim=0d0
43388  DO 100 i=0,14
43389  IF(max(abs(savere),abs(saveim)).LT.1d-30) goto 110
43390  termre=(savere*zre-saveim*zim)/dble(i+1)
43391  termim=(savere*zim+saveim*zre)/dble(i+1)
43392  savere=termre
43393  saveim=termim
43394  spre=spre+b(i)*termre
43395  spim=spim+b(i)*termim
43396  100 CONTINUE
43397 
43398  110 IF(ireim.EQ.1) pyspen=sp0re+sgn*spre
43399  IF(ireim.EQ.2) pyspen=sp0im+sgn*spim
43400 
43401  RETURN
43402  END
43403 
43404 C***********************************************************************
43405 
43406 C...PYQQBH
43407 C...Calculates the matrix element for the processes
43408 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
43409 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
43410 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
43411 
43412  SUBROUTINE pyqqbh(WTQQBH)
43413 
43414 C...Double precision and integer declarations.
43415  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43416  IMPLICIT INTEGER(i-n)
43417  INTEGER pyk,pychge,pycomp
43418 C...Commonblocks.
43419  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43420  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43421  common/pypars/mstp(200),parp(200),msti(200),pari(200)
43422  common/pyint1/mint(400),vint(400)
43423  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
43424  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/
43425 C...Local arrays and function.
43426  dimension pp(15,4),clr(8,8),fm(10,10),rm(8,8),dx(8)
43427  dot(i,j)=pp(i,4)*pp(j,4)-pp(i,1)*pp(j,1)-pp(i,2)*pp(j,2)-
43428  &pp(i,3)*pp(j,3)
43429 
43430 C...Mass parameters.
43431  wtqqbh=0d0
43432  isub=mint(1)
43433  shpr=sqrt(vint(26))*vint(1)
43434  pq=pmas(pycomp(kfpr(isub,2)),1)
43435  ph=sqrt(vint(21))*vint(1)
43436  spq=pq**2
43437  sph=ph**2
43438 
43439 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
43440  DO 100 i=1,2
43441  pt=sqrt(max(0d0,vint(197+5*i)))
43442  pp(i,1)=pt*cos(vint(198+5*i))
43443  pp(i,2)=pt*sin(vint(198+5*i))
43444  100 CONTINUE
43445  pp(3,1)=-pp(1,1)-pp(2,1)
43446  pp(3,2)=-pp(1,2)-pp(2,2)
43447  pms1=spq+pp(1,1)**2+pp(1,2)**2
43448  pms2=spq+pp(2,1)**2+pp(2,2)**2
43449  pms3=sph+pp(3,1)**2+pp(3,2)**2
43450  pmt3=sqrt(pms3)
43451  pp(3,3)=pmt3*sinh(vint(211))
43452  pp(3,4)=pmt3*cosh(vint(211))
43453  pms12=(shpr-pp(3,4))**2-pp(3,3)**2
43454  pp(1,3)=(-pp(3,3)*(pms12+pms1-pms2)+
43455  &vint(213)*(shpr-pp(3,4))*vint(220))/(2d0*pms12)
43456  pp(2,3)=-pp(1,3)-pp(3,3)
43457  pp(1,4)=sqrt(pms1+pp(1,3)**2)
43458  pp(2,4)=sqrt(pms2+pp(2,3)**2)
43459 
43460 C...Set up incoming kinematics and derived momentum combinations.
43461  DO 110 i=4,5
43462  pp(i,1)=0d0
43463  pp(i,2)=0d0
43464  pp(i,3)=-0.5d0*shpr*(-1)**i
43465  pp(i,4)=-0.5d0*shpr
43466  110 CONTINUE
43467  DO 120 j=1,4
43468  pp(6,j)=pp(1,j)+pp(2,j)
43469  pp(7,j)=pp(1,j)+pp(3,j)
43470  pp(8,j)=pp(1,j)+pp(4,j)
43471  pp(9,j)=pp(1,j)+pp(5,j)
43472  pp(10,j)=-pp(2,j)-pp(3,j)
43473  pp(11,j)=-pp(2,j)-pp(4,j)
43474  pp(12,j)=-pp(2,j)-pp(5,j)
43475  pp(13,j)=-pp(4,j)-pp(5,j)
43476  120 CONTINUE
43477 
43478 C...Derived kinematics invariants.
43479  x1=dot(1,2)
43480  x2=dot(1,3)
43481  x3=dot(1,4)
43482  x4=dot(1,5)
43483  x5=dot(2,3)
43484  x6=dot(2,4)
43485  x7=dot(2,5)
43486  x8=dot(3,4)
43487  x9=dot(3,5)
43488  x10=dot(4,5)
43489 
43490 C...Propagators.
43491  ss1=dot(7,7)-spq
43492  ss2=dot(8,8)-spq
43493  ss3=dot(9,9)-spq
43494  ss4=dot(10,10)-spq
43495  ss5=dot(11,11)-spq
43496  ss6=dot(12,12)-spq
43497  ss7=dot(13,13)
43498  dx(1)=ss1*ss6
43499  dx(2)=ss2*ss6
43500  dx(3)=ss2*ss4
43501  dx(4)=ss1*ss5
43502  dx(5)=ss3*ss5
43503  dx(6)=ss3*ss4
43504  dx(7)=ss7*ss1
43505  dx(8)=ss7*ss4
43506 
43507 C...Define colour coefficients for g + g -> Q + Qbar + H.
43508  IF(isub.EQ.121.OR.isub.EQ.181.OR.isub.EQ.186) THEN
43509  DO 140 i=1,3
43510  DO 130 j=1,3
43511  clr(i,j)=16d0/3d0
43512  clr(i+3,j+3)=16d0/3d0
43513  clr(i,j+3)=-2d0/3d0
43514  clr(i+3,j)=-2d0/3d0
43515  130 CONTINUE
43516  140 CONTINUE
43517  DO 160 l=1,2
43518  DO 150 i=1,3
43519  clr(i,6+l)=-6d0
43520  clr(i+3,6+l)=6d0
43521  clr(6+l,i)=-6d0
43522  clr(6+l,i+3)=6d0
43523  150 CONTINUE
43524  160 CONTINUE
43525  DO 180 k1=1,2
43526  DO 170 k2=1,2
43527  clr(6+k1,6+k2)=12d0
43528  170 CONTINUE
43529  180 CONTINUE
43530 
43531 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
43532  fm(1,1)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x4+x9+2*
43533  & x7+x5)+8*pq**2*ph**2*(-x1-x4+2*x7)+16*pq**2*(x2*x9+4*x2*
43534  & x7+x2*x5-2*x4*x7-2*x9*x7)+8*ph**2*x4*x7-16*x2*x9*x7
43535  fm(1,2)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10+x9-x8+2
43536  & *x7-4*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x4-2*x2*x10+x2*x7-2*
43537  & x2*x6-2*x3*x7+2*x4*x7+4*x10*x7-x9*x7-x8*x7)+16*x2*x7*(x4+
43538  & x10)
43539  fm(1,3)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-2*x3-4*
43540  & x4-8*x10+x9+x8-2*x7-4*x6+2*x5)-(4*pq**2*ph**2)*(x1+x4+x10
43541  & +x6)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
43542  & -4*x2*x4-5*x2*x10+x2*x8-x2*x7-3*x2*x6+x2*x5+x3*x9+2*x3*x7
43543  & -x3*x5+x4*x8+2*x4*x6-3*x4*x5-5*x10*x5+x9*x8+x9*x6+x9*x5+
43544  & x8*x7-4*x6*x5+x5**2)-(16*x2*x5)*(x1+x4+x10+x6)
43545  fm(1,4)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1+x2-x3-x4+x10-
43546  & x9-x8+2*x7+2*x6-x5)+4*pq**2*ph**2*(x1+x3+x4+x10+2*x7+2*x6
43547  & )+8*pq**2*(4*x1*x10+4*x1*x7+4*x1*x6+2*x2*x10-x2*x9-x2*x8+
43548  & 4*x2*x7+4*x2*x6-x2*x5+4*x10*x5+4*x7*x5+4*x6*x5)-(8*ph**2*
43549  & x1)*(x10+x7+x6)+16*x2*x5*(x10+x7+x6)
43550  fm(1,5)=8*pq**4*(-2*x1-2*x4+x10-x9)+4*pq**2*(4*x1**2-2*x1*
43551  & x2+8*x1*x3+6*x1*x10-2*x1*x9+4*x1*x8+4*x1*x7+4*x1*x6+2*x1*
43552  & x5+x2*x10+4*x3*x4-x3*x9+2*x3*x7+3*x4*x8-2*x4*x6+2*x4*x5-4
43553  & *x10*x7+3*x10*x5-3*x9*x6+3*x8*x7-4*x7**2+4*x7*x5)+8*(x1**
43554  & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5-x1*x4*
43555  & x8-x1*x4*x5+x1*x10*x9+x1*x9*x7+x1*x9*x6-x1*x8*x7-x2*x3*x7
43556  & +x2*x4*x6-x2*x10*x7-x2*x7**2+x3*x7*x5-x4*x10*x5-x4*x7*x5-
43557  & x4*x6*x5)
43558  fm(1,6)=16*pq**4*(-4*x1-x4+x9-x7)+4*pq**2*ph**2*(-2*x1-x4-
43559  & x7)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x4-3*x1*x9-2*x1*x7-3*
43560  & x1*x5-2*x2*x4-2*x7*x5)-8*ph**2*x4*x7+8*(-x1*x2*x9-2*x1*x2
43561  & *x5-x1*x9**2-x1*x9*x5+x2**2*x7-x2*x4*x5+x2*x9*x7-x2*x7*x5
43562  & +x4*x9*x5+x4*x5**2)
43563  fm(1,7)=8*pq**4*(2*x3+x4+3*x10+x9+2*x8+3*x7+6*x6)+2*pq**2*
43564  & ph**2*(-2*x3-x4+3*x10+3*x7+6*x6)+4*pq**2*(4*x1*x10+4*x1*
43565  & x7+8*x1*x6+6*x2*x10+x2*x9+2*x2*x8+6*x2*x7+12*x2*x6-8*x3*
43566  & x7+4*x4*x7+4*x4*x6+4*x10*x5+4*x9*x7+4*x9*x6-8*x8*x7+4*x7*
43567  & x5+8*x6*x5)+4*ph**2*(-x1*x10-x1*x7-2*x1*x6+2*x3*x7-x4*x7-
43568  & x4*x6)+8*x2*(x10*x5+x9*x7+x9*x6-2*x8*x7+x7*x5+2*x6*x5)
43569  fm(1,8)=8*pq**4*(2*x3+x4+3*x10+2*x9+x8+3*x7+6*x6)+2*pq**2*
43570  & ph**2*(-2*x3-x4+2*x10+x7+2*x6)+4*pq**2*(4*x1*x10-2*x1*x9+
43571  & 2*x1*x8+4*x1*x7+8*x1*x6+5*x2*x10+2*x2*x9+x2*x8+4*x2*x7+8*
43572  & x2*x6-x3*x9-8*x3*x7+2*x3*x5+2*x4*x9-x4*x8+4*x4*x7+4*x4*x6
43573  & +4*x4*x5+5*x10*x5+x9**2-x9*x8+2*x9*x7+5*x9*x6+x9*x5-7*x8*
43574  & x7+2*x8*x5+2*x7*x5+10*x6*x5)+2*ph**2*(-x1*x10+x3*x7-2*x4*
43575  & x7+x4*x6)+4*(-x1*x9**2+x1*x9*x8-2*x1*x9*x5-x1*x8*x5+2*x2*
43576  & x10*x5+x2*x9*x7+x2*x9*x6-2*x2*x8*x7+3*x2*x6*x5+x3*x9*x5+
43577  & x3*x5**2+x4*x9*x5-2*x4*x8*x5+2*x4*x5**2)
43578  fm(2,2)=16*pq**6+16*pq**4*(-x1+x3-x4-x10+x7-x6)+16*pq**2*(
43579  & x3*x10+x3*x7+x3*x6+x4*x7+x10*x7)-16*x3*x10*x7
43580  fm(2,3)=16*pq**6+8*pq**4*(-2*x1+x2+2*x3-4*x4-4*x10-x9+x8-2
43581  & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5+4*x3*x10-x3*x9-x3*x8-2*x3*
43582  & x7+2*x3*x6+x3*x5-2*x4*x5-2*x10*x5-2*x6*x5)+16*x3*x5*(x10+
43583  & x6)
43584  fm(2,4)=8*pq**4*(-2*x1-2*x3+x10-x8)+4*pq**2*(4*x1**2-2*x1*
43585  & x2+8*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+4*x1*x7+4*x1*x6+2*x1*
43586  & x5+x2*x10+4*x3*x4+3*x3*x9-2*x3*x7+2*x3*x5-x4*x8+2*x4*x6-4
43587  & *x10*x6+3*x10*x5+3*x9*x6-3*x8*x7-4*x6**2+4*x6*x5)+8*(-x1
43588  & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9-x1*x3*x5+x1*x4
43589  & *x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x1*x8*x6+x2*x3*
43590  & x7-x2*x4*x6-x2*x10*x6-x2*x6**2-x3*x10*x5-x3*x7*x5-x3*x6*
43591  & x5+x4*x6*x5)
43592  fm(2,5)=16*pq**4*x10+8*pq**2*(2*x1**2+2*x1*x3+2*x1*x4+2*x1
43593  & *x10+2*x1*x7+2*x1*x6+x3*x7+x4*x6)+8*(-2*x1**3-2*x1**2*x3-
43594  & 2*x1**2*x4-2*x1**2*x10-2*x1**2*x7-2*x1**2*x6-2*x1*x3*x4-
43595  & x1*x3*x10-2*x1*x3*x6-x1*x4*x10-2*x1*x4*x7-x1*x10**2-x1*
43596  & x10*x7-x1*x10*x6-2*x1*x7*x6+x3**2*x7-x3*x4*x7-x3*x4*x6+x3
43597  & *x10*x7+x3*x7**2-x3*x7*x6+x4**2*x6+x4*x10*x6-x4*x7*x6+x4*
43598  & x6**2)
43599  fm(2,6)=8*pq**4*(-2*x1+x10-x9-2*x7)+4*pq**2*(4*x1**2+2*x1*
43600  & x2+4*x1*x3+4*x1*x4+6*x1*x10-2*x1*x9+4*x1*x8+8*x1*x6-2*x1*
43601  & x5+4*x2*x4+3*x2*x10+2*x2*x7-3*x3*x9-2*x3*x7-4*x4**2-4*x4*
43602  & x10+3*x4*x8+2*x4*x6+x10*x5-x9*x6+3*x8*x7+4*x7*x6)+8*(x1**
43603  & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5+x1*x4*
43604  & x9-x1*x4*x8-x1*x4*x5+x1*x10*x9+x1*x9*x6-x1*x8*x7-x2*x3*x7
43605  & -x2*x4*x7+x2*x4*x6-x2*x10*x7+x3*x7*x5-x4**2*x5-x4*x10*x5-
43606  & x4*x6*x5)
43607  fm(2,7)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
43608  & 2*x1*x4-2*x1*x10+x1*x9-x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
43609  & x4+3*x2*x10+x2*x7+2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9-2*x3*
43610  & x7-4*x3*x6-x3*x5-6*x4**2-6*x4*x10-3*x4*x9-x4*x8-4*x4*x7-2
43611  & *x4*x6-2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+x10*x5
43612  & +x9*x7-2*x8*x7-2*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
43613  & -x1**2*x9+x1**2*x8-2*x1*x2*x10-3*x1*x2*x7-3*x1*x2*x6+x1*
43614  & x3*x9-x1*x3*x5+x1*x4*x9+x1*x4*x8+x1*x4*x5+x1*x10*x9+x1*
43615  & x10*x8-x1*x9*x6+x1*x8*x6+x2*x3*x7-3*x2*x4*x7-x2*x4*x6-3*
43616  & x2*x10*x7-3*x2*x10*x6-3*x2*x7*x6-3*x2*x6**2-2*x3*x4*x5-x3
43617  & *x10*x5-x3*x6*x5-x4**2*x5-x4*x10*x5+x4*x6*x5)
43618  fm(2,8)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
43619  & 2*x1*x4-2*x1*x10-x1*x9+x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
43620  & x4+x2*x10-x2*x7-2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9+x3*x8-2*
43621  & x3*x7-4*x3*x6+x3*x5-6*x4**2-6*x4*x10-2*x4*x9-4*x4*x7-2*x4
43622  & *x6+2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+3*x10*x5-
43623  & x9*x6-2*x8*x7-3*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
43624  & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6-3*x1*x3*x5+x1*x4*x9-
43625  & x1*x4*x8-3*x1*x4*x5+x1*x10*x9+x1*x10*x8-2*x1*x10*x5+x1*x9
43626  & *x6+x1*x8*x7+x1*x8*x6-x2*x4*x7+x2*x4*x6-x2*x10*x7-x2*x10*
43627  & x6-2*x2*x7*x6-x2*x6**2-3*x3*x4*x5-3*x3*x10*x5+x3*x7*x5-3*
43628  & x3*x6*x5-3*x4**2*x5-3*x4*x10*x5-x4*x6*x5)
43629  fm(3,3)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x3+x8+x6
43630  & +2*x5)+8*pq**2*ph**2*(-x1+2*x3-x6)+16*pq**2*(x2*x5-2*x3*
43631  & x8-2*x3*x6+4*x3*x5+x8*x5)+8*ph**2*x3*x6-16*x3*x8*x5
43632  fm(3,4)=16*pq**4*(-4*x1-x3+x8-x6)+4*pq**2*ph**2*(-2*x1-x3-
43633  & x6)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x3-3*x1*x8-2*x1*x6-3*
43634  & x1*x5-2*x2*x3-2*x6*x5)-8*ph**2*x3*x6+8*(-x1*x2*x8-2*x1*x2
43635  & *x5-x1*x8**2-x1*x8*x5+x2**2*x6-x2*x3*x5+x2*x8*x6-x2*x6*x5
43636  & +x3*x8*x5+x3*x5**2)
43637  fm(3,5)=8*pq**4*(-2*x1+x10-x8-2*x6)+4*pq**2*(4*x1**2+2*x1*
43638  & x2+4*x1*x3+4*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+8*x1*x7-2*x1*
43639  & x5+4*x2*x3+3*x2*x10+2*x2*x6-4*x3**2-4*x3*x10+3*x3*x9+2*x3
43640  & *x7-3*x4*x8-2*x4*x6+x10*x5+3*x9*x6-x8*x7+4*x7*x6)+8*(-x1
43641  & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9+x1*x3*x8-x1*x3
43642  & *x5+x1*x4*x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x2*x3*
43643  & x7-x2*x3*x6-x2*x4*x6-x2*x10*x6-x3**2*x5-x3*x10*x5-x3*x7*
43644  & x5+x4*x6*x5)
43645  fm(3,6)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1-x2+2*x3+2*x4+
43646  & x10-x9-x8-x7-x6+x5)+4*pq**2*ph**2*(x1+2*x3+2*x4+x10+x7+x6
43647  & )+8*pq**2*(4*x1*x3+4*x1*x4+4*x1*x10+4*x2*x3+4*x2*x4+4*x2*
43648  & x10-x2*x5+4*x3*x5+4*x4*x5+2*x10*x5-x9*x5-x8*x5)-(8*ph**2*
43649  & x1)*(x3+x4+x10)+16*x2*x5*(x3+x4+x10)
43650  fm(3,7)=8*pq**4*(3*x3+6*x4+3*x10+x9+2*x8+2*x7+x6)+2*pq**2*
43651  & ph**2*(x3+2*x4+2*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+4*
43652  & x1*x10+2*x1*x9-2*x1*x8+2*x2*x3+10*x2*x4+5*x2*x10+2*x2*x9+
43653  & x2*x8+2*x2*x7+4*x2*x6-7*x3*x9+2*x3*x8-8*x3*x7+4*x3*x6+4*
43654  & x3*x5+5*x4*x8+4*x4*x6+8*x4*x5+5*x10*x5-x9*x8-x9*x6+x9*x5+
43655  & x8**2-x8*x7+2*x8*x6+2*x8*x5)+2*ph**2*(-x1*x10+x3*x7-2*x3*
43656  & x6+x4*x6)+4*(-x1*x2*x9-2*x1*x2*x8+x1*x9*x8-x1*x8**2+x2**2
43657  & *x7+2*x2**2*x6+3*x2*x4*x5+2*x2*x10*x5-2*x2*x9*x6+x2*x8*x7
43658  & +x2*x8*x6-2*x3*x9*x5+x3*x8*x5+x4*x8*x5)
43659  fm(3,8)=8*pq**4*(3*x3+6*x4+3*x10+2*x9+x8+2*x7+x6)+2*pq**2*
43660  & ph**2*(3*x3+6*x4+3*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+
43661  & 4*x1*x10+4*x2*x3+8*x2*x4+4*x2*x10-8*x3*x9+4*x3*x8-8*x3*x7
43662  & +4*x3*x6+6*x3*x5+4*x4*x8+4*x4*x6+12*x4*x5+6*x10*x5+2*x9*
43663  & x5+x8*x5)+4*ph**2*(-x1*x3-2*x1*x4-x1*x10+2*x3*x7-x3*x6-x4
43664  & *x6)+8*x5*(x2*x3+2*x2*x4+x2*x10-2*x3*x9+x3*x8+x4*x8)
43665  fm(4,4)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x3+x8+2*
43666  & x6+x5)+8*pq**2*ph**2*(-x1-x3+2*x6)+16*pq**2*(x2*x8+4*x2*
43667  & x6+x2*x5-2*x3*x6-2*x8*x6)+8*ph**2*x3*x6-16*x2*x8*x6
43668  fm(4,5)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10-x9+x8-4
43669  & *x7+2*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x3-2*x2*x10-2*x2*x7+
43670  & x2*x6+2*x3*x6-2*x4*x6+4*x10*x6-x9*x6-x8*x6)+16*x2*x6*(x3+
43671  & x10)
43672  fm(4,6)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-4*x3-2*
43673  & x4-8*x10+x9+x8-4*x7-2*x6+2*x5)-(4*pq**2*ph**2)*(x1+x3+x10
43674  & +x7)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
43675  & -4*x2*x3-5*x2*x10+x2*x9-3*x2*x7-x2*x6+x2*x5+x3*x9+2*x3*x7
43676  & -3*x3*x5+x4*x8+2*x4*x6-x4*x5-5*x10*x5+x9*x8+x9*x6+x8*x7+
43677  & x8*x5-4*x7*x5+x5**2)-(16*x2*x5)*(x1+x3+x10+x7)
43678  fm(4,7)=8*pq**4*(-x3-2*x4-3*x10-2*x9-x8-6*x7-3*x6)+2*pq**2
43679  & *ph**2*(x3+2*x4-3*x10-6*x7-3*x6)+4*pq**2*(-4*x1*x10-8*x1*
43680  & x7-4*x1*x6-6*x2*x10-2*x2*x9-x2*x8-12*x2*x7-6*x2*x6-4*x3*
43681  & x7-4*x3*x6+8*x4*x6-4*x10*x5+8*x9*x6-4*x8*x7-4*x8*x6-8*x7*
43682  & x5-4*x6*x5)+4*ph**2*(x1*x10+2*x1*x7+x1*x6+x3*x7+x3*x6-2*
43683  & x4*x6)+8*x2*(-x10*x5+2*x9*x6-x8*x7-x8*x6-2*x7*x5-x6*x5)
43684  fm(4,8)=8*pq**4*(-x3-2*x4-3*x10-x9-2*x8-6*x7-3*x6)+2*pq**2
43685  & *ph**2*(x3+2*x4-2*x10-2*x7-x6)+4*pq**2*(-4*x1*x10-2*x1*x9
43686  & +2*x1*x8-8*x1*x7-4*x1*x6-5*x2*x10-x2*x9-2*x2*x8-8*x2*x7-4
43687  & *x2*x6+x3*x9-2*x3*x8-4*x3*x7-4*x3*x6-4*x3*x5+x4*x8+8*x4*
43688  & x6-2*x4*x5-5*x10*x5+x9*x8+7*x9*x6-2*x9*x5-x8**2-5*x8*x7-2
43689  & *x8*x6-x8*x5-10*x7*x5-2*x6*x5)+2*ph**2*(x1*x10-x3*x7+2*x3
43690  & *x6-x4*x6)+4*(-x1*x9*x8+x1*x9*x5+x1*x8**2+2*x1*x8*x5-2*x2
43691  & *x10*x5+2*x2*x9*x6-x2*x8*x7-x2*x8*x6-3*x2*x7*x5+2*x3*x9*
43692  & x5-x3*x8*x5-2*x3*x5**2-x4*x8*x5-x4*x5**2)
43693  fm(5,5)=16*pq**6+16*pq**4*(-x1-x3+x4-x10-x7+x6)+16*pq**2*(
43694  & x3*x6+x4*x10+x4*x7+x4*x6+x10*x6)-16*x4*x10*x6
43695  fm(5,6)=16*pq**6+8*pq**4*(-2*x1+x2-4*x3+2*x4-4*x10+x9-x8-2
43696  & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5-2*x3*x5+4*x4*x10-x4*x9-x4*
43697  & x8+2*x4*x7-2*x4*x6+x4*x5-2*x10*x5-2*x7*x5)+16*x4*x5*(x10+
43698  & x7)
43699  fm(5,7)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
43700  & 4*x1*x4+2*x1*x10+x1*x9-x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
43701  & x4-3*x2*x10-2*x2*x7-x2*x6+6*x3**2+6*x3*x4+6*x3*x10+x3*x9+
43702  & 3*x3*x8+2*x3*x7+4*x3*x6+2*x3*x5+6*x4*x10+2*x4*x8+4*x4*x7+
43703  & 2*x4*x6+x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-x10*x5+
43704  & 2*x9*x7+2*x9*x6-x8*x6+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(-
43705  & x1**2*x9+x1**2*x8+2*x1*x2*x10+3*x1*x2*x7+3*x1*x2*x6-x1*x3
43706  & *x9-x1*x3*x8-x1*x3*x5-x1*x4*x8+x1*x4*x5-x1*x10*x9-x1*x10*
43707  & x8-x1*x9*x7+x1*x8*x7+x2*x3*x7+3*x2*x3*x6-x2*x4*x6+3*x2*
43708  & x10*x7+3*x2*x10*x6+3*x2*x7**2+3*x2*x7*x6+x3**2*x5+2*x3*x4
43709  & *x5+x3*x10*x5-x3*x7*x5+x4*x10*x5+x4*x7*x5)
43710  fm(5,8)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
43711  & 4*x1*x4+2*x1*x10-x1*x9+x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
43712  & x4-x2*x10+2*x2*x7+x2*x6+6*x3**2+6*x3*x4+6*x3*x10+2*x3*x8+
43713  & 2*x3*x7+4*x3*x6-2*x3*x5+6*x4*x10-x4*x9+2*x4*x8+4*x4*x7+2*
43714  & x4*x6-x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-3*x10*x5+
43715  & 3*x9*x7+2*x9*x6+x8*x7+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(
43716  & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9-x1*x3*x8+3*
43717  & x1*x3*x5+3*x1*x4*x5-x1*x10*x9-x1*x10*x8+2*x1*x10*x5-x1*x9
43718  & *x7-x1*x9*x6-x1*x8*x7-x2*x3*x7+x2*x3*x6+x2*x10*x7+x2*x10*
43719  & x6+x2*x7**2+2*x2*x7*x6+3*x3**2*x5+3*x3*x4*x5+3*x3*x10*x5+
43720  & x3*x7*x5+3*x4*x10*x5+3*x4*x7*x5-x4*x6*x5)
43721  fm(6,6)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x4+x9+x7
43722  & +2*x5)+8*pq**2*ph**2*(-x1+2*x4-x7)+16*pq**2*(x2*x5-2*x4*
43723  & x9-2*x4*x7+4*x4*x5+x9*x5)+8*ph**2*x4*x7-16*x4*x9*x5
43724  fm(6,7)=8*pq**4*(-6*x3-3*x4-3*x10-2*x9-x8-x7-2*x6)+2*pq**2
43725  & *ph**2*(-2*x3-x4-2*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*x4
43726  & -4*x1*x10+2*x1*x9-2*x1*x8-10*x2*x3-2*x2*x4-5*x2*x10-x2*x9
43727  & -2*x2*x8-4*x2*x7-2*x2*x6-5*x3*x9-4*x3*x7-8*x3*x5-2*x4*x9+
43728  & 7*x4*x8-4*x4*x7+8*x4*x6-4*x4*x5-5*x10*x5-x9**2+x9*x8-2*x9
43729  & *x7+x9*x6-2*x9*x5+x8*x7-x8*x5)+2*ph**2*(x1*x10-x3*x7+2*x4
43730  & *x7-x4*x6)+4*(2*x1*x2*x9+x1*x2*x8+x1*x9**2-x1*x9*x8-2*x2
43731  & **2*x7-x2**2*x6-3*x2*x3*x5-2*x2*x10*x5-x2*x9*x7-x2*x9*x6+
43732  & 2*x2*x8*x7-x3*x9*x5-x4*x9*x5+2*x4*x8*x5)
43733  fm(6,8)=8*pq**4*(-6*x3-3*x4-3*x10-x9-2*x8-x7-2*x6)+2*pq**2
43734  & *ph**2*(-6*x3-3*x4-3*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*
43735  & x4-4*x1*x10-8*x2*x3-4*x2*x4-4*x2*x10-4*x3*x9-4*x3*x7-12*
43736  & x3*x5-4*x4*x9+8*x4*x8-4*x4*x7+8*x4*x6-6*x4*x5-6*x10*x5-x9
43737  & *x5-2*x8*x5)+4*ph**2*(2*x1*x3+x1*x4+x1*x10+x3*x7+x4*x7-2*
43738  & x4*x6)+8*x5*(-2*x2*x3-x2*x4-x2*x10-x3*x9-x4*x9+2*x4*x8)
43739  fm(7,7)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+9*
43740  & x2*x10+7*x3*x7+2*x3*x6+2*x4*x7+7*x4*x6+x10*x5+2*x9*x7+7*
43741  & x9*x6+7*x8*x7+2*x8*x6)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2
43742  & *x4*x7-7*x4*x6)+4*x2*(x10*x5+2*x9*x7+7*x9*x6+7*x8*x7+2*x8
43743  & *x6)
43744  fm(7,8)=72*pq**4*x10+2*pq**2*ph**2*x10+4*pq**2*(2*x1*x10+
43745  & 10*x2*x10+7*x3*x9+2*x3*x8+14*x3*x7+4*x3*x6+2*x4*x9+7*x4*
43746  & x8+4*x4*x7+14*x4*x6+10*x10*x5+x9**2+7*x9*x8+2*x9*x7+7*x9*
43747  & x6+x8**2+7*x8*x7+2*x8*x6)+2*ph**2*(7*x1*x10-7*x3*x7-2*x3*
43748  & x6-2*x4*x7-7*x4*x6)+2*(-2*x1*x9**2-14*x1*x9*x8-2*x1*x8**2
43749  & +2*x2*x10*x5+2*x2*x9*x7+7*x2*x9*x6+7*x2*x8*x7+2*x2*x8*x6+
43750  & 7*x3*x9*x5+2*x3*x8*x5+2*x4*x9*x5+7*x4*x8*x5)
43751  fm(8,8)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+x2
43752  & *x10+7*x3*x9+2*x3*x8+7*x3*x7+2*x3*x6+2*x4*x9+7*x4*x8+2*x4
43753  & *x7+7*x4*x6+9*x10*x5)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2*
43754  & x4*x7-7*x4*x6)+4*x5*(x2*x10+7*x3*x9+2*x3*x8+2*x4*x9+7*x4*
43755  & x8)
43756  fm(9,9)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
43757  & x3*x7+x4*x6-x10*x5+x9*x6+x8*x7)+ph**2*(x1*x10-x3*x7-x4*x6
43758  & )+2*x2*(-x10*x5+x9*x6+x8*x7)
43759  fm(9,10)=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
43760  & x10+2*x3*x9+2*x3*x7+2*x4*x6-2*x10*x5+x9*x8+2*x8*x7)+ph**2
43761  & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x8*x7+x3*
43762  & x9*x5)
43763  fmxx=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
43764  & x10+2*x4*x8+2*x4*x6+2*x3*x7-2*x10*x5+x9*x8+2*x9*x6)+ph**2
43765  & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x9*x6+x4*
43766  & x8*x5)
43767  fm(9,10)=0.5d0*(fmxx+fm(9,10))
43768  fm(10,10)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
43769  & x3*x7+x4*x6-x10*x5+x9*x3+x8*x4)+ph**2*(x1*x10-x3*x7-x4*x6
43770  & )+2*x5*(-x10*x2+x9*x3+x8*x4)
43771 
43772 C...Repackage matrix elements.
43773  DO 200 i=1,8
43774  DO 190 j=i,8
43775  rm(i,j)=fm(i,j)
43776  190 CONTINUE
43777  200 CONTINUE
43778  rm(7,7)=fm(7,7)-2d0*fm(9,9)
43779  rm(7,8)=fm(7,8)-2d0*fm(9,10)
43780  rm(8,8)=fm(8,8)-2d0*fm(10,10)
43781 
43782 C...Produce final result: matrix elements * colours * propagators.
43783  DO 220 i=1,8
43784  DO 210 j=i,8
43785  fac=8d0
43786  IF(i.EQ.j)fac=4d0
43787  wtqqbh=wtqqbh+rm(i,j)*fac*clr(i,j)/(dx(i)*dx(j))
43788  210 CONTINUE
43789  220 CONTINUE
43790  wtqqbh=-wtqqbh/256d0
43791 
43792  ELSE
43793 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43794  a11=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x2*x10+x3
43795  & *x7+x4*x6+x9*x6+x8*x7)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x2)*(x9
43796  & *x6+x8*x7)
43797  a12=-8d0*pq**4*x10+4d0*pq**2*(-x2*x10-x3*x9-2d0*x3*x7-x4*x8-
43798  & 2d0*x4*x6-x10*x5-x9*x8-x9*x6-x8*x7)+2d0*ph**2*(-x1*x10+x3*x7
43799  & +x4*x6)+2d0*(2d0*x1*x9*x8-x2*x9*x6-x2*x8*x7-x3*x9*x5-x4*x8*
43800  & x5)
43801  a22=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x3*x9+x3*
43802  & x7+x4*x8+x4*x6+x10*x5)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x5)*(x3
43803  & *x9+x4*x8)
43804 
43805 C...Produce final result: matrix elements * propagators.
43806  a11=a11/dx(7)**2
43807  a12=a12/(dx(7)*dx(8))
43808  a22=a22/dx(8)**2
43809  wtqqbh=-(a11+a22+2d0*a12)*8d0/9d0
43810  ENDIF
43811 
43812  RETURN
43813  END
43814 
43815 C*********************************************************************
43816 
43817 C...PYSTBH (and auxiliaries)
43818 C.. Evaluates the matrix elements for t + b + H production.
43819 
43820  SUBROUTINE pystbh(WTTBH)
43821 
43822 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43823  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43824  IMPLICIT INTEGER(i-n)
43825  INTEGER pyk,pychge,pycomp
43826 
43827 C...COMMONBLOCKS
43828  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43829  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43830  common/pypars/mstp(200),parp(200),msti(200),pari(200)
43831  common/pyint1/mint(400),vint(400)
43832  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
43833  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
43834  common/pyint4/mwid(500),wids(500,5)
43835  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
43836  common/pymssm/imss(0:99),rmss(0:99)
43837  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
43838  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
43839  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
43840  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
43841  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
43842  DOUBLE PRECISION mw2
43843  SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
43844  &/pyint4/,/pysubs/,/pymssm/,/pysgcm/,/pyctbh/
43845 
43846 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43847  dimension qq(4,2),pp(4,3)
43848  DATA qq/8*0d0/
43849 
43850  wttbh=0d0
43851 
43852 C...KINEMATIC PARAMETERS.
43853  shpr=sqrt(vint(26))*vint(1)
43854  ph=sqrt(vint(21))*vint(1)
43855  sph=ph**2
43856 
43857 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43858  DO 100 i=1,2
43859  pt=sqrt(max(0d0,vint(197+5*i)))
43860  pp(1,i)=pt*cos(vint(198+5*i))
43861  pp(2,i)=pt*sin(vint(198+5*i))
43862  100 CONTINUE
43863  pp(1,3)=-pp(1,1)-pp(1,2)
43864  pp(2,3)=-pp(2,1)-pp(2,2)
43865  pms1=vint(201)**2+pp(1,1)**2+pp(2,1)**2
43866  pms2=vint(206)**2+pp(1,2)**2+pp(2,2)**2
43867  pms3=sph+pp(1,3)**2+pp(2,3)**2
43868  pmt3=sqrt(pms3)
43869  pp(3,3)=pmt3*sinh(vint(211))
43870  pp(4,3)=pmt3*cosh(vint(211))
43871  pms12=(shpr-pp(4,3))**2-pp(3,3)**2
43872  pp(3,1)=(-pp(3,3)*(pms12+pms1-pms2)+
43873  &vint(213)*(shpr-pp(4,3))*vint(220))/(2d0*pms12)
43874  pp(3,2)=-pp(3,1)-pp(3,3)
43875  pp(4,1)=sqrt(pms1+pp(3,1)**2)
43876  pp(4,2)=sqrt(pms2+pp(3,2)**2)
43877 
43878 C...CM SYSTEM, INGOING QUARKS/GLUONS
43879  qq(3,1) = shpr/2.d0
43880  qq(4,1) = qq(3,1)
43881  qq(3,2) = -qq(3,1)
43882  qq(4,2) = qq(4,1)
43883 
43884 C...PARAMETERS FOR AMPLITUDE METHOD
43885  alpha = aem
43886  alphas = as
43887  sw2 = paru(102)
43888  mw2 = pmas(24,1)**2
43889  tanb = paru(141)
43890  vtb = vckm(3,3)
43891  rmb=pymrun(5,vint(52))
43892 
43893  isub=mint(1)
43894 
43895  IF (isub.EQ.401) THEN
43896  CALL pytbhg(qq(1,1),qq(1,2),pp(1,1),pp(1,2),pp(1,3),
43897  & vint(201),vint(206),rmb,vint(43),wttbh)
43898  ELSE IF (isub.EQ.402) THEN
43899  CALL pytbhq(qq(1,1),qq(1,2),pp(1,1),pp(1,2),pp(1,3),
43900  & vint(201),vint(206),rmb,vint(43),wttbh)
43901  END IF
43902 
43903  RETURN
43904  END
43905 C------------------------------------------------------------------
43906  SUBROUTINE pytbhb(MT,MB,MHP,BR,GAMT)
43907 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43908  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43909  IMPLICIT INTEGER(i-n)
43910  DOUBLE PRECISION mw2,mt,mb,mhp,mw,kfun
43911  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
43912  SAVE /pyctbh/
43913 
43914 C TOP WIDTH CALCULATION
43915 C VTB = 0.99
43916  mw=dsqrt(mw2)
43917  xb=(mb/mt)**2
43918  xw=(mw/mt)**2
43919  xh =(mhp/mt)**2
43920  gamtbh = 0d0
43921  IF (mt .LT. (mhp+mb)) THEN
43922 C T ->B W ONLY
43923  betw = dsqrt(1.d0-2*(xb+xw)+(xw-xb)**2)
43924  gamtbw = vtb**2*alpha/(16*sw2)*mt/xw*betw*
43925  & (2*(1.d0-xb-xw)-(1.d0+xb-xw)*(1.d0-xb -2*xw) )
43926  gamt = gamtbw
43927  ELSE
43928 C T ->BW +T ->B H^+
43929  betw = dsqrt(1.d0-2*(xb+xw)+(xw-xb)**2)
43930  gamtbw = vtb**2*alpha/(16*sw2)*mt/xw*betw*
43931  & (2*(1.d0-xb-xw)-(1.d0+xb-xw)*(1.d0-xb -2*xw) )
43932 C
43933  kfun = dsqrt( (1.d0-(mhp/mt)**2-(mb/mt)**2)**2
43934  & -4.d0*(mhp*mb/mt**2)**2 )
43935  gamtbh= alpha/sw2/8.d0*vtb**2*kfun/mt *
43936  & (v**2*((mt+mb)**2-mhp**2)+a**2*((mt-mb)**2-mhp**2))
43937  gamt = gamtbw+gamtbh
43938  ENDIF
43939 C THUS BR IS
43940  br=gamtbh/gamt
43941  RETURN
43942  END
43943 
43944 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43945 C GG->TBH^+, QQBAR->TBH^+
43946 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43947 C (FOR INSTANCE WITH PYTHIA)
43948 C------------------------------------------------------------
43949 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43950 C PHYS REV. D 60 (1999) 115011
43951 C (THESE FILES PREPARED BY J.-L. KNEUR)
43952 C------------------------------------------------------------
43953 C 1) GG->TBH^+
43954  SUBROUTINE pytbhg(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43955 C
43956 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43957 C
43958 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43959 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43960 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43961 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43962 C "PHYSICAL PARAMETERS" INPUT:
43963 C MT,MB TOP AND BOTTOM MASSES;
43964 C MHP CHARGED HIGGS MASS
43965 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43966 C
43967 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43968 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43969 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43970 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43971 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43972 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43973 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43974 C
43975  IMPLICIT DOUBLE PRECISION(a-h, o-z)
43976  IMPLICIT INTEGER(i-n)
43977  DOUBLE PRECISION mw2,mt,mb,mhp,mw
43978  dimension q1(4),q2(4),p1(4),p2(4),p3(4)
43979  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43980  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43981  common/pymssm/imss(0:99),rmss(0:99)
43982 
43983  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
43984  SAVE /pydat1/,/pydat2/,/pymssm/,/pyctbh/
43985 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43986 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43987 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43988 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43989 C (TAN BETA) VALUES
43990 C
43991 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43992 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43993 
43994  pi = 4*datan(1.d0)
43995  mw = dsqrt(mw2)
43996 C
43997 C COLLECTING THE RELEVANT OVERALL FACTORS:
43998 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43999  ps=1.d0/(8.d0*8.d0 *2.d0*2.d0)
44000 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44001  fact=(4.d0*pi*alpha)*(4.d0*pi*alphas)**2/sw2/2.d0
44002 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44003 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44004 C ALPHAS IS ALPHA_STRONG;
44005 C SW2 IS SIN(THETA_W)**2.
44006 C
44007 C VTB=.998D0
44008 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44009 C
44010  v = ( mt/mw/tanb +rmb/mw*tanb)/2.d0
44011  a = (-mt/mw/tanb +rmb/mw*tanb)/2.d0
44012 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44013 C
44014 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44015 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44016  DO 100 kk=1,4
44017  p2(kk)=p3(kk)-q1(kk)-q2(kk)+p1(kk)
44018  100 CONTINUE
44019 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44020  s = 2*pytbhs(q1,q2)
44021  p1q1=pytbhs(q1,p1)
44022  p1q2=pytbhs(p1,q2)
44023  p2q1=pytbhs(p2,q1)
44024  p2q2=pytbhs(p2,q2)
44025  p1p2=pytbhs(p1,p2)
44026 C
44027 C TOP WIDTH CALCULATION
44028  CALL pytbhb(mt,mb,mhp,br,gamt)
44029 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44030 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44031  a1inv= s -2*p1q1 -2*p1q2
44032  a1 =a1inv/(a1inv**2+ (gamt*mt)**2)
44033 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44034 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
44035 C THE TOP WIDTH
44036  a12 = 1.d0/(a1inv**2+ (gamt*mt)**2)
44037  a2 =1.d0/(s +2*p2q1 +2*p2q2)
44038 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44039 C NOW COMES THE AMP**2:
44040 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
44041 C THE EXPRESSIONS BELOW
44042  v18=0.d0
44043  a18=0.d0
44044  v18= 640*a1/3+640*a2/3+32*a1*a2*mb**2-368*a12*mb*mt-
44045  &512*a1*a2*mb*mt/3-
44046  &368*a2**2*mb*mt+32*a1*a2*mt**2+496*a12*p1p2/3+
44047  &320*a1*a2*p1p2+496*a2**2*p1p2/3+128*a1*mb*mt**3/(3*p1q1**2)+
44048  &128*a1*mt**4/(3*p1q1**2)-256*a12*mb*mt**5/(3*p1q1**2)+
44049  &256*a1*mt**2*p1p2/(3*p1q1**2)-256*a12*mt**4*p1p2/(3*p1q1**2)+
44050  &8/(3*p1q1)-32*a1*mb*mt/p1q1-56*a2*mb*mt/(3*p1q1)+
44051  &88*a1*mt**2/(3*p1q1)+72*a2*mt**2/p1q1+
44052  &704*a12*mb*mt**3/(3*p1q1)-224*a1*a2*mb*mt**3/(3*p1q1)+
44053  &104*a1*p1p2/(3*p1q1)+48*a2*p1p2/p1q1+
44054  &128*a1*a2*mb*mt*p1p2/(3*p1q1)+512*a12*mt**2*p1p2/(3*p1q1)-
44055  &448*a1*a2*mt**2*p1p2/(3*p1q1)-32*a1*a2*p1p2**2/p1q1-
44056  &656*a1*a2*p1q1/3-224*a2**2*p1q1+128*a1*mb*mt**3/(3*p1q2**2)+
44057  &128*a1*mt**4/(3*p1q2**2)-256*a12*mb*mt**5/(3*p1q2**2)+
44058  &256*a1*mt**2*p1p2/(3*p1q2**2)-256*a12*mt**4*p1p2/(3*p1q2**2)+
44059  &256*a1*mt**2*p1q1/(3*p1q2**2)+256*a12*mb*mt**3*p1q1/(3*p1q2**2)+
44060  &8/(3*p1q2)-32*a1*mb*mt/p1q2-56*a2*mb*mt/(3*p1q2)
44061  v18=v18+88*a1*mt**2/(3*p1q2)+72*a2*mt**2/p1q2+
44062  &704*a12*mb*mt**3/(3*p1q2)-224*a1*a2*mb*mt**3/(3*p1q2)+
44063  &104*a1*p1p2/(3*p1q2)+48*a2*p1p2/p1q2+
44064  &128*a1*a2*mb*mt*p1p2/(3*p1q2)+512*a12*mt**2*p1p2/(3*p1q2)-
44065  &448*a1*a2*mt**2*p1p2/(3*p1q2)-32*a1*a2*p1p2**2/p1q2-
44066  &32*a1*mb*mt**3/(3*p1q1*p1q2)-32*a1*mt**4/(3*p1q1*p1q2)+
44067  &64*a12*mb*mt**5/(3*p1q1*p1q2)+16*p1p2/(3*p1q1*p1q2)-
44068  &64*a1*mt**2*p1p2/(3*p1q1*p1q2)+64*a12*mt**4*p1p2/(3*p1q1*p1q2)+
44069  &112*a1*p1q1/p1q2+272*a2*p1q1/(3*p1q2)-
44070  &272*a1*a2*mb**2*p1q1/(3*p1q2)+208*a12*mb*mt*p1q1/(3*p1q2)-
44071  &400*a1*a2*mb*mt*p1q1/(3*p1q2)-80*a1*a2*mt**2*p1q1/p1q2+
44072  &96*a12*p1p2*p1q1/p1q2-320*a1*a2*p1p2*p1q1/p1q2-
44073  &544*a1*a2*p1q1**2/(3*p1q2)-656*a1*a2*p1q2/3-224*a2**2*p1q2+
44074  &256*a1*mt**2*p1q2/(3*p1q1**2)+256*a12*mb*mt**3*p1q2/(3*p1q1**2)+
44075  &112*a1*p1q2/p1q1+272*a2*p1q2/(3*p1q1)-
44076  &272*a1*a2*mb**2*p1q2/(3*p1q1)+208*a12*mb*mt*p1q2/(3*p1q1)-
44077  &400*a1*a2*mb*mt*p1q2/(3*p1q1)-80*a1*a2*mt**2*p1q2/p1q1
44078  v18=v18+96*a12*p1p2*p1q2/p1q1-320*a1*a2*p1p2*p1q2/p1q1-
44079  &544*a1*a2*p1q2**2/(3*p1q1)+128*a2*mb**4/(3*p2q1**2)+
44080  &128*a2*mb**3*mt/(3*p2q1**2)-256*a2**2*mb**5*mt/(3*p2q1**2)+
44081  &256*a2*mb**2*p1p2/(3*p2q1**2)-256*a2**2*mb**4*p1p2/(3*p2q1**2)+
44082  &256*a2*mb**2*p1q1/(3*p2q1**2)-256*a2**2*mb**4*p1q1/(3*p2q1**2)-
44083  &64*mb**3*mt**3/(3*p1q2**2*p2q1**2)-
44084  &64*mb**2*mt**2*p1p2/(3*p1q2**2*p2q1**2)-
44085  &64*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1**2)+
44086  &64*mb**3*mt/(3*p1q2*p2q1**2)+
44087  &256*a2*mb**3*mt*p1p2/(3*p1q2*p2q1**2)+
44088  &256*a2*mb**2*p1p2**2/(3*p1q2*p2q1**2)+
44089  &256*a2*mb**3*mt*p1q1/(3*p1q2*p2q1**2)+
44090  &512*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1**2)+
44091  &256*a2*mb**2*p1q1**2/(3*p1q2*p2q1**2)-
44092  &256*a2**2*mb**4*p1q2/(3*p2q1**2)-8/(3*p2q1)-72*a1*mb**2/p2q1-
44093  &88*a2*mb**2/(3*p2q1)+56*a1*mb*mt/(3*p2q1)+32*a2*mb*mt/p2q1+
44094  &224*a1*a2*mb**3*mt/(3*p2q1)-704*a2**2*mb**3*mt/(3*p2q1)
44095  v18=v18-48*a1*p1p2/p2q1-104*a2*p1p2/(3*p2q1)+
44096  &448*a1*a2*mb**2*p1p2/(3*p2q1)-512*a2**2*mb**2*p1p2/(3*p2q1)-
44097  &128*a1*a2*mb*mt*p1p2/(3*p2q1)+32*a1*a2*p1p2**2/p2q1-
44098  &16*p1p2/(3*p1q1*p2q1)-32*a1*mb*mt*p1p2/(3*p1q1*p2q1)-
44099  &32*a2*mb*mt*p1p2/(3*p1q1*p2q1)-
44100  &64*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q1)-
44101  &64*a1*a2*p1p2**3/(3*p1q1*p2q1)-256*a2*p1q1/(3*p2q1)+
44102  &448*a1*a2*mb**2*p1q1/(3*p2q1)-368*a2**2*mb**2*p1q1/(3*p2q1)+
44103  &224*a1*a2*mb*mt*p1q1/(3*p2q1)+304*a1*a2*p1p2*p1q1/(3*p2q1)-
44104  &64*mb*mt**3/(3*p1q2**2*p2q1)-
44105  &256*a1*mb*mt**3*p1p2/(3*p1q2**2*p2q1)-
44106  &256*a1*mt**2*p1p2**2/(3*p1q2**2*p2q1)+
44107  &64*mt**2*p1q1/(3*p1q2**2*p2q1)-
44108  &128*a1*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1)-
44109  &128*a1*mb*mt**3*p1q1/(3*p1q2**2*p2q1)-
44110  &256*a1*mt**2*p1p2*p1q1/(3*p1q2**2*p2q1)-4*mb**2/(3*p1q2*p2q1)+
44111  &64*mb*mt/(3*p1q2*p2q1)-128*a2*mb**3*mt/(3*p1q2*p2q1)
44112  v18=v18-4*mt**2/(3*p1q2*p2q1)-128*a1*mb**2*mt**2/(3*p1q2*p2q1)-
44113  &128*a2*mb**2*mt**2/(3*p1q2*p2q1)-128*a1*mb*mt**3/(3*p1q2*p2q1)-
44114  &112*a2*mb**2*p1p2/(3*p1q2*p2q1)-32*a1*mb*mt*p1p2/(3*p1q2*p2q1)-
44115  &32*a2*mb*mt*p1p2/(3*p1q2*p2q1)-112*a1*mt**2*p1p2/(3*p1q2*p2q1)-
44116  &48*a1*p1p2**2/(p1q2*p2q1)-48*a2*p1p2**2/(p1q2*p2q1)+
44117  &512*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q1)+
44118  &512*a1*a2*p1p2**3/(3*p1q2*p2q1)-8*mb*mt*p1p2/(3*p1q1*p1q2*p2q1)-
44119  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q1)+
44120  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q1)-
44121  &16*p1p2**2/(3*p1q1*p1q2*p2q1)+
44122  &32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q1)+8*p1q1/(3*p1q2*p2q1)-
44123  &160*a1*mb**2*p1q1/(3*p1q2*p2q1)-272*a2*mb**2*p1q1/(3*p1q2*p2q1)+
44124  &56*a1*mb*mt*p1q1/(3*p1q2*p2q1)+200*a2*mb*mt*p1q1/(3*p1q2*p2q1)-
44125  &48*a1*p1p2*p1q1/(p1q2*p2q1)-256*a2*p1p2*p1q1/(3*p1q2*p2q1)+
44126  &256*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1)+
44127  &256*a1*a2*mb*mt*p1p2*p1q1/(p1q2*p2q1)+
44128  &1024*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q1)
44129  v18=v18-272*a2*p1q1**2/(3*p1q2*p2q1)+
44130  &256*a1*a2*mb**2*p1q1**2/(3*p1q2*p2q1)+
44131  &256*a1*a2*mb*mt*p1q1**2/(3*p1q2*p2q1)+
44132  &512*a1*a2*p1p2*p1q1**2/(3*p1q2*p2q1)+16*a2*p1q2/(3*p2q1)+
44133  &64*a1*a2*mb**2*p1q2/p2q1+32*a2**2*mb**2*p1q2/(3*p2q1)+
44134  &112*a1*a2*mb*mt*p1q2/(3*p2q1)+368*a1*a2*p1p2*p1q2/(3*p2q1)+
44135  &32*a2*p1p2*p1q2/(3*p1q1*p2q1)-
44136  &32*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1)-
44137  &32*a1*a2*mb*mt*p1p2*p1q2/(3*p1q1*p2q1)-
44138  &64*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q1)+224*a12*p2q1+
44139  &656*a1*a2*p2q1/3-256*a1*mt**2*p2q1/(3*p1q1**2)+
44140  &256*a12*mt**4*p2q1/(3*p1q1**2)-256*a1*p2q1/(3*p1q1)+
44141  &224*a1*a2*mb*mt*p2q1/(3*p1q1)-368*a12*mt**2*p2q1/(3*p1q1)+
44142  &448*a1*a2*mt**2*p2q1/(3*p1q1)+304*a1*a2*p1p2*p2q1/(3*p1q1)+
44143  &256*a12*mt**4*p2q1/(3*p1q2**2)+
44144  &256*a12*mt**2*p1q1*p2q1/(3*p1q2**2)+16*a1*p2q1/(3*p1q2)+
44145  &112*a1*a2*mb*mt*p2q1/(3*p1q2)+32*a12*mt**2*p2q1/(3*p1q2)
44146  v18=v18+64*a1*a2*mt**2*p2q1/p1q2+368*a1*a2*p1p2*p2q1/(3*p1q2)+
44147  &16*a1*mt**2*p2q1/(3*p1q1*p1q2)-64*a12*mt**4*p2q1/(3*p1q1*p1q2)+
44148  &640*a12*p1q1*p2q1/(3*p1q2)+544*a1*a2*p1q1*p2q1/(3*p1q2)+
44149  &32*a12*p1q2*p2q1/p1q1+944*a1*a2*p1q2*p2q1/(3*p1q1)+
44150  &128*a2*mb**4/(3*p2q2**2)+128*a2*mb**3*mt/(3*p2q2**2)-
44151  &256*a2**2*mb**5*mt/(3*p2q2**2)+256*a2*mb**2*p1p2/(3*p2q2**2)-
44152  &256*a2**2*mb**4*p1p2/(3*p2q2**2)-
44153  &64*mb**3*mt**3/(3*p1q1**2*p2q2**2)-
44154  &64*mb**2*mt**2*p1p2/(3*p1q1**2*p2q2**2)+
44155  &64*mb**3*mt/(3*p1q1*p2q2**2)+
44156  &256*a2*mb**3*mt*p1p2/(3*p1q1*p2q2**2)+
44157  &256*a2*mb**2*p1p2**2/(3*p1q1*p2q2**2)-
44158  &256*a2**2*mb**4*p1q1/(3*p2q2**2)+256*a2*mb**2*p1q2/(3*p2q2**2)-
44159  &256*a2**2*mb**4*p1q2/(3*p2q2**2)-
44160  &64*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2**2)+
44161  &256*a2*mb**3*mt*p1q2/(3*p1q1*p2q2**2)+
44162  &512*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2**2)
44163  v18=v18+256*a2*mb**2*p1q2**2/(3*p1q1*p2q2**2)-
44164  &256*a2*mb**2*p2q1/(3*p2q2**2)-256*a2**2*mb**3*mt*p2q1/(3*p2q2**2)+
44165  &64*mb**2*mt**2*p2q1/(3*p1q1**2*p2q2**2)+
44166  &64*mb**2*p2q1/(3*p1q1*p2q2**2)-
44167  &128*a2*mb**3*mt*p2q1/(3*p1q1*p2q2**2)-
44168  &128*a2*mb**2*mt**2*p2q1/(3*p1q1*p2q2**2)-
44169  &256*a2*mb**2*p1p2*p2q1/(3*p1q1*p2q2**2)+
44170  &256*a2**2*mb**2*p1q1*p2q1/(3*p2q2**2)-
44171  &256*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2**2)-8/(3*p2q2)-
44172  &72*a1*mb**2/p2q2-88*a2*mb**2/(3*p2q2)+56*a1*mb*mt/(3*p2q2)+
44173  &32*a2*mb*mt/p2q2+224*a1*a2*mb**3*mt/(3*p2q2)-
44174  &704*a2**2*mb**3*mt/(3*p2q2)-48*a1*p1p2/p2q2-
44175  &104*a2*p1p2/(3*p2q2)+448*a1*a2*mb**2*p1p2/(3*p2q2)-
44176  &512*a2**2*mb**2*p1p2/(3*p2q2)-128*a1*a2*mb*mt*p1p2/(3*p2q2)+
44177  &32*a1*a2*p1p2**2/p2q2-64*mb*mt**3/(3*p1q1**2*p2q2)-
44178  &256*a1*mb*mt**3*p1p2/(3*p1q1**2*p2q2)-
44179  &256*a1*mt**2*p1p2**2/(3*p1q1**2*p2q2)-4*mb**2/(3*p1q1*p2q2)
44180  v18=v18+64*mb*mt/(3*p1q1*p2q2)-128*a2*mb**3*mt/(3*p1q1*p2q2)-
44181  &4*mt**2/(3*p1q1*p2q2)-128*a1*mb**2*mt**2/(3*p1q1*p2q2)-
44182  &128*a2*mb**2*mt**2/(3*p1q1*p2q2)-128*a1*mb*mt**3/(3*p1q1*p2q2)-
44183  &112*a2*mb**2*p1p2/(3*p1q1*p2q2)-32*a1*mb*mt*p1p2/(3*p1q1*p2q2)-
44184  &32*a2*mb*mt*p1p2/(3*p1q1*p2q2)-112*a1*mt**2*p1p2/(3*p1q1*p2q2)-
44185  &48*a1*p1p2**2/(p1q1*p2q2)-48*a2*p1p2**2/(p1q1*p2q2)+
44186  &512*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q2)+
44187  &512*a1*a2*p1p2**3/(3*p1q1*p2q2)+16*a2*p1q1/(3*p2q2)+
44188  &64*a1*a2*mb**2*p1q1/p2q2+32*a2**2*mb**2*p1q1/(3*p2q2)+
44189  &112*a1*a2*mb*mt*p1q1/(3*p2q2)+368*a1*a2*p1p2*p1q1/(3*p2q2)-
44190  &16*p1p2/(3*p1q2*p2q2)-32*a1*mb*mt*p1p2/(3*p1q2*p2q2)-
44191  &32*a2*mb*mt*p1p2/(3*p1q2*p2q2)-
44192  &64*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q2)-
44193  &64*a1*a2*p1p2**3/(3*p1q2*p2q2)-8*mb*mt*p1p2/(3*p1q1*p1q2*p2q2)-
44194  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q2)+
44195  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q2)-
44196  &16*p1p2**2/(3*p1q1*p1q2*p2q2)
44197  v18=v18+32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q2)+
44198  &32*a2*p1p2*p1q1/(3*p1q2*p2q2)-
44199  &32*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q2)-
44200  &32*a1*a2*mb*mt*p1p2*p1q1/(3*p1q2*p2q2)-
44201  &64*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q2)-256*a2*p1q2/(3*p2q2)+
44202  &448*a1*a2*mb**2*p1q2/(3*p2q2)-368*a2**2*mb**2*p1q2/(3*p2q2)+
44203  &224*a1*a2*mb*mt*p1q2/(3*p2q2)+304*a1*a2*p1p2*p1q2/(3*p2q2)+
44204  &64*mt**2*p1q2/(3*p1q1**2*p2q2)-
44205  &128*a1*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2)-
44206  &128*a1*mb*mt**3*p1q2/(3*p1q1**2*p2q2)-
44207  &256*a1*mt**2*p1p2*p1q2/(3*p1q1**2*p2q2)+8*p1q2/(3*p1q1*p2q2)-
44208  &160*a1*mb**2*p1q2/(3*p1q1*p2q2)-272*a2*mb**2*p1q2/(3*p1q1*p2q2)+
44209  &56*a1*mb*mt*p1q2/(3*p1q1*p2q2)+200*a2*mb*mt*p1q2/(3*p1q1*p2q2)-
44210  &48*a1*p1p2*p1q2/(p1q1*p2q2)-256*a2*p1p2*p1q2/(3*p1q1*p2q2)+
44211  &256*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2)+
44212  &256*a1*a2*mb*mt*p1p2*p1q2/(p1q1*p2q2)+
44213  &1024*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q2)
44214  v18=v18-272*a2*p1q2**2/(3*p1q1*p2q2)+
44215  &256*a1*a2*mb**2*p1q2**2/(3*p1q1*p2q2)+
44216  &256*a1*a2*mb*mt*p1q2**2/(3*p1q1*p2q2)+
44217  &512*a1*a2*p1p2*p1q2**2/(3*p1q1*p2q2)-32*a2*mb**4/(3*p2q1*p2q2)-
44218  &32*a2*mb**3*mt/(3*p2q1*p2q2)+64*a2**2*mb**5*mt/(3*p2q1*p2q2)+
44219  &16*p1p2/(3*p2q1*p2q2)-64*a2*mb**2*p1p2/(3*p2q1*p2q2)+
44220  &64*a2**2*mb**4*p1p2/(3*p2q1*p2q2)+8*mb**2*p1p2/(3*p1q1*p2q1*p2q2)+
44221  &8*mb*mt*p1p2/(3*p1q1*p2q1*p2q2)-
44222  &32*a2*mb**3*mt*p1p2/(3*p1q1*p2q1*p2q2)+
44223  &16*p1p2**2/(3*p1q1*p2q1*p2q2)-
44224  &32*a2*mb**2*p1p2**2/(3*p1q1*p2q1*p2q2)-
44225  &16*a2*mb**2*p1q1/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q1/(3*p2q1*p2q2)+
44226  &8*mb**2*p1p2/(3*p1q2*p2q1*p2q2)+8*mb*mt*p1p2/(3*p1q2*p2q1*p2q2)-
44227  &32*a2*mb**3*mt*p1p2/(3*p1q2*p2q1*p2q2)+
44228  &16*p1p2**2/(3*p1q2*p2q1*p2q2)-
44229  &32*a2*mb**2*p1p2**2/(3*p1q2*p2q1*p2q2)+
44230  &16*mb*mt*p1p2**2/(3*p1q1*p1q2*p2q1*p2q2)
44231  v18=v18+16*p1p2**3/(3*p1q1*p1q2*p2q1*p2q2)-
44232  &32*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1*p2q2)-
44233  &16*a2*mb**2*p1q2/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q2/(3*p2q1*p2q2)-
44234  &32*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1*p2q2)+272*a1*p2q1/(3*p2q2)+
44235  &112*a2*p2q1/p2q2-80*a1*a2*mb**2*p2q1/p2q2-
44236  &400*a1*a2*mb*mt*p2q1/(3*p2q2)+208*a2**2*mb*mt*p2q1/(3*p2q2)-
44237  &272*a1*a2*mt**2*p2q1/(3*p2q2)-320*a1*a2*p1p2*p2q1/p2q2+
44238  &96*a2**2*p1p2*p2q1/p2q2+256*a1*mb*mt**3*p2q1/(3*p1q1**2*p2q2)+
44239  &512*a1*mt**2*p1p2*p2q1/(3*p1q1**2*p2q2)-8*p2q1/(3*p1q1*p2q2)-
44240  &200*a1*mb*mt*p2q1/(3*p1q1*p2q2)-56*a2*mb*mt*p2q1/(3*p1q1*p2q2)+
44241  &272*a1*mt**2*p2q1/(3*p1q1*p2q2)+160*a2*mt**2*p2q1/(3*p1q1*p2q2)+
44242  &256*a1*p1p2*p2q1/(3*p1q1*p2q2)+48*a2*p1p2*p2q1/(p1q1*p2q2)-
44243  &256*a1*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2)-
44244  &256*a1*a2*mt**2*p1p2*p2q1/(3*p1q1*p2q2)-
44245  &1024*a1*a2*p1p2**2*p2q1/(3*p1q1*p2q2)-
44246  &544*a1*a2*p1q1*p2q1/(3*p2q2)-640*a2**2*p1q1*p2q1/(3*p2q2)-
44247  &32*a1*p1p2*p2q1/(3*p1q2*p2q2)
44248  v18=v18+32*a1*a2*mb*mt*p1p2*p2q1/(3*p1q2*p2q2)+
44249  &32*a1*a2*mt**2*p1p2*p2q1/(3*p1q2*p2q2)+
44250  &64*a1*a2*p1p2**2*p2q1/(3*p1q2*p2q2)-
44251  &32*a1*mt**2*p1p2*p2q1/(3*p1q1*p1q2*p2q2)+
44252  &64*a1*a2*p1p2*p1q1*p2q1/(3*p1q2*p2q2)-
44253  &944*a1*a2*p1q2*p2q1/(3*p2q2)-32*a2**2*p1q2*p2q1/p2q2+
44254  &256*a1*mt**2*p1q2*p2q1/(3*p1q1**2*p2q2)+
44255  &96*a1*p1q2*p2q1/(p1q1*p2q2)+96*a2*p1q2*p2q1/(p1q1*p2q2)-
44256  &128*a1*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2)-
44257  &256*a1*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2)-
44258  &128*a1*a2*mt**2*p1q2*p2q1/(3*p1q1*p2q2)-
44259  &512*a1*a2*p1p2*p1q2*p2q1/(p1q1*p2q2)-
44260  &512*a1*a2*p1q2**2*p2q1/(3*p1q1*p2q2)+544*a1*a2*p2q1**2/(3*p2q2)-
44261  &256*a1*mt**2*p2q1**2/(3*p1q1**2*p2q2)-
44262  &272*a1*p2q1**2/(3*p1q1*p2q2)+
44263  &256*a1*a2*mb*mt*p2q1**2/(3*p1q1*p2q2)+
44264  &256*a1*a2*mt**2*p2q1**2/(3*p1q1*p2q2)
44265  v18=v18+512*a1*a2*p1p2*p2q1**2/(3*p1q1*p2q2)+
44266  &512*a1*a2*p1q2*p2q1**2/(3*p1q1*p2q2)+224*a12*p2q2+
44267  &656*a1*a2*p2q2/3+256*a12*mt**4*p2q2/(3*p1q1**2)+
44268  &16*a1*p2q2/(3*p1q1)+112*a1*a2*mb*mt*p2q2/(3*p1q1)+
44269  &32*a12*mt**2*p2q2/(3*p1q1)+64*a1*a2*mt**2*p2q2/p1q1+
44270  &368*a1*a2*p1p2*p2q2/(3*p1q1)-256*a1*mt**2*p2q2/(3*p1q2**2)+
44271  &256*a12*mt**4*p2q2/(3*p1q2**2)-256*a1*p2q2/(3*p1q2)+
44272  &224*a1*a2*mb*mt*p2q2/(3*p1q2)-368*a12*mt**2*p2q2/(3*p1q2)+
44273  &448*a1*a2*mt**2*p2q2/(3*p1q2)+304*a1*a2*p1p2*p2q2/(3*p1q2)+
44274  &16*a1*mt**2*p2q2/(3*p1q1*p1q2)-64*a12*mt**4*p2q2/(3*p1q1*p1q2)+
44275  &32*a12*p1q1*p2q2/p1q2+944*a1*a2*p1q1*p2q2/(3*p1q2)+
44276  &256*a12*mt**2*p1q2*p2q2/(3*p1q1**2)+
44277  &640*a12*p1q2*p2q2/(3*p1q1)+544*a1*a2*p1q2*p2q2/(3*p1q1)-
44278  &256*a2*mb**2*p2q2/(3*p2q1**2)-256*a2**2*mb**3*mt*p2q2/(3*p2q1**2)+
44279  &64*mb**2*mt**2*p2q2/(3*p1q2**2*p2q1**2)+
44280  &64*mb**2*p2q2/(3*p1q2*p2q1**2)-
44281  &128*a2*mb**3*mt*p2q2/(3*p1q2*p2q1**2)
44282  v18=v18-128*a2*mb**2*mt**2*p2q2/(3*p1q2*p2q1**2)-
44283  &256*a2*mb**2*p1p2*p2q2/(3*p1q2*p2q1**2)-
44284  &256*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1**2)+
44285  &256*a2**2*mb**2*p1q2*p2q2/(3*p2q1**2)+272*a1*p2q2/(3*p2q1)+
44286  &112*a2*p2q2/p2q1-80*a1*a2*mb**2*p2q2/p2q1-
44287  &400*a1*a2*mb*mt*p2q2/(3*p2q1)+208*a2**2*mb*mt*p2q2/(3*p2q1)-
44288  &272*a1*a2*mt**2*p2q2/(3*p2q1)-320*a1*a2*p1p2*p2q2/p2q1+
44289  &96*a2**2*p1p2*p2q2/p2q1-32*a1*p1p2*p2q2/(3*p1q1*p2q1)+
44290  &32*a1*a2*mb*mt*p1p2*p2q2/(3*p1q1*p2q1)+
44291  &32*a1*a2*mt**2*p1p2*p2q2/(3*p1q1*p2q1)+
44292  &64*a1*a2*p1p2**2*p2q2/(3*p1q1*p2q1)-944*a1*a2*p1q1*p2q2/(3*p2q1)-
44293  &32*a2**2*p1q1*p2q2/p2q1+256*a1*mb*mt**3*p2q2/(3*p1q2**2*p2q1)+
44294  &512*a1*mt**2*p1p2*p2q2/(3*p1q2**2*p2q1)+
44295  &256*a1*mt**2*p1q1*p2q2/(3*p1q2**2*p2q1)-8*p2q2/(3*p1q2*p2q1)-
44296  &200*a1*mb*mt*p2q2/(3*p1q2*p2q1)-56*a2*mb*mt*p2q2/(3*p1q2*p2q1)+
44297  &272*a1*mt**2*p2q2/(3*p1q2*p2q1)+160*a2*mt**2*p2q2/(3*p1q2*p2q1)+
44298  &256*a1*p1p2*p2q2/(3*p1q2*p2q1)+48*a2*p1p2*p2q2/(p1q2*p2q1)
44299  v18=v18-256*a1*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1)-
44300  &256*a1*a2*mt**2*p1p2*p2q2/(3*p1q2*p2q1)-
44301  &1024*a1*a2*p1p2**2*p2q2/(3*p1q2*p2q1)-
44302  &32*a1*mt**2*p1p2*p2q2/(3*p1q1*p1q2*p2q1)+
44303  &96*a1*p1q1*p2q2/(p1q2*p2q1)+96*a2*p1q1*p2q2/(p1q2*p2q1)-
44304  &128*a1*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1)-
44305  &256*a1*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1)-
44306  &128*a1*a2*mt**2*p1q1*p2q2/(3*p1q2*p2q1)-
44307  &512*a1*a2*p1p2*p1q1*p2q2/(p1q2*p2q1)-
44308  &512*a1*a2*p1q1**2*p2q2/(3*p1q2*p2q1)-544*a1*a2*p1q2*p2q2/(3*p2q1)-
44309  &640*a2**2*p1q2*p2q2/(3*p2q1)+
44310  &64*a1*a2*p1p2*p1q2*p2q2/(3*p1q1*p2q1)+544*a1*a2*p2q2**2/(3*p2q1)-
44311  &256*a1*mt**2*p2q2**2/(3*p1q2**2*p2q1)-
44312  &272*a1*p2q2**2/(3*p1q2*p2q1)+
44313  &256*a1*a2*mb*mt*p2q2**2/(3*p1q2*p2q1)+
44314  &256*a1*a2*mt**2*p2q2**2/(3*p1q2*p2q1)+
44315  &512*a1*a2*p1p2*p2q2**2/(3*p1q2*p2q1)
44316  v18=v18+512*a1*a2*p1q1*p2q2**2/(3*p1q2*p2q1)+
44317  &384*a12*mb*mt*p1q1**2/s**2+
44318  &384*a12*p1p2*p1q1**2/s**2+2688*a12*mb*mt*p1q1*p1q2/s**2+
44319  &2688*a12*p1p2*p1q1*p1q2/s**2+384*a12*mb*mt*p1q2**2/s**2+
44320  &384*a12*p1p2*p1q2**2/s**2+768*a1*a2*mb*mt*p1q1*p2q1/s**2+
44321  &768*a1*a2*p1p2*p1q1*p2q1/s**2+2688*a1*a2*mb*mt*p1q2*p2q1/s**2+
44322  &2688*a1*a2*p1p2*p1q2*p2q1/s**2-960*a12*p1q1*p1q2*p2q1/s**2-
44323  &960*a1*a2*p1q1*p1q2*p2q1/s**2+960*a12*p1q2**2*p2q1/s**2+
44324  &960*a1*a2*p1q2**2*p2q1/s**2+384*a2**2*mb*mt*p2q1**2/s**2+
44325  &384*a2**2*p1p2*p2q1**2/s**2-960*a1*a2*p1q2*p2q1**2/s**2-
44326  &960*a2**2*p1q2*p2q1**2/s**2+2688*a1*a2*mb*mt*p1q1*p2q2/s**2+
44327  &2688*a1*a2*p1p2*p1q1*p2q2/s**2+960*a12*p1q1**2*p2q2/s**2+
44328  &960*a1*a2*p1q1**2*p2q2/s**2+768*a1*a2*mb*mt*p1q2*p2q2/s**2+
44329  &768*a1*a2*p1p2*p1q2*p2q2/s**2-960*a12*p1q1*p1q2*p2q2/s**2-
44330  &960*a1*a2*p1q1*p1q2*p2q2/s**2+2688*a2**2*mb*mt*p2q1*p2q2/s**2+
44331  &2688*a2**2*p1p2*p2q1*p2q2/s**2+960*a1*a2*p1q1*p2q1*p2q2/s**2+
44332  &960*a2**2*p1q1*p2q1*p2q2/s**2+960*a1*a2*p1q2*p2q1*p2q2/s**2+
44333  &960*a2**2*p1q2*p2q1*p2q2/s**2+384*a2**2*mb*mt*p2q2**2/s**2
44334  v18=v18+384*a2**2*p1p2*p2q2**2/s**2-960*a1*a2*p1q1*p2q2**2/s**2-
44335  &960*a2**2*p1q1*p2q2**2/s**2+96*a1*mb*mt/s+96*a2*mb*mt/s-
44336  &768*a2**2*mb**3*mt/s-768*a12*mb*mt**3/s-192*a1*p1p2/s-
44337  &192*a2*p1p2/s-768*a2**2*mb**2*p1p2/s-2304*a1*a2*mb*mt*p1p2/s-
44338  &768*a12*mt**2*p1p2/s-2304*a1*a2*p1p2**2/s-
44339  &96*a1*mb*mt**3/(p1q1*s)-192*a2*mb*mt*p1p2/(p1q1*s)-
44340  &96*a1*mt**2*p1p2/(p1q1*s)-192*a2*p1p2**2/(p1q1*s)-192*a1*p1q1/s-
44341  &144*a2*p1q1/s-384*a1*a2*mb**2*p1q1/s-480*a2**2*mb**2*p1q1/s-
44342  &480*a12*mb*mt*p1q1/s+96*a1*a2*mb*mt*p1q1/s-
44343  &864*a12*p1p2*p1q1/s-672*a1*a2*p1p2*p1q1/s-96*a1*a2*p1q1**2/s-
44344  &96*a1*mb*mt**3/(p1q2*s)-192*a2*mb*mt*p1p2/(p1q2*s)-
44345  &96*a1*mt**2*p1p2/(p1q2*s)-192*a2*p1p2**2/(p1q2*s)-
44346  &48*a1*mb*mt*p1q1/(p1q2*s)+96*a2*mb*mt*p1q1/(p1q2*s)-
44347  &48*a1*mt**2*p1q1/(p1q2*s)-192*a1*p1p2*p1q1/(p1q2*s)-
44348  &192*a2*p1p2*p1q1/(p1q2*s)+192*a1*a2*mb*mt*p1p2*p1q1/(p1q2*s)+
44349  &192*a1*a2*p1p2**2*p1q1/(p1q2*s)-192*a1*p1q1**2/(p1q2*s)-
44350  &192*a2*p1q1**2/(p1q2*s)+192*a1*a2*mb**2*p1q1**2/(p1q2*s)
44351  v18=v18-192*a12*mb*mt*p1q1**2/(p1q2*s)+
44352  &96*a1*a2*mb*mt*p1q1**2/(p1q2*s)+
44353  &192*a1*a2*p1p2*p1q1**2/(p1q2*s)-192*a1*p1q2/s-144*a2*p1q2/s-
44354  &384*a1*a2*mb**2*p1q2/s-480*a2**2*mb**2*p1q2/s-
44355  &480*a12*mb*mt*p1q2/s+96*a1*a2*mb*mt*p1q2/s-
44356  &864*a12*p1p2*p1q2/s-672*a1*a2*p1p2*p1q2/s-
44357  &48*a1*mb*mt*p1q2/(p1q1*s)+96*a2*mb*mt*p1q2/(p1q1*s)-
44358  &48*a1*mt**2*p1q2/(p1q1*s)-192*a1*p1p2*p1q2/(p1q1*s)-
44359  &192*a2*p1p2*p1q2/(p1q1*s)+192*a1*a2*mb*mt*p1p2*p1q2/(p1q1*s)+
44360  &192*a1*a2*p1p2**2*p1q2/(p1q1*s)-576*a1*a2*p1q1*p1q2/s-
44361  &96*a1*a2*p1q2**2/s-192*a1*p1q2**2/(p1q1*s)-
44362  &192*a2*p1q2**2/(p1q1*s)+192*a1*a2*mb**2*p1q2**2/(p1q1*s)-
44363  &192*a12*mb*mt*p1q2**2/(p1q1*s)+96*a1*a2*mb*mt*p1q2**2/(p1q1*s)+
44364  &192*a1*a2*p1p2*p1q2**2/(p1q1*s)+96*a2*mb**3*mt/(p2q1*s)+
44365  &96*a2*mb**2*p1p2/(p2q1*s)+192*a1*mb*mt*p1p2/(p2q1*s)+
44366  &192*a1*p1p2**2/(p2q1*s)+96*a1*mb**2*p1q1/(p2q1*s)+
44367  &192*a2*mb**2*p1q1/(p2q1*s)+96*a1*mb*mt*p1q1/(p2q1*s)+
44368  &192*a1*a2*mb**3*mt*p1q1/(p2q1*s)+192*a1*p1p2*p1q1/(p2q1*s)
44369  v18=v18+192*a1*a2*mb**2*p1p2*p1q1/(p2q1*s)+
44370  &96*a1*a2*mb**2*p1q1**2/(p2q1*s)+
44371  &192*a2*mb**3*mt*p1q1/(p1q2*p2q1*s)+
44372  &192*a2*mb**2*p1p2*p1q1/(p1q2*p2q1*s)+
44373  &96*a1*mb*mt*p1p2*p1q1/(p1q2*p2q1*s)+
44374  &96*a1*p1p2**2*p1q1/(p1q2*p2q1*s)+
44375  &96*a1*mb**2*p1q1**2/(p1q2*p2q1*s)+
44376  &192*a2*mb**2*p1q1**2/(p1q2*p2q1*s)+
44377  &48*a1*mb*mt*p1q1**2/(p1q2*p2q1*s)+
44378  &96*a1*p1p2*p1q1**2/(p1q2*p2q1*s)+96*a1*mb**2*p1q2/(p2q1*s)+
44379  &48*a2*mb**2*p1q2/(p2q1*s)-192*a1*a2*mb**3*mt*p1q2/(p2q1*s)-
44380  &192*a1*a2*mb**2*p1p2*p1q2/(p2q1*s)-
44381  &96*a1*a2*mb**2*p1q2**2/(p2q1*s)+144*a1*p2q1/s+192*a2*p2q1/s-
44382  &96*a1*a2*mb*mt*p2q1/s+480*a2**2*mb*mt*p2q1/s+
44383  &480*a12*mt**2*p2q1/s+384*a1*a2*mt**2*p2q1/s+
44384  &672*a1*a2*p1p2*p2q1/s+864*a2**2*p1p2*p2q1/s+
44385  &96*a2*mb*mt*p2q1/(p1q1*s)+192*a1*mt**2*p2q1/(p1q1*s)
44386  v18=v18+96*a2*mt**2*p2q1/(p1q1*s)+
44387  &192*a1*a2*mb*mt**3*p2q1/(p1q1*s)+
44388  &192*a2*p1p2*p2q1/(p1q1*s)+192*a1*a2*mt**2*p1p2*p2q1/(p1q1*s)-
44389  &192*a12*p1q1*p2q1/s-192*a2**2*p1q1*p2q1/s+
44390  &48*a1*mt**2*p2q1/(p1q2*s)+96*a2*mt**2*p2q1/(p1q2*s)-
44391  &192*a1*a2*mb*mt**3*p2q1/(p1q2*s)-
44392  &192*a1*a2*mt**2*p1p2*p2q1/(p1q2*s)-
44393  &96*a1*a2*mb*mt*p1q1*p2q1/(p1q2*s)-
44394  &192*a12*mt**2*p1q1*p2q1/(p1q2*s)-
44395  &96*a1*a2*mt**2*p1q1*p2q1/(p1q2*s)-
44396  &384*a1*a2*p1p2*p1q1*p2q1/(p1q2*s)-384*a12*p1q1**2*p2q1/(p1q2*s)-
44397  &384*a1*a2*p1q1**2*p2q1/(p1q2*s)-480*a12*p1q2*p2q1/s-
44398  &960*a1*a2*p1q2*p2q1/s-480*a2**2*p1q2*p2q1/s+
44399  &144*a1*p1q2*p2q1/(p1q1*s)+96*a2*p1q2*p2q1/(p1q1*s)-
44400  &384*a1*a2*mb*mt*p1q2*p2q1/(p1q1*s)-
44401  &96*a12*mt**2*p1q2*p2q1/(p1q1*s)+
44402  &96*a1*a2*mt**2*p1q2*p2q1/(p1q1*s)-
44403  &576*a1*a2*p1p2*p1q2*p2q1/(p1q1*s)-192*a12*p1q2**2*p2q1/(p1q1*s)
44404  v18=v18-384*a1*a2*p1q2**2*p2q1/(p1q1*s)-96*a1*a2*p2q1**2/s-
44405  &96*a1*a2*mt**2*p2q1**2/(p1q1*s)+96*a1*a2*mt**2*p2q1**2/(p1q2*s)+
44406  &288*a1*a2*p1q2*p2q1**2/(p1q1*s)+96*a2*mb**3*mt/(p2q2*s)+
44407  &96*a2*mb**2*p1p2/(p2q2*s)+192*a1*mb*mt*p1p2/(p2q2*s)+
44408  &192*a1*p1p2**2/(p2q2*s)+96*a1*mb**2*p1q1/(p2q2*s)+
44409  &48*a2*mb**2*p1q1/(p2q2*s)-192*a1*a2*mb**3*mt*p1q1/(p2q2*s)-
44410  &192*a1*a2*mb**2*p1p2*p1q1/(p2q2*s)-
44411  &96*a1*a2*mb**2*p1q1**2/(p2q2*s)+96*a1*mb**2*p1q2/(p2q2*s)+
44412  &192*a2*mb**2*p1q2/(p2q2*s)+96*a1*mb*mt*p1q2/(p2q2*s)+
44413  &192*a1*a2*mb**3*mt*p1q2/(p2q2*s)+192*a1*p1p2*p1q2/(p2q2*s)+
44414  &192*a1*a2*mb**2*p1p2*p1q2/(p2q2*s)+
44415  &192*a2*mb**3*mt*p1q2/(p1q1*p2q2*s)+
44416  &192*a2*mb**2*p1p2*p1q2/(p1q1*p2q2*s)+
44417  &96*a1*mb*mt*p1p2*p1q2/(p1q1*p2q2*s)+
44418  &96*a1*p1p2**2*p1q2/(p1q1*p2q2*s)+96*a1*a2*mb**2*p1q2**2/(p2q2*s)+
44419  &96*a1*mb**2*p1q2**2/(p1q1*p2q2*s)+
44420  &192*a2*mb**2*p1q2**2/(p1q1*p2q2*s)
44421  v18=v18+48*a1*mb*mt*p1q2**2/(p1q1*p2q2*s)+
44422  &96*a1*p1p2*p1q2**2/(p1q1*p2q2*s)-48*a2*mb**2*p2q1/(p2q2*s)+
44423  &96*a1*mb*mt*p2q1/(p2q2*s)-48*a2*mb*mt*p2q1/(p2q2*s)-
44424  &192*a1*p1p2*p2q1/(p2q2*s)-192*a2*p1p2*p2q1/(p2q2*s)+
44425  &192*a1*a2*mb*mt*p1p2*p2q1/(p2q2*s)+
44426  &192*a1*a2*p1p2**2*p2q1/(p2q2*s)-
44427  &192*a1*mb*mt**3*p2q1/(p1q1*p2q2*s)-
44428  &96*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2*s)-
44429  &192*a1*mt**2*p1p2*p2q1/(p1q1*p2q2*s)-
44430  &96*a2*p1p2**2*p2q1/(p1q1*p2q2*s)+
44431  &96*a1*a2*mb**2*p1q1*p2q1/(p2q2*s)+
44432  &192*a2**2*mb**2*p1q1*p2q1/(p2q2*s)+
44433  &96*a1*a2*mb*mt*p1q1*p2q1/(p2q2*s)+
44434  &384*a1*a2*p1p2*p1q1*p2q1/(p2q2*s)-96*a1*p1q2*p2q1/(p2q2*s)-
44435  &144*a2*p1q2*p2q1/(p2q2*s)-96*a1*a2*mb**2*p1q2*p2q1/(p2q2*s)+
44436  &96*a2**2*mb**2*p1q2*p2q1/(p2q2*s)+
44437  &384*a1*a2*mb*mt*p1q2*p2q1/(p2q2*s)
44438  v18=v18+576*a1*a2*p1p2*p1q2*p2q1/(p2q2*s)-
44439  &96*a2*mb**2*p1q2*p2q1/(p1q1*p2q2*s)+
44440  &48*a1*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)+
44441  &48*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
44442  &96*a1*mt**2*p1q2*p2q1/(p1q1*p2q2*s)-
44443  &96*a1*p1p2*p1q2*p2q1/(p1q1*p2q2*s)-
44444  &96*a2*p1p2*p1q2*p2q1/(p1q1*p2q2*s)+
44445  &96*a1*a2*p1q1*p1q2*p2q1/(p2q2*s)+288*a1*a2*p1q2**2*p2q1/(p2q2*s)-
44446  &96*a1*p1q2**2*p2q1/(p1q1*p2q2*s)-96*a2*p1q2**2*p2q1/(p1q1*p2q2*s)+
44447  &192*a1*p2q1**2/(p2q2*s)+192*a2*p2q1**2/(p2q2*s)-
44448  &96*a1*a2*mb*mt*p2q1**2/(p2q2*s)+192*a2**2*mb*mt*p2q1**2/(p2q2*s)-
44449  &192*a1*a2*mt**2*p2q1**2/(p2q2*s)-192*a1*a2*p1p2*p2q1**2/(p2q2*s)+
44450  &48*a2*mb*mt*p2q1**2/(p1q1*p2q2*s)+
44451  &192*a1*mt**2*p2q1**2/(p1q1*p2q2*s)+
44452  &96*a2*mt**2*p2q1**2/(p1q1*p2q2*s)+
44453  &96*a2*p1p2*p2q1**2/(p1q1*p2q2*s)-384*a1*a2*p1q1*p2q1**2/(p2q2*s)-
44454  &384*a2**2*p1q1*p2q1**2/(p2q2*s)-384*a1*a2*p1q2*p2q1**2/(p2q2*s)
44455  v18=v18-192*a2**2*p1q2*p2q1**2/(p2q2*s)+
44456  &96*a1*p1q2*p2q1**2/(p1q1*p2q2*s)+
44457  &96*a2*p1q2*p2q1**2/(p1q1*p2q2*s)+144*a1*p2q2/s+192*a2*p2q2/s-
44458  &96*a1*a2*mb*mt*p2q2/s+480*a2**2*mb*mt*p2q2/s+
44459  &480*a12*mt**2*p2q2/s+384*a1*a2*mt**2*p2q2/s+
44460  &672*a1*a2*p1p2*p2q2/s+864*a2**2*p1p2*p2q2/s+
44461  &48*a1*mt**2*p2q2/(p1q1*s)+96*a2*mt**2*p2q2/(p1q1*s)-
44462  &192*a1*a2*mb*mt**3*p2q2/(p1q1*s)-
44463  &192*a1*a2*mt**2*p1p2*p2q2/(p1q1*s)-480*a12*p1q1*p2q2/s-
44464  &960*a1*a2*p1q1*p2q2/s-480*a2**2*p1q1*p2q2/s+
44465  &96*a2*mb*mt*p2q2/(p1q2*s)+192*a1*mt**2*p2q2/(p1q2*s)+
44466  &96*a2*mt**2*p2q2/(p1q2*s)+192*a1*a2*mb*mt**3*p2q2/(p1q2*s)+
44467  &192*a2*p1p2*p2q2/(p1q2*s)+192*a1*a2*mt**2*p1p2*p2q2/(p1q2*s)+
44468  &144*a1*p1q1*p2q2/(p1q2*s)+96*a2*p1q1*p2q2/(p1q2*s)-
44469  &384*a1*a2*mb*mt*p1q1*p2q2/(p1q2*s)-
44470  &96*a12*mt**2*p1q1*p2q2/(p1q2*s)+
44471  &96*a1*a2*mt**2*p1q1*p2q2/(p1q2*s)
44472  v18=v18-576*a1*a2*p1p2*p1q1*p2q2/(p1q2*s)-
44473  &192*a12*p1q1**2*p2q2/(p1q2*s)-
44474  &384*a1*a2*p1q1**2*p2q2/(p1q2*s)-192*a12*p1q2*p2q2/s-
44475  &192*a2**2*p1q2*p2q2/s-96*a1*a2*mb*mt*p1q2*p2q2/(p1q1*s)-
44476  &192*a12*mt**2*p1q2*p2q2/(p1q1*s)-
44477  &96*a1*a2*mt**2*p1q2*p2q2/(p1q1*s)-
44478  &384*a1*a2*p1p2*p1q2*p2q2/(p1q1*s)-384*a12*p1q2**2*p2q2/(p1q1*s)-
44479  &384*a1*a2*p1q2**2*p2q2/(p1q1*s)-48*a2*mb**2*p2q2/(p2q1*s)+
44480  &96*a1*mb*mt*p2q2/(p2q1*s)-48*a2*mb*mt*p2q2/(p2q1*s)-
44481  &192*a1*p1p2*p2q2/(p2q1*s)-192*a2*p1p2*p2q2/(p2q1*s)+
44482  &192*a1*a2*mb*mt*p1p2*p2q2/(p2q1*s)+
44483  &192*a1*a2*p1p2**2*p2q2/(p2q1*s)-96*a1*p1q1*p2q2/(p2q1*s)-
44484  &144*a2*p1q1*p2q2/(p2q1*s)-96*a1*a2*mb**2*p1q1*p2q2/(p2q1*s)+
44485  &96*a2**2*mb**2*p1q1*p2q2/(p2q1*s)+
44486  &384*a1*a2*mb*mt*p1q1*p2q2/(p2q1*s)+
44487  &576*a1*a2*p1p2*p1q1*p2q2/(p2q1*s)+288*a1*a2*p1q1**2*p2q2/(p2q1*s)-
44488  &192*a1*mb*mt**3*p2q2/(p1q2*p2q1*s)
44489  v18=v18-96*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1*s)-
44490  &192*a1*mt**2*p1p2*p2q2/(p1q2*p2q1*s)-
44491  &96*a2*p1p2**2*p2q2/(p1q2*p2q1*s)-
44492  &96*a2*mb**2*p1q1*p2q2/(p1q2*p2q1*s)+
44493  &48*a1*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)
44494 
44495  v18bis=
44496  &48*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
44497  &96*a1*mt**2*p1q1*p2q2/(p1q2*p2q1*s)-
44498  &96*a1*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
44499  &96*a2*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
44500  &96*a1*p1q1**2*p2q2/(p1q2*p2q1*s)-96*a2*p1q1**2*p2q2/(p1q2*p2q1*s)+
44501  &96*a1*a2*mb**2*p1q2*p2q2/(p2q1*s)+
44502  &192*a2**2*mb**2*p1q2*p2q2/(p2q1*s)+
44503  &96*a1*a2*mb*mt*p1q2*p2q2/(p2q1*s)+
44504  &384*a1*a2*p1p2*p1q2*p2q2/(p2q1*s)+
44505  &96*a1*a2*p1q1*p1q2*p2q2/(p2q1*s)-576*a1*a2*p2q1*p2q2/s+
44506  &96*a1*a2*p1q1*p2q1*p2q2/(p1q2*s)+96*a1*a2*p1q2*p2q1*p2q2/(p1q1*s)-
44507  &96*a1*a2*p2q2**2/s+96*a1*a2*mt**2*p2q2**2/(p1q1*s)-
44508  &96*a1*a2*mt**2*p2q2**2/(p1q2*s)+288*a1*a2*p1q1*p2q2**2/(p1q2*s)+
44509  &192*a1*p2q2**2/(p2q1*s)+192*a2*p2q2**2/(p2q1*s)-
44510  &96*a1*a2*mb*mt*p2q2**2/(p2q1*s)+192*a2**2*mb*mt*p2q2**2/(p2q1*s)-
44511  &192*a1*a2*mt**2*p2q2**2/(p2q1*s)-192*a1*a2*p1p2*p2q2**2/(p2q1*s)
44512  v18bis=v18bis-384*a1*a2*p1q1*p2q2**2/(p2q1*s)-
44513  &192*a2**2*p1q1*p2q2**2/(p2q1*s)+
44514  &48*a2*mb*mt*p2q2**2/(p1q2*p2q1*s)+
44515  &192*a1*mt**2*p2q2**2/(p1q2*p2q1*s)+
44516  &96*a2*mt**2*p2q2**2/(p1q2*p2q1*s)+
44517  &96*a2*p1p2*p2q2**2/(p1q2*p2q1*s)+96*a1*p1q1*p2q2**2/(p1q2*p2q1*s)+
44518  &96*a2*p1q1*p2q2**2/(p1q2*p2q1*s)-384*a1*a2*p1q2*p2q2**2/(p2q1*s)-
44519  &384*a2**2*p1q2*p2q2**2/(p2q1*s)+512*a1*a2*s/3-
44520  &128*a1*mt**2*s/(3*p1q1**2)-128*a12*mb*mt**3*s/(3*p1q1**2)-
44521  &152*a1*s/(3*p1q1)+152*a12*mb*mt*s/(3*p1q1)+
44522  &128*a1*a2*mb*mt*s/(3*p1q1)+112*a1*a2*mt**2*s/(3*p1q1)-
44523  &16*a12*p1p2*s/p1q1+152*a1*a2*p1p2*s/(3*p1q1)-
44524  &128*a1*mt**2*s/(3*p1q2**2)-128*a12*mb*mt**3*s/(3*p1q2**2)-
44525  &152*a1*s/(3*p1q2)+152*a12*mb*mt*s/(3*p1q2)+
44526  &128*a1*a2*mb*mt*s/(3*p1q2)+112*a1*a2*mt**2*s/(3*p1q2)-
44527  &16*a12*p1p2*s/p1q2+152*a1*a2*p1p2*s/(3*p1q2)-
44528  &16*a1*mb*mt*s/(3*p1q1*p1q2)+32*a12*mb*mt**3*s/(3*p1q1*p1q2)
44529  v18bis=v18bis-16*a1*p1p2*s/(3*p1q1*p1q2)+
44530  &272*a1*a2*p1q1*s/(3*p1q2)+
44531  &272*a1*a2*p1q2*s/(3*p1q1)-128*a2*mb**2*s/(3*p2q1**2)-
44532  &128*a2**2*mb**3*mt*s/(3*p2q1**2)+
44533  &32*mb**2*mt**2*s/(3*p1q2**2*p2q1**2)+32*mb**2*s/(3*p1q2*p2q1**2)-
44534  &64*a2*mb**3*mt*s/(3*p1q2*p2q1**2)-
44535  &64*a2*mb**2*mt**2*s/(3*p1q2*p2q1**2)-
44536  &128*a2*mb**2*p1p2*s/(3*p1q2*p2q1**2)-
44537  &128*a2*mb**2*p1q1*s/(3*p1q2*p2q1**2)+
44538  &128*a2**2*mb**2*p1q2*s/(3*p2q1**2)+152*a2*s/(3*p2q1)-
44539  &112*a1*a2*mb**2*s/(3*p2q1)-128*a1*a2*mb*mt*s/(3*p2q1)-
44540  &152*a2**2*mb*mt*s/(3*p2q1)-152*a1*a2*p1p2*s/(3*p2q1)+
44541  &16*a2**2*p1p2*s/p2q1+8*a1*a2*mb**3*mt*s/(3*p1q1*p2q1)+
44542  &16*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q1)+
44543  &8*a1*a2*mb*mt**3*s/(3*p1q1*p2q1)-8*a1*p1p2*s/(3*p1q1*p2q1)-
44544  &8*a2*p1p2*s/(3*p1q1*p2q1)+8*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q1)+
44545  &16*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q1)
44546  v18bis=v18bis+8*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q1)+
44547  &32*a1*a2*p1p2**2*s/(3*p1q1*p2q1)-32*a2**2*p1q1*s/(3*p2q1)-
44548  &32*mt**2*s/(3*p1q2**2*p2q1)+64*a1*mb**2*mt**2*s/(3*p1q2**2*p2q1)+
44549  &64*a1*mb*mt**3*s/(3*p1q2**2*p2q1)+
44550  &128*a1*mt**2*p1p2*s/(3*p1q2**2*p2q1)-12*s/(p1q2*p2q1)+
44551  &24*a1*mb**2*s/(p1q2*p2q1)-64*a1*a2*mb**3*mt*s/(3*p1q2*p2q1)+
44552  &24*a2*mt**2*s/(p1q2*p2q1)-128*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q1)-
44553  &64*a1*a2*mb*mt**3*s/(3*p1q2*p2q1)+56*a1*p1p2*s/(3*p1q2*p2q1)+
44554  &56*a2*p1p2*s/(3*p1q2*p2q1)-64*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q1)-
44555  &128*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q1)-
44556  &64*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q1)-
44557  &256*a1*a2*p1p2**2*s/(3*p1q2*p2q1)+4*p1p2*s/(3*p1q1*p1q2*p2q1)+
44558  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1)-
44559  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1)+136*a2*p1q1*s/(3*p1q2*p2q1)-
44560  &128*a1*a2*mb**2*p1q1*s/(3*p1q2*p2q1)-
44561  &128*a1*a2*mb*mt*p1q1*s/(3*p1q2*p2q1)-
44562  &256*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q1)-160*a2**2*p1q2*s/(3*p2q1)
44563  v18bis=v18bis+16*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q1)-
44564  &32*a12*p2q1*s/(3*p1q1)-
44565  &128*a12*mt**2*p2q1*s/(3*p1q2**2)-160*a12*p2q1*s/(3*p1q2)-
44566  &128*a2*mb**2*s/(3*p2q2**2)-128*a2**2*mb**3*mt*s/(3*p2q2**2)+
44567  &32*mb**2*mt**2*s/(3*p1q1**2*p2q2**2)+32*mb**2*s/(3*p1q1*p2q2**2)-
44568  &64*a2*mb**3*mt*s/(3*p1q1*p2q2**2)-
44569  &64*a2*mb**2*mt**2*s/(3*p1q1*p2q2**2)-
44570  &128*a2*mb**2*p1p2*s/(3*p1q1*p2q2**2)+
44571  &128*a2**2*mb**2*p1q1*s/(3*p2q2**2)-
44572  &128*a2*mb**2*p1q2*s/(3*p1q1*p2q2**2)+152*a2*s/(3*p2q2)-
44573  &112*a1*a2*mb**2*s/(3*p2q2)-128*a1*a2*mb*mt*s/(3*p2q2)-
44574  &152*a2**2*mb*mt*s/(3*p2q2)-152*a1*a2*p1p2*s/(3*p2q2)+
44575  &16*a2**2*p1p2*s/p2q2-32*mt**2*s/(3*p1q1**2*p2q2)+
44576  &64*a1*mb**2*mt**2*s/(3*p1q1**2*p2q2)+
44577  &64*a1*mb*mt**3*s/(3*p1q1**2*p2q2)+
44578  &128*a1*mt**2*p1p2*s/(3*p1q1**2*p2q2)-12*s/(p1q1*p2q2)+
44579  &24*a1*mb**2*s/(p1q1*p2q2)-64*a1*a2*mb**3*mt*s/(3*p1q1*p2q2)
44580  v18bis=v18bis+24*a2*mt**2*s/(p1q1*p2q2)-
44581  &128*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q2)-
44582  &64*a1*a2*mb*mt**3*s/(3*p1q1*p2q2)+56*a1*p1p2*s/(3*p1q1*p2q2)+
44583  &56*a2*p1p2*s/(3*p1q1*p2q2)-64*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q2)-
44584  &128*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q2)-
44585  &64*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q2)-
44586  &256*a1*a2*p1p2**2*s/(3*p1q1*p2q2)-160*a2**2*p1q1*s/(3*p2q2)+
44587  &8*a1*a2*mb**3*mt*s/(3*p1q2*p2q2)+
44588  &16*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q2)+
44589  &8*a1*a2*mb*mt**3*s/(3*p1q2*p2q2)-8*a1*p1p2*s/(3*p1q2*p2q2)-
44590  &8*a2*p1p2*s/(3*p1q2*p2q2)+8*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q2)+
44591  &16*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q2)+
44592  &8*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q2)+
44593  &32*a1*a2*p1p2**2*s/(3*p1q2*p2q2)+4*p1p2*s/(3*p1q1*p1q2*p2q2)+
44594  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q2)-
44595  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q2)+
44596  &16*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q2)-32*a2**2*p1q2*s/(3*p2q2)
44597  v18bis=v18bis+136*a2*p1q2*s/(3*p1q1*p2q2)-
44598  &128*a1*a2*mb**2*p1q2*s/(3*p1q1*p2q2)-
44599  &128*a1*a2*mb*mt*p1q2*s/(3*p1q1*p2q2)-
44600  &256*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q2)-16*a2*mb*mt*s/(3*p2q1*p2q2)+
44601  &32*a2**2*mb**3*mt*s/(3*p2q1*p2q2)-16*a2*p1p2*s/(3*p2q1*p2q2)-
44602  &4*p1p2*s/(3*p1q1*p2q1*p2q2)+8*a2*mb**2*p1p2*s/(3*p1q1*p2q1*p2q2)-
44603  &8*a2*mb*mt*p1p2*s/(3*p1q1*p2q1*p2q2)-4*p1p2*s/(3*p1q2*p2q1*p2q2)+
44604  &8*a2*mb**2*p1p2*s/(3*p1q2*p2q1*p2q2)-
44605  &8*a2*mb*mt*p1p2*s/(3*p1q2*p2q1*p2q2)+
44606  &2*mb**3*mt*s/(3*p1q1*p1q2*p2q1*p2q2)+
44607  &4*mb**2*mt**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
44608  &2*mb*mt**3*s/(3*p1q1*p1q2*p2q1*p2q2)-
44609  &2*mb**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44610  &4*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44611  &2*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44612  &8*p1p2**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
44613  &8*a2*p1p2*p1q1*s/(3*p1q2*p2q1*p2q2)
44614  v18bis=v18bis+8*a2*p1p2*p1q2*s/(3*p1q1*p2q1*p2q2)+
44615  &272*a1*a2*p2q1*s/(3*p2q2)-
44616  &128*a1*mt**2*p2q1*s/(3*p1q1**2*p2q2)-136*a1*p2q1*s/(3*p1q1*p2q2)+
44617  &128*a1*a2*mb*mt*p2q1*s/(3*p1q1*p2q2)+
44618  &128*a1*a2*mt**2*p2q1*s/(3*p1q1*p2q2)+
44619  &256*a1*a2*p1p2*p2q1*s/(3*p1q1*p2q2)-
44620  &16*a1*a2*p1p2*p2q1*s/(3*p1q2*p2q2)+
44621  &8*a1*p1p2*p2q1*s/(3*p1q1*p1q2*p2q2)+
44622  &256*a1*a2*p1q2*p2q1*s/(3*p1q1*p2q2)-
44623  &128*a12*mt**2*p2q2*s/(3*p1q1**2)-160*a12*p2q2*s/(3*p1q1)-
44624  &32*a12*p2q2*s/(3*p1q2)+272*a1*a2*p2q2*s/(3*p2q1)-
44625  &16*a1*a2*p1p2*p2q2*s/(3*p1q1*p2q1)-
44626  &128*a1*mt**2*p2q2*s/(3*p1q2**2*p2q1)-136*a1*p2q2*s/(3*p1q2*p2q1)+
44627  &128*a1*a2*mb*mt*p2q2*s/(3*p1q2*p2q1)+
44628  &128*a1*a2*mt**2*p2q2*s/(3*p1q2*p2q1)+
44629  &256*a1*a2*p1p2*p2q2*s/(3*p1q2*p2q1)+
44630  &8*a1*p1p2*p2q2*s/(3*p1q1*p1q2*p2q1)
44631  v18bis=v18bis+256*a1*a2*p1q1*p2q2*s/(3*p1q2*p2q1)+
44632  &8*a12*mb*mt*s**2/(3*p1q1*p1q2)+16*a12*p1p2*s**2/(3*p1q1*p1q2)-
44633  &8*a1*a2*p1p2*s**2/(3*p1q1*p2q1)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q1)-
44634  &8*a1*a2*p1p2*s**2/(3*p1q2*p2q2)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q2)+
44635  &8*a2**2*mb*mt*s**2/(3*p2q1*p2q2)+16*a2**2*p1p2*s**2/(3*p2q1*p2q2)-
44636  &4*a2*p1p2*s**2/(3*p1q1*p2q1*p2q2)-
44637  &4*a2*p1p2*s**2/(3*p1q2*p2q1*p2q2)+
44638  &2*p1p2*s**2/(3*p1q1*p1q2*p2q1*p2q2)
44639 C
44640 
44641  a18 = 640*a1/3+640*a2/3+32*a1*a2*mb**2+368*a12*mb*mt+
44642  &512*a1*a2*mb*mt/3+
44643  &368*a2**2*mb*mt+32*a1*a2*mt**2+496*a12*p1p2/3+
44644  &320*a1*a2*p1p2+496*a2**2*p1p2/3-128*a1*mb*mt**3/(3*p1q1**2)+
44645  &128*a1*mt**4/(3*p1q1**2)+256*a12*mb*mt**5/(3*p1q1**2)+
44646  &256*a1*mt**2*p1p2/(3*p1q1**2)-256*a12*mt**4*p1p2/(3*p1q1**2)+
44647  &8/(3*p1q1)+32*a1*mb*mt/p1q1+56*a2*mb*mt/(3*p1q1)+
44648  &88*a1*mt**2/(3*p1q1)+72*a2*mt**2/p1q1-
44649  &704*a12*mb*mt**3/(3*p1q1)+224*a1*a2*mb*mt**3/(3*p1q1)+
44650  &104*a1*p1p2/(3*p1q1)+48*a2*p1p2/p1q1-
44651  &128*a1*a2*mb*mt*p1p2/(3*p1q1)+512*a12*mt**2*p1p2/(3*p1q1)-
44652  &448*a1*a2*mt**2*p1p2/(3*p1q1)-32*a1*a2*p1p2**2/p1q1-
44653  &656*a1*a2*p1q1/3-224*a2**2*p1q1-128*a1*mb*mt**3/(3*p1q2**2)+
44654  &128*a1*mt**4/(3*p1q2**2)+256*a12*mb*mt**5/(3*p1q2**2)+
44655  &256*a1*mt**2*p1p2/(3*p1q2**2)-256*a12*mt**4*p1p2/(3*p1q2**2)+
44656  &256*a1*mt**2*p1q1/(3*p1q2**2)-256*a12*mb*mt**3*p1q1/(3*p1q2**2)+
44657  &8/(3*p1q2)+32*a1*mb*mt/p1q2+56*a2*mb*mt/(3*p1q2)
44658  a18=a18+88*a1*mt**2/(3*p1q2)+72*a2*mt**2/p1q2-
44659  &704*a12*mb*mt**3/(3*p1q2)+224*a1*a2*mb*mt**3/(3*p1q2)+
44660  &104*a1*p1p2/(3*p1q2)+48*a2*p1p2/p1q2-
44661  &128*a1*a2*mb*mt*p1p2/(3*p1q2)+512*a12*mt**2*p1p2/(3*p1q2)-
44662  &448*a1*a2*mt**2*p1p2/(3*p1q2)-32*a1*a2*p1p2**2/p1q2+
44663  &32*a1*mb*mt**3/(3*p1q1*p1q2)-32*a1*mt**4/(3*p1q1*p1q2)-
44664  &64*a12*mb*mt**5/(3*p1q1*p1q2)+16*p1p2/(3*p1q1*p1q2)-
44665  &64*a1*mt**2*p1p2/(3*p1q1*p1q2)+64*a12*mt**4*p1p2/(3*p1q1*p1q2)+
44666  &112*a1*p1q1/p1q2+272*a2*p1q1/(3*p1q2)-
44667  &272*a1*a2*mb**2*p1q1/(3*p1q2)-208*a12*mb*mt*p1q1/(3*p1q2)+
44668  &400*a1*a2*mb*mt*p1q1/(3*p1q2)-80*a1*a2*mt**2*p1q1/p1q2+
44669  &96*a12*p1p2*p1q1/p1q2-320*a1*a2*p1p2*p1q1/p1q2-
44670  &544*a1*a2*p1q1**2/(3*p1q2)-656*a1*a2*p1q2/3-224*a2**2*p1q2+
44671  &256*a1*mt**2*p1q2/(3*p1q1**2)-256*a12*mb*mt**3*p1q2/(3*p1q1**2)+
44672  &112*a1*p1q2/p1q1+272*a2*p1q2/(3*p1q1)-
44673  &272*a1*a2*mb**2*p1q2/(3*p1q1)-208*a12*mb*mt*p1q2/(3*p1q1)+
44674  &400*a1*a2*mb*mt*p1q2/(3*p1q1)-80*a1*a2*mt**2*p1q2/p1q1
44675  a18=a18+96*a12*p1p2*p1q2/p1q1-320*a1*a2*p1p2*p1q2/p1q1-
44676  &544*a1*a2*p1q2**2/(3*p1q1)+128*a2*mb**4/(3*p2q1**2)-
44677  &128*a2*mb**3*mt/(3*p2q1**2)+256*a2**2*mb**5*mt/(3*p2q1**2)+
44678  &256*a2*mb**2*p1p2/(3*p2q1**2)-256*a2**2*mb**4*p1p2/(3*p2q1**2)+
44679  &256*a2*mb**2*p1q1/(3*p2q1**2)-256*a2**2*mb**4*p1q1/(3*p2q1**2)+
44680  &64*mb**3*mt**3/(3*p1q2**2*p2q1**2)-
44681  &64*mb**2*mt**2*p1p2/(3*p1q2**2*p2q1**2)-
44682  &64*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1**2)-
44683  &64*mb**3*mt/(3*p1q2*p2q1**2)-
44684  &256*a2*mb**3*mt*p1p2/(3*p1q2*p2q1**2)+
44685  &256*a2*mb**2*p1p2**2/(3*p1q2*p2q1**2)-
44686  &256*a2*mb**3*mt*p1q1/(3*p1q2*p2q1**2)+
44687  &512*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1**2)+
44688  &256*a2*mb**2*p1q1**2/(3*p1q2*p2q1**2)-
44689  &256*a2**2*mb**4*p1q2/(3*p2q1**2)-8/(3*p2q1)-72*a1*mb**2/p2q1-
44690  &88*a2*mb**2/(3*p2q1)-56*a1*mb*mt/(3*p2q1)-32*a2*mb*mt/p2q1-
44691  &224*a1*a2*mb**3*mt/(3*p2q1)+704*a2**2*mb**3*mt/(3*p2q1)
44692  a18=a18-48*a1*p1p2/p2q1-104*a2*p1p2/(3*p2q1)+
44693  &448*a1*a2*mb**2*p1p2/(3*p2q1)-512*a2**2*mb**2*p1p2/(3*p2q1)+
44694  &128*a1*a2*mb*mt*p1p2/(3*p2q1)+32*a1*a2*p1p2**2/p2q1-
44695  &16*p1p2/(3*p1q1*p2q1)+32*a1*mb*mt*p1p2/(3*p1q1*p2q1)+
44696  &32*a2*mb*mt*p1p2/(3*p1q1*p2q1)+
44697  &64*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q1)-
44698  &64*a1*a2*p1p2**3/(3*p1q1*p2q1)-256*a2*p1q1/(3*p2q1)+
44699  &448*a1*a2*mb**2*p1q1/(3*p2q1)-368*a2**2*mb**2*p1q1/(3*p2q1)-
44700  &224*a1*a2*mb*mt*p1q1/(3*p2q1)+304*a1*a2*p1p2*p1q1/(3*p2q1)+
44701  &64*mb*mt**3/(3*p1q2**2*p2q1)+
44702  &256*a1*mb*mt**3*p1p2/(3*p1q2**2*p2q1)-
44703  &256*a1*mt**2*p1p2**2/(3*p1q2**2*p2q1)+
44704  &64*mt**2*p1q1/(3*p1q2**2*p2q1)-
44705  &128*a1*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1)+
44706  &128*a1*mb*mt**3*p1q1/(3*p1q2**2*p2q1)-
44707  &256*a1*mt**2*p1p2*p1q1/(3*p1q2**2*p2q1)-4*mb**2/(3*p1q2*p2q1)-
44708  &64*mb*mt/(3*p1q2*p2q1)+128*a2*mb**3*mt/(3*p1q2*p2q1)
44709  a18=a18-4*mt**2/(3*p1q2*p2q1)-128*a1*mb**2*mt**2/(3*p1q2*p2q1)-
44710  &128*a2*mb**2*mt**2/(3*p1q2*p2q1)+128*a1*mb*mt**3/(3*p1q2*p2q1)-
44711  &112*a2*mb**2*p1p2/(3*p1q2*p2q1)+32*a1*mb*mt*p1p2/(3*p1q2*p2q1)+
44712  &32*a2*mb*mt*p1p2/(3*p1q2*p2q1)-112*a1*mt**2*p1p2/(3*p1q2*p2q1)-
44713  &48*a1*p1p2**2/(p1q2*p2q1)-48*a2*p1p2**2/(p1q2*p2q1)-
44714  &512*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q1)+
44715  &512*a1*a2*p1p2**3/(3*p1q2*p2q1)+8*mb*mt*p1p2/(3*p1q1*p1q2*p2q1)-
44716  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q1)-
44717  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q1)-
44718  &16*p1p2**2/(3*p1q1*p1q2*p2q1)+
44719  &32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q1)+8*p1q1/(3*p1q2*p2q1)-
44720  &160*a1*mb**2*p1q1/(3*p1q2*p2q1)-272*a2*mb**2*p1q1/(3*p1q2*p2q1)-
44721  &56*a1*mb*mt*p1q1/(3*p1q2*p2q1)-200*a2*mb*mt*p1q1/(3*p1q2*p2q1)-
44722  &48*a1*p1p2*p1q1/(p1q2*p2q1)-256*a2*p1p2*p1q1/(3*p1q2*p2q1)+
44723  &256*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1)-
44724  &256*a1*a2*mb*mt*p1p2*p1q1/(p1q2*p2q1)+
44725  &1024*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q1)
44726  a18=a18-272*a2*p1q1**2/(3*p1q2*p2q1)+
44727  &256*a1*a2*mb**2*p1q1**2/(3*p1q2*p2q1)-
44728  &256*a1*a2*mb*mt*p1q1**2/(3*p1q2*p2q1)+
44729  &512*a1*a2*p1p2*p1q1**2/(3*p1q2*p2q1)+16*a2*p1q2/(3*p2q1)+
44730  &64*a1*a2*mb**2*p1q2/p2q1+32*a2**2*mb**2*p1q2/(3*p2q1)-
44731  &112*a1*a2*mb*mt*p1q2/(3*p2q1)+368*a1*a2*p1p2*p1q2/(3*p2q1)+
44732  &32*a2*p1p2*p1q2/(3*p1q1*p2q1)-
44733  &32*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1)+
44734  &32*a1*a2*mb*mt*p1p2*p1q2/(3*p1q1*p2q1)-
44735  &64*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q1)+224*a12*p2q1+
44736  &656*a1*a2*p2q1/3-256*a1*mt**2*p2q1/(3*p1q1**2)+
44737  &256*a12*mt**4*p2q1/(3*p1q1**2)-256*a1*p2q1/(3*p1q1)-
44738  &224*a1*a2*mb*mt*p2q1/(3*p1q1)-368*a12*mt**2*p2q1/(3*p1q1)+
44739  &448*a1*a2*mt**2*p2q1/(3*p1q1)+304*a1*a2*p1p2*p2q1/(3*p1q1)+
44740  &256*a12*mt**4*p2q1/(3*p1q2**2)+
44741  &256*a12*mt**2*p1q1*p2q1/(3*p1q2**2)+16*a1*p2q1/(3*p1q2)-
44742  &112*a1*a2*mb*mt*p2q1/(3*p1q2)+32*a12*mt**2*p2q1/(3*p1q2)
44743  a18=a18+64*a1*a2*mt**2*p2q1/p1q2+368*a1*a2*p1p2*p2q1/(3*p1q2)+
44744  &16*a1*mt**2*p2q1/(3*p1q1*p1q2)-64*a12*mt**4*p2q1/(3*p1q1*p1q2)+
44745  &640*a12*p1q1*p2q1/(3*p1q2)+544*a1*a2*p1q1*p2q1/(3*p1q2)+
44746  &32*a12*p1q2*p2q1/p1q1+944*a1*a2*p1q2*p2q1/(3*p1q1)+
44747  &128*a2*mb**4/(3*p2q2**2)-128*a2*mb**3*mt/(3*p2q2**2)+
44748  &256*a2**2*mb**5*mt/(3*p2q2**2)+256*a2*mb**2*p1p2/(3*p2q2**2)-
44749  &256*a2**2*mb**4*p1p2/(3*p2q2**2)+
44750  &64*mb**3*mt**3/(3*p1q1**2*p2q2**2)-
44751  &64*mb**2*mt**2*p1p2/(3*p1q1**2*p2q2**2)-
44752  &64*mb**3*mt/(3*p1q1*p2q2**2)-
44753  &256*a2*mb**3*mt*p1p2/(3*p1q1*p2q2**2)+
44754  &256*a2*mb**2*p1p2**2/(3*p1q1*p2q2**2)-
44755  &256*a2**2*mb**4*p1q1/(3*p2q2**2)+256*a2*mb**2*p1q2/(3*p2q2**2)-
44756  &256*a2**2*mb**4*p1q2/(3*p2q2**2)-
44757  &64*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2**2)-
44758  &256*a2*mb**3*mt*p1q2/(3*p1q1*p2q2**2)+
44759  &512*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2**2)
44760  a18=a18+256*a2*mb**2*p1q2**2/(3*p1q1*p2q2**2)-
44761  &256*a2*mb**2*p2q1/(3*p2q2**2)+256*a2**2*mb**3*mt*p2q1/(3*p2q2**2)+
44762  &64*mb**2*mt**2*p2q1/(3*p1q1**2*p2q2**2)+
44763  &64*mb**2*p2q1/(3*p1q1*p2q2**2)+
44764  &128*a2*mb**3*mt*p2q1/(3*p1q1*p2q2**2)-
44765  &128*a2*mb**2*mt**2*p2q1/(3*p1q1*p2q2**2)-
44766  &256*a2*mb**2*p1p2*p2q1/(3*p1q1*p2q2**2)+
44767  &256*a2**2*mb**2*p1q1*p2q1/(3*p2q2**2)-
44768  &256*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2**2)-8/(3*p2q2)-
44769  &72*a1*mb**2/p2q2-88*a2*mb**2/(3*p2q2)-56*a1*mb*mt/(3*p2q2)-
44770  &32*a2*mb*mt/p2q2-224*a1*a2*mb**3*mt/(3*p2q2)+
44771  &704*a2**2*mb**3*mt/(3*p2q2)-48*a1*p1p2/p2q2-
44772  &104*a2*p1p2/(3*p2q2)+448*a1*a2*mb**2*p1p2/(3*p2q2)-
44773  &512*a2**2*mb**2*p1p2/(3*p2q2)+128*a1*a2*mb*mt*p1p2/(3*p2q2)+
44774  &32*a1*a2*p1p2**2/p2q2+64*mb*mt**3/(3*p1q1**2*p2q2)+
44775  &256*a1*mb*mt**3*p1p2/(3*p1q1**2*p2q2)-
44776  &256*a1*mt**2*p1p2**2/(3*p1q1**2*p2q2)-4*mb**2/(3*p1q1*p2q2)
44777  a18=a18-64*mb*mt/(3*p1q1*p2q2)+128*a2*mb**3*mt/(3*p1q1*p2q2)-
44778  &4*mt**2/(3*p1q1*p2q2)-128*a1*mb**2*mt**2/(3*p1q1*p2q2)-
44779  &128*a2*mb**2*mt**2/(3*p1q1*p2q2)+128*a1*mb*mt**3/(3*p1q1*p2q2)-
44780  &112*a2*mb**2*p1p2/(3*p1q1*p2q2)+32*a1*mb*mt*p1p2/(3*p1q1*p2q2)+
44781  &32*a2*mb*mt*p1p2/(3*p1q1*p2q2)-112*a1*mt**2*p1p2/(3*p1q1*p2q2)-
44782  &48*a1*p1p2**2/(p1q1*p2q2)-48*a2*p1p2**2/(p1q1*p2q2)-
44783  &512*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q2)+
44784  &512*a1*a2*p1p2**3/(3*p1q1*p2q2)+16*a2*p1q1/(3*p2q2)+
44785  &64*a1*a2*mb**2*p1q1/p2q2+32*a2**2*mb**2*p1q1/(3*p2q2)-
44786  &112*a1*a2*mb*mt*p1q1/(3*p2q2)+368*a1*a2*p1p2*p1q1/(3*p2q2)-
44787  &16*p1p2/(3*p1q2*p2q2)+32*a1*mb*mt*p1p2/(3*p1q2*p2q2)+
44788  &32*a2*mb*mt*p1p2/(3*p1q2*p2q2)+
44789  &64*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q2)-
44790  &64*a1*a2*p1p2**3/(3*p1q2*p2q2)+8*mb*mt*p1p2/(3*p1q1*p1q2*p2q2)-
44791  &8*mt**2*p1p2/(3*p1q1*p1q2*p2q2)-
44792  &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q2)-
44793  &16*p1p2**2/(3*p1q1*p1q2*p2q2)
44794  a18=a18+32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q2)+
44795  &32*a2*p1p2*p1q1/(3*p1q2*p2q2)-
44796  &32*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q2)+
44797  &32*a1*a2*mb*mt*p1p2*p1q1/(3*p1q2*p2q2)-
44798  &64*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q2)-256*a2*p1q2/(3*p2q2)+
44799  &448*a1*a2*mb**2*p1q2/(3*p2q2)-368*a2**2*mb**2*p1q2/(3*p2q2)-
44800  &224*a1*a2*mb*mt*p1q2/(3*p2q2)+304*a1*a2*p1p2*p1q2/(3*p2q2)+
44801  &64*mt**2*p1q2/(3*p1q1**2*p2q2)-
44802  &128*a1*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2)+
44803  &128*a1*mb*mt**3*p1q2/(3*p1q1**2*p2q2)-
44804  &256*a1*mt**2*p1p2*p1q2/(3*p1q1**2*p2q2)+8*p1q2/(3*p1q1*p2q2)-
44805  &160*a1*mb**2*p1q2/(3*p1q1*p2q2)-272*a2*mb**2*p1q2/(3*p1q1*p2q2)-
44806  &56*a1*mb*mt*p1q2/(3*p1q1*p2q2)-200*a2*mb*mt*p1q2/(3*p1q1*p2q2)-
44807  &48*a1*p1p2*p1q2/(p1q1*p2q2)-256*a2*p1p2*p1q2/(3*p1q1*p2q2)+
44808  &256*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2)-
44809  &256*a1*a2*mb*mt*p1p2*p1q2/(p1q1*p2q2)+
44810  &1024*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q2)
44811  a18=a18-272*a2*p1q2**2/(3*p1q1*p2q2)+
44812  &256*a1*a2*mb**2*p1q2**2/(3*p1q1*p2q2)-
44813  &256*a1*a2*mb*mt*p1q2**2/(3*p1q1*p2q2)+
44814  &512*a1*a2*p1p2*p1q2**2/(3*p1q1*p2q2)-32*a2*mb**4/(3*p2q1*p2q2)+
44815  &32*a2*mb**3*mt/(3*p2q1*p2q2)-64*a2**2*mb**5*mt/(3*p2q1*p2q2)+
44816  &16*p1p2/(3*p2q1*p2q2)-64*a2*mb**2*p1p2/(3*p2q1*p2q2)+
44817  &64*a2**2*mb**4*p1p2/(3*p2q1*p2q2)+8*mb**2*p1p2/(3*p1q1*p2q1*p2q2)-
44818  &8*mb*mt*p1p2/(3*p1q1*p2q1*p2q2)+
44819  &32*a2*mb**3*mt*p1p2/(3*p1q1*p2q1*p2q2)+
44820  &16*p1p2**2/(3*p1q1*p2q1*p2q2)-
44821  &32*a2*mb**2*p1p2**2/(3*p1q1*p2q1*p2q2)-
44822  &16*a2*mb**2*p1q1/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q1/(3*p2q1*p2q2)+
44823  &8*mb**2*p1p2/(3*p1q2*p2q1*p2q2)-8*mb*mt*p1p2/(3*p1q2*p2q1*p2q2)+
44824  &32*a2*mb**3*mt*p1p2/(3*p1q2*p2q1*p2q2)+
44825  &16*p1p2**2/(3*p1q2*p2q1*p2q2)-
44826  &32*a2*mb**2*p1p2**2/(3*p1q2*p2q1*p2q2)-
44827  &16*mb*mt*p1p2**2/(3*p1q1*p1q2*p2q1*p2q2)
44828  a18=a18+16*p1p2**3/(3*p1q1*p1q2*p2q1*p2q2)-
44829  &32*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1*p2q2)-
44830  &16*a2*mb**2*p1q2/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q2/(3*p2q1*p2q2)-
44831  &32*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1*p2q2)+272*a1*p2q1/(3*p2q2)+
44832  &112*a2*p2q1/p2q2-80*a1*a2*mb**2*p2q1/p2q2+
44833  &400*a1*a2*mb*mt*p2q1/(3*p2q2)-208*a2**2*mb*mt*p2q1/(3*p2q2)-
44834  &272*a1*a2*mt**2*p2q1/(3*p2q2)-320*a1*a2*p1p2*p2q1/p2q2+
44835  &96*a2**2*p1p2*p2q1/p2q2-256*a1*mb*mt**3*p2q1/(3*p1q1**2*p2q2)+
44836  &512*a1*mt**2*p1p2*p2q1/(3*p1q1**2*p2q2)-8*p2q1/(3*p1q1*p2q2)+
44837  &200*a1*mb*mt*p2q1/(3*p1q1*p2q2)+56*a2*mb*mt*p2q1/(3*p1q1*p2q2)+
44838  &272*a1*mt**2*p2q1/(3*p1q1*p2q2)+160*a2*mt**2*p2q1/(3*p1q1*p2q2)+
44839  &256*a1*p1p2*p2q1/(3*p1q1*p2q2)+48*a2*p1p2*p2q1/(p1q1*p2q2)+
44840  &256*a1*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2)-
44841  &256*a1*a2*mt**2*p1p2*p2q1/(3*p1q1*p2q2)-
44842  &1024*a1*a2*p1p2**2*p2q1/(3*p1q1*p2q2)-
44843  &544*a1*a2*p1q1*p2q1/(3*p2q2)-640*a2**2*p1q1*p2q1/(3*p2q2)-
44844  &32*a1*p1p2*p2q1/(3*p1q2*p2q2)
44845  a18=a18-32*a1*a2*mb*mt*p1p2*p2q1/(3*p1q2*p2q2)+
44846  &32*a1*a2*mt**2*p1p2*p2q1/(3*p1q2*p2q2)+
44847  &64*a1*a2*p1p2**2*p2q1/(3*p1q2*p2q2)-
44848  &32*a1*mt**2*p1p2*p2q1/(3*p1q1*p1q2*p2q2)+
44849  &64*a1*a2*p1p2*p1q1*p2q1/(3*p1q2*p2q2)-
44850  &944*a1*a2*p1q2*p2q1/(3*p2q2)-32*a2**2*p1q2*p2q1/p2q2+
44851  &256*a1*mt**2*p1q2*p2q1/(3*p1q1**2*p2q2)+
44852  &96*a1*p1q2*p2q1/(p1q1*p2q2)+96*a2*p1q2*p2q1/(p1q1*p2q2)-
44853  &128*a1*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2)+
44854  &256*a1*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2)-
44855  &128*a1*a2*mt**2*p1q2*p2q1/(3*p1q1*p2q2)-
44856  &512*a1*a2*p1p2*p1q2*p2q1/(p1q1*p2q2)-
44857  &512*a1*a2*p1q2**2*p2q1/(3*p1q1*p2q2)+544*a1*a2*p2q1**2/(3*p2q2)-
44858  &256*a1*mt**2*p2q1**2/(3*p1q1**2*p2q2)-
44859  &272*a1*p2q1**2/(3*p1q1*p2q2)-
44860  &256*a1*a2*mb*mt*p2q1**2/(3*p1q1*p2q2)+
44861  &256*a1*a2*mt**2*p2q1**2/(3*p1q1*p2q2)
44862  a18=a18+512*a1*a2*p1p2*p2q1**2/(3*p1q1*p2q2)+
44863  &512*a1*a2*p1q2*p2q1**2/(3*p1q1*p2q2)+224*a12*p2q2+
44864  &656*a1*a2*p2q2/3+256*a12*mt**4*p2q2/(3*p1q1**2)+
44865  &16*a1*p2q2/(3*p1q1)-112*a1*a2*mb*mt*p2q2/(3*p1q1)+
44866  &32*a12*mt**2*p2q2/(3*p1q1)+64*a1*a2*mt**2*p2q2/p1q1+
44867  &368*a1*a2*p1p2*p2q2/(3*p1q1)-256*a1*mt**2*p2q2/(3*p1q2**2)+
44868  &256*a12*mt**4*p2q2/(3*p1q2**2)-256*a1*p2q2/(3*p1q2)-
44869  &224*a1*a2*mb*mt*p2q2/(3*p1q2)-368*a12*mt**2*p2q2/(3*p1q2)+
44870  &448*a1*a2*mt**2*p2q2/(3*p1q2)+304*a1*a2*p1p2*p2q2/(3*p1q2)+
44871  &16*a1*mt**2*p2q2/(3*p1q1*p1q2)-64*a12*mt**4*p2q2/(3*p1q1*p1q2)+
44872  &32*a12*p1q1*p2q2/p1q2+944*a1*a2*p1q1*p2q2/(3*p1q2)+
44873  &256*a12*mt**2*p1q2*p2q2/(3*p1q1**2)+
44874  &640*a12*p1q2*p2q2/(3*p1q1)+544*a1*a2*p1q2*p2q2/(3*p1q1)-
44875  &256*a2*mb**2*p2q2/(3*p2q1**2)+256*a2**2*mb**3*mt*p2q2/(3*p2q1**2)+
44876  &64*mb**2*mt**2*p2q2/(3*p1q2**2*p2q1**2)+
44877  &64*mb**2*p2q2/(3*p1q2*p2q1**2)+
44878  &128*a2*mb**3*mt*p2q2/(3*p1q2*p2q1**2)
44879  a18=a18-128*a2*mb**2*mt**2*p2q2/(3*p1q2*p2q1**2)-
44880  &256*a2*mb**2*p1p2*p2q2/(3*p1q2*p2q1**2)-
44881  &256*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1**2)+
44882  &256*a2**2*mb**2*p1q2*p2q2/(3*p2q1**2)+272*a1*p2q2/(3*p2q1)+
44883  &112*a2*p2q2/p2q1-80*a1*a2*mb**2*p2q2/p2q1+
44884  &400*a1*a2*mb*mt*p2q2/(3*p2q1)-208*a2**2*mb*mt*p2q2/(3*p2q1)-
44885  &272*a1*a2*mt**2*p2q2/(3*p2q1)-320*a1*a2*p1p2*p2q2/p2q1+
44886  &96*a2**2*p1p2*p2q2/p2q1-32*a1*p1p2*p2q2/(3*p1q1*p2q1)-
44887  &32*a1*a2*mb*mt*p1p2*p2q2/(3*p1q1*p2q1)+
44888  &32*a1*a2*mt**2*p1p2*p2q2/(3*p1q1*p2q1)+
44889  &64*a1*a2*p1p2**2*p2q2/(3*p1q1*p2q1)-944*a1*a2*p1q1*p2q2/(3*p2q1)-
44890  &32*a2**2*p1q1*p2q2/p2q1-256*a1*mb*mt**3*p2q2/(3*p1q2**2*p2q1)+
44891  &512*a1*mt**2*p1p2*p2q2/(3*p1q2**2*p2q1)+
44892  &256*a1*mt**2*p1q1*p2q2/(3*p1q2**2*p2q1)-8*p2q2/(3*p1q2*p2q1)+
44893  &200*a1*mb*mt*p2q2/(3*p1q2*p2q1)+56*a2*mb*mt*p2q2/(3*p1q2*p2q1)+
44894  &272*a1*mt**2*p2q2/(3*p1q2*p2q1)+160*a2*mt**2*p2q2/(3*p1q2*p2q1)+
44895  &256*a1*p1p2*p2q2/(3*p1q2*p2q1)+48*a2*p1p2*p2q2/(p1q2*p2q1)
44896  a18=a18+256*a1*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1)-
44897  &256*a1*a2*mt**2*p1p2*p2q2/(3*p1q2*p2q1)-
44898  &1024*a1*a2*p1p2**2*p2q2/(3*p1q2*p2q1)-
44899  &32*a1*mt**2*p1p2*p2q2/(3*p1q1*p1q2*p2q1)+
44900  &96*a1*p1q1*p2q2/(p1q2*p2q1)+96*a2*p1q1*p2q2/(p1q2*p2q1)-
44901  &128*a1*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1)+
44902  &256*a1*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1)-
44903  &128*a1*a2*mt**2*p1q1*p2q2/(3*p1q2*p2q1)-
44904  &512*a1*a2*p1p2*p1q1*p2q2/(p1q2*p2q1)-
44905  &512*a1*a2*p1q1**2*p2q2/(3*p1q2*p2q1)-544*a1*a2*p1q2*p2q2/(3*p2q1)-
44906  &640*a2**2*p1q2*p2q2/(3*p2q1)+
44907  &64*a1*a2*p1p2*p1q2*p2q2/(3*p1q1*p2q1)+544*a1*a2*p2q2**2/(3*p2q1)-
44908  &256*a1*mt**2*p2q2**2/(3*p1q2**2*p2q1)-
44909  &272*a1*p2q2**2/(3*p1q2*p2q1)-
44910  &256*a1*a2*mb*mt*p2q2**2/(3*p1q2*p2q1)+
44911  &256*a1*a2*mt**2*p2q2**2/(3*p1q2*p2q1)+
44912  &512*a1*a2*p1p2*p2q2**2/(3*p1q2*p2q1)
44913  a18=a18+512*a1*a2*p1q1*p2q2**2/(3*p1q2*p2q1)-
44914  &384*a12*mb*mt*p1q1**2/s**2+
44915  &384*a12*p1p2*p1q1**2/s**2-2688*a12*mb*mt*p1q1*p1q2/s**2+
44916  &2688*a12*p1p2*p1q1*p1q2/s**2-384*a12*mb*mt*p1q2**2/s**2+
44917  &384*a12*p1p2*p1q2**2/s**2-768*a1*a2*mb*mt*p1q1*p2q1/s**2+
44918  &768*a1*a2*p1p2*p1q1*p2q1/s**2-2688*a1*a2*mb*mt*p1q2*p2q1/s**2+
44919  &2688*a1*a2*p1p2*p1q2*p2q1/s**2-960*a12*p1q1*p1q2*p2q1/s**2-
44920  &960*a1*a2*p1q1*p1q2*p2q1/s**2+960*a12*p1q2**2*p2q1/s**2+
44921  &960*a1*a2*p1q2**2*p2q1/s**2-384*a2**2*mb*mt*p2q1**2/s**2+
44922  &384*a2**2*p1p2*p2q1**2/s**2-960*a1*a2*p1q2*p2q1**2/s**2-
44923  &960*a2**2*p1q2*p2q1**2/s**2-2688*a1*a2*mb*mt*p1q1*p2q2/s**2+
44924  &2688*a1*a2*p1p2*p1q1*p2q2/s**2+960*a12*p1q1**2*p2q2/s**2+
44925  &960*a1*a2*p1q1**2*p2q2/s**2-768*a1*a2*mb*mt*p1q2*p2q2/s**2+
44926  &768*a1*a2*p1p2*p1q2*p2q2/s**2-960*a12*p1q1*p1q2*p2q2/s**2-
44927  &960*a1*a2*p1q1*p1q2*p2q2/s**2-2688*a2**2*mb*mt*p2q1*p2q2/s**2+
44928  &2688*a2**2*p1p2*p2q1*p2q2/s**2+960*a1*a2*p1q1*p2q1*p2q2/s**2+
44929  &960*a2**2*p1q1*p2q1*p2q2/s**2+960*a1*a2*p1q2*p2q1*p2q2/s**2
44930  a18=a18+960*a2**2*p1q2*p2q1*p2q2/s**2-
44931  &384*a2**2*mb*mt*p2q2**2/s**2+
44932  &384*a2**2*p1p2*p2q2**2/s**2-960*a1*a2*p1q1*p2q2**2/s**2-
44933  &960*a2**2*p1q1*p2q2**2/s**2-96*a1*mb*mt/s-96*a2*mb*mt/s+
44934  &768*a2**2*mb**3*mt/s+768*a12*mb*mt**3/s-192*a1*p1p2/s-
44935  &192*a2*p1p2/s-768*a2**2*mb**2*p1p2/s+2304*a1*a2*mb*mt*p1p2/s-
44936  &768*a12*mt**2*p1p2/s-2304*a1*a2*p1p2**2/s+
44937  &96*a1*mb*mt**3/(p1q1*s)+192*a2*mb*mt*p1p2/(p1q1*s)-
44938  &96*a1*mt**2*p1p2/(p1q1*s)-192*a2*p1p2**2/(p1q1*s)-192*a1*p1q1/s-
44939  &144*a2*p1q1/s-384*a1*a2*mb**2*p1q1/s-480*a2**2*mb**2*p1q1/s+
44940  &480*a12*mb*mt*p1q1/s-96*a1*a2*mb*mt*p1q1/s-
44941  &864*a12*p1p2*p1q1/s-672*a1*a2*p1p2*p1q1/s-96*a1*a2*p1q1**2/s+
44942  &96*a1*mb*mt**3/(p1q2*s)+192*a2*mb*mt*p1p2/(p1q2*s)-
44943  &96*a1*mt**2*p1p2/(p1q2*s)-192*a2*p1p2**2/(p1q2*s)+
44944  &48*a1*mb*mt*p1q1/(p1q2*s)-96*a2*mb*mt*p1q1/(p1q2*s)-
44945  &48*a1*mt**2*p1q1/(p1q2*s)-192*a1*p1p2*p1q1/(p1q2*s)-
44946  &192*a2*p1p2*p1q1/(p1q2*s)-192*a1*a2*mb*mt*p1p2*p1q1/(p1q2*s)
44947  a18=a18+192*a1*a2*p1p2**2*p1q1/(p1q2*s)-192*a1*p1q1**2/(p1q2*s)-
44948  &192*a2*p1q1**2/(p1q2*s)+192*a1*a2*mb**2*p1q1**2/(p1q2*s)+
44949  &192*a12*mb*mt*p1q1**2/(p1q2*s)-96*a1*a2*mb*mt*p1q1**2/(p1q2*s)+
44950  &192*a1*a2*p1p2*p1q1**2/(p1q2*s)-192*a1*p1q2/s-144*a2*p1q2/s-
44951  &384*a1*a2*mb**2*p1q2/s-480*a2**2*mb**2*p1q2/s+
44952  &480*a12*mb*mt*p1q2/s-96*a1*a2*mb*mt*p1q2/s-
44953  &864*a12*p1p2*p1q2/s-672*a1*a2*p1p2*p1q2/s+
44954  &48*a1*mb*mt*p1q2/(p1q1*s)-96*a2*mb*mt*p1q2/(p1q1*s)-
44955  &48*a1*mt**2*p1q2/(p1q1*s)-192*a1*p1p2*p1q2/(p1q1*s)-
44956  &192*a2*p1p2*p1q2/(p1q1*s)-192*a1*a2*mb*mt*p1p2*p1q2/(p1q1*s)+
44957  &192*a1*a2*p1p2**2*p1q2/(p1q1*s)-576*a1*a2*p1q1*p1q2/s-
44958  &96*a1*a2*p1q2**2/s-192*a1*p1q2**2/(p1q1*s)-
44959  &192*a2*p1q2**2/(p1q1*s)+192*a1*a2*mb**2*p1q2**2/(p1q1*s)+
44960  &192*a12*mb*mt*p1q2**2/(p1q1*s)-96*a1*a2*mb*mt*p1q2**2/(p1q1*s)+
44961  &192*a1*a2*p1p2*p1q2**2/(p1q1*s)-96*a2*mb**3*mt/(p2q1*s)+
44962  &96*a2*mb**2*p1p2/(p2q1*s)-192*a1*mb*mt*p1p2/(p2q1*s)+
44963  &192*a1*p1p2**2/(p2q1*s)+96*a1*mb**2*p1q1/(p2q1*s)
44964  a18=a18+192*a2*mb**2*p1q1/(p2q1*s)-96*a1*mb*mt*p1q1/(p2q1*s)-
44965  &192*a1*a2*mb**3*mt*p1q1/(p2q1*s)+192*a1*p1p2*p1q1/(p2q1*s)+
44966  &192*a1*a2*mb**2*p1p2*p1q1/(p2q1*s)+
44967  &96*a1*a2*mb**2*p1q1**2/(p2q1*s)-
44968  &192*a2*mb**3*mt*p1q1/(p1q2*p2q1*s)+
44969  &192*a2*mb**2*p1p2*p1q1/(p1q2*p2q1*s)-
44970  &96*a1*mb*mt*p1p2*p1q1/(p1q2*p2q1*s)+
44971  &96*a1*p1p2**2*p1q1/(p1q2*p2q1*s)+
44972  &96*a1*mb**2*p1q1**2/(p1q2*p2q1*s)+
44973  &192*a2*mb**2*p1q1**2/(p1q2*p2q1*s)-
44974  &48*a1*mb*mt*p1q1**2/(p1q2*p2q1*s)+
44975  &96*a1*p1p2*p1q1**2/(p1q2*p2q1*s)+96*a1*mb**2*p1q2/(p2q1*s)+
44976  &48*a2*mb**2*p1q2/(p2q1*s)+192*a1*a2*mb**3*mt*p1q2/(p2q1*s)-
44977  &192*a1*a2*mb**2*p1p2*p1q2/(p2q1*s)-
44978  &96*a1*a2*mb**2*p1q2**2/(p2q1*s)+144*a1*p2q1/s+192*a2*p2q1/s+
44979  &96*a1*a2*mb*mt*p2q1/s-480*a2**2*mb*mt*p2q1/s+
44980  &480*a12*mt**2*p2q1/s+384*a1*a2*mt**2*p2q1/s
44981  a18=a18+672*a1*a2*p1p2*p2q1/s+864*a2**2*p1p2*p2q1/s-
44982  &96*a2*mb*mt*p2q1/(p1q1*s)+192*a1*mt**2*p2q1/(p1q1*s)+
44983  &96*a2*mt**2*p2q1/(p1q1*s)-192*a1*a2*mb*mt**3*p2q1/(p1q1*s)+
44984  &192*a2*p1p2*p2q1/(p1q1*s)+192*a1*a2*mt**2*p1p2*p2q1/(p1q1*s)-
44985  &192*a12*p1q1*p2q1/s-192*a2**2*p1q1*p2q1/s+
44986  &48*a1*mt**2*p2q1/(p1q2*s)+96*a2*mt**2*p2q1/(p1q2*s)+
44987  &192*a1*a2*mb*mt**3*p2q1/(p1q2*s)-
44988  &192*a1*a2*mt**2*p1p2*p2q1/(p1q2*s)+
44989  &96*a1*a2*mb*mt*p1q1*p2q1/(p1q2*s)-
44990  &192*a12*mt**2*p1q1*p2q1/(p1q2*s)-
44991  &96*a1*a2*mt**2*p1q1*p2q1/(p1q2*s)-
44992  &384*a1*a2*p1p2*p1q1*p2q1/(p1q2*s)-384*a12*p1q1**2*p2q1/(p1q2*s)-
44993  &384*a1*a2*p1q1**2*p2q1/(p1q2*s)-480*a12*p1q2*p2q1/s-
44994  &960*a1*a2*p1q2*p2q1/s-480*a2**2*p1q2*p2q1/s+
44995  &144*a1*p1q2*p2q1/(p1q1*s)+96*a2*p1q2*p2q1/(p1q1*s)+
44996  &384*a1*a2*mb*mt*p1q2*p2q1/(p1q1*s)-
44997  &96*a12*mt**2*p1q2*p2q1/(p1q1*s)
44998  a18=a18+96*a1*a2*mt**2*p1q2*p2q1/(p1q1*s)-
44999  &576*a1*a2*p1p2*p1q2*p2q1/(p1q1*s)-192*a12*p1q2**2*p2q1/(p1q1*s)-
45000  &384*a1*a2*p1q2**2*p2q1/(p1q1*s)-96*a1*a2*p2q1**2/s-
45001  &96*a1*a2*mt**2*p2q1**2/(p1q1*s)+96*a1*a2*mt**2*p2q1**2/(p1q2*s)+
45002  &288*a1*a2*p1q2*p2q1**2/(p1q1*s)-96*a2*mb**3*mt/(p2q2*s)+
45003  &96*a2*mb**2*p1p2/(p2q2*s)-192*a1*mb*mt*p1p2/(p2q2*s)+
45004  &192*a1*p1p2**2/(p2q2*s)+96*a1*mb**2*p1q1/(p2q2*s)+
45005  &48*a2*mb**2*p1q1/(p2q2*s)+192*a1*a2*mb**3*mt*p1q1/(p2q2*s)-
45006  &192*a1*a2*mb**2*p1p2*p1q1/(p2q2*s)-
45007  &96*a1*a2*mb**2*p1q1**2/(p2q2*s)+96*a1*mb**2*p1q2/(p2q2*s)+
45008  &192*a2*mb**2*p1q2/(p2q2*s)-96*a1*mb*mt*p1q2/(p2q2*s)-
45009  &192*a1*a2*mb**3*mt*p1q2/(p2q2*s)+192*a1*p1p2*p1q2/(p2q2*s)+
45010  &192*a1*a2*mb**2*p1p2*p1q2/(p2q2*s)-
45011  &192*a2*mb**3*mt*p1q2/(p1q1*p2q2*s)+
45012  &192*a2*mb**2*p1p2*p1q2/(p1q1*p2q2*s)-
45013  &96*a1*mb*mt*p1p2*p1q2/(p1q1*p2q2*s)+
45014  &96*a1*p1p2**2*p1q2/(p1q1*p2q2*s)+96*a1*a2*mb**2*p1q2**2/(p2q2*s)
45015  a18=a18+96*a1*mb**2*p1q2**2/(p1q1*p2q2*s)+
45016  &192*a2*mb**2*p1q2**2/(p1q1*p2q2*s)-
45017  &48*a1*mb*mt*p1q2**2/(p1q1*p2q2*s)+
45018  &96*a1*p1p2*p1q2**2/(p1q1*p2q2*s)-48*a2*mb**2*p2q1/(p2q2*s)-
45019  &96*a1*mb*mt*p2q1/(p2q2*s)+48*a2*mb*mt*p2q1/(p2q2*s)-
45020  &192*a1*p1p2*p2q1/(p2q2*s)-192*a2*p1p2*p2q1/(p2q2*s)-
45021  &192*a1*a2*mb*mt*p1p2*p2q1/(p2q2*s)+
45022  &192*a1*a2*p1p2**2*p2q1/(p2q2*s)+
45023  &192*a1*mb*mt**3*p2q1/(p1q1*p2q2*s)+
45024  &96*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2*s)-
45025  &192*a1*mt**2*p1p2*p2q1/(p1q1*p2q2*s)-
45026  &96*a2*p1p2**2*p2q1/(p1q1*p2q2*s)+
45027  &96*a1*a2*mb**2*p1q1*p2q1/(p2q2*s)+
45028  &192*a2**2*mb**2*p1q1*p2q1/(p2q2*s)-
45029  &96*a1*a2*mb*mt*p1q1*p2q1/(p2q2*s)+
45030  &384*a1*a2*p1p2*p1q1*p2q1/(p2q2*s)-96*a1*p1q2*p2q1/(p2q2*s)-
45031  &144*a2*p1q2*p2q1/(p2q2*s)-96*a1*a2*mb**2*p1q2*p2q1/(p2q2*s)
45032  a18=a18+96*a2**2*mb**2*p1q2*p2q1/(p2q2*s)-
45033  &384*a1*a2*mb*mt*p1q2*p2q1/(p2q2*s)+
45034  &576*a1*a2*p1p2*p1q2*p2q1/(p2q2*s)-
45035  &96*a2*mb**2*p1q2*p2q1/(p1q1*p2q2*s)-
45036  &48*a1*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
45037  &48*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
45038  &96*a1*mt**2*p1q2*p2q1/(p1q1*p2q2*s)-
45039  &96*a1*p1p2*p1q2*p2q1/(p1q1*p2q2*s)-
45040  &96*a2*p1p2*p1q2*p2q1/(p1q1*p2q2*s)+
45041  &96*a1*a2*p1q1*p1q2*p2q1/(p2q2*s)+288*a1*a2*p1q2**2*p2q1/(p2q2*s)-
45042  &96*a1*p1q2**2*p2q1/(p1q1*p2q2*s)-96*a2*p1q2**2*p2q1/(p1q1*p2q2*s)+
45043  &192*a1*p2q1**2/(p2q2*s)+192*a2*p2q1**2/(p2q2*s)+
45044  &96*a1*a2*mb*mt*p2q1**2/(p2q2*s)-192*a2**2*mb*mt*p2q1**2/(p2q2*s)-
45045  &192*a1*a2*mt**2*p2q1**2/(p2q2*s)-192*a1*a2*p1p2*p2q1**2/(p2q2*s)-
45046  &48*a2*mb*mt*p2q1**2/(p1q1*p2q2*s)+
45047  &192*a1*mt**2*p2q1**2/(p1q1*p2q2*s)+
45048  &96*a2*mt**2*p2q1**2/(p1q1*p2q2*s)
45049  a18=a18+96*a2*p1p2*p2q1**2/(p1q1*p2q2*s)-
45050  &384*a1*a2*p1q1*p2q1**2/(p2q2*s)-
45051  &384*a2**2*p1q1*p2q1**2/(p2q2*s)-384*a1*a2*p1q2*p2q1**2/(p2q2*s)-
45052  &192*a2**2*p1q2*p2q1**2/(p2q2*s)+96*a1*p1q2*p2q1**2/(p1q1*p2q2*s)+
45053  &96*a2*p1q2*p2q1**2/(p1q1*p2q2*s)+144*a1*p2q2/s+192*a2*p2q2/s+
45054  &96*a1*a2*mb*mt*p2q2/s-480*a2**2*mb*mt*p2q2/s+
45055  &480*a12*mt**2*p2q2/s+384*a1*a2*mt**2*p2q2/s+
45056  &672*a1*a2*p1p2*p2q2/s+864*a2**2*p1p2*p2q2/s+
45057  &48*a1*mt**2*p2q2/(p1q1*s)+96*a2*mt**2*p2q2/(p1q1*s)+
45058  &192*a1*a2*mb*mt**3*p2q2/(p1q1*s)-
45059  &192*a1*a2*mt**2*p1p2*p2q2/(p1q1*s)-480*a12*p1q1*p2q2/s-
45060  &960*a1*a2*p1q1*p2q2/s-480*a2**2*p1q1*p2q2/s-
45061  &96*a2*mb*mt*p2q2/(p1q2*s)+192*a1*mt**2*p2q2/(p1q2*s)+
45062  &96*a2*mt**2*p2q2/(p1q2*s)-192*a1*a2*mb*mt**3*p2q2/(p1q2*s)+
45063  &192*a2*p1p2*p2q2/(p1q2*s)+192*a1*a2*mt**2*p1p2*p2q2/(p1q2*s)+
45064  &144*a1*p1q1*p2q2/(p1q2*s)+96*a2*p1q1*p2q2/(p1q2*s)+
45065  &384*a1*a2*mb*mt*p1q1*p2q2/(p1q2*s)
45066  a18=a18-96*a12*mt**2*p1q1*p2q2/(p1q2*s)+
45067  &96*a1*a2*mt**2*p1q1*p2q2/(p1q2*s)-
45068  &576*a1*a2*p1p2*p1q1*p2q2/(p1q2*s)-192*a12*p1q1**2*p2q2/(p1q2*s)-
45069  &384*a1*a2*p1q1**2*p2q2/(p1q2*s)-192*a12*p1q2*p2q2/s-
45070  &192*a2**2*p1q2*p2q2/s+96*a1*a2*mb*mt*p1q2*p2q2/(p1q1*s)-
45071  &192*a12*mt**2*p1q2*p2q2/(p1q1*s)-
45072  &96*a1*a2*mt**2*p1q2*p2q2/(p1q1*s)-
45073  &384*a1*a2*p1p2*p1q2*p2q2/(p1q1*s)-384*a12*p1q2**2*p2q2/(p1q1*s)-
45074  &384*a1*a2*p1q2**2*p2q2/(p1q1*s)-48*a2*mb**2*p2q2/(p2q1*s)-
45075  &96*a1*mb*mt*p2q2/(p2q1*s)+48*a2*mb*mt*p2q2/(p2q1*s)-
45076  &192*a1*p1p2*p2q2/(p2q1*s)-192*a2*p1p2*p2q2/(p2q1*s)-
45077  &192*a1*a2*mb*mt*p1p2*p2q2/(p2q1*s)+
45078  &192*a1*a2*p1p2**2*p2q2/(p2q1*s)-96*a1*p1q1*p2q2/(p2q1*s)-
45079  &144*a2*p1q1*p2q2/(p2q1*s)-96*a1*a2*mb**2*p1q1*p2q2/(p2q1*s)+
45080  &96*a2**2*mb**2*p1q1*p2q2/(p2q1*s)-
45081  &384*a1*a2*mb*mt*p1q1*p2q2/(p2q1*s)+
45082  &576*a1*a2*p1p2*p1q1*p2q2/(p2q1*s)+288*a1*a2*p1q1**2*p2q2/(p2q1*s)
45083  a18=a18+192*a1*mb*mt**3*p2q2/(p1q2*p2q1*s)+
45084  &96*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1*s)-
45085  &192*a1*mt**2*p1p2*p2q2/(p1q2*p2q1*s)-
45086  &96*a2*p1p2**2*p2q2/(p1q2*p2q1*s)-
45087  &96*a2*mb**2*p1q1*p2q2/(p1q2*p2q1*s)-
45088  &48*a1*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
45089  &48*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
45090  &96*a1*mt**2*p1q1*p2q2/(p1q2*p2q1*s)-
45091  &96*a1*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
45092  &96*a2*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
45093  &96*a1*p1q1**2*p2q2/(p1q2*p2q1*s)-96*a2*p1q1**2*p2q2/(p1q2*p2q1*s)+
45094  &96*a1*a2*mb**2*p1q2*p2q2/(p2q1*s)+
45095  &192*a2**2*mb**2*p1q2*p2q2/(p2q1*s)-
45096  &96*a1*a2*mb*mt*p1q2*p2q2/(p2q1*s)+
45097  &384*a1*a2*p1p2*p1q2*p2q2/(p2q1*s)+
45098  &96*a1*a2*p1q1*p1q2*p2q2/(p2q1*s)-576*a1*a2*p2q1*p2q2/s+
45099  &96*a1*a2*p1q1*p2q1*p2q2/(p1q2*s)+96*a1*a2*p1q2*p2q1*p2q2/(p1q1*s)
45100  a18=a18-96*a1*a2*p2q2**2/s+96*a1*a2*mt**2*p2q2**2/(p1q1*s)-
45101  &96*a1*a2*mt**2*p2q2**2/(p1q2*s)+288*a1*a2*p1q1*p2q2**2/(p1q2*s)+
45102  &192*a1*p2q2**2/(p2q1*s)+192*a2*p2q2**2/(p2q1*s)+
45103  &96*a1*a2*mb*mt*p2q2**2/(p2q1*s)-192*a2**2*mb*mt*p2q2**2/(p2q1*s)-
45104  &192*a1*a2*mt**2*p2q2**2/(p2q1*s)-192*a1*a2*p1p2*p2q2**2/(p2q1*s)-
45105  &384*a1*a2*p1q1*p2q2**2/(p2q1*s)-192*a2**2*p1q1*p2q2**2/(p2q1*s)-
45106  &48*a2*mb*mt*p2q2**2/(p1q2*p2q1*s)+
45107  &192*a1*mt**2*p2q2**2/(p1q2*p2q1*s)+
45108  &96*a2*mt**2*p2q2**2/(p1q2*p2q1*s)+
45109  &96*a2*p1p2*p2q2**2/(p1q2*p2q1*s)+96*a1*p1q1*p2q2**2/(p1q2*p2q1*s)+
45110  &96*a2*p1q1*p2q2**2/(p1q2*p2q1*s)-384*a1*a2*p1q2*p2q2**2/(p2q1*s)-
45111  &384*a2**2*p1q2*p2q2**2/(p2q1*s)+512*a1*a2*s/3-
45112  &128*a1*mt**2*s/(3*p1q1**2)+128*a12*mb*mt**3*s/(3*p1q1**2)-
45113  &152*a1*s/(3*p1q1)-152*a12*mb*mt*s/(3*p1q1)-
45114  &128*a1*a2*mb*mt*s/(3*p1q1)+112*a1*a2*mt**2*s/(3*p1q1)-
45115  &16*a12*p1p2*s/p1q1+152*a1*a2*p1p2*s/(3*p1q1)-
45116  &128*a1*mt**2*s/(3*p1q2**2)+128*a12*mb*mt**3*s/(3*p1q2**2)
45117  a18=a18-152*a1*s/(3*p1q2)-152*a12*mb*mt*s/(3*p1q2)-
45118  &128*a1*a2*mb*mt*s/(3*p1q2)+112*a1*a2*mt**2*s/(3*p1q2)-
45119  &16*a12*p1p2*s/p1q2+152*a1*a2*p1p2*s/(3*p1q2)+
45120  &16*a1*mb*mt*s/(3*p1q1*p1q2)-32*a12*mb*mt**3*s/(3*p1q1*p1q2)-
45121  &16*a1*p1p2*s/(3*p1q1*p1q2)+272*a1*a2*p1q1*s/(3*p1q2)+
45122  &272*a1*a2*p1q2*s/(3*p1q1)-128*a2*mb**2*s/(3*p2q1**2)+
45123  &128*a2**2*mb**3*mt*s/(3*p2q1**2)+
45124  &32*mb**2*mt**2*s/(3*p1q2**2*p2q1**2)+32*mb**2*s/(3*p1q2*p2q1**2)
45125 
45126  a18bis=
45127  &64*a2*mb**3*mt*s/(3*p1q2*p2q1**2)-
45128  &64*a2*mb**2*mt**2*s/(3*p1q2*p2q1**2)-
45129  &128*a2*mb**2*p1p2*s/(3*p1q2*p2q1**2)-
45130  &128*a2*mb**2*p1q1*s/(3*p1q2*p2q1**2)+
45131  &128*a2**2*mb**2*p1q2*s/(3*p2q1**2)+152*a2*s/(3*p2q1)-
45132  &112*a1*a2*mb**2*s/(3*p2q1)+128*a1*a2*mb*mt*s/(3*p2q1)+
45133  &152*a2**2*mb*mt*s/(3*p2q1)-152*a1*a2*p1p2*s/(3*p2q1)+
45134  &16*a2**2*p1p2*s/p2q1-8*a1*a2*mb**3*mt*s/(3*p1q1*p2q1)+
45135  &16*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q1)-
45136  &8*a1*a2*mb*mt**3*s/(3*p1q1*p2q1)-8*a1*p1p2*s/(3*p1q1*p2q1)-
45137  &8*a2*p1p2*s/(3*p1q1*p2q1)+8*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q1)-
45138  &16*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q1)+
45139  &8*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q1)+
45140  &32*a1*a2*p1p2**2*s/(3*p1q1*p2q1)-32*a2**2*p1q1*s/(3*p2q1)-
45141  &32*mt**2*s/(3*p1q2**2*p2q1)+64*a1*mb**2*mt**2*s/(3*p1q2**2*p2q1)-
45142  &64*a1*mb*mt**3*s/(3*p1q2**2*p2q1)
45143  a18bis=a18bis+128*a1*mt**2*p1p2*s/(3*p1q2**2*p2q1)-
45144  &12*s/(p1q2*p2q1)+
45145  &24*a1*mb**2*s/(p1q2*p2q1)+64*a1*a2*mb**3*mt*s/(3*p1q2*p2q1)+
45146  &24*a2*mt**2*s/(p1q2*p2q1)-128*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q1)+
45147  &64*a1*a2*mb*mt**3*s/(3*p1q2*p2q1)+56*a1*p1p2*s/(3*p1q2*p2q1)+
45148  &56*a2*p1p2*s/(3*p1q2*p2q1)-64*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q1)+
45149  &128*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q1)-
45150  &64*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q1)-
45151  &256*a1*a2*p1p2**2*s/(3*p1q2*p2q1)+4*p1p2*s/(3*p1q1*p1q2*p2q1)-
45152  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1)-
45153  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1)+136*a2*p1q1*s/(3*p1q2*p2q1)-
45154  &128*a1*a2*mb**2*p1q1*s/(3*p1q2*p2q1)+
45155  &128*a1*a2*mb*mt*p1q1*s/(3*p1q2*p2q1)-
45156  &256*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q1)-160*a2**2*p1q2*s/(3*p2q1)+
45157  &16*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q1)-32*a12*p2q1*s/(3*p1q1)-
45158  &128*a12*mt**2*p2q1*s/(3*p1q2**2)-160*a12*p2q1*s/(3*p1q2)-
45159  &128*a2*mb**2*s/(3*p2q2**2)+128*a2**2*mb**3*mt*s/(3*p2q2**2)
45160  a18bis=a18bis+32*mb**2*mt**2*s/(3*p1q1**2*p2q2**2)+
45161  &32*mb**2*s/(3*p1q1*p2q2**2)+
45162  &64*a2*mb**3*mt*s/(3*p1q1*p2q2**2)-
45163  &64*a2*mb**2*mt**2*s/(3*p1q1*p2q2**2)-
45164  &128*a2*mb**2*p1p2*s/(3*p1q1*p2q2**2)+
45165  &128*a2**2*mb**2*p1q1*s/(3*p2q2**2)-
45166  &128*a2*mb**2*p1q2*s/(3*p1q1*p2q2**2)+152*a2*s/(3*p2q2)-
45167  &112*a1*a2*mb**2*s/(3*p2q2)+128*a1*a2*mb*mt*s/(3*p2q2)+
45168  &152*a2**2*mb*mt*s/(3*p2q2)-152*a1*a2*p1p2*s/(3*p2q2)+
45169  &16*a2**2*p1p2*s/p2q2-32*mt**2*s/(3*p1q1**2*p2q2)+
45170  &64*a1*mb**2*mt**2*s/(3*p1q1**2*p2q2)-
45171  &64*a1*mb*mt**3*s/(3*p1q1**2*p2q2)+
45172  &128*a1*mt**2*p1p2*s/(3*p1q1**2*p2q2)-12*s/(p1q1*p2q2)+
45173  &24*a1*mb**2*s/(p1q1*p2q2)+64*a1*a2*mb**3*mt*s/(3*p1q1*p2q2)+
45174  &24*a2*mt**2*s/(p1q1*p2q2)-128*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q2)+
45175  &64*a1*a2*mb*mt**3*s/(3*p1q1*p2q2)+56*a1*p1p2*s/(3*p1q1*p2q2)+
45176  &56*a2*p1p2*s/(3*p1q1*p2q2)-64*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q2)
45177  a18bis=a18bis+128*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q2)-
45178  &64*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q2)-
45179  &256*a1*a2*p1p2**2*s/(3*p1q1*p2q2)-160*a2**2*p1q1*s/(3*p2q2)-
45180  &8*a1*a2*mb**3*mt*s/(3*p1q2*p2q2)+
45181  &16*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q2)-
45182  &8*a1*a2*mb*mt**3*s/(3*p1q2*p2q2)-8*a1*p1p2*s/(3*p1q2*p2q2)-
45183  &8*a2*p1p2*s/(3*p1q2*p2q2)+8*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q2)-
45184  &16*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q2)+
45185  &8*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q2)+
45186  &32*a1*a2*p1p2**2*s/(3*p1q2*p2q2)+4*p1p2*s/(3*p1q1*p1q2*p2q2)-
45187  &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q2)-
45188  &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q2)+
45189  &16*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q2)-32*a2**2*p1q2*s/(3*p2q2)+
45190  &136*a2*p1q2*s/(3*p1q1*p2q2)-128*a1*a2*mb**2*p1q2*s/(3*p1q1*p2q2)+
45191  &128*a1*a2*mb*mt*p1q2*s/(3*p1q1*p2q2)-
45192  &256*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q2)+16*a2*mb*mt*s/(3*p2q1*p2q2)-
45193  &32*a2**2*mb**3*mt*s/(3*p2q1*p2q2)-16*a2*p1p2*s/(3*p2q1*p2q2)
45194  a18bis=a18bis-4*p1p2*s/(3*p1q1*p2q1*p2q2)+
45195  &8*a2*mb**2*p1p2*s/(3*p1q1*p2q1*p2q2)+
45196  &8*a2*mb*mt*p1p2*s/(3*p1q1*p2q1*p2q2)-4*p1p2*s/(3*p1q2*p2q1*p2q2)+
45197  &8*a2*mb**2*p1p2*s/(3*p1q2*p2q1*p2q2)+
45198  &8*a2*mb*mt*p1p2*s/(3*p1q2*p2q1*p2q2)-
45199  &2*mb**3*mt*s/(3*p1q1*p1q2*p2q1*p2q2)+
45200  &4*mb**2*mt**2*s/(3*p1q1*p1q2*p2q1*p2q2)-
45201  &2*mb*mt**3*s/(3*p1q1*p1q2*p2q1*p2q2)-
45202  &2*mb**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)+
45203  &4*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
45204  &2*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
45205  &8*p1p2**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
45206  &8*a2*p1p2*p1q1*s/(3*p1q2*p2q1*p2q2)+
45207  &8*a2*p1p2*p1q2*s/(3*p1q1*p2q1*p2q2)+272*a1*a2*p2q1*s/(3*p2q2)-
45208  &128*a1*mt**2*p2q1*s/(3*p1q1**2*p2q2)-136*a1*p2q1*s/(3*p1q1*p2q2)-
45209  &128*a1*a2*mb*mt*p2q1*s/(3*p1q1*p2q2)+
45210  &128*a1*a2*mt**2*p2q1*s/(3*p1q1*p2q2)
45211  a18bis=a18bis+256*a1*a2*p1p2*p2q1*s/(3*p1q1*p2q2)-
45212  &16*a1*a2*p1p2*p2q1*s/(3*p1q2*p2q2)+
45213  &8*a1*p1p2*p2q1*s/(3*p1q1*p1q2*p2q2)+
45214  &256*a1*a2*p1q2*p2q1*s/(3*p1q1*p2q2)-
45215  &128*a12*mt**2*p2q2*s/(3*p1q1**2)-160*a12*p2q2*s/(3*p1q1)-
45216  &32*a12*p2q2*s/(3*p1q2)+272*a1*a2*p2q2*s/(3*p2q1)-
45217  &16*a1*a2*p1p2*p2q2*s/(3*p1q1*p2q1)-
45218  &128*a1*mt**2*p2q2*s/(3*p1q2**2*p2q1)-136*a1*p2q2*s/(3*p1q2*p2q1)-
45219  &128*a1*a2*mb*mt*p2q2*s/(3*p1q2*p2q1)+
45220  &128*a1*a2*mt**2*p2q2*s/(3*p1q2*p2q1)+
45221  &256*a1*a2*p1p2*p2q2*s/(3*p1q2*p2q1)+
45222  &8*a1*p1p2*p2q2*s/(3*p1q1*p1q2*p2q1)+
45223  &256*a1*a2*p1q1*p2q2*s/(3*p1q2*p2q1)-
45224  &8*a12*mb*mt*s**2/(3*p1q1*p1q2)+16*a12*p1p2*s**2/(3*p1q1*p1q2)-
45225  &8*a1*a2*p1p2*s**2/(3*p1q1*p2q1)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q1)-
45226  &8*a1*a2*p1p2*s**2/(3*p1q2*p2q2)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q2)-
45227  &8*a2**2*mb*mt*s**2/(3*p2q1*p2q2)+16*a2**2*p1p2*s**2/(3*p2q1*p2q2)
45228  a18bis=a18bis-4*a2*p1p2*s**2/(3*p1q1*p2q1*p2q2)-
45229  &4*a2*p1p2*s**2/(3*p1q2*p2q1*p2q2)+
45230  &2*p1p2*s**2/(3*p1q1*p1q2*p2q1*p2q2)
45231 C
45232  v18=v18+v18bis
45233  a18=a18+a18bis
45234  v910 =-48*a12*mb*mt-48*a2**2*mb*mt-48*a12*p1p2-48*a2**2*p1p2-
45235  &384*a12*mb*mt*p1q1*p1q2/s**2-384*a12*p1p2*p1q1*p1q2/s**2-
45236  &384*a1*a2*mb*mt*p1q2*p2q1/s**2-384*a1*a2*p1p2*p1q2*p2q1/s**2+
45237  &192*a12*p1q1*p1q2*p2q1/s**2+192*a1*a2*p1q1*p1q2*p2q1/s**2-
45238  &192*a12*p1q2**2*p2q1/s**2-192*a1*a2*p1q2**2*p2q1/s**2+
45239  &192*a1*a2*p1q2*p2q1**2/s**2+192*a2**2*p1q2*p2q1**2/s**2-
45240  &384*a1*a2*mb*mt*p1q1*p2q2/s**2-384*a1*a2*p1p2*p1q1*p2q2/s**2-
45241  &192*a12*p1q1**2*p2q2/s**2-192*a1*a2*p1q1**2*p2q2/s**2+
45242  &192*a12*p1q1*p1q2*p2q2/s**2+192*a1*a2*p1q1*p1q2*p2q2/s**2-
45243  &384*a2**2*mb*mt*p2q1*p2q2/s**2-384*a2**2*p1p2*p2q1*p2q2/s**2-
45244  &192*a1*a2*p1q1*p2q1*p2q2/s**2-192*a2**2*p1q1*p2q1*p2q2/s**2-
45245  &192*a1*a2*p1q2*p2q1*p2q2/s**2-192*a2**2*p1q2*p2q1*p2q2/s**2+
45246  &192*a1*a2*p1q1*p2q2**2/s**2+192*a2**2*p1q1*p2q2**2/s**2+
45247  &96*a12*mb*mt*p1q1/s-96*a1*a2*mb*mt*p1q1/s+
45248  &96*a12*p1p2*p1q1/s-96*a1*a2*p1p2*p1q1/s+96*a12*mb*mt*p1q2/s-
45249  &96*a1*a2*mb*mt*p1q2/s+96*a12*p1p2*p1q2/s-96*a1*a2*p1p2*p1q2/s+
45250  &96*a1*a2*mb*mt*p2q1/s-96*a2**2*mb*mt*p2q1/s
45251  v910=v910+96*a1*a2*p1p2*p2q1/s-
45252  &96*a2**2*p1p2*p2q1/s+96*a12*p1q2*p2q1/s+
45253  &192*a1*a2*p1q2*p2q1/s+96*a2**2*p1q2*p2q1/s+
45254  &96*a1*a2*mb*mt*p2q2/s-96*a2**2*mb*mt*p2q2/s+
45255  &96*a1*a2*p1p2*p2q2/s-96*a2**2*p1p2*p2q2/s+96*a12*p1q1*p2q2/s+
45256  &192*a1*a2*p1q1*p2q2/s+96*a2**2*p1q1*p2q2/s
45257 C
45258  a910 = 48*a12*mb*mt+48*a2**2*mb*mt-48*a12*p1p2-48*a2**2*p1p2+
45259  &384*a12*mb*mt*p1q1*p1q2/s**2-384*a12*p1p2*p1q1*p1q2/s**2+
45260  &384*a1*a2*mb*mt*p1q2*p2q1/s**2-384*a1*a2*p1p2*p1q2*p2q1/s**2+
45261  &192*a12*p1q1*p1q2*p2q1/s**2+192*a1*a2*p1q1*p1q2*p2q1/s**2-
45262  &192*a12*p1q2**2*p2q1/s**2-192*a1*a2*p1q2**2*p2q1/s**2+
45263  &192*a1*a2*p1q2*p2q1**2/s**2+192*a2**2*p1q2*p2q1**2/s**2+
45264  &384*a1*a2*mb*mt*p1q1*p2q2/s**2-384*a1*a2*p1p2*p1q1*p2q2/s**2-
45265  &192*a12*p1q1**2*p2q2/s**2-192*a1*a2*p1q1**2*p2q2/s**2+
45266  &192*a12*p1q1*p1q2*p2q2/s**2+192*a1*a2*p1q1*p1q2*p2q2/s**2+
45267  &384*a2**2*mb*mt*p2q1*p2q2/s**2-384*a2**2*p1p2*p2q1*p2q2/s**2-
45268  &192*a1*a2*p1q1*p2q1*p2q2/s**2-192*a2**2*p1q1*p2q1*p2q2/s**2-
45269  &192*a1*a2*p1q2*p2q1*p2q2/s**2-192*a2**2*p1q2*p2q1*p2q2/s**2+
45270  &192*a1*a2*p1q1*p2q2**2/s**2+192*a2**2*p1q1*p2q2**2/s**2-
45271  &96*a12*mb*mt*p1q1/s+96*a1*a2*mb*mt*p1q1/s+
45272  &96*a12*p1p2*p1q1/s-96*a1*a2*p1p2*p1q1/s-96*a12*mb*mt*p1q2/s+
45273  &96*a1*a2*mb*mt*p1q2/s+96*a12*p1p2*p1q2/s-96*a1*a2*p1p2*p1q2/s-
45274  &96*a1*a2*mb*mt*p2q1/s+96*a2**2*mb*mt*p2q1/s
45275  a910=a910+96*a1*a2*p1p2*p2q1/s-
45276  &96*a2**2*p1p2*p2q1/s+96*a12*p1q2*p2q1/s+
45277  &192*a1*a2*p1q2*p2q1/s+96*a2**2*p1q2*p2q1/s-
45278  &96*a1*a2*mb*mt*p2q2/s+96*a2**2*mb*mt*p2q2/s+
45279  &96*a1*a2*p1p2*p2q2/s-96*a2**2*p1p2*p2q2/s+96*a12*p1q1*p2q2/s+
45280  &192*a1*a2*p1q1*p2q2/s+96*a2**2*p1q1*p2q2/s
45281 C
45282 C FINAL RESULT;
45283 C
45284  amp2= fact*ps*vtb**2*(v**2 *(v18 +v910)+a**2 *(a18+a910) )
45285 
45286  END
45287 C---------------------------------------------------------
45288 C 2) Q QBAR ->TBH^+
45289  SUBROUTINE pytbhq(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
45290 C
45291 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
45292 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
45293  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45294  IMPLICIT INTEGER(i-n)
45295  DOUBLE PRECISION mw2,mt,mb,mhp,mw
45296  dimension q1(4),q2(4),p1(4),p2(4),p3(4)
45297  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45298  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45299  common/pymssm/imss(0:99),rmss(0:99)
45300  common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
45301  SAVE /pydat1/,/pydat2/,/pymssm/,/pyctbh/
45302 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
45303 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
45304 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
45305 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
45306 C
45307 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
45308 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
45309 C
45310  dimension yy(2,2)
45311 
45312  pi = 4*datan(1.d0)
45313  mw = dsqrt(mw2)
45314 
45315 C COLLECTING THE RELEVANT OVERALL FACTORS:
45316 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
45317  ps=1.d0/(3.d0*3.d0 *2.d0*2.d0)
45318 C COUPLING CONSTANT (OVERALL NORMALIZATION)
45319  fact=(4.d0*pi*alpha)*(4.d0*pi*alphas)**2/sw2/2.d0
45320 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
45321 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
45322 C ALPHAS IS ALPHA_STRONG;
45323 C SW2 IS SIN(THETA_W)**2.
45324 C
45325 C VTB=.998D0
45326 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
45327 C
45328  v = ( mt/mw/tanb +rmb/mw*tanb)/2.d0
45329  a = (-mt/mw/tanb +rmb/mw*tanb)/2.d0
45330 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
45331 C
45332 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
45333 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
45334  DO 100 kk=1,4
45335  p2(kk)=p3(kk)-q1(kk)-q2(kk)+p1(kk)
45336  100 CONTINUE
45337 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
45338  s = 2*pytbhs(q1,q2)
45339  p1q1=pytbhs(q1,p1)
45340  p1q2=pytbhs(p1,q2)
45341  p2q1=pytbhs(p2,q1)
45342  p2q2=pytbhs(p2,q2)
45343  p1p2=pytbhs(p1,p2)
45344 C
45345 C TOP WIDTH CALCULATION
45346  CALL pytbhb(mt,mb,mhp,br,gamt)
45347 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
45348 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
45349  a1inv= s -2*p1q1 -2*p1q2
45350  a1 =a1inv/(a1inv**2+ (gamt*mt)**2)
45351 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
45352 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
45353  a12 = 1.d0/(a1inv**2+ (gamt*mt)**2)
45354  a2 =1.d0/(s +2*p2q1 +2*p2q2)
45355 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
45356 C NOW COMES THE AMP**2:
45357 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
45358 C THE EXPRESSIONS BELOW
45359  yy(1, 1) = -16*a**2*a2**2*mb*mt+
45360  &64*a**2*a2**2*p1q2*p2q1**2/s**2+
45361  &128*a**2*a2**2*mb*mt*p2q1*p2q2/s**2-
45362  &128*a**2*a2**2*p1p2*p2q1*p2q2/s**2-
45363  &64*a**2*a2**2*p1q1*p2q1*p2q2/s**2-
45364  &64*a**2*a2**2*p1q2*p2q1*p2q2/s**2+
45365  &64*a**2*a2**2*p1q1*p2q2**2/s**2-
45366  &32*a**2*a2**2*mb**3*mt/s+32*a**2*a2**2*mb**2*p1p2/s+
45367  &32*a**2*a2**2*mb**2*p1q1/s+32*a**2*a2**2*mb**2*p1q2/s-
45368  &32*a**2*a2**2*p1p2*p2q1/s-32*a**2*a2**2*p1q1*p2q1/s-
45369  &32*a**2*a2**2*p1p2*p2q2/s-32*a**2*a2**2*p1q2*p2q2/s+
45370  &16*a2**2*mb*mt*v**2+64*a2**2*p1q2*p2q1**2*v**2/s**2-
45371  &128*a2**2*mb*mt*p2q1*p2q2*v**2/s**2-
45372  &128*a2**2*p1p2*p2q1*p2q2*v**2/s**2-
45373  &64*a2**2*p1q1*p2q1*p2q2*v**2/s**2-
45374  &64*a2**2*p1q2*p2q1*p2q2*v**2/s**2+
45375  &64*a2**2*p1q1*p2q2**2*v**2/s**2
45376  yy(1, 1)=yy(1, 1)+32*a2**2*mb**3*mt*v**2/s+
45377  &32*a2**2*mb**2*p1p2*v**2/s+
45378  &32*a2**2*mb**2*p1q1*v**2/s+32*a2**2*mb**2*p1q2*v**2/s-
45379  &32*a2**2*p1p2*p2q1*v**2/s-32*a2**2*p1q1*p2q1*v**2/s-
45380  &32*a2**2*p1p2*p2q2*v**2/s-32*a2**2*p1q2*p2q2*v**2/s
45381  yy(1, 1)=2*yy(1, 1)
45382 
45383  yy(1, 2) = -32*a**2*a1*a2*mb*mt+
45384  &128*a**2*a1*a2*mb*mt*p1q2*p2q1/s**2-
45385  &128*a**2*a1*a2*p1p2*p1q2*p2q1/s**2+
45386  &64*a**2*a1*a2*p1q1*p1q2*p2q1/s**2-
45387  &64*a**2*a1*a2*p1q2**2*p2q1/s**2+
45388  &64*a**2*a1*a2*p1q2*p2q1**2/s**2+
45389  &128*a**2*a1*a2*mb*mt*p1q1*p2q2/s**2-
45390  &128*a**2*a1*a2*p1p2*p1q1*p2q2/s**2-
45391  &64*a**2*a1*a2*p1q1**2*p2q2/s**2+
45392  &64*a**2*a1*a2*p1q1*p1q2*p2q2/s**2-
45393  &64*a**2*a1*a2*p1q1*p2q1*p2q2/s**2-
45394  &64*a**2*a1*a2*p1q2*p2q1*p2q2/s**2+
45395  &64*a**2*a1*a2*p1q1*p2q2**2/s**2-
45396  &64*a**2*a1*a2*mb*mt*p1p2/s+
45397  &64*a**2*a1*a2*p1p2**2/s+32*a**2*a1*a2*mb**2*p1q1/s+
45398  &32*a**2*a1*a2*p1p2*p1q1/s+32*a**2*a1*a2*mb**2*p1q2/s+
45399  &32*a**2*a1*a2*p1p2*p1q2/s-32*a**2*a1*a2*mt**2*p2q1/s
45400  yy(1, 2)=yy(1, 2)-32*a**2*a1*a2*p1p2*p2q1/s-
45401  &64*a**2*a1*a2*p1q1*p2q1/s-
45402  &32*a**2*a1*a2*mt**2*p2q2/s-32*a**2*a1*a2*p1p2*p2q2/s-
45403  &64*a**2*a1*a2*p1q2*p2q2/s+32*a1*a2*mb*mt*v**2-
45404  &128*a1*a2*mb*mt*p1q2*p2q1*v**2/s**2 -
45405  &128*a1*a2*p1p2*p1q2*p2q1*v**2/s**2+
45406  &64*a1*a2*p1q1*p1q2*p2q1*v**2/s**2-
45407  &64*a1*a2*p1q2**2*p2q1*v**2/s**2+
45408  &64*a1*a2*p1q2*p2q1**2*v**2/s**2-
45409  &128*a1*a2*mb*mt*p1q1*p2q2*v**2/s**2-
45410  &128*a1*a2*p1p2*p1q1*p2q2*v**2/s**2-
45411  &64*a1*a2*p1q1**2*p2q2*v**2/s**2+
45412  &64*a1*a2*p1q1*p1q2*p2q2*v**2/s**2-
45413  &64*a1*a2*p1q1*p2q1*p2q2*v**2/s**2-
45414  &64*a1*a2*p1q2*p2q1*p2q2*v**2/s**2+
45415  &64*a1*a2*p1q1*p2q2**2*v**2/s**2+
45416  &64*a1*a2*mb*mt*p1p2*v**2/s+64*a1*a2*p1p2**2*v**2/s
45417  yy(1, 2)=yy(1, 2)+32*a1*a2*mb**2*p1q1*v**2/s+
45418  &32*a1*a2*p1p2*p1q1*v**2/s+
45419  &32*a1*a2*mb**2*p1q2*v**2/s+32*a1*a2*p1p2*p1q2*v**2/s-
45420  &32*a1*a2*mt**2*p2q1*v**2/s-32*a1*a2*p1p2*p2q1*v**2/s-
45421  &64*a1*a2*p1q1*p2q1*v**2/s-32*a1*a2*mt**2*p2q2*v**2/s-
45422  &32*a1*a2*p1p2*p2q2*v**2/s-64*a1*a2*p1q2*p2q2*v**2/s
45423 
45424 
45425  yy(2, 2) =-16*a**2*a12*mb*mt+
45426  &128*a**2*a12*mb*mt*p1q1*p1q2/s**2-
45427  &128*a**2*a12*p1p2*p1q1*p1q2/s**2+
45428  &64*a**2*a12*p1q1*p1q2*p2q1/s**2-
45429  &64*a**2*a12*p1q2**2*p2q1/s**2-64*a**2*a12*p1q1**2*p2q2/s**2+
45430  &64*a**2*a12*p1q1*p1q2*p2q2/s**2-32*a**2*a12*mb*mt**3/s+
45431  &32*a**2*a12*mt**2*p1p2/s+32*a**2*a12*p1p2*p1q1/s+
45432  &32*a**2*a12*p1p2*p1q2/s-32*a**2*a12*mt**2*p2q1/s-
45433  &32*a**2*a12*p1q1*p2q1/s-32*a**2*a12*mt**2*p2q2/s-
45434  &32*a**2*a12*p1q2*p2q2/s+16*a12*mb*mt*v**2-
45435  &128*a12*mb*mt*p1q1*p1q2*v**2/s**2-
45436  &128*a12*p1p2*p1q1*p1q2*v**2/s**2+
45437  &64*a12*p1q1*p1q2*p2q1*v**2/s**2-
45438  &64*a12*p1q2**2*p2q1*v**2/s**2-64*a12*p1q1**2*p2q2*v**2/s**2+
45439  &64*a12*p1q1*p1q2*p2q2*v**2/s**2+32*a12*mb*mt**3*v**2/s+
45440  &32*a12*mt**2*p1p2*v**2/s+32*a12*p1p2*p1q1*v**2/s+
45441  &32*a12*p1p2*p1q2*v**2/s-32*a12*mt**2*p2q1*v**2/s
45442  yy(2, 2)=yy(2, 2)-32*a12*p1q1*p2q1*v**2/s-
45443  &32*a12*mt**2*p2q2*v**2/s-
45444  &32*a12*p1q2*p2q2*v**2/s
45445  yy(2, 2)=2*yy(2, 2)
45446 
45447  res=yy(1,1)+2*yy(1,2)+yy(2,2)
45448  amp2= fact*ps*vtb**2*res
45449 
45450  END
45451 C=====================================================================
45452 C ************* FUNCTION SCALAR PRODUCTS *************************
45453  DOUBLE PRECISION FUNCTION pytbhs(A,B)
45454  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45455  IMPLICIT INTEGER(i-n)
45456  dimension a(4),b(4)
45457  dum=a(4)*b(4)
45458  DO 100 id=1,3
45459  dum=dum-a(id)*b(id)
45460  100 CONTINUE
45461  pytbhs=dum
45462  RETURN
45463  END
45464 
45465 C*********************************************************************
45466 
45467 C...PYMSIN
45468 C...Initializes supersymmetry: finds sparticle masses and
45469 C...branching ratios and stores this information.
45470 C...AUTHOR: STEPHEN MRENNA
45471 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
45472 
45473  SUBROUTINE pymsin
45474 
45475 C...Double precision and integer declarations.
45476  IMPLICIT DOUBLE PRECISION(a-h, o-z)
45477  IMPLICIT INTEGER(i-n)
45478  INTEGER pyk,pychge,pycomp
45479 C...Parameter statement to help give large particle numbers.
45480  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
45481  &kexcit=4000000,kdimen=5000000)
45482 C...Commonblocks.
45483  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45484  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45485  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
45486  common/pydat4/chaf(500,2)
45487  CHARACTER chaf*16
45488  common/pypars/mstp(200),parp(200),msti(200),pari(200)
45489  common/pyint4/mwid(500),wids(500,5)
45490  common/pymssm/imss(0:99),rmss(0:99)
45491  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
45492  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
45493  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
45494  common/pyhtri/hhh(7)
45495  common/pyqnum/nqnum,nqdum,kqnum(500,0:9)
45496  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pypars/,/pyint4/,
45497  &/pymssm/,/pymsrv/,/pyssmt/
45498 
45499 C...Local variables.
45500  DOUBLE PRECISION alfa,beta
45501  DOUBLE PRECISION tanb,al,be,cosa,cosb,sina,sinb,xw
45502  INTEGER i,j,j1,i1,k1
45503  INTEGER kc,lknt,idlam(400,3)
45504  DOUBLE PRECISION xlam(0:400)
45505  DOUBLE PRECISION wdtp(0:400),wdte(0:400,0:5)
45506  DOUBLE PRECISION xarg,cos2b,xmw2,xmz2
45507  DOUBLE PRECISION delm,xmdif
45508  DOUBLE PRECISION dx,dy,ds,dmu2,dma2,dq2,du2,dd2,dl2,de2,dhu2,dhd2
45509  DOUBLE PRECISION arg,sgnmu,r
45510  INTEGER imssm
45511  INTEGER irprty
45512  INTEGER kfsusy(50),mwidsu(36),mdcysu(36)
45513  SAVE mwidsu,mdcysu
45514  DATA kfsusy/
45515  &1000001,2000001,1000002,2000002,1000003,2000003,
45516  &1000004,2000004,1000005,2000005,1000006,2000006,
45517  &1000011,2000011,1000012,2000012,1000013,2000013,
45518  &1000014,2000014,1000015,2000015,1000016,2000016,
45519  &1000021,1000022,1000023,1000025,1000035,1000024,
45520  &1000037,1000039, 25, 35, 36, 37,
45521  & 6, 24, 45, 46,1000045, 9*0/
45522  DATA init/0/
45523 
45524 C...Automatically read QNUMBERS, MASS, and DECAY tables
45525  IF (imss(21).NE.0.OR.mstp(161).NE.0) THEN
45526  nqnum=0
45527  CALL pyslha(0,0,ifail)
45528  CALL pyslha(5,0,ifail)
45529  ENDIF
45530  IF (imss(22).NE.0.OR.mstp(161).NE.0) CALL pyslha(2,0,ifail)
45531 
45532 C...Do nothing further if SUSY not requested
45533  imssm=imss(1)
45534  IF(imssm.EQ.0) RETURN
45535 
45536 C...Save copy of MWID(KC) and MDCY(KC,1) values before
45537 C...they are set to zero for the LSP.
45538  IF(init.EQ.0) THEN
45539  init=1
45540  DO 100 i=1,36
45541  kf=kfsusy(i)
45542  kc=pycomp(kf)
45543  mwidsu(i)=mwid(kc)
45544  mdcysu(i)=mdcy(kc,1)
45545  100 CONTINUE
45546  ENDIF
45547 
45548 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
45549  DO 110 i=1,36
45550  kf=kfsusy(i)
45551  kc=pycomp(kf)
45552  IF(mdcy(kc,1).EQ.0.AND.mdcysu(i).NE.0) THEN
45553  mwid(kc)=mwidsu(i)
45554  mdcy(kc,1)=mdcysu(i)
45555  ENDIF
45556  110 CONTINUE
45557 
45558 C...First part of routine: set masses and couplings.
45559 
45560 C...Reset mixing values in sfermion sector to pure left/right.
45561  DO 120 i=1,16
45562  sfmix(i,1)=1d0
45563  sfmix(i,4)=1d0
45564  sfmix(i,2)=0d0
45565  sfmix(i,3)=0d0
45566  120 CONTINUE
45567 
45568 C...Add NMSSM states if NMSSM switched on, and change old names.
45569  IF (imss(13).NE.0.AND.pycomp(1000045).EQ.0) THEN
45570 C... Switch on NMSSM
45571  WRITE(mstu(11),*) '(PYMSIN:) switching on NMSSM'
45572 
45573  kfn=25
45574  kcn=kfn
45575  chaf(kcn,1)='h_10'
45576  chaf(kcn,2)=' '
45577 
45578  kfn=35
45579  kcn=kfn
45580  chaf(kcn,1)='h_20'
45581  chaf(kcn,2)=' '
45582 
45583  kfn=45
45584  kcn=kfn
45585  chaf(kcn,1)='h_30'
45586  chaf(kcn,2)=' '
45587 
45588  kfn=36
45589  kcn=kfn
45590  chaf(kcn,1)='A_10'
45591  chaf(kcn,2)=' '
45592 
45593  kfn=46
45594  kcn=kfn
45595  chaf(kcn,1)='A_20'
45596  chaf(kcn,2)=' '
45597 
45598  kfn=1000045
45599  kcn=pycomp(kfn)
45600  IF (kcn.EQ.0) THEN
45601  DO 123 kct=100,mstu(6)
45602  IF(kchg(kct,4).GT.100) kcn=kct
45603  123 CONTINUE
45604  kcn=kcn+1
45605  kchg(kcn,4)=kfn
45606  mstu(20)=0
45607  ENDIF
45608 C... Set stable for now
45609  pmas(kcn,2)=1d-6
45610  mwid(kcn)=0
45611  mdcy(kcn,1)=0
45612  mdcy(kcn,2)=0
45613  mdcy(kcn,3)=0
45614  chaf(kcn,1)='~chi_50'
45615  chaf(kcn,2)=' '
45616  ENDIF
45617 
45618 C...Read spectrum from SLHA file.
45619  IF (imssm.EQ.11) THEN
45620  CALL pyslha(1,0,ifail)
45621  ENDIF
45622 
45623 C...Common couplings.
45624  tanb=rmss(5)
45625  beta=atan(tanb)
45626  cosb=cos(beta)
45627  sinb=tanb*cosb
45628  cos2b=cos(2d0*beta)
45629  alfa=rmss(18)
45630  xmw2=pmas(24,1)**2
45631  xmz2=pmas(23,1)**2
45632  xw=paru(102)
45633 
45634 C...Define sparticle masses for a general MSSM simulation.
45635  IF(imssm.EQ.1) THEN
45636  IF(imss(9).EQ.0) rmss(22)=rmss(9)
45637  DO 130 i=1,5,2
45638  kc=pycomp(ksusy1+i)
45639  pmas(kc,1)=sqrt(rmss(8)**2-(2d0*xmw2+xmz2)*cos2b/6d0)
45640  kc=pycomp(ksusy2+i)
45641  pmas(kc,1)=sqrt(rmss(9)**2+(xmw2-xmz2)*cos2b/3d0)
45642  kc=pycomp(ksusy1+i+1)
45643  pmas(kc,1)=sqrt(rmss(8)**2+(4d0*xmw2-xmz2)*cos2b/6d0)
45644  kc=pycomp(ksusy2+i+1)
45645  pmas(kc,1)=sqrt(rmss(22)**2-(xmw2-xmz2)*cos2b*2d0/3d0)
45646  130 CONTINUE
45647  xarg=rmss(6)**2-pmas(24,1)**2*abs(cos(2d0*beta))
45648  IF(xarg.LT.0d0) THEN
45649  WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45650  & ' FROM THE SUM RULE. '
45651  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45652  RETURN
45653  ELSE
45654  xarg=sqrt(xarg)
45655  ENDIF
45656  DO 140 i=11,15,2
45657  pmas(pycomp(ksusy1+i),1)=rmss(6)
45658  pmas(pycomp(ksusy2+i),1)=rmss(7)
45659  pmas(pycomp(ksusy1+i+1),1)=xarg
45660  pmas(pycomp(ksusy2+i+1),1)=9999d0
45661  140 CONTINUE
45662  IF(imss(8).EQ.1) THEN
45663  rmss(13)=rmss(6)
45664  rmss(14)=rmss(7)
45665  ENDIF
45666 
45667 C...Alternatively derive masses from SUGRA relations.
45668  ELSEIF(imssm.EQ.2) THEN
45669  rmss(36)=rmss(16)
45670  CALL pyapps
45671 C...Or use ISASUSY
45672  ELSEIF(imssm.EQ.12.OR.imssm.EQ.13) THEN
45673  rmss(36)=rmss(16)
45674  CALL pysugi
45675  alfa=rmss(18)
45676  goto 170
45677  ELSE
45678  goto 170
45679  ENDIF
45680 
45681 C...Add in extra D-term contributions.
45682  IF(imss(7).EQ.1) THEN
45683  r=0.43d0
45684  dx=rmss(23)
45685  dy=rmss(24)
45686  ds=rmss(25)
45687  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45688  WRITE(mstu(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
45689  WRITE(mstu(11),*) 'C IN A U(B-L) THEORY '
45690  WRITE(mstu(11),*) 'C DX = ',dx
45691  WRITE(mstu(11),*) 'C DY = ',dy
45692  WRITE(mstu(11),*) 'C DS = ',ds
45693  WRITE(mstu(11),*) 'C '
45694  dy=r*dy-4d0/33d0*(1d0-r)*dx+(1d0-r)/33d0*ds
45695  WRITE(mstu(11),*) 'C DY AT THE WEAK SCALE = ',dy
45696  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45697  dq2=dy/6d0-dx/3d0-ds/3d0
45698  du2=-2d0*dy/3d0-dx/3d0-ds/3d0
45699  dd2=dy/3d0+dx-2d0*ds/3d0
45700  dl2=-dy/2d0+dx-2d0*ds/3d0
45701  de2=dy-dx/3d0-ds/3d0
45702  dhu2=dy/2d0+2d0*dx/3d0+2d0*ds/3d0
45703  dhd2=-dy/2d0-2d0*dx/3d0+ds
45704  dmu2=(-dy/2d0-2d0/3d0*dx+(cosb**2-2d0*sinb**2/3d0)*ds)
45705  & /abs(cos2b)
45706  dma2 = 2d0*dmu2+dhu2+dhd2
45707  DO 150 i=1,5,2
45708  kc=pycomp(ksusy1+i)
45709  pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
45710  kc=pycomp(ksusy2+i)
45711  pmas(kc,1)=sqrt(pmas(kc,1)**2+dd2)
45712  kc=pycomp(ksusy1+i+1)
45713  pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
45714  kc=pycomp(ksusy2+i+1)
45715  pmas(kc,1)=sqrt(pmas(kc,1)**2+du2)
45716  150 CONTINUE
45717  DO 160 i=11,15,2
45718  kc=pycomp(ksusy1+i)
45719  pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
45720  kc=pycomp(ksusy2+i)
45721  pmas(kc,1)=sqrt(pmas(kc,1)**2+de2)
45722  kc=pycomp(ksusy1+i+1)
45723  pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
45724  160 CONTINUE
45725  IF(rmss(4)**2+dmu2.LT.0d0) THEN
45726  WRITE(mstu(11),*) ' MU2 DRIVEN NEGATIVE '
45727  CALL pystop(104)
45728  ENDIF
45729  sgnmu=sign(1d0,rmss(4))
45730  rmss(4)=sgnmu*sqrt(rmss(4)**2+dmu2)
45731  arg=rmss(10)**2*sign(1d0,rmss(10))+dq2
45732  rmss(10)=sign(sqrt(abs(arg)),arg)
45733  arg=rmss(11)**2*sign(1d0,rmss(11))+dd2
45734  rmss(11)=sign(sqrt(abs(arg)),arg)
45735  arg=rmss(12)**2*sign(1d0,rmss(12))+du2
45736  rmss(12)=sign(sqrt(abs(arg)),arg)
45737  arg=rmss(13)**2*sign(1d0,rmss(13))+dl2
45738  rmss(13)=sign(sqrt(abs(arg)),arg)
45739  arg=rmss(14)**2*sign(1d0,rmss(14))+de2
45740  rmss(14)=sign(sqrt(abs(arg)),arg)
45741  IF( rmss(19)**2 + dma2 .LE. 50d0 ) THEN
45742  WRITE(mstu(11),*) ' MA DRIVEN TOO LOW '
45743  CALL pystop(104)
45744  ENDIF
45745  rmss(19)=sqrt(rmss(19)**2+dma2)
45746  rmss(6)=sqrt(rmss(6)**2+dl2)
45747  rmss(7)=sqrt(rmss(7)**2+de2)
45748  WRITE(mstu(11),*) ' MTL = ',rmss(10)
45749  WRITE(mstu(11),*) ' MBR = ',rmss(11)
45750  WRITE(mstu(11),*) ' MTR = ',rmss(12)
45751  WRITE(mstu(11),*) ' SEL = ',rmss(6),rmss(13)
45752  WRITE(mstu(11),*) ' SER = ',rmss(7),rmss(14)
45753  ENDIF
45754 
45755 C...Fix the third generation sfermions.
45756  CALL pythrg
45757 
45758 C...Fix the neutralino--chargino--gluino sector.
45759  CALL pyinom
45760 
45761 C...Fix the Higgs sector.
45762  CALL pyhggm(alfa)
45763 
45764 C...Choose the Gunion-Haber convention.
45765  alfa=-alfa
45766  rmss(18)=alfa
45767 
45768 C...Print information on mass parameters.
45769  IF(imssm.EQ.2.AND.mstp(122).GT.0) THEN
45770  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45771  WRITE(mstu(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45772  WRITE(mstu(11),*) ' M0 = ',rmss(8)
45773  WRITE(mstu(11),*) ' M1/2=',rmss(1)
45774  WRITE(mstu(11),*) ' TANB=',rmss(5)
45775  WRITE(mstu(11),*) ' MU = ',rmss(4)
45776  WRITE(mstu(11),*) ' AT = ',rmss(16)
45777  WRITE(mstu(11),*) ' MA = ',rmss(19)
45778  WRITE(mstu(11),*) ' MTOP=',pmas(6,1)
45779  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45780  ENDIF
45781  IF(imss(20).EQ.1) THEN
45782  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45783  WRITE(mstu(11),*) ' DEBUG MODE '
45784  WRITE(mstu(11),*) ' UMIX = ',umix(1,1),umix(1,2),
45785  & umix(2,1),umix(2,2)
45786  WRITE(mstu(11),*) ' UMIXI = ',umixi(1,1),umixi(1,2),
45787  & umixi(2,1),umixi(2,2)
45788  WRITE(mstu(11),*) ' VMIX = ',vmix(1,1),vmix(1,2),
45789  & vmix(2,1),vmix(2,2)
45790  WRITE(mstu(11),*) ' VMIXI = ',vmixi(1,1),vmixi(1,2),
45791  & vmixi(2,1),vmixi(2,2)
45792  WRITE(mstu(11),*) ' ZMIX = ',(zmix(1,i),i=1,4)
45793  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(1,i),i=1,4)
45794  WRITE(mstu(11),*) ' ZMIX = ',(zmix(2,i),i=1,4)
45795  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(2,i),i=1,4)
45796  WRITE(mstu(11),*) ' ZMIX = ',(zmix(3,i),i=1,4)
45797  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(3,i),i=1,4)
45798  WRITE(mstu(11),*) ' ZMIX = ',(zmix(4,i),i=1,4)
45799  WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(4,i),i=1,4)
45800  WRITE(mstu(11),*) ' ALFA = ',alfa
45801  WRITE(mstu(11),*) ' BETA = ',beta
45802  WRITE(mstu(11),*) ' STOP = ',(sfmix(6,i),i=1,4)
45803  WRITE(mstu(11),*) ' SBOT = ',(sfmix(5,i),i=1,4)
45804  WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45805  ENDIF
45806 
45807 C...Set up the Higgs couplings - needed here since initialization
45808 C...in PYINRE did not yet occur when PYWIDT is called below.
45809  170 al=alfa
45810  be=beta
45811  sina=sin(al)
45812  cosa=cos(al)
45813  cosb=cos(be)
45814  sinb=tanb*cosb
45815  sbma=sin(be-al)
45816  sapb=sin(al+be)
45817  capb=cos(al+be)
45818  cbma=cos(be-al)
45819  c2a=cos(2d0*al)
45820  c2b=cosb**2-sinb**2
45821 C...tanb (used for H+)
45822  paru(141)=tanb
45823 
45824 C...Firstly: h
45825 C...Coupling to d-type quarks
45826  paru(161)=sina/cosb
45827 C...Coupling to u-type quarks
45828  paru(162)=-cosa/sinb
45829 C...Coupling to leptons
45830  paru(163)=paru(161)
45831 C...Coupling to Z
45832  paru(164)=sbma
45833 C...Coupling to W
45834  paru(165)=paru(164)
45835 
45836 C...Secondly: H
45837 C...Coupling to d-type quarks
45838  paru(171)=-cosa/cosb
45839 C...Coupling to u-type quarks
45840  paru(172)=-sina/sinb
45841 C...Coupling to leptons
45842  paru(173)=paru(171)
45843 C...Coupling to Z
45844  paru(174)=cbma
45845 C...Coupling to W
45846  paru(175)=paru(174)
45847 C...Coupling to h
45848  IF(imss(4).GE.2) THEN
45849  paru(176)=cos(2d0*al)*cos(be+al)-2d0*sin(2d0*al)*sin(be+al)
45850  ELSE
45851  hhh(3)=hhh(3)+hhh(4)+hhh(5)
45852  paru(176)=-3d0/hhh(1)*(hhh(1)*sina**2*cosb*cosa+
45853  1 hhh(2)*cosa**2*sinb*sina+hhh(3)*(sina**3*sinb+cosa**3*cosb-
45854  2 2d0/3d0*cbma)-hhh(6)*sina*(cosb*c2a+cosa*capb)+
45855  3 hhh(7)*cosa*(sinb*c2a+sina*capb))
45856  ENDIF
45857 C...Coupling to H+
45858 C...Define later
45859  IF(imss(4).GE.2) THEN
45860  paru(168)=-sbma-cos(2d0*be)*sapb/2d0/(1d0-xw)
45861  ELSE
45862  paru(168)=1d0/hhh(1)*(hhh(1)*sinb**2*cosb*sina-
45863  1 hhh(2)*cosb**2*sinb*cosa-hhh(3)*(sinb**3*cosa-cosb**3*sina)+
45864  2 2d0*hhh(5)*sbma-hhh(6)*sinb*(cosb*sapb+sina*c2b)-
45865  3 hhh(7)*cosb*(cosa*c2b-sinb*sapb)-(hhh(5)-hhh(4))*sbma)
45866  ENDIF
45867 C...Coupling to A
45868  IF(imss(4).GE.2) THEN
45869  paru(177)=cos(2d0*be)*cos(be+al)
45870  ELSE
45871  paru(177)=-1d0/hhh(1)*(hhh(1)*sinb**2*cosb*cosa+
45872  1 hhh(2)*cosb**2*sinb*sina+hhh(3)*(sinb**3*sina+cosb**3*cosa)-
45873  2 2d0*hhh(5)*cbma-hhh(6)*sinb*(cosb*capb+cosa*c2b)+
45874  3 hhh(7)*cosb*(sinb*capb+sina*c2b))
45875  ENDIF
45876 C...Coupling to H+
45877  IF(imss(4).GE.2) THEN
45878  paru(178)=paru(177)
45879  ELSE
45880  paru(178)=paru(177)-(hhh(5)-hhh(4))/hhh(1)*cbma
45881  ENDIF
45882 C...Thirdly, A
45883 C...Coupling to d-type quarks
45884  paru(181)=tanb
45885 C...Coupling to u-type quarks
45886  paru(182)=1d0/paru(181)
45887 C...Coupling to leptons
45888  paru(183)=paru(181)
45889  paru(184)=0d0
45890  paru(185)=0d0
45891 C...Coupling to Z h
45892  paru(186)=cos(be-al)
45893 C...Coupling to Z H
45894  paru(187)=sin(be-al)
45895  paru(188)=0d0
45896  paru(189)=0d0
45897  paru(190)=0d0
45898 
45899 C...Finally: H+
45900 C...Coupling to W h
45901  paru(195)=cos(be-al)
45902 
45903 C...Tell that all Higgs couplings have been set.
45904  mstp(4)=1
45905 
45906 C...Set R-Violating couplings.
45907 C...Set lambda couplings to common value or "natural values".
45908  IF ((imss(51).NE.3).AND.(imss(51).NE.0)) THEN
45909  vir3=1d0/(126d0)**3
45910  DO 200 irk=1,3
45911  DO 190 iri=1,3
45912  DO 180 irj=1,3
45913  IF (iri.NE.irj) THEN
45914  IF (iri.LT.irj) THEN
45915  rvlam(iri,irj,irk)=rmss(51)
45916  IF (imss(51).EQ.2) rvlam(iri,irj,irk)=rmss(51)*
45917  & sqrt(pmas(9+2*iri,1)*pmas(9+2*irj,1)*
45918  & pmas(9+2*irk,1)*vir3)
45919  ELSE
45920  rvlam(iri,irj,irk)=-rvlam(irj,iri,irk)
45921  ENDIF
45922  ELSE
45923  rvlam(iri,irj,irk)=0d0
45924  ENDIF
45925  180 CONTINUE
45926  190 CONTINUE
45927  200 CONTINUE
45928  ENDIF
45929 C...Set lambda' couplings to common value or "natural values".
45930  IF ((imss(52).NE.3).AND.(imss(52).NE.0)) THEN
45931  vir3=1d0/(126d0)**3
45932  DO 230 iri=1,3
45933  DO 220 irj=1,3
45934  DO 210 irk=1,3
45935  rvlamp(iri,irj,irk)=rmss(52)
45936  IF (imss(52).EQ.2) rvlamp(iri,irj,irk)=rmss(52)*
45937  & sqrt(pmas(9+2*iri,1)*0.5d0*(pmas(2*irj,1)+
45938  & pmas(2*irj-1,1))*pmas(2*irk-1,1)*vir3)
45939  210 CONTINUE
45940  220 CONTINUE
45941  230 CONTINUE
45942  ENDIF
45943 C...Set lambda'' couplings to common value or "natural values".
45944  IF ((imss(53).NE.3).AND.(imss(53).NE.0)) THEN
45945  vir3=1d0/(126d0)**3
45946  DO 260 iri=1,3
45947  DO 250 irj=1,3
45948  DO 240 irk=1,3
45949  IF (irj.NE.irk) THEN
45950  IF (irj.LT.irk) THEN
45951  rvlamb(iri,irj,irk)=rmss(53)
45952  IF (imss(53).EQ.2) rvlamb(iri,irj,irk)=
45953  & rmss(53)*sqrt(pmas(2*iri,1)*pmas(2*irj-1,1)*
45954  & pmas(2*irk-1,1)*vir3)
45955  ELSE
45956  rvlamb(iri,irj,irk)=-rvlamb(iri,irk,irj)
45957  ENDIF
45958  ELSE
45959  rvlamb(iri,irj,irk) = 0d0
45960  ENDIF
45961  240 CONTINUE
45962  250 CONTINUE
45963  260 CONTINUE
45964  ENDIF
45965 
45966 C...Antisymmetrize couplings set by user
45967  IF (imss(51).EQ.3.OR.imss(53).EQ.3) THEN
45968  DO 290 iri=1,3
45969  DO 280 irj=1,3
45970  DO 270 irk=1,3
45971  IF (rvlam(iri,irj,irk).NE.-rvlam(irj,iri,irk)) THEN
45972  rvlam(irj,iri,irk)=-rvlam(iri,irj,irk)
45973  IF (iri.EQ.irj) rvlam(iri,irj,irk)=0d0
45974  ENDIF
45975  IF (rvlamb(iri,irj,irk).NE.-rvlamb(iri,irk,irj)) THEN
45976  rvlamb(iri,irk,irj)=-rvlamb(iri,irj,irk)
45977  IF (irj.EQ.irk) rvlamb(iri,irj,irk)=0d0
45978  ENDIF
45979  270 CONTINUE
45980  280 CONTINUE
45981  290 CONTINUE
45982  ENDIF
45983 
45984 C...Write spectrum to SLHA file
45985  IF (imss(23).NE.0) THEN
45986  ifail=0
45987  CALL pyslha(3,0,ifail)
45988  ENDIF
45989 
45990 C...Second part of routine: set decay modes and branching ratios.
45991 
45992 C...Allow chi10 -> gravitino + gamma or not.
45993  kc=pycomp(ksusy1+39)
45994  IF( imss(11) .NE. 0 ) THEN
45995  pmas(kc,1)=rmss(21)/1d9
45996  pmas(kc,2)=0d0
45997  irprty=0
45998  WRITE(mstu(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45999  ELSE IF (imss(51).GE.1.OR.imss(52).GE.1.OR.imss(53).GE.1) THEN
46000  irprty=0
46001  IF (imss(51).GE.1) WRITE(mstu(11),*)
46002  & ' ALLOWING SUSY LLE DECAYS'
46003  IF (imss(52).GE.1) WRITE(mstu(11),*)
46004  & ' ALLOWING SUSY LQD DECAYS'
46005  IF (imss(53).GE.1) WRITE(mstu(11),*)
46006  & ' ALLOWING SUSY UDD DECAYS'
46007  IF (imss(53).GE.1.AND.imss(52).GE.1) WRITE(mstu(11),*)
46008  & ' --- Warning: R-Violating couplings possibly',
46009  & ' incompatible with proton decay'
46010  ELSE
46011  pmas(kc,1)=9999d0
46012  irprty=1
46013  ENDIF
46014 
46015 C...Loop over sparticle and Higgs species.
46016  pmchi1=pmas(pycomp(ksusy1+22),1)
46017 C...Find the LSP or NLSP for a gravitino LSP
46018  ilsp=0
46019  pmlsp=1d20
46020  DO 300 i=1,36
46021  kf=kfsusy(i)
46022  IF(kf.EQ.1000039) goto 300
46023  kc=pycomp(kf)
46024  IF(pmas(kc,1).LT.pmlsp) THEN
46025  ilsp=i
46026  pmlsp=pmas(kc,1)
46027  ENDIF
46028  300 CONTINUE
46029  DO 370 i=1,50
46030  IF (i.GT.39.AND.imss(13).NE.1) goto 370
46031  kf=kfsusy(i)
46032  IF (kf.EQ.0) goto 370
46033  kc=pycomp(kf)
46034  lknt=0
46035 
46036 C...Check if there are any decays listed for this sparticle
46037 C...in a file
46038  IF (imss(22).NE.0.OR.mstp(161).NE.0) THEN
46039  ifail=0
46040  CALL pyslha(2,kf,ifail)
46041  IF (ifail.EQ.0.OR.kf.EQ.6.OR.kf.EQ.24) goto 370
46042  ELSEIF (i.GE.37) THEN
46043  goto 370
46044  ENDIF
46045 
46046 C...Sfermion decays.
46047  IF(i.LE.24) THEN
46048 C...First check to see if sneutrino is lighter than chi10.
46049  IF((i.EQ.15.OR.i.EQ.19.OR.i.EQ.23).AND.
46050  & pmas(kc,1).LT.pmchi1) THEN
46051  ELSE
46052  CALL pysfdc(kf,xlam,idlam,lknt)
46053  ENDIF
46054 
46055 C...Gluino decays.
46056  ELSEIF(i.EQ.25) THEN
46057  CALL pyglui(kf,xlam,idlam,lknt)
46058  IF(i.EQ.ilsp.AND.irprty.EQ.1) lknt=0
46059 
46060 C...Neutralino decays.
46061  ELSEIF(i.GE.26.AND.i.LE.29) THEN
46062  CALL pynjdc(kf,xlam,idlam,lknt)
46063 C...chi10 stable or chi10 -> gravitino + gamma.
46064  IF(i.EQ.26.AND.irprty.EQ.1) THEN
46065  pmas(kc,2)=1d-6
46066  mdcy(kc,1)=0
46067  mwid(kc)=0
46068  ENDIF
46069 
46070 C...Chargino decays.
46071  ELSEIF(i.GE.30.AND.i.LE.31) THEN
46072  CALL pycjdc(kf,xlam,idlam,lknt)
46073 
46074 C...Gravitino is stable.
46075  ELSEIF(i.EQ.32) THEN
46076  mdcy(kc,1)=0
46077  mwid(kc)=0
46078 
46079 C...Higgs decays.
46080  ELSEIF(i.GE.33.AND.i.LE.36) THEN
46081 C...Calculate decays to non-SUSY particles.
46082  CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
46083  lknt=0
46084  DO 310 i1=0,100
46085  xlam(i1)=0d0
46086  310 CONTINUE
46087  DO 330 i1=1,mdcy(kc,3)
46088  k1=mdcy(kc,2)+i1-1
46089  IF(iabs(kfdp(k1,1)).GT.ksusy1.OR.
46090  & iabs(kfdp(k1,2)).GT.ksusy1) goto 330
46091  xlam(i1)=wdtp(i1)
46092  xlam(0)=xlam(0)+xlam(i1)
46093  DO 320 j1=1,3
46094  idlam(i1,j1)=kfdp(k1,j1)
46095  320 CONTINUE
46096  lknt=lknt+1
46097  330 CONTINUE
46098 C...Add the decays to SUSY particles.
46099  CALL pyhext(kf,xlam,idlam,lknt)
46100  ENDIF
46101 C...Zero the branching ratios for use in loop mode
46102 C...thanks to K. Matchev (FNAL)
46103  DO 340 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46104  brat(idc)=0d0
46105  340 CONTINUE
46106 
46107 C...Set stable particles.
46108  IF(lknt.EQ.0) THEN
46109  mdcy(kc,1)=0
46110  mwid(kc)=0
46111  pmas(kc,2)=1d-6
46112  pmas(kc,3)=1d-5
46113  pmas(kc,4)=0d0
46114 
46115 C...Store branching ratios in the standard tables.
46116  ELSE
46117  idc=mdcy(kc,2)+mdcy(kc,3)-1
46118  delm=1d6
46119  DO 360 il=1,lknt
46120  idcsv=idc
46121  350 idc=idc+1
46122  brat(idc)=0d0
46123  IF(idc.EQ.mdcy(kc,2)+mdcy(kc,3)) idc=mdcy(kc,2)
46124  IF(idlam(il,1).EQ.kfdp(idc,1).AND.idlam(il,2).EQ.
46125  & kfdp(idc,2).AND.idlam(il,3).EQ.kfdp(idc,3)) THEN
46126  brat(idc)=xlam(il)/xlam(0)
46127  xmdif=pmas(kc,1)
46128  IF(mdme(idc,1).GE.1) THEN
46129  xmdif=xmdif-pmas(pycomp(kfdp(idc,1)),1)-
46130  & pmas(pycomp(kfdp(idc,2)),1)
46131  IF(kfdp(idc,3).NE.0) xmdif=xmdif-
46132  & pmas(pycomp(kfdp(idc,3)),1)
46133  ENDIF
46134  IF(i.LE.32) THEN
46135  IF(xmdif.GE.0d0) THEN
46136  delm=min(delm,xmdif)
46137  ELSE
46138  WRITE(mstu(11),*) ' ERROR WITH DELM ',delm,xmdif
46139  WRITE(mstu(11),*) ' KF = ',kf
46140  WRITE(mstu(11),*) ' KF(decay) = ',(kfdp(idc,j),j=1,3)
46141  ENDIF
46142  ENDIF
46143  goto 360
46144  ELSEIF(idc.EQ.idcsv) THEN
46145  WRITE(mstu(11),*) ' Error in PYMSIN: SUSY decay ',
46146  & 'channel not recognized:'
46147  WRITE(mstu(11),*) kf,' -> ',(idlam(il,j),j=1,3)
46148  goto 360
46149  ELSE
46150  goto 350
46151  ENDIF
46152  360 CONTINUE
46153 
46154 C...Store width, cutoff and lifetime.
46155  pmas(kc,2)=xlam(0)
46156  IF(pmas(kc,2).LT.0.1d0*delm) THEN
46157  pmas(kc,3)=pmas(kc,2)*10d0
46158  ELSE
46159  pmas(kc,3)=0.95d0*delm
46160  ENDIF
46161  IF(pmas(kc,2).NE.0d0) THEN
46162  pmas(kc,4)=paru(3)/pmas(kc,2)*1d-12
46163  ENDIF
46164 C...Write decays to SLHA file
46165  IF (imss(24).NE.0) THEN
46166  ifail=0
46167  CALL pyslha(4,kf,ifail)
46168  ENDIF
46169 
46170  ENDIF
46171  370 CONTINUE
46172 
46173  RETURN
46174  END
46175 C*********************************************************************
46176 
46177 C...PYSLHA
46178 C...Read/write spectrum or decay data from SLHA standard file(s).
46179 C...P. Skands
46180 C...DECAY TABLE writeout by Nils-Erik Bomark (2010)
46181 
46182 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
46183 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
46184 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
46185 C... (KFORIG=0 : read all decay tables)
46186 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
46187 C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24)
46188 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
46189 C... (KFORIG=0 : read all MASS entries)
46190 
46191  SUBROUTINE pyslha(MUPDA,KFORIG,IRETRN)
46192 
46193 C...Double precision and integer declarations.
46194  IMPLICIT DOUBLE PRECISION(a-h, o-z)
46195  IMPLICIT INTEGER(i-n)
46196  INTEGER pyk,pychge,pycomp
46197  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
46198  &kexcit=4000000,kdimen=5000000)
46199 C...Commonblocks.
46200  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46201  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
46202  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
46203  common/pydat4/chaf(500,2)
46204  CHARACTER chaf*16
46205  common/pypars/mstp(200),parp(200),msti(200),pari(200)
46206  CHARACTER*40 isaver,visaje
46207  common/pyint4/mwid(500),wids(500,5)
46208  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pypars/,/pyint4/
46209 C...SUSY blocks
46210  common/pymssm/imss(0:99),rmss(0:99)
46211  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
46212  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
46213  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
46214  SAVE /pymssm/,/pyssmt/,/pymsrv/
46215 
46216 C...Local arrays, character variables and data.
46217  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
46218  & au(3,3),ad(3,3),ae(3,3)
46219  common/pylh3c/cpro(2),cver(2)
46220 C...The common block of new states (QNUMBERS / PARTICLE)
46221  common/pyqnum/nqnum,nqdum,kqnum(500,0:9)
46222 C...- NQNUM : Number of QNUMBERS blocks that have been read in
46223 C...- KQNUM(I,0) : KF of new state
46224 C...- KQNUM(I,1) : 3 times electric charge
46225 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
46226 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
46227 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
46228 C...- KQNUM(I,5:9) : space available for further quantum numbers
46229  dimension mmod(100),mspc(100),kfdec(100)
46230  SAVE /pylh3p/,/pylh3c/,/pyqnum/,mmod,mspc,kfdec
46231 C...MMOD: flags to set for each block read in.
46232 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
46233 C...MSPC: Flags to set for each block read in.
46234 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
46235 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
46236 C...11: AD 12: AE 13: YU 14: YD 15: YE
46237 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
46238  CHARACTER cpro*12,cver*12,chnlin*6
46239  CHARACTER doc*11, chdum*120, chblck*60
46240  CHARACTER chinl*120,chkf*9,chtmp*16
46241  INTEGER verbos
46242  SAVE verbos
46243 C...Date of last Change
46244  parameter(doc='26 Feb 2013')
46245 C...Local arrays and initial values
46246  dimension idc(5),kfsusy(50)
46247  SAVE kfsusy
46248  DATA nqnum /0/
46249  DATA ndecay /0/
46250  DATA verbos /1/
46251  DATA nhello /0/
46252  DATA mlhef /0/
46253  DATA mlhefd /0/
46254  DATA kfsusy/
46255  &1000001,1000002,1000003,1000004,1000005,1000006,
46256  &2000001,2000002,2000003,2000004,2000005,2000006,
46257  &1000011,1000012,1000013,1000014,1000015,1000016,
46258  &2000011,2000012,2000013,2000014,2000015,2000016,
46259  &1000021,1000022,1000023,1000025,1000035,1000024,
46260  &1000037,1000039, 25, 35, 36, 37,
46261  & 6, 24, 45, 46,1000045, 9*0/
46262  DATA kfdec/100*0/
46263  rmfun(ip)=pmas(pycomp(ip),1)
46264 
46265 C...Shorthand for spectrum and decay table unit numbers
46266  imss21=imss(21)
46267  imss22=imss(22)
46268 
46269 C...Default for LHEF input: read header information
46270  IF (imss21.EQ.0.AND.mstp(161).NE.0) imss21=mstp(161)
46271  IF (imss22.EQ.0.AND.mstp(161).NE.0) imss22=mstp(161)
46272  IF (imss21.EQ.mstp(161).AND.imss21.NE.0) mlhef=1
46273  IF (imss22.EQ.mstp(161).AND.imss22.NE.0) mlhefd=1
46274 
46275 C...Hello World
46276  IF (nhello.EQ.0) THEN
46277  IF ((mlhef.NE.1.AND.mlhefd.NE.1).OR.(imss(1).NE.0)) THEN
46278  WRITE(mstu(11),5000) doc
46279  nhello=1
46280  ENDIF
46281  ENDIF
46282 
46283 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
46284 C...+MUPDA).
46285  lfn=imss21
46286  IF (mupda.EQ.2) lfn=imss22
46287  IF (mupda.EQ.3) lfn=imss(23)
46288  IF (mupda.EQ.4) lfn=imss(24)
46289 C...Flag that we have not yet found whatever we were asked to find.
46290  iretrn=1
46291 C...Flag that we are skipping until <slha> tag found (if LHEF)
46292  iskip=0
46293  IF (mlhef.EQ.1.OR.mlhefd.EQ.1) iskip=1
46294 
46295 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46296  IF (lfn.EQ.0) THEN
46297  WRITE(mstu(11),*) '* (PYSLHA:) No valid unit given in IMSS'
46298  goto 9999
46299  ENDIF
46300 
46301 C...If reading LHEF header, start by rewinding file
46302  IF (mlhef.EQ.1.OR.mlhefd.EQ.1) rewind(lfn)
46303 
46304 C...If told to read spectrum, first zero all previous information.
46305  IF (mupda.EQ.1) THEN
46306 C...Zero all block read flags
46307  DO 100 m=1,100
46308  mmod(m)=0
46309  mspc(m)=0
46310  100 CONTINUE
46311 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
46312  DO 110 isusy=1,36
46313  kc=pycomp(kfsusy(isusy))
46314  pmas(kc,1)=0d0
46315  110 CONTINUE
46316 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
46317  DO 130 j=1,4
46318  sfmix(5,j) =0d0
46319  sfmix(6,j) =0d0
46320  sfmix(15,j)=0d0
46321  DO 120 l=1,4
46322  zmix(l,j) =0d0
46323  zmixi(l,j)=0d0
46324  IF (j.LE.2.AND.l.LE.2) THEN
46325  umix(l,j) =0d0
46326  umixi(l,j)=0d0
46327  vmix(l,j) =0d0
46328  vmixi(l,j)=0d0
46329  ENDIF
46330  120 CONTINUE
46331 C...Zero signed masses.
46332  smz(j)=0d0
46333  IF (j.LE.2) smw(j)=0d0
46334  130 CONTINUE
46335 
46336 C...If reading decays, reset PYTHIA decay counters.
46337  ELSEIF (mupda.EQ.2) THEN
46338 C...Check if DECAY for this KF already read
46339  IF (kforig.NE.0) THEN
46340  DO 140 idec=1,ndecay
46341  IF (kforig.EQ.kfdec(idec)) THEN
46342  iretrn=0
46343  RETURN
46344  ENDIF
46345  140 CONTINUE
46346  ENDIF
46347  kcc=100
46348  ndc=0
46349  brsum=0d0
46350  DO 150 kc=1,mstu(6)
46351  IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
46352  ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
46353  150 CONTINUE
46354  ELSEIF (mupda.EQ.5) THEN
46355 C...Zero block read flags
46356  DO 160 m=1,100
46357  mspc(m)=0
46358  160 CONTINUE
46359  ENDIF
46360 
46361 C............READ
46362 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
46363  IF(mupda.EQ.0.OR.mupda.EQ.1.OR.mupda.EQ.2.OR.mupda.EQ.5) THEN
46364 C...Initialize program and version strings
46365  IF(mupda.EQ.1.OR.mupda.EQ.2) THEN
46366  cpro(mupda)=' '
46367  cver(mupda)=' '
46368  ENDIF
46369 
46370 C...Initialize read loop
46371  merr=0
46372  nline=0
46373  chblck=' '
46374 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
46375  170 chinl=' '
46376  READ(lfn,'(A120)',end=400) chinl
46377 C...Count which line number we're at.
46378  nline=nline+1
46379  WRITE(chnlin,'(I6)') nline
46380 
46381 C...Skip comment and empty lines without processing.
46382  IF (chinl(1:1).EQ.'#'.OR.chinl.EQ.' ') goto 170
46383 
46384 C...We assume all upper case below. Rewrite CHINL to all upper case.
46385  inl=0
46386  igood=0
46387  180 inl=inl+1
46388  IF (chinl(inl:inl).NE.'#') THEN
46389  DO 190 ich=97,122
46390  IF (char(ich).EQ.chinl(inl:inl)) chinl(inl:inl)=char(ich-32)
46391  190 CONTINUE
46392 C...Extra safety. Chek for sensible input on line
46393  IF (igood.EQ.0) THEN
46394  DO 200 ich=48,90
46395  IF (char(ich).EQ.chinl(inl:inl)) igood=1
46396  200 CONTINUE
46397  ENDIF
46398  IF (inl.LT.120) goto 180
46399  ENDIF
46400  IF (igood.EQ.0) goto 170
46401 
46402 C...If reading from LHEF file, skip until <slha> begin tag found
46403  IF (iskip.NE.0) THEN
46404  DO 205 i1=1,10
46405  IF (chinl(i1:i1+4).EQ.'<SLHA') iskip=0
46406  205 CONTINUE
46407  IF (iskip.NE.0) goto 170
46408  ENDIF
46409 
46410 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
46411  DO 210 i1=1,10
46412  IF (chinl(i1:i1+5).EQ.'</SLHA'
46413  & .OR.chinl(i1:i1+5).EQ.'<EVENT'
46414  & .OR.chinl(i1:i1+4).EQ.'<INIT') THEN
46415  rewind(lfn)
46416  goto 400
46417  ENDIF
46418  210 CONTINUE
46419 
46420 C...Check for BLOCK begin statement (spectrum).
46421  IF (chinl(1:5).EQ.'BLOCK') THEN
46422  merr=0
46423  READ(chinl,'(A6,A)',err=580) chdum,chblck
46424 C...Check if another of this type of block was already read.
46425 C...(logarithmic interpolation not yet implemented, so duplicates always
46426 C...give errors)
46427  IF (chblck(1:6).EQ.'MODSEL'.AND.mmod(1).NE.0) merr=7
46428  IF (chblck(1:6).EQ.'MINPAR'.AND.mmod(2).NE.0) merr=7
46429  IF (chblck(1:6).EQ.'EXTPAR'.AND.mmod(3).NE.0) merr=7
46430  IF (chblck(1:8).EQ.'SMINPUTS'.AND.mmod(4).NE.0) merr=7
46431  IF (chblck(1:4).EQ.'MASS'.AND.mspc(1).NE.0) merr=7
46432  IF (chblck(1:4).EQ.'NMIX'.AND.mspc(2).NE.0) merr=7
46433  IF (chblck(1:4).EQ.'UMIX'.AND.mspc(3).NE.0) merr=7
46434  IF (chblck(1:4).EQ.'VMIX'.AND.mspc(4).NE.0) merr=7
46435  IF (chblck(1:7).EQ.'SBOTMIX'.AND.mspc(5).NE.0) merr=7
46436  IF (chblck(1:7).EQ.'STOPMIX'.AND.mspc(6).NE.0) merr=7
46437  IF (chblck(1:7).EQ.'STAUMIX'.AND.mspc(7).NE.0) merr=7
46438  IF (chblck(1:4).EQ.'HMIX'.AND.mspc(8).NE.0) merr=7
46439  IF (chblck(1:5).EQ.'ALPHA'.AND.mspc(17).NE.0) merr=7
46440  IF (chblck(1:5).EQ.'AU'.AND.mspc(10).NE.0) merr=7
46441  IF (chblck(1:5).EQ.'AD'.AND.mspc(11).NE.0) merr=7
46442  IF (chblck(1:5).EQ.'AE'.AND.mspc(12).NE.0) merr=7
46443  IF (chblck(1:5).EQ.'MSOFT'.AND.mspc(18).NE.0) merr=7
46444 C...Check for new particles
46445  IF (chblck(1:8).EQ.'QNUMBERS'.OR.chblck(1:8).EQ.'PARTICLE')
46446  & THEN
46447  mspc(19)=mspc(19)+1
46448 C...Read PDG code
46449  READ(chblck(9:60),*) kfq
46450 
46451  DO 220 mq=1,nqnum
46452  IF (kqnum(mq,0).EQ.kfq) THEN
46453  merr=17
46454  goto 380
46455  ENDIF
46456  220 CONTINUE
46457  IF (nhello.EQ.0) THEN
46458  WRITE(mstu(11),5000) doc
46459  nhello=1
46460  ENDIF
46461  nqnum=nqnum+1
46462  kqnum(nqnum,0)=kfq
46463  mspc(19)=mspc(19)+1
46464  kcq=pycomp(kfq)
46465 C...Only read in new codes (also OK to overwrite if KF > 3000000)
46466  IF (kcq.EQ.0.OR.iabs(kfq).GE.3000000) THEN
46467  IF (kcq.EQ.0) THEN
46468  DO 230 kct=100,mstu(6)
46469  IF(kchg(kct,4).GT.100) kcq=kct
46470  230 CONTINUE
46471  kcq=kcq+1
46472  ENDIF
46473 C...More than 25 new QNUMBERS: fill up empty space before UED
46474  IF (kcq.GT.500) THEN
46475  kcq=0
46476  DO 235 kct=100,450
46477  IF(kchg(kct,4).GT.100) kcq=kct
46478  235 CONTINUE
46479  kcq=kcq+1
46480  IF (kcq.EQ.451) THEN
46481  WRITE(mstu(11),*)
46482  & '* (PYSLHA:) Warning: too many QNUMBERS. ',
46483  & 'Starting overwrite of UED particles.'
46484  ELSE IF (kcq.EQ.476) THEN
46485  WRITE(mstu(11),*)
46486  & '* (PYSLHA:) Error: too many QNUMBERS. ',
46487  & 'Ran out of space, sorry! Try Pythia 8.'
46488  kcq = 501
46489  ENDIF
46490  ENDIF
46491 C...End of special case for more than 25 new QNUMERS
46492  IF (kcq.LE.500) THEN
46493  WRITE(mstu(11),'(A,I9,A,I4,A)')
46494  & ' * (PYSLHA:) Reading '//chblck(1:8)//
46495  & ' for KF =',kfq,' (assigned KC',kcq,')'
46496  kcc=kcq
46497  kchg(kcq,4)=kfq
46498 C... First write PDG code as name
46499  WRITE(chtmp,*) kfq
46500  WRITE(chtmp,'(A)') chtmp(2:10)
46501 C... Then look for real name
46502  ibeg=9
46503  240 ibeg=ibeg+1
46504  IF (chblck(ibeg:ibeg).NE.'#'.AND.ibeg.LT.59) goto 240
46505  250 ibeg=ibeg+1
46506  IF (chblck(ibeg:ibeg).EQ.' '.AND.ibeg.LT.59) goto 250
46507  iend=ibeg-1
46508  260 iend=iend+1
46509  IF (chblck(iend+1:iend+1).NE.' '.AND.iend.LT.59)
46510  & goto 260
46511  IF (iend.LT.59) THEN
46512  READ(chblck(ibeg:iend),'(A)',err=270) chdum
46513  IF (chdum.NE.' ') chtmp=chdum
46514  ENDIF
46515  270 READ(chtmp,'(A)') chaf(kcq,1)
46516  mstu(20)=0
46517 C... Set stable for now
46518  pmas(kcq,2)=1d-6
46519  mwid(kcq)=0
46520  mdcy(kcq,1)=0
46521  mdcy(kcq,2)=0
46522  mdcy(kcq,3)=0
46523  ENDIF
46524  ELSE
46525  WRITE(mstu(11),'(A,I9,A)')
46526  & ' * (PYSLHA:) Warning! Failed to read '
46527  & //chblck(1:8)//' for KF =',kfq,
46528  & ' (entry reserved by PYTHIA)'
46529  merr=7
46530  ENDIF
46531  ENDIF
46532 C... Finalize this line and read next.
46533  goto 380
46534 C...Check for DECAY begin statement (decays).
46535  ELSEIF (chinl(1:3).EQ.'DEC') THEN
46536  merr=0
46537  brsum=0d0
46538  chblck='DECAY'
46539 C...Read KF code and WIDTH
46540  mpsign=1
46541  READ(chinl(7:inl),*,err=590) kf, width
46542  IF (kf.LE.0) THEN
46543  kf=-kf
46544  mpsign=-1
46545  ENDIF
46546 C...If this is not the KF we're looking for...
46547  IF ((kforig.NE.0.AND.kf.NE.kforig).OR.mupda.NE.2) THEN
46548 C...Set block skip flag and read next line.
46549  merr=16
46550  goto 380
46551  ELSE
46552 C...Check whether decay table for this particle already read in
46553  DO 280 idecay=1,ndecay
46554  IF (kfdec(idecay).EQ.kf) THEN
46555  WRITE(mstu(11),'(A,A,I9,A,A6,A)')
46556  & ' * (PYSLHA:) Ignoring DECAY table ',
46557  & 'for KF =',kf,' on line ',chnlin,
46558  & ' (duplicate)'
46559  merr=16
46560  goto 380
46561  ENDIF
46562  280 CONTINUE
46563  ENDIF
46564 
46565 C...Determine PYTHIA KC code of particle
46566  kcrep=0
46567  IF(kf.LE.100) THEN
46568  kcrep=kf
46569  ELSE
46570  DO 290 kcr=101,kcc
46571  IF(kchg(kcr,4).EQ.kf) kcrep=kcr
46572  290 CONTINUE
46573  ENDIF
46574  kc=kcrep
46575  IF (kcrep.NE.0) THEN
46576 C...Particle is already known. Do not overwrite low-mass SM particles,
46577 C...since this could give problems at hadronization / hadron decay stage.
46578  IF (iabs(kf).LT.1000000.AND.pmas(kc,1).LT.20d0) THEN
46579 C...Set block skip flag and read next line
46580  WRITE(mstu(11),'(A,I9,A,F12.3)')
46581  & ' * (PYSLHA:) Ignoring DECAY table for KF =',
46582  & kf, ' (SLHA read-in not allowed)'
46583  merr=16
46584  goto 380
46585  ELSEIF (iabs(kf).EQ.6.OR.iabs(kf).EQ.23.OR.iabs(kf).EQ.24)
46586  & THEN
46587 C...Set block skip flag and read next line
46588  WRITE(mstu(11),'(A,I9,A,F12.3)')
46589  & ' * (PYSLHA:) Allowing DECAY table for KF =',
46590  & kf, ' but this is NOT recommended.'
46591  ENDIF
46592  ELSE
46593 C... Add new particle. Actually, this should not happen.
46594 C... New particles should be added already when reading the spectrum
46595 C... information, so go under previously stable category.
46596  kcc=kcc+1
46597  kc=kcc
46598  ENDIF
46599 
46600  IF (width.LE.0d0) THEN
46601 C...Stable (i.e. LSP)
46602  WRITE(mstu(11),'(A,I9,A,A)')
46603  & ' * (PYSLHA:) Reading SLHA stable particle KF =',
46604  & kf,', ',chaf(kcrep,1)(1:16)
46605  IF (width.LT.0d0) THEN
46606  CALL pyerrm(19,'(PYSLHA:) Negative width forced to'//
46607  & ' zero !')
46608  width=0d0
46609  ENDIF
46610  pmas(kc,2)=1d-6
46611  mwid(kc)=0
46612  mdcy(kc,1)=0
46613 C...Ignore any decay lines that may be present for this KF
46614  merr=16
46615  mdcy(kc,2)=0
46616  mdcy(kc,3)=0
46617 C...Return ok
46618  iretrn=0
46619  ENDIF
46620 C...Finalize and start reading in decay modes.
46621  goto 380
46622  ELSEIF (mod(merr,10).GE.6) THEN
46623 C...If ignore block flag set, skip directly to next line.
46624  goto 170
46625  ENDIF
46626 
46627 C...READ SPECTRUM
46628  IF (mupda.EQ.0.AND.merr.EQ.0) THEN
46629  IF (chblck(1:8).EQ.'QNUMBERS'.OR.chblck(1:8).EQ.'PARTICLE')
46630  & THEN
46631  READ(chinl,*) indx, ival
46632  IF (indx.GE.1.AND.indx.LE.9) kqnum(nqnum,indx)=ival
46633  IF (indx.EQ.1) kchg(kcq,1)=ival
46634  IF (indx.EQ.3) kchg(kcq,2)=0
46635  IF (indx.EQ.3.AND.ival.EQ.3) kchg(kcq,2)=1
46636  IF (indx.EQ.3.AND.ival.EQ.-3) kchg(kcq,2)=-1
46637  IF (indx.EQ.3.AND.ival.EQ.8) kchg(kcq,2)=2
46638  IF (indx.EQ.4) THEN
46639  kchg(kcq,3)=ival
46640  IF (ival.EQ.1) THEN
46641  chtmp=chaf(kcq,1)
46642  IF (chtmp.EQ.' ') THEN
46643  WRITE(chaf(kcq,1),*) kchg(kcq,4)
46644  WRITE(chaf(kcq,2),*) -kchg(kcq,4)
46645  ELSE
46646  ilast=17
46647  300 ilast=ilast-1
46648  IF (chtmp(ilast:ilast).EQ.' ') goto 300
46649  IF (chtmp(ilast:ilast).EQ.'+') THEN
46650  chtmp(ilast:ilast)='-'
46651  ELSE
46652  chtmp(ilast+1:min(16,ilast+4))='bar'
46653  ENDIF
46654  chaf(kcq,2)=chtmp
46655  ENDIF
46656  ENDIF
46657  ENDIF
46658  ELSE
46659  merr=8
46660  ENDIF
46661  ELSEIF ((mupda.EQ.1.OR.mupda.EQ.5).AND.merr.EQ.0) THEN
46662 C...MASS: Mass spectrum
46663  IF (chblck(1:4).EQ.'MASS') THEN
46664  READ(chinl,*) kf, val
46665  merr=1
46666  kc=0
46667  IF (mupda.EQ.1.OR.kf.EQ.kforig.OR.kforig.EQ.0) THEN
46668 C...Read in masses for almost anything
46669  merr=0
46670  kc=pycomp(kf)
46671  IF (kc.NE.0) THEN
46672 C...Don't read in masses for special code particles
46673  IF (iabs(kf).GE.80.AND.iabs(kf).LT.100) THEN
46674  WRITE(mstu(11),'(A,I9,A,F12.3)')
46675  & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46676  & kf, ' (KF reserved by PYTHIA)'
46677  goto 170
46678  ENDIF
46679 C...Be careful with light SM particles / hadrons
46680  IF (pmas(kc,1).LE.20d0) THEN
46681  IF (iabs(kf).LE.22) THEN
46682  WRITE(mstu(11),'(A,I9,A,F12.3)')
46683  & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46684  & kf, ' (SLHA read-in not allowed)'
46685 
46686  goto 170
46687  ELSEIF (iabs(kf).GE.100.AND.iabs(kf).LT.1000000) THEN
46688  WRITE(mstu(11),'(A,I9,A,F12.3)')
46689  & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46690  & kf, ' (SLHA read-in not allowed)'
46691  goto 170
46692  ENDIF
46693  ENDIF
46694  mspc(1)=mspc(1)+1
46695  pmas(kc,1) = abs(val)
46696  IF (mupda.EQ.5.AND.imss(1).EQ.0) THEN
46697  WRITE(mstu(11),'(A,I9,A,F12.3)')
46698  & ' * (PYSLHA:) Reading MASS entry for KF =',
46699  & kf, ', pole mass =', val
46700  iretrn=0
46701  ENDIF
46702 C...Check Z, W and top masses
46703  IF (kf.EQ.23.AND.abs(pmas(pycomp(23),1)-91.2d0).GT.1d0)
46704  & THEN
46705  WRITE(chtmp,8500) pmas(pycomp(23),1)
46706  CALL pyerrm(9,'(PYSLHA:) Note Z boson mass, M ='
46707  & //chtmp)
46708  ENDIF
46709  IF (kf.EQ.24.AND.abs(pmas(pycomp(24),1)-80.4d0).GT.1d0)
46710  & THEN
46711  WRITE(chtmp,8500) pmas(pycomp(24),1)
46712  CALL pyerrm(9,'(PYSLHA:) Note W boson mass, M ='
46713  & //chtmp)
46714  ENDIF
46715  IF (kf.EQ.6.AND.abs(pmas(pycomp(6),1)-175d0).GT.25d0)
46716  & THEN
46717  WRITE(chtmp,8500) pmas(pycomp(6),1)
46718  CALL pyerrm(9,'(PYSLHA:) Note top quark mass, M ='
46719  & //chtmp//'GeV')
46720  ENDIF
46721 C... Signed masses
46722  IF (kf.EQ.1000021.AND.mspc(18).EQ.0) rmss(3)=val
46723  IF (kf.EQ.1000022) smz(1)=val
46724  IF (kf.EQ.1000023) smz(2)=val
46725  IF (kf.EQ.1000025) smz(3)=val
46726  IF (kf.EQ.1000035) smz(4)=val
46727  IF (kf.EQ.1000024) smw(1)=val
46728  IF (kf.EQ.1000037) smw(2)=val
46729 C... Also store gravitino mass in RMSS(21), translated to eV unit
46730  IF (kf.EQ.1000039) rmss(21) = 1d9 * val
46731  ENDIF
46732  ELSEIF (mupda.EQ.5) THEN
46733  merr=0
46734  ENDIF
46735 C... MODSEL: Model selection and global switches
46736  ELSEIF (chblck(1:6).EQ.'MODSEL') THEN
46737  READ(chinl,*) indx, ival
46738  IF (indx.LE.200.AND.indx.GT.0) THEN
46739  IF (imss(1).EQ.0) imss(1)=11
46740  modsel(indx)=ival
46741  mmod(1)=mmod(1)+1
46742  IF (indx.EQ.3.AND.ival.EQ.1.AND.pycomp(1000045).EQ.0) THEN
46743 C... Switch on NMSSM
46744  WRITE(mstu(11),*) '* (PYSLHA:) switching on NMSSM'
46745  imss(13)=max(1,imss(13))
46746 C... Add NMSSM states if not already done
46747 
46748  kfn=25
46749  kcn=kfn
46750  chaf(kcn,1)='h_10'
46751  chaf(kcn,2)=' '
46752 
46753  kfn=35
46754  kcn=kfn
46755  chaf(kcn,1)='h_20'
46756  chaf(kcn,2)=' '
46757 
46758  kfn=45
46759  kcn=kfn
46760  chaf(kcn,1)='h_30'
46761  chaf(kcn,2)=' '
46762 
46763  kfn=36
46764  kcn=kfn
46765  chaf(kcn,1)='A_10'
46766  chaf(kcn,2)=' '
46767 
46768  kfn=46
46769  kcn=kfn
46770  chaf(kcn,1)='A_20'
46771  chaf(kcn,2)=' '
46772 
46773  kfn=1000045
46774  kcn=pycomp(kfn)
46775  IF (kcn.EQ.0) THEN
46776  DO 310 kct=100,mstu(6)
46777  IF(kchg(kct,4).GT.100) kcn=kct
46778  310 CONTINUE
46779  kcn=kcn+1
46780  kchg(kcn,4)=kfn
46781  mstu(20)=0
46782  ENDIF
46783 C... Set stable for now
46784  pmas(kcn,2)=1d-6
46785  mwid(kcn)=0
46786  mdcy(kcn,1)=0
46787  mdcy(kcn,2)=0
46788  mdcy(kcn,3)=0
46789  chaf(kcn,1)='~chi_50'
46790  chaf(kcn,2)=' '
46791  ENDIF
46792  ELSE
46793  merr=1
46794  ENDIF
46795  ELSEIF (mupda.EQ.5) THEN
46796 C...If MUPDA = 5, skip all except MASS, return if MODSEL
46797  merr=8
46798  ELSEIF (chblck(1:8).EQ.'QNUMBERS'.OR.
46799  & chblck(1:8).EQ.'PARTICLE') THEN
46800 C...Don't print a warning for QNUMBERS when reading spectrum
46801  merr=8
46802 C...MINPAR: Minimal model parameters
46803  ELSEIF (chblck(1:6).EQ.'MINPAR') THEN
46804  READ(chinl,*) indx, val
46805  IF (indx.LE.100.AND.indx.GT.0) THEN
46806  parmin(indx)=val
46807  mmod(2)=mmod(2)+1
46808  ELSE
46809  merr=1
46810  ENDIF
46811  IF (mmod(3).NE.0) THEN
46812  WRITE(mstu(11),*)
46813  & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46814  merr=1
46815  ENDIF
46816 C...tan(beta)
46817  IF (indx.EQ.3) rmss(5)=val
46818 C...EXTPAR: non-minimal model parameters.
46819  ELSEIF (chblck(1:6).EQ.'EXTPAR') THEN
46820  IF (mmod(1).NE.0) THEN
46821  READ(chinl,*) indx, val
46822  IF (indx.LE.200.AND.indx.GT.0) THEN
46823  parext(indx)=val
46824  mmod(3)=mmod(3)+1
46825  ELSE
46826  merr=1
46827  ENDIF
46828  ELSE
46829  WRITE(mstu(11),*)
46830  & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46831  merr=1
46832  ENDIF
46833 C...tan(beta)
46834  IF (indx.EQ.25) rmss(5)=val
46835  ELSEIF (chblck(1:8).EQ.'SMINPUTS') THEN
46836  READ(chinl,*) indx, val
46837  IF (indx.LE.3.OR.indx.EQ.5.OR.indx.GE.7) THEN
46838  merr=1
46839  ELSEIF (indx.EQ.4) THEN
46840  pmas(pycomp(23),1)=val
46841  ELSEIF (indx.EQ.6) THEN
46842  pmas(pycomp(6),1)=val
46843  ENDIF
46844  ELSEIF (chblck(1:4).EQ.'NMIX'.OR.chblck(1:4).EQ.'VMIX'.or
46845  $ .chblck(1:4).EQ.'UMIX'.OR.chblck(1:7).EQ.'STOPMIX'.or
46846  $ .chblck(1:7).EQ.'SBOTMIX'.OR.chblck(1:7).EQ.'STAUMIX')
46847  $ THEN
46848 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46849  im=0
46850  IF (chblck(5:6).EQ.'IM') im=1
46851  320 READ(chinl,*) indx1, indx2, val
46852  IF (chblck(1:1).EQ.'N'.AND.indx1.LE.4.AND.indx2.LE.4) THEN
46853  IF (im.EQ.0) zmix(indx1,indx2) = val
46854  IF (im.EQ.1) zmixi(indx1,indx2)= val
46855  mspc(2)=mspc(2)+1
46856  ELSEIF (chblck(1:1).EQ.'U') THEN
46857  IF (im.EQ.0) umix(indx1,indx2) = val
46858  IF (im.EQ.1) umixi(indx1,indx2)= val
46859  mspc(3)=mspc(3)+1
46860  ELSEIF (chblck(1:1).EQ.'V') THEN
46861  IF (im.EQ.0) vmix(indx1,indx2) = val
46862  IF (im.EQ.1) vmixi(indx1,indx2)= val
46863  mspc(4)=mspc(4)+1
46864  ELSEIF (chblck(1:4).EQ.'STOP'.OR.chblck(1:4).EQ.'SBOT'.or
46865  $ .chblck(1:4).EQ.'STAU') THEN
46866  IF (chblck(1:4).EQ.'STOP') THEN
46867  kfsm=6
46868  ispc=6
46869  ELSEIF (chblck(1:4).EQ.'SBOT') THEN
46870  kfsm=5
46871  ispc=5
46872  ELSEIF (chblck(1:4).EQ.'STAU') THEN
46873  kfsm=15
46874  ispc=7
46875  ENDIF
46876 C...Set SFMIX element
46877  sfmix(kfsm,2*(indx1-1)+indx2)=val
46878  mspc(ispc)=mspc(ispc)+1
46879  ENDIF
46880 C...Running parameters
46881  ELSEIF (chblck(1:4).EQ.'HMIX') THEN
46882  READ(chblck(8:25),*,err=620) q
46883  READ(chinl,*) indx, val
46884  mspc(8)=mspc(8)+1
46885  IF (indx.EQ.1) THEN
46886  rmss(4) = val
46887  ELSE
46888  merr=1
46889  mspc(8)=mspc(8)-1
46890  ENDIF
46891  ELSEIF (chblck(1:5).EQ.'ALPHA') THEN
46892  READ(chinl,*,err=630) val
46893  rmss(18)= val
46894  mspc(17)=mspc(17)+1
46895 C...Higgs parameters set manually or with FeynHiggs.
46896  imss(4)=max(2,imss(4))
46897  ELSEIF (chblck(1:2).EQ.'AU'.OR.chblck(1:2).EQ.'AD'.or
46898  & .chblck(1:2).EQ.'AE') THEN
46899  READ(chblck(9:26),*,err=620) q
46900  READ(chinl,*) indx1, indx2, val
46901  IF (chblck(2:2).EQ.'U') THEN
46902  au(indx1,indx2)=val
46903  IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(16)=val
46904  mspc(11)=mspc(11)+1
46905  ELSEIF (chblck(2:2).EQ.'D') THEN
46906  ad(indx1,indx2)=val
46907  IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(15)=val
46908  mspc(10)=mspc(10)+1
46909  ELSEIF (chblck(2:2).EQ.'E') THEN
46910  ae(indx1,indx2)=val
46911  IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(17)=val
46912  mspc(12)=mspc(12)+1
46913  ELSE
46914  merr=1
46915  ENDIF
46916  ELSEIF (chblck(1:5).EQ.'MSOFT') THEN
46917  IF (mspc(18).EQ.0) THEN
46918  READ(chblck(9:25),*,err=620) q
46919  rmsoft(0)=q
46920  ENDIF
46921  READ(chinl,*) indx, val
46922  rmsoft(indx)=val
46923  mspc(18)=mspc(18)+1
46924  ELSEIF (chblck(1:5).EQ.'GAUGE') THEN
46925  merr=8
46926  ELSEIF (chblck(1:2).EQ.'YU'.OR.chblck(1:2).EQ.'YD'.or
46927  & .chblck(1:2).EQ.'YE') THEN
46928  merr=8
46929  ELSEIF (chblck(1:6).EQ.'SPINFO') THEN
46930  READ(chinl(1:6),*) indx
46931  it=0
46932  mird=0
46933  330 it=it+1
46934  IF (chinl(it:it).EQ.' ') goto 330
46935 C...Don't read index
46936  IF (chinl(it:it).EQ.char(indx+48).AND.mird.EQ.0) THEN
46937  mird=1
46938  goto 330
46939  ENDIF
46940  IF (indx.EQ.1) cpro(1)=chinl(it:it+12)
46941  IF (indx.EQ.2) cver(1)=chinl(it:it+12)
46942  ELSE
46943 C... Set unrecognized block flag.
46944  merr=6
46945  ENDIF
46946 
46947 C...DECAY TABLES
46948 C...Read in decay information
46949  ELSEIF (mupda.EQ.2.AND.merr.EQ.0) THEN
46950 C...Read new decay chanel
46951  IF(chinl(1:1).EQ.' '.AND.chblck(1:5).EQ.'DECAY') THEN
46952  ndc=ndc+1
46953 C...Read in branching ratio and number of daughters for this mode.
46954  READ(chinl(4:50),*,err=390) brat(ndc)
46955  READ(chinl(4:50),*,err=600) dum, nda
46956  IF (nda.LE.5) THEN
46957  IF(ndc.GT.mstu(7)) CALL pyerrm(27,
46958  & '(PYSLHA:) Decay data arrays full by KF = '
46959  $ //chaf(kc,1))
46960 C...If first decay channel, set decays start point in decay table
46961  IF(brsum.LE.0d0.AND.brat(ndc).NE.0d0) THEN
46962  IF (kforig.EQ.0) WRITE(mstu(11),'(1x,A,I9,A,A16)')
46963  & '* (PYSLHA:) Reading DECAY table for '//
46964  & 'KF =',kf,', ',chaf(kcrep,1)(1:16)
46965 C...Set particle parameters (mass set when reading BLOCK MASS above)
46966  pmas(kc,2)=width
46967  IF (kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) THEN
46968  WRITE(mstu(11),'(1x,A)')
46969  & '* Note: the Pythia gg->h/H/A cross section'//
46970  & ' is proportional to the h/H/A->gg width'
46971  ELSEIF (kf.EQ.23.OR.kf.EQ.24.OR.kf.EQ.6.OR.kf.EQ.32
46972  & .OR.kf.EQ.33.OR.kf.EQ.34) THEN
46973  WRITE(mstu(11),'(1x,A,A16)')
46974  & '* Warning: will use DECAY table (fixed-width,'//
46975  & ' flat PS) for ',chaf(kc,1)(1:16)
46976  ENDIF
46977  pmas(kc,3)=0d0
46978  pmas(kc,4)=paru(3)*1d-12/width
46979  mwid(kc)=2
46980  mdcy(kc,1)=1
46981  mdcy(kc,2)=ndc
46982  mdcy(kc,3)=0
46983 C...Add to list of DECAY blocks currently read
46984  ndecay=ndecay+1
46985  kfdec(ndecay)=kf
46986 C...Return ok
46987  iretrn=0
46988  ENDIF
46989 C... Count up number of decay modes for this particle
46990  mdcy(kc,3)=mdcy(kc,3)+1
46991 C... Read in decay daughters.
46992  READ(chinl(4:120),*,err=610) dum,idm, (idc(ida),ida=1,nda)
46993 C... Flip sign if reading antiparticle decays (if antipartner exists)
46994  DO 340 ida=1,nda
46995  IF (kchg(pycomp(idc(ida)),3).NE.0)
46996  & idc(ida)=mpsign*idc(ida)
46997  340 CONTINUE
46998 C...Switch on decay channel
46999 C MDME(NDC,1)=1
47000  IF(mdme(ndc,1).LT.0.AND.mdme(ndc,1).GE.-5) THEN
47001  mdme(ndc,1)=-mdme(ndc,1)
47002  ELSE
47003  mdme(ndc,1)=1
47004  ENDIF
47005 
47006 C...Switch off decay channels with < 0 branching fraction
47007  IF (brat(ndc).LE.0d0) THEN
47008  mdme(ndc,1)=0
47009 C...Else check if decays to gravitinos should be switched on
47010  ELSE
47011  DO 345 ida=1,nda
47012  IF (idc(ida).EQ.1000039) THEN
47013 C... Inform user
47014  IF (imss(11).LE.0) WRITE(mstu(11),*)
47015  & '* (PYSLHA:) Switching on decays to gravitinos'
47016  imss(11) = 2
47017  ENDIF
47018  345 CONTINUE
47019  ENDIF
47020 
47021 C...Store decay products ordered in decreasing ABS(KF)
47022  brsum=brsum+abs(brat(ndc))
47023  brat(ndc)=abs(brat(ndc))
47024  350 iflip=0
47025  DO 360 ida=1,nda-1
47026  IF (iabs(idc(ida+1)).GT.iabs(idc(ida))) THEN
47027  itmp=idc(ida)
47028  idc(ida)=idc(ida+1)
47029  idc(ida+1)=itmp
47030  iflip=iflip+1
47031  ENDIF
47032  360 CONTINUE
47033  IF (iflip.GT.0) goto 350
47034 C...Treat as ordinary decay, no fancy stuff.
47035  mdme(ndc,2)=0
47036  DO 370 ida=1,5
47037  IF (ida.LE.nda) THEN
47038  kfdp(ndc,ida)=idc(ida)
47039  ELSE
47040  kfdp(ndc,ida)=0
47041  ENDIF
47042  370 CONTINUE
47043 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
47044 C & (KFDP(NDC,J),J=1,NDA)
47045  ELSE
47046  CALL pyerrm(7,'(PYSLHA:) Too many daughters on line '//
47047  & chnlin)
47048  merr=11
47049  ndc=ndc-1
47050  ENDIF
47051  ELSEIF(chinl(1:1).EQ.'+') THEN
47052  merr=11
47053  ELSEIF(chblck(1:6).EQ.'DCINFO') THEN
47054  merr=16
47055  ELSE
47056  merr=16
47057  ENDIF
47058  ENDIF
47059 C... Error check.
47060  380 IF (mod(merr,10).EQ.1.AND.(mupda.EQ.1.OR.mupda.EQ.2)) THEN
47061  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring line '//chnlin//': '
47062  & //chinl(1:40)
47063  merr=0
47064  ELSEIF (merr.EQ.6.AND.mupda.EQ.1) THEN
47065  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring BLOCK '//
47066  & chblck(1:min(inl,40))//'... on line '//chnlin
47067  ELSEIF (merr.EQ.8.AND.mupda.EQ.1) THEN
47068  WRITE(mstu(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
47069  & //chblck(1:inl)//'... on line'//chnlin
47070  ELSEIF (merr.EQ.16.AND.mupda.EQ.2.AND.imss21.EQ.0.AND.
47071  & chblck(1:1).NE.'D'.AND.verbos.EQ.1) THEN
47072  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring BLOCK '//chblck(1:inl)
47073  & //'... on line'//chnlin
47074  ELSEIF (merr.EQ.7.AND.mupda.EQ.1) THEN
47075  WRITE(mstu(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
47076  & /chblck(1:inl)//'... on line'//chnlin
47077  ELSEIF (merr.EQ.2.AND.mupda.EQ.1) THEN
47078  WRITE (chtmp,*) kf
47079  WRITE(mstu(11),*)
47080  & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
47081  & chtmp(1:9)//' on line'//chnlin
47082  ENDIF
47083 C...Iterate read loop
47084  goto 170
47085 C...Error catching
47086  390 WRITE(*,*) '* (PYSLHA:) read BR error on line',nline,
47087  & ', ignoring subsequent lines.'
47088  WRITE(*,*) '* (PYSLHA:) Offending line:',chinl(1:46)
47089  chblck=' '
47090  goto 170
47091 C...End of read loop
47092  400 CONTINUE
47093 C...Set flag that KC codes have been rearranged.
47094  mstu(20)=0
47095  verbos=0
47096 
47097 C...Perform possible tests that new information is consistent.
47098  IF (mupda.EQ.1) THEN
47099  mstu23=mstu(23)
47100  mstu27=mstu(27)
47101 C...Check masses
47102  DO 410 isusy=1,37
47103  kf=kfsusy(isusy)
47104 C...Don't complain about right-handed neutrinos
47105  IF (kf.EQ.ksusy2+12.OR.kf.EQ.ksusy2+14.OR.kf.EQ.ksusy2
47106  & +16) goto 410
47107 C...Only check gravitino in GMSB scenarios
47108  IF (modsel(1).NE.2.AND.kf.EQ.ksusy1+39) goto 410
47109  kc=pycomp(kf)
47110  IF (pmas(kc,1).EQ.0d0) THEN
47111  WRITE(chtmp,*) kf
47112  CALL pyerrm(9
47113  & ,'(PYSLHA:) No mass information found for KF ='
47114  & //chtmp)
47115  ENDIF
47116  410 CONTINUE
47117 C...Check mixing matrices (MSSM only)
47118  IF (imss(13).EQ.0) THEN
47119  IF (mspc(2).NE.16.AND.mspc(2).NE.32) CALL pyerrm(9
47120  & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
47121  IF (mspc(3).NE.4.AND.mspc(3).NE.8) CALL pyerrm(9
47122  & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
47123  IF (mspc(4).NE.4.AND.mspc(4).NE.8) CALL pyerrm(9
47124  & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
47125  IF (mspc(5).NE.4) CALL pyerrm(9
47126  & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
47127  IF (mspc(6).NE.4) CALL pyerrm(9
47128  & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
47129  IF (mspc(7).NE.4) CALL pyerrm(9
47130  & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
47131  IF (mspc(8).LT.1) CALL pyerrm(9
47132  & ,'(PYSLHA:) Too few elements in HMIX')
47133  IF (mspc(10).EQ.0) CALL pyerrm(9
47134  & ,'(PYSLHA:) Missing A_b trilinear coupling')
47135  IF (mspc(11).EQ.0) CALL pyerrm(9
47136  & ,'(PYSLHA:) Missing A_t trilinear coupling')
47137  IF (mspc(12).EQ.0) CALL pyerrm(9
47138  & ,'(PYSLHA:) Missing A_tau trilinear coupling')
47139  IF (mspc(17).LT.1) CALL pyerrm(9
47140  & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
47141  ENDIF
47142 C...Check wavefunction normalizations.
47143 C...Sfermions
47144  DO 420 ispc=5,7
47145  IF (mspc(ispc).EQ.4) THEN
47146  kfsm=ispc
47147  IF (ispc.EQ.7) kfsm=15
47148  check=abs(sfmix(kfsm,1)*sfmix(kfsm,4)-sfmix(kfsm,2)
47149  & *sfmix(kfsm,3))
47150  IF (abs(1d0-check).GT.1d-3) THEN
47151  kcsm=pycomp(kfsm)
47152  CALL pyerrm(17
47153  & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
47154  & //chaf(kcsm,1))
47155  ENDIF
47156 C...Bug fix 30/09 2008: PS
47157 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
47158  IF (sfmix(kfsm,1)*sfmix(kfsm,4).LT.0d0) THEN
47159  sfmix(kfsm,3) = -sfmix(kfsm,3)
47160  sfmix(kfsm,4) = -sfmix(kfsm,4)
47161  ENDIF
47162  ENDIF
47163  420 CONTINUE
47164 C...Neutralinos + charginos
47165  DO 440 j=1,4
47166  cn1=0d0
47167  cn2=0d0
47168  cu1=0d0
47169  cu2=0d0
47170  cv1=0d0
47171  cv2=0d0
47172  DO 430 l=1,4
47173  cn1=cn1+zmix(j,l)**2
47174  cn2=cn2+zmix(l,j)**2
47175  IF (j.LE.2.AND.l.LE.2) THEN
47176  cu1=cu1+umix(j,l)**2
47177  cu2=cu2+umix(l,j)**2
47178  cv1=cv1+vmix(j,l)**2
47179  cv2=cv2+vmix(l,j)**2
47180  ENDIF
47181  430 CONTINUE
47182 C...NMIX normalization
47183  IF (mspc(2).EQ.16.AND.(abs(1d0-cn1).GT.1d-3.OR.abs(1d0-cn2)
47184  & .GT.1d-3).AND.imss(13).EQ.0) THEN
47185  CALL pyerrm(19,
47186  & '(PYSLHA:) NMIX: Inconsistent normalization.')
47187  WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F7.4))') j, cn1, cn2
47188  ENDIF
47189 C...UMIX, VMIX normalizations
47190  IF (mspc(3).EQ.4.OR.mspc(4).EQ.4.AND.imss(13).EQ.0) THEN
47191  IF (j.LE.2) THEN
47192  IF (abs(1d0-cu1).GT.1d-3.OR.abs(1d0-cu2).GT.1d-3) THEN
47193  CALL pyerrm(19
47194  & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
47195  WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F6.2))') j, cu1,
47196  & cu2
47197  ENDIF
47198  IF (abs(1d0-cv1).GT.1d-3.OR.abs(1d0-cv2).GT.1d-3) THEN
47199  CALL pyerrm(19,
47200  & '(PYSLHA:) VMIX: Inconsistent normalization.')
47201  WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F6.2))') j, cv1,
47202  & cv2
47203  ENDIF
47204  ENDIF
47205  ENDIF
47206  440 CONTINUE
47207  IF (mstu(27).EQ.mstu27.AND.mstu(23).EQ.mstu23) THEN
47208  WRITE(mstu(11),'(1x,"*"/1x,A/1x,"*")')
47209  & '* (PYSLHA:) No spectrum inconsistencies were found.'
47210  ELSE
47211  WRITE(mstu(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
47212  & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
47213  & ,' Warning: one or more (serious)'//
47214  & ' inconsistencies were found in the spectrum !'
47215  & ,' Read the error messages above and check your'//
47216  & ' input file.'
47217  ENDIF
47218 C...Increase precision in Higgs sector using FeynHiggs
47219  IF (imss(4).EQ.3) THEN
47220 C...FeynHiggs needs MSOFT.
47221  ierr=0
47222  IF (mspc(18).EQ.0) THEN
47223  WRITE(mstu(11),'(1x,"*"/1x,A/)')
47224  & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
47225  & ' Cannot call FeynHiggs.'
47226  ierr=-1
47227  ELSE
47228  WRITE(mstu(11),'(1x,/1x,A/)')
47229  & '* (PYSLHA:) Now calling FeynHiggs.'
47230  CALL pyfeyn(ierr)
47231  IF (ierr.NE.0) imss(4)=2
47232  ENDIF
47233  ENDIF
47234  ELSEIF (mupda.EQ.2.AND.iretrn.EQ.0.AND.merr.NE.16) THEN
47235  ibeg=1
47236  IF (kforig.NE.0) ibeg=ndecay
47237  DO 490 idecay=ibeg,ndecay
47238  kf = kfdec(idecay)
47239  kc = pycomp(kf)
47240  WRITE(chkf,8300) kf
47241  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3
47242  $ ),pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0.OR.(mdcy(kc,3)
47243  $ .EQ.0.AND.mdcy(kc,1).GE.1)) CALL pyerrm(17
47244  $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
47245  $ //chkf)
47246  brsum=0d0
47247  bropn=0d0
47248  DO 460 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
47249  IF(mdme(ida,2).GT.80) goto 460
47250  kq=kchg(kc,1)
47251  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
47252  merr=0
47253  DO 450 j=1,5
47254  kp=kfdp(ida,j)
47255  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
47256  IF(kp.EQ.81) kq=0
47257  ELSEIF(pycomp(kp).EQ.0) THEN
47258  merr=3
47259  ELSE
47260  kq=kq-pychge(kp)
47261  kpc=pycomp(kp)
47262  pms=pms-pmas(kpc,1)
47263  IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
47264  & pmas(kpc,3))
47265  ENDIF
47266  450 CONTINUE
47267  IF(kq.NE.0) merr=max(2,merr)
47268  IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
47269  & merr=max(1,merr)
47270  IF(merr.EQ.3) CALL pyerrm(17,
47271  & '(PYSLHA:) Unknown particle code in decay of KF ='
47272  $ //chkf)
47273  IF(merr.EQ.2) CALL pyerrm(17,
47274  & '(PYSLHA:) Charge not conserved in decay of KF ='
47275  $ //chkf)
47276  IF(merr.EQ.1) CALL pyerrm(7,
47277  & '(PYSLHA:) Kinematically unallowed decay of KF ='
47278  $ //chkf)
47279  brsum=brsum+brat(ida)
47280  IF (mdme(ida,1).GT.0) bropn=bropn+brat(ida)
47281  460 CONTINUE
47282 C...Check branching ratio sum.
47283  IF (bropn.LE.0d0) THEN
47284 C...If zero, set stable.
47285  WRITE(chtmp,8500) bropn
47286  CALL pyerrm(7
47287  & ,"(PYSLHA:) Effective BR sum for KF="//chkf//' is '//
47288  & chtmp(9:16)//'. Changed to stable.')
47289  pmas(kc,2)=1d-6
47290  mwid(kc)=0
47291 C...If BR's > 1, rescale.
47292  ELSEIF (brsum.GT.(1d0+1d-6)) THEN
47293  WRITE(chtmp,8500) brsum
47294  IF (brsum.GT.(1d0+1d-3)) CALL pyerrm(7
47295  & ,"(PYSLHA:) Forced rescaling of BR's for KF="//chkf//
47296  & ' ; sum was '//chtmp(9:16)//'.')
47297  fac=1d0/brsum
47298  DO 470 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
47299  IF(mdme(ida,2).GT.80) goto 470
47300  brat(ida)=fac*brat(ida)
47301  470 CONTINUE
47302  ELSEIF (brsum.LT.(1d0-1d-6)) THEN
47303 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
47304  WRITE(chtmp,8500) brsum
47305  IF (brsum.LT.(1d0-1d-3)) CALL pyerrm(7
47306  & ,"(PYSLHA:) Sum of BR's for KF="//chkf//' is '//
47307  & chtmp(9:16)//'. Dummy mode will be inserted.')
47308 C...Move table and insert dummy mode
47309  DO 480 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
47310  ndc=ndc+1
47311  brat(ndc)=brat(ida)
47312  kfdp(ndc,1)=kfdp(ida,1)
47313  kfdp(ndc,2)=kfdp(ida,2)
47314  kfdp(ndc,3)=kfdp(ida,3)
47315  kfdp(ndc,4)=kfdp(ida,4)
47316  kfdp(ndc,5)=kfdp(ida,5)
47317  mdme(ndc,1)=mdme(ida,1)
47318  480 CONTINUE
47319  ndc=ndc+1
47320  brat(ndc)=1d0-brsum
47321  kfdp(ndc,1)=0
47322  kfdp(ndc,2)=0
47323  kfdp(ndc,3)=0
47324  kfdp(ndc,4)=0
47325  kfdp(ndc,5)=0
47326  mdme(ndc,1)=0
47327  brsum=1d0
47328 C...Update MDCY
47329  mdcy(kc,3)=mdcy(kc,3)+1
47330  mdcy(kc,2)=ndc-mdcy(kc,3)+1
47331  ENDIF
47332  490 CONTINUE
47333  ENDIF
47334 
47335 
47336 C...WRITE SPECTRUM ON SLHA FILE
47337  ELSEIF(mupda.EQ.3) THEN
47338 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
47339  IF (imss(1).EQ.2.OR.imss(1).EQ.12) THEN
47340  modsel(1)=1
47341  parmin(1)=rmss(8)
47342  parmin(2)=rmss(1)
47343  parmin(3)=rmss(5)
47344  parmin(4)=sign(1d0,rmss(4))
47345  parmin(5)=rmss(36)
47346  ENDIF
47347 C...Write spectrum
47348  WRITE(lfn,7000) 'SLHA MSSM spectrum'
47349  WRITE(lfn,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
47350  & // ' P. Skands.'
47351  WRITE(lfn,7010) 'MODSEL', 'Model selection'
47352  WRITE(lfn,7110) 1, modsel(1)
47353  WRITE(lfn,7010) 'MINPAR', 'Parameters for minimal model.'
47354  IF (modsel(1).EQ.1) THEN
47355  WRITE(lfn,7210) 1, parmin(1), 'm0'
47356  WRITE(lfn,7210) 2, parmin(2), 'm12'
47357  WRITE(lfn,7210) 3, parmin(3), 'tan(beta)'
47358  WRITE(lfn,7210) 4, parmin(4), 'sign(mu)'
47359  WRITE(lfn,7210) 5, parmin(5), 'a0'
47360  ELSEIF(modsel(2).EQ.2) THEN
47361  WRITE(lfn,7210) 1, parmin(1), 'Lambda'
47362  WRITE(lfn,7210) 2, parmin(2), 'M'
47363  WRITE(lfn,7210) 3, parmin(3), 'tan(beta)'
47364  WRITE(lfn,7210) 4, parmin(4), 'sign(mu)'
47365  WRITE(lfn,7210) 5, parmin(5), 'N5'
47366  WRITE(lfn,7210) 6, parmin(6), 'c_grav'
47367  ENDIF
47368  WRITE(lfn,7000) ' '
47369  WRITE(lfn,7010) 'MASS', 'Mass spectrum'
47370  DO 500 i=1,36
47371  kf=kfsusy(i)
47372  kc=pycomp(kf)
47373  IF (kf.EQ.1000039.AND.modsel(1).NE.2) goto 500
47374  kfsm=kf-ksusy1
47375  IF (kfsm.GE.22.AND.kfsm.LE.37) THEN
47376  IF (kfsm.EQ.22) WRITE(lfn,7220) kf, smz(1), chaf(kc,1)
47377  IF (kfsm.EQ.23) WRITE(lfn,7220) kf, smz(2), chaf(kc,1)
47378  IF (kfsm.EQ.25) WRITE(lfn,7220) kf, smz(3), chaf(kc,1)
47379  IF (kfsm.EQ.35) WRITE(lfn,7220) kf, smz(4), chaf(kc,1)
47380  IF (kfsm.EQ.24) WRITE(lfn,7220) kf, smw(1), chaf(kc,1)
47381  IF (kfsm.EQ.37) WRITE(lfn,7220) kf, smw(2), chaf(kc,1)
47382  ELSE
47383  WRITE(lfn,7220) kf, pmas(kc,1), chaf(kc,1)
47384  ENDIF
47385  500 CONTINUE
47386 C...SUSY scale
47387  rmsusy=sqrt(pmas(pycomp(ksusy1+6),1)*pmas(pycomp(ksusy2+6),1))
47388  WRITE(lfn,7020) 'HMIX',rmsusy,'Higgs parameters'
47389  WRITE(lfn,7210) 1, rmss(4),'mu'
47390  WRITE(lfn,7010) 'ALPHA',' '
47391 C WRITE(LFN,7210) 1, RMSS(18), 'alpha'
47392  WRITE(lfn,7200) rmss(18), 'alpha'
47393  WRITE(lfn,7020) 'AU',rmsusy
47394  WRITE(lfn,7410) 3, 3, rmss(16), 'A_t'
47395  WRITE(lfn,7020) 'AD',rmsusy
47396  WRITE(lfn,7410) 3, 3, rmss(15), 'A_b'
47397  WRITE(lfn,7020) 'AE',rmsusy
47398  WRITE(lfn,7410) 3, 3, rmss(17), 'A_tau'
47399  WRITE(lfn,7010) 'STOPMIX','~t mixing matrix'
47400  WRITE(lfn,7410) 1, 1, sfmix(6,1)
47401  WRITE(lfn,7410) 1, 2, sfmix(6,2)
47402  WRITE(lfn,7410) 2, 1, sfmix(6,3)
47403  WRITE(lfn,7410) 2, 2, sfmix(6,4)
47404  WRITE(lfn,7010) 'SBOTMIX','~b mixing matrix'
47405  WRITE(lfn,7410) 1, 1, sfmix(5,1)
47406  WRITE(lfn,7410) 1, 2, sfmix(5,2)
47407  WRITE(lfn,7410) 2, 1, sfmix(5,3)
47408  WRITE(lfn,7410) 2, 2, sfmix(5,4)
47409  WRITE(lfn,7010) 'STAUMIX','~tau mixing matrix'
47410  WRITE(lfn,7410) 1, 1, sfmix(15,1)
47411  WRITE(lfn,7410) 1, 2, sfmix(15,2)
47412  WRITE(lfn,7410) 2, 1, sfmix(15,3)
47413  WRITE(lfn,7410) 2, 2, sfmix(15,4)
47414  WRITE(lfn,7010) 'NMIX','~chi0 mixing matrix'
47415  DO 520 i1=1,4
47416  DO 510 i2=1,4
47417  WRITE(lfn,7410) i1, i2, zmix(i1,i2)
47418  510 CONTINUE
47419  520 CONTINUE
47420  WRITE(lfn,7010) 'UMIX','~chi^+ U mixing matrix'
47421  DO 540 i1=1,2
47422  DO 530 i2=1,2
47423  WRITE(lfn,7410) i1, i2, umix(i1,i2)
47424  530 CONTINUE
47425  540 CONTINUE
47426  WRITE(lfn,7010) 'VMIX','~chi^+ V mixing matrix'
47427  DO 560 i1=1,2
47428  DO 550 i2=1,2
47429  WRITE(lfn,7410) i1, i2, vmix(i1,i2)
47430  550 CONTINUE
47431  560 CONTINUE
47432  WRITE(lfn,7010) 'SPINFO'
47433  IF (imss(1).EQ.2) THEN
47434  cpro(1)='PYTHIA'
47435  cver(1)='6.4'
47436  ELSEIF (imss(1).EQ.12) THEN
47437  isaver=visaje()
47438  cpro(1)='ISASUSY'
47439  cver(1)=isaver(1:12)
47440  ENDIF
47441  WRITE(lfn,7310) 1, cpro(1), 'Spectrum Calculator'
47442  WRITE(lfn,7310) 2, cver(1), 'Version number'
47443  ENDIF
47444 
47445 C...Print user information about spectrum
47446  IF (mupda.EQ.1.OR.mupda.EQ.3) THEN
47447  IF (cpro(mod(mupda,2)).NE.' '.AND.cver(mod(mupda,2)).NE.' ')
47448  & WRITE(mstu(11),5030) cpro(1), cver(1)
47449  IF (imss(4).EQ.3) WRITE(mstu(11),5040)
47450  IF (mupda.EQ.1) THEN
47451  WRITE(mstu(11),5020) lfn
47452  ELSE
47453  WRITE(mstu(11),5010) lfn
47454  ENDIF
47455 
47456  WRITE(mstu(11),5400)
47457  WRITE(mstu(11),5500) 'Pole masses'
47458  WRITE(mstu(11),5700) (rmfun(ksusy1+ip),ip=1,6)
47459  $ ,(rmfun(ksusy2+ip),ip=1,6)
47460  WRITE(mstu(11),5800) (rmfun(ksusy1+ip),ip=11,16)
47461  $ ,(rmfun(ksusy2+ip),ip=11,16)
47462  IF (imss(13).EQ.0) THEN
47463  WRITE(mstu(11),5900) rmfun(ksusy1+21),rmfun(ksusy1+22)
47464  $ ,rmfun(ksusy1+23),rmfun(ksusy1+25),rmfun(ksusy1+35),
47465  $ rmfun(ksusy1+24),rmfun(ksusy1+37)
47466  WRITE(mstu(11),6000) chaf(25,1),chaf(35,1),chaf(36,1),
47467  & chaf(37,1), ' ', ' ',' ',' ',
47468  & rmfun(25), rmfun(35), rmfun(36), rmfun(37)
47469  ELSEIF (imss(13).EQ.1) THEN
47470  kf1=ksusy1+21
47471  kf2=ksusy1+22
47472  kf3=ksusy1+23
47473  kf4=ksusy1+25
47474  kf5=ksusy1+35
47475  kf6=ksusy1+45
47476  kf7=ksusy1+24
47477  kf8=ksusy1+37
47478  WRITE(mstu(11),6000) chaf(pycomp(kf1),1),chaf(pycomp(kf2),1),
47479  & chaf(pycomp(kf3),1),chaf(pycomp(kf4),1),
47480  & chaf(pycomp(kf5),1),chaf(pycomp(kf6),1),
47481  & chaf(pycomp(kf7),1),chaf(pycomp(kf8),1),
47482  & rmfun(kf1),rmfun(kf2),rmfun(kf3),rmfun(kf4),
47483  & rmfun(kf5),rmfun(kf6),rmfun(kf7),rmfun(kf8)
47484  WRITE(mstu(11),6000) chaf(25,1), chaf(35,1), chaf(45,1),
47485  & chaf(36,1), chaf(46,1), chaf(37,1),' ',' ',
47486  & rmfun(25), rmfun(35), rmfun(45), rmfun(36), rmfun(46),
47487  & rmfun(37)
47488  ENDIF
47489  WRITE(mstu(11),5400)
47490  WRITE(mstu(11),5500) 'Mixing structure'
47491  WRITE(mstu(11),6100) ((zmix(i,j), j=1,4),i=1,4)
47492  WRITE(mstu(11),6200) (umix(1,j), j=1,2),(vmix(1,j),j=1,2)
47493  & ,(umix(2,j), j=1,2),(vmix(2,j),j=1,2)
47494  WRITE(mstu(11),6300) (sfmix(5,j), j=1,2),(sfmix(6,j),j=1,2)
47495  & ,(sfmix(15,j), j=1,2),(sfmix(5,j),j=3,4),(sfmix(6,j), j=3,4
47496  & ),(sfmix(15,j),j=3,4)
47497  WRITE(mstu(11),5400)
47498  WRITE(mstu(11),5500) 'Couplings'
47499  WRITE(mstu(11),6400) rmss(15),rmss(16),rmss(17)
47500  WRITE(mstu(11),6450) rmss(18), rmss(5), rmss(4)
47501  WRITE(mstu(11),5400)
47502  WRITE(mstu(11),6500)
47503 
47504 C...DECAY TABLES writeout
47505 C...Write decay information by Nils-Erik Bomark 3/29/2010
47506  ELSEIF (mupda.EQ.4) THEN
47507  kf = kforig
47508  kc = pycomp(kf)
47509  IF (kc.NE.0) THEN
47510  WRITE(lfn,7000) ''
47511  WRITE(lfn,7000) ' PDG Width'
47512  WRITE(lfn,7500) kf,pmas(kc,2), chaf(kc,1)
47513  WRITE(lfn,7000)
47514  & ' BR NDA ID1 ID2 ID3'
47515  DO 575 i=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
47516  nda = 0
47517  DO 570 j=1,5
47518  IF (kfdp(i,j).NE.0) nda = nda+1
47519  570 CONTINUE
47520  IF (nda.EQ.2)
47521  & WRITE(lfn,7512) brat(i),nda,(kfdp(i,k),k=1,nda),
47522  & chaf(kc,1),(chaf(pycomp(kfdp(i,k)),
47523  & (3-kfdp(i,k)/abs(kfdp(i,k)))/2),k=1,nda)
47524  IF (nda.EQ.3)
47525  & WRITE(lfn,7513) brat(i),nda,(kfdp(i,k),k=1,nda),
47526  & chaf(kc,1),(chaf(pycomp(kfdp(i,k)),
47527  & (3-kfdp(i,k)/abs(kfdp(i,k)))/2),k=1,nda)
47528  IF (nda.EQ.4)
47529  & WRITE(lfn,7514) brat(i),nda,(kfdp(i,k),k=1,nda),
47530  & chaf(kc,1),(chaf(pycomp(kfdp(i,k)),
47531  & (3-kfdp(i,k)/abs(kfdp(i,k)))/2),k=1,nda)
47532  IF (nda.EQ.5)
47533  & WRITE(lfn,7515) brat(i),nda,(kfdp(i,k),k=1,nda),
47534  & chaf(kc,1),(chaf(pycomp(kfdp(i,k)),
47535  & (3-kfdp(i,k)/abs(kfdp(i,k)))/2),k=1,nda)
47536  575 CONTINUE
47537  ENDIF
47538 C....End of DECAY TABLES writeout
47539 
47540  ENDIF
47541 
47542 C...Only rewind when reading
47543  IF (mupda.LE.2.OR.mupda.EQ.5) rewind(lfn)
47544 
47545  9999 RETURN
47546 
47547 C...Serious error catching
47548  580 write(*,*) '* (PYSLHA:) read BLOCK error on line',nline
47549  write(*,*) chinl(1:80)
47550  CALL pystop(106)
47551  590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',nline
47552  WRITE(*,*) chinl(1:72)
47553  CALL pystop(106)
47554  600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',nline
47555  WRITE(*,*) chinl(1:80)
47556  CALL pystop(106)
47557  610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',nline
47558  WRITE(*,*) chinl(1:80)
47559  620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',chblck
47560  CALL pystop(106)
47561  630 WRITE(*,*) '* (PYSLHA:) read error in line ',nline,':'
47562  WRITE(*,*) chinl(1:80)
47563  CALL pystop(106)
47564 
47565  8300 FORMAT(i9)
47566  8500 FORMAT(f16.5)
47567 
47568 C...Formats for user information printout.
47569  5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.15: SUSY/BSM SPECTRUM '
47570  & ,'INTERFACE',1x,17('*')/1x,'*',1x
47571  & ,'(PYSLHA:) Last Change',1x,a,1x,'-',1x,'P. Skands')
47572  5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',i3)
47573  5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',i3)
47574  5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',a,' version ',a)
47575  5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
47576  5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
47577  5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47578  & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(f8.2,1x),i8,2x,f8.2)
47579  5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
47580  & ,'----------------')
47581  5400 FORMAT(1x,'*',1x,a)
47582  5500 FORMAT(1x,'*',1x,a,':')
47583  5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47584  & 1x,'*',2x,1p,2(1x,e8.2),2x,e8.2)
47585  5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
47586  & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
47587  & ,6(f8.2,1x)/1x,'*',2x,'R',1x,6(f8.2,1x))
47588  5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
47589  & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
47590  & ,'L',1x,6(f8.2,1x)/1x,'*',2x,'R',1x,6(f8.2,1x))
47591  5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47592  & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47593  & ,1x,'~chi_2+'/1x,'*',3x,1x,7(f8.2,1x))
47594  6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,a7,1x)/1x,'*',3x,1x,8(f8.2,1x))
47595  6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47596  & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47597  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47598  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47599  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47600  & ,1x,f6.3,1x),'|')
47601  6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47602  & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47603  & ,'~chi_1+',1x,2('|',1x,f6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47604  & ,f6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,f6.3,1x),'|',9x
47605  & ,'~chi_2+',1x,2('|',1x,f6.3,1x),'|')
47606  6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47607  & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47608  & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47609  & 1x,'*',3x,'~b_1',1x,2('|',1x,f6.3,1x),'|',3x,'~t_1',1x,2('|'
47610  & ,1x,f6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,f6.3,1x),'|'/
47611  & 1x,'*',3x,'~b_2',1x,2('|',1x,f6.3,1x),'|',3x,'~t_2',1x,2('|'
47612  & ,1x,f6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,f6.3,1x),'|')
47613  6400 FORMAT(1x,'*',3x,' A_b = ',f8.2,4x,' A_t = ',f8.2,4x
47614  & ,'A_tau = ',f8.2)
47615  6450 FORMAT(1x,'*',3x,'alpha = ',f8.2,4x,'tan(beta) = ',f8.2,4x
47616  & ,' mu = ',f8.2)
47617  6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
47618 
47619 C...Format to use for comments
47620  7000 FORMAT('# ',a)
47621 C...Format to use for block statements
47622  7010 FORMAT('Block',1x,a,3x,'#',1x,a)
47623  7020 FORMAT('Block',1x,a,1x,'Q=',1p,e16.8,0p,3x,'#',1x,a)
47624 C...Indexed Int
47625  7110 FORMAT(1x,i4,1x,i4,3x,'#')
47626 C...Non-Indexed Double
47627  7200 FORMAT(9x,1p,e16.8,0p,3x,'#',1x,a)
47628 C...Indexed Double
47629  7210 FORMAT(1x,i4,3x,1p,e16.8,0p,3x,'#',1x,a)
47630 C...Long Indexed Double (PDG + double)
47631  7220 FORMAT(1x,i9,3x,1p,e16.8,0p,3x,'#',1x,a)
47632 C...Indexed Char(12)
47633  7310 FORMAT(1x,i4,3x,a12,3x,'#',1x,a)
47634 C...Single matrix
47635  7410 FORMAT(1x,i2,1x,i2,3x,1p,e16.8,0p,3x,'#',1x,a)
47636 C...Double Matrix
47637  7420 FORMAT(1x,i2,1x,i2,3x,1p,e16.8,3x,e16.8,0p,3x,'#',1x,a)
47638 C...Write Decay Table
47639  7500 FORMAT('Decay',1x,i9,1x,1p,e16.8,0p,3x,'#',1x,a)
47640  7510 FORMAT(4x,1p,e16.8,0p,3x,i2,3x,'IDA=',1x,5(1x,i9),3x,'#',1x,a)
47641  7512 FORMAT(4x,1p,e16.8,0p,3x,i2,3x,1x,2(1x,i9),13x,
47642  & '#',1x,'BR(',a10,1x,'->',2(1x,a10),')')
47643  7513 FORMAT(4x,1p,e16.8,0p,3x,i2,3x,1x,3(1x,i9),3x,
47644  & '#',1x,'BR(',a10,1x,'->',3(1x,a10),')')
47645  7514 FORMAT(4x,1p,e16.8,0p,3x,i2,3x,1x,4(1x,i9),3x,
47646  & '#',1x,'BR(',a10,1x,'->',4(1x,a10),')')
47647  7515 FORMAT(4x,1p,e16.8,0p,3x,i2,3x,1x,5(1x,i9),3x,
47648  & '#',1x,'BR(',a10,1x,'->',5(1x,a10),')')
47649 
47650  END
47651 
47652 
47653 C*********************************************************************
47654 
47655 C...PYAPPS
47656 C...Uses approximate analytical formulae to determine the full set of
47657 C...MSSM parameters from SUGRA input.
47658 C...See M. Drees and S.P. Martin, hep-ph/9504124
47659 
47660  SUBROUTINE pyapps
47661 
47662 C...Double precision and integer declarations.
47663  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47664  IMPLICIT INTEGER(i-n)
47665  INTEGER pyk,pychge,pycomp
47666 C...Parameter statement to help give large particle numbers.
47667  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
47668  &kexcit=4000000,kdimen=5000000)
47669 C...Commonblocks.
47670  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47671  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47672  common/pymssm/imss(0:99),rmss(0:99)
47673  SAVE /pydat1/,/pydat2/,/pymssm/
47674 
47675  WRITE(mstu(11),*) '(PYAPPS:) approximate mSUGRA relations'//
47676  &' not intended for serious physics studies'
47677  imss(5)=0
47678  imss(8)=0
47679  xmt=pmas(6,1)
47680  xmz2=pmas(23,1)**2
47681  xmw2=pmas(24,1)**2
47682  tanb=rmss(5)
47683  beta=atan(tanb)
47684  xw=paru(102)
47685  xmg=rmss(1)
47686  xmg2=xmg*xmg
47687  xm0=rmss(8)
47688  xm02=xm0*xm0
47689 C...Temporary sign change for AT. Others unchanged.
47690  at=-rmss(16)
47691  rmss(15)=rmss(16)
47692  rmss(17)=rmss(16)
47693  sinb=tanb/sqrt(tanb**2+1d0)
47694  cosb=sinb/tanb
47695 
47696  dterm=xmz2*cos(2d0*beta)
47697  xmer=sqrt(xm02+0.15d0*xmg2-xw*dterm)
47698  xmel=sqrt(xm02+0.52d0*xmg2-(0.5d0-xw)*dterm)
47699  rmss(6)=xmel
47700  rmss(7)=xmer
47701  xmur=sqrt(pyrnmq(2,2d0/3d0*xw*dterm))
47702  xmdr=sqrt(pyrnmq(3,-1d0/3d0*xw*dterm))
47703  xmul=sqrt(pyrnmq(1,(0.5d0-2d0/3d0*xw)*dterm))
47704  xmdl=sqrt(pyrnmq(1,-(0.5d0-1d0/3d0*xw)*dterm))
47705  DO 100 i=1,5,2
47706  pmas(pycomp(ksusy1+i),1)=xmdl
47707  pmas(pycomp(ksusy2+i),1)=xmdr
47708  pmas(pycomp(ksusy1+i+1),1)=xmul
47709  pmas(pycomp(ksusy2+i+1),1)=xmur
47710  100 CONTINUE
47711  xarg=xmel**2-xmw2*abs(cos(2d0*beta))
47712  IF(xarg.LT.0d0) THEN
47713  WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
47714  & ' FROM THE SUM RULE. '
47715  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47716  RETURN
47717  ELSE
47718  xarg=sqrt(xarg)
47719  ENDIF
47720  DO 110 i=11,15,2
47721  pmas(pycomp(ksusy1+i),1)=xmel
47722  pmas(pycomp(ksusy2+i),1)=xmer
47723  pmas(pycomp(ksusy1+i+1),1)=xarg
47724  pmas(pycomp(ksusy2+i+1),1)=9999d0
47725  110 CONTINUE
47726  rmt=pymrun(6,pmas(6,1)**2)
47727  xtop=(rmt/150d0/sinb)**2*(.9d0*xm02+2.1d0*xmg2+
47728  &(1d0-(rmt/190d0/sinb)**3)*(.24d0*at**2+at*xmg))
47729  rmb=pymrun(5,pmas(6,1)**2)
47730  xbot=(rmb/150d0/cosb)**2*(.9d0*xm02+2.1d0*xmg2+
47731  &(1d0-(rmb/190d0/cosb)**3)*(.24d0*at**2+at*xmg))
47732  xtau=1d-4/cosb**2*(xm02+0.15d0*xmg2+at**2/3d0)
47733  atp=at*(1d0-(rmt/190d0/sinb)**2)+xmg*(3.47d0-1.9d0*(rmt/190d0/
47734  &sinb)**2)
47735  rmss(16)=-atp
47736  xmu2=-.5d0*xmz2+(sinb**2*(xm02+.52d0*xmg2-xtop)-
47737  &cosb**2*(xm02+.52d0*xmg2-xbot-xtau/3d0))/(cosb**2-sinb**2)
47738  xma2=2d0*(xm02+.52d0*xmg2+xmu2)-xtop-xbot-xtau/3d0
47739  xmu=sign(sqrt(xmu2),rmss(4))
47740  rmss(4)=xmu
47741  IF(xma2.GT.0d0) THEN
47742  rmss(19)=sqrt(xma2)
47743  ELSE
47744  WRITE(mstu(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
47745  CALL pystop(102)
47746  ENDIF
47747  arg=xm02+0.15d0*xmg2-2d0*xtau/3d0-xw*dterm
47748  IF(arg.GT.0d0) THEN
47749  rmss(14)=sqrt(arg)
47750  ELSE
47751  WRITE(mstu(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
47752  CALL pystop(102)
47753  ENDIF
47754  arg=xm02+0.52d0*xmg2-xtau/3d0-(0.5d0-xw)*dterm
47755  IF(arg.GT.0d0) THEN
47756  rmss(13)=sqrt(arg)
47757  ELSE
47758  WRITE(mstu(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
47759  CALL pystop(102)
47760  ENDIF
47761  arg=pyrnmq(1,-(xbot+xtop)/3d0)
47762  IF(arg.GT.0d0) THEN
47763  rmss(10)=sqrt(arg)
47764  ELSE
47765  rmss(10)=-sqrt(-arg)
47766  ENDIF
47767  arg=pyrnmq(2,-2d0*xtop/3d0)
47768  IF(arg.GT.0d0) THEN
47769  rmss(12)=sqrt(arg)
47770  ELSE
47771  rmss(12)=-sqrt(-arg)
47772  ENDIF
47773  arg=pyrnmq(3,-2d0*xbot/3d0)
47774  IF(arg.GT.0d0) THEN
47775  rmss(11)=sqrt(arg)
47776  ELSE
47777  rmss(11)=-sqrt(-arg)
47778  ENDIF
47779 
47780  RETURN
47781  END
47782 
47783 C*********************************************************************
47784 
47785 C...PYSUGI
47786 C...Interface to ISASUSY version 7.71.
47787 C...Warning: this interface should not be used with earlier versions
47788 C...of ISASUSY, since common block incompatibilities may then arise.
47789 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
47790 C...Then converts to Gunion-Haber conventions.
47791 
47792  SUBROUTINE pysugi
47793  IMPLICIT DOUBLE PRECISION(a-h, o-z)
47794 
47795  INTEGER pyk,pychge,pycomp
47796  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
47797  &kexcit=4000000,kdimen=5000000)
47798 
47799 C...Date of Change
47800  CHARACTER doc*11
47801  parameter(doc='01 May 2006')
47802 
47803 C...ISASUGRA Input:
47804  REAL mzero,mhlf,azero,tanb,sgnmu,mtop
47805 C...XISAIN contains the MSSMi inputs in natural order.
47806  COMMON /sugxin/ xisain(24),xsugin(7),xgmin(14),xnrin(4),
47807  $xamin(7)
47808  REAL xisain,xsugin,xgmin,xnrin,xamin
47809  SAVE /sugxin/
47810 C...ISASUGRA Output
47811  CHARACTER*40 isaver,visaje
47812  REAL super
47813  COMMON /sspar/ super(72)
47814  COMMON /sugmg/ mss(32),gss(31),mgutss,ggutss,agutss,ftgut,
47815  $fbgut,ftagut,fngut
47816  REAL mss,gss,mgutss,ggutss,agutss,ftgut,fbgut,ftagut,fngut
47817  COMMON /sugpas/ xtanb,msusy,amt,mgut,mu,g2,gp,v,vp,xw,
47818  $a1mz,a2mz,asmz,ftamz,fbmz,b,sin2b,ftmt,g3mt,vev,higfrz,
47819  $fnmz,amnrmj,nogood,ial3un,itachy,mhpneg,asm3,
47820  $vumt,vdmt,asmtp,asmss,m3q
47821  REAL xtanb,msusy,amt,mgut,mu,g2,gp,v,vp,xw,
47822  $a1mz,a2mz,asmz,ftamz,fbmz,b,sin2b,ftmt,g3mt,vev,higfrz,
47823  $fnmz,amnrmj,asm3,vumt,vdmt,asmtp,asmss,m3q
47824  INTEGER nogood,ial3un,itachy,mhpneg
47825  INTEGER iallow
47826  SAVE /sugmg/,/sspar/
47827 C SUPER: Filled by ISASUGRA.
47828 C SUPER(1) = mass of ~g
47829 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
47830 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
47831 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
47832 C ,~tau_2
47833 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
47834 C SUPER(29) = Higgsino mass = - mu
47835 C SUPER(30) = ratio v2/v1 of vev's
47836 C SUPER(31:34) = Signed neutralino masses
47837 C SUPER(35:50) = Neutralino mixing matrix
47838 C SUPER(51:52) = Signed chargino masses
47839 C SUPER(53:54) = Chargino left, right mixing angles
47840 C SUPER(55:58) = mass of h0, H0, A0, H+
47841 C SUPER(59) = Higgs mixing angle alpha
47842 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
47843 C SUPER(66) = Gravitino mass
47844 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47845 C SUPER(70) = b-Yukawa at mA scale (not used)
47846 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47847 C GSS: Filled by ISASUGRA
47848 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47849 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47850 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47851 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47852 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47853 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47854 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47855 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47856 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47857 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47858 C GSS(31) = log(vuq)
47859 C MSS: Filled by ISASUGRA
47860 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47861 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47862 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47863 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47864 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47865 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47866 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47867 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47868 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47869 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47870 C MSS(31) = ha0 MSS(32) = h+
47871 C Unification, filled by ISASUGRA if applicable.
47872 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47873 
47874 C...SPYTHIA Input/Output
47875  INTEGER imss
47876  DOUBLE PRECISION rmss
47877  common/pymssm/imss(0:99),rmss(0:99)
47878  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
47879  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
47880 C...SLHA Input/Output
47881  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
47882  & au(3,3),ad(3,3),ae(3,3)
47883 C...PYTHIA common blocks
47884  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47885  common/pypars/mstp(200),parp(200),msti(200),pari(200)
47886  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47887 
47888  SAVE /pymssm/,/pyssmt/,/pylh3p/,/pydat1/,/pypars/,/pydat2/
47889 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47890  INTEGER imodel
47891  REAL m0,mhf,a0,mt
47892  CHARACTER*20 chmod(5)
47893  CHARACTER*32 fname
47894 
47895  COMMON /sugnu/ xnusug(18)
47896  REAL xnusug
47897  SAVE /sugnu/
47898 
47899  DATA chmod/'mSUGRA','mGMSB','non-universal SUGRA',
47900  & 'truly unified SUGRA', 'non-minimal GMSB'/
47901 
47902 C...Start by checking for incompatibilities/inconsistencies:
47903  DO 100 ichk=2,9
47904  IF (ichk.NE.8.AND.ichk.NE.4.AND.imss(ichk).NE.0) THEN
47905  WRITE (mstu(11),*) '(PYSUGI:) IMSS(',ichk,')=',imss(ichk)
47906  & ,' option not used by PYSUGI'
47907  ENDIF
47908  100 CONTINUE
47909 C...ISAJET works with REAL numbers.
47910  mzero=REAL(rmss(8))
47911  mhlf=REAL(rmss(1))
47912  azero=REAL(rmss(16))
47913  tanb=REAL(rmss(5))
47914  sgnmu=REAL(rmss(4))
47915  mtop=REAL(pmas(6,1))
47916  imodel=0
47917  IF (imss(1).EQ.12) THEN
47918  imodel=1
47919  goto 130
47920  ELSEIF(imss(1).EQ.13) THEN
47921 C...Read from isajet par file in IMSS(20)
47922  lfn=imss(20)
47923 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47924  IF (lfn.EQ.0) THEN
47925  WRITE(mstu(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47926  goto 9999
47927  ENDIF
47928  WRITE(mstu(11),*) 'READING SUSY MODEL FROM FILE...'
47929 CMrenna change to allow any susy model
47930  WRITE(mstu(11),*) 'ENTER 1 for mSUGRA:'
47931  WRITE(mstu(11),*) 'ENTER 2 for mGMSB:'
47932  WRITE(mstu(11),*) 'ENTER 3 for non-universal SUGRA:'
47933  WRITE(mstu(11),*) 'ENTER 4 for SUGRA with truly unified'//
47934  & ' gauge couplings:'
47935  WRITE(mstu(11),*) 'ENTER 5 for non-minimal GMSB:'
47936  READ(lfn,*) imodel
47937  IF (imodel.EQ.4) THEN
47938  ial3un=1
47939  imodel=1
47940  ENDIF
47941  IF (imodel.EQ.1.OR.imodel.EQ.3) THEN
47942  WRITE(mstu(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47943  & //' sgn(mu), M_t:'
47944  READ(lfn,*) m0,mhf,a0,tanb,sgnmu,mt
47945  IF (imodel.EQ.3) THEN
47946  imodel=1
47947  110 WRITE(mstu(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47948  & //' 0 to continue:'
47949  WRITE(mstu(11),*) ' NUSUG1 = GUT scale gaugino masses'
47950  WRITE(mstu(11),*) ' NUSUG2 = GUT scale A terms'
47951  WRITE(mstu(11),*) ' NUSUG3 = GUT scale Higgs masses'
47952  WRITE(mstu(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47953  & //' generation masses'
47954  WRITE(mstu(11),*)
47955  & ' NUSUG5 = GUT scale 3rd generation masses'
47956  READ(lfn,*) inusug
47957  IF (inusug.EQ.0) THEN
47958  goto 120
47959  ELSEIF (inusug.EQ.1) THEN
47960  WRITE(mstu(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47961  READ(lfn,*) xnusug(1),xnusug(2),xnusug(3)
47962  IF (xnusug(3).LE.0.) THEN
47963  WRITE(mstu(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47964  CALL pystop(109)
47965  END IF
47966  ELSEIF (inusug.EQ.2) THEN
47967  WRITE(mstu(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47968  READ(lfn,*) xnusug(6),xnusug(5),xnusug(4)
47969  ELSEIF (inusug.EQ.3) THEN
47970  WRITE(mstu(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47971  READ(lfn,*) xnusug(7),xnusug(8)
47972  ELSEIF (inusug.EQ.4) THEN
47973  WRITE(mstu(11),*) 'Enter GUT scale M(ul), M(dr),'
47974  & //' M(ur), M(el), M(er):'
47975  READ(lfn,*) xnusug(13),xnusug(11),xnusug(12),
47976  & xnusug(10),xnusug(9)
47977  ELSEIF (inusug.EQ.5) THEN
47978  WRITE(mstu(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47979  & //' M(Ll), M(Lr):'
47980  READ(lfn,*) xnusug(18),xnusug(16),xnusug(17),
47981  & xnusug(15),xnusug(14)
47982  ENDIF
47983  goto 110
47984  ENDIF
47985  ELSEIF (imodel.EQ.2.OR.imodel.EQ.5) THEN
47986  imss(11)=1
47987  WRITE(mstu(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47988  & ,' sgn(mu), M_t, C_gv:'
47989  READ(lfn,*) m0,mhf,a0,tanb,sgnmu,mt,xcmgv
47990  xgmin(7)=xcmgv
47991  xgmin(8)=1.
47992 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47993  ampl=2.4d18
47994  amgvss=m0*mhf*xcmgv/sqrt(3d0)/ampl
47995  IF (imodel.EQ.5) THEN
47996  imodel=2
47997  WRITE(mstu(11),*) 'Rsl = factor multiplying gaugino'
47998  & ,' masses at M_mes'
47999  WRITE(mstu(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
48000  & ,' shifts at M_mes'
48001  WRITE(mstu(11),*) 'd_Y = mass**2 shifts proportional to',
48002  & ' Y at M_mes'
48003  WRITE(mstu(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
48004  & ,'SU(2),SU(3)'
48005  WRITE(mstu(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
48006  & ,' n5_2, n5_3'
48007  READ(lfn,*) xgmin(8),xgmin(9),xgmin(10),xgmin(11),xgmin(12),
48008  $ xgmin(13),xgmin(14)
48009  ENDIF
48010  ELSE
48011  WRITE(mstu(11),*) 'Invalid model choice.'
48012  goto 9999
48013  ENDIF
48014  ENDIF
48015 
48016  120 mzero=m0
48017  mhlf=mhf
48018  azero=a0
48019 C TANB=REAL(RMSS(5))
48020 C SGNMU=REAL(RMSS(4))
48021  mtop=mt
48022 
48023 C...Initialize MSSM parameter array
48024  130 DO 140 ipar=1,72
48025  super(ipar)=0.0
48026  140 CONTINUE
48027 C...Call ISASUGRA
48028  CALL sugra(mzero,mhlf,azero,tanb,sgnmu,mtop,imodel)
48029 C...Check whether ISASUSY thought the model was OK.
48030  IF (nogood.NE.0) THEN
48031  IF (nogood.EQ.1) CALL pyerrm(26
48032  & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
48033  IF (nogood.EQ.2) CALL pyerrm(26
48034  & ,'(PYSUGI:) SUSY parameters give no EWSB.')
48035  IF (nogood.EQ.3) CALL pyerrm(26
48036  & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
48037  IF (nogood.EQ.4) CALL pyerrm(26
48038  & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
48039  IF (nogood.EQ.7) CALL pyerrm(26
48040  & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
48041  IF (nogood.EQ.8) CALL pyerrm(26
48042  & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
48043 C...Give warning, but don't stop, if LSP not ~chi_10.
48044  IF (nogood.EQ.5) CALL pyerrm(16
48045  & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
48046  ENDIF
48047 C...Warn about possible GUT scale tachyons.
48048  IF (itachy.NE.0) CALL pyerrm(16,
48049  & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
48050 C...Finalize spectrum (last iteration)
48051 C...(Thanks to A. Raklev for pointing this out.)
48052 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
48053  CALL ssmssm(xisain(1),xisain(2),xisain(3),
48054  $ xisain(4),xisain(5),xisain(6),xisain(7),xisain(8),xisain(9),
48055  $ xisain(10),xisain(11),xisain(12),xisain(13),xisain(14),
48056  $ xisain(15),xisain(16),xisain(17),xisain(18),xisain(19),
48057  $ xisain(20),xisain(21),xisain(22),xisain(23),xisain(24),
48058  $ mtop,iallow,1)
48059 
48060 C...M1, M2, M3.
48061  rmss(1)=dble(gss(7))
48062  rmss(2)=dble(gss(8))
48063  rmss(3)=dble(gss(9))
48064  rmsoft(1)=dble(gss(7))
48065  rmsoft(2)=dble(gss(8))
48066  rmsoft(3)=dble(gss(9))
48067 C...Mu = - Higgsino mass.
48068  rmss(4)=-super(29)
48069  rmss(5)=tanb
48070 C...Slepton and squark masses. 2 first generations.
48071  rmss(6)=0.5*(super(18)+super(20))
48072  rmss(7)=0.5*(super(19)+super(21))
48073  rmss(8)=0.25*(super(2)+super(4)+super(6)+super(8))
48074  rmss(9)=0.25*(super(3)+super(5)+super(7)+super(9))
48075 C...Third generation.
48076  rmss(10)=0.5*(super(14)+super(10))
48077  rmss(11)=super(11)
48078  rmss(12)=super(15)
48079  rmss(13)=super(22)
48080  rmss(14)=super(23)
48081 C...SLHA: store exact soft spectrum in RMSOFT
48082  rmsoft(31)=super(18)
48083  rmsoft(32)=super(20)
48084  rmsoft(33)=super(22)
48085  rmsoft(34)=super(19)
48086  rmsoft(35)=super(21)
48087  rmsoft(36)=super(23)
48088  rmsoft(41)=0.5d0*(super(2)+super(4))
48089  rmsoft(42)=0.5d0*(super(6)+super(8))
48090  rmsoft(43)=0.5d0*(super(10)+super(14))
48091  rmsoft(44)=super(3)
48092  rmsoft(45)=super(9)
48093  rmsoft(46)=super(15)
48094  rmsoft(47)=super(5)
48095  rmsoft(48)=super(7)
48096  rmsoft(49)=super(11)
48097 
48098 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
48099  rmss(15)=super(62)
48100  rmss(16)=super(60)
48101  rmss(17)=super(64)
48102  rmss(26)=super(63)
48103  rmss(27)=super(61)
48104  rmss(28)=super(65)
48105 C...SLHA trilinears
48106  DO 142 k1=1,3
48107  DO 141 k2=1,3
48108  ae(k1,k2)=0d0
48109  au(k1,k2)=0d0
48110  ad(k1,k2)=0d0
48111  141 CONTINUE
48112  142 CONTINUE
48113  ae(3,3)=super(64)
48114  au(3,3)=super(60)
48115  ad(3,3)=super(62)
48116 C...Higgs mixing angle alpha (Gunion-Haber convention).
48117  rmss(18)=-super(59)
48118 C...A0 mass.
48119  rmss(19)=super(57)
48120 C...GUT scale coupling
48121  rmss(20)=agutss
48122 C...Gravitino mass (for future compatibility)
48123  rmss(21)=max(rmss(21),dble(super(66)))
48124 
48125 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
48126 C...Higgs sector.
48127  pmas(pycomp(25),1)=abs(super(55))
48128  pmas(pycomp(35),1)=abs(super(56))
48129  pmas(pycomp(36),1)=abs(super(57))
48130  pmas(pycomp(37),1)=abs(super(58))
48131 C...Gluino.
48132  pmas(pycomp(ksusy1+21),1)=abs(super(1))
48133 C...Squarks and Sleptons.
48134  DO 150 ilr=1,2
48135  ilrm=ilr-1
48136  pmas(pycomp(ilr*ksusy1+1),1)=abs(super(4+ilrm))
48137  pmas(pycomp(ilr*ksusy1+2),1)=abs(super(2+ilrm))
48138  pmas(pycomp(ilr*ksusy1+3),1)=abs(super(6+ilrm))
48139  pmas(pycomp(ilr*ksusy1+4),1)=abs(super(8+ilrm))
48140  pmas(pycomp(ilr*ksusy1+5),1)=abs(super(12+ilrm))
48141  pmas(pycomp(ilr*ksusy1+6),1)=abs(super(16+ilrm))
48142  pmas(pycomp(ilr*ksusy1+11),1)=abs(super(18+ilrm))
48143  pmas(pycomp(ilr*ksusy1+13),1)=abs(super(20+ilrm))
48144  pmas(pycomp(ilr*ksusy1+15),1)=abs(super(24+ilrm))
48145  150 CONTINUE
48146  pmas(pycomp(ksusy1+12),1)=abs(super(26))
48147  pmas(pycomp(ksusy1+14),1)=abs(super(27))
48148  pmas(pycomp(ksusy1+16),1)=abs(super(28))
48149 C...Neutralinos.
48150  pmas(pycomp(ksusy1+22),1)=abs(super(31))
48151  pmas(pycomp(ksusy1+23),1)=abs(super(32))
48152  pmas(pycomp(ksusy1+25),1)=abs(super(33))
48153  pmas(pycomp(ksusy1+35),1)=abs(super(34))
48154 C...Signed masses (extra minus from going to G-H convention).
48155  smz(1)=-super(31)
48156  smz(2)=-super(32)
48157  smz(3)=-super(33)
48158  smz(4)=-super(34)
48159 C...Charginos
48160  pmas(pycomp(ksusy1+24),1)=abs(super(51))
48161  pmas(pycomp(ksusy1+37),1)=abs(super(52))
48162 C...Signed masses (extra minus from going to G-H convention).
48163  smw(1)=-super(51)
48164  smw(2)=-super(52)
48165 
48166 C... Neutralino Mixing.
48167  DO 160 in=1,4
48168  zmix(in,1)= super(38+4*(in-1))
48169  zmix(in,2)= super(37+4*(in-1))
48170  zmix(in,3)=-super(36+4*(in-1))
48171  zmix(in,4)=-super(35+4*(in-1))
48172  160 CONTINUE
48173 C...Chargino Mixing (PYTHIA same angle as HERWIG).
48174  thx=1d0
48175  thy=1d0
48176  IF (super(53).GT.0) thx=-1d0
48177  IF (super(54).GT.0) thy=-1d0
48178  umix(1,1) = -sin(super(53))
48179  umix(1,2) = -cos(super(53))
48180  umix(2,1) = -thx*cos(super(53))
48181  umix(2,2) = thx*sin(super(53))
48182  vmix(1,1) = -sin(super(54))
48183  vmix(1,2) = -cos(super(54))
48184  vmix(2,1) = -thy*cos(super(54))
48185  vmix(2,2) = thy*sin(super(54))
48186 C...Sfermion mixing (PYTHIA same angle as ISAJET)
48187  sfmix(5,1)=cos(super(63))
48188  sfmix(5,2)=sin(super(63))
48189  sfmix(5,3)=-sin(super(63))
48190  sfmix(5,4)=cos(super(63))
48191  sfmix(6,1)=cos(super(61))
48192  sfmix(6,2)=sin(super(61))
48193  sfmix(6,3)=-sin(super(61))
48194  sfmix(6,4)=cos(super(61))
48195  sfmix(15,1)=cos(super(65))
48196  sfmix(15,2)=sin(super(65))
48197  sfmix(15,3)=-sin(super(65))
48198  sfmix(15,4)=cos(super(65))
48199 
48200  IF (mstp(122).NE.0) THEN
48201 C...Print a few lines to make the user know what's happening
48202  isaver=visaje()
48203  WRITE(mstu(11),5000) doc, isaver
48204  WRITE(mstu(11),5100)
48205  IF (imodel.EQ.1) THEN
48206  WRITE(mstu(11),5200) mzero, mhlf, azero, tanb, nint(sgnmu),
48207  & mtop
48208  WRITE(mstu(11),5300)
48209  ENDIF
48210  WRITE(mstu(11),5500) 'Pole masses'
48211  WRITE(mstu(11),5700) (super(ip),ip=2,16,2),(super(ip),ip=3,17,2)
48212  WRITE(mstu(11),5800) (super(ip),ip=18,24,2),(super(ip),ip=26,28)
48213  & ,(super(ip),ip=19,25,2)
48214  WRITE(mstu(11),5900) super(1),(smz(ip),ip=1,4), (smw(ip)
48215  & ,ip=1,2)
48216  WRITE(mstu(11),5400)
48217  WRITE(mstu(11),6000) (super(ip),ip=55,58)
48218  WRITE(mstu(11),5400)
48219  WRITE(mstu(11),5500) 'EW scale mixing structure'
48220  WRITE(mstu(11),6100) ((zmix(i,j), j=1,4),i=1,4)
48221  WRITE(mstu(11),6200) (umix(1,j), j=1,2),(vmix(1,j),j=1,2)
48222  & ,(umix(2,j), j=1,2),(vmix(2,j),j=1,2)
48223  WRITE(mstu(11),6300) (sfmix(5,j), j=1,2),(sfmix(6,j),j=1,2)
48224  & ,(sfmix(15,j), j=1,2),(sfmix(5,j),j=3,4),(sfmix(6,j), j=3,4
48225  & ),(sfmix(15,j),j=3,4)
48226  WRITE(mstu(11),5400)
48227  WRITE(mstu(11),6450) rmss(18)
48228  WRITE(mstu(11),5400)
48229  WRITE(mstu(11),5500) 'Couplings'
48230  WRITE(mstu(11),6400) rmss(15),rmss(16),rmss(17),rmss(20)
48231  WRITE(mstu(11),5400)
48232  ENDIF
48233 
48234 C...Call FeynHiggs to improve Higgs sector if requested
48235  IF (imss(4).EQ.3) THEN
48236  IF (mstp(122).NE.0) WRITE(mstu(11),'(1x,"*"/1x,"*",A)')
48237  & ' (PYSUGI:) Now calling FeynHiggs.'
48238  CALL pyfeyn(ierr)
48239  IF (ierr.EQ.0) THEN
48240  imss(4)=2
48241  IF (mstp(122).NE.0) THEN
48242  WRITE(mstu(11),5400)
48243  WRITE(mstu(11),5500)
48244  & 'Corrected Higgs masses and mixing'
48245  WRITE(mstu(11),6000) pmas(25,1),pmas(35,1),pmas(36,1),
48246  & pmas(37,1)
48247  WRITE(mstu(11),6450) rmss(18)
48248  WRITE(mstu(11),5400)
48249  ENDIF
48250  ENDIF
48251  ENDIF
48252 
48253  IF (mstp(122).NE.0) WRITE(mstu(11),6500)
48254 
48255 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
48256 C...output by ISASUSY.
48257  imss(4)=max(2,imss(4))
48258 
48259  5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
48260  & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,a
48261  & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,a/1x,'*')
48262  5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
48263  5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
48264  & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(f8.2,1x),i8,2x,f8.2)
48265  5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
48266  & ,'----------------')
48267  5400 FORMAT(1x,'*',1x,a)
48268  5500 FORMAT(1x,'*',1x,a,':')
48269  5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
48270  & 1x,'*',2x,1p,2(1x,e8.2),2x,e8.2)
48271  5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
48272  & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
48273  & '~t(12)'/1x,'*',2x,'L',1x,8(f8.2,1x)/1x,'*',2x,'R',1x,8(f8.2
48274  & ,1x))
48275  5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
48276  & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
48277  & ,'~nu_tau'/1x,'*',2x,'L',1x,7(f8.2,1x)/1x,'*',2x,'R',1x,4(f8
48278  & .2,1x))
48279  5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
48280  & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
48281  & ,1x,'~chi_2+'/1x,'*',3x,1x,7(f8.2,1x))
48282  6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48283  & ,1x,4x,'H+'/1x,'*',3x,1x,5(f8.2,1x))
48284  6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48285  & ,1x,4x,'H+'/1x,'*',3x,1x,5(f8.2,1x),3x,'(Before FeynHiggs)')
48286  6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
48287  & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
48288  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
48289  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
48290  & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
48291  & ,1x,f6.3,1x),'|')
48292  6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
48293  & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
48294  & ,'~chi_1+',1x,2('|',1x,f6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
48295  & ,f6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,f6.3,1x),'|',9x
48296  & ,'~chi_2+',1x,2('|',1x,f6.3,1x),'|')
48297  6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
48298  & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
48299  & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
48300  & 1x,'*',3x,'~b_1',1x,2('|',1x,f6.3,1x),'|',3x,'~t_1',1x,2('|'
48301  & ,1x,f6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,f6.3,1x),'|'/
48302  & 1x,'*',3x,'~b_2',1x,2('|',1x,f6.3,1x),'|',3x,'~t_2',1x,2('|'
48303  & ,1x,f6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,f6.3,1x),'|')
48304  6400 FORMAT(1x,'*',3x,'A_b = ',f8.2,4x,'A_t = ',f8.2,4x,'A_tau = ',f8.2
48305  & ,4x,'Alpha_GUT = ',f8.2)
48306  6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',f8.4)
48307  6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
48308 
48309  9999 RETURN
48310  END
48311 
48312 C*********************************************************************
48313 
48314 C...PYFEYN
48315 C...Interface to FeynHiggs for MSSM Higgs sector.
48316 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
48317 C...P. Skands
48318 
48319  SUBROUTINE pyfeyn(IERR)
48320 
48321 C...Double precision and integer declarations.
48322  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48323  IMPLICIT INTEGER(i-n)
48324  INTEGER pyk,pychge,pycomp
48325 C...Commonblocks.
48326  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48327  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48328 C...SUSY blocks
48329  common/pymssm/imss(0:99),rmss(0:99)
48330 C...FeynHiggs variables
48331  DOUBLE PRECISION rmhigg(4)
48332  DOUBLE COMPLEX saeff, uhiggs(3,3)
48333  DOUBLE COMPLEX dmu,
48334  & ae33, au33, ad33, ae22, au22, ad22, ae11, au11, ad11,
48335  & dm1, dm2, dm3
48336 C...SLHA Common Block
48337  common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
48338  & au(3,3),ad(3,3),ae(3,3)
48339  SAVE /pydat1/,/pydat2/,/pymssm/,/pylh3p/
48340 
48341  ierr=0
48342  CALL fhsetflags(ierr,4,0,0,2,0,2,1,1)
48343  IF (ierr.NE.0) THEN
48344  CALL pyerrm(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
48345  & //'Will not use FeynHiggs for this run.')
48346  RETURN
48347  ENDIF
48348  q=rmsoft(0)
48349  dmb=pmas(5,1)
48350  dmt=pmas(6,1)
48351  dmz=pmas(23,1)
48352  dmw=pmas(24,1)
48353  dma=pmas(36,1)
48354  dm1=rmsoft(1)
48355  dm2=rmsoft(2)
48356  dm3=rmsoft(3)
48357  dtanb=rmss(5)
48358  dmu=rmss(4)
48359  dm3sl=rmsoft(33)
48360  dm3se=rmsoft(36)
48361  dm3sq=rmsoft(43)
48362  dm3su=rmsoft(46)
48363  dm3sd=rmsoft(49)
48364  dm2sl=rmsoft(32)
48365  dm2se=rmsoft(35)
48366  dm2sq=rmsoft(42)
48367  dm2su=rmsoft(45)
48368  dm2sd=rmsoft(48)
48369  dm1sl=rmsoft(31)
48370  dm1se=rmsoft(34)
48371  dm1sq=rmsoft(41)
48372  dm1su=rmsoft(44)
48373  dm1sd=rmsoft(47)
48374  ae33=ae(3,3)
48375  ae22=ae(2,2)
48376  ae11=ae(1,1)
48377  au33=au(3,3)
48378  au22=au(2,2)
48379  au11=au(1,1)
48380  ad33=ad(3,3)
48381  ad22=ad(2,2)
48382  ad11=ad(1,1)
48383  CALL fhsetpara(ierr, 1d0, dmt, dmb, dmw, dmz, dtanb,
48384  & dma,0d0, dm3sl, dm3se, dm3sq, dm3su, dm3sd,
48385  & dm2sl, dm2se, dm2sq, dm2su, dm2sd,
48386  & dm1sl, dm1se, dm1sq, dm1su, dm1sd,dmu,
48387  & ae33, au33, ad33, ae22, au22, ad22, ae11, au11, ad11,
48388  & dm1, dm2, dm3, 0d0, 0d0,q,q,q)
48389  IF (ierr.NE.0) THEN
48390  CALL pyerrm(11,'(PYHGGM:) Caught error from FHSETPARA.'
48391  & //' Will not use FeynHiggs for this run.')
48392  RETURN
48393  ENDIF
48394 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
48395  saeff=0d0
48396  CALL fhhiggscorr(ierr, rmhigg, saeff, uhiggs)
48397  IF (ierr.NE.0) THEN
48398  CALL pyerrm(11,'(PYFEYN:) Caught error from FHHIG'//
48399  & 'GSCORR. Will not use FeynHiggs for this run.')
48400  RETURN
48401  ENDIF
48402  alpha = asin(dble(saeff))
48403  r=rmss(18)/alpha
48404  IF (r.LT.0d0.OR.abs(r).GT.1.2d0.OR.abs(r).LT.0.8d0) THEN
48405  CALL pyerrm(1,'(PYFEYN:) Large corrections in Higgs sector.')
48406  WRITE(mstu(11),*) ' Old Alpha:', rmss(18)
48407  WRITE(mstu(11),*) ' New Alpha:', alpha
48408  ENDIF
48409  IF (rmhigg(1).LT.0.85d0*pmas(25,1).OR.rmhigg(1).GT.
48410  & 1.15d0*pmas(25,1)) THEN
48411  CALL pyerrm(1,'(PYFEYN:) Large corrections in Higgs sector.')
48412  WRITE(mstu(11),*) ' Old m(h0):', pmas(25,1)
48413  WRITE(mstu(11),*) ' New m(h0):', rmhigg(1)
48414  ENDIF
48415  rmss(18)=alpha
48416  pmas(25,1)=rmhigg(1)
48417  pmas(35,1)=rmhigg(2)
48418  pmas(36,1)=rmhigg(3)
48419  pmas(37,1)=rmhigg(4)
48420 
48421  RETURN
48422  END
48423 
48424 C*********************************************************************
48425 
48426 C...PYRNMQ
48427 C...Determines the running mass of Squarks.
48428 
48429  FUNCTION pyrnmq(ID,DTERM)
48430 
48431 C...Double precision and integer declarations.
48432  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48433  IMPLICIT INTEGER(i-n)
48434  INTEGER pyk,pychge,pycomp
48435 C...Commonblock.
48436  common/pymssm/imss(0:99),rmss(0:99)
48437  SAVE /pymssm/
48438 
48439 C...Local variables.
48440  DOUBLE PRECISION pi,r
48441  DOUBLE PRECISION tol
48442  DOUBLE PRECISION ci(3)
48443  EXTERNAL pyalps
48444  DOUBLE PRECISION pyalps
48445  DATA tol/0.001d0/
48446  DATA pi,r/3.141592654d0,.61803399d0/
48447  DATA ci/0.47d0,0.07d0,0.02d0/
48448 
48449  c=1d0-r
48450  ca=ci(id)
48451  ag=(0.71d0)**2/4d0/pi
48452  ag=rmss(20)
48453  xm0=rmss(8)
48454  xmg=rmss(1)
48455  xm02=xm0*xm0
48456  xmg2=xmg*xmg
48457 
48458  as=pyalps(xm02+6d0*xmg2)
48459  cg=8d0/9d0*((as/ag)**2-1d0)
48460  bx=xm02+(ca+cg)*xmg2+dterm
48461  ax=min(50d0**2,0.5d0*bx)
48462  cx=max(2000d0**2,2d0*bx)
48463 
48464  x0=ax
48465  x3=cx
48466  IF(abs(cx-bx).GT.abs(bx-ax))THEN
48467  x1=bx
48468  x2=bx+c*(cx-bx)
48469  ELSE
48470  x2=bx
48471  x1=bx-c*(bx-ax)
48472  ENDIF
48473  as1=pyalps(x1)
48474  cg=8d0/9d0*((as1/ag)**2-1d0)
48475  f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
48476  as2=pyalps(x2)
48477  cg=8d0/9d0*((as2/ag)**2-1d0)
48478  f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
48479  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
48480  IF(f2.LT.f1) THEN
48481  x0=x1
48482  x1=x2
48483  x2=r*x1+c*x3
48484  f1=f2
48485  as2=pyalps(x2)
48486  cg=8d0/9d0*((as2/ag)**2-1d0)
48487  f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
48488  ELSE
48489  x3=x2
48490  x2=x1
48491  x1=r*x2+c*x0
48492  f2=f1
48493  as1=pyalps(x1)
48494  cg=8d0/9d0*((as1/ag)**2-1d0)
48495  f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
48496  ENDIF
48497  goto 100
48498  ENDIF
48499  IF(f1.LT.f2) THEN
48500  pyrnmq=x1
48501  xmin=x1
48502  ELSE
48503  pyrnmq=x2
48504  xmin=x2
48505  ENDIF
48506 
48507  RETURN
48508  END
48509 
48510 C*********************************************************************
48511 
48512 C...PYTHRG
48513 C...Calculates the mass eigenstates of the third generation sfermions.
48514 C...Created: 5-31-96
48515 
48516  SUBROUTINE pythrg
48517 
48518 C...Double precision and integer declarations.
48519  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48520  IMPLICIT INTEGER(i-n)
48521  INTEGER pyk,pychge,pycomp
48522 C...Parameter statement to help give large particle numbers.
48523  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
48524  &kexcit=4000000,kdimen=5000000)
48525 C...Commonblocks.
48526  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48527  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48528  common/pymssm/imss(0:99),rmss(0:99)
48529  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
48530  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
48531  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
48532 
48533 C...Local variables.
48534  DOUBLE PRECISION beta
48535  DOUBLE PRECISION am2(2,2),rt(2,2),di(2,2)
48536  DOUBLE PRECISION xmz2,xmw2,tanb,xmu,cos2b,xmql2,xmqr2
48537  DOUBLE PRECISION xmf,xmf2,diff,same,xmf12,xmf22,small
48538  DOUBLE PRECISION atr,amqr,amql
48539  INTEGER id1(3),id2(3),id3(3),id4(3)
48540  INTEGER if,i,j,ii,jj,it,l
48541  LOGICAL dterm
48542  DATA small/1d-3/
48543  DATA id1/10,10,13/
48544  DATA id2/5,6,15/
48545  DATA id3/15,16,17/
48546  DATA id4/11,12,14/
48547  DATA dterm/.true./
48548 
48549  xmz2=pmas(23,1)**2
48550  xmw2=pmas(24,1)**2
48551  tanb=rmss(5)
48552  xmu=-rmss(4)
48553  beta=atan(tanb)
48554  cos2b=cos(2d0*beta)
48555 
48556 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
48557 
48558  iopt=imss(5)
48559  IF(iopt.EQ.1) THEN
48560  ctt=dcos(rmss(27))
48561  ctt2=ctt**2
48562  stt=dsin(rmss(27))
48563  stt2=stt**2
48564  xm12=rmss(10)**2
48565  xm22=rmss(12)**2
48566  xmql2=ctt2*xm12+stt2*xm22
48567  xmqr2=stt2*xm12+ctt2*xm22
48568  xmf2=pymrun(6,pmas(6,1)**2)**2
48569  atop=-xmu/tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
48570  rmss(16)=atop
48571 C......SUBTRACT OUT D-TERM AND FERMION MASS
48572  xmql2=xmql2-xmf2-(4d0*xmw2-xmz2)*cos2b/6d0
48573  xmqr2=xmqr2-xmf2+(xmw2-xmz2)*cos2b*2d0/3d0
48574  IF(xmql2.GE.0d0) THEN
48575  rmss(10)=sqrt(xmql2)
48576  ELSE
48577  rmss(10)=-sqrt(-xmql2)
48578  ENDIF
48579  IF(xmqr2.GE.0d0) THEN
48580  rmss(12)=sqrt(xmqr2)
48581  ELSE
48582  rmss(12)=-sqrt(-xmqr2)
48583  ENDIF
48584 
48585 C SAME FOR BOTTOM SQUARK
48586  ctt=dcos(rmss(26))
48587  ctt2=ctt**2
48588  stt=dsin(rmss(26))
48589  stt2=stt**2
48590  xm22=rmss(11)**2
48591  xmf2=pymrun(5,pmas(6,1)**2)**2
48592  xmql2=sign(rmss(10)**2,rmss(10))-(2d0*xmw2+xmz2)*cos2b/6d0+xmf2
48593  IF(abs(ctt).GE..9999d0) THEN
48594  abot=-xmu*tanb
48595  xmqr2=rmss(11)**2
48596  ELSEIF(abs(ctt).LE.1d-4) THEN
48597  abot=-xmu*tanb
48598  xmqr2=rmss(11)**2
48599  ELSE
48600  xm12=(xmql2-stt2*xm22)/ctt2
48601  xmqr2=stt2*xm12+ctt2*xm22
48602  abot=-xmu*tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
48603  ENDIF
48604  rmss(15)=abot
48605 C......SUBTRACT OUT D-TERM AND FERMION MASS
48606  xmqr2=xmqr2-(xmw2-xmz2)*cos2b/3d0-xmf2
48607  IF(xmqr2.GE.0d0) THEN
48608  rmss(11)=sqrt(xmqr2)
48609  ELSE
48610  rmss(11)=-sqrt(-xmqr2)
48611  ENDIF
48612 C SAME FOR TAU SLEPTON
48613  ctt=dcos(rmss(28))
48614  ctt2=ctt**2
48615  stt=dsin(rmss(28))
48616  stt2=stt**2
48617  xm12=rmss(13)**2
48618  xm22=rmss(14)**2
48619  xmql2=ctt2*xm12+stt2*xm22
48620  xmqr2=stt2*xm12+ctt2*xm22
48621  xmfr=pmas(15,1)
48622  xmf2=xmfr**2
48623  atau=-xmu*tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
48624  rmss(17)=atau
48625 C......SUBTRACT OUT D-TERM AND FERMION MASS
48626  xmql2=xmql2-xmf2+(-.5d0*xmz2+xmw2)*cos2b
48627  xmqr2=xmqr2-xmf2+(xmz2-xmw2)*cos2b
48628  IF(xmql2.GE.0d0) THEN
48629  rmss(13)=sqrt(xmql2)
48630  ELSE
48631  rmss(13)=-sqrt(-xmql2)
48632  ENDIF
48633  IF(xmqr2.GE.0d0) THEN
48634  rmss(14)=sqrt(xmqr2)
48635  ELSE
48636  rmss(14)=-sqrt(-xmqr2)
48637  ENDIF
48638  ENDIF
48639  DO 170 l=1,3
48640  amql=rmss(id1(l))
48641  IF(amql.LT.0d0) THEN
48642  xmql2=-amql**2
48643  ELSE
48644  xmql2=amql**2
48645  ENDIF
48646  atr=rmss(id3(l))
48647  amqr=rmss(id4(l))
48648  IF(amqr.LT.0d0) THEN
48649  xmqr2=-amqr**2
48650  ELSE
48651  xmqr2=amqr**2
48652  ENDIF
48653  if=id2(l)
48654  xmf=pymrun(IF,pmas(6,1)**2)
48655  xmf2=xmf**2
48656  am2(1,1)=xmql2+xmf2
48657  am2(2,2)=xmqr2+xmf2
48658  IF(am2(1,1).EQ.am2(2,2)) am2(2,2)=am2(2,2)*1.00001d0
48659  IF(dterm) THEN
48660  IF(l.EQ.1) THEN
48661  am2(1,1)=am2(1,1)-(2d0*xmw2+xmz2)*cos2b/6d0
48662  am2(2,2)=am2(2,2)+(xmw2-xmz2)*cos2b/3d0
48663  am2(1,2)=xmf*(atr+xmu*tanb)
48664  ELSEIF(l.EQ.2) THEN
48665  am2(1,1)=am2(1,1)+(4d0*xmw2-xmz2)*cos2b/6d0
48666  am2(2,2)=am2(2,2)-(xmw2-xmz2)*cos2b*2d0/3d0
48667  am2(1,2)=xmf*(atr+xmu/tanb)
48668  ELSEIF(l.EQ.3) THEN
48669  IF(imss(8).EQ.1) THEN
48670  am2(1,1)=rmss(6)**2
48671  am2(2,2)=rmss(7)**2
48672  am2(1,2)=0d0
48673  rmss(13)=rmss(6)
48674  rmss(14)=rmss(7)
48675  ELSE
48676  am2(1,1)=am2(1,1)-(-.5d0*xmz2+xmw2)*cos2b
48677  am2(2,2)=am2(2,2)-(xmz2-xmw2)*cos2b
48678  am2(1,2)=xmf*(atr+xmu*tanb)
48679  ENDIF
48680  ENDIF
48681  ENDIF
48682  am2(2,1)=am2(1,2)
48683  detm=am2(1,1)*am2(2,2)-am2(2,1)**2
48684  IF(detm.LT.0d0) THEN
48685  WRITE(mstu(11),*) id2(l),detm,am2
48686  CALL pyerrm(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
48687  ENDIF
48688  same=0.5d0*(am2(1,1)+am2(2,2))
48689  diff=0.5d0*sqrt((am2(1,1)-am2(2,2))**2+4d0*am2(1,2)*am2(2,1))
48690  xmf12=same-diff
48691  xmf22=same+diff
48692  it=0
48693  IF(xmf22-xmf12.GT.0d0) THEN
48694  rt(1,1) = sqrt(max(0d0,(xmf22-am2(1,1))/(xmf22-xmf12)))
48695  rt(2,2) = rt(1,1)
48696  rt(1,2) = -sign(sqrt(max(0d0,1d0-rt(1,1)**2)),
48697  & am2(1,2)/(xmf22-xmf12))
48698  rt(2,1) = -rt(1,2)
48699  ELSE
48700  rt(1,1) = 1d0
48701  rt(2,2) = rt(1,1)
48702  rt(1,2) = 0d0
48703  rt(2,1) = -rt(1,2)
48704  ENDIF
48705  100 CONTINUE
48706  it=it+1
48707 
48708  DO 140 i=1,2
48709  DO 130 jj=1,2
48710  di(i,jj)=0d0
48711  DO 120 ii=1,2
48712  DO 110 j=1,2
48713  di(i,jj)=di(i,jj)+rt(i,j)*am2(j,ii)*rt(jj,ii)
48714  110 CONTINUE
48715  120 CONTINUE
48716  130 CONTINUE
48717  140 CONTINUE
48718 
48719  IF(di(1,1).GT.di(2,2)) THEN
48720  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION '
48721  WRITE(mstu(11),*) l,sqrt(xmf12),sqrt(xmf22)
48722  WRITE(mstu(11),*) am2
48723  WRITE(mstu(11),*) di
48724  WRITE(mstu(11),*) rt
48725  di(1,1)=-rt(2,1)
48726  di(2,2)=rt(1,2)
48727  di(1,2)=-rt(2,2)
48728  di(2,1)=rt(1,1)
48729  DO 160 i=1,2
48730  DO 150 j=1,2
48731  rt(i,j)=di(i,j)
48732  150 CONTINUE
48733  160 CONTINUE
48734  goto 100
48735  ELSEIF(abs(di(1,2)*di(2,1)/di(1,1)/di(2,2)).GT.small) THEN
48736  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
48737  & ' OFF DIAGONAL ELEMENTS '
48738  WRITE(mstu(11),*) 'MASSES = ',l,sqrt(xmf12),sqrt(xmf22)
48739  WRITE(mstu(11),*) di
48740  WRITE(mstu(11),*) ' ROTATION = ',rt
48741 C...STOP
48742  ELSEIF(di(1,1).LT.0d0.OR.di(2,2).LT.0d0) THEN
48743  WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
48744  & ' NEGATIVE MASSES '
48745  CALL pystop(111)
48746  ENDIF
48747  pmas(pycomp(ksusy1+if),1)=sqrt(xmf12)
48748  pmas(pycomp(ksusy2+if),1)=sqrt(xmf22)
48749  sfmix(IF,1)=rt(1,1)
48750  sfmix(IF,2)=rt(1,2)
48751  sfmix(IF,3)=rt(2,1)
48752  sfmix(IF,4)=rt(2,2)
48753  170 CONTINUE
48754 
48755 C.....TAU SNEUTRINO MASS...L=3
48756 
48757  xarg=am2(1,1)+xmw2*cos2b
48758  IF(xarg.LT.0d0) THEN
48759  WRITE(mstu(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
48760  & ' FROM THE SUM RULE. '
48761  WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
48762  RETURN
48763  ELSE
48764  pmas(pycomp(ksusy1+16),1)=sqrt(xarg)
48765  ENDIF
48766 
48767  RETURN
48768  END
48769 C*********************************************************************
48770 
48771 C...PYINOM
48772 C...Finds the mass eigenstates and mixing matrices for neutralinos
48773 C...and charginos.
48774 
48775  SUBROUTINE pyinom
48776 
48777 C...Double precision and integer declarations.
48778  IMPLICIT DOUBLE PRECISION(a-h, o-z)
48779  IMPLICIT INTEGER(i-n)
48780  INTEGER pycomp
48781 C...Parameter statement to help give large particle numbers.
48782  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
48783  &kexcit=4000000,kdimen=5000000)
48784 C...Commonblocks.
48785  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48786  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48787  common/pymssm/imss(0:99),rmss(0:99)
48788  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
48789  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
48790  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
48791 
48792 C...Local variables.
48793  DOUBLE PRECISION xmw,xmz,xm(4)
48794  DOUBLE PRECISION ar(5,5),wr(5),zr(5,5),zi(5,5),ai(5,5)
48795  DOUBLE PRECISION wi(5),fv1(5),fv2(5),fv3(5)
48796  DOUBLE PRECISION cosw,sinw
48797  DOUBLE PRECISION xmu
48798  DOUBLE PRECISION tanb,cosb,sinb
48799  DOUBLE PRECISION xm1,xm2,xm3,beta
48800  DOUBLE PRECISION q2,aem,a1,a2,aq,rm1,rm2
48801  DOUBLE PRECISION arg,x0,x1,ax0,ax1,at,bt
48802  DOUBLE PRECISION y0,y1,amgx0,am1x0,amgx1,am1x1
48803  DOUBLE PRECISION argx0,ar1x0,argx1,ar1x1
48804  DOUBLE PRECISION pyalps,pyalem
48805  DOUBLE PRECISION pyrnm3
48806  COMPLEX*16 car(4,4),cai(4,4),ca1,ca2
48807  INTEGER ierr,index(4),i,j,k,iopt,ilr,kfnchi(4)
48808  DATA kfnchi/1000022,1000023,1000025,1000035/
48809 
48810  iopt=imss(2)
48811  IF(imss(1).EQ.2) THEN
48812  iopt=1
48813  ENDIF
48814 C...M1, M2, AND M3 ARE INDEPENDENT
48815  IF(iopt.EQ.0) THEN
48816  xm1=rmss(1)
48817  xm2=rmss(2)
48818  xm3=rmss(3)
48819  ELSEIF(iopt.GE.1) THEN
48820  q2=pmas(23,1)**2
48821  aem=pyalem(q2)
48822  a2=aem/paru(102)
48823  a1=aem/(1d0-paru(102))
48824  xm1=rmss(1)
48825  xm2=rmss(2)
48826  IF(imss(1).EQ.2) xm1=rmss(1)/rmss(20)*a1*5d0/3d0
48827  IF(iopt.EQ.1) THEN
48828  xm2=xm1*a2/a1*3d0/5d0
48829  rmss(2)=xm2
48830  ELSEIF(iopt.EQ.3) THEN
48831  xm1=xm2*5d0/3d0*a1/a2
48832  rmss(1)=xm1
48833  ENDIF
48834  xm3=pyrnm3(xm2/a2)
48835  rmss(3)=xm3
48836  IF(xm3.LE.0d0) THEN
48837  WRITE(mstu(11),*) ' ERROR WITH M3 = ',xm3
48838  CALL pystop(105)
48839  ENDIF
48840  ENDIF
48841 
48842 C...GLUINO MASS
48843  IF(imss(3).EQ.1) THEN
48844  pmas(pycomp(ksusy1+21),1)=abs(xm3)
48845  ELSE
48846  aq=0d0
48847  DO 110 i=1,4
48848  DO 100 ilr=1,2
48849  rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
48850  aq=aq+0.5d0*((2d0-rm1)*(rm1*log(rm1)-1d0)
48851  & +(1d0-rm1)**2*log(abs(1d0-rm1)))
48852  100 CONTINUE
48853  110 CONTINUE
48854 
48855  DO 130 i=5,6
48856  DO 120 ilr=1,2
48857  rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
48858  rm2=pmas(i,1)**2/xm3**2
48859  arg=(rm1-rm2-1d0)**2-4d0*rm2**2
48860  IF(arg.GE.0d0) THEN
48861  x0=0.5d0*(1d0+rm2-rm1-sqrt(arg))
48862  ax0=abs(x0)
48863  x1=0.5d0*(1d0+rm2-rm1+sqrt(arg))
48864  ax1=abs(x1)
48865  IF(x0.EQ.1d0) THEN
48866  at=-1d0
48867  bt=0.25d0
48868  ELSEIF(x0.EQ.0d0) THEN
48869  at=0d0
48870  bt=-0.25d0
48871  ELSE
48872  at=0.5d0*log(abs(1d0-x0))*(1d0-x0**2)+
48873  & 0.5d0*x0**2*log(ax0)
48874  bt=(-1d0-2d0*x0)/4d0
48875  ENDIF
48876  IF(x1.EQ.1d0) THEN
48877  at=-1d0+at
48878  bt=0.25d0+bt
48879  ELSEIF(x1.EQ.0d0) THEN
48880  at=0d0+at
48881  bt=-0.25d0+bt
48882  ELSE
48883  at=0.5d0*log(abs(1d0-x1))*(1d0-x1**2)+0.5d0*
48884  & x1**2*log(ax1)+at
48885  bt=(-1d0-2d0*x1)/4d0+bt
48886  ENDIF
48887  aq=aq+at+bt
48888  ELSE
48889  x0=0.5d0*(1d0+rm2-rm1)
48890  y0=-0.5d0*sqrt(-arg)
48891  amgx0=sqrt(x0**2+y0**2)
48892  am1x0=sqrt((1d0-x0)**2+y0**2)
48893  argx0=atan2(-x0,-y0)
48894  ar1x0=atan2(1d0-x0,y0)
48895  x1=x0
48896  y1=-y0
48897  amgx1=amgx0
48898  am1x1=am1x0
48899  argx1=atan2(-x1,-y1)
48900  ar1x1=atan2(1d0-x1,y1)
48901  at=0.5d0*log(am1x0)*(1d0-x0**2+3d0*y0**2)
48902  & +0.5d0*(x0**2-y0**2)*log(amgx0)
48903  bt=(-1d0-2d0*x0)/4d0+x0*y0*( ar1x0-argx0 )
48904  at=at+0.5d0*log(am1x1)*(1d0-x1**2+3d0*y1**2)
48905  & +0.5d0*(x1**2-y1**2)*log(amgx1)
48906  bt=bt+(-1d0-2d0*x1)/4d0+x1*y1*( ar1x1-argx1 )
48907  aq=aq+at+bt
48908  ENDIF
48909  120 CONTINUE
48910  130 CONTINUE
48911  pmas(pycomp(ksusy1+21),1)=abs(xm3)*(1d0+pyalps(xm3**2)
48912  & /(2d0*paru(2))*(15d0+aq))
48913  ENDIF
48914 
48915 C...NEUTRALINO MASSES
48916  DO 150 i=1,4
48917  DO 140 j=1,4
48918  ai(i,j)=0d0
48919  140 CONTINUE
48920  150 CONTINUE
48921  xmz=pmas(23,1)/100d0
48922  xmw=pmas(24,1)/100d0
48923  xmu=rmss(4)/100d0
48924  sinw=sqrt(paru(102))
48925  cosw=sqrt(1d0-paru(102))
48926  tanb=rmss(5)
48927  beta=atan(tanb)
48928  cosb=cos(beta)
48929  sinb=tanb*cosb
48930 
48931  xm2=xm2/100d0
48932  xm1=xm1/100d0
48933 
48934 
48935 C... Definitions:
48936 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48937 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48938  ar(1,1) = xm1*cos(rmss(30))
48939  ai(1,1) = xm1*sin(rmss(30))
48940  ar(2,2) = xm2*cos(rmss(31))
48941  ai(2,2) = xm2*sin(rmss(31))
48942  ar(3,3) = 0d0
48943  ar(4,4) = 0d0
48944  ar(1,2) = 0d0
48945  ar(2,1) = 0d0
48946  ar(1,3) = -xmz*sinw*cosb
48947  ar(3,1) = ar(1,3)
48948  ar(1,4) = xmz*sinw*sinb
48949  ar(4,1) = ar(1,4)
48950  ar(2,3) = xmz*cosw*cosb
48951  ar(3,2) = ar(2,3)
48952  ar(2,4) = -xmz*cosw*sinb
48953  ar(4,2) = ar(2,4)
48954  ar(3,4) = -xmu*cos(rmss(33))
48955  ai(3,4) = -xmu*sin(rmss(33))
48956  ar(4,3) = -xmu*cos(rmss(33))
48957  ai(4,3) = -xmu*sin(rmss(33))
48958 C CALL PYEIG4(AR,WR,ZR)
48959  CALL pyeicg(5,4,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
48960  IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
48961  & 'PROBLEM WITH PYEICG IN PYINOM ')
48962  DO 160 i=1,4
48963  index(i)=i
48964  xm(i)=abs(wr(i))
48965  160 CONTINUE
48966  DO 180 i=2,4
48967  k=i
48968  DO 170 j=i-1,1,-1
48969  IF(xm(k).LT.xm(j)) THEN
48970  itmp=index(j)
48971  xtmp=xm(j)
48972  index(j)=index(k)
48973  xm(j)=xm(k)
48974  index(k)=itmp
48975  xm(k)=xtmp
48976  k=k-1
48977  ELSE
48978  goto 180
48979  ENDIF
48980  170 CONTINUE
48981  180 CONTINUE
48982 
48983 
48984  DO 210 i=1,4
48985  k=index(i)
48986  smz(i)=wr(k)*100d0
48987  pmas(pycomp(kfnchi(i)),1)=abs(smz(i))
48988  s=0d0
48989  DO 190 j=1,4
48990  s=s+zr(j,k)**2+zi(j,k)**2
48991  190 CONTINUE
48992  DO 200 j=1,4
48993  zmix(i,j)=zr(j,k)/sqrt(s)
48994  zmixi(i,j)=zi(j,k)/sqrt(s)
48995  IF(abs(zmix(i,j)).LT.1d-6) zmix(i,j)=0d0
48996  IF(abs(zmixi(i,j)).LT.1d-6) zmixi(i,j)=0d0
48997  200 CONTINUE
48998  210 CONTINUE
48999 
49000 C...CHARGINO MASSES
49001 C.....Find eigenvectors of X X^*
49002  DO i=1,4
49003  DO j=1,4
49004  ar(i,j)=0d0
49005  ai(i,j)=0d0
49006  ENDDO
49007  ENDDO
49008  ai(1,1) = 0d0
49009  ai(2,2) = 0d0
49010  ar(1,1) = xm2**2+2d0*xmw**2*sinb**2
49011  ar(2,2) = xmu**2+2d0*xmw**2*cosb**2
49012  ar(1,2) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*cosb+
49013  &xmu*cos(rmss(33))*sinb)
49014  ai(1,2) = sqrt(2d0)*xmw*(xm2*sin(rmss(31))*cosb-
49015  &xmu*sin(rmss(33))*sinb)
49016  ar(2,1) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*cosb+
49017  &xmu*cos(rmss(33))*sinb)
49018  ai(2,1) = sqrt(2d0)*xmw*(-xm2*sin(rmss(31))*cosb+
49019  &xmu*sin(rmss(33))*sinb)
49020  CALL pyeicg(5,2,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
49021  IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
49022  & 'PROBLEM WITH PYEICG IN PYINOM ')
49023  index(1)=1
49024  index(2)=2
49025  IF(wr(2).LT.wr(1)) THEN
49026  index(1)=2
49027  index(2)=1
49028  ENDIF
49029 
49030 
49031  DO 240 i=1,2
49032  k=index(i)
49033  smw(i)=sqrt(wr(k))*100d0
49034  s=0d0
49035  DO 220 j=1,2
49036  s=s+zr(j,k)**2+zi(j,k)**2
49037  220 CONTINUE
49038  DO 230 j=1,2
49039  umix(i,j)=zr(j,k)/sqrt(s)
49040  umixi(i,j)=-zi(j,k)/sqrt(s)
49041  IF(abs(umix(i,j)).LT.1d-6) umix(i,j)=0d0
49042  IF(abs(umixi(i,j)).LT.1d-6) umixi(i,j)=0d0
49043  230 CONTINUE
49044  240 CONTINUE
49045 C...Force chargino mass > neutralino mass
49046  ifrc=0
49047  IF(abs(smw(1)).LT.abs(smz(1))+2d0*pmas(pycomp(111),1)) THEN
49048  CALL pyerrm(8,'(PYINOM:) '//
49049  & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
49050  smw(1)=sign(abs(smz(1))+2d0*pmas(pycomp(111),1),smw(1))
49051  ifrc=1
49052  ENDIF
49053  pmas(pycomp(ksusy1+24),1)=smw(1)
49054  pmas(pycomp(ksusy1+37),1)=smw(2)
49055 
49056 C.....Find eigenvectors of X^* X
49057  DO i=1,4
49058  DO j=1,4
49059  ar(i,j)=0d0
49060  ai(i,j)=0d0
49061  zr(i,j)=0d0
49062  zi(i,j)=0d0
49063  ENDDO
49064  ENDDO
49065  ai(1,1) = 0d0
49066  ai(2,2) = 0d0
49067  ar(1,1) = xm2**2+2d0*xmw**2*cosb**2
49068  ar(2,2) = xmu**2+2d0*xmw**2*sinb**2
49069  ar(1,2) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*sinb+
49070  &xmu*cos(rmss(33))*cosb)
49071  ai(1,2) = sqrt(2d0)*xmw*(-xm2*sin(rmss(31))*sinb+
49072  &xmu*sin(rmss(33))*cosb)
49073  ar(2,1) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*sinb+
49074  &xmu*cos(rmss(33))*cosb)
49075  ai(2,1) = sqrt(2d0)*xmw*(xm2*sin(rmss(31))*sinb-
49076  &xmu*sin(rmss(33))*cosb)
49077  CALL pyeicg(5,2,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
49078  IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
49079  & 'PROBLEM WITH PYEICG IN PYINOM ')
49080  index(1)=1
49081  index(2)=2
49082  IF(wr(2).LT.wr(1)) THEN
49083  index(1)=2
49084  index(2)=1
49085  ENDIF
49086 
49087  simag=0d0
49088  DO 270 i=1,2
49089  k=index(i)
49090  s=0d0
49091  DO 250 j=1,2
49092  s=s+zr(j,k)**2+zi(j,k)**2
49093  simag=simag+zi(j,k)**2
49094  250 CONTINUE
49095  DO 260 j=1,2
49096  vmix(i,j)=zr(j,k)/sqrt(s)
49097  vmixi(i,j)=-zi(j,k)/sqrt(s)
49098  IF(abs(vmix(i,j)).LT.1d-6) vmix(i,j)=0d0
49099  IF(abs(vmixi(i,j)).LT.1d-6) vmixi(i,j)=0d0
49100  260 CONTINUE
49101  270 CONTINUE
49102 
49103 C.....Simplify if no phases
49104  IF(simag.LT.1d-6) THEN
49105  ar(1,1) = xm2*cos(rmss(31))
49106  ar(2,2) = xmu*cos(rmss(33))
49107  ar(1,2) = sqrt(2d0)*xmw*sinb
49108  ar(2,1) = sqrt(2d0)*xmw*cosb
49109  iknt=0
49110  300 CONTINUE
49111  DO i=1,2
49112  DO j=1,2
49113  zr(i,j)=0d0
49114  ENDDO
49115  ENDDO
49116 
49117  DO i=1,2
49118  DO j=1,2
49119  DO k=1,2
49120  DO l=1,2
49121  zr(i,j)=zr(i,j)+umix(i,k)*ar(k,l)*vmix(j,l)
49122  ENDDO
49123  ENDDO
49124  ENDDO
49125  ENDDO
49126  vmix(1,1)=vmix(1,1)*smw(1)/zr(1,1)/100d0
49127  vmix(1,2)=vmix(1,2)*smw(1)/zr(1,1)/100d0
49128  vmix(2,1)=vmix(2,1)*smw(2)/zr(2,2)/100d0
49129  vmix(2,2)=vmix(2,2)*smw(2)/zr(2,2)/100d0
49130  IF(iknt.EQ.2.AND.ifrc.EQ.0) THEN
49131  CALL pyerrm(18,'(PYINOM:) Problem with Charginos')
49132  ELSEIF(zr(1,1).LT.0d0.OR.zr(2,2).LT.0d0) THEN
49133  iknt=iknt+1
49134  goto 300
49135  ENDIF
49136 C.....Must deal with phases
49137  ELSE
49138  car(1,1) = xm2*cmplx(cos(rmss(31)),sin(rmss(31)))
49139  car(2,2) = xmu*cmplx(cos(rmss(33)),sin(rmss(33)))
49140  car(1,2) = sqrt(2d0)*xmw*sinb*cmplx(1d0,0d0)
49141  car(2,1) = sqrt(2d0)*xmw*cosb*cmplx(1d0,0d0)
49142 
49143  iknt=0
49144  310 CONTINUE
49145  DO i=1,2
49146  DO j=1,2
49147  cai(i,j)=cmplx(0d0,0d0)
49148  ENDDO
49149  ENDDO
49150 
49151  DO i=1,2
49152  DO j=1,2
49153  DO k=1,2
49154  DO l=1,2
49155  cai(i,j)=cai(i,j)+cmplx(umix(i,k),-umixi(i,k))*car(k,l)*
49156  & cmplx(vmix(j,l),vmixi(j,l))
49157  ENDDO
49158  ENDDO
49159  ENDDO
49160  ENDDO
49161 
49162  ca1=smw(1)*cai(1,1)/abs(cai(1,1))**2/100d0
49163  ca2=smw(2)*cai(2,2)/abs(cai(2,2))**2/100d0
49164  tempr=vmix(1,1)
49165  tempi=vmixi(1,1)
49166  vmix(1,1)=tempr*dble(ca1)-tempi*dimag(ca1)
49167  vmixi(1,1)=tempi*dble(ca1)+tempr*dimag(ca1)
49168  tempr=vmix(1,2)
49169  tempi=vmixi(1,2)
49170  vmix(1,2)=tempr*dble(ca1)-tempi*dimag(ca1)
49171  vmixi(1,2)=tempi*dble(ca1)+tempr*dimag(ca1)
49172  tempr=vmix(2,1)
49173  tempi=vmixi(2,1)
49174  vmix(2,1)=tempr*dble(ca2)-tempi*dimag(ca2)
49175  vmixi(2,1)=tempi*dble(ca2)+tempr*dimag(ca2)
49176  tempr=vmix(2,2)
49177  tempi=vmixi(2,2)
49178  vmix(2,2)=tempr*dble(ca2)-tempi*dimag(ca2)
49179  vmixi(2,2)=tempi*dble(ca2)+tempr*dimag(ca2)
49180  IF(iknt.EQ.2.AND.ifrc.EQ.0) THEN
49181  CALL pyerrm(18,'(PYINOM:) Problem with Charginos')
49182  ELSEIF(dble(ca1).LT.0d0.OR.dble(ca2).LT.0d0.OR.
49183  & abs(imag(ca1)).GT.1d-3.OR.abs(imag(ca2)).GT.1d-3) THEN
49184  iknt=iknt+1
49185  goto 310
49186  ENDIF
49187  ENDIF
49188  RETURN
49189  END
49190 
49191 C*********************************************************************
49192 
49193 C...PYRNM3
49194 C...Calculates the running of M3, the SU(3) gluino mass parameter.
49195 
49196  FUNCTION pyrnm3(RGUT)
49197 
49198 C...Double precision and integer declarations.
49199  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49200  IMPLICIT INTEGER(i-n)
49201  INTEGER pyk,pychge,pycomp
49202 
49203 C...Local variables.
49204  DOUBLE PRECISION r
49205  DOUBLE PRECISION tol
49206  EXTERNAL pyalps
49207  DOUBLE PRECISION pyalps
49208  DATA tol/0.001d0/
49209  DATA r/0.61803399d0/
49210 
49211  c=1d0-r
49212 
49213  bx=rgut*pyalps(rgut**2)
49214  ax=min(50d0,bx*0.5d0)
49215  cx=max(2000d0,2d0*bx)
49216 
49217  x0=ax
49218  x3=cx
49219  IF(abs(cx-bx).GT.abs(bx-ax))THEN
49220  x1=bx
49221  x2=bx+c*(cx-bx)
49222  ELSE
49223  x2=bx
49224  x1=bx-c*(bx-ax)
49225  ENDIF
49226  as1=pyalps(x1**2)
49227  f1=abs(x1-rgut*as1)
49228  as2=pyalps(x2**2)
49229  f2=abs(x2-rgut*as2)
49230  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
49231  IF(f2.LT.f1) THEN
49232  x0=x1
49233  x1=x2
49234  x2=r*x1+c*x3
49235  f1=f2
49236  as2=pyalps(x2**2)
49237  f2=abs(x2-rgut*as2)
49238  ELSE
49239  x3=x2
49240  x2=x1
49241  x1=r*x2+c*x0
49242  f2=f1
49243  as1=pyalps(x1**2)
49244  f1=abs(x1-rgut*as1)
49245  ENDIF
49246  goto 100
49247  ENDIF
49248  IF(f1.LT.f2) THEN
49249  pyrnm3=x1
49250  xmin=x1
49251  ELSE
49252  pyrnm3=x2
49253  xmin=x2
49254  ENDIF
49255 
49256  RETURN
49257  END
49258 
49259 C*********************************************************************
49260 
49261 C...PYEIG4
49262 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
49263 C...Specific application: mixing in neutralino sector.
49264 
49265  SUBROUTINE pyeig4(A,W,Z)
49266 
49267 C...Double precision and integer declarations.
49268  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49269  IMPLICIT INTEGER(i-n)
49270  INTEGER pyk,pychge,pycomp
49271 
49272 C...Arrays: in call and local.
49273  dimension a(4,4),w(4),z(4,4),x(4),d(4,4),e(4)
49274 
49275 C...Coefficients of fourth-degree equation from matrix.
49276 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
49277  b3=-(a(1,1)+a(2,2)+a(3,3)+a(4,4))
49278  b2=0d0
49279  DO 110 i=1,3
49280  DO 100 j=i+1,4
49281  b2=b2+a(i,i)*a(j,j)-a(i,j)*a(j,i)
49282  100 CONTINUE
49283  110 CONTINUE
49284  b1=0d0
49285  b0=0d0
49286  DO 120 i=1,4
49287  i1=mod(i,4)+1
49288  i2=mod(i+1,4)+1
49289  i3=mod(i+2,4)+1
49290  b1=b1+a(i,i)*(-a(i1,i1)*a(i2,i2)+a(i1,i2)*a(i2,i1)+
49291  & a(i1,i3)*a(i3,i1)+a(i2,i3)*a(i3,i2))-
49292  & a(i,i1)*a(i1,i2)*a(i2,i)-a(i,i2)*a(i2,i1)*a(i1,i)
49293  b0=b0+(-1d0)**(i+1)*a(1,i)*(
49294  & a(2,i1)*(a(3,i2)*a(4,i3)-a(3,i3)*a(4,i2))+
49295  & a(2,i2)*(a(3,i3)*a(4,i1)-a(3,i1)*a(4,i3))+
49296  & a(2,i3)*(a(3,i1)*a(4,i2)-a(3,i2)*a(4,i1)))
49297  120 CONTINUE
49298 
49299 C...Coefficients of third-degree equation needed for
49300 C...separation into two second-degree equations.
49301 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
49302  c2=-b2
49303  c1=b1*b3-4d0*b0
49304  c0=-b1**2-b0*b3**2+4d0*b0*b2
49305  cq=c1/3d0-c2**2/9d0
49306  cr=c1*c2/6d0-c0/2d0-c2**3/27d0
49307  cqr=cq**3+cr**2
49308 
49309 C...Cases with one or three real roots.
49310  IF(cqr.GE.0d0) THEN
49311  s1=(cr+sqrt(cqr))**(1d0/3d0)
49312  s2=(cr-sqrt(cqr))**(1d0/3d0)
49313  u=s1+s2-c2/3d0
49314  ELSE
49315  sabs=sqrt(-cq)
49316  the=acos(cr/sabs**3)/3d0
49317  sre=sabs*cos(the)
49318  u=2d0*sre-c2/3d0
49319  ENDIF
49320 
49321 C...Find and solve two second-degree equations.
49322  p1=b3/2d0-sqrt(b3**2/4d0+u-b2)
49323  p2=b3/2d0+sqrt(b3**2/4d0+u-b2)
49324  q1=u/2d0+sqrt(u**2/4d0-b0)
49325  q2=u/2d0-sqrt(u**2/4d0-b0)
49326  IF(abs(p1*q1+p2*q2-b1).LT.abs(p1*q2+p2*q1-b1)) THEN
49327  qsav=q1
49328  q1=q2
49329  q2=qsav
49330  ENDIF
49331  x(1)=-p1/2d0+sqrt(p1**2/4d0-q1)
49332  x(2)=-p1/2d0-sqrt(p1**2/4d0-q1)
49333  x(3)=-p2/2d0+sqrt(p2**2/4d0-q2)
49334  x(4)=-p2/2d0-sqrt(p2**2/4d0-q2)
49335 
49336 C...Order eigenvalues in asceding mass.
49337  w(1)=x(1)
49338  DO 150 i1=2,4
49339  DO 130 i2=i1-1,1,-1
49340  IF(abs(x(i1)).GE.abs(w(i2))) goto 140
49341  w(i2+1)=w(i2)
49342  130 CONTINUE
49343  140 w(i2+1)=x(i1)
49344  150 CONTINUE
49345 
49346 C...Find equation system for eigenvectors.
49347  DO 250 i=1,4
49348  DO 170 j1=1,4
49349  d(j1,j1)=a(j1,j1)-w(i)
49350  DO 160 j2=j1+1,4
49351  d(j1,j2)=a(j1,j2)
49352  d(j2,j1)=a(j2,j1)
49353  160 CONTINUE
49354  170 CONTINUE
49355 
49356 C...Find largest element in matrix.
49357  damax=0d0
49358  DO 190 j1=1,4
49359  DO 180 j2=1,4
49360  IF(abs(d(j1,j2)).LE.damax) goto 180
49361  ja=j1
49362  jb=j2
49363  damax=abs(d(j1,j2))
49364  180 CONTINUE
49365  190 CONTINUE
49366 
49367 C...Subtract others by multiple of row selected above.
49368  damax=0d0
49369  DO 210 j3=ja+1,ja+3
49370  j1=j3-4*((j3-1)/4)
49371  rl=d(j1,jb)/d(ja,jb)
49372  DO 200 j2=1,4
49373  d(j1,j2)=d(j1,j2)-rl*d(ja,j2)
49374  IF(abs(d(j1,j2)).LE.damax) goto 200
49375  jc=j1
49376  jd=j2
49377  damax=abs(d(j1,j2))
49378  200 CONTINUE
49379  210 CONTINUE
49380 
49381 C...Do one more subtraction of a row.
49382  damax=0d0
49383  DO 230 j3=jc+1,jc+3
49384  j1=j3-4*((j3-1)/4)
49385  IF(j1.EQ.ja) goto 230
49386  rl=d(j1,jd)/d(jc,jd)
49387  DO 220 j2=1,4
49388  IF(j2.EQ.jb) goto 220
49389  d(j1,j2)=d(j1,j2)-rl*d(jc,j2)
49390  IF(abs(d(j1,j2)).LE.damax) goto 220
49391  je=j1
49392  damax=abs(d(j1,j2))
49393  220 CONTINUE
49394  230 CONTINUE
49395 
49396 C...Construct unnormalized eigenvector.
49397  jf1=jd+1-4*(jd/4)
49398  jf2=jd+2-4*((jd+1)/4)
49399  IF(jf1.EQ.jb) jf1=jd+3-4*((jd+2)/4)
49400  IF(jf2.EQ.jb) jf2=jd+3-4*((jd+2)/4)
49401  e(jf1)=-d(je,jf2)
49402  e(jf2)=d(je,jf1)
49403  e(jd)=-(d(jc,jf1)*e(jf1)+d(jc,jf2)*e(jf2))/d(jc,jd)
49404  e(jb)=-(d(ja,jf1)*e(jf1)+d(ja,jf2)*e(jf2)+d(ja,jd)*e(jd))/
49405  & d(ja,jb)
49406 
49407 C...Normalize and fill in final array.
49408  ea=sqrt(e(1)**2+e(2)**2+e(3)**2+e(4)**2)
49409  sgn=(-1d0)**int(pyr(0)+0.5d0)
49410  DO 240 j=1,4
49411  z(i,j)=sgn*e(j)/ea
49412  240 CONTINUE
49413  250 CONTINUE
49414 
49415  RETURN
49416  END
49417 
49418 C*********************************************************************
49419 
49420 C...PYHGGM
49421 C...Determines the Higgs boson mass spectrum using several inputs.
49422 
49423  SUBROUTINE pyhggm(ALPHA)
49424 
49425 C...Double precision and integer declarations.
49426  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49427  IMPLICIT INTEGER(i-n)
49428  INTEGER pyk,pychge,pycomp
49429 C...Parameter statement to help give large particle numbers.
49430  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
49431  &kexcit=4000000,kdimen=5000000)
49432 C...Commonblocks.
49433  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49434  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49435  common/pypars/mstp(200),parp(200),msti(200),pari(200)
49436  common/pymssm/imss(0:99),rmss(0:99)
49437  SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/
49438 
49439 C...Local variables.
49440  DOUBLE PRECISION at,ab,xmu,tanb
49441  DOUBLE PRECISION alpha
49442  INTEGER ihopt
49443  DOUBLE PRECISION dma,dtanb,dmq,dmur,dmtop,dau,dad
49444  DOUBLE PRECISION dmu,dmh,dhm,dmhch,dsa,dca,dtanba
49445  DOUBLE PRECISION dmc,dmdr,dmhp,dhmp,damp
49446  DOUBLE PRECISION dstop1,dstop2,dsbot1,dsbot2
49447 
49448  ihopt=imss(4)
49449  IF(ihopt.EQ.2) THEN
49450  alpha=rmss(18)
49451  RETURN
49452  ENDIF
49453  at=rmss(16)
49454  ab=rmss(15)
49455  dmgl=rmss(3)
49456  xmu=rmss(4)
49457  tanb=rmss(5)
49458 
49459  dma=rmss(19)
49460  dtanb=tanb
49461  dmq=rmss(10)
49462  dmur=rmss(12)
49463  dmdr=rmss(11)
49464  dmtop=pmas(6,1)
49465  dmc=pmas(pycomp(ksusy1+37),1)
49466  dau=at
49467  dad=ab
49468  dmu=xmu
49469  rmss(40)=0d0
49470  rmss(41)=0d0
49471 
49472  IF(ihopt.EQ.0) THEN
49473  CALL pysubh(dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
49474  & dmhch,dsa,dca,dtanba)
49475  ELSEIF(ihopt.EQ.1) THEN
49476  CALL pysubh(dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
49477  & dmhch,dsa,dca,dtanba)
49478  CALL pypole(3,dmc,dma,dtanb,dmq,dmur,dmdr,dmtop,dau,dad,dmu,
49479  & dmh,dmhp,dhm,dhmp,damp,dsa,dca,
49480  & dstop1,dstop2,dsbot1,dsbot2,dtanba,dmgl,ddt,ddb)
49481  rmss(40)=ddt
49482  rmss(41)=ddb
49483  dmh=dmhp
49484  dhm=dhmp
49485  dma=damp
49486  IF(abs(pmas(pycomp(1000006),1)-dstop2).GT.5d-1) THEN
49487  WRITE(mstu(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
49488  WRITE(mstu(11),*) ' STOP1 MASSES = ',
49489  & pmas(pycomp(1000006),1),dstop2
49490  ENDIF
49491  IF(abs(pmas(pycomp(2000006),1)-dstop1).GT.5d-1) THEN
49492  WRITE(mstu(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
49493  WRITE(mstu(11),*) ' STOP2 MASSES = ',
49494  & pmas(pycomp(2000006),1),dstop1
49495  ENDIF
49496  IF(abs(pmas(pycomp(1000005),1)-dsbot2).GT.5d-1) THEN
49497  WRITE(mstu(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
49498  WRITE(mstu(11),*) ' SBOT1 MASSES = ',
49499  & pmas(pycomp(1000005),1),dsbot2
49500  ENDIF
49501  IF(abs(pmas(pycomp(2000005),1)-dsbot1).GT.5d-1) THEN
49502  WRITE(mstu(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
49503  WRITE(mstu(11),*) ' SBOT2 MASSES = ',
49504  & pmas(pycomp(2000005),1),dsbot1
49505  ENDIF
49506 
49507  ELSEIF (ihopt.EQ.3) THEN
49508 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
49509 C...Currently only available for SLHA spectrum read-in.
49510  IF (imss(1).NE.11.AND.imss(1).NE.12.AND.imss(1).NE.13) THEN
49511  CALL pyerrm(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
49512  & //' spectrum, change IMSS(1) or IMSS(4) option.')
49513  ENDIF
49514  alpha=rmss(18)
49515  RETURN
49516  ENDIF
49517 
49518  alpha=acos(dca)
49519 
49520  pmas(25,1)=dmh
49521  pmas(35,1)=dhm
49522  pmas(36,1)=dma
49523  pmas(37,1)=dmhch
49524 
49525  RETURN
49526  END
49527 
49528 C*********************************************************************
49529 
49530 C...PYSUBH
49531 C...This routine computes the renormalization group improved
49532 C...values of Higgs masses and couplings in the MSSM.
49533 
49534 C...Program based on the work by M. Carena, J.R. Espinosa,
49535 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
49536 
49537 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
49538 C...All masses in GeV units. MA is the CP-odd Higgs mass,
49539 C...MTOP is the physical top mass, MQ and MUR are the soft
49540 C...supersymmetry breaking mass parameters of left handed
49541 C...and right handed stops respectively, AU and AD are the
49542 C...stop and sbottom trilinear soft breaking terms,
49543 C...respectively, and MU is the supersymmetric
49544 C...Higgs mass parameter. We use the conventions from
49545 C...the physics report of Haber and Kane: left right
49546 C...stop mixing term proportional to (AU - MU/TANB)
49547 C...We use as input TANB defined at the scale MTOP
49548 
49549 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
49550 C...where MH and HM are the lightest and heaviest CP-even
49551 C...Higgs masses, MHCH is the charged Higgs mass and
49552 C...ALPHA is the Higgs mixing angle
49553 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
49554 
49555 C...Range of validity:
49556 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
49557 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
49558 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
49559 C...are the sbottom mass eigenvalues, respectively. This
49560 C...range automatically excludes the existence of tachyons.
49561 C...For the charged Higgs mass computation, the method is
49562 C...valid if
49563 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
49564 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
49565 C...where M_SUSY**2 is the average of the squared stop mass
49566 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
49567 C...masses have been assumed to be of order of the stop ones
49568 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
49569 
49570  SUBROUTINE pysubh (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
49571  &xmhch,sa,ca,tanba)
49572 
49573 C...Double precision and integer declarations.
49574  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49575  IMPLICIT INTEGER(i-n)
49576  INTEGER pyk,pychge,pycomp
49577 C...Parameter statement to help give large particle numbers.
49578  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
49579  &kexcit=4000000,kdimen=5000000)
49580 C...Commonblocks.
49581  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49582  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49583  common/pyhtri/hhh(7)
49584  SAVE /pydat1/,/pydat2/
49585 
49586 C...Local variables.
49587  DOUBLE PRECISION pyalem,pyalps
49588  DOUBLE PRECISION tanb,xmq,xmur,xmtop,au,ad,xmu,xmh,xhm
49589  DOUBLE PRECISION xmhch,sa,ca
49590  DOUBLE PRECISION xma,aem,alp1,alp2,alph3z,v,pi
49591  DOUBLE PRECISION q02
49592  DOUBLE PRECISION tanba,tanbt,xmb,alp3
49593  DOUBLE PRECISION rmtop,xms,t,sinb,cosb
49594  DOUBLE PRECISION xlam1,xlam2,xlam3,xlam4,xlam5,xlam6
49595  DOUBLE PRECISION xlam7,xau,xad,g1,g2,g3,hu,hd,hu2
49596  DOUBLE PRECISION hd2,hu4,hd4,sinbt,cosbt
49597  DOUBLE PRECISION trm2,detm2,xmh2,xhm2,xmhch2
49598  DOUBLE PRECISION sinalp,cosalp,aud,pi2,xms2,xms4,ad2
49599  DOUBLE PRECISION au2,xmu2,xmz,xms3
49600 
49601  xmz = pmas(23,1)
49602  q02=xmz**2
49603  aem=pyalem(q02)
49604  alp1=aem/(1d0-paru(102))
49605  alp2=aem/paru(102)
49606  alph3z=pyalps(q02)
49607 
49608  alp1 = 0.0101d0
49609  alp2 = 0.0337d0
49610  alph3z = 0.12d0
49611 
49612  v = 174.1d0
49613  pi = paru(1)
49614  tanba = tanb
49615  tanbt = tanb
49616 
49617 C...MBOTTOM(MTOP) = 3. GEV
49618  xmb = pymrun(5,xmtop**2)
49619  alp3 = alph3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alph3z*
49620  &log(xmtop**2/xmz**2))
49621 
49622 C...RMTOP= RUNNING TOP QUARK MASS
49623  rmtop = xmtop/(1d0+4d0*alp3/3d0/pi)
49624  xms = ((xmq**2 + xmur**2)/2d0 + xmtop**2)**0.5d0
49625  t = log(xms**2/xmtop**2)
49626  sinb = tanb/((1d0 + tanb**2)**0.5d0)
49627  cosb = sinb/tanb
49628 C...IF(MA.LE.XMTOP) TANBA = TANBT
49629  IF(xma.GT.xmtop)
49630  &tanba = tanbt*(1d0-3d0/32d0/pi**2*
49631  &(rmtop**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*
49632  &log(xma**2/xmtop**2))
49633 
49634  sinbt = tanbt/sqrt(1d0 + tanbt**2)
49635  cosbt = 1d0/sqrt(1d0 + tanbt**2)
49636 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
49637  g1 = sqrt(alp1*4d0*pi)
49638  g2 = sqrt(alp2*4d0*pi)
49639  g3 = sqrt(alp3*4d0*pi)
49640  hu = rmtop/v/sinbt
49641  hd = xmb/v/cosbt
49642  hu2=hu*hu
49643  hd2=hd*hd
49644  hu4=hu2*hu2
49645  hd4=hd2*hd2
49646  au2=au**2
49647  ad2=ad**2
49648  xms2=xms**2
49649  xms3=xms**3
49650  xms4=xms2*xms2
49651  xmu2=xmu*xmu
49652  pi2=pi*pi
49653 
49654  xau = (2d0*au2/xms2)*(1d0 - au2/12d0/xms2)
49655  xad = (2d0*ad2/xms2)*(1d0 - ad2/12d0/xms2)
49656  aud = (-6d0*xmu2/xms2 - ( xmu2- ad*au)**2/xms4
49657  &+ 3d0*(au + ad)**2/xms2)/6d0
49658  xlam1 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hd2*t/8d0/pi2)
49659  &+(3d0*hd4/8d0/pi2) * (t + xad/2d0 + (3d0*hd2/2d0 + hu2/2d0
49660  &- 8d0*g3**2) * (xad*t + t**2)/16d0/pi2)
49661  &-(3d0*hu4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hu2 -5d0* hd2
49662  &- 16d0*g3**2) *t/16d0/pi2)
49663  xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu2*t/8d0/pi2)
49664  &+(3d0*hu4/8d0/pi2) * (t + xau/2d0 + (3d0*hu2/2d0 + hd2/2d0
49665  &- 8d0*g3**2) * (xau*t + t**2)/16d0/pi2)
49666  &-(3d0*hd4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hd2 -5d0* hu2
49667  &- 16d0*g3**2) *t/16d0/pi2)
49668  xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
49669  &(hu2 + hd2)*t/16d0/pi2)
49670  &+(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
49671  &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
49672  &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
49673  &xms4)* (1d0+ (6d0*hu2 -2d0* hd2/2d0
49674  &- 16d0*g3**2) *t/16d0/pi2)
49675  &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
49676  &xms4)*(1d0+ (6d0*hd2 -2d0* hu2
49677  &- 16d0*g3**2) *t/16d0/pi2)
49678  xlam4 = (- g2**2/2d0)*(1d0-3d0*(hu2 + hd2)*t/16d0/pi2)
49679  &-(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
49680  &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
49681  &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
49682  &xms4)*
49683  &(1+ (6d0*hu2 -2d0* hd2
49684  &- 16d0*g3**2) *t/16d0/pi2)
49685  &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
49686  &xms4)*
49687  &(1+ (6d0*hd2 -2d0* hu2/2d0
49688  &- 16d0*g3**2) *t/16d0/pi2)
49689  xlam5 = -(3d0*hu4* xmu2*au2/96d0/pi2/xms4) *
49690  &(1- (2d0*hd2 -6d0* hu2 + 16d0*g3**2) *t/16d0/pi2)
49691  &-(3d0*hd4* xmu2*ad2/96d0/pi2/xms4) *
49692  &(1- (2d0*hu2 -6d0* hd2 + 16d0*g3**2) *t/16d0/pi2)
49693  xlam6 = (3d0*hu4* xmu**3*au/96d0/pi2/xms4) *
49694  &(1- (7d0*hd2/2d0 -15d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
49695  &+(3d0*hd4* xmu *(ad**3/xms3 - 6d0*ad/xms )/96d0/pi2/xms) *
49696  &(1- (hu2/2d0 -9d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
49697  xlam7 = (3d0*hd4* xmu**3*ad/96d0/pi2/xms4) *
49698  &(1- (7d0*hu2/2d0 -15d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
49699  &+(3d0*hu4* xmu *(au**3/xms3 - 6d0*au/xms )/96d0/pi2/xms) *
49700  &(1- (hd2/2d0 -9d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
49701  hhh(1)=xlam1
49702  hhh(2)=xlam2
49703  hhh(3)=xlam3
49704  hhh(4)=xlam4
49705  hhh(5)=xlam5
49706  hhh(6)=xlam6
49707  hhh(7)=xlam7
49708  trm2 = xma**2 + 2d0*v**2* (xlam1* cosbt**2 +
49709  &2d0* xlam6*sinbt*cosbt
49710  &+ xlam5*sinbt**2 + xlam2* sinbt**2 + 2d0* xlam7*sinbt*cosbt
49711  &+ xlam5*cosbt**2)
49712  detm2 = 4d0*v**4*(-(sinbt*cosbt*(xlam3 + xlam4) +
49713  &xlam6*cosbt**2
49714  &+ xlam7* sinbt**2)**2 + (xlam1* cosbt**2 +
49715  &2d0* xlam6* cosbt*sinbt
49716  &+ xlam5*sinbt**2)*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
49717  &+ xlam5*cosbt**2)) + xma**2*2d0*v**2 *
49718  &((xlam1* cosbt**2 +2d0*
49719  &xlam6* cosbt*sinbt + xlam5*sinbt**2)*cosbt**2 +
49720  &(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt + xlam5*cosbt**2)
49721  &*sinbt**2
49722  &+2d0*sinbt*cosbt* (sinbt*cosbt*(xlam3
49723  &+ xlam4) + xlam6*cosbt**2
49724  &+ xlam7* sinbt**2))
49725 
49726  xmh2 = (trm2 - sqrt(trm2**2 - 4d0* detm2))/2d0
49727  xhm2 = (trm2 + sqrt(trm2**2 - 4d0* detm2))/2d0
49728  xhm = sqrt(xhm2)
49729  xmh = sqrt(xmh2)
49730  xmhch2 = xma**2 + (xlam5 - xlam4)* v**2
49731  xmhch = sqrt(xmhch2)
49732 
49733  sinalp = sqrt(((trm2**2 - 4d0* detm2)**0.5d0) -
49734  &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
49735  &xlam6* cosbt*sinbt
49736  &+ xlam5*sinbt**2) + xma**2*sinbt**2)
49737  &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
49738  &+ xlam5*cosbt**2) + xma**2*cosbt**2)))/
49739  &sqrt(((trm2**2 - 4d0* detm2)**0.5d0))/2d0**0.5d0
49740 
49741  cosalp = (2d0*(2d0*v**2*(sinbt*cosbt*(xlam3 + xlam4) +
49742  &xlam6*cosbt**2 + xlam7* sinbt**2) -
49743  &xma**2*sinbt*cosbt))/2d0**0.5d0/
49744  &sqrt(((trm2**2 - 4d0* detm2)**0.5d0)*
49745  &(((trm2**2 - 4d0* detm2)**0.5d0) -
49746  &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
49747  &xlam6* cosbt*sinbt
49748  &+ xlam5*sinbt**2) + xma**2*sinbt**2)
49749  &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
49750  &+ xlam5*cosbt**2) + xma**2*cosbt**2))))
49751 
49752  sa = -sinalp
49753  ca = -cosalp
49754 
49755  100 CONTINUE
49756 
49757  RETURN
49758  END
49759 
49760 C*********************************************************************
49761 
49762 C...PYPOLE
49763 C...This subroutine computes the CP-even higgs and CP-odd pole
49764 c...Higgs masses and mixing angles.
49765 
49766 C...Program based on the work by M. Carena, M. Quiros
49767 C...and C.E.M. Wagner, "Effective potential methods and
49768 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
49769 
49770 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
49771 C...AT,AB,MU
49772 C...where MCHI is the largest chargino mass, MA is the running
49773 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
49774 C...expectaion values at the scale MTOP, MQ is the third generation
49775 C...left handed squark mass parameter, MUR is the third generation
49776 C...right handed stop mass parameter, MDR is the third generation
49777 C...right handed sbottom mass parameter, MTOP is the pole top quark
49778 C...mass; AT,AB are the soft supersymmetry breaking trilinear
49779 C...couplings of the stop and sbottoms, respectively, and MU is the
49780 C...supersymmetric mass parameter
49781 
49782 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
49783 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
49784 C...masses are given, what makes the running of the program
49785 c...much faster and it is quite generally a good approximation
49786 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
49787 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
49788 c...and if IHIGGS=3, then h,H,A polarizations are computed
49789 
49790 C...Output: MH and MHP which are the lightest CP-even Higgs running
49791 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
49792 C...Higgs running and pole masses, repectively; SA and CA are the
49793 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
49794 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
49795 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
49796 C...the value of TANB at the CP-odd Higgs mass scale
49797 
49798 C...This subroutine makes use of CERN library subroutine
49799 C...integration package, which makes the computation of the
49800 C...pole Higgs masses somewhat faster. We thank P. Janot for this
49801 C...improvement. Those who are not able to call the CERN
49802 C...libraries, please use the subroutine SUBHPOLE2.F, which
49803 C...although somewhat slower, gives identical results
49804 
49805  SUBROUTINE pypole(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
49806  &xmh,xmhp,hm,hmp,amp,sa,ca,stop1,stop2,sbot1,sbot2,tanba,xmg,dt,db)
49807 
49808 C...Double precision and integer declarations.
49809  IMPLICIT DOUBLE PRECISION(a-h, o-z)
49810  IMPLICIT INTEGER(i-n)
49811 
49812 C...Parameters.
49813  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49814  SAVE /pydat1/
49815  INTEGER pyk,pychge,pycomp
49816 
49817 C...Local variables.
49818  dimension delta(2,2),coupt(2,2),t(2,2),sstop2(2),
49819  &ssbot2(2),b(2,2),coupb(2,2),
49820  &hcoupt(2,2),hcoupb(2,2),
49821  &acoupt(2,2),acoupb(2,2),pr(3), polar(3)
49822 
49823  delta(1,1) = 1d0
49824  delta(2,2) = 1d0
49825  delta(1,2) = 0d0
49826  delta(2,1) = 0d0
49827  v = 174.1d0
49828  xmz=91.18d0
49829  pi=paru(1)
49830  rxmt=pymrun(6,xmt**2)
49831  CALL pyrghm(xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,
49832  &xmu,xmh,hm,xmch,sa,ca,sab,cab,tanba,xmg,dt,db)
49833 
49834  sinb = tanb/(tanb**2+1d0)**0.5d0
49835  cosb = 1d0/(tanb**2+1d0)**0.5d0
49836  cos2b = sinb**2 - cosb**2
49837  sinbpa = sinb*ca + cosb*sa
49838  cosbpa = cosb*ca - sinb*sa
49839  rmbot = pymrun(5,xmt**2)
49840  xmq2 = xmq**2
49841  xmur2 = xmur**2
49842  IF(xmur.LT.0d0) xmur2=-xmur2
49843  xmdr2 = xmdr**2
49844  xmst11 = rxmt**2 + xmq2 - 0.35d0*xmz**2*cos2b
49845  xmst22 = rxmt**2 + xmur2 - 0.15d0*xmz**2*cos2b
49846  IF(xmst11.LT.0d0) goto 500
49847  IF(xmst22.LT.0d0) goto 500
49848  xmsb11 = rmbot**2 + xmq2 + 0.42d0*xmz**2*cos2b
49849  xmsb22 = rmbot**2 + xmdr2 + 0.08d0*xmz**2*cos2b
49850  IF(xmsb11.LT.0d0) goto 500
49851  IF(xmsb22.LT.0d0) goto 500
49852 C WMST11 = RXMT**2 + XMQ2
49853 C WMST22 = RXMT**2 + XMUR2
49854  xmst12 = rxmt*(at - xmu/tanb)
49855  xmsb12 = rmbot*(ab - xmu*tanb)
49856 
49857 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49858 C...STOP EIGENVALUES CALCULATION
49859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49860 
49861  stop12 = 0.5d0*(xmst11+xmst22) +
49862  &0.5d0*((xmst11+xmst22)**2 -
49863  &4d0*(xmst11*xmst22 - xmst12**2))**0.5d0
49864  stop22 = 0.5d0*(xmst11+xmst22) -
49865  &0.5d0*((xmst11+xmst22)**2 - 4d0*(xmst11*xmst22 -
49866  &xmst12**2))**0.5d0
49867 
49868  IF(stop22.LT.0d0) goto 500
49869  sstop2(1) = stop12
49870  sstop2(2) = stop22
49871  stop1 = stop12**0.5d0
49872  stop2 = stop22**0.5d0
49873 C STOP1W = STOP1
49874 C STOP2W = STOP2
49875 
49876  IF(xmst12.EQ.0d0) xst11 = 1d0
49877  IF(xmst12.EQ.0d0) xst12 = 0d0
49878  IF(xmst12.EQ.0d0) xst21 = 0d0
49879  IF(xmst12.EQ.0d0) xst22 = 1d0
49880 
49881  IF(xmst12.EQ.0d0) goto 110
49882 
49883  100 xst11 = xmst12/(xmst12**2+(xmst11-stop12)**2)**0.5d0
49884  xst12 = - (xmst11-stop12)/(xmst12**2+(xmst11-stop12)**2)**0.5d0
49885  xst21 = xmst12/(xmst12**2+(xmst11-stop22)**2)**0.5d0
49886  xst22 = - (xmst11-stop22)/(xmst12**2+(xmst11-stop22)**2)**0.5d0
49887 
49888  110 t(1,1) = xst11
49889  t(2,2) = xst22
49890  t(1,2) = xst12
49891  t(2,1) = xst21
49892 
49893  sbot12 = 0.5d0*(xmsb11+xmsb22) +
49894  &0.5d0*((xmsb11+xmsb22)**2 -
49895  &4d0*(xmsb11*xmsb22 - xmsb12**2))**0.5d0
49896  sbot22 = 0.5d0*(xmsb11+xmsb22) -
49897  &0.5d0*((xmsb11+xmsb22)**2 - 4d0*(xmsb11*xmsb22 -
49898  &xmsb12**2))**0.5d0
49899  IF(sbot22.LT.0d0) goto 500
49900  sbot1 = sbot12**0.5d0
49901  sbot2 = sbot22**0.5d0
49902 
49903  ssbot2(1) = sbot12
49904  ssbot2(2) = sbot22
49905 
49906  IF(xmsb12.EQ.0d0) xsb11 = 1d0
49907  IF(xmsb12.EQ.0d0) xsb12 = 0d0
49908  IF(xmsb12.EQ.0d0) xsb21 = 0d0
49909  IF(xmsb12.EQ.0d0) xsb22 = 1d0
49910 
49911  IF(xmsb12.EQ.0d0) goto 130
49912 
49913  120 xsb11 = xmsb12/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
49914  xsb12 = - (xmsb11-sbot12)/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
49915  xsb21 = xmsb12/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
49916  xsb22 = - (xmsb11-sbot22)/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
49917 
49918  130 b(1,1) = xsb11
49919  b(2,2) = xsb22
49920  b(1,2) = xsb12
49921  b(2,1) = xsb21
49922 
49923 
49924  sint = 0.2320d0
49925  sqr = dsqrt(2d0)
49926  vp = 174.1d0*sqr
49927 
49928 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49929 C...STARTING OF LIGHT HIGGS
49930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49931 
49932  IF(ihiggs.EQ.0) goto 490
49933 
49934  DO 150 i = 1,2
49935  DO 140 j = 1,2
49936  coupt(i,j) =
49937  & sint*xmz**2*2d0*sqr/174.1d0/3d0*sinbpa*(delta(i,j) +
49938  & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
49939  & -rxmt**2/174.1d0**2*vp/sinb*ca*delta(i,j)
49940  & -rxmt/vp/sinb*(at*ca + xmu*sa)*(t(1,i)*t(2,j) +
49941  & t(1,j)*t(2,i))
49942  140 CONTINUE
49943  150 CONTINUE
49944 
49945 
49946  DO 170 i = 1,2
49947  DO 160 j = 1,2
49948  coupb(i,j) =
49949  & -sint*xmz**2*2d0*sqr/174.1d0/6d0*sinbpa*(delta(i,j) +
49950  & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
49951  & +rmbot**2/174.1d0**2*vp/cosb*sa*delta(i,j)
49952  & +rmbot/vp/cosb*(ab*sa + xmu*ca)*(b(1,i)*b(2,j) +
49953  & b(1,j)*b(2,i))
49954  160 CONTINUE
49955  170 CONTINUE
49956 
49957  prun = xmh
49958  eps = 1d-4*prun
49959  iter = 0
49960  180 iter = iter + 1
49961  DO 230 i3 = 1,3
49962 
49963  pr(i3)=prun+(i3-2)*eps/2
49964  p2=pr(i3)**2
49965  polt = 0d0
49966  DO 200 i = 1,2
49967  DO 190 j = 1,2
49968  polt = polt + coupt(i,j)**2*3d0*
49969  & pyfint(p2,sstop2(i),sstop2(j))/16d0/pi**2
49970  190 CONTINUE
49971  200 CONTINUE
49972 
49973  polb = 0d0
49974  DO 220 i = 1,2
49975  DO 210 j = 1,2
49976  polb = polb + coupb(i,j)**2*3d0*
49977  & pyfint(p2,ssbot2(i),ssbot2(j))/16d0/pi**2
49978  210 CONTINUE
49979  220 CONTINUE
49980 C RXMT2 = RXMT**2
49981  xmt2=xmt**2
49982 
49983  poltt =
49984  & 3d0*rxmt**2/8d0/pi**2/ v **2*
49985  & ca**2/sinb**2 *
49986  & (-2d0*xmt**2+0.5d0*p2)*
49987  & pyfint(p2,xmt2,xmt2)
49988 
49989  pol = polt + polb + poltt
49990  polar(i3) = p2 - xmh**2 - pol
49991  230 CONTINUE
49992  deriv = (polar(3)-polar(1))/eps
49993  drun = - polar(2)/deriv
49994  prun = prun + drun
49995  p2 = prun**2
49996  IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) goto 240
49997  goto 180
49998  240 CONTINUE
49999 
50000  xmhp = dsqrt(p2)
50001 
50002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50003 C...END OF LIGHT HIGGS
50004 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50005 
50006  250 IF(ihiggs.EQ.1) goto 490
50007 
50008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50009 C... STARTING OF HEAVY HIGGS
50010 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50011 
50012  DO 270 i = 1,2
50013  DO 260 j = 1,2
50014  hcoupt(i,j) =
50015  & -sint*xmz**2*2d0*sqr/174.1d0/3d0*cosbpa*(delta(i,j) +
50016  & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
50017  & -rxmt**2/174.1d0**2*vp/sinb*sa*delta(i,j)
50018  & -rxmt/vp/sinb*(at*sa - xmu*ca)*(t(1,i)*t(2,j) +
50019  & t(1,j)*t(2,i))
50020  260 CONTINUE
50021  270 CONTINUE
50022 
50023  DO 290 i = 1,2
50024  DO 280 j = 1,2
50025  hcoupb(i,j) =
50026  & sint*xmz**2*2d0*sqr/174.1d0/6d0*cosbpa*(delta(i,j) +
50027  & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
50028  & -rmbot**2/174.1d0**2*vp/cosb*ca*delta(i,j)
50029  & -rmbot/vp/cosb*(ab*ca - xmu*sa)*(b(1,i)*b(2,j) +
50030  & b(1,j)*b(2,i))
50031  hcoupb(i,j)=0d0
50032  280 CONTINUE
50033  290 CONTINUE
50034 
50035  prun = hm
50036  eps = 1d-4*prun
50037  iter = 0
50038  300 iter = iter + 1
50039  DO 350 i3 = 1,3
50040  pr(i3)=prun+(i3-2)*eps/2
50041  hp2=pr(i3)**2
50042 
50043  hpolt = 0d0
50044  DO 320 i = 1,2
50045  DO 310 j = 1,2
50046  hpolt = hpolt + hcoupt(i,j)**2*3d0*
50047  & pyfint(hp2,sstop2(i),sstop2(j))/16d0/pi**2
50048  310 CONTINUE
50049  320 CONTINUE
50050 
50051  hpolb = 0d0
50052  DO 340 i = 1,2
50053  DO 330 j = 1,2
50054  hpolb = hpolb + hcoupb(i,j)**2*3d0*
50055  & pyfint(hp2,ssbot2(i),ssbot2(j))/16d0/pi**2
50056  330 CONTINUE
50057  340 CONTINUE
50058 
50059 C RXMT2 = RXMT**2
50060  xmt2 = xmt**2
50061 
50062  hpoltt =
50063  & 3d0*rxmt**2/8d0/pi**2/ v **2*
50064  & sa**2/sinb**2 *
50065  & (-2d0*xmt**2+0.5d0*hp2)*
50066  & pyfint(hp2,xmt2,xmt2)
50067 
50068  hpol = hpolt + hpolb + hpoltt
50069  polar(i3) =hp2-hm**2-hpol
50070  350 CONTINUE
50071  deriv = (polar(3)-polar(1))/eps
50072  drun = - polar(2)/deriv
50073  prun = prun + drun
50074  hp2 = prun**2
50075  IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) goto 360
50076  goto 300
50077  360 CONTINUE
50078 
50079 
50080  370 CONTINUE
50081  hmp = hp2**0.5d0
50082 
50083 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50084 C... END OF HEAVY HIGGS
50085 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50086 
50087  IF(ihiggs.EQ.2) goto 490
50088 
50089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50090 C...BEGINNING OF PSEUDOSCALAR HIGGS
50091 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50092 
50093  DO 390 i = 1,2
50094  DO 380 j = 1,2
50095  acoupt(i,j) =
50096  & -rxmt/vp/sinb*(at*cosb + xmu*sinb)*
50097  & (t(1,i)*t(2,j) -t(1,j)*t(2,i))
50098  380 CONTINUE
50099  390 CONTINUE
50100  DO 410 i = 1,2
50101  DO 400 j = 1,2
50102  acoupb(i,j) =
50103  & rmbot/vp/cosb*(ab*sinb + xmu*cosb)*
50104  & (b(1,i)*b(2,j) -b(1,j)*b(2,i))
50105  400 CONTINUE
50106  410 CONTINUE
50107 
50108  prun = xma
50109  eps = 1d-4*prun
50110  iter = 0
50111  420 iter = iter + 1
50112  DO 470 i3 = 1,3
50113  pr(i3)=prun+(i3-2)*eps/2
50114  ap2=pr(i3)**2
50115  apolt = 0d0
50116  DO 440 i = 1,2
50117  DO 430 j = 1,2
50118  apolt = apolt + acoupt(i,j)**2*3d0*
50119  & pyfint(ap2,sstop2(i),sstop2(j))/16d0/pi**2
50120  430 CONTINUE
50121  440 CONTINUE
50122  apolb = 0d0
50123  DO 460 i = 1,2
50124  DO 450 j = 1,2
50125  apolb = apolb + acoupb(i,j)**2*3d0*
50126  & pyfint(ap2,ssbot2(i),ssbot2(j))/16d0/pi**2
50127  450 CONTINUE
50128  460 CONTINUE
50129 C RXMT2 = RXMT**2
50130  xmt2=xmt**2
50131  apoltt =
50132  & 3d0*rxmt**2/8d0/pi**2/ v **2*
50133  & cosb**2/sinb**2 *
50134  & (-0.5d0*ap2)*
50135  & pyfint(ap2,xmt2,xmt2)
50136  apol = apolt + apolb + apoltt
50137  polar(i3) = ap2 - xma**2 -apol
50138  470 CONTINUE
50139  deriv = (polar(3)-polar(1))/eps
50140  drun = - polar(2)/deriv
50141  prun = prun + drun
50142  ap2 = prun**2
50143  IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) goto 480
50144  goto 420
50145  480 CONTINUE
50146 
50147  amp = dsqrt(ap2)
50148 
50149 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50150 C...END OF PSEUDOSCALAR HIGGS
50151 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50152 
50153  IF(ihiggs.EQ.3) goto 490
50154 
50155  490 CONTINUE
50156  RETURN
50157  500 CONTINUE
50158  WRITE(mstu(11),*) ' EXITING IN PYPOLE '
50159  WRITE(mstu(11),*) ' XMST11,XMST22 = ',xmst11,xmst22
50160  WRITE(mstu(11),*) ' XMSB11,XMSB22 = ',xmsb11,xmsb22
50161  WRITE(mstu(11),*) ' STOP22,SBOT22 = ',stop22,sbot22
50162  CALL pystop(107)
50163  END
50164 
50165 C*********************************************************************
50166 
50167 C...PYRGHM
50168 C...Auxiliary to PYPOLE.
50169 
50170  SUBROUTINE pyrghm(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
50171  * mhp,hmp,mch,sa,ca,sab,cab,tanba,mglu,deltamt,deltamb)
50172  IMPLICIT DOUBLE PRECISION(a-h,l,m,o-z)
50173  dimension vh(2,2),m2(2,2),m2p(2,2)
50174 C...Parameters.
50175  INTEGER mstu,mstj
50176  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50177  SAVE /pydat1/
50178 
50179  mz = 91.18d0
50180  pi = paru(1)
50181  v = 174.1d0
50182  alpha1 = 0.0101d0
50183  alpha2 = 0.0337d0
50184  alpha3z = 0.12d0
50185  tanba = tanb
50186  tanbt = tanb
50187 C MBOTTOM(MTOP) = 3. GEV
50188  mb = pymrun(5,mtop**2)
50189  alpha3 = alpha3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alpha3z*
50190  *log(mtop**2/mz**2))
50191 C RMTOP= RUNNING TOP QUARK MASS
50192  rmtop = mtop/(1d0+4d0*alpha3/3d0/pi)
50193  tq = log((mq**2+mtop**2)/mtop**2)
50194  tu = log((mur**2 + mtop**2)/mtop**2)
50195  td = log((md**2 + mtop**2)/mtop**2)
50196 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50197 C
50198 C NEW DEFINITION, TGLU.
50199 C
50200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50201  tglu = log(mglu**2/mtop**2)
50202  sinb = tanb/dsqrt(1d0 + tanb**2)
50203  cosb = sinb/tanb
50204  IF(ma.GT.mtop)
50205  *tanba = tanb*(1d0-3d0/32d0/pi**2*
50206  *(rmtop**2/v**2/sinb**2-mb**2/v**2/cosb**2)*
50207  *log(ma**2/mtop**2))
50208  IF(ma.LT.mtop.OR.ma.EQ.mtop) tanbt = tanba
50209  sinb = tanbt/sqrt(1d0 + tanbt**2)
50210  cosb = 1d0/dsqrt(1d0 + tanbt**2)
50211  g1 = sqrt(alpha1*4d0*pi)
50212  g2 = sqrt(alpha2*4d0*pi)
50213  g3 = sqrt(alpha3*4d0*pi)
50214  hu = rmtop/v/sinb
50215  hd = mb/v/cosb
50216  CALL pygfxx(ma,tanba,mq,mur,md,mtop,au,ad,mu,mglu,vh,stop1,stop2,
50217  *sbot1,sbot2,deltamt,deltamb)
50218  IF(mq.GT.mur) tp = tq - tu
50219  IF(mq.LT.mur.OR.mq.EQ.mur) tp = tu - tq
50220  IF(mq.GT.mur) tdp = tu
50221  IF(mq.LT.mur.OR.mq.EQ.mur) tdp = tq
50222  IF(mq.GT.md) tpd = tq - td
50223  IF(mq.LT.md.OR.mq.EQ.md) tpd = td - tq
50224  IF(mq.GT.md) tdpd = td
50225  IF(mq.LT.md.OR.mq.EQ.md) tdpd = tq
50226 
50227  IF(mq.GT.md) dlambda1 = 6d0/96d0/pi**2*g1**2*hd**2*tpd
50228  IF(mq.LT.md.OR.mq.EQ.md) dlambda1 = 3d0/32d0/pi**2*
50229  * hd**2*(g1**2/3d0+g2**2)*tpd
50230 
50231  IF(mq.GT.mur) dlambda2 =12d0/96d0/pi**2*g1**2*hu**2*tp
50232  IF(mq.LT.mur.OR.mq.EQ.mur) dlambda2 = 3d0/32d0/pi**2*
50233  * hu**2*(-g1**2/3d0+g2**2)*tp
50234 
50235 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50236 C
50237 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
50238 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
50239 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
50240 C TWO STOPS.
50241 C
50242 C
50243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50244 
50245  dlambdap2 = 0d0
50246  IF(mglu.LT.mur.OR.mglu.LT.mq) THEN
50247  IF(mq.GT.mur.AND.mglu.GT.mur) THEN
50248  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tglu**2)
50249  ENDIF
50250 
50251  IF(mq.GT.mur.AND.mglu.LT.mur) THEN
50252  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tu**2)
50253  ENDIF
50254 
50255  IF(mq.GT.mur.AND.mglu.EQ.mur) THEN
50256  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tu**2)
50257  ENDIF
50258 
50259  IF(mur.GT.mq.AND.mglu.GT.mq) THEN
50260  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tglu**2)
50261  ENDIF
50262 
50263  IF(mur.GT.mq.AND.mglu.LT.mq) THEN
50264  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tq**2)
50265  ENDIF
50266 
50267  IF(mur.GT.mq.AND.mglu.EQ.mq) THEN
50268  dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tq**2)
50269  ENDIF
50270  ENDIF
50271  dlambda3 = 0d0
50272  dlambda4 = 0d0
50273  IF(mq.GT.md) dlambda3 = -1d0/32d0/pi**2*g1**2*hd**2*tpd
50274  IF(mq.LT.md.OR.mq.EQ.md) dlambda3 = 3d0/64d0/pi**2*hd**2*
50275  *(g2**2-g1**2/3d0)*tpd
50276  IF(mq.GT.mur) dlambda3 = dlambda3 -
50277  *1d0/16d0/pi**2*g1**2*hu**2*tp
50278  IF(mq.LT.mur.OR.mq.EQ.mur) dlambda3 = dlambda3 +
50279  * 3d0/64d0/pi**2*hu**2*(g2**2+g1**2/3d0)*tp
50280  IF(mq.LT.mur) dlambda4 = -3d0/32d0/pi**2*g2**2*hu**2*tp
50281  IF(mq.LT.md) dlambda4 = dlambda4 - 3d0/32d0/pi**2*g2**2*
50282  *hd**2*tpd
50283  lambda1 = ((g1**2 + g2**2)/4d0)*
50284  * (1d0-3d0*hd**2*(tpd + tdpd)/8d0/pi**2)
50285  *+(3d0*hd**4d0/16d0/pi**2) *tpd*(1d0
50286  *+ (3d0*hd**2/2d0 + hu**2/2d0
50287  *- 8d0*g3**2) * (tpd + 2d0*tdpd)/16d0/pi**2)
50288  *+(3d0*hd**4d0/8d0/pi**2) *tdpd*(1d0 + (3d0*hd**2/2d0 + hu**2/2d0
50289  *- 8d0*g3**2) * tdpd/16d0/pi**2) + dlambda1
50290  lambda2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu**2*
50291  *(tp + tdp)/8d0/pi**2)
50292  *+(3d0*hu**4d0/16d0/pi**2) *tp*(1d0
50293  *+ (3d0*hu**2/2d0 + hd**2/2d0
50294  *- 8d0*g3**2) * (tp + 2d0*tdp)/16d0/pi**2)
50295  *+(3d0*hu**4d0/8d0/pi**2) *tdp*(1d0 + (3d0*hu**2/2d0 + hd**2/2d0
50296  *- 8d0*g3**2) * tdp/16d0/pi**2) + dlambda2 + dlambdap2
50297  lambda3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
50298  *(hu**2)*(tp + tdp)/16d0/pi**2 -3d0*
50299  *(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlambda3
50300  lambda4 = (- g2**2/2d0)*(1d0
50301  *-3d0*(hu**2)*(tp + tdp)/16d0/pi**2
50302  *-3d0*(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlambda4
50303 
50304  lambda5 = 0d0
50305  lambda6 = 0d0
50306  lambda7 = 0d0
50307 
50308  m2(1,1) = 2d0*v**2*(lambda1*cosb**2+2d0*lambda6*
50309  *cosb*sinb + lambda5*sinb**2) + ma**2*sinb**2
50310 
50311  m2(2,2) = 2d0*v**2*(lambda5*cosb**2+2d0*lambda7*
50312  *cosb*sinb + lambda2*sinb**2) + ma**2*cosb**2
50313  m2(1,2) = 2d0*v**2*(lambda6*cosb**2+(lambda3+lambda4)*
50314  *cosb*sinb + lambda7*sinb**2) - ma**2*sinb*cosb
50315 
50316  m2(2,1) = m2(1,2)
50317 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50318 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
50319 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50320 
50321  mssusy=dsqrt(.5d0*(mq**2+mur**2)+mtop**2)
50322 
50323  IF(mchi.GT.mssusy) goto 100
50324  IF(mchi.LT.mtop) mchi=mtop
50325 
50326  tchar=log(mssusy**2/mchi**2)
50327 
50328  deltal12=(9d0/64d0/pi**2*g2**4+5d0/192d0/pi**2*g1**4)*tchar
50329  deltal3p4=(3d0/64d0/pi**2*g2**4+7d0/192d0/pi**2*g1**4
50330  *+4d0/32d0/pi**2*g1**2*g2**2)*tchar
50331 
50332  deltam112=2d0*deltal12*v**2*cosb**2
50333  deltam222=2d0*deltal12*v**2*sinb**2
50334  deltam122=2d0*deltal3p4*v**2*sinb*cosb
50335 
50336  m2(1,1)=m2(1,1)+deltam112
50337  m2(2,2)=m2(2,2)+deltam222
50338  m2(1,2)=m2(1,2)+deltam122
50339  m2(2,1)=m2(2,1)+deltam122
50340 
50341  100 CONTINUE
50342 
50343 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50344 CCC END OF CHARGINOS/NEUTRALINOS
50345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50346 
50347  DO 120 i = 1,2
50348  DO 110 j = 1,2
50349  m2p(i,j) = m2(i,j) + vh(i,j)
50350  110 CONTINUE
50351  120 CONTINUE
50352  trm2p = m2p(1,1) + m2p(2,2)
50353  detm2p = m2p(1,1)*m2p(2,2) - m2p(1,2)*m2p(2,1)
50354  mh2p = (trm2p - dsqrt(trm2p**2 - 4d0* detm2p))/2d0
50355  hm2p = (trm2p + dsqrt(trm2p**2 - 4d0* detm2p))/2d0
50356  hmp = dsqrt(hm2p)
50357  mch2=ma**2+(lambda5-lambda4)*v**2
50358  mch=dsqrt(mch2)
50359  IF(mh2p.LT.0.) goto 130
50360  mhp = sqrt(mh2p)
50361  sin2alpha = 2d0*m2p(1,2)/sqrt(trm2p**2-4d0*detm2p)
50362  cos2alpha = (m2p(1,1)-m2p(2,2))/sqrt(trm2p**2-4d0*detm2p)
50363  IF(cos2alpha.GE.0.) THEN
50364  alpha = asin(sin2alpha)/2d0
50365  ELSE
50366  alpha = -pi/2d0-asin(sin2alpha)/2d0
50367  ENDIF
50368  sa = sin(alpha)
50369  ca = cos(alpha)
50370 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50371 C
50372 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
50373 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
50374 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
50375 C
50376 C
50377 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50378  sab = sa*(1d0-deltamb/(1d0+deltamb)*(1d0+ca/sa/tanb))
50379  cab = ca*(1d0-deltamb/(1d0+deltamb)*(1d0-sa/ca/tanb))
50380  130 CONTINUE
50381  RETURN
50382  END
50383 
50384 C*********************************************************************
50385 
50386 C...PYGFXX
50387 C...Auxiliary to PYRGHM.
50388 
50389  SUBROUTINE pygfxx(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
50390  * stop1,stop2,sbot1,sbot2,deltamt,deltamb)
50391  IMPLICIT DOUBLE PRECISION(a-h,m,o-z)
50392  dimension vh(2,2),vh3t(2,2),vh3b(2,2),al(2,2)
50393 C...Commonblocks.
50394  INTEGER mstu,mstj,kchg
50395  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50396  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50397  SAVE /pydat1/,/pydat2/
50398 
50399  g(x,y) = 2.d0 - (x+y)/(x-y)*dlog(x/y)
50400 
50401  t(x,y,z) = (x**2*y**2*log(x**2/y**2) + x**2*z**2*log(z**2/x**2)
50402  * + y**2*z**2*log(y**2/z**2))/((x**2-y**2)*(y**2-z**2)*(x**2-z**2))
50403 
50404  IF(dabs(xmu).LT.0.000001d0) xmu = 0.000001d0
50405  mq2 = mq**2
50406  mur2 = mur**2
50407  md2 = md**2
50408  tanba = tanb
50409  sinba = tanba/dsqrt(tanba**2+1d0)
50410  cosba = sinba/tanba
50411 
50412  sinb = tanb/dsqrt(tanb**2+1d0)
50413  cosb = sinb/tanb
50414 
50415  pi = paru(1)
50416  mz = pmas(23,1)
50417  mw = pmas(24,1)
50418  sw = 1d0-mw**2/mz**2
50419  v = 174.1d0
50420 
50421  alpha3 = 0.12d0/(1d0+23/12d0/pi*0.12d0*log(mtop**2/mz**2))
50422  g2 = dsqrt(0.0336d0*4d0*pi)
50423  g1 = dsqrt(0.0101d0*4d0*pi)
50424 
50425  IF(mq.GT.mur) mst = mq
50426  IF(mur.GT.mq.OR.mur.EQ.mq) mst = mur
50427 
50428  msusyt = dsqrt(mst**2 + mtop**2)
50429 
50430  IF(mq.GT.md) msb = mq
50431  IF(md.GT.mq.OR.md.EQ.mq) msb = md
50432 
50433  mb = pymrun(5,msb**2)
50434  msusyb = dsqrt(msb**2 + mb**2)
50435  tt = log(msusyt**2/mtop**2)
50436  tb = log(msusyb**2/mtop**2)
50437 
50438  rmtop = mtop/(1d0+4d0*alpha3/3d0/pi)
50439  ht = rmtop/(v*sinb)
50440  htst = rmtop/v
50441  hb = mb/v/cosb
50442  g32 = alpha3*4d0*pi
50443  bt2 = -(8d0*g32 - 9d0*ht**2/2d0 - hb**2/2d0)/(4d0*pi)**2
50444  bb2 = -(8d0*g32 - 9d0*hb**2/2d0 - ht**2/2d0)/(4d0*pi)**2
50445  al2 = 3d0/8d0/pi**2*ht**2
50446 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
50447 C ALST = 3./8./PI**2*HTST**2
50448  al1 = 3d0/8d0/pi**2*hb**2
50449 
50450  al(1,1) = al1
50451  al(1,2) = (al2+al1)/2d0
50452  al(2,1) = (al2+al1)/2d0
50453  al(2,2) = al2
50454 
50455  IF(ma.GT.mtop) THEN
50456  vi = v*(1d0 + 3d0/32d0/pi**2*htst**2*
50457  * log(mtop**2/ma**2))
50458  h1i = vi* cosba
50459  h2i = vi*sinba
50460  h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(ma**2/msusyt**2))**.25d0
50461  h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(ma**2/msusyt**2))**.25d0
50462  h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(ma**2/msusyb**2))**.25d0
50463  h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(ma**2/msusyb**2))**.25d0
50464  ELSE
50465  vi = v
50466  h1i = vi*cosb
50467  h2i = vi*sinb
50468  h1t=h1i*(1d0+3d0/8d0/pi**2*hb**2*log(mtop**2/msusyt**2))**.25d0
50469  h2t=h2i*(1d0+3d0/8d0/pi**2*ht**2*log(mtop**2/msusyt**2))**.25d0
50470  h1b=h1i*(1d0+3d0/8d0/pi**2*hb**2*log(mtop**2/msusyb**2))**.25d0
50471  h2b=h2i*(1d0+3d0/8d0/pi**2*ht**2*log(mtop**2/msusyb**2))**.25d0
50472  ENDIF
50473 
50474  tanbst = h2t/h1t
50475  sinbt = tanbst/dsqrt(1d0+tanbst**2)
50476 
50477  tanbsb = h2b/h1b
50478  sinbb = tanbsb/dsqrt(1d0+tanbsb**2)
50479  cosbb = sinbb/tanbsb
50480 
50481  deltamt = 0d0
50482  deltamb = 0d0
50483 
50484  mtop4 = rmtop**4*(1d0+2d0*bt2*tt- al2*tt - 4d0*deltamt)
50485  mtop2 = dsqrt(mtop4)
50486  mbot4 = mb**4*(1d0+2d0*bb2*tb - al1*tb)
50487  * /(1d0+deltamb)**4
50488  mbot2 = dsqrt(mbot4)
50489 
50490  stop12 = (mq2 + mur2)*.5d0 + mtop2
50491  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
50492  * +sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
50493  * mq2 - mur2)**2*0.25d0 + mtop2*(at-xmu/tanbst)**2)
50494  stop22 = (mq2 + mur2)*.5d0 + mtop2
50495  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
50496  * - sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
50497  * mq2 - mur2)**2*0.25d0
50498  * + mtop2*(at-xmu/tanbst)**2)
50499  IF(stop22.LT.0.) goto 120
50500  sbot12 = (mq2 + md2)*.5d0
50501  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
50502  * + sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
50503  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
50504  sbot22 = (mq2 + md2)*.5d0
50505  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
50506  * - sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
50507  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
50508  IF(sbot22.LT.0.) sbot22 = 10000d0
50509 
50510  stop1 = dsqrt(stop12)
50511  stop2 = dsqrt(stop22)
50512  sbot1 = dsqrt(sbot12)
50513  sbot2 = dsqrt(sbot22)
50514 
50515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50516 C
50517 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
50518 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
50519 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
50520 C INDUCED CORRECTIONS.
50521 C
50522 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50523 
50524  x=sbot1
50525  y=sbot2
50526  z=xmgl
50527  IF(x.EQ.y) x = x - 0.00001d0
50528  IF(x.EQ.z) x = x - 0.00002d0
50529  IF(y.EQ.z) y = y - 0.00003d0
50530 
50531  t1=t(x,y,z)
50532  x=stop1
50533  y=stop2
50534  z=xmu
50535  IF(x.EQ.y) x = x - 0.00001d0
50536  IF(x.EQ.z) x = x - 0.00002d0
50537  IF(y.EQ.z) y = y - 0.00003d0
50538  t2=t(x,y,z)
50539  deltamb = -2*alpha3/3d0/pi*xmgl*(ab-xmu*tanb)*t1
50540  * + ht**2/(4d0*pi)**2*(at-xmu/tanb)*xmu*tanb*t2
50541  x=stop1
50542  y=stop2
50543  z=xmgl
50544  IF(x.EQ.y) x = x - 0.00001d0
50545  IF(x.EQ.z) x = x - 0.00002d0
50546  IF(y.EQ.z) y = y - 0.00003d0
50547  t3=t(x,y,z)
50548  deltamt = -2d0*alpha3/3d0/pi*(at-xmu/tanb)*xmgl*t3
50549 
50550 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50551 C
50552 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
50553 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
50554 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
50555 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
50556 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
50557 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
50558 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
50559 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
50560 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
50561 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
50562 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
50563 C
50564 C
50565 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50566 
50567  mtop4 = rmtop**4*(1d0+2d0*bt2*tt- al2*tt - 4d0*deltamt)
50568  mtop2 = dsqrt(mtop4)
50569  mbot4 = mb**4*(1d0+2d0*bb2*tb - al1*tb)
50570  * /(1d0+deltamb)**4
50571  mbot2 = dsqrt(mbot4)
50572 
50573  stop12 = (mq2 + mur2)*.5d0 + mtop2
50574  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
50575  * +sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
50576  * mq2 - mur2)**2*0.25d0 + mtop2*(at-xmu/tanbst)**2)
50577  stop22 = (mq2 + mur2)*.5d0 + mtop2
50578  * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
50579  * - sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
50580  * mq2 - mur2)**2*0.25d0
50581  * + mtop2*(at-xmu/tanbst)**2)
50582 
50583  IF(stop22.LT.0.) goto 120
50584  sbot12 = (mq2 + md2)*.5d0
50585  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
50586  * + sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
50587  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
50588  sbot22 = (mq2 + md2)*.5d0
50589  * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
50590  * - sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
50591  * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
50592  IF(sbot22.LT.0.) goto 120
50593 
50594 
50595  stop1 = dsqrt(stop12)
50596  stop2 = dsqrt(stop22)
50597  sbot1 = dsqrt(sbot12)
50598  sbot2 = dsqrt(sbot22)
50599 
50600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50601 CCC D-TERMS
50602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50603  stw=sw
50604 
50605  f1t=(mq2-mur2)/(stop12-stop22)*(.5d0-4d0/3d0*stw)*
50606  * log(stop1/stop2)
50607  * +(.5d0-2d0/3d0*stw)*log(stop1*stop2/(mq2+mtop2))
50608  * + 2d0/3d0*stw*log(stop1*stop2/(mur2+mtop2))
50609 
50610  f1b=(mq2-md2)/(sbot12-sbot22)*(-.5d0+2d0/3d0*stw)*
50611  * log(sbot1/sbot2)
50612  * +(-.5d0+1d0/3d0*stw)*log(sbot1*sbot2/(mq2+mbot2))
50613  * - 1d0/3d0*stw*log(sbot1*sbot2/(md2+mbot2))
50614 
50615  f2t=dsqrt(mtop2)*(at-xmu/tanbst)/(stop12-stop22)*
50616  * (-.5d0*log(stop12/stop22)
50617  * +(4d0/3d0*stw-.5d0)*(mq2-mur2)/(stop12-stop22)*
50618  * g(stop12,stop22))
50619 
50620  f2b=dsqrt(mbot2)*(ab-xmu*tanbsb)/(sbot12-sbot22)*
50621  * (.5d0*log(sbot12/sbot22)
50622  * +(-2d0/3d0*stw+.5d0)*(mq2-md2)/(sbot12-sbot22)*
50623  * g(sbot12,sbot22))
50624 
50625  vh3b(1,1) = mbot4/(cosbb**2)*(log(sbot1**2*sbot2**2/
50626  * (mq2+mbot2)/(md2+mbot2))
50627  * + 2d0*(ab*(ab-xmu*tanbsb)/(sbot1**2-sbot2**2))*
50628  * log(sbot1**2/sbot2**2)) +
50629  * mbot4/(cosbb**2)*(ab*(ab-xmu*tanbsb)/
50630  * (sbot1**2-sbot2**2))**2*g(sbot12,sbot22)
50631 
50632  vh3t(1,1) =
50633  * mtop4/(sinbt**2)*(xmu*(-at+xmu/tanbst)/(stop1**2
50634  * -stop2**2))**2*g(stop12,stop22)
50635 
50636  vh3b(1,1)=vh3b(1,1)+
50637  * mz**2*(2*mbot2*f1b-dsqrt(mbot2)*ab*f2b)
50638 
50639  vh3t(1,1) = vh3t(1,1) +
50640  * mz**2*(dsqrt(mtop2)*xmu/tanbst*f2t)
50641 
50642  vh3t(2,2) = mtop4/(sinbt**2)*(log(stop1**2*stop2**2/
50643  * (mq2+mtop2)/(mur2+mtop2))
50644  * + 2d0*(at*(at-xmu/tanbst)/(stop1**2-stop2**2))*
50645  * log(stop1**2/stop2**2)) +
50646  * mtop4/(sinbt**2)*(at*(at-xmu/tanbst)/
50647  * (stop1**2-stop2**2))**2*g(stop12,stop22)
50648 
50649  vh3b(2,2) =
50650  * mbot4/(cosbb**2)*(xmu*(-ab+xmu*tanbsb)/(sbot1**2
50651  * -sbot2**2))**2*g(sbot12,sbot22)
50652 
50653  vh3t(2,2)=vh3t(2,2)+
50654  * mz**2*(-2*mtop2*f1t+dsqrt(mtop2)*at*f2t)
50655  vh3b(2,2) = vh3b(2,2) -mz**2*dsqrt(mbot2)*xmu*tanbsb*f2b
50656  vh3t(1,2) = -
50657  * mtop4/(sinbt**2)*xmu*(at-xmu/tanbst)/
50658  * (stop1**2-stop2**2)*(log(stop1**2/stop2**2) + at*
50659  * (at - xmu/tanbst)/(stop1**2-stop2**2)*g(stop12,stop22))
50660 
50661  vh3b(1,2) =
50662  * - mbot4/(cosbb**2)*xmu*(ab-xmu*tanbsb)/
50663  * (sbot1**2-sbot2**2)*(log(sbot1**2/sbot2**2) + ab*
50664  * (ab - xmu*tanbsb)/(sbot1**2-sbot2**2)*g(sbot12,sbot22))
50665 
50666 
50667  vh3t(1,2)=vh3t(1,2) +
50668  *mz**2*(mtop2/tanbst*f1t-dsqrt(mtop2)*(at/tanbst+xmu)/2d0*f2t)
50669 
50670  vh3b(1,2)=vh3b(1,2) +
50671  *mz**2*(-mbot2*tanbsb*f1b+dsqrt(mbot2)*(ab*tanbsb+xmu)/2d0*f2b)
50672 
50673  vh3t(2,1) = vh3t(1,2)
50674  vh3b(2,1) = vh3b(1,2)
50675 
50676 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
50677 C TU = LOG((MUR2+MTOP2)/MTOP2)
50678 C TQD = LOG((MQ2 + MB**2)/MB**2)
50679 C TD = LOG((MD2+MB**2)/MB**2)
50680 
50681  DO 110 i = 1,2
50682  DO 100 j = 1,2
50683  vh(i,j) =
50684  * 6d0/(8d0*pi**2*(h1t**2+h2t**2))
50685  * *vh3t(i,j)*0.5d0*(1d0-al(i,j)*tt/2d0) +
50686  * 6d0/(8d0*pi**2*(h1b**2+h2b**2))
50687  * *vh3b(i,j)*0.5d0*(1d0-al(i,j)*tb/2d0)
50688  100 CONTINUE
50689  110 CONTINUE
50690 
50691  goto 150
50692  120 DO 140 i =1,2
50693  DO 130 j = 1,2
50694  vh(i,j) = -1d15
50695  130 CONTINUE
50696  140 CONTINUE
50697 
50698 
50699  150 RETURN
50700  END
50701 
50702 
50703 
50704 
50705 
50706 C*********************************************************************
50707 
50708 C...PYFINT
50709 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
50710 
50711  FUNCTION pyfint(A,B,C)
50712 
50713 C...Double precision and integer declarations.
50714  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50715  IMPLICIT INTEGER(i-n)
50716  INTEGER pyk,pychge,pycomp
50717 C...Commonblock.
50718  common/pyints/xxm(20)
50719  SAVE/pyints/
50720 
50721 C...Local variables.
50722  EXTERNAL pyfisb
50723  DOUBLE PRECISION pyfisb
50724 
50725  xxm(1)=a
50726  xxm(2)=b
50727  xxm(3)=c
50728  xlo=0d0
50729  xhi=1d0
50730  pyfint = pygaus(pyfisb,xlo,xhi,1d-3)
50731 
50732  RETURN
50733  END
50734 
50735 C*********************************************************************
50736 
50737 C...PYFISB
50738 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
50739 
50740  FUNCTION pyfisb(X)
50741 
50742 C...Double precision and integer declarations.
50743  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50744  IMPLICIT INTEGER(i-n)
50745  INTEGER pyk,pychge,pycomp
50746 C...Commonblock.
50747  common/pyints/xxm(20)
50748  SAVE/pyints/
50749 
50750  pyfisb = log(abs(x*xxm(2)+(1-x)*xxm(3)-x*(1-x)*xxm(1))/
50751  &(x*(xxm(2)-xxm(3))+xxm(3)))
50752 
50753  RETURN
50754  END
50755 
50756 C*********************************************************************
50757 
50758 C...PYSFDC
50759 C...Calculates decays of sfermions.
50760 
50761  SUBROUTINE pysfdc(KFIN,XLAM,IDLAM,IKNT)
50762 
50763 C...Double precision and integer declarations.
50764  IMPLICIT DOUBLE PRECISION(a-h, o-z)
50765  IMPLICIT INTEGER(i-n)
50766  INTEGER pyk,pychge,pycomp
50767 C...Parameter statement to help give large particle numbers.
50768  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
50769  &kexcit=4000000,kdimen=5000000)
50770 C...Commonblocks.
50771  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50772  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50773  common/pymssm/imss(0:99),rmss(0:99)
50774  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
50775  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
50776  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
50777 
50778 C...Local variables.
50779  COMPLEX*16 zmixc(4,4),vmixc(2,2),umixc(2,2)
50780  COMPLEX*16 cal,car,cbl,cbr,calp,carp,cblp,cbrp,ca,cb
50781  INTEGER kfin,kcin
50782  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,xmz,axmj
50783  DOUBLE PRECISION xmi2,xmi3,xma2,xmb2,xmfp
50784  DOUBLE PRECISION pylamf,xl
50785  DOUBLE PRECISION tanw,xw,aem,c1,as
50786  DOUBLE PRECISION al,ar,bl,br
50787  DOUBLE PRECISION ch1,ch2,ch3,ch4
50788  DOUBLE PRECISION xmbot,xmtop
50789  DOUBLE PRECISION xlam(0:400)
50790  INTEGER idlam(400,3)
50791  INTEGER lknt,ix,ilr,idu,j,i,iknt,ifl,ii
50792  DOUBLE PRECISION sr2
50793  DOUBLE PRECISION cbeta,sbeta
50794  DOUBLE PRECISION cw
50795  DOUBLE PRECISION beta,alfa,xmu,at,ab,atrit,atrib,atril
50796  DOUBLE PRECISION cosa,sina,tanb
50797  DOUBLE PRECISION pyalem,pi,pyalps,ei
50798  DOUBLE PRECISION ghrr,ghll,ghlr,xmb,blr
50799  INTEGER ig,kf1,kf2
50800  INTEGER igg(4),kfnchi(4),kfcchi(2)
50801  DATA igg/23,25,35,36/
50802  DATA pi/3.141592654d0/
50803  DATA sr2/1.4142136d0/
50804  DATA kfnchi/1000022,1000023,1000025,1000035/
50805  DATA kfcchi/1000024,1000037/
50806 
50807 C...COUNT THE NUMBER OF DECAY MODES
50808  lknt=0
50809 
50810 C...NO NU_R DECAYS
50811  IF(kfin.EQ.ksusy2+12.OR.kfin.EQ.ksusy2+14.OR.
50812  &kfin.EQ.ksusy2+16) RETURN
50813 
50814  xmw=pmas(24,1)
50815  xmw2=xmw**2
50816  xmz=pmas(23,1)
50817  xw=paru(102)
50818  tanw = sqrt(xw/(1d0-xw))
50819  cw=sqrt(1d0-xw)
50820 
50821  DO 110 i=1,4
50822  DO 100 j=1,4
50823  zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
50824  100 CONTINUE
50825  110 CONTINUE
50826  DO 130 i=1,2
50827  DO 120 j=1,2
50828  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
50829  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
50830  120 CONTINUE
50831  130 CONTINUE
50832 
50833 C...KCIN
50834  kcin=pycomp(kfin)
50835 C...ILR is 1 for left and 2 for right.
50836  ilr=kfin/ksusy1
50837 C...IFL is matching non-SUSY flavour.
50838  ifl=mod(kfin,ksusy1)
50839 C...IDU is weak isospin, 1 for down and 2 for up.
50840  idu=2-mod(ifl,2)
50841 
50842  xmi=pmas(kcin,1)
50843  xmi2=xmi**2
50844  aem=pyalem(xmi2)
50845  as =pyalps(xmi2)
50846  c1=aem/xw
50847  xmi3=xmi**3
50848  ei=kchg(ifl,1)/3d0
50849 
50850  xmbot=pymrun(5,xmi2)
50851  xmtop=pymrun(6,xmi2)
50852 
50853  tanb=rmss(5)
50854  beta=atan(tanb)
50855  alfa=rmss(18)
50856  cbeta=cos(beta)
50857  sbeta=tanb*cbeta
50858  sina=sin(alfa)
50859  cosa=cos(alfa)
50860  xmu=-rmss(4)
50861  atrit=rmss(16)
50862  atrib=rmss(15)
50863  atril=rmss(17)
50864 
50865 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50866 
50867  IF(imss(11).EQ.1) THEN
50868  xmp=rmss(29)
50869  idg=39+ksusy1
50870  xmgr=pmas(pycomp(idg),1)
50871  xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi
50872  IF(ifl.EQ.5) THEN
50873  xmf=xmbot
50874  ELSEIF(ifl.EQ.6) THEN
50875  xmf=xmtop
50876  ELSE
50877  xmf=pmas(ifl,1)
50878  ENDIF
50879  IF(xmi.GT.xmgr+xmf) THEN
50880  lknt=lknt+1
50881  idlam(lknt,1)=idg
50882  idlam(lknt,2)=ifl
50883  idlam(lknt,3)=0
50884  xlam(lknt)=xfac*(1d0-xmf**2/xmi2)**4
50885  ENDIF
50886  ENDIF
50887 
50888 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50889 
50890 C...CHARGED DECAYS:
50891  DO 140 ix=1,2
50892 C...DI -> U CHI1-,CHI2-
50893  IF(idu.EQ.1) THEN
50894  xmfp=pmas(ifl+1,1)
50895  xmf =pmas(ifl,1)
50896 C...UI -> D CHI1+,CHI2+
50897  ELSE
50898  xmfp=pmas(ifl-1,1)
50899  xmf =pmas(ifl,1)
50900  ENDIF
50901  xmj=smw(ix)
50902  axmj=abs(xmj)
50903  IF(xmi.GE.axmj+xmfp) THEN
50904  xma2=xmj**2
50905  xmb2=xmfp**2
50906  IF(idu.EQ.2) THEN
50907  IF(ifl.EQ.6) THEN
50908  xmfp=xmbot
50909  xmf =xmtop
50910  ELSEIF(ifl.LT.6) THEN
50911  xmf=0d0
50912  xmfp=0d0
50913  ENDIF
50914  cbl=vmixc(ix,1)
50915  cal=-xmfp*umixc(ix,2)/sr2/xmw/cbeta
50916  cbr=-xmf*vmixc(ix,2)/sr2/xmw/sbeta
50917  car=0d0
50918  ELSE
50919  IF(ifl.EQ.5) THEN
50920  xmf =xmbot
50921  xmfp=xmtop
50922  ELSEIF(ifl.LT.5) THEN
50923  xmf=0d0
50924  xmfp=0d0
50925  ENDIF
50926  cbl=umixc(ix,1)
50927  cal=-xmfp*vmixc(ix,2)/sr2/xmw/sbeta
50928  cbr=-xmf*umixc(ix,2)/sr2/xmw/cbeta
50929  car=0d0
50930  ENDIF
50931 
50932  calp=sfmix(ifl,1)*cal + sfmix(ifl,2)*car
50933  cblp=sfmix(ifl,1)*cbl + sfmix(ifl,2)*cbr
50934  carp=sfmix(ifl,4)*car + sfmix(ifl,3)*cal
50935  cbrp=sfmix(ifl,4)*cbr + sfmix(ifl,3)*cbl
50936  cal=calp
50937  cbl=cblp
50938  car=carp
50939  cbr=cbrp
50940 
50941 C...F1 -> F` CHI
50942  IF(ilr.EQ.1) THEN
50943  ca=cal
50944  cb=cbl
50945 C...F2 -> F` CHI
50946  ELSE
50947  ca=car
50948  cb=cbr
50949  ENDIF
50950  lknt=lknt+1
50951  xl=pylamf(xmi2,xma2,xmb2)
50952 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50953  xlam(lknt)=2d0*c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
50954  & (abs(ca)**2+abs(cb)**2)-4d0*dble(ca*dconjg(cb))*xmj*xmfp)
50955  idlam(lknt,3)=0
50956  IF(idu.EQ.1) THEN
50957  idlam(lknt,1)=-kfcchi(ix)
50958  idlam(lknt,2)=ifl+1
50959  ELSE
50960  idlam(lknt,1)=kfcchi(ix)
50961  idlam(lknt,2)=ifl-1
50962  ENDIF
50963  ENDIF
50964  140 CONTINUE
50965 
50966 C...NEUTRAL DECAYS
50967  DO 150 ix=1,4
50968 C...DI -> D CHI10
50969  xmf=pmas(ifl,1)
50970  xmj=smz(ix)
50971  axmj=abs(xmj)
50972  IF(xmi.GE.axmj+xmf) THEN
50973  xma2=xmj**2
50974  xmb2=xmf**2
50975  IF(idu.EQ.1) THEN
50976  IF(ifl.EQ.5) THEN
50977  xmf=xmbot
50978  ELSEIF(ifl.LT.5) THEN
50979  xmf=0d0
50980  ENDIF
50981  cbl=-zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei+1)
50982  cal=xmf*zmixc(ix,3)/xmw/cbeta
50983  car=-2d0*ei*tanw*zmixc(ix,1)
50984  cbr=cal
50985  ELSE
50986  IF(ifl.EQ.6) THEN
50987  xmf=xmtop
50988  ELSEIF(ifl.LT.5) THEN
50989  xmf=0d0
50990  ENDIF
50991  cbl=zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-1)
50992  cal=xmf*zmixc(ix,4)/xmw/sbeta
50993  car=-2d0*ei*tanw*zmixc(ix,1)
50994  cbr=cal
50995  ENDIF
50996 
50997  calp=sfmix(ifl,1)*cal + sfmix(ifl,2)*car
50998  cblp=sfmix(ifl,1)*cbl + sfmix(ifl,2)*cbr
50999  carp=sfmix(ifl,4)*car + sfmix(ifl,3)*cal
51000  cbrp=sfmix(ifl,4)*cbr + sfmix(ifl,3)*cbl
51001  cal=calp
51002  cbl=cblp
51003  car=carp
51004  cbr=cbrp
51005 
51006 C...F1 -> F CHI
51007  IF(ilr.EQ.1) THEN
51008  ca=cal
51009  cb=cbl
51010 C...F2 -> F CHI
51011  ELSE
51012  ca=car
51013  cb=cbr
51014  ENDIF
51015  lknt=lknt+1
51016  xl=pylamf(xmi2,xma2,xmb2)
51017 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
51018  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
51019  & (abs(ca)**2+abs(cb)**2)-4d0*dble(ca*dconjg(cb))*xmj*xmf)
51020  idlam(lknt,1)=kfnchi(ix)
51021  idlam(lknt,2)=ifl
51022  idlam(lknt,3)=0
51023  ENDIF
51024  150 CONTINUE
51025 
51026 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
51027 C...IG=23,25,35,36
51028  DO 160 ii=1,4
51029  ig=igg(ii)
51030  IF(ilr.EQ.1) goto 160
51031  xmb=pmas(ig,1)
51032  xmsf1=pmas(pycomp(kfin-ksusy1),1)
51033  IF(xmi.LT.xmsf1+xmb) goto 160
51034  IF(ig.EQ.23) THEN
51035  bl=-sign(.5d0,ei)/cw+ei*xw/cw
51036  br=ei*xw/cw
51037  blr=0d0
51038  ELSEIF(ig.EQ.25) THEN
51039  IF(ifl.EQ.5) THEN
51040  xmf=xmbot
51041  ELSEIF(ifl.EQ.6) THEN
51042  xmf=xmtop
51043  ELSEIF(ifl.LT.5) THEN
51044  xmf=0d0
51045  ELSE
51046  xmf=pmas(ifl,1)
51047  ENDIF
51048  IF(idu.EQ.2) THEN
51049  ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
51050  & xmf**2/xmw*cosa/sbeta
51051  ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
51052  & xmf**2/xmw*cosa/sbeta
51053  ELSE
51054  ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
51055  & xmf**2/xmw*(-sina)/cbeta
51056  ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
51057  & xmf**2/xmw*(-sina)/cbeta
51058  ENDIF
51059  IF(ifl.EQ.5) THEN
51060  at=atrib
51061  ELSEIF(ifl.EQ.6) THEN
51062  at=atrit
51063  ELSEIF(ifl.EQ.15) THEN
51064  at=atril
51065  ELSE
51066  at=0d0
51067  ENDIF
51068 C.........need to complexify
51069  IF(idu.EQ.2) THEN
51070  ghlr=xmf/2d0/xmw/sbeta*(-xmu*sina+
51071  & at*cosa)
51072  ELSE
51073  ghlr=xmf/2d0/xmw/cbeta*(xmu*cosa-
51074  & at*sina)
51075  ENDIF
51076  bl=ghll
51077  br=ghrr
51078  blr=-ghlr
51079  ELSEIF(ig.EQ.35) THEN
51080  IF(ifl.EQ.5) THEN
51081  xmf=xmbot
51082  ELSEIF(ifl.EQ.6) THEN
51083  xmf=xmtop
51084  ELSEIF(ifl.LT.5) THEN
51085  xmf=0d0
51086  ELSE
51087  xmf=pmas(ifl,1)
51088  ENDIF
51089  IF(idu.EQ.2) THEN
51090  ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
51091  & xmf**2/xmw*sina/sbeta
51092  ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
51093  & xmf**2/xmw*sina/sbeta
51094  ELSE
51095  ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
51096  & xmf**2/xmw*cosa/cbeta
51097  ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
51098  & xmf**2/xmw*cosa/cbeta
51099  ENDIF
51100  IF(ifl.EQ.5) THEN
51101  at=atrib
51102  ELSEIF(ifl.EQ.6) THEN
51103  at=atrit
51104  ELSEIF(ifl.EQ.15) THEN
51105  at=atril
51106  ELSE
51107  at=0d0
51108  ENDIF
51109 C.........Need to complexify
51110  IF(idu.EQ.2) THEN
51111  ghlr=xmf/2d0/xmw/sbeta*(xmu*cosa+
51112  & at*sina)
51113  ELSE
51114  ghlr=xmf/2d0/xmw/cbeta*(xmu*sina+
51115  & at*cosa)
51116  ENDIF
51117  bl=ghll
51118  br=ghrr
51119  blr=ghlr
51120  ELSEIF(ig.EQ.36) THEN
51121  ghll=0d0
51122  ghrr=0d0
51123  IF(ifl.EQ.5) THEN
51124  xmf=xmbot
51125  ELSEIF(ifl.EQ.6) THEN
51126  xmf=xmtop
51127  ELSEIF(ifl.LT.5) THEN
51128  xmf=0d0
51129  ELSE
51130  xmf=pmas(ifl,1)
51131  ENDIF
51132  IF(ifl.EQ.5) THEN
51133  at=atrib
51134  ELSEIF(ifl.EQ.6) THEN
51135  at=atrit
51136  ELSEIF(ifl.EQ.15) THEN
51137  at=atril
51138  ELSE
51139  at=0d0
51140  ENDIF
51141 C.........Need to complexify
51142  IF(idu.EQ.2) THEN
51143  ghlr=xmf/2d0/xmw*(-xmu+at/tanb)
51144  ELSE
51145  ghlr=xmf/2d0/xmw/(-xmu+at*tanb)
51146  ENDIF
51147  bl=ghll
51148  br=ghrr
51149  blr=ghlr
51150  ENDIF
51151  al=sfmix(ifl,1)*sfmix(ifl,3)*bl+
51152  & sfmix(ifl,2)*sfmix(ifl,4)*br+
51153  & (sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,3)*sfmix(ifl,2))*blr
51154  xl=pylamf(xmi2,xmsf1**2,xmb**2)
51155  lknt=lknt+1
51156  IF(ig.EQ.23) THEN
51157  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
51158  ELSE
51159  xlam(lknt)=c1/4d0/xmi3*sqrt(xl)*al**2
51160  ENDIF
51161  idlam(lknt,3)=0
51162  idlam(lknt,1)=kfin-ksusy1
51163  idlam(lknt,2)=ig
51164  160 CONTINUE
51165 
51166 C...SF -> SF' + W
51167  xmb=pmas(24,1)
51168  IF(mod(ifl,2).EQ.0) THEN
51169  kf1=ksusy1+ifl-1
51170  ELSE
51171  kf1=ksusy1+ifl+1
51172  ENDIF
51173  kf2=kf1+ksusy1
51174  xmsf1=pmas(pycomp(kf1),1)
51175  xmsf2=pmas(pycomp(kf2),1)
51176  IF(xmi.GT.xmb+xmsf1) THEN
51177  IF(mod(ifl,2).EQ.0) THEN
51178  IF(ilr.EQ.1) THEN
51179  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,1)
51180  ELSE
51181  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,1)
51182  ENDIF
51183  ELSE
51184  IF(ilr.EQ.1) THEN
51185  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,1)
51186  ELSE
51187  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,1)
51188  ENDIF
51189  ENDIF
51190  xl=pylamf(xmi2,xmsf1**2,xmb**2)
51191  lknt=lknt+1
51192  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
51193  idlam(lknt,3)=0
51194  idlam(lknt,1)=kf1
51195  idlam(lknt,2)=sign(24,kchg(ifl,1))
51196  ENDIF
51197  IF(xmi.GT.xmb+xmsf2) THEN
51198  IF(mod(ifl,2).EQ.0) THEN
51199  IF(ilr.EQ.1) THEN
51200  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,3)
51201  ELSE
51202  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,3)
51203  ENDIF
51204  ELSE
51205  IF(ilr.EQ.1) THEN
51206  al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,3)
51207  ELSE
51208  al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,3)
51209  ENDIF
51210  ENDIF
51211  xl=pylamf(xmi2,xmsf2**2,xmb**2)
51212  lknt=lknt+1
51213  xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
51214  idlam(lknt,3)=0
51215  idlam(lknt,1)=kf2
51216  idlam(lknt,2)=sign(24,kchg(ifl,1))
51217  ENDIF
51218 
51219 C...SF -> SF' + HC
51220  xmb=pmas(37,1)
51221  IF(mod(ifl,2).EQ.0) THEN
51222  kf1=ksusy1+ifl-1
51223  ELSE
51224  kf1=ksusy1+ifl+1
51225  ENDIF
51226  kf2=kf1+ksusy1
51227  xmsf1=pmas(pycomp(kf1),1)
51228  xmsf2=pmas(pycomp(kf2),1)
51229  IF(xmi.GT.xmb+xmsf1) THEN
51230  xmf=0d0
51231  xmfp=0d0
51232  at=0d0
51233  ab=0d0
51234  IF(mod(ifl,2).EQ.0) THEN
51235 C...T1-> B1 HC
51236  IF(ilr.EQ.1) THEN
51237  ch1=-sfmix(ifl,1)*sfmix(ifl-1,1)
51238  ch2= sfmix(ifl,2)*sfmix(ifl-1,2)
51239  ch3=-sfmix(ifl,1)*sfmix(ifl-1,2)
51240  ch4=-sfmix(ifl,2)*sfmix(ifl-1,1)
51241 C...T2-> B1 HC
51242  ELSE
51243  ch1= sfmix(ifl,3)*sfmix(ifl-1,1)
51244  ch2=-sfmix(ifl,4)*sfmix(ifl-1,2)
51245  ch3= sfmix(ifl,3)*sfmix(ifl-1,2)
51246  ch4= sfmix(ifl,4)*sfmix(ifl-1,1)
51247  ENDIF
51248  IF(ifl.EQ.6) THEN
51249  xmf=xmtop
51250  xmfp=xmbot
51251  at=atrit
51252  ab=atrib
51253  ENDIF
51254  ELSE
51255 C...B1 -> T1 HC
51256  IF(ilr.EQ.1) THEN
51257  ch1=-sfmix(ifl+1,1)*sfmix(ifl,1)
51258  ch2= sfmix(ifl+1,2)*sfmix(ifl,2)
51259  ch3=-sfmix(ifl+1,1)*sfmix(ifl,2)
51260  ch4=-sfmix(ifl+1,2)*sfmix(ifl,1)
51261 C...B2-> T1 HC
51262  ELSE
51263  ch1= sfmix(ifl,3)*sfmix(ifl+1,1)
51264  ch2=-sfmix(ifl,4)*sfmix(ifl+1,2)
51265  ch3= sfmix(ifl,4)*sfmix(ifl+1,1)
51266  ch4= sfmix(ifl,3)*sfmix(ifl+1,2)
51267  ENDIF
51268  IF(ifl.EQ.5) THEN
51269  xmf=xmtop
51270  xmfp=xmbot
51271  at=atrit
51272  ab=atrib
51273  ENDIF
51274  ENDIF
51275  xl=pylamf(xmi2,xmsf1**2,xmb**2)
51276  lknt=lknt+1
51277 C.......Need to complexify
51278  al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
51279  & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
51280  & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
51281  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
51282  idlam(lknt,3)=0
51283  idlam(lknt,1)=kf1
51284  idlam(lknt,2)=sign(37,kchg(ifl,1))
51285  ENDIF
51286  IF(xmi.GT.xmb+xmsf2) THEN
51287  xmf=0d0
51288  xmfp=0d0
51289  at=0d0
51290  ab=0d0
51291  IF(mod(ifl,2).EQ.0) THEN
51292 C...T1-> B2 HC
51293  IF(ilr.EQ.1) THEN
51294  ch1= sfmix(ifl-1,3)*sfmix(ifl,1)
51295  ch2=-sfmix(ifl-1,4)*sfmix(ifl,2)
51296  ch3= sfmix(ifl-1,4)*sfmix(ifl,1)
51297  ch4= sfmix(ifl-1,3)*sfmix(ifl,2)
51298 C...T2-> B2 HC
51299  ELSE
51300  ch1= -sfmix(ifl,3)*sfmix(ifl-1,3)
51301  ch2= sfmix(ifl,4)*sfmix(ifl-1,4)
51302  ch3= -sfmix(ifl,3)*sfmix(ifl-1,4)
51303  ch4= -sfmix(ifl,4)*sfmix(ifl-1,3)
51304  ENDIF
51305  IF(ifl.EQ.6) THEN
51306  xmf=xmtop
51307  xmfp=xmbot
51308  at=atrit
51309  ab=atrib
51310  ENDIF
51311  ELSE
51312 C...B1 -> T2 HC
51313  IF(ilr.EQ.1) THEN
51314  ch1= sfmix(ifl+1,3)*sfmix(ifl,1)
51315  ch2=-sfmix(ifl+1,4)*sfmix(ifl,2)
51316  ch3= sfmix(ifl+1,3)*sfmix(ifl,2)
51317  ch4= sfmix(ifl+1,4)*sfmix(ifl,1)
51318 C...B2-> T2 HC
51319  ELSE
51320  ch1= -sfmix(ifl+1,3)*sfmix(ifl,3)
51321  ch2= sfmix(ifl+1,4)*sfmix(ifl,4)
51322  ch3= -sfmix(ifl+1,3)*sfmix(ifl,4)
51323  ch4= -sfmix(ifl+1,4)*sfmix(ifl,3)
51324  ENDIF
51325  IF(ifl.EQ.5) THEN
51326  xmf=xmtop
51327  xmfp=xmbot
51328  at=atrit
51329  ab=atrib
51330  ENDIF
51331  ENDIF
51332  xl=pylamf(xmi2,xmsf1**2,xmb**2)
51333  lknt=lknt+1
51334 C.......Need to complexify
51335  al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
51336  & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
51337  & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
51338  xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
51339  idlam(lknt,3)=0
51340  idlam(lknt,1)=kf2
51341  idlam(lknt,2)=sign(37,kchg(ifl,1))
51342  ENDIF
51343 
51344 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
51345 
51346  IF(ifl.LE.6) THEN
51347  xmfp=0d0
51348  xmf=0d0
51349  IF(ifl.EQ.6) xmf=pmas(6,1)
51350  IF(ifl.EQ.5) xmf=pmas(5,1)
51351  xmj=pmas(pycomp(ksusy1+21),1)
51352  axmj=abs(xmj)
51353  IF(xmi.GE.axmj+xmf) THEN
51354  al=-sfmix(ifl,3)
51355  bl=sfmix(ifl,1)
51356  ar=-sfmix(ifl,4)
51357  br=sfmix(ifl,2)
51358 C...F1 -> F CHI
51359  IF(ilr.EQ.1) THEN
51360  xca=al
51361  xcb=bl
51362 C...F2 -> F CHI
51363  ELSE
51364  xca=ar
51365  xcb=br
51366  ENDIF
51367  lknt=lknt+1
51368  xma2=xmj**2
51369  xmb2=xmf**2
51370  xl=pylamf(xmi2,xma2,xmb2)
51371  xlam(lknt)=4d0/3d0*as/2d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
51372  & (xca**2+xcb**2)+4d0*xca*xcb*xmj*xmf)
51373  idlam(lknt,1)=ksusy1+21
51374  idlam(lknt,2)=ifl
51375  idlam(lknt,3)=0
51376  ENDIF
51377  ENDIF
51378 
51379 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
51380  IF(kfin.EQ.ksusy1+6.AND.pmas(kcin,1).GT.
51381  &pmas(pycomp(ksusy1+22),1)+pmas(4,1)) THEN
51382 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
51383 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
51384 C...M*M = C1**2 * G**2/(16PI**2)
51385 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
51386  lknt=lknt+1
51387  xl=pylamf(xmi2,0d0,pmas(pycomp(ksusy1+22),1)**2)
51388  xlam(lknt)=c1**3/64d0/pi**2/xmi3*sqrt(xl)
51389  IF(xlam(lknt).EQ.0) xlam(lknt)=1d-3
51390  idlam(lknt,1)=ksusy1+22
51391  idlam(lknt,2)=4
51392  idlam(lknt,3)=0
51393  ENDIF
51394 
51395 C...R-violating sfermion decays (SKANDS).
51396  CALL pyrvsf(kfin,xlam,idlam,lknt)
51397 
51398  iknt=lknt
51399  xlam(0)=0d0
51400  DO 170 i=1,iknt
51401  IF(xlam(i).LT.0d0) xlam(i)=0d0
51402  xlam(0)=xlam(0)+xlam(i)
51403  170 CONTINUE
51404  IF(xlam(0).EQ.0d0) xlam(0)=1d-3
51405 
51406  RETURN
51407  END
51408 
51409 C*********************************************************************
51410 
51411 C...PYGLUI
51412 C...Calculates gluino decay modes.
51413 
51414  SUBROUTINE pyglui(KFIN,XLAM,IDLAM,IKNT)
51415 
51416 C...Double precision and integer declarations.
51417  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51418  IMPLICIT INTEGER(i-n)
51419  INTEGER pyk,pychge,pycomp
51420 C...Parameter statement to help give large particle numbers.
51421  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
51422  &kexcit=4000000,kdimen=5000000)
51423 C...Commonblocks.
51424  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51425  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
51426  common/pymssm/imss(0:99),rmss(0:99)
51427  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
51428  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
51429 CC &SFMIX(16,4),
51430 C COMMON/PYINTS/XXM(20)
51431  COMPLEX*16 cxc
51432  common/pyintc/xxc(10),cxc(8)
51433  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyintc/
51434 
51435 C...Local variables
51436  COMPLEX*16 zmixc(4,4),vmixc(2,2),umixc(2,2),olpp,orpp,glij,grij
51437  DOUBLE PRECISION xmi,xmj,xmf,axmj,axmi
51438  DOUBLE PRECISION xmi2,xmi3,xma2,xmb2,xmfp
51439  DOUBLE PRECISION pylamf,xl
51440  DOUBLE PRECISION tanw,xw,aem,c1,as,s12max,s12min
51441  DOUBLE PRECISION ca,cb,al,ar,bl,br
51442  DOUBLE PRECISION xlam(0:400)
51443  INTEGER idlam(400,3)
51444  INTEGER lknt,ix,ilr,i,iknt,ifl
51445  DOUBLE PRECISION sr2
51446  DOUBLE PRECISION gam
51447  DOUBLE PRECISION pyalem,pi,pyalps,ei,t3i
51448  EXTERNAL pygaus,pyxxz6
51449  DOUBLE PRECISION pygaus,pyxxz6
51450  DOUBLE PRECISION prec
51451  INTEGER kfnchi(4),kfcchi(2)
51452  DATA pi/3.141592654d0/
51453  DATA sr2/1.4142136d0/
51454  DATA prec/1d-2/
51455  DATA kfnchi/1000022,1000023,1000025,1000035/
51456  DATA kfcchi/1000024,1000037/
51457 
51458 C...COUNT THE NUMBER OF DECAY MODES
51459  lknt=0
51460  IF(kfin.NE.ksusy1+21) RETURN
51461  kcin=pycomp(kfin)
51462 
51463  xw=paru(102)
51464  tanw = sqrt(xw/(1d0-xw))
51465 
51466  xmi=pmas(kcin,1)
51467  axmi=abs(xmi)
51468  xmi2=xmi**2
51469  aem=pyalem(xmi2)
51470  as =pyalps(xmi2)
51471  c1=aem/xw
51472  xmi3=axmi**3
51473 
51474  xmi=sign(xmi,rmss(3))
51475 
51476 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
51477 
51478  IF(imss(11).EQ.1) THEN
51479  xmp=rmss(29)
51480  idg=39+ksusy1
51481  xmgr=pmas(pycomp(idg),1)
51482  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
51483  IF(axmi.GT.xmgr) THEN
51484  lknt=lknt+1
51485  idlam(lknt,1)=idg
51486  idlam(lknt,2)=21
51487  idlam(lknt,3)=0
51488  xlam(lknt)=xfac
51489  ENDIF
51490  ENDIF
51491 
51492 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
51493 
51494  DO 110 ifl=1,6
51495  DO 100 ilr=1,2
51496  xmj=pmas(pycomp(ilr*ksusy1+ifl),1)
51497  axmj=abs(xmj)
51498  xmf=pmas(ifl,1)
51499  IF(axmi.GE.axmj+xmf) THEN
51500 C...Minus sign difference from gluino-quark-squark feynman rules
51501  al=sfmix(ifl,1)
51502  bl=-sfmix(ifl,3)
51503  ar=sfmix(ifl,2)
51504  br=-sfmix(ifl,4)
51505 C...F1 -> F CHI
51506  IF(ilr.EQ.1) THEN
51507  ca=al
51508  cb=bl
51509 C...F2 -> F CHI
51510  ELSE
51511  ca=ar
51512  cb=br
51513  ENDIF
51514  lknt=lknt+1
51515  xma2=xmj**2
51516  xmb2=xmf**2
51517  xl=pylamf(xmi2,xma2,xmb2)
51518  xlam(lknt)=4d0/8d0*as/4d0/xmi3*sqrt(xl)*((xmi2+xmb2-xma2)*
51519  & (ca**2+cb**2)-4d0*ca*cb*xmi*xmf)
51520  idlam(lknt,1)=ilr*ksusy1+ifl
51521  idlam(lknt,2)=-ifl
51522  idlam(lknt,3)=0
51523  lknt=lknt+1
51524  xlam(lknt)=xlam(lknt-1)
51525  idlam(lknt,1)=-idlam(lknt-1,1)
51526  idlam(lknt,2)=-idlam(lknt-1,2)
51527  idlam(lknt,3)=0
51528  ENDIF
51529  100 CONTINUE
51530  110 CONTINUE
51531 
51532 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
51533 C...GLUINO -> NI Q QBAR
51534  DO 170 ix=1,4
51535  xmj=smz(ix)
51536  axmj=abs(xmj)
51537  IF(axmi.GE.axmj) THEN
51538  DO 120 i=1,4
51539  zmixc(ix,i)=dcmplx(zmix(ix,i),zmixi(ix,i))
51540  120 CONTINUE
51541  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))/sr2
51542  orpp=dconjg(olpp)
51543  xxc(1)=0d0
51544  xxc(2)=xmj
51545  xxc(3)=0d0
51546  xxc(4)=xmi
51547  ia=1
51548  xxc(5)=pmas(pycomp(ksusy1+ia),1)
51549  xxc(6)=pmas(pycomp(ksusy2+ia),1)
51550  xxc(7)=xxc(5)
51551  xxc(8)=xxc(6)
51552  xxc(9)=1d6
51553  xxc(10)=0d0
51554  ei=kchg(ia,1)/3d0
51555  t3i=sign(1d0,ei+1d-6)/2d0
51556  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
51557  grij=zmixc(ix,1)*(ei*tanw)*orpp
51558  cxc(1)=0d0
51559  cxc(2)=-glij
51560  cxc(3)=0d0
51561  cxc(4)=dconjg(glij)
51562  cxc(5)=0d0
51563  cxc(6)=grij
51564  cxc(7)=0d0
51565  cxc(8)=-dconjg(grij)
51566  s12min=0d0
51567  s12max=(axmi-axmj)**2
51568  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) goto 130
51569  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
51570  lknt=lknt+1
51571  xlam(lknt)=c1*as/xmi3/(16d0*pi)*
51572  & pygaus(pyxxz6,s12min,s12max,1d-2)
51573  idlam(lknt,1)=kfnchi(ix)
51574  idlam(lknt,2)=1
51575  idlam(lknt,3)=-1
51576  ENDIF
51577  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
51578  lknt=lknt+1
51579  xlam(lknt)=xlam(lknt-1)
51580  idlam(lknt,1)=kfnchi(ix)
51581  idlam(lknt,2)=3
51582  idlam(lknt,3)=-3
51583  ENDIF
51584  130 CONTINUE
51585  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
51586  pmold=pmas(pycomp(ksusy1+5),1)
51587  IF(axmi.GT.pmas(pycomp(ksusy2+5),1)+pmas(5,1)) THEN
51588  goto 140
51589  ELSEIF(axmi.GT.pmas(pycomp(ksusy1+5),1)+pmas(5,1)) THEN
51590  pmas(pycomp(ksusy1+5),1)=100d0*xmi
51591  ENDIF
51592  CALL pytbbn(ix,100,-1d0/3d0,xmi,gam)
51593  lknt=lknt+1
51594  xlam(lknt)=gam
51595  idlam(lknt,1)=kfnchi(ix)
51596  idlam(lknt,2)=5
51597  idlam(lknt,3)=-5
51598  pmas(pycomp(ksusy1+5),1)=pmold
51599  ENDIF
51600 C...U-TYPE QUARKS
51601  140 CONTINUE
51602  ia=2
51603  xxc(5)=pmas(pycomp(ksusy1+ia),1)
51604  xxc(6)=pmas(pycomp(ksusy2+ia),1)
51605 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
51606  xxc(7)=xxc(5)
51607  xxc(8)=xxc(6)
51608  ei=kchg(ia,1)/3d0
51609  t3i=sign(1d0,ei+1d-6)/2d0
51610  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
51611  grij=zmixc(ix,1)*(ei*tanw)*orpp
51612  cxc(2)=-glij
51613  cxc(4)=dconjg(glij)
51614  cxc(6)=grij
51615  cxc(8)=-dconjg(grij)
51616  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) goto 150
51617  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
51618  lknt=lknt+1
51619  xlam(lknt)=c1*as/xmi3/(16d0*pi)*
51620  & pygaus(pyxxz6,s12min,s12max,1d-2)
51621  idlam(lknt,1)=kfnchi(ix)
51622  idlam(lknt,2)=2
51623  idlam(lknt,3)=-2
51624  ENDIF
51625  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
51626  lknt=lknt+1
51627  xlam(lknt)=xlam(lknt-1)
51628  idlam(lknt,1)=kfnchi(ix)
51629  idlam(lknt,2)=4
51630  idlam(lknt,3)=-4
51631  ENDIF
51632  150 CONTINUE
51633 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
51634 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
51635  xmf=pmas(6,1)
51636  IF(axmi.GE.axmj+2d0*xmf) THEN
51637  pmold=pmas(pycomp(ksusy1+6),1)
51638  IF(axmi.GT.pmas(pycomp(ksusy2+6),1)+xmf) THEN
51639  goto 160
51640  ELSEIF(axmi.GT.pmas(pycomp(ksusy1+6),1)+xmf) THEN
51641  pmas(pycomp(ksusy1+6),1)=100d0*xmi
51642  ENDIF
51643  CALL pytbbn(ix,100,2d0/3d0,xmi,gam)
51644  lknt=lknt+1
51645  xlam(lknt)=gam
51646  idlam(lknt,1)=kfnchi(ix)
51647  idlam(lknt,2)=6
51648  idlam(lknt,3)=-6
51649  pmas(pycomp(ksusy1+6),1)=pmold
51650  ENDIF
51651  160 CONTINUE
51652  ENDIF
51653  170 CONTINUE
51654 
51655 C...GLUINO -> CI Q QBAR'
51656  DO 210 ix=1,2
51657  xmj=smw(ix)
51658  axmj=abs(xmj)
51659  IF(axmi.GE.axmj) THEN
51660  DO 180 i=1,2
51661  vmixc(ix,i)=dcmplx(vmix(ix,i),vmixi(ix,i))
51662  umixc(ix,i)=dcmplx(umix(ix,i),umixi(ix,i))
51663  180 CONTINUE
51664  s12min=0d0
51665  s12max=(axmi-axmj)**2
51666  xxc(1)=0d0
51667  xxc(2)=xmj
51668  xxc(3)=0d0
51669  xxc(4)=xmi
51670  xxc(5)=pmas(pycomp(ksusy1+1),1)
51671  xxc(6)=pmas(pycomp(ksusy1+2),1)
51672  xxc(9)=1d6
51673  xxc(10)=0d0
51674  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))
51675  orpp=dconjg(olpp)
51676  cxc(1)=dcmplx(0d0,0d0)
51677  cxc(3)=dcmplx(0d0,0d0)
51678  cxc(5)=dcmplx(0d0,0d0)
51679  cxc(7)=dcmplx(0d0,0d0)
51680  cxc(2)=umixc(ix,1)*olpp/sr2
51681  cxc(4)=-dconjg(vmixc(ix,1))*orpp/sr2
51682  cxc(6)=dcmplx(0d0,0d0)
51683  cxc(8)=dcmplx(0d0,0d0)
51684  IF(xxc(5).LT.axmi) THEN
51685  xxc(5)=1d6
51686  ELSEIF(xxc(6).LT.axmi) THEN
51687  xxc(6)=1d6
51688  ENDIF
51689  xxc(7)=xxc(6)
51690  xxc(8)=xxc(5)
51691  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) goto 190
51692  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
51693  lknt=lknt+1
51694  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
51695  & pygaus(pyxxz6,s12min,s12max,prec)
51696  idlam(lknt,1)=kfcchi(ix)
51697  idlam(lknt,2)=1
51698  idlam(lknt,3)=-2
51699  lknt=lknt+1
51700  xlam(lknt)=xlam(lknt-1)
51701  idlam(lknt,1)=-idlam(lknt-1,1)
51702  idlam(lknt,2)=-idlam(lknt-1,2)
51703  idlam(lknt,3)=-idlam(lknt-1,3)
51704  ENDIF
51705  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
51706  lknt=lknt+1
51707  xlam(lknt)=xlam(lknt-1)
51708  idlam(lknt,1)=kfcchi(ix)
51709  idlam(lknt,2)=3
51710  idlam(lknt,3)=-4
51711  lknt=lknt+1
51712  xlam(lknt)=xlam(lknt-1)
51713  idlam(lknt,1)=-idlam(lknt-1,1)
51714  idlam(lknt,2)=-idlam(lknt-1,2)
51715  idlam(lknt,3)=-idlam(lknt-1,3)
51716  ENDIF
51717  190 CONTINUE
51718 
51719  xmf=pmas(6,1)
51720  xmfp=pmas(5,1)
51721  IF(axmi.GE.axmj+xmf+xmfp) THEN
51722  IF(xmi.GT.min(pmas(pycomp(ksusy1+5),1)+xmfp,
51723  $ pmas(pycomp(ksusy2+6),1)+xmf)) goto 200
51724  pmolt2=pmas(pycomp(ksusy2+6),1)
51725  pmolb2=pmas(pycomp(ksusy2+5),1)
51726  pmolt1=pmas(pycomp(ksusy1+6),1)
51727  pmolb1=pmas(pycomp(ksusy1+5),1)
51728  IF(xmi.GT.pmolt2+xmf) pmas(pycomp(ksusy2+6),1)=100d0*axmi
51729  IF(xmi.GT.pmolt1+xmf) pmas(pycomp(ksusy1+6),1)=100d0*axmi
51730  IF(xmi.GT.pmolb2+xmfp) pmas(pycomp(ksusy2+5),1)=100d0*axmi
51731  IF(xmi.GT.pmolb1+xmfp) pmas(pycomp(ksusy1+5),1)=100d0*axmi
51732  CALL pytbbc(ix,100,xmi,gam)
51733  lknt=lknt+1
51734  xlam(lknt)=gam
51735  idlam(lknt,1)=kfcchi(ix)
51736  idlam(lknt,2)=5
51737  idlam(lknt,3)=-6
51738  lknt=lknt+1
51739  xlam(lknt)=xlam(lknt-1)
51740  idlam(lknt,1)=-idlam(lknt-1,1)
51741  idlam(lknt,2)=-idlam(lknt-1,2)
51742  idlam(lknt,3)=-idlam(lknt-1,3)
51743  pmas(pycomp(ksusy2+6),1)=pmolt2
51744  pmas(pycomp(ksusy2+5),1)=pmolb2
51745  pmas(pycomp(ksusy1+6),1)=pmolt1
51746  pmas(pycomp(ksusy1+5),1)=pmolb1
51747  ENDIF
51748  200 CONTINUE
51749  ENDIF
51750  210 CONTINUE
51751 
51752 C...R-parity violating (3-body) decays.
51753  CALL pyrvgl(kfin,xlam,idlam,lknt)
51754 
51755  iknt=lknt
51756  xlam(0)=0d0
51757  DO 220 i=1,iknt
51758  IF(xlam(i).LT.0d0) xlam(i)=0d0
51759  xlam(0)=xlam(0)+xlam(i)
51760  220 CONTINUE
51761  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
51762 
51763  RETURN
51764  END
51765 
51766 
51767 C*********************************************************************
51768 
51769 C...PYTBBN
51770 C...Calculates the three-body decay of gluinos into
51771 C...neutralinos and third generation fermions.
51772 
51773  SUBROUTINE pytbbn(I,NN,E,XMGLU,GAM)
51774 
51775 C...Double precision and integer declarations.
51776  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51777  IMPLICIT INTEGER(i-n)
51778  INTEGER pyk,pychge,pycomp
51779 C...Parameter statement to help give large particle numbers.
51780  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
51781  &kexcit=4000000,kdimen=5000000)
51782 C...Commonblocks.
51783  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51784  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
51785  common/pymssm/imss(0:99),rmss(0:99)
51786  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
51787  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
51788  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
51789 
51790 C...Local variables.
51791  EXTERNAL pysimp,pylamf
51792  DOUBLE PRECISION pysimp,pylamf
51793  INTEGER lin,nn
51794  DOUBLE PRECISION cosd,sind,cosd2,sind2,cos2d,sin2d
51795  DOUBLE PRECISION hl,hr,fl,fr,hl2,hr2,fl2,fr2
51796  DOUBLE PRECISION xms2(2),xm,xm2,xmg,xmg2,xmr,xmr2
51797  DOUBLE PRECISION sbar,smin,smax,xmqa,w,grs,g(0:6),summe(0:100)
51798  DOUBLE PRECISION ff,hh,hfl,hfr,hrfl,hlfr,xmq4,xm24
51799  DOUBLE PRECISION xln1,xln2,b1,b2
51800  DOUBLE PRECISION e,xmglu,gam
51801  DOUBLE PRECISION hrb(4),hlb(4),flb(4),frb(4)
51802  SAVE hrb,hlb,flb,frb
51803  DOUBLE PRECISION alphaw,alphas
51804  DOUBLE PRECISION hlt(4),hrt(4),flt(4),frt(4)
51805  SAVE hlt,hrt,flt,frt
51806  DOUBLE PRECISION amn(4),an(4,4),zn(3)
51807  SAVE amn,an,zn
51808  DOUBLE PRECISION ambot,sinc,cosc
51809  DOUBLE PRECISION amtop,sina,cosa
51810  DOUBLE PRECISION sinw,cosw,tanw
51811  DOUBLE PRECISION rot1(4,4)
51812  LOGICAL ifirst
51813  SAVE ifirst
51814  DATA ifirst/.true./
51815 
51816  tanb=rmss(5)
51817  sinb=tanb/sqrt(1d0+tanb**2)
51818  cosb=sinb/tanb
51819  xw=paru(102)
51820  sinw=sqrt(xw)
51821  cosw=sqrt(1d0-xw)
51822  tanw=sinw/cosw
51823  amw=pmas(24,1)
51824  cosc=sfmix(5,1)
51825  sinc=sfmix(5,3)
51826  cosa=sfmix(6,1)
51827  sina=sfmix(6,3)
51828  ambot=pymrun(5,xmglu**2)
51829  amtop=pymrun(6,xmglu**2)
51830  w2=sqrt(2d0)
51831  fakt1=ambot/w2/amw/cosb
51832  fakt2=amtop/w2/amw/sinb
51833  IF(ifirst) THEN
51834  DO 110 ii=1,4
51835  amn(ii)=smz(ii)
51836  DO 100 j=1,4
51837  rot1(ii,j)=0d0
51838  an(ii,j)=0d0
51839  100 CONTINUE
51840  110 CONTINUE
51841  rot1(1,1)=cosw
51842  rot1(1,2)=-sinw
51843  rot1(2,1)=-rot1(1,2)
51844  rot1(2,2)=rot1(1,1)
51845  rot1(3,3)=cosb
51846  rot1(3,4)=sinb
51847  rot1(4,3)=-rot1(3,4)
51848  rot1(4,4)=rot1(3,3)
51849  DO 140 ii=1,4
51850  DO 130 j=1,4
51851  DO 120 jj=1,4
51852  an(ii,j)=an(ii,j)+zmix(ii,jj)*rot1(jj,j)
51853  120 CONTINUE
51854  130 CONTINUE
51855  140 CONTINUE
51856  DO 150 j=1,4
51857  zn(1)=-fakt2*(-sinb*an(j,3)+cosb*an(j,4))
51858  zn(2)=-2d0*w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
51859  zn(3)=-2*w2/3d0*sinw*an(j,1)-w2*(0.5d0-2d0/3d0*
51860  & xw)*an(j,2)/cosw
51861  hrt(j)=zn(1)*cosa-zn(3)*sina
51862  hlt(j)=zn(1)*cosa+zn(2)*sina
51863  flt(j)=zn(3)*cosa+zn(1)*sina
51864  frt(j)=zn(2)*cosa-zn(1)*sina
51865 C FLU(J)=ZN(3)
51866 C FRU(J)=ZN(2)
51867  zn(1)=-fakt1*(cosb*an(j,3)+sinb*an(j,4))
51868  zn(2)=w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
51869  zn(3)=w2/3d0*sinw*an(j,1)+w2*(0.5d0-xw/3d0)*an(j,2)/cosw
51870  hrb(j)=zn(1)*cosc-zn(3)*sinc
51871  hlb(j)=zn(1)*cosc+zn(2)*sinc
51872  flb(j)=zn(3)*cosc+zn(1)*sinc
51873  frb(j)=zn(2)*cosc-zn(1)*sinc
51874 C FLD(J)=ZN(3)
51875 C FRD(J)=ZN(2)
51876  150 CONTINUE
51877 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51878 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51879 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51880 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51881  ifirst=.false.
51882  ENDIF
51883 
51884  IF(nint(3d0*e).EQ.2) THEN
51885  hl=hlt(i)
51886  hr=hrt(i)
51887  fl=flt(i)
51888  fr=frt(i)
51889  cosd=sfmix(6,1)
51890  sind=sfmix(6,3)
51891  xms2(1)=pmas(pycomp(ksusy1+6),1)**2
51892  xms2(2)=pmas(pycomp(ksusy2+6),1)**2
51893  xm=pmas(6,1)
51894  ELSE
51895  hl=hlb(i)
51896  hr=hrb(i)
51897  fl=flb(i)
51898  fr=frb(i)
51899  cosd=sfmix(5,1)
51900  sind=sfmix(5,3)
51901  xms2(1)=pmas(pycomp(ksusy1+5),1)**2
51902  xms2(2)=pmas(pycomp(ksusy2+5),1)**2
51903  xm=pmas(5,1)
51904  ENDIF
51905  cosd2=cosd*cosd
51906  sind2=sind*sind
51907  cos2d=cosd2-sind2
51908  sin2d=sind*cosd*2d0
51909  hl2=hl*hl
51910  hr2=hr*hr
51911  fl2=fl*fl
51912  fr2=fr*fr
51913  ff=fl*fr
51914  hh=hl*hr
51915  hfl=hl*fl
51916  hfr=hr*fr
51917  hrfl=hr*fl
51918  hlfr=hl*fr
51919  xm2=xm*xm
51920  xmg=xmglu
51921  xmg2=xmg*xmg
51922  alphaw=pyalem(xmg2)
51923  alphas=pyalps(xmg2)
51924  xmr=amn(i)
51925  xmr2=xmr*xmr
51926  xmq4=xmg*xm2*xmr
51927  xm24=(xmg2+xm2)*(xm2+xmr2)
51928  smin=4d0*xm2
51929  smax=(xmg-abs(xmr))**2
51930  xmqa=xmg2+2d0*xm2+xmr2
51931  DO 170 lin=1,nn-1
51932  sbar=smin+dble(lin)*(smax-smin)/dble(nn)
51933  grs=sbar-xmqa
51934  w=pylamf(xmg2,xmr2,sbar)*(0.25d0-xm2/sbar)
51935  w=dsqrt(w)
51936  xln1=log(abs((grs/2d0+xms2(1)-w)/(grs/2d0+xms2(1)+w)))
51937  xln2=log(abs((grs/2d0+xms2(2)-w)/(grs/2d0+xms2(2)+w)))
51938  b1=1d0/(grs/2d0+xms2(1)-w)-1d0/(grs/2d0+xms2(1)+w)
51939  b2=1d0/(grs/2d0+xms2(2)-w)-1d0/(grs/2d0+xms2(2)+w)
51940  g(0)=-2d0*(hl2+fl2+hr2+fr2+(hfr-hfl)*sin2d
51941  & +2d0*(ff*sind2-hh*cosd2))*w
51942  g(1)=((hl2+fl2)*(xmqa-2d0*xms2(1)-2d0*xm*xmg*sin2d)
51943  & +4d0*hfl*xm*xmr)*xln1
51944  & +((hl2+fl2)*((xmqa-xms2(1))*xms2(1)-xm24
51945  & +2d0*xm*xmg*(xm2+xmr2-xms2(1))*sin2d)
51946  & -4d0*hfl*xmr*xm*(xmg2+xm2-xms2(1))
51947  & +8d0*hfl*xmq4*sin2d)*b1
51948  g(2)=((hr2+fr2)*(xmqa-2d0*xms2(2)+2d0*xm*xmg*sin2d)
51949  & +4d0*hfr*xmr*xm)*xln2
51950  & +((hr2+fr2)*((xmqa-xms2(2))*xms2(2)-xm24
51951  & +2d0*xmg*xm*sin2d*(xms2(2)-xm2-xmr2))
51952  & +4d0*hfr*xm*xmr*(xms2(2)-xmg2-xm2)
51953  & -8d0*hfr*xmq4*sin2d)*b2
51954  g(3)=(2d0*hfl*sin2d*(xms2(1)*(grs+xms2(1))+xm2*(sbar-xmg2-xmr2)
51955  & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hl2*sind2+fl2*cosd2)*sbar
51956  & -2d0*xmg*xm*hfl*(sbar+xmr2-xmg2)
51957  & +xmr*xm*(hl2+fl2)*sin2d*(sbar+xmg2-xmr2)
51958  & -4d0*xmq4*(hl2-fl2)*cos2d)/(grs+2d0*xms2(1))*xln1
51959  g(4)=4d0*cos2d*xm*xmg/(xms2(1)-xms2(2))*
51960  & (((hlfr+hrfl)*(xm2+xmr2)+2d0*xm*xmr*(hh+ff))*(xln1-xln2)
51961  & +(hlfr+hrfl)*(xms2(2)*xln2-xms2(1)*xln1))
51962  g(5)=(2d0*(hh*cosd2-ff*sind2)
51963  & *((xms2(2)*(xms2(2)+grs)+xm2*xm2+xmg2*xmr2)*xln2
51964  & +(xms2(1)*(xms2(1)+grs)+xm2*xm2+xmg2*xmr2)*xln1)
51965  & +xm*((hh-ff)*sin2d*xmg-(hrfl-hlfr)*xmr)
51966  & *((grs+xms2(1)*2d0)*xln1-(grs+xms2(2)*2d0)*xln2)
51967  & +((hrfl-hlfr)*xmr*(sin2d*xmg*(sbar-4d0*xm2)
51968  & +cos2d*xm*(sbar+xmg2-xmr2))
51969  & +2d0*(ff*cosd2-hh*sind2)*xm2*(sbar-xmg2-xmr2))
51970  & *(xln1+xln2))/(grs+xms2(1)+xms2(2))
51971  g(6)=(-2d0*hfr*sin2d*(xms2(2)*(grs+xms2(2))+xm2*(sbar-xmg2-xmr2)
51972  & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hr2*sind2+fr2*cosd2)*sbar
51973  & -2d0*xmg*xm*hfr*(sbar+xmr2-xmg2)
51974  & -xmr*xm*(hr2+fr2)*sin2d*(sbar+xmg2-xmr2)
51975  & -4d0*xmq4*(hr2-fr2)*cos2d)/(grs+2d0*xms2(2))*xln2
51976  summe(lin)=0d0
51977  DO 160 j=0,6
51978  summe(lin)=summe(lin)+g(j)
51979  160 CONTINUE
51980  170 CONTINUE
51981  summe(0)=0d0
51982  summe(nn)=0d0
51983  gam = alphaw * alphas * pysimp(summe,smin,smax,nn)
51984  &/ (16d0 * paru(1) * paru(102) * xmglu**3)
51985 
51986  RETURN
51987  END
51988 
51989 C*********************************************************************
51990 
51991 C...PYTBBC
51992 C...Calculates the three-body decay of gluinos into
51993 C...charginos and third generation fermions.
51994 
51995  SUBROUTINE pytbbc(I,NN,XMGLU,GAM)
51996 
51997 C...Double precision and integer declarations.
51998  IMPLICIT DOUBLE PRECISION(a-h, o-z)
51999  IMPLICIT INTEGER(i-n)
52000  INTEGER pyk,pychge,pycomp
52001 C...Parameter statement to help give large particle numbers.
52002  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
52003  &kexcit=4000000,kdimen=5000000)
52004 C...Commonblocks.
52005  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
52006  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
52007  common/pymssm/imss(0:99),rmss(0:99)
52008  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
52009  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
52010  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
52011 
52012 C...Local variables.
52013  EXTERNAL pysimp,pylamf
52014  DOUBLE PRECISION pysimp,pylamf
52015  INTEGER i,nn,lin
52016  DOUBLE PRECISION xmg,xmg2,xmb,xmb2,xmr,xmr2
52017  DOUBLE PRECISION xmt,xmt2,xmst(4),xmsb(4)
52018  DOUBLE PRECISION ulr(2),vlr(2),xmq2,xmq4,am,w,sbar,smin,smax
52019  DOUBLE PRECISION summe(0:100),a(4,8)
52020  DOUBLE PRECISION cos2a,sin2a,cos2c,sin2c
52021  DOUBLE PRECISION grs,xmq3,xmgbtr,xmgtbr,ant1,ant2,anb1,anb2
52022  DOUBLE PRECISION xmglu,gam
52023  DOUBLE PRECISION xx1(2),xx2(2),aaa(2),bbb(2),ccc(2),
52024  &ddd(2),eee(2),fff(2)
52025  SAVE xx1,xx2,aaa,bbb,ccc,ddd,eee,fff
52026  DOUBLE PRECISION alphaw,alphas
52027  DOUBLE PRECISION amc(2)
52028  SAVE amc
52029  DOUBLE PRECISION ambot,amsb(2),sinc,cosc
52030  DOUBLE PRECISION amtop,amst(2),sina,cosa
52031  SAVE amsb,amst
52032  LOGICAL ifirst
52033  SAVE ifirst
52034  DATA ifirst/.true./
52035 
52036  tanb=rmss(5)
52037  sinb=tanb/sqrt(1d0+tanb**2)
52038  cosb=sinb/tanb
52039  xw=paru(102)
52040  amw=pmas(24,1)
52041  cosc=sfmix(5,1)
52042  sinc=sfmix(5,3)
52043  cosa=sfmix(6,1)
52044  sina=sfmix(6,3)
52045  ambot=pymrun(5,xmglu**2)
52046  amtop=pymrun(6,xmglu**2)
52047  w2=sqrt(2d0)
52048  amw=pmas(24,1)
52049  fakt1=ambot/w2/amw/cosb
52050  fakt2=amtop/w2/amw/sinb
52051  IF(ifirst) THEN
52052  amc(1)=smw(1)
52053  amc(2)=smw(2)
52054  DO 100 jj=1,2
52055  ccc(jj)=fakt1*umix(jj,2)*sinc-umix(jj,1)*cosc
52056  eee(jj)=fakt2*vmix(jj,2)*cosc
52057  ddd(jj)=fakt1*umix(jj,2)*cosc+umix(jj,1)*sinc
52058  fff(jj)=fakt2*vmix(jj,2)*sinc
52059  xx1(jj)=fakt2*vmix(jj,2)*sina-vmix(jj,1)*cosa
52060  aaa(jj)=fakt1*umix(jj,2)*cosa
52061  xx2(jj)=fakt2*vmix(jj,2)*cosa+vmix(jj,1)*sina
52062  bbb(jj)=fakt1*umix(jj,2)*sina
52063  100 CONTINUE
52064  amst(1)=pmas(pycomp(ksusy1+6),1)
52065  amst(2)=pmas(pycomp(ksusy2+6),1)
52066  amsb(1)=pmas(pycomp(ksusy1+5),1)
52067  amsb(2)=pmas(pycomp(ksusy2+5),1)
52068  ifirst=.false.
52069  ENDIF
52070 
52071  ulr(1)=xx1(i)*xx1(i)+aaa(i)*aaa(i)
52072  ulr(2)=xx2(i)*xx2(i)+bbb(i)*bbb(i)
52073  vlr(1)=ccc(i)*ccc(i)+eee(i)*eee(i)
52074  vlr(2)=ddd(i)*ddd(i)+fff(i)*fff(i)
52075 
52076  cos2a=cosa**2-sina**2
52077  sin2a=sina*cosa*2d0
52078  cos2c=cosc**2-sinc**2
52079  sin2c=sinc*cosc*2d0
52080 
52081  xmg=xmglu
52082  xmt=pmas(6,1)
52083  xmb=pmas(5,1)
52084  xmr=amc(i)
52085  xmg2=xmg*xmg
52086  alphaw=pyalem(xmg2)
52087  alphas=pyalps(xmg2)
52088  xmt2=xmt*xmt
52089  xmb2=xmb*xmb
52090  xmr2=xmr*xmr
52091  xmq2=xmg2+xmt2+xmb2+xmr2
52092  xmq4=xmg*xmt*xmb*xmr
52093  xmq3=xmg2*xmr2+xmt2*xmb2
52094  xmgbtr=(xmg2+xmb2)*(xmt2+xmr2)
52095  xmgtbr=(xmg2+xmt2)*(xmb2+xmr2)
52096 
52097  xmst(1)=amst(1)*amst(1)
52098  xmst(2)=amst(1)*amst(1)
52099  xmst(3)=amst(2)*amst(2)
52100  xmst(4)=amst(2)*amst(2)
52101  xmsb(1)=amsb(1)*amsb(1)
52102  xmsb(2)=amsb(2)*amsb(2)
52103  xmsb(3)=amsb(1)*amsb(1)
52104  xmsb(4)=amsb(2)*amsb(2)
52105 
52106  a(1,1)=-cosa*sinc*ccc(i)*aaa(i)-sina*cosc*eee(i)*xx1(i)
52107  a(1,2)=xmg*xmb*(cosa*cosc*ccc(i)*aaa(i)+sina*sinc*eee(i)*xx1(i))
52108  a(1,3)=-xmg*xmr*(cosa*cosc*ccc(i)*xx1(i)+sina*sinc*eee(i)*aaa(i))
52109  a(1,4)=xmb*xmr*(cosa*sinc*ccc(i)*xx1(i)+sina*cosc*eee(i)*aaa(i))
52110  a(1,5)=xmg*xmt*(cosa*cosc*eee(i)*xx1(i)+sina*sinc*ccc(i)*aaa(i))
52111  a(1,6)=-xmt*xmb*(cosa*sinc*eee(i)*xx1(i)+sina*cosc*ccc(i)*aaa(i))
52112  a(1,7)=xmt*xmr*(cosa*sinc*eee(i)*aaa(i)+sina*cosc*ccc(i)*xx1(i))
52113  a(1,8)=-xmq4*(cosa*cosc*eee(i)*aaa(i)+sina*sinc*ccc(i)*xx1(i))
52114 
52115  a(2,1)=-cosa*cosc*ddd(i)*aaa(i)-sina*sinc*fff(i)*xx1(i)
52116  a(2,2)=-xmg*xmb*(cosa*sinc*ddd(i)*aaa(i)+sina*cosc*fff(i)*xx1(i))
52117  a(2,3)=xmg*xmr*(cosa*sinc*ddd(i)*xx1(i)+sina*cosc*fff(i)*aaa(i))
52118  a(2,4)=xmb*xmr*(cosa*cosc*ddd(i)*xx1(i)+sina*sinc*fff(i)*aaa(i))
52119  a(2,5)=xmg*xmt*(cosa*sinc*fff(i)*xx1(i)+sina*cosc*ddd(i)*aaa(i))
52120  a(2,6)=xmt*xmb*(cosa*cosc*fff(i)*xx1(i)+sina*sinc*ddd(i)*aaa(i))
52121  a(2,7)=-xmt*xmr*(cosa*cosc*fff(i)*aaa(i)+sina*sinc*ddd(i)*xx1(i))
52122  a(2,8)=-xmq4*(cosa*sinc*fff(i)*aaa(i)+sina*cosc*ddd(i)*xx1(i))
52123 
52124  a(3,1)=-cosa*cosc*eee(i)*xx2(i)-sina*sinc*ccc(i)*bbb(i)
52125  a(3,2)=xmg*xmb*(cosa*sinc*eee(i)*xx2(i)+sina*cosc*ccc(i)*bbb(i))
52126  a(3,3)=xmg*xmr*(cosa*sinc*eee(i)*bbb(i)+sina*cosc*ccc(i)*xx2(i))
52127  a(3,4)=-xmb*xmr*(cosa*cosc*eee(i)*bbb(i)+sina*sinc*ccc(i)*xx2(i))
52128  a(3,5)=-xmg*xmt*(cosa*sinc*ccc(i)*bbb(i)+sina*cosc*eee(i)*xx2(i))
52129  a(3,6)=xmt*xmb*(cosa*cosc*ccc(i)*bbb(i)+sina*sinc*eee(i)*xx2(i))
52130  a(3,7)=xmt*xmr*(cosa*cosc*ccc(i)*xx2(i)+sina*sinc*eee(i)*bbb(i))
52131  a(3,8)=-xmq4*(cosa*sinc*ccc(i)*xx2(i)+sina*cosc*eee(i)*bbb(i))
52132 
52133  a(4,1)=-cosa*sinc*fff(i)*xx2(i)-sina*cosc*ddd(i)*bbb(i)
52134  a(4,2)=-xmg*xmb*(cosa*cosc*fff(i)*xx2(i)+sina*sinc*ddd(i)*bbb(i))
52135  a(4,3)=-xmg*xmr*(cosa*cosc*fff(i)*bbb(i)+sina*sinc*ddd(i)*xx2(i))
52136  a(4,4)=-xmb*xmr*(cosa*sinc*fff(i)*bbb(i)+sina*cosc*ddd(i)*xx2(i))
52137  a(4,5)=-xmg*xmt*(cosa*cosc*ddd(i)*bbb(i)+sina*sinc*fff(i)*xx2(i))
52138  a(4,6)=-xmt*xmb*(cosa*sinc*ddd(i)*bbb(i)+sina*cosc*fff(i)*xx2(i))
52139  a(4,7)=-xmt*xmr*(cosa*sinc*ddd(i)*xx2(i)+sina*cosc*fff(i)*bbb(i))
52140  a(4,8)=-xmq4*(cosa*cosc*ddd(i)*xx2(i)+sina*sinc*fff(i)*bbb(i))
52141 
52142  smax=(xmg-abs(xmr))**2
52143  smin=(xmb+xmt)**2+0.1d0
52144 
52145  DO 120 lin=0,nn-1
52146  sbar=smin+dble(lin)*(smax-smin)/dble(nn)
52147  am=(xmg2-xmr2)*(xmt2-xmb2)/2d0/sbar
52148  grs=sbar-xmq2
52149  w=pylamf(sbar,xmb2,xmt2)*pylamf(sbar,xmg2,xmr2)
52150  w=dsqrt(w)/2d0/sbar
52151  ant1=log(abs((grs/2d0+am+xmst(1)-w)/(grs/2d0+am+xmst(1)+w)))
52152  ant2=log(abs((grs/2d0+am+xmst(3)-w)/(grs/2d0+am+xmst(3)+w)))
52153  anb1=log(abs((grs/2d0-am+xmsb(1)-w)/(grs/2d0-am+xmsb(1)+w)))
52154  anb2=log(abs((grs/2d0-am+xmsb(2)-w)/(grs/2d0-am+xmsb(2)+w)))
52155  summe(lin)=-ulr(1)*w+(ulr(1)*(xmq2/2d0-xmst(1)-xmg*xmt*sin2a)
52156  & +2d0*xx1(i)*aaa(i)*xmr*xmb)*ant1
52157  & +(ulr(1)/2d0*(xmst(1)*(xmq2-xmst(1))-xmgtbr
52158  & -2d0*xmg*xmt*sin2a*(xmst(1)-xmb2-xmr2))
52159  & +2d0*xx1(i)*aaa(i)*xmr*xmb*(xmst(1)-xmg2-xmt2)
52160  & +4d0*sin2a*xx1(i)*aaa(i)*xmq4)
52161  & *(1d0/(grs/2d0+am+xmst(1)-w)-1d0/(grs/2d0+am+xmst(1)+w))
52162  summe(lin)=summe(lin)-ulr(2)*w
52163  & +(ulr(2)*(xmq2/2d0-xmst(3)+xmg*xmt*sin2a)
52164  & -2d0*xx2(i)*bbb(i)*xmr*xmb)*ant2
52165  & +(ulr(2)/2d0*(xmst(3)*(xmq2-xmst(3))-xmgtbr
52166  & +2d0*xmg*xmt*sin2a*(xmst(3)-xmb2-xmr2))
52167  & -2d0*xx2(i)*bbb(i)*xmr*xmb*(xmst(3)-xmg2-xmt2)
52168  & +4d0*sin2a*xx2(i)*bbb(i)*xmq4)
52169  & *(1d0/(grs/2d0+am+xmst(3)-w)-1d0/(grs/2d0+am+xmst(3)+w))
52170  summe(lin)=summe(lin)-vlr(1)*w
52171  & +(vlr(1)*(xmq2/2d0-xmsb(1)-xmg*xmb*sin2c)
52172  & +2d0*ccc(i)*eee(i)*xmr*xmt)*anb1
52173  & +(vlr(1)/2d0*(xmsb(1)*(xmq2-xmsb(1))-xmgbtr
52174  & -2d0*xmg*xmb*sin2c*(xmsb(1)-xmt2-xmr2))
52175  & +2d0*ccc(i)*eee(i)*xmr*xmt*(xmsb(1)-xmg2-xmb2)
52176  & +4d0*sin2c*ccc(i)*eee(i)*xmq4)
52177  & *(1d0/(grs/2d0-am+xmsb(1)-w)-1d0/(grs/2d0-am+xmsb(1)+w))
52178  summe(lin)=summe(lin)-vlr(2)*w
52179  & +(vlr(2)*(xmq2/2d0-xmsb(2)+xmg*xmb*sin2c)
52180  & -2d0*ddd(i)*fff(i)*xmr*xmt)*anb2
52181  & +(vlr(2)/2d0*(xmsb(2)*(xmq2-xmsb(2))-xmgbtr
52182  & +2d0*xmg*xmb*sin2c*(xmsb(2)-xmt2-xmr2))
52183  & -2d0*ddd(i)*fff(i)*xmr*xmt*(xmsb(2)-xmg2-xmb2)
52184  & +4d0*sin2c*ddd(i)*fff(i)*xmq4)
52185  & *(1d0/(grs/2d0-am+xmsb(2)-w)-1d0/(grs/2d0-am+xmsb(2)+w))
52186  summe(lin)=summe(lin)+2d0*xmg*xmt*cos2a/(xmst(3)-xmst(1))
52187  & *((aaa(i)*bbb(i)-xx1(i)*xx2(i))
52188  & *((xmst(3)-xmb2-xmr2)*ant2-(xmst(1)-xmb2-xmr2)*ant1)
52189  & +2d0*(aaa(i)*xx2(i)-xx1(i)*bbb(i))*xmb*xmr*(ant2-ant1))
52190  summe(lin)=summe(lin)+2d0*xmg*xmb*cos2c/(xmsb(2)-xmsb(1))
52191  & *((eee(i)*fff(i)-ccc(i)*ddd(i))
52192  & *((xmsb(2)-xmt2-xmr2)*anb2-(xmsb(1)-xmt2-xmr2)*anb1)
52193  & +2d0*(eee(i)*ddd(i)-ccc(i)*fff(i))*xmt*xmr*(anb2-anb1))
52194  DO 110 j=1,4
52195  summe(lin)=summe(lin)-2d0*a(j,1)*w
52196  & +((-a(j,1)*(xmsb(j)*(grs+xmsb(j))+xmq3)
52197  & +a(j,2)*(xmsb(j)-xmt2-xmr2)+a(j,3)*(sbar-xmb2-xmt2)
52198  & +a(j,4)*(xmsb(j)+sbar-xmb2-xmr2)
52199  & -a(j,5)*(xmsb(j)+sbar-xmg2-xmt2)+a(j,6)*(xmg2+xmr2-sbar)
52200  & -a(j,7)*(xmsb(j)-xmg2-xmb2)+2d0*a(j,8))
52201  & *log(abs((grs/2d0+xmsb(j)-am-w)/(grs/2d0+xmsb(j)-am+w)))
52202  & -(a(j,1)*(xmst(j)*(grs+xmst(j))+xmq3)
52203  & +a(j,2)*(xmst(j)+sbar-xmg2-xmb2)-a(j,3)*(sbar-xmb2-xmt2)
52204  & +a(j,4)*(xmst(j)-xmg2-xmt2)-a(j,5)*(xmst(j)-xmr2-xmb2)
52205  & -a(j,6)*(xmg2+xmr2-sbar)
52206  & -a(j,7)*(xmst(j)+sbar-xmt2-xmr2)-2d0*a(j,8))
52207  & *log(abs((grs/2d0+xmst(j)+am-w)/(grs/2d0+xmst(j)+am+w))))
52208  & /(grs+xmsb(j)+xmst(j))
52209  110 CONTINUE
52210  120 CONTINUE
52211  summe(nn)=0d0
52212  gam= alphaw * alphas * pysimp(summe,smin,smax,nn)
52213  &/ (16d0 * paru(1) * paru(102) * xmglu**3)
52214 
52215  RETURN
52216  END
52217 
52218 C*********************************************************************
52219 
52220 C...PYNJDC
52221 C...Calculates decay widths for the neutralinos (admixtures of
52222 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
52223 
52224 C...Input: KCIN = KF code for particle
52225 C...Output: XLAM = widths
52226 C... IDLAM = KF codes for decay particles
52227 C... IKNT = number of decay channels defined
52228 C...AUTHOR: STEPHEN MRENNA
52229 C...Last change:
52230 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
52231 C...when CHIGAMMA .NE. 0
52232 C...10 FEB 96: Calculate this decay for small tan(beta)
52233 
52234  SUBROUTINE pynjdc(KFIN,XLAM,IDLAM,IKNT)
52235 
52236 C...Double precision and integer declarations.
52237  IMPLICIT DOUBLE PRECISION(a-h, o-z)
52238  IMPLICIT INTEGER(i-n)
52239  INTEGER pyk,pychge,pycomp
52240 C...Parameter statement to help give large particle numbers.
52241  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
52242  &kexcit=4000000,kdimen=5000000)
52243 C...Commonblocks.
52244  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
52245  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
52246  common/pymssm/imss(0:99),rmss(0:99)
52247 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52248 c &SFMIX(16,4)
52249  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
52250  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
52251 C COMMON/PYINTS/XXM(20)
52252  COMPLEX*16 cxc
52253  common/pyintc/xxc(10),cxc(8)
52254  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyintc/
52255 
52256 C...Local variables.
52257  COMPLEX*16 zmixc(4,4),vmixc(2,2),umixc(2,2),olpp,orpp,glij,grij
52258  COMPLEX*16 qij,rij,f21k,f12k,cal,car,cbl,cbr,ca,cb
52259  INTEGER kfin
52260  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,
52261  &xmz,xmz2,axmj,axmi
52262  DOUBLE PRECISION s12min,s12max
52263  DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xma2,xmb2
52264  DOUBLE PRECISION pylamf,xl
52265  DOUBLE PRECISION tanw,xw,aem,c1,as,ei,t3i
52266  DOUBLE PRECISION pyx2xh,pyx2xg
52267  DOUBLE PRECISION xlam(0:400)
52268  INTEGER idlam(400,3)
52269  INTEGER lknt,ix,ih,j,ij,i,iknt,fid
52270  INTEGER ith(3),kf1,kf2
52271  INTEGER ithc
52272  DOUBLE PRECISION dh(3),eh(3)
52273  DOUBLE PRECISION sr2
52274  DOUBLE PRECISION cbeta,sbeta
52275  DOUBLE PRECISION gamcon,xmt1,xmt2
52276  DOUBLE PRECISION pyalem,pi,pyalps
52277  DOUBLE PRECISION rat1,rat2
52278  DOUBLE PRECISION t3t,fcol
52279  DOUBLE PRECISION alfa,beta,tanb
52280  DOUBLE PRECISION pyxxga
52281  EXTERNAL pygaus,pyxxz6
52282  DOUBLE PRECISION pygaus,pyxxz6
52283  DOUBLE PRECISION prec
52284  INTEGER kfnchi(4),kfcchi(2)
52285  DATA ith/25,35,36/
52286  DATA ithc/37/
52287  DATA prec/1d-2/
52288  DATA pi/3.141592654d0/
52289  DATA sr2/1.4142136d0/
52290  DATA kfnchi/1000022,1000023,1000025,1000035/
52291  DATA kfcchi/1000024,1000037/
52292 
52293 C...COUNT THE NUMBER OF DECAY MODES
52294  lknt=0
52295 
52296  xmw=pmas(24,1)
52297  xmw2=xmw**2
52298  xmz=pmas(23,1)
52299  xmz2=xmz**2
52300  xw=1d0-xmw2/xmz2
52301  xw1=1d0-xw
52302  tanw = sqrt(xw/xw1)
52303 
52304 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
52305  ix=1
52306  IF(kfin.EQ.kfnchi(2)) ix=2
52307  IF(kfin.EQ.kfnchi(3)) ix=3
52308  IF(kfin.EQ.kfnchi(4)) ix=4
52309 
52310  xmi=smz(ix)
52311  xmi2=xmi**2
52312  axmi=abs(xmi)
52313  aem=pyalem(xmi2)
52314  as =pyalps(xmi2)
52315  c1=aem/xw
52316  xmi3=abs(xmi**3)
52317 
52318  tanb=rmss(5)
52319  beta=atan(tanb)
52320  alfa=rmss(18)
52321  cbeta=cos(beta)
52322  sbeta=tanb*cbeta
52323  calfa=cos(alfa)
52324  salfa=sin(alfa)
52325 
52326  DO 110 i=1,4
52327  DO 100 j=1,4
52328  zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
52329  100 CONTINUE
52330  110 CONTINUE
52331  DO 130 i=1,2
52332  DO 120 j=1,2
52333  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
52334  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
52335  120 CONTINUE
52336  130 CONTINUE
52337 
52338 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52339  IF(ix.EQ.1.AND.imss(11).EQ.0) goto 300
52340 
52341 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
52342  IF(ix.EQ.2 .AND. imss(10).NE.0 ) THEN
52343  xmj=smz(1)
52344  axmj=abs(xmj)
52345  lknt=lknt+1
52346  gamcon=aem**3/8d0/pi/xmw2/xw
52347  xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
52348  xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
52349  xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
52350  idlam(lknt,1)=ksusy1+22
52351  idlam(lknt,2)=22
52352  idlam(lknt,3)=0
52353  WRITE(mstu(11),*) 'FORCED N2 -> N1 + GAMMA ',xlam(lknt)
52354  goto 340
52355  ENDIF
52356 
52357 C...GRAVITINO DECAY MODES
52358 
52359  IF(imss(11).EQ.1) THEN
52360  xmp=rmss(29)
52361  idg=39+ksusy1
52362  xmgr=pmas(pycomp(idg),1)
52363  sinw=sqrt(xw)
52364  cosw=sqrt(1d0-xw)
52365  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
52366  IF(axmi.GT.xmgr+pmas(22,1)) THEN
52367  lknt=lknt+1
52368  idlam(lknt,1)=idg
52369  idlam(lknt,2)=22
52370  idlam(lknt,3)=0
52371  xlam(lknt)=xfac*abs(zmixc(ix,1)*cosw+zmixc(ix,2)*sinw)**2
52372  ENDIF
52373  IF(axmi.GT.xmgr+xmz) THEN
52374  lknt=lknt+1
52375  idlam(lknt,1)=idg
52376  idlam(lknt,2)=23
52377  idlam(lknt,3)=0
52378  xlam(lknt)=xfac*(abs(zmixc(ix,1)*sinw-zmixc(ix,2)*cosw)**2 +
52379  $ .5d0*abs(zmixc(ix,3)*cbeta-zmixc(ix,4)*sbeta)**2)*
52380  & (1d0-xmz2/xmi2)**4
52381  ENDIF
52382  IF(axmi.GT.xmgr+pmas(25,1)) THEN
52383  lknt=lknt+1
52384  idlam(lknt,1)=idg
52385  idlam(lknt,2)=25
52386  idlam(lknt,3)=0
52387  xlam(lknt)=xfac*(abs(zmixc(ix,3)*salfa-zmixc(ix,4)*calfa)**2)*
52388  $ .5d0*(1d0-pmas(25,1)**2/xmi2)**4
52389  ENDIF
52390  IF(axmi.GT.xmgr+pmas(35,1)) THEN
52391  lknt=lknt+1
52392  idlam(lknt,1)=idg
52393  idlam(lknt,2)=35
52394  idlam(lknt,3)=0
52395  xlam(lknt)=xfac*(abs(zmixc(ix,3)*calfa+zmixc(ix,4)*salfa)**2)*
52396  $ .5d0*(1d0-pmas(35,1)**2/xmi2)**4
52397  ENDIF
52398  IF(axmi.GT.xmgr+pmas(36,1)) THEN
52399  lknt=lknt+1
52400  idlam(lknt,1)=idg
52401  idlam(lknt,2)=36
52402  idlam(lknt,3)=0
52403  xlam(lknt)=xfac*(abs(zmixc(ix,3)*sbeta+zmixc(ix,4)*cbeta)**2)*
52404  $ .5d0*(1d0-pmas(36,1)**2/xmi2)**4
52405  ENDIF
52406  IF(ix.EQ.1) goto 300
52407  ENDIF
52408 
52409  DO 220 ij=1,ix-1
52410  xmj=smz(ij)
52411  axmj=abs(xmj)
52412  xmj2=xmj**2
52413 
52414 C...CHI0_I -> CHI0_J + GAMMA
52415  IF(axmi.GE.axmj.AND.sbeta/cbeta.LE.2d0) THEN
52416  rat1=abs(zmixc(ij,1))**2+abs(zmixc(ij,2))**2
52417  rat1=rat1/( 1d-6+abs(zmixc(ix,3))**2+abs(zmixc(ix,4))**2 )
52418  rat2=abs(zmixc(ix,1))**2+abs(zmixc(ix,2))**2
52419  rat2=rat2/( 1d-6+abs(zmixc(ij,3))**2+abs(zmixc(ij,4))**2 )
52420  IF((rat1.GT. 0.90d0 .AND. rat1.LT. 1.10d0) .OR.
52421  & (rat2.GT. 0.90d0 .AND. rat2.LT. 1.10d0)) THEN
52422  lknt=lknt+1
52423  idlam(lknt,1)=kfnchi(ij)
52424  idlam(lknt,2)=22
52425  idlam(lknt,3)=0
52426  gamcon=aem**3/8d0/pi/xmw2/xw
52427  xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
52428  xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
52429  xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
52430  ENDIF
52431  ENDIF
52432 
52433 C...CHI0_I -> CHI0_J + Z0
52434  IF(axmi.GE.axmj+xmz) THEN
52435  lknt=lknt+1
52436  olpp=(zmixc(ix,3)*dconjg(zmixc(ij,3))-
52437  & zmixc(ix,4)*dconjg(zmixc(ij,4)))/2d0
52438  orpp=-dconjg(olpp)
52439  gx2=abs(olpp)**2+abs(orpp)**2
52440  glr=dble(olpp*dconjg(orpp))
52441  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gx2,glr)
52442  idlam(lknt,1)=kfnchi(ij)
52443  idlam(lknt,2)=23
52444  idlam(lknt,3)=0
52445  ELSEIF(axmi.GE.axmj) THEN
52446  xxc(1)=0d0
52447  xxc(2)=xmj
52448  xxc(3)=0d0
52449  xxc(4)=xmi
52450  xxc(9)=xmz
52451  xxc(10)=pmas(23,2)
52452  olpp=(zmixc(ix,3)*dconjg(zmixc(ij,3))-
52453  & zmixc(ix,4)*dconjg(zmixc(ij,4)))/2d0
52454  orpp=dconjg(olpp)
52455 C...CHARGED LEPTONS
52456  fid=11
52457  xxc(5)=pmas(pycomp(ksusy1+fid),1)
52458  xxc(6)=pmas(pycomp(ksusy2+fid),1)
52459  ei=kchg(fid,1)/3d0
52460  t3i=sign(1d0,ei+1d-6)/2d0
52461  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
52462  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
52463  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
52464  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
52465  cxc(2)=-glij
52466  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
52467  cxc(4)=dconjg(glij)
52468  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
52469  cxc(6)=grij
52470  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
52471  cxc(8)=-dconjg(grij)
52472  s12min=0d0
52473  s12max=(axmi-axmj)**2
52474  IF( xxc(5).LT.axmi ) THEN
52475  xxc(5)=1d6
52476  ENDIF
52477  IF(xxc(6).LT.axmi ) THEN
52478  xxc(6)=1d6
52479  ENDIF
52480  xxc(7)=xxc(5)
52481  xxc(8)=xxc(6)
52482 
52483  IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
52484  lknt=lknt+1
52485  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52486  & pygaus(pyxxz6,s12min,s12max,1d-3)
52487  idlam(lknt,1)=kfnchi(ij)
52488  idlam(lknt,2)=fid
52489  idlam(lknt,3)=-fid
52490  IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
52491  lknt=lknt+1
52492  xlam(lknt)=xlam(lknt-1)
52493  idlam(lknt,1)=kfnchi(ij)
52494  idlam(lknt,2)=13
52495  idlam(lknt,3)=-13
52496  ENDIF
52497  ENDIF
52498  140 CONTINUE
52499  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
52500  xxc(5)=pmas(pycomp(ksusy1+15),1)
52501  xxc(6)=pmas(pycomp(ksusy2+15),1)
52502  ELSE
52503  xxc(6)=pmas(pycomp(ksusy1+15),1)
52504  xxc(5)=pmas(pycomp(ksusy2+15),1)
52505  ENDIF
52506  IF( xxc(5).LT.axmi ) THEN
52507  xxc(5)=1d6
52508  ENDIF
52509  IF(xxc(6).LT.axmi ) THEN
52510  xxc(6)=1d6
52511  ENDIF
52512  xxc(7)=xxc(5)
52513  xxc(8)=xxc(6)
52514 
52515  IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
52516  lknt=lknt+1
52517  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52518  & pygaus(pyxxz6,s12min,s12max,1d-3)
52519  idlam(lknt,1)=kfnchi(ij)
52520  idlam(lknt,2)=15
52521  idlam(lknt,3)=-15
52522  ENDIF
52523 
52524 C...NEUTRINOS
52525  150 CONTINUE
52526  fid=12
52527  xxc(5)=pmas(pycomp(ksusy1+fid),1)
52528  xxc(6)=pmas(pycomp(ksusy2+fid),1)
52529  ei=kchg(fid,1)/3d0
52530  t3i=sign(1d0,ei+1d-6)/2d0
52531  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
52532  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
52533  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
52534  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
52535  cxc(2)=-glij
52536  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
52537  cxc(4)=dconjg(glij)
52538  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
52539  cxc(6)=grij
52540  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
52541  cxc(8)=-dconjg(grij)
52542  s12min=0d0
52543  s12max=(axmi-axmj)**2
52544  IF( xxc(5).LT.axmi ) THEN
52545  xxc(5)=1d6
52546  ENDIF
52547  IF( xxc(6).LT.axmi ) THEN
52548  xxc(6)=1d6
52549  ENDIF
52550  xxc(7)=xxc(5)
52551  xxc(8)=xxc(6)
52552 
52553  lknt=lknt+1
52554  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52555  & pygaus(pyxxz6,s12min,s12max,1d-3)
52556  idlam(lknt,1)=kfnchi(ij)
52557  idlam(lknt,2)=12
52558  idlam(lknt,3)=-12
52559  lknt=lknt+1
52560  xlam(lknt)=xlam(lknt-1)
52561  idlam(lknt,1)=kfnchi(ij)
52562  idlam(lknt,2)=14
52563  idlam(lknt,3)=-14
52564  160 CONTINUE
52565 
52566  IF(pmas(pycomp(ksusy1+16),1).NE.pmas(pycomp(ksusy1+12),1))
52567  & THEN
52568  xxc(5)=pmas(pycomp(ksusy1+16),1)
52569  IF( xxc(5).LT.axmi ) THEN
52570  xxc(5)=1d6
52571  ENDIF
52572  xxc(7)=xxc(5)
52573  lknt=lknt+1
52574  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52575  & pygaus(pyxxz6,s12min,s12max,1d-3)
52576  ELSE
52577  lknt=lknt+1
52578  xlam(lknt)=xlam(lknt-1)
52579  ENDIF
52580  idlam(lknt,1)=kfnchi(ij)
52581  idlam(lknt,2)=16
52582  idlam(lknt,3)=-16
52583 C...D-TYPE QUARKS
52584  170 CONTINUE
52585  fid=1
52586  xxc(5)=pmas(pycomp(ksusy1+fid),1)
52587  xxc(6)=pmas(pycomp(ksusy2+fid),1)
52588  ei=kchg(fid,1)/3d0
52589  t3i=sign(1d0,ei+1d-6)/2d0
52590  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
52591  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
52592  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
52593  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
52594  cxc(2)=-glij
52595  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
52596  cxc(4)=dconjg(glij)
52597  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
52598  cxc(6)=grij
52599  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
52600  cxc(8)=-dconjg(grij)
52601  s12min=0d0
52602  s12max=(axmi-axmj)**2
52603  IF( xxc(5).LT.axmi ) THEN
52604  xxc(5)=1d6
52605  ENDIF
52606  IF( xxc(6).LT.axmi ) THEN
52607  xxc(6)=1d6
52608  ENDIF
52609  xxc(7)=xxc(5)
52610  xxc(8)=xxc(6)
52611 
52612  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
52613  lknt=lknt+1
52614  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52615  & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
52616  idlam(lknt,1)=kfnchi(ij)
52617  idlam(lknt,2)=1
52618  idlam(lknt,3)=-1
52619  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
52620  lknt=lknt+1
52621  xlam(lknt)=xlam(lknt-1)
52622  idlam(lknt,1)=kfnchi(ij)
52623  idlam(lknt,2)=3
52624  idlam(lknt,3)=-3
52625  ENDIF
52626  ENDIF
52627  180 CONTINUE
52628  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
52629  xxc(5)=pmas(pycomp(ksusy1+5),1)
52630  xxc(6)=pmas(pycomp(ksusy2+5),1)
52631  ELSE
52632  xxc(6)=pmas(pycomp(ksusy1+5),1)
52633  xxc(5)=pmas(pycomp(ksusy2+5),1)
52634  ENDIF
52635  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) goto 190
52636  IF(xxc(5).LT.axmi) THEN
52637  xxc(5)=1d6
52638  ELSEIF(xxc(6).LT.axmi) THEN
52639  xxc(6)=1d6
52640  ENDIF
52641  xxc(7)=xxc(5)
52642  xxc(8)=xxc(6)
52643  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
52644  lknt=lknt+1
52645  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52646  & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
52647  idlam(lknt,1)=kfnchi(ij)
52648  idlam(lknt,2)=5
52649  idlam(lknt,3)=-5
52650  ENDIF
52651 
52652 C...U-TYPE QUARKS
52653  190 CONTINUE
52654  fid=2
52655  xxc(5)=pmas(pycomp(ksusy1+fid),1)
52656  xxc(6)=pmas(pycomp(ksusy2+fid),1)
52657  ei=kchg(fid,1)/3d0
52658  t3i=sign(1d0,ei+1d-6)/2d0
52659  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
52660  & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
52661  grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
52662  cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
52663  cxc(2)=-glij
52664  cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
52665  cxc(4)=dconjg(glij)
52666  cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
52667  cxc(6)=grij
52668  cxc(7)=dcmplx((ei*xw)/xw1)*orpp
52669  cxc(8)=-dconjg(grij)
52670 
52671  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) goto 200
52672  IF(xxc(5).LT.axmi) THEN
52673  xxc(5)=1d6
52674  ELSEIF(xxc(6).LT.axmi) THEN
52675  xxc(6)=1d6
52676  ENDIF
52677  xxc(7)=xxc(5)
52678  xxc(8)=xxc(6)
52679 
52680  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
52681  lknt=lknt+1
52682  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52683  & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
52684  idlam(lknt,1)=kfnchi(ij)
52685  idlam(lknt,2)=2
52686  idlam(lknt,3)=-2
52687  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
52688  lknt=lknt+1
52689  xlam(lknt)=xlam(lknt-1)
52690  idlam(lknt,1)=kfnchi(ij)
52691  idlam(lknt,2)=4
52692  idlam(lknt,3)=-4
52693  ENDIF
52694  ENDIF
52695  200 CONTINUE
52696  ENDIF
52697 
52698 C...CHI0_I -> CHI0_J + H0_K
52699  eh(1)=sin(alfa)
52700  eh(2)=cos(alfa)
52701  eh(3)=-sin(beta)
52702  dh(1)=cos(alfa)
52703  dh(2)=-sin(alfa)
52704  dh(3)=cos(beta)
52705  qij=zmixc(ix,3)*dconjg(zmixc(ij,2))+
52706  & dconjg(zmixc(ij,3))*zmixc(ix,2)-
52707  & tanw*(zmixc(ix,3)*dconjg(zmixc(ij,1))+
52708  & dconjg(zmixc(ij,3))*zmixc(ix,1))
52709  rij=dconjg(zmixc(ix,4))*zmixc(ij,2)+
52710  & zmixc(ij,4)*dconjg(zmixc(ix,2))-
52711  & tanw*(dconjg(zmixc(ix,4))*zmixc(ij,1)+
52712  & zmixc(ij,4)*dconjg(zmixc(ix,1)))
52713  DO 210 ih=1,3
52714  xmh=pmas(ith(ih),1)
52715  xmh2=xmh**2
52716  IF(axmi.GE.axmj+xmh) THEN
52717  lknt=lknt+1
52718  xl=pylamf(xmi2,xmj2,xmh2)
52719  f21k=0.5d0*(qij*eh(ih)+rij*dh(ih))
52720  f12k=f21k
52721 C...SIGN OF MASSES I,J
52722  xmk=xmj
52723  IF(ih.EQ.3) xmk=-xmk
52724  gx2=abs(f21k)**2+abs(f12k)**2
52725  glr=dble(f21k*dconjg(f12k))
52726  xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,gx2,glr)
52727  idlam(lknt,1)=kfnchi(ij)
52728  idlam(lknt,2)=ith(ih)
52729  idlam(lknt,3)=0
52730  ENDIF
52731  210 CONTINUE
52732  220 CONTINUE
52733 
52734 C...CHI0_I -> CHI+_J + W-
52735  DO 260 ij=1,2
52736  xmj=smw(ij)
52737  axmj=abs(xmj)
52738  xmj2=xmj**2
52739  IF(axmi.GE.axmj+xmw) THEN
52740  lknt=lknt+1
52741  cxc(1)=(dconjg(zmixc(ix,2))*vmixc(ij,1)-
52742  & dconjg(zmixc(ix,4))*vmixc(ij,2)/sr2)
52743  cxc(3)=(zmixc(ix,2)*dconjg(umixc(ij,1))+
52744  & zmixc(ix,3)*dconjg(umixc(ij,2))/sr2)
52745  gx2=abs(cxc(1))**2+abs(cxc(3))**2
52746  glr=dble(cxc(1)*dconjg(cxc(3)))
52747  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gx2,glr)
52748  idlam(lknt,1)=kfcchi(ij)
52749  idlam(lknt,2)=-24
52750  idlam(lknt,3)=0
52751  lknt=lknt+1
52752  xlam(lknt)=xlam(lknt-1)
52753  idlam(lknt,1)=-kfcchi(ij)
52754  idlam(lknt,2)=24
52755  idlam(lknt,3)=0
52756  ELSEIF(axmi.GE.axmj) THEN
52757  s12min=0d0
52758  s12max=(axmi-axmj)**2
52759  rt2i = 1d0/sqrt(2d0)
52760  cxc(1)=(dconjg(zmixc(ix,2))*vmixc(ij,1)-
52761  & dconjg(zmixc(ix,4))*vmixc(ij,2)*rt2i)*rt2i
52762  cxc(3)=(zmixc(ix,2)*dconjg(umixc(ij,1))+
52763  & zmixc(ix,3)*dconjg(umixc(ij,2))*rt2i)*rt2i
52764  cxc(5)=dcmplx(0d0,0d0)
52765  cxc(7)=dcmplx(0d0,0d0)
52766  ia=11
52767  ja=12
52768  ei=kchg(ia,1)/3d0
52769  t3i=sign(1d0,ei+1d-6)/2d0
52770  ej=kchg(ja,1)/3d0
52771  t3j=sign(1d0,ej+1d-6)/2d0
52772  cxc(2)=vmixc(ij,1)*dconjg(zmixc(ix,1)*(ej-t3j)*
52773  & tanw+zmixc(ix,2)*t3j)*rt2i
52774  cxc(4)=-dconjg(umixc(ij,1))*(
52775  & zmixc(ix,1)*(ei-t3i)*tanw+zmixc(ix,2)*t3i)*rt2i
52776  cxc(6)=dcmplx(0d0,0d0)
52777  cxc(8)=dcmplx(0d0,0d0)
52778  xxc(1)=0d0
52779  xxc(2)=xmj
52780  xxc(3)=0d0
52781  xxc(4)=xmi
52782  xxc(5)=pmas(pycomp(ksusy1+ja),1)
52783  xxc(6)=pmas(pycomp(ksusy1+ia),1)
52784  xxc(9)=pmas(24,1)
52785  xxc(10)=pmas(24,2)
52786  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) goto 230
52787  IF(xxc(5).LT.axmi) THEN
52788  xxc(5)=1d6
52789  ELSEIF(xxc(6).LT.axmi) THEN
52790  xxc(6)=1d6
52791  ENDIF
52792  xxc(7)=xxc(6)
52793  xxc(8)=xxc(5)
52794  IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
52795  lknt=lknt+1
52796  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52797  & pygaus(pyxxz6,s12min,s12max,prec)
52798  idlam(lknt,1)=kfcchi(ij)
52799  idlam(lknt,2)=11
52800  idlam(lknt,3)=-12
52801  lknt=lknt+1
52802  xlam(lknt)=xlam(lknt-1)
52803  idlam(lknt,1)=-idlam(lknt-1,1)
52804  idlam(lknt,2)=-idlam(lknt-1,2)
52805  idlam(lknt,3)=-idlam(lknt-1,3)
52806  IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
52807  lknt=lknt+1
52808  xlam(lknt)=xlam(lknt-1)
52809  idlam(lknt,1)=kfcchi(ij)
52810  idlam(lknt,2)=13
52811  idlam(lknt,3)=-14
52812  lknt=lknt+1
52813  xlam(lknt)=xlam(lknt-1)
52814  idlam(lknt,1)=-idlam(lknt-1,1)
52815  idlam(lknt,2)=-idlam(lknt-1,2)
52816  idlam(lknt,3)=-idlam(lknt-1,3)
52817  ENDIF
52818  ENDIF
52819  230 CONTINUE
52820  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
52821  xxc(5)=pmas(pycomp(ksusy1+15),1)
52822  xxc(6)=pmas(pycomp(ksusy1+16),1)
52823  ELSE
52824  xxc(5)=pmas(pycomp(ksusy2+15),1)
52825  xxc(6)=pmas(pycomp(ksusy1+16),1)
52826  ENDIF
52827  IF(xxc(5).LT.axmi) THEN
52828  xxc(5)=1d6
52829  ENDIF
52830  IF(xxc(6).LT.axmi) THEN
52831  xxc(6)=1d6
52832  ENDIF
52833  xxc(7)=xxc(6)
52834  xxc(8)=xxc(5)
52835  IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
52836  lknt=lknt+1
52837  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52838  & pygaus(pyxxz6,s12min,s12max,prec)
52839  xlam(lknt)=xlam(lknt-1)
52840  idlam(lknt,1)=kfcchi(ij)
52841  idlam(lknt,2)=15
52842  idlam(lknt,3)=-16
52843  lknt=lknt+1
52844  xlam(lknt)=xlam(lknt-1)
52845  idlam(lknt,1)=-idlam(lknt-1,1)
52846  idlam(lknt,2)=-idlam(lknt-1,2)
52847  idlam(lknt,3)=-idlam(lknt-1,3)
52848  ENDIF
52849 
52850 C...NOW, DO THE QUARKS
52851  240 CONTINUE
52852  ia=1
52853  ja=2
52854  ei=kchg(ia,1)/3d0
52855  t3i=sign(1d0,ei+1d-6)/2d0
52856  ej=kchg(ja,1)/3d0
52857  t3j=sign(1d0,ej+1d-6)/2d0
52858  cxc(2)=vmixc(ij,1)*dconjg(zmixc(ix,1)*(ej-t3j)*
52859  & tanw+zmixc(ix,2)*t3j)
52860  cxc(4)=-dconjg(umixc(ij,1))*(
52861  & zmixc(ix,1)*(ei-t3i)*tanw+zmixc(ix,2)*t3i)
52862  xxc(5)=pmas(pycomp(ksusy1+ia),1)
52863  xxc(6)=pmas(pycomp(ksusy1+ja),1)
52864  IF(xxc(5).LT.axmi) THEN
52865  xxc(5)=1d6
52866  ENDIF
52867  IF(xxc(6).LT.axmi) THEN
52868  xxc(6)=1d6
52869  ENDIF
52870  xxc(7)=xxc(6)
52871  xxc(8)=xxc(5)
52872  IF(axmi.GE.axmj+pmas(2,1)+pmas(1,1)) THEN
52873  lknt=lknt+1
52874  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52875  & pygaus(pyxxz6,s12min,s12max,prec)
52876  idlam(lknt,1)=kfcchi(ij)
52877  idlam(lknt,2)=1
52878  idlam(lknt,3)=-2
52879  lknt=lknt+1
52880  xlam(lknt)=xlam(lknt-1)
52881  idlam(lknt,1)=-idlam(lknt-1,1)
52882  idlam(lknt,2)=-idlam(lknt-1,2)
52883  idlam(lknt,3)=-idlam(lknt-1,3)
52884  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
52885  lknt=lknt+1
52886  xlam(lknt)=xlam(lknt-1)
52887  idlam(lknt,1)=kfcchi(ij)
52888  idlam(lknt,2)=3
52889  idlam(lknt,3)=-4
52890  lknt=lknt+1
52891  xlam(lknt)=xlam(lknt-1)
52892  idlam(lknt,1)=-idlam(lknt-1,1)
52893  idlam(lknt,2)=-idlam(lknt-1,2)
52894  idlam(lknt,3)=-idlam(lknt-1,3)
52895  ENDIF
52896  ENDIF
52897  250 CONTINUE
52898  ENDIF
52899  260 CONTINUE
52900  270 CONTINUE
52901 
52902 C...CHI0_I -> CHI+_I + H-
52903  DO 280 ij=1,2
52904  xmj=smw(ij)
52905  axmj=abs(xmj)
52906  xmj2=xmj**2
52907  xmhp=pmas(ithc,1)
52908  IF(axmi.GE.axmj+xmhp) THEN
52909  lknt=lknt+1
52910  olpp=cbeta*(zmixc(ix,4)*dconjg(vmixc(ij,1))+(zmixc(ix,2)+
52911  & zmixc(ix,1)*tanw)*dconjg(vmixc(ij,2))/sr2)
52912  orpp=sbeta*(dconjg(zmixc(ix,3))*umixc(ij,1)-
52913  & (dconjg(zmixc(ix,2))+dconjg(zmixc(ix,1))*tanw)*
52914  & umixc(ij,2)/sr2)
52915  gx2=abs(olpp)**2+abs(orpp)**2
52916  glr=dble(olpp*dconjg(orpp))
52917  xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gx2,glr)
52918  idlam(lknt,1)=kfcchi(ij)
52919  idlam(lknt,2)=-ithc
52920  idlam(lknt,3)=0
52921  lknt=lknt+1
52922  xlam(lknt)=xlam(lknt-1)
52923  idlam(lknt,1)=-idlam(lknt-1,1)
52924  idlam(lknt,2)=-idlam(lknt-1,2)
52925  idlam(lknt,3)=-idlam(lknt-1,3)
52926  ELSE
52927 
52928  ENDIF
52929  280 CONTINUE
52930 
52931 C...2-BODY DECAYS TO FERMION SFERMION
52932  DO 290 j=1,16
52933  IF(j.GE.7.AND.j.LE.10) goto 290
52934  kf1=ksusy1+j
52935  kf2=ksusy2+j
52936  xmsf1=pmas(pycomp(kf1),1)
52937  xmsf2=pmas(pycomp(kf2),1)
52938  xmf=pmas(j,1)
52939  IF(j.LE.6) THEN
52940  fcol=3d0
52941  ELSE
52942  fcol=1d0
52943  ENDIF
52944 
52945  ei=kchg(j,1)/3d0
52946  t3t=sign(1d0,ei)
52947  IF(j.EQ.12.OR.j.EQ.14.OR.j.EQ.16) t3t=1d0
52948  IF(mod(j,2).EQ.0) THEN
52949  cbl=t3t*zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-t3t)
52950  cal=xmf*zmixc(ix,4)/xmw/sbeta
52951  car=-2d0*ei*tanw*zmixc(ix,1)
52952  cbr=cal
52953  ELSE
52954  cbl=t3t*zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-t3t)
52955  cal=xmf*zmixc(ix,3)/xmw/cbeta
52956  car=-2d0*ei*tanw*zmixc(ix,1)
52957  cbr=cal
52958  ENDIF
52959 
52960 C...D~ D_L
52961  IF(axmi.GE.xmf+xmsf1) THEN
52962  lknt=lknt+1
52963  xma2=xmsf1**2
52964  xmb2=xmf**2
52965  xl=pylamf(xmi2,xma2,xmb2)
52966  ca=cal*sfmix(j,1)+car*sfmix(j,2)
52967  cb=cbl*sfmix(j,1)+cbr*sfmix(j,2)
52968  xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52969  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52970  idlam(lknt,1)=kf1
52971  idlam(lknt,2)=-j
52972  idlam(lknt,3)=0
52973  lknt=lknt+1
52974  xlam(lknt)=xlam(lknt-1)
52975  idlam(lknt,1)=-idlam(lknt-1,1)
52976  idlam(lknt,2)=-idlam(lknt-1,2)
52977  idlam(lknt,3)=0
52978  ENDIF
52979 
52980 C...D~ D_R
52981  IF(axmi.GE.xmf+xmsf2) THEN
52982  lknt=lknt+1
52983  xma2=xmsf2**2
52984  xmb2=xmf**2
52985  ca=cal*sfmix(j,3)+car*sfmix(j,4)
52986  cb=cbl*sfmix(j,3)+cbr*sfmix(j,4)
52987  xl=pylamf(xmi2,xma2,xmb2)
52988  xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52989  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52990  idlam(lknt,1)=kf2
52991  idlam(lknt,2)=-j
52992  idlam(lknt,3)=0
52993  lknt=lknt+1
52994  xlam(lknt)=xlam(lknt-1)
52995  idlam(lknt,1)=-idlam(lknt-1,1)
52996  idlam(lknt,2)=-idlam(lknt-1,2)
52997  idlam(lknt,3)=0
52998  ENDIF
52999  290 CONTINUE
53000  300 CONTINUE
53001 C...3-BODY DECAY TO Q Q~ GLUINO
53002  xmj=pmas(pycomp(ksusy1+21),1)
53003  IF(axmi.GE.xmj) THEN
53004  rt2i = 1d0/sqrt(2d0)
53005  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))*rt2i
53006  orpp=dconjg(olpp)
53007  axmj=abs(xmj)
53008  xxc(1)=0d0
53009  xxc(2)=xmj
53010  xxc(3)=0d0
53011  xxc(4)=xmi
53012  fid=1
53013  xxc(5)=pmas(pycomp(ksusy1+fid),1)
53014  xxc(6)=pmas(pycomp(ksusy2+fid),1)
53015  xxc(7)=xxc(5)
53016  xxc(8)=xxc(6)
53017  xxc(9)=1d6
53018  xxc(10)=0d0
53019  ei=kchg(fid,1)/3d0
53020  t3i=sign(1d0,ei+1d-6)/2d0
53021  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
53022  grij=zmixc(ix,1)*(ei*tanw)*orpp
53023  cxc(1)=0d0
53024  cxc(2)=-glij
53025  cxc(3)=0d0
53026  cxc(4)=dconjg(glij)
53027  cxc(5)=0d0
53028  cxc(6)=grij
53029  cxc(7)=0d0
53030  cxc(8)=-dconjg(grij)
53031  s12min=0d0
53032  s12max=(axmi-axmj)**2
53033 CMRENNA.This statement must be here to define S12MAX
53034  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) goto 310
53035 C...ALL QUARKS BUT T
53036  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
53037  lknt=lknt+1
53038  xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
53039  & pygaus(pyxxz6,s12min,s12max,1d-3)
53040  idlam(lknt,1)=ksusy1+21
53041  idlam(lknt,2)=1
53042  idlam(lknt,3)=-1
53043  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
53044  lknt=lknt+1
53045  xlam(lknt)=xlam(lknt-1)
53046  idlam(lknt,1)=ksusy1+21
53047  idlam(lknt,2)=3
53048  idlam(lknt,3)=-3
53049  ENDIF
53050  ENDIF
53051  310 CONTINUE
53052  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
53053  xxc(5)=pmas(pycomp(ksusy1+5),1)
53054  xxc(6)=pmas(pycomp(ksusy2+5),1)
53055  ELSE
53056  xxc(6)=pmas(pycomp(ksusy1+5),1)
53057  xxc(5)=pmas(pycomp(ksusy2+5),1)
53058  ENDIF
53059  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) goto 320
53060  xxc(7)=xxc(5)
53061  xxc(8)=xxc(6)
53062  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
53063  lknt=lknt+1
53064  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
53065  & pygaus(pyxxz6,s12min,s12max,1d-3)
53066  idlam(lknt,1)=ksusy1+21
53067  idlam(lknt,2)=5
53068  idlam(lknt,3)=-5
53069  ENDIF
53070 C...U-TYPE QUARKS
53071  320 CONTINUE
53072  fid=2
53073  xxc(5)=pmas(pycomp(ksusy1+fid),1)
53074  xxc(6)=pmas(pycomp(ksusy2+fid),1)
53075  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) goto 330
53076  xxc(7)=xxc(5)
53077  xxc(8)=xxc(6)
53078  ei=kchg(fid,1)/3d0
53079  t3i=sign(1d0,ei+1d-6)/2d0
53080  glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
53081  grij=zmixc(ix,1)*(ei*tanw)*orpp
53082  cxc(2)=-glij
53083  cxc(4)=dconjg(glij)
53084  cxc(6)=grij
53085  cxc(8)=-dconjg(grij)
53086  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
53087  lknt=lknt+1
53088  xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
53089  & pygaus(pyxxz6,s12min,s12max,1d-3)
53090  idlam(lknt,1)=ksusy1+21
53091  idlam(lknt,2)=2
53092  idlam(lknt,3)=-2
53093  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
53094  lknt=lknt+1
53095  xlam(lknt)=xlam(lknt-1)
53096  idlam(lknt,1)=ksusy1+21
53097  idlam(lknt,2)=4
53098  idlam(lknt,3)=-4
53099  ENDIF
53100  ENDIF
53101  330 CONTINUE
53102  ENDIF
53103 
53104 C...R-violating decay modes (SKANDS).
53105  CALL pyrvne(kfin,xlam,idlam,lknt)
53106 
53107  340 iknt=lknt
53108  xlam(0)=0d0
53109  DO 350 i=1,iknt
53110  IF(xlam(i).LT.0d0) xlam(i)=0d0
53111  xlam(0)=xlam(0)+xlam(i)
53112  350 CONTINUE
53113  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
53114 
53115  RETURN
53116  END
53117 
53118 C*********************************************************************
53119 
53120 C...PYCJDC
53121 C...Calculate decay widths for the charginos (admixtures of
53122 C...charged Wino and charged Higgsino.
53123 
53124 C...Input: KCIN = KF code for particle
53125 C...Output: XLAM = widths
53126 C... IDLAM = KF codes for decay particles
53127 C... IKNT = number of decay channels defined
53128 C...AUTHOR: STEPHEN MRENNA
53129 C...Last change:
53130 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
53131 C...when CHIENU .NE. 0
53132 
53133  SUBROUTINE pycjdc(KFIN,XLAM,IDLAM,IKNT)
53134 
53135 C...Double precision and integer declarations.
53136  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53137  IMPLICIT INTEGER(i-n)
53138  INTEGER pyk,pychge,pycomp
53139 C...Parameter statement to help give large particle numbers.
53140  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
53141  &kexcit=4000000,kdimen=5000000)
53142 C...Commonblocks.
53143  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53144  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
53145  common/pymssm/imss(0:99),rmss(0:99)
53146  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
53147  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
53148 CC &SFMIX(16,4),
53149 C COMMON/PYINTS/XXM(20)
53150  COMPLEX*16 cxc
53151  common/pyintc/xxc(10),cxc(8)
53152  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyintc/
53153 
53154 C...Local variables
53155  COMPLEX*16 zmixc(4,4),vmixc(2,2),umixc(2,2),olpp,orpp
53156  COMPLEX*16 cal,cbl,car,cbr,ca,cb
53157  INTEGER kfin,kcin
53158  DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,
53159  &xmz,xmz2,axmj,axmi
53160  DOUBLE PRECISION s12min,s12max
53161  DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xma2,xmb2,xmk
53162  DOUBLE PRECISION pylamf,xl
53163  DOUBLE PRECISION tanw,xw,aem,c1,as,ei,t3i,beta,alfa
53164  DOUBLE PRECISION pyx2xh,pyx2xg
53165  DOUBLE PRECISION xlam(0:400)
53166  INTEGER idlam(400,3)
53167  INTEGER lknt,ix,ih,j,ij,i,iknt
53168  INTEGER ith(3)
53169  INTEGER ithc
53170  DOUBLE PRECISION etah(3),dh(3),eh(3)
53171  DOUBLE PRECISION sr2
53172  DOUBLE PRECISION cbeta,sbeta,tanb
53173 
53174  DOUBLE PRECISION pyalem,pi,pyalps
53175  DOUBLE PRECISION fcol
53176  INTEGER kf1,kf2,isf
53177  INTEGER kfnchi(4),kfcchi(2)
53178 
53179  DOUBLE PRECISION temp
53180  EXTERNAL pygaus,pyxxz6
53181  DOUBLE PRECISION pygaus,pyxxz6
53182  DOUBLE PRECISION prec
53183  DATA ith/25,35,36/
53184  DATA ithc/37/
53185  DATA etah/1d0,1d0,-1d0/
53186  DATA sr2/1.4142136d0/
53187  DATA pi/3.141592654d0/
53188  DATA prec/1d-2/
53189  DATA kfnchi/1000022,1000023,1000025,1000035/
53190  DATA kfcchi/1000024,1000037/
53191 
53192 C...COUNT THE NUMBER OF DECAY MODES
53193  lknt=0
53194  xmw=pmas(24,1)
53195  xmw2=xmw**2
53196  xmz=pmas(23,1)
53197  xmz2=xmz**2
53198  xw=1d0-xmw2/xmz2
53199  xw1=1d0-xw
53200  tanw = sqrt(xw/xw1)
53201 
53202 C...1 OR 2 DEPENDING ON CHARGINO TYPE
53203  ix=1
53204  IF(kfin.EQ.kfcchi(2)) ix=2
53205  kcin=pycomp(kfin)
53206 
53207  xmi=smw(ix)
53208  xmi2=xmi**2
53209  axmi=abs(xmi)
53210  aem=pyalem(xmi2)
53211  as =pyalps(xmi2)
53212  c1=aem/xw
53213  xmi3=abs(xmi**3)
53214  tanb=rmss(5)
53215  beta=atan(tanb)
53216  cbeta=cos(beta)
53217  sbeta=tanb*cbeta
53218  alfa=rmss(18)
53219 
53220  DO 110 i=1,2
53221  DO 100 j=1,2
53222  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
53223  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
53224  100 CONTINUE
53225  110 CONTINUE
53226 
53227 C...GRAVITINO DECAY MODES
53228 
53229  IF(imss(11).EQ.1) THEN
53230  xmp=rmss(29)
53231  idg=39+ksusy1
53232  xmgr=pmas(pycomp(idg),1)
53233 C SINW=SQRT(XW)
53234 C COSW=SQRT(1D0-XW)
53235  xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
53236  IF(axmi.GT.xmgr+xmw) THEN
53237  lknt=lknt+1
53238  idlam(lknt,1)=idg
53239  idlam(lknt,2)=24
53240  idlam(lknt,3)=0
53241  xlam(lknt)=xfac*(
53242  & .5d0*(abs(vmixc(ix,1))**2+abs(umixc(ix,1))**2)+
53243  & .5d0*((abs(vmixc(ix,2))*sbeta)**2+(abs(umixc(ix,2))*cbeta)**2))*
53244  & (1d0-xmw2/xmi2)**4
53245  ENDIF
53246  IF(axmi.GT.xmgr+pmas(37,1)) THEN
53247  lknt=lknt+1
53248  idlam(lknt,1)=idg
53249  idlam(lknt,2)=37
53250  idlam(lknt,3)=0
53251  xlam(lknt)=xfac*(.5d0*((abs(vmixc(ix,2))*cbeta)**2+
53252  & (abs(umixc(ix,2))*sbeta)**2))
53253  & *(1d0-pmas(37,1)**2/xmi2)**4
53254  ENDIF
53255  ENDIF
53256 
53257 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53258  IF(ix.EQ.1) goto 170
53259  xmj=smw(1)
53260  axmj=abs(xmj)
53261  xmj2=xmj**2
53262 
53263 C...CHI_2+ -> CHI_1+ + Z0
53264  IF(axmi.GE.axmj+xmz) THEN
53265  lknt=lknt+1
53266  ij=1
53267  olpp=-vmixc(ij,1)*dconjg(vmixc(ix,1))-
53268  & vmixc(ij,2)*dconjg(vmixc(ix,2))/2d0
53269  orpp=-umixc(ix,1)*dconjg(umixc(ij,1))-
53270  & umixc(ix,2)*dconjg(umixc(ij,2))/2d0
53271  gx2=abs(olpp)**2+abs(orpp)**2
53272  glr=dble(olpp*dconjg(orpp))
53273  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gx2,glr)
53274  idlam(lknt,1)=kfcchi(1)
53275  idlam(lknt,2)=23
53276  idlam(lknt,3)=0
53277 
53278 C...CHARGED LEPTONS
53279  ELSEIF(axmi.GE.axmj) THEN
53280  s12min=0d0
53281  s12max=(axmi-axmj)**2
53282  ia=11
53283  ja=12
53284  ei=kchg(iabs(ia),1)/3d0
53285  t3i=sign(1d0,ei+1d-6)/2d0
53286  xxc(1)=0d0
53287  xxc(2)=xmj
53288  xxc(3)=0d0
53289  xxc(4)=xmi
53290  xxc(5)=pmas(pycomp(ksusy1+ja),1)
53291  xxc(6)=1d6
53292  xxc(9)=pmas(23,1)
53293  xxc(10)=pmas(23,2)
53294  ij=1
53295  olpp=-vmixc(ij,1)*dconjg(vmixc(ix,1))-
53296  & vmixc(ij,2)*dconjg(vmixc(ix,2))/2d0
53297  orpp=-umixc(ix,1)*dconjg(umixc(ij,1))-
53298  & umixc(ix,2)*dconjg(umixc(ij,2))/2d0
53299  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
53300  cxc(2)=dcmplx(0d0,0d0)
53301  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
53302  cxc(4)=-vmixc(ij,1)*dconjg(vmixc(ix,1))*dcmplx(t3i/xw)
53303  cxc(5)=-dcmplx(ei/xw1)*orpp
53304  cxc(6)=dcmplx(0d0,0d0)
53305  cxc(7)=-dcmplx(ei/xw1)*olpp
53306  cxc(8)=dcmplx(0d0,0d0)
53307  IF( xxc(5).LT.axmi ) THEN
53308  xxc(5)=1d6
53309  ENDIF
53310  xxc(7)=xxc(5)
53311  xxc(8)=xxc(6)
53312  IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
53313  lknt=lknt+1
53314  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
53315  & pygaus(pyxxz6,s12min,s12max,prec)
53316  idlam(lknt,1)=kfcchi(1)
53317  idlam(lknt,2)=11
53318  idlam(lknt,3)=-11
53319  IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
53320  lknt=lknt+1
53321  xlam(lknt)=xlam(lknt-1)
53322  idlam(lknt,1)=kfcchi(1)
53323  idlam(lknt,2)=13
53324  idlam(lknt,3)=-13
53325  ENDIF
53326  IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
53327  lknt=lknt+1
53328  xlam(lknt)=xlam(lknt-1)
53329  idlam(lknt,1)=kfcchi(1)
53330  idlam(lknt,2)=15
53331  idlam(lknt,3)=-15
53332  ENDIF
53333  ENDIF
53334 
53335 C...NEUTRINOS
53336  120 CONTINUE
53337  ia=12
53338  ja=11
53339  ei=kchg(iabs(ia),1)/3d0
53340  t3i=sign(1d0,ei+1d-6)/2d0
53341  xxc(5)=pmas(pycomp(ksusy1+ja),1)
53342  xxc(6)=1d6
53343  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
53344  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
53345  cxc(4)=-umixc(ij,1)*dconjg(umixc(ix,1))*dcmplx(t3i/xw)
53346  cxc(5)=-dcmplx(ei/xw1)*orpp
53347  cxc(7)=-dcmplx(ei/xw1)*olpp
53348  IF( xxc(5).LT.axmi ) THEN
53349  xxc(5)=1d6
53350  ENDIF
53351  xxc(7)=xxc(5)
53352  xxc(8)=xxc(6)
53353  IF(axmi.GE.axmj+2d0*pmas(12,1)) THEN
53354  lknt=lknt+1
53355  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
53356  & pygaus(pyxxz6,s12min,s12max,prec)
53357  idlam(lknt,1)=kfcchi(1)
53358  idlam(lknt,2)=12
53359  idlam(lknt,3)=-12
53360  lknt=lknt+1
53361  xlam(lknt)=xlam(lknt-1)
53362  idlam(lknt,1)=kfcchi(1)
53363  idlam(lknt,2)=14
53364  idlam(lknt,3)=-14
53365  ENDIF
53366  IF(axmi.GE.axmj+2d0*pmas(16,1)) THEN
53367  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
53368  xxc(5)=pmas(pycomp(ksusy1+15),1)
53369  ELSE
53370  xxc(5)=pmas(pycomp(ksusy2+15),1)
53371  ENDIF
53372  IF( xxc(5).LT.axmi ) THEN
53373  xxc(5)=1d6
53374  ENDIF
53375  xxc(7)=xxc(5)
53376  lknt=lknt+1
53377  xlam(lknt)=c1**2/xmi3/(16d0*pi)*
53378  & pygaus(pyxxz6,s12min,s12max,prec)
53379  idlam(lknt,1)=kfcchi(1)
53380  idlam(lknt,2)=16
53381  idlam(lknt,3)=-16
53382  ENDIF
53383 
53384 C...D-TYPE QUARKS
53385  130 CONTINUE
53386  ia=1
53387  ja=2
53388  ei=kchg(iabs(ia),1)/3d0
53389  t3i=sign(1d0,ei+1d-6)/2d0
53390  xxc(5)=pmas(pycomp(ksusy1+ja),1)
53391  xxc(6)=1d6
53392  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
53393  cxc(2)=dcmplx(0d0,0d0)
53394  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
53395  cxc(4)=-vmixc(ij,1)*dconjg(vmixc(ix,1))*dcmplx(t3i/xw)
53396  cxc(5)=-dcmplx(ei/xw1)*orpp
53397  cxc(6)=dcmplx(0d0,0d0)
53398  cxc(7)=-dcmplx(ei/xw1)*olpp
53399  cxc(8)=dcmplx(0d0,0d0)
53400  IF( xxc(5).LT.axmi ) THEN
53401  xxc(5)=1d6
53402  ENDIF
53403  xxc(7)=xxc(5)
53404  xxc(8)=xxc(6)
53405  IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
53406  lknt=lknt+1
53407  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
53408  & pygaus(pyxxz6,s12min,s12max,prec)
53409  idlam(lknt,1)=kfcchi(1)
53410  idlam(lknt,2)=1
53411  idlam(lknt,3)=-1
53412  IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
53413  lknt=lknt+1
53414  xlam(lknt)=xlam(lknt-1)
53415  idlam(lknt,1)=kfcchi(1)
53416  idlam(lknt,2)=3
53417  idlam(lknt,3)=-3
53418  ENDIF
53419  ENDIF
53420  IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
53421  IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
53422  xxc(5)=pmas(pycomp(ksusy1+5),1)
53423  ELSE
53424  xxc(5)=pmas(pycomp(ksusy2+5),1)
53425  ENDIF
53426  IF( xxc(5).LT.axmi ) THEN
53427  xxc(5)=1d6
53428  ENDIF
53429  xxc(7)=xxc(5)
53430  lknt=lknt+1
53431  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
53432  & pygaus(pyxxz6,s12min,s12max,prec)
53433  idlam(lknt,1)=kfcchi(1)
53434  idlam(lknt,2)=5
53435  idlam(lknt,3)=-5
53436  ENDIF
53437 
53438 C...U-TYPE QUARKS
53439  140 CONTINUE
53440  ia=2
53441  ja=1
53442  ei=kchg(iabs(ia),1)/3d0
53443  t3i=sign(1d0,ei+1d-6)/2d0
53444  xxc(5)=pmas(pycomp(ksusy1+ja),1)
53445  xxc(6)=1d6
53446  cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
53447  cxc(2)=dcmplx(0d0,0d0)
53448  cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
53449  cxc(4)=-umixc(ij,1)*dconjg(umixc(ix,1))*dcmplx(t3i/xw)
53450  cxc(5)=-dcmplx(ei/xw1)*orpp
53451  cxc(6)=dcmplx(0d0,0d0)
53452  cxc(7)=-dcmplx(ei/xw1)*olpp
53453  cxc(8)=dcmplx(0d0,0d0)
53454  IF( xxc(5).LT.axmi ) THEN
53455  xxc(5)=1d6
53456  ENDIF
53457  xxc(7)=xxc(5)
53458  xxc(8)=xxc(6)
53459  IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
53460  lknt=lknt+1
53461  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
53462  & pygaus(pyxxz6,s12min,s12max,prec)
53463  idlam(lknt,1)=kfcchi(1)
53464  idlam(lknt,2)=2
53465  idlam(lknt,3)=-2
53466  IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
53467  lknt=lknt+1
53468  xlam(lknt)=xlam(lknt-1)
53469  idlam(lknt,1)=kfcchi(1)
53470  idlam(lknt,2)=4
53471  idlam(lknt,3)=-4
53472  ENDIF
53473  ENDIF
53474  150 CONTINUE
53475  ENDIF
53476 
53477 C...CHI_2+ -> CHI_1+ + H0_K
53478  eh(2)=cos(alfa)
53479  eh(1)=sin(alfa)
53480  eh(3)=-sbeta
53481  dh(2)=-sin(alfa)
53482  dh(1)=cos(alfa)
53483  dh(3)=cos(beta)
53484  DO 160 ih=1,3
53485  xmh=pmas(ith(ih),1)
53486  xmh2=xmh**2
53487 C...NO 3-BODY OPTION
53488  IF(axmi.GE.axmj+xmh) THEN
53489  lknt=lknt+1
53490  xl=pylamf(xmi2,xmj2,xmh2)
53491  olpp=(vmixc(2,1)*dconjg(umixc(1,2))*eh(ih) -
53492  & vmixc(2,2)*dconjg(umixc(1,1))*dh(ih))/sr2
53493  orpp=(dconjg(vmixc(1,1))*umixc(2,2)*eh(ih) -
53494  & dconjg(vmixc(1,2))*umixc(2,1)*dh(ih))/sr2
53495  xmk=xmj*etah(ih)
53496  gx2=abs(olpp)**2+abs(orpp)**2
53497  glr=dble(olpp*dconjg(orpp))
53498  xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,gx2,glr)
53499  idlam(lknt,1)=kfcchi(1)
53500  idlam(lknt,2)=ith(ih)
53501  idlam(lknt,3)=0
53502  ENDIF
53503  160 CONTINUE
53504 
53505 C...CHI1 JUMPS TO HERE
53506  170 CONTINUE
53507 
53508 C...CHI+_I -> CHI0_J + W+
53509  DO 220 ij=1,4
53510  xmj=smz(ij)
53511  axmj=abs(xmj)
53512  xmj2=xmj**2
53513  IF(axmi.GE.axmj+xmw) THEN
53514  lknt=lknt+1
53515  DO 180 i=1,4
53516  zmixc(ij,i)=dcmplx(zmix(ij,i),zmixi(ij,i))
53517  180 CONTINUE
53518  cxc(1)=(dconjg(zmixc(ij,2))*vmixc(ix,1)-
53519  & dconjg(zmixc(ij,4))*vmixc(ix,2)/sr2)
53520  cxc(3)=(zmixc(ij,2)*dconjg(umixc(ix,1))+
53521  & zmixc(ij,3)*dconjg(umixc(ix,2))/sr2)
53522  gx2=abs(cxc(1))**2+abs(cxc(3))**2
53523  glr=dble(cxc(1)*dconjg(cxc(3)))
53524  xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gx2,glr)
53525  idlam(lknt,1)=kfnchi(ij)
53526  idlam(lknt,2)=24
53527  idlam(lknt,3)=0
53528 C...LEPTONS
53529  ELSEIF(axmi.GE.axmj) THEN
53530  s12min=0d0
53531  s12max=(axmi-axmj)**2
53532  DO 190 i=1,4
53533  zmixc(ij,i)=dcmplx(zmix(ij,i),zmixi(ij,i))
53534  190 CONTINUE
53535  cxc(1)=(dconjg(zmixc(ij,2))*vmixc(ix,1)-
53536  & dconjg(zmixc(ij,4))*vmixc(ix,2)/sr2)/sr2
53537  cxc(3)=(zmixc(ij,2)*dconjg(umixc(ix,1))+
53538  & zmixc(ij,3)*dconjg(umixc(ix,2))/sr2)/sr2
53539  cxc(5)=dcmplx(0d0,0d0)
53540  cxc(7)=dcmplx(0d0,0d0)
53541  ia=11
53542  ja=12
53543  ei=kchg(ia,1)/3d0
53544  t3i=sign(1d0,ei+1d-6)/2d0
53545  ej=kchg(ja,1)/3d0
53546  t3j=sign(1d0,ej+1d-6)/2d0
53547  cxc(2)=vmixc(ix,1)*dconjg(zmixc(ij,1)*(ej-t3j)*
53548  & tanw+zmixc(ij,2)*t3j)/sr2
53549  cxc(4)=-dconjg(umixc(ix,1))*(
53550  & zmixc(ij,1)*(ei-t3i)*tanw+zmixc(ij,2)*t3i)/sr2
53551  cxc(6)=dcmplx(0d0,0d0)
53552  cxc(8)=dcmplx(0d0,0d0)
53553  xxc(1)=0d0
53554  xxc(2)=xmj
53555  xxc(3)=0d0
53556  xxc(4)=xmi
53557  xxc(5)=pmas(pycomp(ksusy1+ja),1)
53558  xxc(6)=pmas(pycomp(ksusy1+ia),1)
53559  xxc(9)=pmas(24,1)
53560  xxc(10)=pmas(24,2)
53561 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
53562  IF(xxc(5).LT.axmi) THEN
53563  xxc(5)=1d6
53564  ELSEIF(xxc(6).LT.axmi) THEN
53565  xxc(6)=1d6
53566  ENDIF
53567  xxc(7)=xxc(6)
53568  xxc(8)=xxc(5)
53569 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
53570 C...--> 1/(16PI)/M**3*(AEM/XW)**2
53571  IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
53572  lknt=lknt+1
53573  temp=pygaus(pyxxz6,s12min,s12max,prec)
53574  xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
53575  idlam(lknt,1)=kfnchi(ij)
53576  idlam(lknt,2)=-11
53577  idlam(lknt,3)=12
53578 C...ONLY DECAY CHI+1 -> E+ NU_E
53579  IF( imss(12).NE. 0 ) goto 260
53580  IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
53581  lknt=lknt+1
53582  xlam(lknt)=xlam(lknt-1)
53583  idlam(lknt,1)=kfnchi(ij)
53584  idlam(lknt,2)=-13
53585  idlam(lknt,3)=14
53586  ENDIF
53587  ENDIF
53588  IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
53589  lknt=lknt+1
53590  IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
53591  xxc(6)=pmas(pycomp(ksusy1+15),1)
53592  ELSE
53593  xxc(6)=pmas(pycomp(ksusy2+15),1)
53594  ENDIF
53595  xxc(5)=pmas(pycomp(ksusy1+16),1)
53596  IF(xxc(5).LT.axmi) THEN
53597  xxc(5)=1d6
53598  ELSEIF(xxc(6).LT.axmi) THEN
53599  xxc(6)=1d6
53600  ENDIF
53601  xxc(7)=xxc(6)
53602  xxc(8)=xxc(5)
53603  temp=pygaus(pyxxz6,s12min,s12max,prec)
53604  xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
53605  idlam(lknt,1)=kfnchi(ij)
53606  idlam(lknt,2)=-15
53607  idlam(lknt,3)=16
53608  ENDIF
53609 
53610 C...NOW, DO THE QUARKS
53611  200 CONTINUE
53612  ia=1
53613  ja=2
53614  ei=kchg(ia,1)/3d0
53615  t3i=sign(1d0,ei+1d-6)/2d0
53616  ej=kchg(ja,1)/3d0
53617  t3j=sign(1d0,ej+1d-6)/2d0
53618  cxc(2)=vmixc(ix,1)*dconjg(zmixc(ij,1)*(ej-t3j)*
53619  & tanw+zmixc(ij,2)*t3j)
53620  cxc(4)=-dconjg(umixc(ix,1))*(
53621  & zmixc(ij,1)*(ei-t3i)*tanw+zmixc(ij,2)*t3i)
53622  xxc(5)=pmas(pycomp(ksusy1+ja),1)
53623  xxc(6)=pmas(pycomp(ksusy1+ia),1)
53624  IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) goto 210
53625  IF(xxc(5).LT.axmi) THEN
53626  xxc(5)=1d6
53627  ENDIF
53628  IF(xxc(6).LT.axmi) THEN
53629  xxc(6)=1d6
53630  ENDIF
53631  xxc(7)=xxc(6)
53632  xxc(8)=xxc(5)
53633  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
53634  lknt=lknt+1
53635  xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
53636  & pygaus(pyxxz6,s12min,s12max,prec)
53637  idlam(lknt,1)=kfnchi(ij)
53638  idlam(lknt,2)=-1
53639  idlam(lknt,3)=2
53640  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
53641  lknt=lknt+1
53642  xlam(lknt)=xlam(lknt-1)
53643  idlam(lknt,1)=kfnchi(ij)
53644  idlam(lknt,2)=-3
53645  idlam(lknt,3)=4
53646  ENDIF
53647  ENDIF
53648  210 CONTINUE
53649  ENDIF
53650  220 CONTINUE
53651 
53652 C...CHI+_I -> CHI0_J + H+
53653  DO 230 ij=1,4
53654  xmj=smz(ij)
53655  axmj=abs(xmj)
53656  xmj2=xmj**2
53657  xmhp=pmas(ithc,1)
53658  IF(axmi.GE.axmj+xmhp) THEN
53659  lknt=lknt+1
53660  olpp=cbeta*(zmixc(ij,4)*dconjg(vmixc(ix,1))+(zmixc(ij,2)+
53661  & zmixc(ij,1)*tanw)*dconjg(vmixc(ix,2))/sr2)
53662  orpp=sbeta*(dconjg(zmixc(ij,3))*umixc(ix,1)-
53663  & (dconjg(zmixc(ij,2))+dconjg(zmixc(ij,1))*tanw)*
53664  & umixc(ix,2)/sr2)
53665  gx2=abs(olpp)**2+abs(orpp)**2
53666  glr=dble(olpp*dconjg(orpp))
53667  xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gx2,glr)
53668  idlam(lknt,1)=kfnchi(ij)
53669  idlam(lknt,2)=ithc
53670  idlam(lknt,3)=0
53671  ELSE
53672 
53673  ENDIF
53674  230 CONTINUE
53675 
53676 C...2-BODY DECAYS TO FERMION SFERMION
53677  DO 240 j=1,16
53678  IF(j.GE.7.AND.j.LE.10) goto 240
53679  IF(mod(j,2).EQ.0) THEN
53680  kf1=ksusy1+j-1
53681  ELSE
53682  kf1=ksusy1+j+1
53683  ENDIF
53684  kf2=kf1+ksusy1
53685  xmsf1=pmas(pycomp(kf1),1)
53686  xmsf2=pmas(pycomp(kf2),1)
53687  xmf=pmas(j,1)
53688  IF(j.LE.6) THEN
53689  fcol=3d0
53690  ELSE
53691  fcol=1d0
53692  ENDIF
53693 
53694 C...U~ D_L
53695  IF(mod(j,2).EQ.0) THEN
53696  xmfp=pmas(j-1,1)
53697  cal=umixc(ix,1)
53698  cbl=-xmf*vmixc(ix,2)/xmw/sbeta/sr2
53699  car=-xmfp*umixc(ix,2)/xmw/cbeta/sr2
53700  cbr=0d0
53701  isf=j-1
53702  ELSE
53703  xmfp=pmas(j+1,1)
53704  cal=vmixc(ix,1)
53705  cbl=-xmf*umixc(ix,2)/xmw/cbeta/sr2
53706  cbr=0d0
53707  car=-xmfp*vmixc(ix,2)/xmw/sbeta/sr2
53708  isf=j+1
53709  ENDIF
53710 
53711 C...~U_L D
53712  IF(axmi.GE.xmf+xmsf1) THEN
53713  lknt=lknt+1
53714  xma2=xmsf1**2
53715  xmb2=xmf**2
53716  xl=pylamf(xmi2,xma2,xmb2)
53717  ca=cal*sfmix(isf,1)+car*sfmix(isf,2)
53718  cb=cbl*sfmix(isf,1)+cbr*sfmix(isf,2)
53719  xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
53720  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
53721  idlam(lknt,3)=0
53722  IF(mod(j,2).EQ.0) THEN
53723  idlam(lknt,1)=-kf1
53724  idlam(lknt,2)=j
53725  ELSE
53726  idlam(lknt,1)=kf1
53727  idlam(lknt,2)=-j
53728  ENDIF
53729  ENDIF
53730 
53731 C...U~ D_R
53732  IF(axmi.GE.xmf+xmsf2) THEN
53733  lknt=lknt+1
53734  xma2=xmsf2**2
53735  xmb2=xmf**2
53736  ca=cal*sfmix(isf,3)+car*sfmix(isf,4)
53737  cb=cbl*sfmix(isf,3)+cbr*sfmix(isf,4)
53738  xl=pylamf(xmi2,xma2,xmb2)
53739  xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
53740  & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
53741  idlam(lknt,3)=0
53742  IF(mod(j,2).EQ.0) THEN
53743  idlam(lknt,1)=-kf2
53744  idlam(lknt,2)=j
53745  ELSE
53746  idlam(lknt,1)=kf2
53747  idlam(lknt,2)=-j
53748  ENDIF
53749  ENDIF
53750  240 CONTINUE
53751 
53752 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
53753 C...A 2-BODY -- 2-BODY CHAIN
53754  xmj=pmas(pycomp(ksusy1+21),1)
53755  IF(axmi.GE.xmj) THEN
53756  axmj=abs(xmj)
53757  s12min=0d0
53758  s12max=(axmi-axmj)**2
53759  xxc(1)=0d0
53760  xxc(2)=xmj
53761  xxc(3)=0d0
53762  xxc(4)=xmi
53763  xxc(5)=pmas(pycomp(ksusy1+1),1)
53764  xxc(6)=pmas(pycomp(ksusy1+2),1)
53765  xxc(9)=1d6
53766  xxc(10)=0d0
53767  olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))
53768  orpp=dconjg(olpp)
53769  cxc(1)=dcmplx(0d0,0d0)
53770  cxc(3)=dcmplx(0d0,0d0)
53771  cxc(5)=dcmplx(0d0,0d0)
53772  cxc(7)=dcmplx(0d0,0d0)
53773  cxc(2)=umixc(ix,1)*olpp/sr2
53774  cxc(4)=-dconjg(vmixc(ix,1))*orpp/sr2
53775  cxc(6)=dcmplx(0d0,0d0)
53776  cxc(8)=dcmplx(0d0,0d0)
53777  IF(xxc(5).LT.axmi) THEN
53778  xxc(5)=1d6
53779  ELSEIF(xxc(6).LT.axmi) THEN
53780  xxc(6)=1d6
53781  ENDIF
53782  xxc(7)=xxc(6)
53783  xxc(8)=xxc(5)
53784  IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) goto 250
53785  IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
53786  lknt=lknt+1
53787  xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
53788  & pygaus(pyxxz6,s12min,s12max,prec)
53789  idlam(lknt,1)=ksusy1+21
53790  idlam(lknt,2)=-1
53791  idlam(lknt,3)=2
53792  IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
53793  lknt=lknt+1
53794  xlam(lknt)=xlam(lknt-1)
53795  idlam(lknt,1)=ksusy1+21
53796  idlam(lknt,2)=-3
53797  idlam(lknt,3)=4
53798  ENDIF
53799  ENDIF
53800  250 CONTINUE
53801  ENDIF
53802 
53803 C...R-violating decay modes (SKANDS).
53804  CALL pyrvch(kfin,xlam,idlam,lknt)
53805 
53806  260 iknt=lknt
53807  xlam(0)=0d0
53808  DO 270 i=1,iknt
53809  xlam(0)=xlam(0)+xlam(i)
53810  IF(xlam(i).LT.0d0) THEN
53811  WRITE(mstu(11),*) ' XLAM(I) = ',xlam(i),kcin,
53812  & (idlam(i,j),j=1,3)
53813  xlam(i)=0d0
53814  ENDIF
53815  270 CONTINUE
53816  IF(xlam(0).EQ.0d0) THEN
53817  xlam(0)=1d-6
53818  WRITE(mstu(11),*) ' XLAM(0) = ',xlam(0)
53819  WRITE(mstu(11),*) lknt
53820  WRITE(mstu(11),*) (xlam(j),j=1,lknt)
53821  ENDIF
53822 
53823  RETURN
53824  END
53825 
53826 C*********************************************************************
53827 
53828 C...PYXXZ6
53829 C...Used in the calculation of inoi -> inoj + f + ~f.
53830 
53831  FUNCTION pyxxz6(X)
53832 
53833 C...Double precision and integer declarations.
53834  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53835  IMPLICIT INTEGER(i-n)
53836  INTEGER pyk,pychge,pycomp
53837 C...Parameter statement to help give large particle numbers.
53838  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
53839  &kexcit=4000000,kdimen=5000000)
53840 C...Commonblocks.
53841  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53842 C COMMON/PYINTS/XXM(20)
53843  COMPLEX*16 cxc
53844  common/pyintc/xxc(10),cxc(8)
53845  SAVE /pydat1/,/pyintc/
53846 
53847 C...Local variables.
53848  COMPLEX*16 qlls,qrrs,qrls,qlrs,qllu,qrru,qlrt,qrlt
53849  DOUBLE PRECISION pyxxz6,x
53850  DOUBLE PRECISION xm12,xm22,xm32,s,s13,wprop2
53851  DOUBLE PRECISION ww,wf1,wf2,wfl1,wfl2
53852  DOUBLE PRECISION sij
53853  DOUBLE PRECISION xmv,xmg,xmsu1,xmsu2,xmsd1,xmsd2
53854  DOUBLE PRECISION ol2
53855  DOUBLE PRECISION s23min,s23max,s23ave,s23del
53856  INTEGER i
53857 
53858 C...Statement functions.
53859 C...Integral from x to y of (t-a)(b-t) dt.
53860  tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
53861 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53862  tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
53863  &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
53864 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53865  tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
53866  &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
53867 C...Integral from x to y of (t-a)/(b-t) dt.
53868  utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)
53869 C...Integral from x to y of 1/(t-a) dt.
53870  tprop(x,y,a)=log(abs((x-a)/(y-a)))
53871 
53872  xm12=xxc(1)**2
53873  xm22=xxc(2)**2
53874  xm32=xxc(3)**2
53875  s=xxc(4)**2
53876  s13=x
53877 
53878  s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
53879  s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
53880  &( (x-xm22-s)**2 -4d0*xm22*s ) )
53881 
53882  s23min=(s23ave-s23del)
53883  s23max=(s23ave+s23del)
53884 
53885  xmsd1=xxc(5)**2
53886  xmsd2=xxc(7)**2
53887  xmsu1=xxc(6)**2
53888  xmsu2=xxc(8)**2
53889 
53890  xmv=xxc(9)
53891  xmg=xxc(10)
53892  qlls=cxc(1)
53893  qllu=cxc(2)
53894  qlrs=cxc(3)
53895  qlrt=cxc(4)
53896  qrls=cxc(5)
53897  qrlt=cxc(6)
53898  qrrs=cxc(7)
53899  qrru=cxc(8)
53900  wprop2=(s13-xmv**2)**2+(xmv*xmg)**2
53901  sij=2d0*xxc(2)*xxc(4)*s13
53902  IF(xmv.LE.1000d0) THEN
53903  ol2=abs(qlls)**2+abs(qrrs)**2+abs(qlrs)**2+abs(qrls)**2
53904  olr=-2d0*dble(qlrs*dconjg(qlls)+qrls*dconjg(qrrs))
53905  ww=(ol2*2d0*tint(s23max,s23min,xm22,s)
53906  & +olr*sij*(s23max-s23min))/wprop2
53907  IF(xxc(5).LE.10000d0) THEN
53908  wfl1=4d0*(dble(qlls*dconjg(qllu))*
53909  & tint2(s23max,s23min,xm22,s,xmsd1)-
53910  & .5d0*dble(qlls*dconjg(qlrt))*sij*tprop(s23max,s23min,xmsd2)+
53911  & dble(qlrs*dconjg(qlrt))*tint2(s23max,s23min,xm22,s,xmsd2)-
53912  & .5d0*dble(qlrs*dconjg(qllu))*sij*tprop(s23max,s23min,xmsd1))
53913  & *(s13-xmv**2)/wprop2
53914  ELSE
53915  wfl1=0d0
53916  ENDIF
53917 
53918  IF(xxc(6).LE.10000d0) THEN
53919  wfl2=4d0*(dble(qrrs*dconjg(qrru))*
53920  & tint2(s23max,s23min,xm22,s,xmsu1)-
53921  & .5d0*dble(qrrs*dconjg(qrlt))*sij*tprop(s23max,s23min,xmsu2)+
53922  & dble(qrls*dconjg(qrlt))*tint2(s23max,s23min,xm22,s,xmsu2)-
53923  & .5d0*dble(qrls*dconjg(qrru))*sij*tprop(s23max,s23min,xmsu1))
53924  & *(s13-xmv**2)/wprop2
53925  ELSE
53926  wfl2=0d0
53927  ENDIF
53928  ELSE
53929  ww=0d0
53930  wfl1=0d0
53931  wfl2=0d0
53932  ENDIF
53933  IF(xxc(5).LE.10000d0) THEN
53934  wf1=2d0*abs(qllu)**2*tint3(s23max,s23min,xm22,s,xmsd1)
53935  & +2d0*abs(qlrt)**2*tint3(s23max,s23min,xm22,s,xmsd2)
53936  & - 2d0*dble(qlrt*dconjg(qllu))*
53937  & sij*utint(s23max,s23min,xmsd1,xm22+s-s13-xmsd2)
53938  ELSE
53939  wf1=0d0
53940  ENDIF
53941  IF(xxc(6).LE.10000d0) THEN
53942  wf2=2d0*abs(qrru)**2*tint3(s23max,s23min,xm22,s,xmsu1)
53943  & +2d0*abs(qrlt)**2*tint3(s23max,s23min,xm22,s,xmsu2)
53944  & - 2d0*dble(qrlt*dconjg(qrru))*
53945  & sij*utint(s23max,s23min,xmsu1,xm22+s-s13-xmsu2)
53946  ELSE
53947  wf2=0d0
53948  ENDIF
53949 
53950  pyxxz6=(ww+wf1+wf2+wfl1+wfl2)
53951 
53952  IF(pyxxz6.LT.0d0) THEN
53953  WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ6 '
53954  WRITE(mstu(11),*) (xxc(i),i=1,5)
53955  WRITE(mstu(11),*) (xxc(i),i=6,10)
53956  WRITE(mstu(11),*) ww,wf1,wf2,wfl1,wfl2
53957  WRITE(mstu(11),*) s23min,s23max
53958  pyxxz6=0d0
53959  ENDIF
53960 
53961  RETURN
53962  END
53963 
53964 
53965 C*********************************************************************
53966 
53967 C...PYXXGA
53968 C...Calculates chi0_i -> chi0_j + gamma.
53969 
53970  FUNCTION pyxxga(C0,XM1,XM2,XMTR,XMTL)
53971 
53972 C...Double precision and integer declarations.
53973  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53974  IMPLICIT INTEGER(i-n)
53975  INTEGER pyk,pychge,pycomp
53976 
53977 C...Local variables.
53978  DOUBLE PRECISION pyxxga,c0,xm1,xm2,xmtr,xmtl
53979  DOUBLE PRECISION f1,f2
53980 
53981  f1=(1d0+xmtr/(1d0-xmtr)*log(xmtr))/(1d0-xmtr)
53982  f2=(1d0+xmtl/(1d0-xmtl)*log(xmtl))/(1d0-xmtl)
53983  pyxxga=c0*((xm1**2-xm2**2)/xm1)**3
53984  pyxxga=pyxxga*(2d0/3d0*(f1+f2)-13d0/12d0)**2
53985 
53986  RETURN
53987  END
53988 
53989 C*********************************************************************
53990 
53991 C...PYX2XG
53992 C...Calculates the decay rate for ino -> ino + gauge boson.
53993 
53994  FUNCTION pyx2xg(C1,XM1,XM2,XM3,GX2,GLR)
53995 
53996 C...Double precision and integer declarations.
53997  IMPLICIT DOUBLE PRECISION(a-h, o-z)
53998  IMPLICIT INTEGER(i-n)
53999  INTEGER pyk,pychge,pycomp
54000 
54001 C...Local variables.
54002  DOUBLE PRECISION pyx2xg,xm1,xm2,xm3,gx2,glr
54003  DOUBLE PRECISION xl,pylamf,c1
54004  DOUBLE PRECISION xmi2,xmj2,xmv2,xmi3
54005 
54006  xmi2=xm1**2
54007  xmi3=abs(xm1**3)
54008  xmj2=xm2**2
54009  xmv2=xm3**2
54010  xl=pylamf(xmi2,xmj2,xmv2)
54011  pyx2xg=c1/8d0/xmi3*sqrt(xl)
54012  &*(gx2*(xl+3d0*xmv2*(xmi2+xmj2-xmv2))-
54013  &12d0*glr*xm1*xm2*xmv2)
54014 
54015  RETURN
54016  END
54017 
54018 C*********************************************************************
54019 
54020 C...PYX2XH
54021 C...Calculates the decay rate for ino -> ino + H.
54022 
54023  FUNCTION pyx2xh(C1,XM1,XM2,XM3,GX2,GLR)
54024 
54025 C...Double precision and integer declarations.
54026  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54027  IMPLICIT INTEGER(i-n)
54028  INTEGER pyk,pychge,pycomp
54029 
54030 C...Local variables.
54031  DOUBLE PRECISION pyx2xh,xm1,xm2,xm3
54032  DOUBLE PRECISION xl,pylamf,c1
54033  DOUBLE PRECISION xmi2,xmj2,xmv2,xmi3
54034 
54035  xmi2=xm1**2
54036  xmi3=abs(xm1**3)
54037  xmj2=xm2**2
54038  xmv2=xm3**2
54039  xl=pylamf(xmi2,xmj2,xmv2)
54040  pyx2xh=c1/8d0/xmi3*sqrt(xl)
54041  &*(gx2*(xmi2+xmj2-xmv2)+
54042  &4d0*glr*xm1*xm2)
54043 
54044  RETURN
54045  END
54046 
54047 C*********************************************************************
54048 
54049 C...PYHEXT
54050 C...Calculates the non-standard decay modes of the Higgs boson.
54051 C...
54052 C...Author: Stephen Mrenna
54053 C...Last Update: April 2001
54054 C......Allow complex values for Z,U, and V
54055 
54056  SUBROUTINE pyhext(KFIN,XLAM,IDLAM,IKNT)
54057 
54058 C...Double precision and integer declarations.
54059  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54060  IMPLICIT INTEGER(i-n)
54061  INTEGER pyk,pychge,pycomp
54062 C...Parameter statement to help give large particle numbers.
54063  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
54064  &kexcit=4000000,kdimen=5000000)
54065 C...Commonblocks.
54066  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54067  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54068  common/pypars/mstp(200),parp(200),msti(200),pari(200)
54069  common/pymssm/imss(0:99),rmss(0:99)
54070  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
54071  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
54072  SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/,/pyssmt/
54073 
54074 C...Local variables.
54075  COMPLEX*16 zmixc(4,4),vmixc(2,2),umixc(2,2),olpp,orpp
54076  COMPLEX*16 qij,rij,f21k,f12k
54077  INTEGER kfin
54078  DOUBLE PRECISION xmi,xmj,xmf,xmw,xmw2,xmz,axmj,axmi
54079  DOUBLE PRECISION xmi2,xmi3,xmj2
54080  DOUBLE PRECISION pylamf,xl,cf,ei
54081  INTEGER idu,ifl
54082  DOUBLE PRECISION tanw,xw,aem,c1,as
54083  DOUBLE PRECISION pyh2xx,ghll,ghrr,ghlr
54084  DOUBLE PRECISION xlam(0:400)
54085  INTEGER idlam(400,3)
54086  INTEGER lknt,ih,j,ij,i,iknt,ik
54087  INTEGER ith(4)
54088  INTEGER kfnchi(4),kfcchi(2)
54089  DOUBLE PRECISION etah(3),ch(3),dh(3),eh(3)
54090  DOUBLE PRECISION sr2
54091  DOUBLE PRECISION beta,alfa
54092  DOUBLE PRECISION cbeta,sbeta,gr,gl,tanb
54093  DOUBLE PRECISION pyalem
54094  DOUBLE PRECISION al,ar,alr
54095  DOUBLE PRECISION xmk,axmk,cosa,sina,cw,xml
54096  DOUBLE PRECISION xmuz,atrit,atrib,atril
54097  DOUBLE PRECISION xmjl,xmjr,xm1,xm2
54098  DATA ith/25,35,36,37/
54099  DATA etah/1d0,1d0,-1d0/
54100  DATA sr2/1.4142136d0/
54101  DATA kfnchi/1000022,1000023,1000025,1000035/
54102  DATA kfcchi/1000024,1000037/
54103 
54104 C...COUNT THE NUMBER OF DECAY MODES
54105  lknt=iknt
54106 
54107  xmw=pmas(24,1)
54108  xmw2=xmw**2
54109  xmz=pmas(23,1)
54110  xw=paru(102)
54111  tanw = sqrt(xw/(1d0-xw))
54112  cw=sqrt(1d0-xw)
54113 
54114 C...1 - 4 DEPENDING ON Higgs species.
54115  ih=1
54116  IF(kfin.EQ.ith(2)) ih=2
54117  IF(kfin.EQ.ith(3)) ih=3
54118  IF(kfin.EQ.ith(4)) ih=4
54119 
54120  xmi=pmas(kfin,1)
54121  xmi2=xmi**2
54122  axmi=abs(xmi)
54123  aem=pyalem(xmi2)
54124  c1=aem/xw
54125  xmi3=abs(xmi**3)
54126 
54127  tanb=rmss(5)
54128  beta=atan(tanb)
54129  cbeta=cos(beta)
54130  sbeta=tanb*cbeta
54131  alfa=rmss(18)
54132  cosa=cos(alfa)
54133  sina=sin(alfa)
54134  atrit=rmss(16)
54135  atrib=rmss(15)
54136  atril=rmss(17)
54137  xmuz=-rmss(4)
54138 
54139  DO 110 i=1,4
54140  DO 100 j=1,4
54141  zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
54142  100 CONTINUE
54143  110 CONTINUE
54144  DO 130 i=1,2
54145  DO 120 j=1,2
54146  vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
54147  umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
54148  120 CONTINUE
54149  130 CONTINUE
54150 
54151 
54152  IF(ih.EQ.4) goto 220
54153 
54154 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
54155 C...H0_K -> CHI0_I + CHI0_J
54156  eh(2)=sina
54157  eh(1)=cosa
54158  eh(3)=cbeta
54159  dh(2)=cosa
54160  dh(1)=-sina
54161  dh(3)=sbeta
54162  DO 150 ij=1,4
54163  xmj=smz(ij)
54164  axmj=abs(xmj)
54165  DO 140 ik=1,ij
54166  xmk=smz(ik)
54167  axmk=abs(xmk)
54168  IF(axmi.GE.axmj+axmk) THEN
54169  lknt=lknt+1
54170  qij=zmixc(ik,3)*zmixc(ij,2)+
54171  & zmixc(ij,3)*zmixc(ik,2)-
54172  & tanw*(zmixc(ik,3)*zmixc(ij,1)+
54173  & zmixc(ij,3)*zmixc(ik,1))
54174  rij=zmixc(ik,4)*zmixc(ij,2)+
54175  & zmixc(ij,4)*zmixc(ik,2)-
54176  & tanw*(zmixc(ik,4)*zmixc(ij,1)+
54177  & zmixc(ij,4)*zmixc(ik,1))
54178  f21k=0.5d0*dconjg(qij*dh(ih)-rij*eh(ih))
54179  f12k=0.5d0*(qij*dh(ih)-rij*eh(ih))
54180 C...SIGN OF MASSES I,J
54181  xml=xmk*etah(ih)
54182  gx2=abs(f12k)**2+abs(f21k)**2
54183  glr=dble(f12k*dconjg(f21k))
54184  xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,gx2,glr)
54185  IF(ij.EQ.ik) xlam(lknt)=xlam(lknt)*0.5d0
54186  idlam(lknt,1)=kfnchi(ij)
54187  idlam(lknt,2)=kfnchi(ik)
54188  idlam(lknt,3)=0
54189  ENDIF
54190  140 CONTINUE
54191  150 CONTINUE
54192 
54193 C...H0_K -> CHI+_I CHI-_J
54194  DO 170 ij=1,2
54195  xmj=smw(ij)
54196  axmj=abs(xmj)
54197  DO 160 ik=1,2
54198  xmk=smw(ik)
54199  axmk=abs(xmk)
54200  IF(axmi.GE.axmj+axmk) THEN
54201  lknt=lknt+1
54202  olpp=dconjg(vmixc(ij,1)*umixc(ik,2)*dh(ih) +
54203  & vmixc(ij,2)*umixc(ik,1)*eh(ih))/sr2
54204  orpp=(vmixc(ik,1)*umixc(ij,2)*dh(ih) +
54205  & vmixc(ik,2)*umixc(ij,1)*eh(ih))/sr2
54206  gx2=abs(olpp)**2+abs(orpp)**2
54207  glr=dble(olpp*dconjg(orpp))
54208  xml=xmk*etah(ih)
54209  xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,gx2,glr)
54210  idlam(lknt,1)=kfcchi(ij)
54211  idlam(lknt,2)=-kfcchi(ik)
54212  idlam(lknt,3)=0
54213  ENDIF
54214  160 CONTINUE
54215  170 CONTINUE
54216 
54217 C...HIGGS TO SFERMION SFERMION
54218  DO 200 ifl=1,16
54219  IF(ifl.GE.7.AND.ifl.LE.10) goto 200
54220  ij=ksusy1+ifl
54221  xmjl=pmas(pycomp(ij),1)
54222  xmjr=pmas(pycomp(ij+ksusy1),1)
54223  IF(axmi.GE.2d0*min(xmjl,xmjr)) THEN
54224  xmj=xmjl
54225  xmj2=xmj**2
54226  xl=pylamf(xmi2,xmj2,xmj2)
54227  xmf=pmas(ifl,1)
54228  ei=kchg(ifl,1)/3d0
54229  idu=2-mod(ifl,2)
54230 
54231  IF(ih.EQ.1) THEN
54232  IF(idu.EQ.1) THEN
54233  ghll=-xmz/cw*(0.5d0+ei*xw)*sin(alfa+beta)+
54234  & xmf**2/xmw*sina/cbeta
54235  ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)+
54236  & xmf**2/xmw*sina/cbeta
54237  IF(ifl.EQ.5) THEN
54238  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
54239  & atrib*sina)
54240  ELSEIF(ifl.EQ.15) THEN
54241  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
54242  & atril*sina)
54243  ELSE
54244  ghlr=0d0
54245  ENDIF
54246  ELSE
54247  ghll=xmz/cw*(0.5d0-ei*xw)*sin(alfa+beta)-
54248  & xmf**2/xmw*cosa/sbeta
54249  ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)-
54250  & xmf**2/xmw*cosa/sbeta
54251  IF(ifl.EQ.6) THEN
54252  ghlr=xmf/2d0/xmw/sbeta*(xmuz*sina-
54253  & atrit*cosa)
54254  ELSE
54255  ghlr=0d0
54256  ENDIF
54257  ENDIF
54258 
54259  ELSEIF(ih.EQ.2) THEN
54260  IF(idu.EQ.1) THEN
54261  ghll=xmz/cw*(0.5d0+ei*xw)*cos(alfa+beta)-
54262  & xmf**2/xmw*cosa/cbeta
54263  ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
54264  & xmf**2/xmw*cosa/cbeta
54265  IF(ifl.EQ.5) THEN
54266  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
54267  & atrib*cosa)
54268  ELSEIF(ifl.EQ.15) THEN
54269  ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
54270  & atril*cosa)
54271  ELSE
54272  ghlr=0d0
54273  ENDIF
54274  ELSE
54275  ghll=-xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)-
54276  & xmf**2/xmw*sina/sbeta
54277  ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
54278  & xmf**2/xmw*sina/sbeta
54279  IF(ifl.EQ.6) THEN
54280  ghlr=-xmf/2d0/xmw/sbeta*(xmuz*cosa+
54281  & atrit*sina)
54282  ELSE
54283  ghlr=0d0
54284  ENDIF
54285  ENDIF
54286 
54287  ELSEIF(ih.EQ.3) THEN
54288  ghll=0d0
54289  ghrr=0d0
54290  ghlr=0d0
54291  IF(idu.EQ.1) THEN
54292  IF(ifl.EQ.5) THEN
54293  ghlr=xmf/2d0/xmw*(atrib*tanb-xmuz)
54294  ELSEIF(ifl.EQ.15) THEN
54295  ghlr=xmf/2d0/xmw*(atril*tanb-xmuz)
54296  ENDIF
54297  ELSE
54298  IF(ifl.EQ.6) THEN
54299  ghlr=xmf/2d0/xmw*(atrit/tanb-xmuz)
54300  ENDIF
54301  ENDIF
54302  ENDIF
54303  IF(ih.EQ.3) goto 180
54304 
54305  al=sfmix(ifl,1)**2
54306  ar=sfmix(ifl,2)**2
54307  alr=sfmix(ifl,1)*sfmix(ifl,2)
54308  IF(ifl.LE.6) THEN
54309  cf=3d0
54310  ELSE
54311  cf=1d0
54312  ENDIF
54313 
54314  IF(axmi.GE.2d0*xmj) THEN
54315  lknt=lknt+1
54316  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
54317  & (ghll*al+ghrr*ar
54318  & +2d0*ghlr*alr)**2
54319  idlam(lknt,1)=ij
54320  idlam(lknt,2)=-ij
54321  idlam(lknt,3)=0
54322  ENDIF
54323 
54324  IF(axmi.GE.2d0*xmjr) THEN
54325  lknt=lknt+1
54326  al=sfmix(ifl,3)**2
54327  ar=sfmix(ifl,4)**2
54328  alr=sfmix(ifl,3)*sfmix(ifl,4)
54329  xmj=xmjr
54330  xmj2=xmj**2
54331  xl=pylamf(xmi2,xmj2,xmj2)
54332  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
54333  & (ghll*al+ghrr*ar
54334  & +2d0*ghlr*alr)**2
54335  idlam(lknt,1)=ij+ksusy1
54336  idlam(lknt,2)=-(ij+ksusy1)
54337  idlam(lknt,3)=0
54338  ENDIF
54339  180 CONTINUE
54340 
54341  IF(axmi.GE.xmjl+xmjr) THEN
54342  lknt=lknt+1
54343  al=sfmix(ifl,1)*sfmix(ifl,3)
54344  ar=sfmix(ifl,2)*sfmix(ifl,4)
54345  alr=sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,2)*sfmix(ifl,3)
54346  xmj=xmjr
54347  xmj2=xmj**2
54348  xl=pylamf(xmi2,xmj2,xmjl**2)
54349  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
54350  & (ghll*al+ghrr*ar)**2
54351  idlam(lknt,1)=ij
54352  idlam(lknt,2)=-(ij+ksusy1)
54353  idlam(lknt,3)=0
54354  lknt=lknt+1
54355  idlam(lknt,1)=-ij
54356  idlam(lknt,2)=ij+ksusy1
54357  idlam(lknt,3)=0
54358  xlam(lknt)=xlam(lknt-1)
54359  ENDIF
54360  ENDIF
54361  190 CONTINUE
54362  200 CONTINUE
54363  210 CONTINUE
54364 
54365  goto 270
54366  220 CONTINUE
54367 
54368 C...H+ -> CHI+_I + CHI0_J
54369  DO 240 ij=1,4
54370  xmj=smz(ij)
54371  axmj=abs(xmj)
54372  xmj2=xmj**2
54373  DO 230 ik=1,2
54374  xmk=smw(ik)
54375  axmk=abs(xmk)
54376  IF(axmi.GE.axmj+axmk) THEN
54377  lknt=lknt+1
54378  olpp=cbeta*dconjg(zmixc(ij,4)*vmixc(ik,1)+(zmixc(ij,2)+
54379  & zmixc(ij,1)*tanw)*vmixc(ik,2)/sr2)
54380  orpp=sbeta*(zmixc(ij,3)*umixc(ik,1)-
54381  & (zmixc(ij,2)+zmixc(ij,1)*tanw)*umixc(ik,2)/sr2)
54382  gx2=abs(olpp)**2+abs(orpp)**2
54383  glr=dble(olpp*dconjg(orpp))
54384  xlam(lknt)=pyh2xx(c1,xmi,xmj,-xmk,gx2,glr)
54385  idlam(lknt,1)=kfnchi(ij)
54386  idlam(lknt,2)=kfcchi(ik)
54387  idlam(lknt,3)=0
54388  ENDIF
54389  230 CONTINUE
54390  240 CONTINUE
54391 
54392  gl=-xmw/sr2*(sin(2d0*beta)-pmas(6,1)**2/tanb/xmw2)
54393  gr=-pmas(6,1)/sr2/xmw*(xmuz-atrit/tanb)
54394  al=0d0
54395  ar=0d0
54396  cf=3d0
54397 
54398 C...H+ -> T_1 B_1~
54399  xm1=pmas(pycomp(ksusy1+6),1)
54400  xm2=pmas(pycomp(ksusy1+5),1)
54401  IF(xmi.GE.xm1+xm2) THEN
54402  xl=pylamf(xmi2,xm1**2,xm2**2)
54403  lknt=lknt+1
54404  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
54405  & (gl*sfmix(6,1)*sfmix(5,1)+gr*sfmix(6,2)*sfmix(5,1))**2
54406  idlam(lknt,1)=ksusy1+6
54407  idlam(lknt,2)=-(ksusy1+5)
54408  idlam(lknt,3)=0
54409  ENDIF
54410 
54411 C...H+ -> T_2 B_1~
54412  xm1=pmas(pycomp(ksusy2+6),1)
54413  xm2=pmas(pycomp(ksusy1+5),1)
54414  IF(xmi.GE.xm1+xm2) THEN
54415  xl=pylamf(xmi2,xm1**2,xm2**2)
54416  lknt=lknt+1
54417  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
54418  & (gl*sfmix(6,3)*sfmix(5,1)+gr*sfmix(6,4)*sfmix(5,1))**2
54419  idlam(lknt,1)=ksusy2+6
54420  idlam(lknt,2)=-(ksusy1+5)
54421  idlam(lknt,3)=0
54422  ENDIF
54423 
54424 C...H+ -> T_1 B_2~
54425  xm1=pmas(pycomp(ksusy1+6),1)
54426  xm2=pmas(pycomp(ksusy2+5),1)
54427  IF(xmi.GE.xm1+xm2) THEN
54428  xl=pylamf(xmi2,xm1**2,xm2**2)
54429  lknt=lknt+1
54430  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
54431  & (gl*sfmix(6,1)*sfmix(5,3)+gr*sfmix(6,2)*sfmix(5,3))**2
54432  idlam(lknt,1)=ksusy1+6
54433  idlam(lknt,2)=-(ksusy2+5)
54434  idlam(lknt,3)=0
54435  ENDIF
54436 
54437 C...H+ -> T_2 B_2~
54438  xm1=pmas(pycomp(ksusy2+6),1)
54439  xm2=pmas(pycomp(ksusy2+5),1)
54440  IF(xmi.GE.xm1+xm2) THEN
54441  xl=pylamf(xmi2,xm1**2,xm2**2)
54442  lknt=lknt+1
54443  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
54444  & (gl*sfmix(6,3)*sfmix(5,3)+gr*sfmix(6,4)*sfmix(5,3))**2
54445  idlam(lknt,1)=ksusy2+6
54446  idlam(lknt,2)=-(ksusy2+5)
54447  idlam(lknt,3)=0
54448  ENDIF
54449 
54450 C...H+ -> UL DL~
54451  gl=-xmw/sr2*sin(2d0*beta)
54452  DO 250 ij=1,3,2
54453  xm1=pmas(pycomp(ksusy1+ij),1)
54454  xm2=pmas(pycomp(ksusy1+ij+1),1)
54455  IF(xmi.GE.xm1+xm2) THEN
54456  xl=pylamf(xmi2,xm1**2,xm2**2)
54457  lknt=lknt+1
54458  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2
54459  idlam(lknt,1)=-(ksusy1+ij)
54460  idlam(lknt,2)=ksusy1+ij+1
54461  idlam(lknt,3)=0
54462  ENDIF
54463  250 CONTINUE
54464 
54465 C...H+ -> EL~ NUL
54466  cf=1d0
54467  DO 260 ij=11,13,2
54468  xm1=pmas(pycomp(ksusy1+ij),1)
54469  xm2=pmas(pycomp(ksusy1+ij+1),1)
54470  IF(xmi.GE.xm1+xm2) THEN
54471  xl=pylamf(xmi2,xm1**2,xm2**2)
54472  lknt=lknt+1
54473  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2
54474  idlam(lknt,1)=-(ksusy1+ij)
54475  idlam(lknt,2)=ksusy1+ij+1
54476  idlam(lknt,3)=0
54477  ENDIF
54478  260 CONTINUE
54479 
54480 C...H+ -> TAU1 NUTAUL
54481  xm1=pmas(pycomp(ksusy1+15),1)
54482  xm2=pmas(pycomp(ksusy1+16),1)
54483  IF(xmi.GE.xm1+xm2) THEN
54484  xl=pylamf(xmi2,xm1**2,xm2**2)
54485  lknt=lknt+1
54486  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2*sfmix(15,1)**2
54487  idlam(lknt,1)=-(ksusy1+15)
54488  idlam(lknt,2)= ksusy1+16
54489  idlam(lknt,3)=0
54490  ENDIF
54491 
54492 C...H+ -> TAU2 NUTAUL
54493  xm1=pmas(pycomp(ksusy2+15),1)
54494  xm2=pmas(pycomp(ksusy1+16),1)
54495  IF(xmi.GE.xm1+xm2) THEN
54496  xl=pylamf(xmi2,xm1**2,xm2**2)
54497  lknt=lknt+1
54498  xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2*sfmix(15,3)**2
54499  idlam(lknt,1)=-(ksusy2+15)
54500  idlam(lknt,2)= ksusy1+16
54501  idlam(lknt,3)=0
54502  ENDIF
54503 
54504  270 CONTINUE
54505  iknt=lknt
54506  xlam(0)=0d0
54507  DO 280 i=1,iknt
54508  IF(xlam(i).LE.0d0) xlam(i)=0d0
54509  xlam(0)=xlam(0)+xlam(i)
54510  280 CONTINUE
54511  IF(xlam(0).EQ.0d0) xlam(0)=1d-6
54512 
54513  RETURN
54514  END
54515 
54516 C*********************************************************************
54517 
54518 C...PYH2XX
54519 C...Calculates the decay rate for a Higgs to an ino pair.
54520 
54521  FUNCTION pyh2xx(C1,XM1,XM2,XM3,GX2,GLR)
54522 
54523 C...Double precision and integer declarations.
54524  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54525  IMPLICIT INTEGER(i-n)
54526  INTEGER pyk,pychge,pycomp
54527 C...Commonblocks.
54528  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54529  SAVE /pydat1/
54530 
54531 C...Local variables.
54532  DOUBLE PRECISION pyh2xx,xm1,xm2,xm3,gl,gr
54533  DOUBLE PRECISION xl,pylamf,c1
54534  DOUBLE PRECISION xmi2,xmj2,xmk2,xmi3
54535 
54536  xmi2=xm1**2
54537  xmi3=abs(xm1**3)
54538  xmj2=xm2**2
54539  xmk2=xm3**2
54540  xl=pylamf(xmi2,xmj2,xmk2)
54541  pyh2xx=c1/4d0/xmi3*sqrt(xl)
54542  &*(gx2*(xmi2-xmj2-xmk2)-
54543  &4d0*glr*xm3*xm2)
54544  IF(pyh2xx.LT.0d0) pyh2xx=0d0
54545 
54546  RETURN
54547  END
54548 
54549 C*********************************************************************
54550 
54551 C...PYGAUS
54552 C...Integration by adaptive Gaussian quadrature.
54553 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54554 
54555  FUNCTION pygaus(F, A, B, EPS)
54556 
54557 C...Double precision and integer declarations.
54558  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54559  IMPLICIT INTEGER(i-n)
54560  INTEGER pyk,pychge,pycomp
54561 
54562 C...Local declarations.
54563  EXTERNAL f
54564  DOUBLE PRECISION f,w(12), x(12)
54565  DATA x( 1) /9.6028985649753623d-1/, w( 1) /1.0122853629037626d-1/
54566  DATA x( 2) /7.9666647741362674d-1/, w( 2) /2.2238103445337447d-1/
54567  DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
54568  DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
54569  DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
54570  DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
54571  DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
54572  DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
54573  DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
54574  DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
54575  DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
54576  DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
54577 
54578 C...The Gaussian quadrature algorithm.
54579  h = 0d0
54580  IF(b .EQ. a) goto 140
54581  const = 5d-3 / abs(b-a)
54582  bb = a
54583  100 CONTINUE
54584  aa = bb
54585  bb = b
54586  110 CONTINUE
54587  c1 = 0.5d0*(bb+aa)
54588  c2 = 0.5d0*(bb-aa)
54589  s8 = 0d0
54590  DO 120 i = 1, 4
54591  u = c2*x(i)
54592  s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
54593  120 CONTINUE
54594  s16 = 0d0
54595  DO 130 i = 5, 12
54596  u = c2*x(i)
54597  s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
54598  130 CONTINUE
54599  s16 = c2*s16
54600  IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
54601  h = h + s16
54602  IF(bb .NE. b) goto 100
54603  ELSE
54604  bb = c1
54605  IF(1d0 + const*abs(c2) .NE. 1d0) goto 110
54606  h = 0d0
54607  CALL pyerrm(18,'(PYGAUS:) too high accuracy required')
54608  goto 140
54609  ENDIF
54610  140 CONTINUE
54611  pygaus = h
54612 
54613  RETURN
54614  END
54615 
54616 C*********************************************************************
54617 
54618 C...PYGAU2
54619 C...Integration by adaptive Gaussian quadrature.
54620 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54621 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
54622 
54623  FUNCTION pygau2(F, A, B, EPS)
54624 
54625 C...Double precision and integer declarations.
54626  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54627  IMPLICIT INTEGER(i-n)
54628  INTEGER pyk,pychge,pycomp
54629 
54630 C...Local declarations.
54631  EXTERNAL f
54632  DOUBLE PRECISION f,w(12), x(12)
54633  DATA x( 1) /9.6028985649753623d-1/, w( 1) /1.0122853629037626d-1/
54634  DATA x( 2) /7.9666647741362674d-1/, w( 2) /2.2238103445337447d-1/
54635  DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
54636  DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
54637  DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
54638  DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
54639  DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
54640  DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
54641  DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
54642  DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
54643  DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
54644  DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
54645 
54646 C...The Gaussian quadrature algorithm.
54647  h = 0d0
54648  IF(b .EQ. a) goto 140
54649  const = 5d-3 / abs(b-a)
54650  bb = a
54651  100 CONTINUE
54652  aa = bb
54653  bb = b
54654  110 CONTINUE
54655  c1 = 0.5d0*(bb+aa)
54656  c2 = 0.5d0*(bb-aa)
54657  s8 = 0d0
54658  DO 120 i = 1, 4
54659  u = c2*x(i)
54660  s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
54661  120 CONTINUE
54662  s16 = 0d0
54663  DO 130 i = 5, 12
54664  u = c2*x(i)
54665  s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
54666  130 CONTINUE
54667  s16 = c2*s16
54668  IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
54669  h = h + s16
54670  IF(bb .NE. b) goto 100
54671  ELSE
54672  bb = c1
54673  IF(1d0 + const*abs(c2) .NE. 1d0) goto 110
54674  h = 0d0
54675  CALL pyerrm(18,'(PYGAU2:) too high accuracy required')
54676  goto 140
54677  ENDIF
54678  140 CONTINUE
54679  pygau2 = h
54680 
54681  RETURN
54682  END
54683 
54684 C*********************************************************************
54685 
54686 C...PYSIMP
54687 C...Simpson formula for an integral.
54688 
54689  FUNCTION pysimp(Y,X0,X1,N)
54690 
54691 C...Double precision and integer declarations.
54692  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54693  IMPLICIT INTEGER(i-n)
54694  INTEGER pyk,pychge,pycomp
54695 
54696 C...Local variables.
54697  DOUBLE PRECISION y,x0,x1,h,s
54698  dimension y(0:n)
54699 
54700  s=0d0
54701  h=(x1-x0)/n
54702  DO 100 i=0,n-2,2
54703  s=s+y(i)+4d0*y(i+1)+y(i+2)
54704  100 CONTINUE
54705  pysimp=s*h/3d0
54706 
54707  RETURN
54708  END
54709 
54710 C*********************************************************************
54711 
54712 C...PYLAMF
54713 C...The standard lambda function.
54714 
54715  FUNCTION pylamf(X,Y,Z)
54716 
54717 C...Double precision and integer declarations.
54718  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54719  IMPLICIT INTEGER(i-n)
54720  INTEGER pyk,pychge,pycomp
54721 
54722 C...Local variables.
54723  DOUBLE PRECISION pylamf,x,y,z
54724 
54725  pylamf=(x-(y+z))**2-4d0*y*z
54726  IF(pylamf.LT.0d0) pylamf=0d0
54727 
54728  RETURN
54729  END
54730 
54731 C*********************************************************************
54732 
54733 C...PYTBDY
54734 C...Generates 3-body decays of gauginos.
54735 
54736  SUBROUTINE pytbdy(IDIN)
54737 
54738 C...Double precision and integer declarations.
54739  IMPLICIT DOUBLE PRECISION(a-h, o-z)
54740  IMPLICIT INTEGER(i-n)
54741  INTEGER pyk,pychge,pycomp
54742 C...Parameter statement to help give large particle numbers.
54743  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
54744  &kexcit=4000000,kdimen=5000000)
54745 C...Commonblocks.
54746  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
54747  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54748  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54749 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54750  common/pypars/mstp(200),parp(200),msti(200),pari(200)
54751  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
54752  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
54753 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
54754  SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyssmt/
54755 
54756 C...Local variables.
54757  DOUBLE PRECISION xm(5)
54758  COMPLEX*16 olpp,orpp,qll,qlr,qrr,qrl,glij,grij,propz
54759  COMPLEX*16 qlls,qrrs,qlrs,qrls,qllu,qrru,qlrt,qrlt
54760  COMPLEX*16 zmixc(4,4),umixc(2,2),vmixc(2,2)
54761  DOUBLE PRECISION s12min,s12max,yjaco1,s23ave,s23df1,s23df2
54762  DOUBLE PRECISION d1,d2,d3,p1,p2,p3,cthe1,sthe1,cthe3,sthe3
54763  DOUBLE PRECISION cphi1,sphi1
54764  DOUBLE PRECISION s23del,eps
54765  DOUBLE PRECISION golden,ax,bx,cx,tol,xmin,r,c
54766  parameter(r=0.61803399d0,c=1d0-r,tol=1d-3)
54767  DOUBLE PRECISION f1,f2,x0,x1,x2,x3
54768  INTEGER inoid(4)
54769  DATA inoid/22,23,25,35/
54770  DATA eps/1d-6/
54771 
54772  id=idin
54773  iskip=1
54774  xm(1)=p(n+1,5)
54775  xm(2)=p(n+2,5)
54776  xm(3)=p(n+3,5)
54777  xm(5)=p(id,5)
54778 
54779 C...GENERATE S12
54780  s12min=(xm(1)+xm(2))**2
54781  s12max=(xm(5)-xm(3))**2
54782  yjaco1=s12max-s12min
54783 
54784 C...Initialize some parameters
54785  xw=paru(102)
54786  xw1=1d0-xw
54787  tanw=sqrt(xw/xw1)
54788  izid1=0
54789  iwid1=0
54790  izid2=0
54791  iwid2=0
54792 
54793  ia=k(n+2,2)
54794  ja=k(n+3,2)
54795 
54796 C...Mrenna: check that we are indeed decaying a SUSY particle
54797  IF(iabs(k(id,2)).LT.ksusy1.OR.iabs(k(id,2)).GE.3000000) THEN
54798 
54799  ELSE
54800  DO 100 i1=1,4
54801  IF(mod(k(n+1,2),ksusy1).EQ.inoid(i1)) izid1=i1
54802  IF(mod(k(id,2),ksusy1).EQ.inoid(i1)) izid2=i1
54803  100 CONTINUE
54804  IF(mod(k(n+1,2),ksusy1).EQ.24) iwid1=1
54805  IF(mod(k(n+1,2),ksusy1).EQ.37) iwid1=2
54806  IF(mod(k(id,2),ksusy1).EQ.24) iwid2=1
54807  IF(mod(k(id,2),ksusy1).EQ.37) iwid2=2
54808  zm12=xm(5)**2
54809  zm22=xm(1)**2
54810  ei=kchg(pycomp(iabs(ia)),1)/3d0
54811  t3i=sign(1d0,ei+1d-6)/2d0
54812  ENDIF
54813 
54814  IF(mstp(47).EQ.0) THEN
54815  iskip=0
54816  ELSEIF(max(abs(ia),abs(ja)).EQ.6) THEN
54817  iskip=0
54818  ELSEIF(izid1*izid2.NE.0) THEN
54819  sqmz=pmas(23,1)**2
54820  gmmz=pmas(23,1)*pmas(23,2)
54821  DO 110 i=1,4
54822  zmixc(izid1,i)=dcmplx(zmix(izid1,i),zmixi(izid1,i))
54823  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
54824  110 CONTINUE
54825  olpp=(zmixc(izid1,3)*dconjg(zmixc(izid2,3))-
54826  & zmixc(izid1,4)*dconjg(zmixc(izid2,4)))/2d0
54827  orpp=dconjg(olpp)
54828  xll2=pmas(pycomp(ksusy1+iabs(ia)),1)**2
54829  xlr2=xll2
54830  xrr2=pmas(pycomp(ksusy2+iabs(ia)),1)**2
54831  xrl2=xrr2
54832  glij=(t3i*zmixc(izid1,2)-tanw*(t3i-ei)*zmixc(izid1,1))*
54833  & dconjg(t3i*zmixc(izid2,2)-tanw*(t3i-ei)*zmixc(izid2,1))
54834  grij=zmixc(izid1,1)*dconjg(zmixc(izid2,1))*(ei*tanw)**2
54835  xm1m2=smz(izid1)*smz(izid2)
54836  qlls=dcmplx((t3i-ei*xw)/xw1)*olpp
54837  qllu=-glij
54838  qlrs=-dcmplx((t3i-ei*xw)/xw1)*orpp
54839  qlrt=dconjg(glij)
54840  qrls=-dcmplx((ei*xw)/xw1)*olpp
54841  qrlt=grij
54842  qrrs=dcmplx((ei*xw)/xw1)*orpp
54843  qrru=-dconjg(grij)
54844  ELSEIF(izid1*iwid2.NE.0.OR.izid2*iwid1.NE.0) THEN
54845  IF(izid1.NE.0) THEN
54846  xm1m2=smz(izid1)*smw(iwid2)
54847  izid1=iwid2
54848  izid2=izid1
54849  ELSE
54850  xm1m2=smz(izid2)*smw(iwid1)
54851  izid1=iwid1
54852  ENDIF
54853  rt2i = 1d0/sqrt(2d0)
54854  sqmz=pmas(24,1)**2
54855  gmmz=pmas(24,1)*pmas(24,2)
54856  DO 120 i=1,2
54857  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
54858  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
54859  120 CONTINUE
54860  DO 130 i=1,4
54861  zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
54862  130 CONTINUE
54863  qlls=(dconjg(zmixc(izid2,2))*vmixc(izid1,1)-
54864  & dconjg(zmixc(izid2,4))*vmixc(izid1,2)*rt2i)
54865  qlrs=(zmixc(izid2,2)*dconjg(umixc(izid1,1))+
54866  & zmixc(izid2,3)*dconjg(umixc(izid1,2))*rt2i)
54867  ej=kchg(iabs(ja),1)/3d0
54868  t3j=sign(1d0,ej+1d-6)/2d0
54869  qrls=dcmplx(0d0,0d0)
54870  qrlt=qrls
54871  qrrs=qrls
54872  qrru=qrls
54873  xrr2=1d6**2
54874  xrl2=xrr2
54875  xlr2 = pmas(pycomp(ksusy1+iabs(ja)),1)**2
54876  xll2 = pmas(pycomp(ksusy1+iabs(ia)),1)**2
54877  IF(mod(ia,2).EQ.0) THEN
54878  qllu=vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ei-t3i)*
54879  & tanw+zmixc(izid2,2)*t3i)
54880  qlrt=-dconjg(umixc(izid1,1))*(
54881  & zmixc(izid2,1)*(ej-t3j)*tanw+zmixc(izid2,2)*t3j)
54882  ELSE
54883  qllu=vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ej-t3j)*
54884  & tanw+zmixc(izid2,2)*t3j)
54885  qlrt=-dconjg(umixc(izid1,1))*(
54886  & zmixc(izid2,1)*(ei-t3i)*tanw+zmixc(izid2,2)*t3i)
54887  ENDIF
54888  ELSEIF(iwid1*iwid2.NE.0) THEN
54889  izid1=iwid1
54890  izid2=iwid2
54891  xm1m2=smw(iwid1)*smw(iwid2)
54892  sqmz=pmas(23,1)**2
54893  gmmz=pmas(23,1)*pmas(23,2)
54894  DO 140 i=1,2
54895  vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
54896  umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
54897  vmixc(izid2,i)=dcmplx(vmix(izid2,i),vmixi(izid2,i))
54898  umixc(izid2,i)=dcmplx(umix(izid2,i),umixi(izid2,i))
54899  140 CONTINUE
54900  olpp=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))-
54901  & vmixc(izid2,2)*dconjg(vmixc(izid1,2))/2d0
54902  orpp=-umixc(izid1,1)*dconjg(umixc(izid2,1))-
54903  & umixc(izid1,2)*dconjg(umixc(izid2,2))/2d0
54904  qrls=-dcmplx(ei/xw1)*orpp
54905  qlls=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
54906  qrrs=-dcmplx(ei/xw1)*olpp
54907  qlrs=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
54908  IF(mod(ia,2).EQ.0) THEN
54909  xlr2=pmas(pycomp(ksusy1+iabs(ia)-1),1)**2
54910  qlrt=-umixc(izid2,1)*dconjg(umixc(izid1,1))*dcmplx(t3i/xw)
54911  ELSE
54912  xlr2=pmas(pycomp(ksusy1+iabs(ia)+1),1)**2
54913  qlrt=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))*dcmplx(t3i/xw)
54914  ENDIF
54915  ELSEIF(mod(k(n+1,2),ksusy1).EQ.21.OR.mod(k(id,2),ksusy1).EQ.21)
54916  &THEN
54917  iskip=0
54918  ELSE
54919  iskip=0
54920  ENDIF
54921 
54922  IF(iskip.NE.0) THEN
54923  wtmax=0d0
54924  DO 160 kt=1,100
54925  s12=s12min+yjaco1*(kt-1)/99
54926  s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
54927  & *(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
54928  s23df1=(s12-xm(2)**2-xm(1)**2)**2
54929  & -(2d0*xm(1)*xm(2))**2
54930  s23df2=(s12-xm(3)**2-xm(5)**2)**2
54931  & -(2d0*xm(3)*xm(5))**2
54932  s23df1=s23df1*eps
54933  s23df2=s23df2*eps
54934  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*s12)
54935  s23del=s23del/eps
54936  s23min=s23ave-s23del
54937  s23max=s23ave+s23del
54938  yjaco2=s23max-s23min
54939  th=s12
54940  DO 150 ks=1,100
54941  s23=s23min+yjaco2*(ks-1)/99
54942  sh=s23
54943  uh=zm12+zm22-sh-th
54944  wu2 = (uh-zm12)*(uh-zm22)
54945  wt2 = (th-zm12)*(th-zm22)
54946  ws2 = xm1m2*sh
54947  propz2 = (sh-sqmz)**2 + gmmz**2
54948  propz=dcmplx(sh-sqmz,-gmmz)/dcmplx(propz2)
54949  qll=qlls*propz+qllu/dcmplx(uh-xll2)
54950  qlr=qlrs*propz+qlrt/dcmplx(th-xlr2)
54951  qrl=qrls*propz+qrlt/dcmplx(th-xrl2)
54952  qrr=qrrs*propz+qrru/dcmplx(uh-xrr2)
54953  wt0=-((abs(qll)**2+abs(qrr)**2)*wu2+
54954  & (abs(qrl)**2+abs(qlr)**2)*wt2+
54955  & 2d0*dble(qlr*dconjg(qll)+qrl*dconjg(qrr))*ws2)
54956  IF(wt0.GT.wtmax) wtmax=wt0
54957  150 CONTINUE
54958  160 CONTINUE
54959 
54960  wtmax=wtmax*1.05d0
54961  ENDIF
54962 
54963 C...FIND S12*
54964  ax=s12min
54965  cx=s12max
54966  bx=s12min+0.5d0*yjaco1
54967  x0=ax
54968  x3=cx
54969  IF(abs(cx-bx).GT.abs(bx-ax))THEN
54970  x1=bx
54971  x2=bx+c*(cx-bx)
54972  ELSE
54973  x2=bx
54974  x1=bx-c*(bx-ax)
54975  ENDIF
54976 
54977 C...SOLVE FOR F1 AND F2
54978  s23df1=(x1-xm(2)**2-xm(1)**2)**2
54979  &-(2d0*xm(1)*xm(2))**2
54980  s23df2=(x1-xm(3)**2-xm(5)**2)**2
54981  &-(2d0*xm(3)*xm(5))**2
54982  s23df1=s23df1*eps
54983  s23df2=s23df2*eps
54984  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x1)
54985  f1=-2d0*s23del/eps
54986  s23df1=(x2-xm(2)**2-xm(1)**2)**2
54987  &-(2d0*xm(1)*xm(2))**2
54988  s23df2=(x2-xm(3)**2-xm(5)**2)**2
54989  &-(2d0*xm(3)*xm(5))**2
54990  s23df1=s23df1*eps
54991  s23df2=s23df2*eps
54992  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x2)
54993  f2=-2d0*s23del/eps
54994 
54995  170 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2)))THEN
54996 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54997  IF(f2.LE.f1)THEN
54998  x0=x1
54999  x1=x2
55000  x2=r*x1+c*x3
55001  f1=f2
55002  s23df1=(x2-xm(2)**2-xm(1)**2)**2
55003  & -(2d0*xm(1)*xm(2))**2
55004  s23df2=(x2-xm(3)**2-xm(5)**2)**2
55005  & -(2d0*xm(3)*xm(5))**2
55006  s23df1=s23df1*eps
55007  s23df2=s23df2*eps
55008  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x2)
55009  f2=-2d0*s23del/eps
55010  ELSE
55011  x3=x2
55012  x2=x1
55013  x1=r*x2+c*x0
55014  f2=f1
55015  s23df1=(x1-xm(2)**2-xm(1)**2)**2
55016  & -(2d0*xm(1)*xm(2))**2
55017  s23df2=(x1-xm(3)**2-xm(5)**2)**2
55018  & -(2d0*xm(3)*xm(5))**2
55019  s23df1=s23df1*eps
55020  s23df2=s23df2*eps
55021  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x1)
55022  f1=-2d0*s23del/eps
55023  ENDIF
55024  goto 170
55025  ENDIF
55026 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
55027  IF(f1.LT.f2)THEN
55028  golden=-f1
55029  xmin=x1
55030  ELSE
55031  golden=-f2
55032  xmin=x2
55033  ENDIF
55034 
55035  iknt=0
55036  180 s12=s12min+pyr(0)*yjaco1
55037  iknt=iknt+1
55038 C...GENERATE S23
55039  s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
55040  &*(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
55041  s23df1=(s12-xm(2)**2-xm(1)**2)**2
55042  &-(2d0*xm(1)*xm(2))**2
55043  s23df2=(s12-xm(3)**2-xm(5)**2)**2
55044  &-(2d0*xm(3)*xm(5))**2
55045  s23df1=s23df1*eps
55046  s23df2=s23df2*eps
55047  s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*s12)
55048  s23del=s23del/eps
55049  s23min=s23ave-s23del
55050  s23max=s23ave+s23del
55051  yjaco2=s23max-s23min
55052  s23=s23min+pyr(0)*yjaco2
55053 
55054 C...CHECK THE SAMPLING
55055  IF(iknt.GT.100) THEN
55056  WRITE(mstu(11),*) ' IKNT > 100 IN PYTBDY '
55057  goto 190
55058  ENDIF
55059  IF(yjaco2.LT.pyr(0)*golden) goto 180
55060 
55061  IF(iskip.EQ.0) goto 190
55062 
55063  sh=s23
55064  th=s12
55065  uh=zm12+zm22-sh-th
55066 
55067  wu2 = (uh-zm12)*(uh-zm22)
55068  wt2 = (th-zm12)*(th-zm22)
55069  ws2 = xm1m2*sh
55070  propz2 = (sh-sqmz)**2 + gmmz**2
55071  propz=dcmplx(sh-sqmz,-gmmz)/dcmplx(propz2)
55072 
55073  qll=qlls*propz+qllu/dcmplx(uh-xll2)
55074  qlr=qlrs*propz+qlrt/dcmplx(th-xlr2)
55075  qrl=qrls*propz+qrlt/dcmplx(th-xrl2)
55076  qrr=qrrs*propz+qrru/dcmplx(uh-xrr2)
55077 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
55078 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
55079 c &/DCMPLX(TH-XML2)
55080 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
55081 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
55082 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
55083  wt=-((abs(qll)**2+abs(qrr)**2)*wu2+
55084  &(abs(qrl)**2+abs(qlr)**2)*wt2+
55085  &2d0*dble(qlr*dconjg(qll)+qrl*dconjg(qrr))*ws2)
55086 
55087  IF(wt.LT.pyr(0)*wtmax) goto 180
55088  IF(wt.GT.wtmax) print*,' WT > WTMAX ',wt,wtmax
55089 
55090  190 d3=(xm(5)**2+xm(3)**2-s12)/(2d0*xm(5))
55091  d1=(xm(5)**2+xm(1)**2-s23)/(2d0*xm(5))
55092  d2=xm(5)-d1-d3
55093  p1=sqrt(d1*d1-xm(1)**2)
55094  p2=sqrt(d2*d2-xm(2)**2)
55095  p3=sqrt(d3*d3-xm(3)**2)
55096  cthe1=2d0*pyr(0)-1d0
55097  ang1=2d0*pyr(0)*paru(1)
55098  cphi1=cos(ang1)
55099  sphi1=sin(ang1)
55100  arg=1d0-cthe1**2
55101  IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
55102  sthe1=sqrt(arg)
55103  p(n+1,1)=p1*sthe1*cphi1
55104  p(n+1,2)=p1*sthe1*sphi1
55105  p(n+1,3)=p1*cthe1
55106  p(n+1,4)=d1
55107 
55108 C...GET CPHI3
55109  ang3=2d0*pyr(0)*paru(1)
55110  cphi3=cos(ang3)
55111  sphi3=sin(ang3)
55112  cthe3=(p2**2-p1**2-p3**2)/2d0/p1/p3
55113  arg=1d0-cthe3**2
55114  IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
55115  sthe3=sqrt(arg)
55116  p(n+3,1)=-p3*sthe3*cphi3*cthe1*cphi1
55117  &+p3*sthe3*sphi3*sphi1
55118  &+p3*cthe3*sthe1*cphi1
55119  p(n+3,2)=-p3*sthe3*cphi3*cthe1*sphi1
55120  &-p3*sthe3*sphi3*cphi1
55121  &+p3*cthe3*sthe1*sphi1
55122  p(n+3,3)=p3*sthe3*cphi3*sthe1
55123  &+p3*cthe3*cthe1
55124  p(n+3,4)=d3
55125 
55126  DO 200 i=1,3
55127  p(n+2,i)=-p(n+1,i)-p(n+3,i)
55128  200 CONTINUE
55129  p(n+2,4)=d2
55130 
55131  RETURN
55132  END
55133 
55134 
55135 C*********************************************************************
55136 
55137 C...PYTECM
55138 C...Finds the s-hat dependent eigenvalues of the inverse propagator
55139 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
55140 C...phase space generation. Extended to include techni-a meson, and
55141 C...to return the width.
55142 
55143  SUBROUTINE pytecm(SMIN,SMOU,WIDO,IOPT)
55144 
55145 C...Double precision and integer declarations.
55146  IMPLICIT DOUBLE PRECISION(a-h, o-z)
55147  IMPLICIT INTEGER(i-n)
55148  INTEGER pyk,pychge,pycomp
55149 C...Parameter statement to help give large particle numbers.
55150  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
55151  &kexcit=4000000,kdimen=5000000)
55152 C...Commonblocks.
55153  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55154  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
55155  common/pypars/mstp(200),parp(200),msti(200),pari(200)
55156  common/pytcsm/itcm(0:99),rtcm(0:99)
55157  SAVE /pydat1/,/pydat2/,/pypars/,/pytcsm/
55158 
55159 C...Local variables.
55160  DOUBLE PRECISION ar(5,5),wr(5),zr(5,5),zi(5,5),work(12,12),
55161  &at(5,5),wi(5),fv1(5),fv2(5),fv3(5),sh,aem,tanw,ct2w,qupd,alprht,
55162  &far,fao,fzr,fzo,shr,r1,r2,s1,s2,wdtp(0:400),wdte(0:400,0:5),wx(5)
55163  INTEGER i,j,ierr
55164 
55165  sh=smin
55166  shr=sqrt(sh)
55167  aem=pyalem(sh)
55168 
55169  sinw=min(sqrt(paru(102)),1d0)
55170  cosw=sqrt(1d0-sinw**2)
55171  tanw=sinw/cosw
55172  ct2w=(1d0-2d0*paru(102))/(2d0*paru(102)/tanw)
55173  qupd=2d0*rtcm(2)-1d0
55174 
55175  alprht=2.16d0*(3d0/dble(itcm(1)))
55176  far=sqrt(aem/alprht)
55177  fao=far*qupd
55178  fzr=far*ct2w
55179  fzo=-fao*tanw
55180  fzx=-far/rtcm(47)/(2d0*sinw*cosw)
55181  fwr=far/(2d0*sinw)
55182  fwx=-fwr/rtcm(47)
55183 
55184  DO 110 i=1,5
55185  DO 100 j=1,5
55186  at(i,j)=0d0
55187  100 CONTINUE
55188  110 CONTINUE
55189 
55190 C...NC
55191  IF(iopt.EQ.1) THEN
55192  ar(1,1) = sh
55193  ar(2,2) = sh-pmas(23,1)**2
55194  ar(3,3) = sh-pmas(pycomp(ktechn+113),1)**2
55195  ar(4,4) = sh-pmas(pycomp(ktechn+223),1)**2
55196  ar(5,5) = sh-pmas(pycomp(ktechn+115),1)**2
55197  ar(1,2) = 0d0
55198  ar(2,1) = 0d0
55199  ar(1,3) = sh*far
55200  ar(3,1) = ar(1,3)
55201  ar(1,4) = sh*fao
55202  ar(4,1) = ar(1,4)
55203  ar(2,3) = sh*fzr
55204  ar(3,2) = ar(2,3)
55205  ar(2,4) = sh*fzo
55206  ar(4,2) = ar(2,4)
55207  ar(3,4) = 0d0
55208  ar(4,3) = 0d0
55209  ar(2,5) = sh*fzx
55210  ar(5,2) = ar(2,5)
55211  ar(1,5) = 0d0
55212  ar(5,1) = ar(1,5)
55213  ar(3,5) = 0d0
55214  ar(5,3) = ar(3,5)
55215  ar(4,5) = 0d0
55216  ar(5,4) = ar(4,5)
55217  CALL pywidt(23,sh,wdtp,wdte)
55218  at(2,2) = wdtp(0)*shr
55219  CALL pywidt(ktechn+113,sh,wdtp,wdte)
55220  at(3,3) = wdtp(0)*shr
55221  CALL pywidt(ktechn+223,sh,wdtp,wdte)
55222  at(4,4) = wdtp(0)*shr
55223  CALL pywidt(ktechn+115,sh,wdtp,wdte)
55224  at(5,5) = wdtp(0)*shr
55225  idim=5
55226 C...CC
55227  ELSE
55228  ar(1,1) = sh-pmas(24,1)**2
55229  ar(2,2) = sh-pmas(pycomp(ktechn+213),1)**2
55230  ar(3,3) = sh-pmas(pycomp(ktechn+215),1)**2
55231  ar(1,2) = sh*fwr
55232  ar(2,1) = ar(1,2)
55233  ar(1,3) = sh*fwx
55234  ar(3,1) = ar(1,3)
55235  ar(2,3) = 0d0
55236  ar(3,2) = 0d0
55237  CALL pywidt(24,sh,wdtp,wdte)
55238  at(1,1) = wdtp(0)*shr
55239  CALL pywidt(ktechn+213,sh,wdtp,wdte)
55240  at(2,2) = wdtp(0)*shr
55241  CALL pywidt(ktechn+215,sh,wdtp,wdte)
55242  at(3,3) = wdtp(0)*shr
55243  idim=3
55244  ENDIF
55245  CALL pyeicg(idim,idim,ar,at,wr,wi,0,zr,zi,fv1,fv2,fv3,ierr)
55246 
55247  imin=1
55248  sxmn=1d20
55249  DO 120 i=1,idim
55250  wx(i)=sqrt(abs(sh-wr(i)))
55251  wr(i)=abs(wr(i))
55252  IF(wr(i).LT.sxmn) THEN
55253  sxmn=wr(i)
55254  imin=i
55255  ENDIF
55256  120 CONTINUE
55257  smou=wx(imin)**2
55258  wido=wi(imin)/shr
55259 
55260  RETURN
55261  END
55262 C*********************************************************************
55263 
55264 C...PYXDIN
55265 C...Universal Extra Dimensions Model (UED)
55266 C...Initialize the xd masses and widths
55267 C...M. ELKACIMI 4/03/2006
55268 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
55269 
55270  SUBROUTINE pyxdin
55271 
55272 C...Double precision and integer declarations.
55273  IMPLICIT DOUBLE PRECISION(a-h, o-z)
55274  IMPLICIT INTEGER(i-n)
55275  INTEGER pyk,pychge,pycomp
55276 C...Commonblocks.
55277  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55278  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
55279  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
55280 C...UED Pythia common
55281  common/pypued/iued(0:99),rued(0:99)
55282 
55283 C...SAVE statements
55284  SAVE /pydat1/,/pydat3/,/pysubs/,/pypued/
55285 
55286 C...Print out some info about the UED model
55287  WRITE(mstu(11),7000)
55288  & ' ',
55289  & '********** PYXDIN: initialization of UED ******************',
55290  & ' ',
55291  & 'Universal Extra Dimensions (UED) switched on ',
55292  & ' ',
55293  & 'This implementation is courtesy of',
55294  & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
55295  & ' see [hep-ph/0602198] (Les Houches 2005) ',
55296  & ' ',
55297  & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
55298  & 'Dobrescu), with gravity-mediated decay widths calculated in',
55299  & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
55300  & 'radiative corrections to the KK masses from [hep/ph0204342]',
55301  & '(Cheng, Matchev, Schmaltz).'
55302  WRITE(mstu(11),7000)
55303  & ' ',
55304  & 'SM particles can propagate into one small extra dimension ',
55305  & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
55306  & 'graviton is further allowed to propagate into N = IUED(4)',
55307  & 'large (eV^-1) extra dimensions.'
55308  WRITE(mstu(11),7000)
55309  & ' ',
55310  & 'The switches and parameters for UED are:',
55311  & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
55312  & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
55313  & ' IUED(3): (D=5) number of quark flavours',
55314  & ' IUED(4): (D=6) number of large extra dimensions into',
55315  & ' which the graviton propagates',
55316  & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
55317  & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
55318  & ' ',
55319  & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
55320  & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
55321  & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
55322  & ' when IUED(5)=0',
55323  & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
55324  WRITE(mstu(11),7000)
55325  & ' ',
55326  & 'N.B.: the Higgs mass is also a free parameter of the UED ',
55327  & 'model, but is set through pmas(25,1).',
55328  & ' '
55329 
55330 C...Hardcoded switch, required by current implementation
55331  CALL pygive('MSTP(42)=0')
55332 
55333 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
55334  IF(iued(2).EQ.0) CALL pygive('MDCY(C5100022,1)=0')
55335 
55336 C...Calculated the radiative corrections to the KK particle masses
55337  CALL pyuedc
55338 
55339 C...Initialize the graviton mass
55340 C...only if the KK particles decays gravitationally
55341  IF(iued(2).EQ.1) CALL pygram(0)
55342 
55343  WRITE(mstu(11),7000)
55344  & '********** PYXDIN: UED initialization completed ***********'
55345 
55346 C...Format to use for comments
55347  7000 FORMAT(' * ',a)
55348 
55349  RETURN
55350  END
55351 C*********************************************************************
55352 
55353 C...PYUEDC
55354 C...Auxiliary to PYXDIN
55355 C...Mass kk states radiative corrections
55356 C...Radiative corrections are included (hep/ph0204342)
55357 
55358  SUBROUTINE pyuedc
55359 
55360 C...Double precision and integer declarations.
55361  IMPLICIT DOUBLE PRECISION(a-h, o-z)
55362  IMPLICIT INTEGER(i-n)
55363  INTEGER pyk,pychge,pycomp
55364 
55365  parameter(kkpart=25,kkfla=450)
55366 
55367 C...UED Pythia common
55368  common/pypued/iued(0:99),rued(0:99)
55369 C...Pythia common: particles properties
55370  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
55371 C...Parameters.
55372  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55373 C...Decay information.
55374  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
55375 C...Resonance width and secondary decay treatment.
55376  common/pyint4/mwid(500),wids(500,5)
55377  common/pypars/mstp(200),parp(200),msti(200),pari(200)
55378 
55379 C...Local variables
55380  DOUBLE PRECISION pi,qup,qdw
55381  DOUBLE PRECISION wdtp,wdte
55382  dimension wdtp(0:400),wdte(0:400,0:5)
55383  DOUBLE PRECISION q2,alphem,alphs,sw2,cw2,rmkk,rmkk2,zeta3
55384  DOUBLE PRECISION dsmg2,loglam,dbmg2
55385  DOUBLE PRECISION dbmqu,dbmqd,dbmqdo,dbmldo,dbmle
55386  DOUBLE PRECISION dsma2,dsmb2,dbma2,dbmb2
55387  DOUBLE PRECISION rfact,rmw,rmz,rmz2,rmw2,a,b,c,sqrdel,dmb2,dma2
55388  DOUBLE PRECISION sww1,cww1
55389  DOUBLE PRECISION rmgst,rmphst,rmzst,rmwst
55390  DOUBLE PRECISION rmdqst,rmsqus,rmsqds,rmlsld,rmlsle
55391  DOUBLE PRECISION sw21,cw21,sw021,cw021
55392  common/sw1/sw021,cw021
55393 C...UED related declarations:
55394 C...equivalences between ordered particles (451->475)
55395 C...and UED particle code (5 000 000 + id)
55396  dimension iuedeq(475)
55397  DATA (iuedeq(i),i=451,475)/
55398 C...Singlet quarks
55399  & 6100001,6100002,6100003,6100004,6100005,6100006,
55400 C...Doublet quarks
55401  & 5100001,5100002,5100003,5100004,5100005,5100006,
55402 C...Singlet leptons
55403  & 6100011,6100013,6100015,
55404 C...Doublet leptons
55405  & 5100012,5100011,5100014,5100013,5100016,5100015,
55406 C...Gauge boson KK excitations
55407  & 5100021,5100022,5100023,5100024/
55408 
55409 C...N.B. rinv=rued(1)
55410  IF(rued(1).LE.0.)THEN
55411  WRITE(mstu(11),*) 'PYUEDC: RINV < 0 : ',rued(1)
55412  WRITE(mstu(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
55413  RETURN
55414  ENDIF
55415 
55416  pi=dacos(-1.d0)
55417  rmz = pmas(23,1)
55418  rmz2 = rmz**2
55419  rmw = pmas(24,1)
55420  rmw2 = rmw**2
55421  alphem = paru(101)
55422  qup = 2./3.
55423  qdw = -1./3.
55424 
55425 c...qt is q-tilde, qs is q-star
55426 c...strong coupling value
55427  q2 = rued(1)**2
55428  alphs=pyalps(q2)
55429 
55430 c...weak mixing angle
55431  sw2=paru(102)
55432  cw2=1d0-paru(102)
55433 
55434 c...for the mass corrections
55435  rmkk = rued(1)
55436  rmkk2 = rmkk**2
55437  zeta3= 1.2
55438 
55439 C... Either fix the cutoff scale LAMUED
55440  IF(iued(5).EQ.0)THEN
55441  loglam = dlog((rued(3)*(1./rued(1)))**2)
55442 C... or the ratio LAMUED/RINV (=product Lambda*R)
55443  ELSEIF(iued(5).EQ.1)THEN
55444  loglam = dlog(rued(4)**2)
55445  ELSE
55446  WRITE(mstu(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
55447  CALL pystop(6000)
55448  ENDIF
55449 
55450 C...Calculate the radiative corrections for the UED KK masses
55451  IF(iued(6).EQ.1)THEN
55452  rfact=1.d0
55453 C...or induce a minute mass difference
55454 C...keeping the UED KK mass values nearly equal to 1/R
55455  ELSEIF(iued(6).EQ.0)THEN
55456  rfact=0.01d0
55457  ELSE
55458  WRITE(mstu(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
55459  CALL pystop(6001)
55460  ENDIF
55461 
55462 c...Take into account only the strong interactions:
55463 
55464 c...The space bulk corrections :
55465  dsmg2 = rmkk2*(-1.5)*(alphs/4./pi)*zeta3/pi**2
55466 c...The boundary terms:
55467  dbmg2 = rmkk2*(23./2.)*(alphs/4./pi)*loglam
55468 
55469 c...Mass corrections for fermions are extracted from
55470 c...Phys. Rev. D66 036005(2002)9
55471  dbmqdo=rmkk*(3.*(alphs/4./pi)+27./16.*(alphem/4./pi/sw2)
55472  . +1./16.*(alphem/4./pi/cw2))*loglam
55473  dbmqu=rmkk*(3.*(alphs/4./pi)
55474  . +(alphem/4./pi/cw2))*loglam
55475  dbmqd=rmkk*(3.*(alphs/4./pi)
55476  . +0.25*(alphem/4./pi/cw2))*loglam
55477 
55478  dbmldo=rmkk *((27./16.)*(alphem/4./pi/sw2)+9./16.*
55479  . (alphem/4./pi/cw2))*loglam
55480  dbmle=rmkk *(9./4.*(alphem/4./pi/cw2))*loglam
55481 
55482 c...Vector boson masss matrix diagonalization
55483  dbmb2 = rmkk2*(-1./6.)*(alphem/4./pi/cw2)*loglam
55484  dsmb2 = rmkk2*(-39./2.)*(alphem/4./pi**3/cw2)*zeta3
55485  dbma2 = rmkk2*(15./2.)*(alphem/4./pi/sw2)*loglam
55486  dsma2 = rmkk2*(-5./2.)*(alphem/4./pi**3/sw2)*zeta3
55487 
55488 c...Elements of the mass matrix
55489  a = rmz2*sw2 + dbmb2 + dsmb2
55490  b = rmz2*cw2 + dbma2 + dsma2
55491  c = rmz2*dsqrt(sw2*cw2)
55492  sqrdel = dsqrt( (a-b)**2 + 4*c**2 )
55493 
55494 c...Eigenvalues: corrections to X1 and Z1 masses
55495  dmb2 = (a+b-sqrdel)/2.
55496  dma2 = (a+b+sqrdel)/2.
55497 
55498 c...Rotation angles
55499  sww1 = 2*c
55500  cww1 = a-b-sqrdel
55501 C...Weinberg angle
55502  sw21= sww1**2/(sww1**2 + cww1**2)
55503  cw21= 1. - sw21
55504 
55505  sw021=sw21
55506  cw021=cw21
55507 
55508 c...Masses:
55509  rmgst = rmkk+rfact*(dsqrt(rmkk2 + dsmg2 + dbmg2)-rmkk)
55510 
55511  rmdqst=rmkk+rfact*dbmqdo
55512  rmsqus=rmkk+rfact*dbmqu
55513  rmsqds=rmkk+rfact*dbmqd
55514 
55515 C...Note: MZ mass is included in ma2
55516  rmphst= rmkk+rfact*(dsqrt(rmkk2 + dmb2)-rmkk)
55517  rmzst = rmkk+rfact*(dsqrt(rmkk2 + dma2)-rmkk)
55518  rmwst = rmkk+rfact*(dsqrt(rmkk2 + dbma2 + dsma2 + rmw**2)-rmkk)
55519 
55520  rmlsld=rmkk+rfact*dbmldo
55521  rmlsle=rmkk+rfact*dbmle
55522 
55523  DO 100 ipart=1,5,2
55524  pmas(kkfla+ipart,1)=rmsqds
55525  100 CONTINUE
55526  DO 110 ipart=2,6,2
55527  pmas(kkfla+ipart,1)=rmsqus
55528  110 CONTINUE
55529  DO 120 ipart=7,12
55530  pmas(kkfla+ipart,1)=rmdqst
55531  120 CONTINUE
55532  DO 130 ipart=13,15
55533  pmas(kkfla+ipart,1)=rmlsle
55534  130 CONTINUE
55535  DO 140 ipart=16,21
55536  pmas(kkfla+ipart,1)=rmlsld
55537  140 CONTINUE
55538  pmas(kkfla+22,1)=rmgst
55539  pmas(kkfla+23,1)=rmphst
55540  pmas(kkfla+24,1)=rmzst
55541  pmas(kkfla+25,1)=rmwst
55542 
55543  WRITE(mstu(11),7000) ' PYUEDC: ',
55544  & 'UED Mass Spectrum (GeV) :'
55545  WRITE(mstu(11),7100) ' m(d*_S,s*_S,b*_S) = ',rmsqds
55546  WRITE(mstu(11),7100) ' m(u*_S,c*_S,t*_S) = ',rmsqus
55547  WRITE(mstu(11),7100) ' m(q*_D) = ',rmdqst
55548  WRITE(mstu(11),7100) ' m(l*_S) = ',rmlsle
55549  WRITE(mstu(11),7100) ' m(l*_D) = ',rmlsld
55550  WRITE(mstu(11),7100) ' m(g*) = ',rmgst
55551  WRITE(mstu(11),7100) ' m(gamma*) = ',rmphst
55552  WRITE(mstu(11),7100) ' m(Z*) = ',rmzst
55553  WRITE(mstu(11),7100) ' m(W*) = ',rmwst
55554  WRITE(mstu(11),7000) ' '
55555 
55556 C...Initialize widths, branching ratios and life time
55557  DO 199 ipart=1,25
55558  kc=kkfla+ipart
55559  IF(mwid(kc).EQ.1.AND.mdcy(kc,1).EQ.1)THEN
55560  CALL pywidt(iuedeq(kc),pmas(kc,1)**2,wdtp,wdte)
55561  IF(wdtp(0).LE.0)THEN
55562  WRITE(mstu(11),*)
55563  + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', kc
55564  WRITE(mstu(11),*) 'INITIAL VALUE IS TAKEN',pmas(kc,2)
55565  goto 199
55566  ELSE
55567  DO 180 idc=1,mdcy(kc,3)
55568  ic=idc+mdcy(kc,2)-1
55569  IF(mdme(ic,1).EQ.1.AND.wdtp(idc).GT.0.)THEN
55570 C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
55571  pmas(kc,4)=paru(3)/wdtp(idc)*1.d-12
55572  brat(ic)=wdtp(idc)/wdtp(0)
55573  ENDIF
55574  180 CONTINUE
55575  ENDIF
55576  ENDIF
55577  199 CONTINUE
55578 
55579 C...Format to use for comments
55580  7000 FORMAT(' * ',a)
55581  7100 FORMAT(' * ',a,f12.3)
55582 
55583  END
55584 C********************************************************************
55585 C...PYXUED
55586 C... Last change:
55587 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
55588 C... Original version:
55589 C... M. El Kacimi
55590 C... 05/07/2005
55591 C Universal Extra Dimensions Subprocess cross sections
55592 C The expressions used are from atl-com-phys-2005-003
55593 C What is coded here is shat**2/pi * dsigma/dt = |M|**2
55594 C For each UED subprocess, the color flow used is the same
55595 C as the equivalent QCD subprocess. Different configuration
55596 C color flows are considered to have the same probability.
55597 C
55598 C The Xsection is calculated following ATL-PHYS-PUB-2005-003
55599 C by G.Azuelos and P.H.Beauchemin.
55600 C
55601 C This routine is called from pysigh.
55602 
55603  SUBROUTINE pyxued(NCHN,SIGS)
55604 
55605 C...Double precision and integer declarations
55606  IMPLICIT DOUBLE PRECISION(a-h, o-z)
55607  IMPLICIT INTEGER(i-n)
55608 C...
55609  INTEGER ngrdec
55610  common/decmod/ngrdec
55611 C...
55612  parameter(kkpart=25,kkfla=450)
55613 C...Commonblocks
55614  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
55615  common/pypars/mstp(200),parp(200),msti(200),pari(200)
55616  common/pyint1/mint(400),vint(400)
55617  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
55618  common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
55619  &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
55620  &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
55621  &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
55622  SAVE /pydat2/,/pyint1/,/pyint3/,/pypars/
55623 C...UED Pythia common
55624  common/pypued/iued(0:99),rued(0:99)
55625 C...Local arrays and complex variables
55626  DOUBLE PRECISION shat,sp,that,tp,uhat,up,alphas
55627  + ,fac1,xmnkk,xmued,sigs
55628  INTEGER nchn
55629 
55630 C...Return if UED not switched on
55631  IF (iued(1).LE.0) THEN
55632  RETURN
55633  ENDIF
55634 
55635 C...Energy scale of the parton processus
55636 C...taken equal to the mass of the final state kk
55637 c Q2=XMNKK**2
55638 
55639 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
55640  xmnkk=pmas(kkfla+23,1)
55641 
55642 C...To compare the cross section with phys-pub-2005-03
55643 C...(no radiative corrections),
55644 C...take xmnkk=rinv and q2=rinv**2
55645 c++lnk
55646 C...n.b. (rinv=rued(1))
55647 c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
55648  IF(ngrdec.EQ.1)xmnkk=rued(1)
55649 c--lnk
55650 
55651  shat=vint(44)
55652  sp=shat
55653  that=vint(45)
55654  tp=that-xmnkk**2
55655  uhat=vint(46)
55656  up=uhat-xmnkk**2
55657  beta34=dsqrt(1.d0-4.d0*xmnkk**2/shat)
55658  pi=dacos(-1.d0)
55659 c++lnk
55660 c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
55661  q2=rued(1)**2+(tp*up-rued(1)**4)/sp
55662 
55663 c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
55664  IF(ngrdec.EQ.1)q2=rued(1)**2
55665 c--lnk
55666 
55667 C...Strong coupling value
55668  alphas=pyalps(q2)
55669 
55670  IF(isub.EQ.311)THEN
55671 C...gg --> g* g*
55672  fac1=9./8.*alphas**2/(sp*tp*up)**2
55673  xmued=fac1*(xmnkk**4*(6.*tp**4+18.*tp**3*up+
55674  & 24.*tp**2*up**2+18.*tp*up**3+6.*up**4)
55675  & +xmnkk**2*(6.*tp**4*up+12.*tp**3*up**2+
55676  & 12.*tp**2*up**3+6*tp*up**4)
55677  & +2.*tp**6+6*tp**5*up+13*tp**4*up**2+
55678  & 15.*tp**3*up**3+13*tp**2*up**4+
55679  & 6.*tp*up**5+2.*up**6)
55680  nchn=nchn+1
55681  isig(nchn,1)=21
55682  isig(nchn,2)=21
55683 C...Three color flow configurations (qcd g+g->g+g)
55684  xcol=pyr(0)
55685  IF(xcol.LE.1./3.)THEN
55686  isig(nchn,3)=1
55687  ELSEIF(xcol.LE.2./3.)THEN
55688  isig(nchn,3)=2
55689  ELSE
55690  isig(nchn,3)=3
55691  ENDIF
55692  sigh(nchn)=comfac*xmued
55693  ELSEIF(isub.EQ.312)THEN
55694 C...q + g -> q*_D + g*, q*_S + g*
55695 C...(the two channels have the same cross section)
55696  fac1=-1./36.*alphas**2/(sp*tp*up)**2
55697  xmued=fac1*(12.*sp*up**5+5.*sp**2*up**4+22.*sp**3*up**3+
55698  & 5.*sp**4*up**2+12.*sp**5*up)
55699  xmued=comfac*2.*xmued
55700 
55701  DO 190 i=mmina,mmaxa
55702  IF(i.EQ.0.OR.iabs(i).GT.10) goto 190
55703  DO 180 isde=1,2
55704 
55705  IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 180
55706  IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 180
55707  nchn=nchn+1
55708  isig(nchn,isde)=i
55709  isig(nchn,3-isde)=21
55710  isig(nchn,3)=1
55711  sigh(nchn)=xmued
55712  IF(pyr(0).GT.0.5)isig(nchn,3)=2
55713  180 CONTINUE
55714  190 CONTINUE
55715 
55716  ELSEIF(isub.EQ.313)THEN
55717 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
55718 C...(the two channels have the same cross section)
55719 C...qi and qj have the same charge sign
55720  DO 100 i=mmin1,mmax1
55721  ia=iabs(i)
55722  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 100
55723  DO 101 j=mmin2,mmax2
55724  ja=iabs(j)
55725  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).
55726  & eq.0) goto 101
55727  IF(j*i.LE.0)goto 101
55728  nchn=nchn+1
55729  isig(nchn,1)=i
55730  isig(nchn,2)=j
55731  IF(j.EQ.i)THEN
55732  fac1=1./72.*alphas**2/(tp*up)**2
55733  xmued=fac1*
55734  & (xmnkk**2*(8*tp**3+4./3.*tp**2*up+4./3.*tp*up**2
55735  & +8.*up**3)+8.*tp**4+56./3.*tp**3*up+
55736  & 20.*tp**2*up**2+56./3.*
55737  & tp*up**3+8.*up**4)
55738  sigh(nchn)=comfac*2.*xmued
55739  isig(nchn,3)=1
55740  IF(pyr(0).GT.0.5)isig(nchn,3)=2
55741  ELSE
55742  fac1=2./9.*alphas**2/tp**2
55743  xmued=fac1*(-xmnkk**2*sp+sp**2+0.25*tp**2)
55744  sigh(nchn)=comfac*2.*xmued
55745  isig(nchn,3)=1
55746  ENDIF
55747  101 CONTINUE
55748  100 CONTINUE
55749  ELSEIF(isub.EQ.314)THEN
55750 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
55751 C...(the two channels have the same cross section)
55752  nchn=nchn+1
55753  isig(nchn,1)=21
55754  isig(nchn,2)=21
55755  isig(nchn,3)=int(1.5+pyr(0))
55756 
55757  fac1=5./6.*alphas**2/(sp*tp*up)**2
55758  xmued=fac1*(-xmnkk**4*(8.*tp*up**3+8.*tp**2*up**2+8.*tp**3*up
55759  + +4.*up**4+4*tp**4)
55760  + -xmnkk**2*(0.5*tp*up**4+4.*tp**2*up**3+15./2.*tp**3
55761  + *up**2+ 4.*tp**4*up)+tp*up**5-0.25*tp**2*up**4+
55762  + 2.*tp**3*up**3-0.25*tp**4*up**2+tp**5*up)
55763 
55764  sigh(nchn)=comfac*xmued
55765 C...has been multiplied by 5: all possible quark flavors in final state
55766 
55767  ELSEIF(isub.EQ.315)THEN
55768 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
55769 C...(the two channels have the same cross section)
55770  DO 141 i=mmin1,mmax1
55771  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
55772  & kfac(1,i)*kfac(2,-i).EQ.0) goto 141
55773  DO 142 j=mmin2,mmax2
55774  IF(j.EQ.0.OR.abs(i).NE.abs(j).OR.i*j.GE.0) goto 142
55775  fac1=2./9.*alphas**2*1./(sp*tp)**2
55776  xmued=fac1*(xmnkk**2*sp*(4.*tp**2-sp*tp-sp**2)+
55777  & 4.*tp**4+3.*sp*tp**3+11./12.*tp**2*sp**2-
55778  & 2./3.*sp**3*tp+sp**4)
55779  nchn=nchn+1
55780  isig(nchn,1)=i
55781  isig(nchn,2)=-i
55782  isig(nchn,3)=1
55783  sigh(nchn)=comfac*2.*xmued
55784  142 CONTINUE
55785  141 CONTINUE
55786  ELSEIF(isub.EQ.316)THEN
55787 C...q + qbar' -> q*_D + q*_Sbar'
55788  fac1=2./9.*alphas**2
55789  DO 300 i=mmin1,mmax1
55790  ia=iabs(i)
55791  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 300
55792  DO 301 j=mmin2,mmax2
55793  ja=iabs(j)
55794  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 301
55795  IF(j*i.GE.0.OR.ia.EQ.ja)goto 301
55796  nchn=nchn+1
55797  isig(nchn,1)=i
55798  isig(nchn,2)=j
55799  isig(nchn,3)=1
55800  fac1=2./9.*alphas**2/tp**2
55801  xmued=fac1*(-xmnkk**2*sp+sp**2+0.25*tp**2)
55802  sigh(nchn)=comfac*xmued
55803  301 CONTINUE
55804  300 CONTINUE
55805 
55806  ELSEIF(isub.EQ.317)THEN
55807 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
55808 C...(the two channels have the same cross section)
55809  DO 400 i=mmin1,mmax1
55810  ia=iabs(i)
55811  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 400
55812  DO 401 j=mmin1,mmax1
55813  ja=iabs(j)
55814  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 401
55815  IF(j*i.GE.0.OR.ia.EQ.ja)goto 401
55816  nchn=nchn+1
55817  isig(nchn,1)=i
55818  isig(nchn,2)=j
55819  isig(nchn,3)=1
55820  fac1=1./18.*alphas**2/tp**2
55821  xmued=fac1*(4.*xmnkk**2*sp+4.*sp**2+8.*sp*tp+5*tp**2)
55822  sigh(nchn)=comfac*2.*xmued
55823  401 CONTINUE
55824  400 CONTINUE
55825  ELSEIF(isub.EQ.318)THEN
55826 C...q + q' -> q*_D + q*_S'
55827  DO 500 i=mmin1,mmax1
55828  ia=iabs(i)
55829  IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 500
55830  DO 501 j=mmin2,mmax2
55831  ja=iabs(j)
55832  IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 501
55833  IF(j*i.LE.0)goto 501
55834  IF(ia.EQ.ja)THEN
55835  nchn=nchn+1
55836  isig(nchn,1)=i
55837  isig(nchn,2)=j
55838  isig(nchn,3)=int(1.5+pyr(0))
55839  fac1=1./36.*alphas**2/(tp*up)**2
55840  xmued=fac1*(-8.*xmnkk**2*(tp**3+tp**2*up+tp*up**2+up**3)
55841  & +8.*tp**4+4.*tp**2*up**2+8.*up**4)
55842  sigh(nchn)=comfac*xmued
55843  ELSE
55844  nchn=nchn+1
55845  isig(nchn,1)=i
55846  isig(nchn,2)=j
55847  isig(nchn,3)=1
55848  fac1=1./18.*alphas**2/tp**2
55849  xmued=fac1*(4.*xmnkk**2*sp+4.*sp**2+8.*sp*tp+5*tp**2)
55850  sigh(nchn)=comfac*2.*xmued
55851  ENDIF
55852  501 CONTINUE
55853  500 CONTINUE
55854  ELSEIF(isub.EQ.319)THEN
55855 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55856 C...(the two channels have the same cross section)
55857  DO 741 i=mmin1,mmax1
55858  IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
55859  & kfac(1,i)*kfac(2,-i).EQ.0) goto 741
55860  DO 742 j=mmin2,mmax2
55861  IF(j.EQ.0.OR.iabs(j).NE.iabs(i).OR.j*i.GT.0) goto 742
55862  fac1=16./9.*alphas**2*1./(sp)**2
55863  xmued=fac1*(2.*xmnkk**2*sp+sp**2+2.*sp*tp+2.*tp**2)
55864  nchn=nchn+1
55865  isig(nchn,1)=i
55866  isig(nchn,2)=-i
55867  isig(nchn,3)=1
55868  sigh(nchn)=comfac*2.*xmued
55869  742 CONTINUE
55870  741 CONTINUE
55871 
55872  ENDIF
55873 
55874  RETURN
55875  END
55876 C*********************************************************************
55877 
55878 C...PYGRAM
55879 C...Universal Extra Dimensions Model (UED)
55880 C...Computation of the Graviton mass.
55881 
55882  SUBROUTINE pygram(IN)
55883 
55884 C...Double precision and integer declarations
55885  IMPLICIT DOUBLE PRECISION(a-h, o-z)
55886  IMPLICIT INTEGER(i-n)
55887 
55888 C...Pythia commonblocks
55889  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55890  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
55891 C...UED Pythia common
55892  common/pypued/iued(0:99),rued(0:99)
55893 
55894 C...Local variables
55895  INTEGER kcfla,nmax
55896  parameter(kcfla=450,nmax=5000)
55897  dimension yvec(5000),resvec(5000)
55898  common/intsav/ysav,ymax,resmax
55899  common/uedgra/xmplnk,xmd,rinv,ndim
55900  common/kappa/xkappa
55901 
55902 C...External function (used in call to PYGAUS)
55903  EXTERNAL pygraw
55904 
55905 C...SAVE statements
55906  SAVE /pydat1/,/pydat2/,/pypued/,/intsav/
55907 
55908 C...Initialization
55909  ndim=iued(4)
55910  rinv=rued(1)
55911  xmd=rued(2)
55912  pi=paru(1)
55913 
55914 C...Initialize for numerical integration
55915  xmplnk=2.4d+18
55916  xkappa=dsqrt(2.d0)/xmplnk
55917 
55918 C...For NDIM=2, compute graviton mass distribution numerically
55919  IF(ndim.EQ.2)THEN
55920 
55921 C... For first event: tabulate distribution of stepwise integrals:
55922 C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55923  IF(in.EQ.0)THEN
55924  resmax = 0d0
55925  ymax = 0d0
55926  DO 100 i=1,nmax
55927  ysav = (i-0.5)/dble(nmax)
55928  tol = 1d-6
55929 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55930  resint = pygaus(pygraw,0d0,1d0,tol)
55931  yvec(i) = ysav
55932  resvec(i) = resint
55933 C... Save max of distribution (for accept/reject below)
55934  IF(resint.GT.resmax)THEN
55935  resmax = resint
55936  ymax = yvec(i)
55937  ENDIF
55938  100 CONTINUE
55939  ENDIF
55940 
55941 C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55942  pcujet=1d0
55943  kcgakk=kcfla+23
55944  xmgamk=pmas(kcgakk,1)
55945 
55946 C... Pick random graviton mass, accept according to stored integrals
55947  ammax=dsqrt(xmgamk**2-2d0*xmgamk*pcujet)
55948  110 rmg=ammax*pyr(0)
55949  x=rmg/xmgamk
55950 
55951 C... Bin enumeration starts at 1, but make sure always in range
55952  ibin=int(nmax*x)+1
55953  ibin=min(ibin,nmax)
55954  IF(resvec(ibin)/resmax.LT.pyr(0)) goto 110
55955 
55956 C... For NDIM=4 and 6, the analytical expression for the
55957 C... graviton mass distribution integral is used.
55958  ELSEIF(ndim.EQ.4.OR.ndim.EQ.6)THEN
55959 
55960 C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55961  pcujet=1d0
55962 
55963 C... KK photon (?) compressed code and mass
55964  kcgakk=kcfla+23
55965  xmgamk=pmas(kcgakk,1)
55966 
55967 C... Find maximum of (dGamma/dMg)
55968  IF(in.EQ.0)THEN
55969  resmax=0d0
55970  ymax=0d0
55971  DO 120 i=1,nmax-1
55972  y=i/dble(nmax)
55973  resint=y**(ndim-3)*(1d0/(1d0-y**2))*(1d0+dcos(pi*y))
55974  IF(resint.GE.resmax)THEN
55975  resmax=resint
55976  ymax=y
55977  ENDIF
55978  120 CONTINUE
55979  ENDIF
55980 
55981 C... Pick random graviton mass, accept/reject
55982  ammax=dsqrt(xmgamk**2-2d0*xmgamk*pcujet)
55983  130 rmg=ammax*pyr(0)
55984  x=rmg/xmgamk
55985  dgadmg=x**(ndim-3)*(1./(1.-x**2))*(1.+dcos(pi*x))
55986  IF(dgadmg/resmax.LT.pyr(0)) goto 130
55987 
55988 C... If the user has not chosen N=2,4 or 6, STOP
55989  ELSE
55990  WRITE(mstu(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',ndim,
55991  & ' (MUST BE 2, 4, OR 6) '
55992  CALL pystop(6002)
55993  ENDIF
55994 
55995 C... Now store the sampled Mg
55996  pmas(39,1)=rmg
55997 
55998  RETURN
55999  END
56000 
56001 C*********************************************************************
56002 
56003 C...PYGRAW
56004 C...Universal Extra Dimensions Model (UED)
56005 C...
56006 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
56007 C...
56008 C...Integrand for the KK boson -> SM boson + graviton
56009 C...graviton mass distribution (and gravity mediated total width),
56010 C...which contains (see 0201300 and below for the full product)
56011 C...the gravity mediated partial decay width Gamma(xx, yy)
56012 C... i.e. GRADEN(YY)*PYWDKK(XXA)
56013 C... where xx is exclusive to gravity
56014 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
56015 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
56016 
56017  DOUBLE PRECISION FUNCTION pygraw(YIN)
56018 
56019 C...Double precision and integer declarations
56020  IMPLICIT DOUBLE PRECISION (a-h,o-z)
56021  IMPLICIT integer(i-n)
56022 
56023 C...Pythia commonblocks
56024  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
56025 
56026 C...Local UED commonblocks and variables
56027  common/uedgra/xmplnk,xmd,rinv,ndim
56028  common/intsav/ysav,ymax,resmax
56029 
56030 C...SAVE statements
56031  SAVE /pydat1/,/intsav/
56032 
56033 C...External: Pythia's Gamma function
56034  EXTERNAL pygamm
56035 
56036 C...Pi
56037  pi=paru(1)
56038  pi2=pi*pi
56039 
56040  ymin=1.d-9/rinv
56041  yy=ysav
56042  xx=dsqrt(1.-yy**2)*yin
56043  djac=(1.-ymin)*dsqrt(1.-yy**2)
56044  fac=2.*pi**((ndim-1.)/2.)*xmplnk**2*rinv**ndim/xmd**(ndim+2)
56045  xnd=(ndim-1.)/2.
56046  gammn=pygamm(xnd)
56047  fac=fac/gammn
56048  xxa=dsqrt(xx**2+yy**2)
56049  graden=4./pi2 * (yy**2/(1.-yy**2)**2)*(1.+dcos(pi*yy))
56050 
56051  pygraw=djac*
56052  + fac*xx**(ndim-2)*graden*pywdkk(xxa)
56053 
56054  RETURN
56055  END
56056 C*********************************************************************
56057 
56058 C...PYWDKK
56059 C...Universal Extra Dimensions Model (UED)
56060 C...
56061 C...Multiplied by the square modulus of a form factor
56062 C...(see GRADEN in function PYGRAW)
56063 C...PYWDKK is the KK boson -> SM boson + graviton
56064 C...gravity mediated partial decay width Gamma(xx, yy)
56065 C... where xx is exclusive to gravity
56066 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
56067 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
56068 C...
56069 C...N.B. The Feynman rules for the couplings of the graviton fields
56070 C...to the UED fields are related to the corresponding couplings of
56071 C...the graviton fields to the SM fields by the form factor.
56072 
56073  DOUBLE PRECISION FUNCTION pywdkk(X)
56074 
56075 C...Double precision and integer declarations
56076  IMPLICIT DOUBLE PRECISION (a-h,o-z)
56077  IMPLICIT integer(i-n)
56078 
56079 C...Pythia commonblocks
56080  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
56081  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
56082 
56083 C...Local UED commonblocks and variables
56084  common/uedgra/xmplnk,xmd,rinv,ndim
56085  common/kappa/xkappa
56086 
56087 C...SAVE statements
56088  SAVE /pydat1/,/pydat2/,/uedgra/,/kappa/
56089 
56090  pi=paru(1)
56091 
56092 C...gamma* mass 473
56093  kcqkk=473
56094  xmnkk=pmas(kcqkk,1)
56095 
56096 C...Bosons partial width Macesanu hep-ph/0201300
56097  pywdkk=xkappa**2/(96.*pi)*xmnkk**3/x**4*
56098  + ((1.-x**2)**2*(1.+3.*x**2+6.*x**4))
56099 
56100  RETURN
56101  END
56102 
56103 C*********************************************************************
56104 
56105 C...PYEIGC
56106 C...Finds eigenvalues of a general complex matrix
56107 C
56108 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
56109 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
56110 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
56111 C OF A COMPLEX GENERAL MATRIX.
56112 C
56113 C ON INPUT
56114 C
56115 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
56116 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56117 C DIMENSION STATEMENT.
56118 C
56119 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
56120 C
56121 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56122 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
56123 C
56124 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
56125 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
56126 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
56127 C
56128 C ON OUTPUT
56129 C
56130 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56131 C RESPECTIVELY, OF THE EIGENVALUES.
56132 C
56133 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56134 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
56135 C
56136 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
56137 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
56138 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
56139 C
56140 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
56141 C
56142 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56143 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56144 C
56145 C THIS VERSION DATED AUGUST 1983.
56146 C
56147 
56148  SUBROUTINE pyeicg(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
56149 
56150  INTEGER n,nm,is1,is2,ierr,matz
56151  DOUBLE PRECISION ar(5,5),ai(5,5),wr(5),wi(5),zr(5,5),zi(5,5),
56152  x fv1(5),fv2(5),fv3(5)
56153  IF (n .LE. nm) goto 100
56154  ierr = 10 * n
56155  goto 120
56156 C
56157  100 CALL pycbal(nm,n,ar,ai,is1,is2,fv1)
56158  CALL pycrth(nm,n,is1,is2,ar,ai,fv2,fv3)
56159  IF (matz .NE. 0) goto 110
56160 C .......... FIND EIGENVALUES ONLY ..........
56161  CALL pycmqr(nm,n,is1,is2,ar,ai,wr,wi,ierr)
56162  goto 120
56163 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
56164  110 CALL pycmq2(nm,n,is1,is2,fv2,fv3,ar,ai,wr,wi,zr,zi,ierr)
56165  IF (ierr .NE. 0) goto 120
56166  CALL pycba2(nm,n,is1,is2,fv1,n,zr,zi)
56167  120 RETURN
56168  END
56169 
56170 C*********************************************************************
56171 
56172 C...PYCMQR
56173 C...Auxiliary to PYEICG.
56174 C
56175 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56176 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
56177 C AND WILKINSON.
56178 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
56179 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56180 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56181 C
56182 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
56183 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
56184 C
56185 C ON INPUT
56186 C
56187 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56188 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56189 C DIMENSION STATEMENT.
56190 C
56191 C N IS THE ORDER OF THE MATRIX.
56192 C
56193 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56194 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56195 C SET LOW=1, IGH=N.
56196 C
56197 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56198 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56199 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
56200 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
56201 C THE REDUCTION BY CORTH, IF PERFORMED.
56202 C
56203 C ON OUTPUT
56204 C
56205 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
56206 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
56207 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
56208 C EIGENVECTORS IS TO BE PERFORMED.
56209 C
56210 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56211 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56212 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56213 C FOR INDICES IERR+1,...,N.
56214 C
56215 C IERR IS SET TO
56216 C ZERO FOR NORMAL RETURN,
56217 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56218 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56219 C
56220 C CALLS PYCDIV FOR COMPLEX DIVISION.
56221 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56222 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56223 C
56224 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56225 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56226 C
56227 C THIS VERSION DATED AUGUST 1983.
56228 C
56229 
56230  SUBROUTINE pycmqr(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
56231 
56232  INTEGER i,j,l,n,en,ll,nm,igh,itn,its,low,lp1,enm1,ierr
56233  DOUBLE PRECISION hr(5,5),hi(5,5),wr(5),wi(5)
56234  DOUBLE PRECISION si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm,tst1,tst2,
56235  x pythag
56236 
56237  ierr = 0
56238  IF (low .EQ. igh) goto 130
56239 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56240  l = low + 1
56241 C
56242  DO 120 i = l, igh
56243  ll = min0(i+1,igh)
56244  IF (hi(i,i-1) .EQ. 0.0d0) goto 120
56245  norm = pythag(hr(i,i-1),hi(i,i-1))
56246  yr = hr(i,i-1) / norm
56247  yi = hi(i,i-1) / norm
56248  hr(i,i-1) = norm
56249  hi(i,i-1) = 0.0d0
56250 C
56251  DO 100 j = i, igh
56252  si = yr * hi(i,j) - yi * hr(i,j)
56253  hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
56254  hi(i,j) = si
56255  100 CONTINUE
56256 C
56257  DO 110 j = low, ll
56258  si = yr * hi(j,i) + yi * hr(j,i)
56259  hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
56260  hi(j,i) = si
56261  110 CONTINUE
56262 C
56263  120 CONTINUE
56264 C .......... STORE ROOTS ISOLATED BY CBAL ..........
56265  130 DO 140 i = 1, n
56266  IF (i .GE. low .AND. i .LE. igh) goto 140
56267  wr(i) = hr(i,i)
56268  wi(i) = hi(i,i)
56269  140 CONTINUE
56270 C
56271  en = igh
56272  tr = 0.0d0
56273  ti = 0.0d0
56274  itn = 30*n
56275 C .......... SEARCH FOR NEXT EIGENVALUE ..........
56276  150 IF (en .LT. low) goto 320
56277  its = 0
56278  enm1 = en - 1
56279 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56280 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
56281  160 DO 170 ll = low, en
56282  l = en + low - ll
56283  IF (l .EQ. low) goto 180
56284  tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
56285  x + dabs(hr(l,l)) + dabs(hi(l,l))
56286  tst2 = tst1 + dabs(hr(l,l-1))
56287  IF (tst2 .EQ. tst1) goto 180
56288  170 CONTINUE
56289 C .......... FORM SHIFT ..........
56290  180 IF (l .EQ. en) goto 300
56291  IF (itn .EQ. 0) goto 310
56292  IF (its .EQ. 10 .OR. its .EQ. 20) goto 200
56293  sr = hr(en,en)
56294  si = hi(en,en)
56295  xr = hr(enm1,en) * hr(en,enm1)
56296  xi = hi(enm1,en) * hr(en,enm1)
56297  IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) goto 210
56298  yr = (hr(enm1,enm1) - sr) / 2.0d0
56299  yi = (hi(enm1,enm1) - si) / 2.0d0
56300  CALL pycsrt(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
56301  IF (yr * zzr + yi * zzi .GE. 0.0d0) goto 190
56302  zzr = -zzr
56303  zzi = -zzi
56304  190 CALL pycdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
56305  sr = sr - xr
56306  si = si - xi
56307  goto 210
56308 C .......... FORM EXCEPTIONAL SHIFT ..........
56309  200 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
56310  si = 0.0d0
56311 C
56312  210 DO 220 i = low, en
56313  hr(i,i) = hr(i,i) - sr
56314  hi(i,i) = hi(i,i) - si
56315  220 CONTINUE
56316 C
56317  tr = tr + sr
56318  ti = ti + si
56319  its = its + 1
56320  itn = itn - 1
56321 C .......... REDUCE TO TRIANGLE (ROWS) ..........
56322  lp1 = l + 1
56323 C
56324  DO 240 i = lp1, en
56325  sr = hr(i,i-1)
56326  hr(i,i-1) = 0.0d0
56327  norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
56328  xr = hr(i-1,i-1) / norm
56329  wr(i-1) = xr
56330  xi = hi(i-1,i-1) / norm
56331  wi(i-1) = xi
56332  hr(i-1,i-1) = norm
56333  hi(i-1,i-1) = 0.0d0
56334  hi(i,i-1) = sr / norm
56335 C
56336  DO 230 j = i, en
56337  yr = hr(i-1,j)
56338  yi = hi(i-1,j)
56339  zzr = hr(i,j)
56340  zzi = hi(i,j)
56341  hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
56342  hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
56343  hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
56344  hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
56345  230 CONTINUE
56346 C
56347  240 CONTINUE
56348 C
56349  si = hi(en,en)
56350  IF (si .EQ. 0.0d0) goto 250
56351  norm = pythag(hr(en,en),si)
56352  sr = hr(en,en) / norm
56353  si = si / norm
56354  hr(en,en) = norm
56355  hi(en,en) = 0.0d0
56356 C .......... INVERSE OPERATION (COLUMNS) ..........
56357  250 DO 280 j = lp1, en
56358  xr = wr(j-1)
56359  xi = wi(j-1)
56360 C
56361  DO 270 i = l, j
56362  yr = hr(i,j-1)
56363  yi = 0.0d0
56364  zzr = hr(i,j)
56365  zzi = hi(i,j)
56366  IF (i .EQ. j) goto 260
56367  yi = hi(i,j-1)
56368  hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
56369  260 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
56370  hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
56371  hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
56372  270 CONTINUE
56373 C
56374  280 CONTINUE
56375 C
56376  IF (si .EQ. 0.0d0) goto 160
56377 C
56378  DO 290 i = l, en
56379  yr = hr(i,en)
56380  yi = hi(i,en)
56381  hr(i,en) = sr * yr - si * yi
56382  hi(i,en) = sr * yi + si * yr
56383  290 CONTINUE
56384 C
56385  goto 160
56386 C .......... A ROOT FOUND ..........
56387  300 wr(en) = hr(en,en) + tr
56388  wi(en) = hi(en,en) + ti
56389  en = enm1
56390  goto 150
56391 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56392 C CONVERGED AFTER 30*N ITERATIONS ..........
56393  310 ierr = en
56394  320 RETURN
56395  END
56396 
56397 C*********************************************************************
56398 
56399 C...PYCMQ2
56400 C...Auxiliary to PYEICG.
56401 C
56402 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56403 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
56404 C AND WILKINSON.
56405 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
56406 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56407 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56408 C
56409 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
56410 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
56411 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
56412 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
56413 C THIS GENERAL MATRIX TO HESSENBERG FORM.
56414 C
56415 C ON INPUT
56416 C
56417 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56418 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56419 C DIMENSION STATEMENT.
56420 C
56421 C N IS THE ORDER OF THE MATRIX.
56422 C
56423 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56424 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56425 C SET LOW=1, IGH=N.
56426 C
56427 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
56428 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
56429 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
56430 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
56431 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
56432 C
56433 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56434 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56435 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
56436 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
56437 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
56438 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
56439 C ARBITRARY.
56440 C
56441 C ON OUTPUT
56442 C
56443 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
56444 C HAVE BEEN DESTROYED.
56445 C
56446 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56447 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56448 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56449 C FOR INDICES IERR+1,...,N.
56450 C
56451 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56452 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
56453 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
56454 C THE EIGENVECTORS HAS BEEN FOUND.
56455 C
56456 C IERR IS SET TO
56457 C ZERO FOR NORMAL RETURN,
56458 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56459 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56460 C
56461 C CALLS PYCDIV FOR COMPLEX DIVISION.
56462 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56463 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56464 C
56465 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56466 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56467 C
56468 C THIS VERSION DATED OCTOBER 1989.
56469 C
56470 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
56471 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
56472 C
56473 
56474  SUBROUTINE pycmq2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
56475 
56476  INTEGER i,j,k,l,m,n,en,ii,jj,ll,nm,nn,igh,ip1,
56477  x itn,its,low,lp1,enm1,iend,ierr
56478  DOUBLE PRECISION hr(5,5),hi(5,5),wr(5),wi(5),zr(5,5),zi(5,5),
56479  x ortr(5),orti(5)
56480  DOUBLE PRECISION si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm,tst1,tst2,
56481  x pythag
56482 
56483  ierr = 0
56484 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
56485  DO 110 j = 1, n
56486 C
56487  DO 100 i = 1, n
56488  zr(i,j) = 0.0d0
56489  zi(i,j) = 0.0d0
56490  100 CONTINUE
56491  zr(j,j) = 1.0d0
56492  110 CONTINUE
56493 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
56494 C FROM THE INFORMATION LEFT BY CORTH ..........
56495  iend = igh - low - 1
56496  IF (iend.LT.0) goto 220
56497  IF (iend.EQ.0) goto 170
56498 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
56499  DO 160 ii = 1, iend
56500  i = igh - ii
56501  IF (ortr(i) .EQ. 0.0d0 .AND. orti(i) .EQ. 0.0d0) goto 160
56502  IF (hr(i,i-1) .EQ. 0.0d0 .AND. hi(i,i-1) .EQ. 0.0d0) goto 160
56503 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
56504  norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)
56505  ip1 = i + 1
56506 C
56507  DO 120 k = ip1, igh
56508  ortr(k) = hr(k,i-1)
56509  orti(k) = hi(k,i-1)
56510  120 CONTINUE
56511 C
56512  DO 150 j = i, igh
56513  sr = 0.0d0
56514  si = 0.0d0
56515 C
56516  DO 130 k = i, igh
56517  sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
56518  si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
56519  130 CONTINUE
56520 C
56521  sr = sr / norm
56522  si = si / norm
56523 C
56524  DO 140 k = i, igh
56525  zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
56526  zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
56527  140 CONTINUE
56528 C
56529  150 CONTINUE
56530 C
56531  160 CONTINUE
56532 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56533  170 l = low + 1
56534 C
56535  DO 210 i = l, igh
56536  ll = min0(i+1,igh)
56537  IF (hi(i,i-1) .EQ. 0.0d0) goto 210
56538  norm = pythag(hr(i,i-1),hi(i,i-1))
56539  yr = hr(i,i-1) / norm
56540  yi = hi(i,i-1) / norm
56541  hr(i,i-1) = norm
56542  hi(i,i-1) = 0.0d0
56543 C
56544  DO 180 j = i, n
56545  si = yr * hi(i,j) - yi * hr(i,j)
56546  hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
56547  hi(i,j) = si
56548  180 CONTINUE
56549 C
56550  DO 190 j = 1, ll
56551  si = yr * hi(j,i) + yi * hr(j,i)
56552  hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
56553  hi(j,i) = si
56554  190 CONTINUE
56555 C
56556  DO 200 j = low, igh
56557  si = yr * zi(j,i) + yi * zr(j,i)
56558  zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
56559  zi(j,i) = si
56560  200 CONTINUE
56561 C
56562  210 CONTINUE
56563 C .......... STORE ROOTS ISOLATED BY CBAL ..........
56564  220 DO 230 i = 1, n
56565  IF (i .GE. low .AND. i .LE. igh) goto 230
56566  wr(i) = hr(i,i)
56567  wi(i) = hi(i,i)
56568  230 CONTINUE
56569 C
56570  en = igh
56571  tr = 0.0d0
56572  ti = 0.0d0
56573  itn = 30*n
56574 C .......... SEARCH FOR NEXT EIGENVALUE ..........
56575  240 IF (en .LT. low) goto 430
56576  its = 0
56577  enm1 = en - 1
56578 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56579 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
56580  250 DO 260 ll = low, en
56581  l = en + low - ll
56582  IF (l .EQ. low) goto 270
56583  tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
56584  x + dabs(hr(l,l)) + dabs(hi(l,l))
56585  tst2 = tst1 + dabs(hr(l,l-1))
56586  IF (tst2 .EQ. tst1) goto 270
56587  260 CONTINUE
56588 C .......... FORM SHIFT ..........
56589  270 IF (l .EQ. en) goto 420
56590  IF (itn .EQ. 0) goto 550
56591  IF (its .EQ. 10 .OR. its .EQ. 20) goto 290
56592  sr = hr(en,en)
56593  si = hi(en,en)
56594  xr = hr(enm1,en) * hr(en,enm1)
56595  xi = hi(enm1,en) * hr(en,enm1)
56596  IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) goto 300
56597  yr = (hr(enm1,enm1) - sr) / 2.0d0
56598  yi = (hi(enm1,enm1) - si) / 2.0d0
56599  CALL pycsrt(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
56600  IF (yr * zzr + yi * zzi .GE. 0.0d0) goto 280
56601  zzr = -zzr
56602  zzi = -zzi
56603  280 CALL pycdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
56604  sr = sr - xr
56605  si = si - xi
56606  goto 300
56607 C .......... FORM EXCEPTIONAL SHIFT ..........
56608  290 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
56609  si = 0.0d0
56610 C
56611  300 DO 310 i = low, en
56612  hr(i,i) = hr(i,i) - sr
56613  hi(i,i) = hi(i,i) - si
56614  310 CONTINUE
56615 C
56616  tr = tr + sr
56617  ti = ti + si
56618  its = its + 1
56619  itn = itn - 1
56620 C .......... REDUCE TO TRIANGLE (ROWS) ..........
56621  lp1 = l + 1
56622 C
56623  DO 330 i = lp1, en
56624  sr = hr(i,i-1)
56625  hr(i,i-1) = 0.0d0
56626  norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
56627  xr = hr(i-1,i-1) / norm
56628  wr(i-1) = xr
56629  xi = hi(i-1,i-1) / norm
56630  wi(i-1) = xi
56631  hr(i-1,i-1) = norm
56632  hi(i-1,i-1) = 0.0d0
56633  hi(i,i-1) = sr / norm
56634 C
56635  DO 320 j = i, n
56636  yr = hr(i-1,j)
56637  yi = hi(i-1,j)
56638  zzr = hr(i,j)
56639  zzi = hi(i,j)
56640  hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
56641  hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
56642  hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
56643  hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
56644  320 CONTINUE
56645 C
56646  330 CONTINUE
56647 C
56648  si = hi(en,en)
56649  IF (si .EQ. 0.0d0) goto 350
56650  norm = pythag(hr(en,en),si)
56651  sr = hr(en,en) / norm
56652  si = si / norm
56653  hr(en,en) = norm
56654  hi(en,en) = 0.0d0
56655  IF (en .EQ. n) goto 350
56656  ip1 = en + 1
56657 C
56658  DO 340 j = ip1, n
56659  yr = hr(en,j)
56660  yi = hi(en,j)
56661  hr(en,j) = sr * yr + si * yi
56662  hi(en,j) = sr * yi - si * yr
56663  340 CONTINUE
56664 C .......... INVERSE OPERATION (COLUMNS) ..........
56665  350 DO 390 j = lp1, en
56666  xr = wr(j-1)
56667  xi = wi(j-1)
56668 C
56669  DO 370 i = 1, j
56670  yr = hr(i,j-1)
56671  yi = 0.0d0
56672  zzr = hr(i,j)
56673  zzi = hi(i,j)
56674  IF (i .EQ. j) goto 360
56675  yi = hi(i,j-1)
56676  hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
56677  360 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
56678  hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
56679  hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
56680  370 CONTINUE
56681 C
56682  DO 380 i = low, igh
56683  yr = zr(i,j-1)
56684  yi = zi(i,j-1)
56685  zzr = zr(i,j)
56686  zzi = zi(i,j)
56687  zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
56688  zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
56689  zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
56690  zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
56691  380 CONTINUE
56692 C
56693  390 CONTINUE
56694 C
56695  IF (si .EQ. 0.0d0) goto 250
56696 C
56697  DO 400 i = 1, en
56698  yr = hr(i,en)
56699  yi = hi(i,en)
56700  hr(i,en) = sr * yr - si * yi
56701  hi(i,en) = sr * yi + si * yr
56702  400 CONTINUE
56703 C
56704  DO 410 i = low, igh
56705  yr = zr(i,en)
56706  yi = zi(i,en)
56707  zr(i,en) = sr * yr - si * yi
56708  zi(i,en) = sr * yi + si * yr
56709  410 CONTINUE
56710 C
56711  goto 250
56712 C .......... A ROOT FOUND ..........
56713  420 hr(en,en) = hr(en,en) + tr
56714  wr(en) = hr(en,en)
56715  hi(en,en) = hi(en,en) + ti
56716  wi(en) = hi(en,en)
56717  en = enm1
56718  goto 240
56719 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
56720 C VECTORS OF UPPER TRIANGULAR FORM ..........
56721  430 norm = 0.0d0
56722 C
56723  DO 440 i = 1, n
56724 C
56725  DO 440 j = i, n
56726  tr = dabs(hr(i,j)) + dabs(hi(i,j))
56727  IF (tr .GT. norm) norm = tr
56728  440 CONTINUE
56729 C
56730  IF (n .EQ. 1 .OR. norm .EQ. 0.0d0) goto 560
56731 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
56732  DO 500 nn = 2, n
56733  en = n + 2 - nn
56734  xr = wr(en)
56735  xi = wi(en)
56736  hr(en,en) = 1.0d0
56737  hi(en,en) = 0.0d0
56738  enm1 = en - 1
56739 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
56740  DO 490 ii = 1, enm1
56741  i = en - ii
56742  zzr = 0.0d0
56743  zzi = 0.0d0
56744  ip1 = i + 1
56745 C
56746  DO 450 j = ip1, en
56747  zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
56748  zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
56749  450 CONTINUE
56750 C
56751  yr = xr - wr(i)
56752  yi = xi - wi(i)
56753  IF (yr .NE. 0.0d0 .OR. yi .NE. 0.0d0) goto 470
56754  tst1 = norm
56755  yr = tst1
56756  460 yr = 0.01d0 * yr
56757  tst2 = norm + yr
56758  IF (tst2 .GT. tst1) goto 460
56759  470 CONTINUE
56760  CALL pycdiv(zzr,zzi,yr,yi,hr(i,en),hi(i,en))
56761 C .......... OVERFLOW CONTROL ..........
56762  tr = dabs(hr(i,en)) + dabs(hi(i,en))
56763  IF (tr .EQ. 0.0d0) goto 490
56764  tst1 = tr
56765  tst2 = tst1 + 1.0d0/tst1
56766  IF (tst2 .GT. tst1) goto 490
56767  DO 480 j = i, en
56768  hr(j,en) = hr(j,en)/tr
56769  hi(j,en) = hi(j,en)/tr
56770  480 CONTINUE
56771 C
56772  490 CONTINUE
56773 C
56774  500 CONTINUE
56775 C .......... END BACKSUBSTITUTION ..........
56776 C .......... VECTORS OF ISOLATED ROOTS ..........
56777  DO 520 i = 1, n
56778  IF (i .GE. low .AND. i .LE. igh) goto 520
56779 C
56780  DO 510 j = i, n
56781  zr(i,j) = hr(i,j)
56782  zi(i,j) = hi(i,j)
56783  510 CONTINUE
56784 C
56785  520 CONTINUE
56786 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
56787 C VECTORS OF ORIGINAL FULL MATRIX.
56788 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
56789  DO 540 jj = low, n
56790  j = n + low - jj
56791  m = min0(j,igh)
56792 C
56793  DO 540 i = low, igh
56794  zzr = 0.0d0
56795  zzi = 0.0d0
56796 C
56797  DO 530 k = low, m
56798  zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
56799  zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
56800  530 CONTINUE
56801 C
56802  zr(i,j) = zzr
56803  zi(i,j) = zzi
56804  540 CONTINUE
56805 C
56806  goto 560
56807 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56808 C CONVERGED AFTER 30*N ITERATIONS ..........
56809  550 ierr = en
56810  560 RETURN
56811  END
56812 
56813 C*********************************************************************
56814 
56815 C...PYCDIV
56816 C...Auxiliary to PYCMQR
56817 C
56818 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
56819 C
56820 
56821  SUBROUTINE pycdiv(AR,AI,BR,BI,CR,CI)
56822 
56823  DOUBLE PRECISION ar,ai,br,bi,cr,ci
56824  DOUBLE PRECISION s,ars,ais,brs,bis
56825 
56826  s = dabs(br) + dabs(bi)
56827  ars = ar/s
56828  ais = ai/s
56829  brs = br/s
56830  bis = bi/s
56831  s = brs**2 + bis**2
56832  cr = (ars*brs + ais*bis)/s
56833  ci = (ais*brs - ars*bis)/s
56834  RETURN
56835  END
56836 
56837 C*********************************************************************
56838 
56839 C...PYCSRT
56840 C...Auxiliary to PYCMQR
56841 C
56842 C (YR,YI) = COMPLEX DSQRT(XR,XI)
56843 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56844 C
56845 
56846  SUBROUTINE pycsrt(XR,XI,YR,YI)
56847 
56848  DOUBLE PRECISION xr,xi,yr,yi
56849  DOUBLE PRECISION s,tr,ti,pythag
56850 
56851  tr = xr
56852  ti = xi
56853  s = dsqrt(0.5d0*(pythag(tr,ti) + dabs(tr)))
56854  IF (tr .GE. 0.0d0) yr = s
56855  IF (ti .LT. 0.0d0) s = -s
56856  IF (tr .LE. 0.0d0) yi = s
56857  IF (tr .LT. 0.0d0) yr = 0.5d0*(ti/yi)
56858  IF (tr .GT. 0.0d0) yi = 0.5d0*(ti/yr)
56859  RETURN
56860  END
56861 
56862  DOUBLE PRECISION FUNCTION pythag(A,B)
56863  DOUBLE PRECISION a,b
56864 C
56865 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56866 C
56867  DOUBLE PRECISION p,r,s,t,u
56868  p = dmax1(dabs(a),dabs(b))
56869  IF (p .EQ. 0.0d0) goto 110
56870  r = (dmin1(dabs(a),dabs(b))/p)**2
56871  100 CONTINUE
56872  t = 4.0d0 + r
56873  IF (t .EQ. 4.0d0) goto 110
56874  s = r/t
56875  u = 1.0d0 + 2.0d0*s
56876  p = u*p
56877  r = (s/u)**2 * r
56878  goto 100
56879  110 pythag = p
56880  RETURN
56881  END
56882 
56883 C*********************************************************************
56884 
56885 C...PYCBAL
56886 C...Auxiliary to PYEICG
56887 C
56888 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56889 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56890 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56891 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56892 C
56893 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56894 C EIGENVALUES WHENEVER POSSIBLE.
56895 C
56896 C ON INPUT
56897 C
56898 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56899 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56900 C DIMENSION STATEMENT.
56901 C
56902 C N IS THE ORDER OF THE MATRIX.
56903 C
56904 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56905 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56906 C
56907 C ON OUTPUT
56908 C
56909 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56910 C RESPECTIVELY, OF THE BALANCED MATRIX.
56911 C
56912 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56913 C ARE EQUAL TO ZERO IF
56914 C (1) I IS GREATER THAN J AND
56915 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56916 C
56917 C SCALE CONTAINS INFORMATION DETERMINING THE
56918 C PERMUTATIONS AND SCALING FACTORS USED.
56919 C
56920 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56921 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56922 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56923 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56924 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56925 C = D(J,J) J = LOW,...,IGH
56926 C = P(J) J = IGH+1,...,N.
56927 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56928 C THEN 1 TO LOW-1.
56929 C
56930 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56931 C
56932 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56933 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56934 C K,L HAVE BEEN REVERSED.)
56935 C
56936 C ARITHMETIC IS REAL THROUGHOUT.
56937 C
56938 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56939 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56940 C
56941 C THIS VERSION DATED AUGUST 1983.
56942 C
56943 
56944  SUBROUTINE pycbal(NM,N,AR,AI,LOW,IGH,SCALE)
56945 
56946  INTEGER i,j,k,l,m,n,jj,nm,igh,low,iexc
56947  DOUBLE PRECISION ar(5,5),ai(5,5),scale(5)
56948  DOUBLE PRECISION c,f,g,r,s,b2,radix
56949  LOGICAL noconv
56950 
56951  radix = 16.0d0
56952 C
56953  b2 = radix * radix
56954  k = 1
56955  l = n
56956  goto 150
56957 C .......... IN-LINE PROCEDURE FOR ROW AND
56958 C COLUMN EXCHANGE ..........
56959  100 scale(m) = j
56960  IF (j .EQ. m) goto 130
56961 C
56962  DO 110 i = 1, l
56963  f = ar(i,j)
56964  ar(i,j) = ar(i,m)
56965  ar(i,m) = f
56966  f = ai(i,j)
56967  ai(i,j) = ai(i,m)
56968  ai(i,m) = f
56969  110 CONTINUE
56970 C
56971  DO 120 i = k, n
56972  f = ar(j,i)
56973  ar(j,i) = ar(m,i)
56974  ar(m,i) = f
56975  f = ai(j,i)
56976  ai(j,i) = ai(m,i)
56977  ai(m,i) = f
56978  120 CONTINUE
56979 C
56980  130 IF(iexc.EQ.1) goto 140
56981  IF(iexc.EQ.2) goto 180
56982 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56983 C AND PUSH THEM DOWN ..........
56984  140 IF (l .EQ. 1) goto 320
56985  l = l - 1
56986 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56987  150 DO 170 jj = 1, l
56988  j = l + 1 - jj
56989 C
56990  DO 160 i = 1, l
56991  IF (i .EQ. j) goto 160
56992  IF (ar(j,i) .NE. 0.0d0 .OR. ai(j,i) .NE. 0.0d0) goto 170
56993  160 CONTINUE
56994 C
56995  m = l
56996  iexc = 1
56997  goto 100
56998  170 CONTINUE
56999 C
57000  goto 190
57001 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
57002 C AND PUSH THEM LEFT ..........
57003  180 k = k + 1
57004 C
57005  190 DO 210 j = k, l
57006 C
57007  DO 200 i = k, l
57008  IF (i .EQ. j) goto 200
57009  IF (ar(i,j) .NE. 0.0d0 .OR. ai(i,j) .NE. 0.0d0) goto 210
57010  200 CONTINUE
57011 C
57012  m = k
57013  iexc = 2
57014  goto 100
57015  210 CONTINUE
57016 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
57017  DO 220 i = k, l
57018  220 scale(i) = 1.0d0
57019 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
57020  230 noconv = .false.
57021 C
57022  DO 310 i = k, l
57023  c = 0.0d0
57024  r = 0.0d0
57025 C
57026  DO 240 j = k, l
57027  IF (j .EQ. i) goto 240
57028  c = c + dabs(ar(j,i)) + dabs(ai(j,i))
57029  r = r + dabs(ar(i,j)) + dabs(ai(i,j))
57030  240 CONTINUE
57031 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
57032  IF (c .EQ. 0.0d0 .OR. r .EQ. 0.0d0) goto 310
57033  g = r / radix
57034  f = 1.0d0
57035  s = c + r
57036  250 IF (c .GE. g) goto 260
57037  f = f * radix
57038  c = c * b2
57039  goto 250
57040  260 g = r * radix
57041  270 IF (c .LT. g) goto 280
57042  f = f / radix
57043  c = c / b2
57044  goto 270
57045 C .......... NOW BALANCE ..........
57046  280 IF ((c + r) / f .GE. 0.95d0 * s) goto 310
57047  g = 1.0d0 / f
57048  scale(i) = scale(i) * f
57049  noconv = .true.
57050 C
57051  DO 290 j = k, n
57052  ar(i,j) = ar(i,j) * g
57053  ai(i,j) = ai(i,j) * g
57054  290 CONTINUE
57055 C
57056  DO 300 j = 1, l
57057  ar(j,i) = ar(j,i) * f
57058  ai(j,i) = ai(j,i) * f
57059  300 CONTINUE
57060 C
57061  310 CONTINUE
57062 C
57063  IF (noconv) goto 230
57064 C
57065  320 low = k
57066  igh = l
57067  RETURN
57068  END
57069 
57070 C*********************************************************************
57071 
57072 C...PYCBA2
57073 C...Auxiliary to PYEICG.
57074 C
57075 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
57076 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
57077 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
57078 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
57079 C
57080 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
57081 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
57082 C BALANCED MATRIX DETERMINED BY CBAL.
57083 C
57084 C ON INPUT
57085 C
57086 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57087 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57088 C DIMENSION STATEMENT.
57089 C
57090 C N IS THE ORDER OF THE MATRIX.
57091 C
57092 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
57093 C
57094 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
57095 C AND SCALING FACTORS USED BY CBAL.
57096 C
57097 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
57098 C
57099 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57100 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
57101 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
57102 C
57103 C ON OUTPUT
57104 C
57105 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57106 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
57107 C IN THEIR FIRST M COLUMNS.
57108 C
57109 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57110 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57111 C
57112 C THIS VERSION DATED AUGUST 1983.
57113 C
57114 
57115  SUBROUTINE pycba2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
57116 
57117  INTEGER i,j,k,m,n,ii,nm,igh,low
57118  DOUBLE PRECISION scale(5),zr(5,5),zi(5,5)
57119  DOUBLE PRECISION s
57120 
57121  IF (m .EQ. 0) goto 150
57122  IF (igh .EQ. low) goto 120
57123 C
57124  DO 110 i = low, igh
57125  s = scale(i)
57126 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
57127 C IF THE FOREGOING STATEMENT IS REPLACED BY
57128 C S=1.0D0/SCALE(I). ..........
57129  DO 100 j = 1, m
57130  zr(i,j) = zr(i,j) * s
57131  zi(i,j) = zi(i,j) * s
57132  100 CONTINUE
57133 C
57134  110 CONTINUE
57135 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
57136 C IGH+1 STEP 1 UNTIL N DO -- ..........
57137  120 DO 140 ii = 1, n
57138  i = ii
57139  IF (i .GE. low .AND. i .LE. igh) goto 140
57140  IF (i .LT. low) i = low - ii
57141  k = scale(i)
57142  IF (k .EQ. i) goto 140
57143 C
57144  DO 130 j = 1, m
57145  s = zr(i,j)
57146  zr(i,j) = zr(k,j)
57147  zr(k,j) = s
57148  s = zi(i,j)
57149  zi(i,j) = zi(k,j)
57150  zi(k,j) = s
57151  130 CONTINUE
57152 C
57153  140 CONTINUE
57154 C
57155  150 RETURN
57156  END
57157 
57158 C*********************************************************************
57159 
57160 C...PYCRTH
57161 C...Auxiliary to PYEICG.
57162 C
57163 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
57164 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
57165 C BY MARTIN AND WILKINSON.
57166 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
57167 C
57168 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
57169 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
57170 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
57171 C UNITARY SIMILARITY TRANSFORMATIONS.
57172 C
57173 C ON INPUT
57174 C
57175 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57176 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57177 C DIMENSION STATEMENT.
57178 C
57179 C N IS THE ORDER OF THE MATRIX.
57180 C
57181 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
57182 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
57183 C SET LOW=1, IGH=N.
57184 C
57185 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57186 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
57187 C
57188 C ON OUTPUT
57189 C
57190 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57191 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
57192 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
57193 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
57194 C HESSENBERG MATRIX.
57195 C
57196 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
57197 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
57198 C
57199 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
57200 C
57201 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57202 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57203 C
57204 C THIS VERSION DATED AUGUST 1983.
57205 C
57206 
57207  SUBROUTINE pycrth(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
57208 
57209  INTEGER i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low
57210  DOUBLE PRECISION ar(5,5),ai(5,5),ortr(5),orti(5)
57211  DOUBLE PRECISION f,g,h,fi,fr,scale,pythag
57212 
57213  la = igh - 1
57214  kp1 = low + 1
57215  IF (la .LT. kp1) goto 210
57216 C
57217  DO 200 m = kp1, la
57218  h = 0.0d0
57219  ortr(m) = 0.0d0
57220  orti(m) = 0.0d0
57221  scale = 0.0d0
57222 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
57223  DO 100 i = m, igh
57224  100 scale = scale + dabs(ar(i,m-1)) + dabs(ai(i,m-1))
57225 C
57226  IF (scale .EQ. 0.0d0) goto 200
57227  mp = m + igh
57228 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57229  DO 110 ii = m, igh
57230  i = mp - ii
57231  ortr(i) = ar(i,m-1) / scale
57232  orti(i) = ai(i,m-1) / scale
57233  h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
57234  110 CONTINUE
57235 C
57236  g = dsqrt(h)
57237  f = pythag(ortr(m),orti(m))
57238  IF (f .EQ. 0.0d0) goto 120
57239  h = h + f * g
57240  g = g / f
57241  ortr(m) = (1.0d0 + g) * ortr(m)
57242  orti(m) = (1.0d0 + g) * orti(m)
57243  goto 130
57244 C
57245  120 ortr(m) = g
57246  ar(m,m-1) = scale
57247 C .......... FORM (I-(U*UT)/H) * A ..........
57248  130 DO 160 j = m, n
57249  fr = 0.0d0
57250  fi = 0.0d0
57251 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57252  DO 140 ii = m, igh
57253  i = mp - ii
57254  fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
57255  fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
57256  140 CONTINUE
57257 C
57258  fr = fr / h
57259  fi = fi / h
57260 C
57261  DO 150 i = m, igh
57262  ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i)
57263  ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i)
57264  150 CONTINUE
57265 C
57266  160 CONTINUE
57267 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
57268  DO 190 i = 1, igh
57269  fr = 0.0d0
57270  fi = 0.0d0
57271 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
57272  DO 170 jj = m, igh
57273  j = mp - jj
57274  fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
57275  fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
57276  170 CONTINUE
57277 C
57278  fr = fr / h
57279  fi = fi / h
57280 C
57281  DO 180 j = m, igh
57282  ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j)
57283  ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j)
57284  180 CONTINUE
57285 C
57286  190 CONTINUE
57287 C
57288  ortr(m) = scale * ortr(m)
57289  orti(m) = scale * orti(m)
57290  ar(m,m-1) = -g * ar(m,m-1)
57291  ai(m,m-1) = -g * ai(m,m-1)
57292  200 CONTINUE
57293 C
57294  210 RETURN
57295  END
57296 
57297 C*********************************************************************
57298 
57299 C...PYLDCM
57300 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57301 C...processes.
57302 
57303  SUBROUTINE pyldcm(A,N,NP,INDX,D)
57304  IMPLICIT NONE
57305  INTEGER n,np,indx(n)
57306  REAL*8 d,tiny
57307  COMPLEX*16 a(np,np)
57308  parameter(tiny=1.0d-20)
57309  INTEGER i,imax,j,k
57310  REAL*8 aamax,vv(6),dum
57311  COMPLEX*16 sum,dumc
57312 
57313  d=1d0
57314  DO 110 i=1,n
57315  aamax=0d0
57316  DO 100 j=1,n
57317  IF (abs(a(i,j)).GT.aamax) aamax=abs(a(i,j))
57318  100 CONTINUE
57319  IF (aamax.EQ.0d0) CALL pyerrm(28,'(PYLDCM:) singular matrix')
57320  vv(i)=1d0/aamax
57321  110 CONTINUE
57322  DO 180 j=1,n
57323  DO 130 i=1,j-1
57324  sum=a(i,j)
57325  DO 120 k=1,i-1
57326  sum=sum-a(i,k)*a(k,j)
57327  120 CONTINUE
57328  a(i,j)=sum
57329  130 CONTINUE
57330  aamax=0d0
57331  DO 150 i=j,n
57332  sum=a(i,j)
57333  DO 140 k=1,j-1
57334  sum=sum-a(i,k)*a(k,j)
57335  140 CONTINUE
57336  a(i,j)=sum
57337  dum=vv(i)*abs(sum)
57338  IF (dum.GE.aamax) THEN
57339  imax=i
57340  aamax=dum
57341  ENDIF
57342  150 CONTINUE
57343  IF (j.NE.imax)THEN
57344  DO 160 k=1,n
57345  dumc=a(imax,k)
57346  a(imax,k)=a(j,k)
57347  a(j,k)=dumc
57348  160 CONTINUE
57349  d=-d
57350  vv(imax)=vv(j)
57351  ENDIF
57352  indx(j)=imax
57353  IF(abs(a(j,j)).EQ.0d0) a(j,j)=dcmplx(tiny,0d0)
57354  IF(j.NE.n)THEN
57355  DO 170 i=j+1,n
57356  a(i,j)=a(i,j)/a(j,j)
57357  170 CONTINUE
57358  ENDIF
57359  180 CONTINUE
57360 
57361  RETURN
57362  END
57363 
57364 C*********************************************************************
57365 
57366 C...PYBKSB
57367 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57368 C...processes.
57369 
57370  SUBROUTINE pybksb(A,N,NP,INDX,B)
57371  IMPLICIT NONE
57372  INTEGER n,np,indx(n)
57373  COMPLEX*16 a(np,np),b(n)
57374  INTEGER i,ii,j,ll
57375  COMPLEX*16 sum
57376 
57377  ii=0
57378  DO 110 i=1,n
57379  ll=indx(i)
57380  sum=b(ll)
57381  b(ll)=b(i)
57382  IF (ii.NE.0)THEN
57383  DO 100 j=ii,i-1
57384  sum=sum-a(i,j)*b(j)
57385  100 CONTINUE
57386  ELSE IF (abs(sum).NE.0d0) THEN
57387  ii=i
57388  ENDIF
57389  b(i)=sum
57390  110 CONTINUE
57391  DO 130 i=n,1,-1
57392  sum=b(i)
57393  DO 120 j=i+1,n
57394  sum=sum-a(i,j)*b(j)
57395  120 CONTINUE
57396  b(i)=sum/a(i,i)
57397  130 CONTINUE
57398  RETURN
57399  END
57400 
57401 C***********************************************************************
57402 
57403 C...PYWIDX
57404 C...Calculates full and partial widths of resonances.
57405 C....copy of PYWIDT, used for techniparticle widths
57406 
57407  SUBROUTINE pywidx(KFLR,SH,WDTP,WDTE)
57408 
57409 C...Double precision and integer declarations.
57410  IMPLICIT DOUBLE PRECISION(a-h, o-z)
57411  IMPLICIT INTEGER(i-n)
57412  INTEGER pyk,pychge,pycomp
57413 C...Parameter statement to help give large particle numbers.
57414  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57415  &kexcit=4000000,kdimen=5000000)
57416 C...Commonblocks.
57417  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57418  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57419  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
57420  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
57421  common/pypars/mstp(200),parp(200),msti(200),pari(200)
57422  common/pyint1/mint(400),vint(400)
57423  common/pyint4/mwid(500),wids(500,5)
57424  common/pymssm/imss(0:99),rmss(0:99)
57425  common/pytcsm/itcm(0:99),rtcm(0:99)
57426  SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
57427  &/pyint4/,/pymssm/,/pytcsm/
57428 C...Local arrays and saved variables.
57429  dimension wdtp(0:400),wdte(0:400,0:5),mofsv(3,2),widwsv(3,2),
57430  &wid2sv(3,2)
57431  SAVE mofsv,widwsv,wid2sv
57432  DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
57433 
57434 C...Compressed code and sign; mass.
57435  kfla=iabs(kflr)
57436  kfls=isign(1,kflr)
57437  kc=pycomp(kfla)
57438  shr=sqrt(sh)
57439  pmr=pmas(kc,1)
57440 
57441 C...Reset width information.
57442  DO i=0,400
57443  wdtp(i)=0d0
57444  ENDDO
57445 
57446 C...Common electroweak and strong constants.
57447  xw=paru(102)
57448  xwv=xw
57449  IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
57450  xw1=1d0-xw
57451  aem=pyalem(sh)
57452  IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
57453  as=pyalps(sh)
57454  radc=1d0+as/paru(1)
57455 
57456  IF(kfla.EQ.23) THEN
57457 C...Z0:
57458  xwc=1d0/(16d0*xw*xw1)
57459  fac=(aem*xwc/3d0)*shr
57460  120 CONTINUE
57461  DO 130 i=1,mdcy(kc,3)
57462  idc=i+mdcy(kc,2)-1
57463  IF(mdme(idc,1).LT.0) goto 130
57464  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
57465  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
57466  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 130
57467  IF(i.LE.8) THEN
57468 C...Z0 -> q + qbar
57469  ef=kchg(i,1)/3d0
57470  af=sign(1d0,ef+0.1d0)
57471  vf=af-4d0*ef*xwv
57472  fcof=3d0*radc
57473  IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
57474  ELSEIF(i.LE.16) THEN
57475 C...Z0 -> l+ + l-, nu + nubar
57476  ef=kchg(i+2,1)/3d0
57477  af=sign(1d0,ef+0.1d0)
57478  vf=af-4d0*ef*xwv
57479  fcof=1d0
57480  ENDIF
57481  be34=sqrt(max(0d0,1d0-4d0*rm1))
57482  wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
57483  & be34
57484  wdtp(0)=wdtp(0)+wdtp(i)
57485  130 CONTINUE
57486 
57487 
57488  ELSEIF(kfla.EQ.24) THEN
57489 C...W+/-:
57490  fac=(aem/(24d0*xw))*shr
57491  DO 140 i=1,mdcy(kc,3)
57492  idc=i+mdcy(kc,2)-1
57493  IF(mdme(idc,1).LT.0) goto 140
57494  rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
57495  rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
57496  IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 140
57497  wid2=1d0
57498  IF(i.LE.16) THEN
57499 C...W+/- -> q + qbar'
57500  fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
57501  ELSEIF(i.LE.20) THEN
57502 C...W+/- -> l+/- + nu
57503  fcof=1d0
57504  ENDIF
57505  wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
57506  & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
57507  wdtp(0)=wdtp(0)+wdtp(i)
57508  140 CONTINUE
57509 
57510 C.....V8 -> quark anti-quark
57511  ELSEIF(kfla.EQ.ktechn+100021) THEN
57512  fac=as/6d0*shr
57513  tant3=rtcm(21)
57514  IF(itcm(2).EQ.0) THEN
57515  imdl=1
57516  ELSEIF(itcm(2).EQ.1) THEN
57517  imdl=2
57518  ENDIF
57519  DO 150 i=1,mdcy(kc,3)
57520  idc=i+mdcy(kc,2)-1
57521  IF(mdme(idc,1).LT.0) goto 150
57522  pm1=pmas(pycomp(kfdp(idc,1)),1)
57523  rm1=pm1**2/sh
57524  IF(rm1.GT.0.25d0) goto 150
57525  wid2=1d0
57526  IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
57527  fmix=1d0/tant3**2
57528  ELSE
57529  fmix=tant3**2
57530  ENDIF
57531  wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*fmix
57532  IF(i.EQ.6) wid2=wids(6,1)
57533  wdtp(0)=wdtp(0)+wdtp(i)
57534  150 CONTINUE
57535  ENDIF
57536 
57537  RETURN
57538  END
57539 
57540 C*********************************************************************
57541 
57542 C...PYRVSF
57543 C...Calculates R-violating decays of sfermions.
57544 C...P. Z. Skands
57545 
57546  SUBROUTINE pyrvsf(KFIN,XLAM,IDLAM,LKNT)
57547 
57548 C...Double precision and integer declarations.
57549  IMPLICIT DOUBLE PRECISION(a-h, o-z)
57550  IMPLICIT INTEGER(i-n)
57551 C...Parameter statement to help give large particle numbers.
57552  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57553  &kexcit=4000000,kdimen=5000000)
57554 C...Commonblocks.
57555  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57556  common/pymssm/imss(0:99),rmss(0:99)
57557  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57558  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57559  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
57560 C...Local variables.
57561  DOUBLE PRECISION xlam(0:400)
57562  INTEGER idlam(400,3), pycomp
57563  SAVE /pymsrv/,/pyssmt/,/pymssm/,/pydat2/
57564 
57565 C...IS R-VIOLATION ON ?
57566  IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
57567 C...Mass eigenstate counter
57568  icnt=int(kfin/ksusy1)
57569 C...SM KF code of SUSY particle
57570  kfsm=kfin-icnt*ksusy1
57571 C...Squared Sparticle Mass
57572  sm=pmas(pycomp(kfin),1)**2
57573 C... Squared mass of top quark
57574  smt=pmas(pycomp(6),1)**2
57575 C...IS L-VIOLATION ON ?
57576  IF ((imss(51).GE.1).OR.(imss(52).GE.1)) THEN
57577 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
57578  IF(icnt.NE.0.AND.(kfsm.EQ.11.OR.kfsm.EQ.13.OR.kfsm.EQ.15))
57579  & THEN
57580  k=int((kfsm-9)/2)
57581  DO 110 i=1,3
57582  DO 100 j=1,3
57583  IF(i.NE.j) THEN
57584 C...~e,~mu,~tau -> nu_I + lepton-_J
57585  lknt = lknt+1
57586  idlam(lknt,1)= 12 +2*(i-1)
57587  idlam(lknt,2)= 11 +2*(j-1)
57588  idlam(lknt,3)= 0
57589  xlam(lknt)=0d0
57590  rm2=rvlam(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
57591  IF (imss(51).NE.0) xlam(lknt) =
57592  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57593 C...KINEMATICS CHECK
57594  IF (xlam(lknt).EQ.0d0) THEN
57595  lknt=lknt-1
57596  ENDIF
57597  ENDIF
57598  100 CONTINUE
57599  110 CONTINUE
57600 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
57601  j=int((kfsm-9)/2)
57602  DO 130 i=1,3
57603  IF(i.NE.j) THEN
57604  DO 120 k=1,3
57605  lknt = lknt+1
57606  idlam(lknt,1)=-12 -2*(i-1)
57607  idlam(lknt,2)= 11 +2*(k-1)
57608  idlam(lknt,3)= 0
57609  xlam(lknt)=0d0
57610  rm2=rvlam(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
57611  IF (imss(51).NE.0) xlam(lknt) =
57612  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57613 C...KINEMATICS CHECK
57614  IF (xlam(lknt).EQ.0d0) THEN
57615  lknt=lknt-1
57616  ENDIF
57617  120 CONTINUE
57618  ENDIF
57619  130 CONTINUE
57620 C...~e,~mu,~tau -> u_Jbar + d_K
57621  i=int((kfsm-9)/2)
57622  DO 150 j=1,3
57623  DO 140 k=1,3
57624  lknt = lknt+1
57625  idlam(lknt,1)=-2 -2*(j-1)
57626  idlam(lknt,2)= 1 +2*(k-1)
57627  idlam(lknt,3)= 0
57628  xlam(lknt)=0
57629  IF (imss(52).NE.0) THEN
57630 C...Use massive top quark
57631  IF (idlam(lknt,1).EQ.-6) THEN
57632  rm2=3*rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2
57633  & * (sm-smt)
57634  xlam(lknt) =
57635  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,3)
57636 C...If no top quark, all decay products massless
57637  ELSE
57638  rm2=3*rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
57639  xlam(lknt) =
57640  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57641  ENDIF
57642 C...KINEMATICS CHECK
57643  IF (xlam(lknt).EQ.0d0) THEN
57644  lknt=lknt-1
57645  ENDIF
57646  ENDIF
57647  140 CONTINUE
57648  150 CONTINUE
57649  ENDIF
57650 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
57651 C...No right-handed neutrinos
57652  IF(icnt.EQ.1) THEN
57653  IF(kfsm.EQ.12.OR.kfsm.EQ.14.OR.kfsm.EQ.16) THEN
57654  j=int((kfsm-10)/2)
57655  DO 170 i=1,3
57656  DO 160 k=1,3
57657  IF (i.NE.j) THEN
57658 C...~nu_J -> lepton+_I + lepton-_K
57659  lknt = lknt+1
57660  idlam(lknt,1)=-11 -2*(i-1)
57661  idlam(lknt,2)= 11 +2*(k-1)
57662  idlam(lknt,3)= 0
57663  xlam(lknt)=0d0
57664  rm2=rvlam(i,j,k)**2 * sm
57665  IF (imss(51).NE.0) xlam(lknt) =
57666  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57667 C...KINEMATICS CHECK
57668  IF (xlam(lknt).EQ.0d0) THEN
57669  lknt=lknt-1
57670  ENDIF
57671  ENDIF
57672  160 CONTINUE
57673  170 CONTINUE
57674 C...~nu_I -> dbar_J + d_K
57675  i=int((kfsm-10)/2)
57676  DO 190 j=1,3
57677  DO 180 k=1,3
57678  lknt = lknt+1
57679  idlam(lknt,1)=-1 -2*(j-1)
57680  idlam(lknt,2)= 1 +2*(k-1)
57681  idlam(lknt,3)= 0
57682  xlam(lknt)=0d0
57683  rm2=3*rvlamp(i,j,k)**2 * sm
57684  IF (imss(52).NE.0) xlam(lknt) =
57685  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57686 C...KINEMATICS CHECK
57687  IF (xlam(lknt).EQ.0d0) THEN
57688  lknt=lknt-1
57689  ENDIF
57690  180 CONTINUE
57691  190 CONTINUE
57692  ENDIF
57693  ENDIF
57694 C * SDOWN -> NU(BAR) + D and LEPTON- + U
57695  IF(icnt.NE.0.AND.(kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5)) THEN
57696  j=int((kfsm+1)/2)
57697  DO 210 i=1,3
57698  DO 200 k=1,3
57699 C...~d_J -> nu_Ibar + d_K
57700  lknt = lknt+1
57701  idlam(lknt,1)=-12 -2*(i-1)
57702  idlam(lknt,2)= 1 +2*(k-1)
57703  idlam(lknt,3)= 0
57704  xlam(lknt)=0d0
57705  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
57706  IF (imss(52).NE.0) xlam(lknt) =
57707  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57708 C...KINEMATICS CHECK
57709  IF (xlam(lknt).EQ.0d0) THEN
57710  lknt=lknt-1
57711  ENDIF
57712  200 CONTINUE
57713  210 CONTINUE
57714  k=int((kfsm+1)/2)
57715  DO 240 i=1,3
57716  DO 230 j=1,3
57717 C...~d_K -> nu_I + d_J
57718  lknt = lknt+1
57719  idlam(lknt,1)= 12 +2*(i-1)
57720  idlam(lknt,2)= 1 +2*(j-1)
57721  idlam(lknt,3)= 0
57722  xlam(lknt)=0d0
57723  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
57724  IF (imss(52).NE.0) xlam(lknt) =
57725  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57726 C...KINEMATICS CHECK
57727  IF (xlam(lknt).EQ.0d0) THEN
57728  lknt=lknt-1
57729  ENDIF
57730 C...~d_K -> lepton_I- + u_J
57731  220 lknt = lknt+1
57732  idlam(lknt,1)= 11 +2*(i-1)
57733  idlam(lknt,2)= 2 +2*(j-1)
57734  idlam(lknt,3)= 0
57735  xlam(lknt)=0d0
57736  IF (imss(52).NE.0) THEN
57737 C...Use massive top quark
57738  IF (idlam(lknt,2).EQ.6) THEN
57739  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2*(sm-smt)
57740  xlam(lknt) =
57741  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,2)
57742 C...If no top quark, all decay products massless
57743  ELSE
57744  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
57745  xlam(lknt) =
57746  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57747  ENDIF
57748 C...KINEMATICS CHECK
57749  IF (xlam(lknt).EQ.0d0) THEN
57750  lknt=lknt-1
57751  ENDIF
57752  ENDIF
57753  230 CONTINUE
57754  240 CONTINUE
57755  ENDIF
57756 C * SUP -> LEPTON+ + D
57757  IF(icnt.NE.0.AND.(kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6)) THEN
57758  j=nint(kfsm/2.)
57759  DO 260 i=1,3
57760  DO 250 k=1,3
57761 C...~u_J -> lepton_I+ + d_K
57762  lknt = lknt+1
57763  idlam(lknt,1)=-11 -2*(i-1)
57764  idlam(lknt,2)= 1 +2*(k-1)
57765  idlam(lknt,3)= 0
57766  xlam(lknt)=0d0
57767  rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
57768  IF (imss(52).NE.0) xlam(lknt) =
57769  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57770 C...KINEMATICS CHECK
57771  IF (xlam(lknt).EQ.0d0) THEN
57772  lknt=lknt-1
57773  ENDIF
57774  250 CONTINUE
57775  260 CONTINUE
57776  ENDIF
57777  ENDIF
57778 C...BARYON NUMBER VIOLATING DECAYS
57779  IF (imss(53).GE.1) THEN
57780 C * SUP -> DBAR + DBAR
57781  IF(icnt.NE.0.AND.(kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6)) THEN
57782  i = kfsm/2
57783  DO 280 j=1,3
57784  DO 270 k=1,3
57785 C...~u_I -> dbar_J + dbar_K
57786  IF (j.LT.k) THEN
57787 C...(anti-) symmetry J <-> K.
57788  lknt = lknt + 1
57789  idlam(lknt,1) = -1 -2*(j-1)
57790  idlam(lknt,2) = -1 -2*(k-1)
57791  idlam(lknt,3) = 0
57792  xlam(lknt) = 0d0
57793  rm2 = 2.*(rvlamb(i,j,k)**2)
57794  & * sfmix(kfsm,2*icnt)**2 * sm
57795  xlam(lknt) =
57796  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57797 C...KINEMATICS CHECK
57798  IF (xlam(lknt).EQ.0d0) THEN
57799  lknt = lknt-1
57800  ENDIF
57801  ENDIF
57802  270 CONTINUE
57803  280 CONTINUE
57804  ENDIF
57805 C * SDOWN -> UBAR + DBAR
57806  IF(icnt.NE.0.AND.(kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5)) THEN
57807  k=(kfsm+1)/2
57808  DO 300 i=1,3
57809  DO 290 j=1,3
57810 C...LAMB coupling antisymmetric in J and K.
57811  IF (j.NE.k) THEN
57812 C...~d_K -> ubar_I + dbar_K
57813  lknt = lknt + 1
57814  idlam(lknt,1)= -2 -2*(i-1)
57815  idlam(lknt,2)= -1 -2*(j-1)
57816  idlam(lknt,3)= 0
57817  xlam(lknt)=0d0
57818 C...Use massive top quark
57819  IF (idlam(lknt,1).EQ.-6) THEN
57820  rm2=2*rvlamb(i,j,k)**2*sfmix(kfsm,2*icnt)**2*(sm-smt
57821  & )
57822  xlam(lknt) =
57823  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,3)
57824 C...If no top quark, all decay products massless
57825  ELSE
57826  rm2=2*rvlamb(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
57827  xlam(lknt) =
57828  & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
57829  ENDIF
57830 C...KINEMATICS CHECK
57831  IF (xlam(lknt).EQ.0d0) THEN
57832  lknt=lknt-1
57833  ENDIF
57834  ENDIF
57835  290 CONTINUE
57836  300 CONTINUE
57837  ENDIF
57838  ENDIF
57839  ENDIF
57840 
57841  RETURN
57842  END
57843 
57844 C*********************************************************************
57845 
57846 C...PYRVNE
57847 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57848 C...P. Z. Skands
57849 
57850  SUBROUTINE pyrvne(KFIN,XLAM,IDLAM,LKNT)
57851 
57852 C...Double precision and integer declarations.
57853  IMPLICIT DOUBLE PRECISION(a-h, o-z)
57854  IMPLICIT INTEGER(i-n)
57855 C...Parameter statement to help give large particle numbers.
57856  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57857  &kexcit=4000000,kdimen=5000000)
57858 C...Commonblocks.
57859  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57860  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57861  common/pymssm/imss(0:99),rmss(0:99)
57862  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57863  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57864  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
57865 C...Local variables.
57866  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
57867  & ,dcmass,kfr(3)
57868  DOUBLE PRECISION xlam(0:400)
57869  DOUBLE PRECISION zpmix(4,4), nmix(4,4), rmq(6)
57870  INTEGER idlam(400,3), pycomp
57871  LOGICAL dcmass
57872  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pymsrv/,/pyrvnv/
57873 
57874 C...R-VIOLATING DECAYS
57875  IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
57876  kfsm=kfin-ksusy1
57877  IF(kfsm.EQ.22.OR.kfsm.EQ.23.OR.kfsm.EQ.25.OR.kfsm.EQ.35) THEN
57878 C...WHICH NEUTRALINO ?
57879  nchi=1
57880  IF (kfsm.EQ.23) nchi=2
57881  IF (kfsm.EQ.25) nchi=3
57882  IF (kfsm.EQ.35) nchi=4
57883 C...SIGN OF MASS (Opposite convention as HERWIG)
57884  ism = 1
57885  IF (smz(nchi).LT.0d0) ism = -ism
57886 
57887 C...Useful parameters for the calculation of the A and B constants.
57888  wmass = pmas(pycomp(24),1)
57889  echg = 2*sqrt(paru(103)*paru(1))
57890  cosb=1/(sqrt(1+rmss(5)**2))
57891  sinb=rmss(5)/sqrt(1+rmss(5)**2)
57892  cosw=sqrt(1-paru(102))
57893  sinw=sqrt(paru(102))
57894  gw=2d0*sqrt(paru(103)*paru(1))/sinw
57895 C...Run quark masses to neutralino mass squared (for Higgs-type
57896 C...couplings)
57897  sqmchi=pmas(pycomp(kfin),1)**2
57898  DO 100 i=1,6
57899  rmq(i)=pymrun(i,sqmchi)
57900  100 CONTINUE
57901 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57902  DO 110 nchj=1,4
57903  zpmix(nchj,1)= zmix(nchj,1)*cosw+zmix(nchj,2)*sinw
57904  zpmix(nchj,2)=-zmix(nchj,1)*sinw+zmix(nchj,2)*cosw
57905  zpmix(nchj,3)= zmix(nchj,3)
57906  zpmix(nchj,4)= zmix(nchj,4)
57907  110 CONTINUE
57908  c1=gw*zpmix(nchi,3)/(2d0*cosb*wmass)
57909  c1u=gw*zpmix(nchi,4)/(2d0*sinb*wmass)
57910  c2=echg*zpmix(nchi,1)
57911  c3=gw*zpmix(nchi,2)/cosw
57912  eu=2d0/3d0
57913  ed=-1d0/3d0
57914 C... AB(x,y,z):
57915 C x=1-2 : Select A or B constant (1:A ; 2:B)
57916 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57917 C 11-16:e,nu_e,mu,...)
57918 C z=1-2 : Mass eigenstate number
57919 C...CALCULATE COUPLINGS
57920  DO 120 i = 11,15,2
57921  cms=pmas(pycomp(i),1)
57922 C...Intermediate sleptons
57923  ab(1,i,1)=ism*(cms*c1*sfmix(i,1) + sfmix(i,2)
57924  & *(c2-c3*sinw**2))
57925  ab(1,i,2)=ism*(cms*c1*sfmix(i,3) + sfmix(i,4)
57926  & *(c2-c3*sinw**2))
57927  ab(2,i,1)= cms*c1*sfmix(i,2) - sfmix(i,1)*(c2+c3*(5d-1-sinw
57928  & **2))
57929  ab(2,i,2)=cms*c1*sfmix(i,4) - sfmix(i,3)*(c2+c3*(5d-1-sinw
57930  & **2))
57931 C...Inermediate sneutrinos
57932  ab(1,i+1,1)=0d0
57933  ab(2,i+1,1)=5d-1*c3
57934  ab(1,i+1,2)=0d0
57935  ab(2,i+1,2)=0d0
57936 C...Inermediate sdown
57937  j=i-10
57938  cms=rmq(j)
57939  ab(1,j,1)=ism*(cms*c1*sfmix(j,1) - sfmix(j,2)
57940  & *ed*(c2-c3*sinw**2))
57941  ab(1,j,2)=ism*(cms*c1*sfmix(j,3) - sfmix(j,4)
57942  & *ed*(c2-c3*sinw**2))
57943  ab(2,j,1)=cms*c1*sfmix(j,2) + sfmix(j,1)
57944  & *(ed*c2-c3*(1d0/2d0+ed*sinw**2))
57945  ab(2,j,2)=cms*c1*sfmix(j,4) + sfmix(j,3)
57946  & *(ed*c2-c3*(1d0/2d0+ed*sinw**2))
57947 C...Inermediate sup
57948  j=j+1
57949  cms=rmq(j)
57950  ab(1,j,1)=ism*(cms*c1u*sfmix(j,1) - sfmix(j,2)
57951  & *eu*(c2-c3*sinw**2))
57952  ab(1,j,2)=ism*(cms*c1u*sfmix(j,3) - sfmix(j,4)
57953  & *eu*(c2-c3*sinw**2))
57954  ab(2,j,1)=cms*c1u*sfmix(j,2) + sfmix(j,1)
57955  & *(eu*c2+c3*(1d0/2d0-eu*sinw**2))
57956  ab(2,j,2)=cms*c1u*sfmix(j,4) + sfmix(j,3)
57957  & *(eu*c2+c3*(1d0/2d0-eu*sinw**2))
57958  120 CONTINUE
57959 
57960  IF (imss(51).GE.1) THEN
57961 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57962 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57963 C...STEP IN I,J,K USING SINGLE COUNTER
57964  DO 130 isc=0,26
57965 C...LAMBDA COUPLING ASYM IN I,J
57966  IF(mod(isc/9,3).NE.mod(isc/3,3)) THEN
57967  lknt = lknt+1
57968  idlam(lknt,1) =-12 -2*mod(isc/9,3)
57969  idlam(lknt,2) =-11 -2*mod(isc/3,3)
57970  idlam(lknt,3) = 11 +2*mod(isc,3)
57971  xlam(lknt) = 0d0
57972 C...Set coupling, and decay product masses on/off
57973  rvlamc = rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1
57974  & ,mod(isc,3)+1)**2
57975  dcmass=.false.
57976  IF (idlam(lknt,2).EQ.-15.OR.idlam(lknt,3).EQ.15)
57977  & dcmass = .true.
57978 C...Resonance KF codes (1=I,2=J,3=K)
57979  kfr(1)=-idlam(lknt,1)
57980  kfr(2)=-idlam(lknt,2)
57981  kfr(3)=-idlam(lknt,3)
57982 C...Calculate width.
57983  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57984  & idlam(lknt,3),xlam(lknt))
57985  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57986 C...Charge conjugate mode.
57987  lknt=lknt+1
57988  idlam(lknt,1)=-idlam(lknt-1,1)
57989  idlam(lknt,2)=-idlam(lknt-1,2)
57990  idlam(lknt,3)=-idlam(lknt-1,3)
57991  xlam(lknt)=xlam(lknt-1)
57992 C...KINEMATICS CHECK
57993  IF (xlam(lknt).EQ.0d0) THEN
57994  lknt=lknt-2
57995  ENDIF
57996  ENDIF
57997  130 CONTINUE
57998  ENDIF
57999 
58000  IF (imss(52).GE.1) THEN
58001 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
58002 C * CHI0 -> NUBAR_I + DBAR_J + D_K
58003  DO 140 isc=0,26
58004  lknt = lknt+1
58005  idlam(lknt,1) =-12 -2*mod(isc/9,3)
58006  idlam(lknt,2) = -1 -2*mod(isc/3,3)
58007  idlam(lknt,3) = 1 +2*mod(isc,3)
58008  xlam(lknt) = 0d0
58009 C...Set coupling, and decay product masses on/off
58010  rvlamc = 3 * rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1
58011  & ,mod(isc,3)+1)**2
58012  dcmass=.false.
58013  IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.5)
58014  & dcmass = .true.
58015 C...Resonance KF codes (1=I,2=J,3=K)
58016  kfr(1)=-idlam(lknt,1)
58017  kfr(2)=-idlam(lknt,2)
58018  kfr(3)=-idlam(lknt,3)
58019 C...Calculate width.
58020  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58021  & ,xlam(lknt))
58022  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58023 C...Charge conjugate mode.
58024  lknt=lknt+1
58025  idlam(lknt,1)=-idlam(lknt-1,1)
58026  idlam(lknt,2)=-idlam(lknt-1,2)
58027  idlam(lknt,3)=-idlam(lknt-1,3)
58028  xlam(lknt)=xlam(lknt-1)
58029 C...KINEMATICS CHECK
58030  IF (xlam(lknt).EQ.0d0) THEN
58031  lknt=lknt-2
58032  ENDIF
58033 
58034 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
58035  lknt = lknt+1
58036  idlam(lknt,1) =-11 -2*mod(isc/9,3)
58037  idlam(lknt,2) = -2 -2*mod(isc/3,3)
58038  idlam(lknt,3) = 1 +2*mod(isc,3)
58039  xlam(lknt) = 0d0
58040 C...Set coupling, and decay product masses on/off
58041  rvlamc = 3 * rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1
58042  & ,mod(isc,3)+1)**2
58043  dcmass=.false.
58044  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-6
58045  & .OR.idlam(lknt,3).EQ.5) dcmass=.true.
58046 C...Resonance KF codes (1=I,2=J,3=K)
58047  kfr(1)=-idlam(lknt,1)
58048  kfr(2)=-idlam(lknt,2)
58049  kfr(3)=-idlam(lknt,3)
58050 C...Calculate width.
58051  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58052  & ,xlam(lknt))
58053  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58054 C...Charge conjugate mode.
58055  lknt=lknt+1
58056  idlam(lknt,1)=-idlam(lknt-1,1)
58057  idlam(lknt,2)=-idlam(lknt-1,2)
58058  idlam(lknt,3)=-idlam(lknt-1,3)
58059  xlam(lknt)=xlam(lknt-1)
58060 C...KINEMATICS CHECK
58061  IF (xlam(lknt).EQ.0d0) THEN
58062  lknt=lknt-2
58063  ENDIF
58064  140 CONTINUE
58065  ENDIF
58066 
58067  IF (imss(53).GE.1) THEN
58068 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
58069 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
58070  DO 150 isc=0,26
58071 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
58072  IF (mod(isc/3,3).LT.mod(isc,3)) THEN
58073  lknt = lknt+1
58074  idlam(lknt,1) = -2 -2*mod(isc/9,3)
58075  idlam(lknt,2) = -1 -2*mod(isc/3,3)
58076  idlam(lknt,3) = -1 -2*mod(isc,3)
58077  xlam(lknt) = 0d0
58078 C...Set coupling, and decay product masses on/off
58079  rvlamc = 6. * rvlamb(mod(isc/9,3)+1,mod(isc/3,3)
58080  & +1,mod(isc,3)+1)**2
58081  dcmass=.false.
58082  IF (idlam(lknt,1).EQ.-6.OR.idlam(lknt,2).EQ.-5
58083  & .OR.idlam(lknt,3).EQ.-5) dcmass=.true.
58084 C...Resonance KF codes (1=I,2=J,3=K)
58085  kfr(1) = idlam(lknt,1)
58086  kfr(2) = idlam(lknt,2)
58087  kfr(3) = idlam(lknt,3)
58088 C...Calculate width.
58089  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58090  & idlam(lknt,3),xlam(lknt))
58091  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58092 C...Charge conjugate mode.
58093  lknt=lknt+1
58094  idlam(lknt,1)=-idlam(lknt-1,1)
58095  idlam(lknt,2)=-idlam(lknt-1,2)
58096  idlam(lknt,3)=-idlam(lknt-1,3)
58097  xlam(lknt)=xlam(lknt-1)
58098 C...KINEMATICS CHECK
58099  IF (xlam(lknt).EQ.0d0) THEN
58100  lknt=lknt-2
58101  ENDIF
58102  ENDIF
58103  150 CONTINUE
58104  ENDIF
58105  ENDIF
58106  ENDIF
58107 
58108  RETURN
58109  END
58110 
58111 C*********************************************************************
58112 
58113 C...PYRVCH
58114 C...Calculates R-violating chargino decay widths.
58115 C...P. Z. Skands
58116 
58117  SUBROUTINE pyrvch(KFIN,XLAM,IDLAM,LKNT)
58118 
58119 C...Double precision and integer declarations.
58120  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58121  IMPLICIT INTEGER(i-n)
58122 C...Parameter statement to help give large particle numbers.
58123  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
58124  &kexcit=4000000,kdimen=5000000)
58125 C...Commonblocks.
58126  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58127  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58128  common/pymssm/imss(0:99),rmss(0:99)
58129  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
58130  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
58131  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
58132 C...Local variables.
58133  DOUBLE PRECISION xlam(0:400)
58134  INTEGER idlam(400,3), pycomp
58135 C...Information from main routine to PYRVGW
58136  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58137  & ,dcmass,kfr(3)
58138 C...Auxiliary variables needed for BV (RV Gauge STOre)
58139  common/rvgsto/xresi,xresj,xresk,xresij,xresik,xresjk,rvlijk,rvlkij
58140  & ,rvljki,rvljik
58141 C...Running quark masses
58142  DOUBLE PRECISION rmq(6)
58143 C...Decay product masses on/off
58144  LOGICAL dcmass
58145  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pymsrv/,/pyrvnv/,
58146  & /rvgsto/
58147 
58148 
58149 C...IF R-VIOLATION ON.
58150  IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
58151  kfsm=kfin-ksusy1
58152  IF(kfsm.EQ.24.OR.kfsm.EQ.37) THEN
58153 C...WHICH CHARGINO ?
58154  nchi = 1
58155  IF (kfsm.EQ.37) nchi = 2
58156 
58157 C...Useful parameters for calculating the A and B constants.
58158 C...SIGN OF MASS (Opposite convention as HERWIG)
58159  ism = 1
58160  IF (smw(nchi).LT.0d0) ism = -1
58161  wmass = pmas(pycomp(24),1)
58162  cosb = 1/(sqrt(1+rmss(5)**2))
58163  sinb = rmss(5)/sqrt(1+rmss(5)**2)
58164  gw2 = 4*paru(103)*paru(1)/paru(102)
58165  c1u = umix(nchi,2)/(sqrt(2d0)*cosb*wmass)
58166  c1v = vmix(nchi,2)/(sqrt(2d0)*sinb*wmass)
58167  c2 = umix(nchi,1)
58168  c3 = vmix(nchi,1)
58169 C...Running masses at Q^2=MCHI^2.
58170  sqmchi = pmas(pycomp(kfsm),1)**2
58171  DO 100 i=1,6
58172  rmq(i)=pymrun(i,sqmchi)
58173  100 CONTINUE
58174 
58175 C... AB(x,y,z) coefficients:
58176 C x=1-2 : A or B coefficient (1:A ; 2:B)
58177 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58178 C 11-16:e,nu_e,mu,...)
58179 C z=1-2 : Mass eigenstate number
58180  DO 110 i = 11,15,2
58181 C...Intermediate sleptons
58182  ab(1,i,1) = 0d0
58183  ab(1,i,2) = 0d0
58184  ab(2,i,1) = -pmas(pycomp(i),1)*c1u*sfmix(i,2) +
58185  & sfmix(i,1)*c2
58186  ab(2,i,2) = -pmas(pycomp(i),1)*c1u*sfmix(i,4) +
58187  & sfmix(i,3)*c2
58188 C...Intermediate sneutrinos
58189  ab(1,i+1,1) = -pmas(pycomp(i),1)*c1u
58190  ab(1,i+1,2) = 0d0
58191  ab(2,i+1,1) = ism*c3
58192  ab(2,i+1,2) = 0d0
58193 C...Intermediate sdown
58194  j=i-10
58195  ab(1,j,1) = -rmq(j+1)*c1v*sfmix(j,1)
58196  ab(1,j,2) = -rmq(j+1)*c1v*sfmix(j,3)
58197  ab(2,j,1) = -ism*(rmq(j)*c1u*sfmix(j,2) - sfmix(j,1)*c2)
58198  ab(2,j,2) = -ism*(rmq(j)*c1u*sfmix(j,4) - sfmix(j,3)*c2)
58199 C...Intermediate sup
58200  j=j+1
58201  ab(1,j,1) = -rmq(j-1)*c1u*sfmix(j,1)
58202  ab(1,j,2) = -rmq(j-1)*c1u*sfmix(j,3)
58203  ab(2,j,1) = -ism*(rmq(j)*c1v*sfmix(j,2) - sfmix(j,1)*c3)
58204  ab(2,j,2) = -ism*(rmq(j)*c1v*sfmix(j,4) - sfmix(j,3)*c3)
58205  110 CONTINUE
58206 
58207 C...LLE TYPE R-VIOLATION
58208  IF (imss(51).GE.1) THEN
58209 C...LOOP OVER DECAY MODES
58210  DO 140 isc=0,26
58211 
58212 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
58213  IF(mod(isc/9,3).NE.mod(isc/3,3)) THEN
58214  lknt = lknt+1
58215  idlam(lknt,1) = -12 -2*mod(isc/9,3)
58216  idlam(lknt,2) = -11 -2*mod(isc/3,3)
58217  idlam(lknt,3) = 12 +2*mod(isc,3)
58218  xlam(lknt) = 0d0
58219 C...Set coupling, and decay product masses on/off
58220  rvlamc = gw2 * 5d-1 *
58221  & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
58222  & **2
58223  dcmass=.false.
58224  IF (idlam(lknt,2).EQ.-15) dcmass = .true.
58225 C...Resonance KF codes (1=I,2=J,3=K).
58226  kfr(1) = 0
58227  kfr(2) = 0
58228  kfr(3) = -idlam(lknt,3)+1
58229 C...Calculate width.
58230  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58231  & idlam(lknt,3),xlam(lknt))
58232  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58233 C...KINEMATICS CHECK
58234  IF (xlam(lknt).EQ.0d0) THEN
58235  lknt=lknt-1
58236  ENDIF
58237 
58238 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
58239  120 IF (mod(isc/9,3).LT.mod(isc/3,3)) THEN
58240  lknt = lknt+1
58241  idlam(lknt,1) = 12 +2*mod(isc/9,3)
58242  idlam(lknt,2) = 12 +2*mod(isc/3,3)
58243  idlam(lknt,3) =-11 -2*mod(isc,3)
58244  xlam(lknt) = 0d0
58245 C...Set coupling, and decay product masses on/off
58246  rvlamc = gw2 * 5d-1 *
58247  & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
58248 C...I,J SYMMETRY => FACTOR 2
58249  rvlamc=2*rvlamc
58250  dcmass=.false.
58251  IF (idlam(lknt,3).EQ.-15) dcmass = .true.
58252 C...Resonance KF codes (1=I,2=J,3=K)
58253  kfr(1)=idlam(lknt,1)-1
58254  kfr(2)=idlam(lknt,2)-1
58255  kfr(3)=0
58256 C...Calculate width.
58257  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58258  & idlam(lknt,3),xlam(lknt))
58259  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58260 C...KINEMATICS CHECK
58261  IF (xlam(lknt).EQ.0d0) THEN
58262  lknt=lknt-1
58263  ENDIF
58264 
58265 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J)
58266 C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement
58267 C * from above, thanks to N.-E. Bomark.
58268  lknt = lknt+1
58269  idlam(lknt,1) =-11 -2*mod(isc/9,3)
58270  idlam(lknt,2) =-11 -2*mod(isc/3,3)
58271  idlam(lknt,3) = 11 +2*mod(isc,3)
58272  xlam(lknt) = 0d0
58273 C...Set coupling, and decay product masses on/off
58274  rvlamc = gw2 * 5d-1 *
58275  & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
58276 C...I,J SYMMETRY => FACTOR 2
58277  rvlamc=2*rvlamc
58278  dcmass=.false.
58279  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-15
58280  & .OR.idlam(lknt,3).EQ.15) dcmass = .true.
58281 C...Resonance KF codes (1=I,2=J,3=K)
58282  kfr(1) =-idlam(lknt,1)+1
58283  kfr(2) =-idlam(lknt,2)+1
58284  kfr(3) = 0
58285 C...Calculate width.
58286  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58287  & idlam(lknt,3),xlam(lknt))
58288  xlam(lknt)=xlam(lknt)*rvlamc
58289  & /((2*paru(1)*rms(0))**3*32)
58290 C...KINEMATICS CHECK
58291  IF (xlam(lknt).EQ.0d0) THEN
58292  lknt=lknt-1
58293  ENDIF
58294  ENDIF
58295  ENDIF
58296  140 CONTINUE
58297  ENDIF
58298 
58299 C...LQD TYPE R-VIOLATION
58300  IF (imss(52).GE.1) THEN
58301 C...LOOP OVER DECAY MODES
58302  DO 180 isc=0,26
58303 
58304 C...CHI+ -> NUBAR_I + DBAR_J + U_K
58305  lknt = lknt+1
58306  idlam(lknt,1) =-12 -2*mod(isc/9,3)
58307  idlam(lknt,2) = -1 -2*mod(isc/3,3)
58308  idlam(lknt,3) = 2 +2*mod(isc,3)
58309  xlam(lknt) = 0d0
58310 C...Set coupling, and decay product masses on/off
58311  rvlamc = 3. * gw2 * 5d-1 *
58312  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
58313  dcmass=.false.
58314  IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.6)
58315  & dcmass = .true.
58316 C...Resonance KF codes (1=I,2=J,3=K)
58317  kfr(1)=0
58318  kfr(2)=0
58319  kfr(3)=-idlam(lknt,3)+1
58320 C...Calculate width.
58321  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58322  & ,xlam(lknt))
58323  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58324 C...KINEMATICS CHECK
58325  IF (xlam(lknt).EQ.0d0) THEN
58326  lknt=lknt-1
58327  ENDIF
58328 
58329 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
58330  150 lknt = lknt+1
58331  idlam(lknt,1) =-11 -2*mod(isc/9,3)
58332  idlam(lknt,2) = -2 -2*mod(isc/3,3)
58333  idlam(lknt,3) = 2 +2*mod(isc,3)
58334  xlam(lknt) = 0d0
58335 C...Set coupling, and decay product masses on/off
58336  rvlamc = 3. * gw2 * 5d-1 *
58337  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
58338  dcmass=.false.
58339  IF (idlam(lknt,1).EQ.-11.OR.idlam(lknt,2).EQ.-6
58340  & .OR.idlam(lknt,3).EQ.6) dcmass = .true.
58341 C...Resonance KF codes (1=I,2=J,3=K)
58342  kfr(1)=0
58343  kfr(2)=0
58344  kfr(3)=-idlam(lknt,3)+1
58345 C...Calculate width.
58346  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58347  & ,xlam(lknt))
58348  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58349 C...KINEMATICS CHECK
58350  IF (xlam(lknt).EQ.0d0) THEN
58351  lknt=lknt-1
58352  ENDIF
58353 
58354 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
58355  160 lknt = lknt+1
58356  idlam(lknt,1) =-11 -2*mod(isc/9,3)
58357  idlam(lknt,2) = -1 -2*mod(isc/3,3)
58358  idlam(lknt,3) = 1 +2*mod(isc,3)
58359  xlam(lknt) = 0d0
58360 C...Set coupling, and decay product masses on/off
58361  rvlamc = 3. * gw2 * 5d-1 *
58362  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
58363  dcmass = .false.
58364  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-5
58365  & .OR.idlam(lknt,3).EQ.5) dcmass = .true.
58366 C...Resonance KF codes (1=I,2=J,3=K)
58367  kfr(1)=-idlam(lknt,1)+1
58368  kfr(2)=-idlam(lknt,2)+1
58369  kfr(3)=0
58370 C...Calculate width.
58371  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58372  & ,xlam(lknt))
58373  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58374 C...KINEMATICS CHECK
58375  IF (xlam(lknt).EQ.0d0) THEN
58376  lknt=lknt-1
58377  ENDIF
58378 
58379 C * CHI+ -> NU_I + U_J + DBAR_K.
58380  170 lknt = lknt+1
58381  idlam(lknt,1) = 12 +2*mod(isc/9,3)
58382  idlam(lknt,2) = 2 +2*mod(isc/3,3)
58383  idlam(lknt,3) = -1 -2*mod(isc,3)
58384  xlam(lknt) = 0d0
58385 C...Set coupling, and decay product masses on/off
58386  dcmass = .false.
58387  rvlamc = 3. * gw2 * 5d-1 *
58388  & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
58389  IF (idlam(lknt,2).EQ.6.OR.idlam(lknt,3).EQ.-5)
58390  & dcmass = .true.
58391 C...Resonance KF codes (1=I,2=J,3=K)
58392  kfr(1)=idlam(lknt,1)-1
58393  kfr(2)=idlam(lknt,2)-1
58394  kfr(3)=0
58395 C...Calculate width.
58396  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58397  & ,xlam(lknt))
58398  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58399 C...KINEMATICS CHECK
58400  IF (xlam(lknt).EQ.0d0) THEN
58401  lknt=lknt-1
58402  ENDIF
58403 
58404  180 CONTINUE
58405  ENDIF
58406 
58407 C...UDD TYPE R-VIOLATION
58408 C...These decays need special treatment since more than one BV coupling
58409 C...contributes (with interference). Consider e.g. (symbolically)
58410 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
58411 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
58412 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
58413 C...The problem is that a single call to PYRVGW would evaluate all
58414 C...these terms and sum them, but without the different couplings. The
58415 C...way out is to call PYRVGW three times, once for the first line, once
58416 C...for the second line, and then once for all the lines (it is
58417 C...impossible to get just the last line out) without multiplying by
58418 C...couplings. The last line is then obtained as the result of the third
58419 C...call minus the results of the two first calls. Each term is then
58420 C...multiplied by its respective coupling before the whole thing is
58421 C...summed up in XLAM.
58422 C...Note that with three interfering resonances, this procedure becomes
58423 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
58424 
58425  IF (imss(53).GE.1) THEN
58426 C...LOOP OVER DECAY MODES
58427  DO 190 isc=1,25
58428 
58429 C...CHI+ -> U_I + U_J + D_K
58430 C...Decay mode I<->J symmetric.
58431  IF (mod(isc/9,3).LE.mod(isc/3,3).AND.isc.NE.13) THEN
58432  lknt = lknt+1
58433  idlam(lknt,1) = 2 +2*mod(isc/9,3)
58434  idlam(lknt,2) = 2 +2*mod(isc/3,3)
58435  idlam(lknt,3) = 1 +2*mod(isc,3)
58436  xlam(lknt) = 0d0
58437 C...Set coupling, and decay product masses on/off
58438  rvlamc= 6. * gw2 * 5d-1
58439  rvljik= rvlamb(mod(isc/3,3)+1,mod(isc/9,3)+1,mod(isc,3)
58440  & +1)
58441  rvlijk= rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)
58442  & +1)
58443  IF (mod(isc/9,3).EQ.mod(isc/3,3)) rvlamc = 5d-1
58444  & * rvlamc
58445  dcmass=.false.
58446  IF (idlam(lknt,1).EQ.6.OR.idlam(lknt,2).EQ.6
58447  & .OR.idlam(lknt,3).EQ.5) dcmass =.true.
58448 C...Resonance KF codes (1=I,2=J,3=K)
58449  kfr(1) = -idlam(lknt,1)+1
58450  kfr(2) = 0
58451  kfr(3) = 0
58452 C...Calculate width.
58453  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58454  & idlam(lknt,3),xresi)
58455 C...Resonance KF codes (1=I,2=J,3=K)
58456  kfr(1) = 0
58457  kfr(2) = -idlam(lknt,2)+1
58458  kfr(3) = 0
58459 C...Calculate width.
58460  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58461  & idlam(lknt,3),xresj)
58462 C...Resonance KF codes (1=I,2=J,3=K)
58463  kfr(1) = -idlam(lknt,1)+1
58464  kfr(2) = -idlam(lknt,2)+1
58465  kfr(3) = 0
58466 C...Calculate width.
58467  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58468  & idlam(lknt,3),xresij)
58469  IF (abs(xresi+xresj-xresij).GT.1d-4*xresij) THEN
58470  xresij = xresij-xresi-xresj
58471  ELSE
58472  xresij = 0d0
58473  ENDIF
58474 C...CALCULATE TOTAL WIDTH
58475  xlam(lknt) = rvljik**2 * xresi + rvlijk**2 * xresj
58476  & + rvljik*rvlijk * xresij
58477  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58478 C...KINEMATICS CHECK
58479  IF (xlam(lknt).EQ.0d0) THEN
58480  lknt=lknt-1
58481  ENDIF
58482  ENDIF
58483 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
58484 C...Symmetry I<->J<->K.
58485  IF ((mod(isc/9,3).LE.mod(isc/3,3)).AND.(mod(isc/3,3).le
58486  & .mod(isc,3)).AND.isc.NE.13) THEN
58487  lknt = lknt+1
58488  idlam(lknt,1) = -1 -2*mod(isc/9,3)
58489  idlam(lknt,2) = -1 -2*mod(isc/3,3)
58490  idlam(lknt,3) = -1 -2*mod(isc,3)
58491  xlam(lknt) = 0d0
58492 C...Set coupling, and decay product masses on/off
58493  rvlamc = 6. * gw2 * 5d-1
58494  rvlijk = rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)
58495  & +1)
58496  rvlkij = rvlamb(mod(isc,3)+1,mod(isc/9,3)+1,mod(isc/3,3)
58497  & +1)
58498  rvljki = rvlamb(mod(isc/3,3)+1,mod(isc,3)+1,mod(isc/9,3)
58499  & +1)
58500  dcmass = .false.
58501  IF (idlam(lknt,1).EQ.-5.OR.idlam(lknt,2).EQ.-5
58502  & .OR.idlam(lknt,3).EQ.-5) dcmass = .true.
58503 C...Collect symmetry factors
58504  IF (mod(isc/9,3).EQ.mod(isc/3,3).OR.mod(isc/3,3).eq
58505  & .mod(isc,3).OR.mod(isc/9,3).EQ.mod(isc,3))
58506  & rvlamc = 5d-1 * rvlamc
58507 C...Resonance KF codes (1=I,2=J,3=K)
58508  kfr(1) = idlam(lknt,1)-1
58509  kfr(2) = 0
58510  kfr(3) = 0
58511 C...Calculate width.
58512  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58513  & idlam(lknt,3),xresi)
58514 C...Resonance KF codes (1=I,2=J,3=K)
58515  kfr(1) = 0
58516  kfr(2) = idlam(lknt,2)-1
58517  kfr(3) = 0
58518 C...Calculate width.
58519  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58520  & idlam(lknt,3),xresj)
58521 C...Resonance KF codes (1=I,2=J,3=K)
58522  kfr(1) = 0
58523  kfr(2) = 0
58524  kfr(3) = idlam(lknt,3)-1
58525 C...Calculate width.
58526  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58527  & idlam(lknt,3),xresk)
58528 C...Resonance KF codes (1=I,2=J,3=K)
58529  kfr(1) = idlam(lknt,1)-1
58530  kfr(2) = idlam(lknt,2)-1
58531  kfr(3) = 0
58532 C...Calculate width.
58533  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58534  & idlam(lknt,3),xresij)
58535  IF (abs(xresi+xresj-xresij).GT.1d-4*(xresi+xresj)) THEN
58536  xresij = xresi+xresj-xresij
58537  ELSE
58538  xresij = 0d0
58539  ENDIF
58540 C...Resonance KF codes (1=I,2=J,3=K)
58541  kfr(1) = 0
58542  kfr(2) = idlam(lknt,2)-1
58543  kfr(3) = idlam(lknt,3)-1
58544 C...Calculate width.
58545  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58546  & idlam(lknt,3),xresjk)
58547  IF (abs(xresj+xresk-xresjk).GT.1d-4*(xresj+xresk)) THEN
58548  xresjk = xresj+xresk-xresjk
58549  ELSE
58550  xresjk = 0d0
58551  ENDIF
58552 C...Resonance KF codes (1=I,2=J,3=K)
58553  kfr(1) = idlam(lknt,1)-1
58554  kfr(2) = 0
58555  kfr(3) = idlam(lknt,3)-1
58556 C...Calculate width.
58557  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
58558  & idlam(lknt,3),xresik)
58559  IF (abs(xresi+xresk-xresik).GT.1d-4*(xresi+xresk)) THEN
58560  xresik = xresi+xresk-xresik
58561  ELSE
58562  xresik = 0d0
58563  ENDIF
58564 C...CALCULATE TOTAL WIDTH
58565  xlam(lknt) =
58566  & rvlijk**2 * xresi
58567  & + rvljki**2 * xresj
58568  & + rvlkij**2 * xresk
58569  & + rvlijk*rvljki * xresij
58570  & + rvlijk*rvlkij * xresik
58571  & + rvljki*rvlkij * xresjk
58572  xlam(lknt)=xlam(lknt)*rvlamc/((2.*paru(1)*rms(0))**3*32)
58573 C...KINEMATICS CHECK
58574  IF (xlam(lknt).EQ.0d0) THEN
58575  lknt=lknt-1
58576  ENDIF
58577  ENDIF
58578  190 CONTINUE
58579  ENDIF
58580  ENDIF
58581  ENDIF
58582 
58583  RETURN
58584  END
58585 
58586 C*********************************************************************
58587 
58588 C...PYRVGL
58589 C...Calculates R-violating gluino decay widths.
58590 C...See BV part of PYRVCH for comments about the way the BV decay width
58591 C...is calculated. Same comments apply here.
58592 C...P. Z. Skands
58593 
58594  SUBROUTINE pyrvgl(KFIN,XLAM,IDLAM,LKNT)
58595 
58596 C...Double precision and integer declarations.
58597  IMPLICIT DOUBLE PRECISION(a-h, o-z)
58598  IMPLICIT INTEGER(i-n)
58599 C...Parameter statement to help give large particle numbers.
58600  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
58601  &kexcit=4000000,kdimen=5000000)
58602 C...Commonblocks.
58603  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58604  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58605  common/pymssm/imss(0:99),rmss(0:99)
58606  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
58607  &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
58608  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
58609 C...Local variables.
58610  DOUBLE PRECISION xlam(0:400)
58611  INTEGER idlam(400,3), pycomp
58612 C...Information from main routine to PYRVGW
58613  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58614  & ,dcmass,kfr(3)
58615 C...Auxiliary variables needed for BV (RV Gauge STOre)
58616  common/rvgsto/xresi,xresj,xresk,xresij,xresik,xresjk,rvlijk,rvlkij
58617  & ,rvljki,rvljik
58618 C...Running quark masses
58619  DOUBLE PRECISION rmq(6)
58620 C...Decay product masses on/off
58621  LOGICAL dcmass
58622  SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pymsrv/,/pyrvnv/,
58623  & /rvgsto/
58624 
58625 C...IF LQD OR UDD TYPE R-VIOLATION ON.
58626  IF (imss(52).GE.1.OR.imss(53).GE.1) THEN
58627  kfsm=kfin-ksusy1
58628 
58629 C... AB(x,y,z):
58630 C x=1-2 : Select A or B coupling (1:A ; 2:B)
58631 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58632 C 11-16:e,nu_e,mu,... not used here)
58633 C z=1-2 : Mass eigenstate number
58634  DO 100 i = 1,6
58635 C...A Couplings
58636  ab(1,i,1) = sfmix(i,2)
58637  ab(1,i,2) = sfmix(i,4)
58638 C...B Couplings
58639  ab(2,i,1) = -sfmix(i,1)
58640  ab(2,i,2) = -sfmix(i,3)
58641  100 CONTINUE
58642  gstr2 = 4d0*paru(1) * pyalps(pmas(pycomp(kfin),1)**2)
58643 C...LQD DECAYS.
58644  IF (imss(52).GE.1) THEN
58645 C...STEP IN I,J,K USING SINGLE COUNTER
58646  DO 120 isc=0,26
58647 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
58648  lknt = lknt+1
58649  idlam(lknt,1) =-12 -2*mod(isc/9,3)
58650  idlam(lknt,2) = -1 -2*mod(isc/3,3)
58651  idlam(lknt,3) = 1 +2*mod(isc,3)
58652  xlam(lknt)=0d0
58653 C...Set coupling, and decay product masses on/off
58654  rvlamc=rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
58655  & * 5d-1 * gstr2
58656  dcmass = .false.
58657  IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.5) dcmass=.true.
58658 C...Resonance KF codes (1=I,2=J,3=K)
58659  kfr(1) = 0
58660  kfr(2) = -idlam(lknt,2)
58661  kfr(3) = -idlam(lknt,3)
58662 C...Calculate width.
58663  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58664  & ,xlam(lknt))
58665 C...Normalize
58666  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58667 C...Charge conjugate mode.
58668  110 lknt = lknt+1
58669  idlam(lknt,1) =-idlam(lknt-1,1)
58670  idlam(lknt,2) =-idlam(lknt-1,2)
58671  idlam(lknt,3) =-idlam(lknt-1,3)
58672  xlam(lknt) = xlam(lknt-1)
58673 C...KINEMATICS CHECK
58674  IF (xlam(lknt).EQ.0d0) THEN
58675  lknt=lknt-2
58676  ENDIF
58677 
58678 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
58679  lknt = lknt+1
58680  idlam(lknt,1) =-11 -2*mod(isc/9,3)
58681  idlam(lknt,2) = -2 -2*mod(isc/3,3)
58682  idlam(lknt,3) = 1 +2*mod(isc,3)
58683  xlam(lknt)=0d0
58684 C...Set coupling, and decay product masses on/off
58685  rvlamc = rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
58686  & **2* 5d-1 * gstr2
58687  dcmass = .false.
58688  IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-6
58689  & .OR.idlam(lknt,3).EQ.5) dcmass = .true.
58690 C...Resonance KF codes (1=I,2=J,3=K)
58691  kfr(1) = 0
58692  kfr(2) = -idlam(lknt,2)
58693  kfr(3) = -idlam(lknt,3)
58694 C...Calculate width.
58695  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58696  & ,xlam(lknt))
58697  xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58698 C...Charge conjugate mode.
58699  lknt=lknt+1
58700  idlam(lknt,1) = -idlam(lknt-1,1)
58701  idlam(lknt,2) = -idlam(lknt-1,2)
58702  idlam(lknt,3) = -idlam(lknt-1,3)
58703  xlam(lknt) = xlam(lknt-1)
58704 C...KINEMATICS CHECK
58705  IF (xlam(lknt).EQ.0d0) THEN
58706  lknt=lknt-2
58707  ENDIF
58708 
58709  120 CONTINUE
58710  ENDIF
58711 
58712 C...UDD DECAYS.
58713  IF (imss(53).GE.1) THEN
58714 C...STEP IN I,J,K USING SINGLE COUNTER
58715  DO 130 isc=0,26
58716 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
58717  IF (mod(isc/3,3).LT.mod(isc,3)) THEN
58718  lknt = lknt+1
58719  idlam(lknt,1) = -2 -2*mod(isc/9,3)
58720  idlam(lknt,2) = -1 -2*mod(isc/3,3)
58721  idlam(lknt,3) = -1 -2*mod(isc,3)
58722  xlam(lknt)=0d0
58723 C...Set coupling, and decay product masses on/off. A factor of 2 for
58724 C...(N_C-1) has been used to cancel a factor 0.5.
58725  rvlamc=rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
58726  & **2 * gstr2
58727  dcmass = .false.
58728  IF (idlam(lknt,1).EQ.-6.OR.idlam(lknt,2).EQ.-5
58729  & .OR.idlam(lknt,3).EQ.-5) dcmass=.true.
58730 C...Resonance KF codes (1=I,2=J,3=K)
58731  kfr(1) = idlam(lknt,1)
58732  kfr(2) = 0
58733  kfr(3) = 0
58734 C...Calculate width.
58735  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58736  & ,xresi)
58737 C...Resonance KF codes (1=I,2=J,3=K)
58738  kfr(1) = 0
58739  kfr(2) = idlam(lknt,2)
58740  kfr(3) = 0
58741 C...Calculate width.
58742  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58743  & ,xresj)
58744 C...Resonance KF codes (1=I,2=J,3=K)
58745  kfr(1) = 0
58746  kfr(2) = 0
58747  kfr(3) = idlam(lknt,3)
58748 C...Calculate width.
58749  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58750  & ,xresk)
58751 C...Resonance KF codes (1=I,2=J,3=K)
58752  kfr(1) = idlam(lknt,1)
58753  kfr(2) = idlam(lknt,2)
58754  kfr(3) = 0
58755 C...Calculate width.
58756  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58757  & ,xresij)
58758 C...Calculate interference function. (Factor -1/2 to make up for factor
58759 C...-2 in PYRVGW.
58760  IF (abs(xresi+xresj-xresij).GT.1d-4*xresij) THEN
58761  xresij = 5d-1 * (xresi+xresj-xresij)
58762  ELSE
58763  xresij = 0d0
58764  ENDIF
58765 C...Resonance KF codes (1=I,2=J,3=K)
58766  kfr(1) = 0
58767  kfr(2) = idlam(lknt,2)
58768  kfr(3) = idlam(lknt,3)
58769 C...Calculate width.
58770  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58771  & ,xresjk)
58772  IF (abs(xresj+xresk-xresjk).GT.1d-4*xresjk) THEN
58773  xresjk = 5d-1 * (xresj+xresk-xresjk)
58774  ELSE
58775  xresjk = 0d0
58776  ENDIF
58777 C...Resonance KF codes (1=I,2=J,3=K)
58778  kfr(1) = idlam(lknt,1)
58779  kfr(2) = 0
58780  kfr(3) = idlam(lknt,3)
58781 C...Calculate width.
58782  CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
58783  & ,xresik)
58784  IF (abs(xresi+xresk-xresik).GT.1d-4*xresik) THEN
58785  xresik = 5d-1 * (xresi+xresk-xresik)
58786  ELSE
58787  xresik = 0d0
58788  ENDIF
58789 C...Calculate total width (factor 1/2 from 1/(N_C-1))
58790  xlam(lknt) = xresi + xresj + xresk
58791  & + 5d-1 * (xresij + xresik + xresjk)
58792 C...Normalize
58793  xlam(lknt) = xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
58794 C...Charge conjugate mode.
58795  lknt = lknt+1
58796  idlam(lknt,1) =-idlam(lknt-1,1)
58797  idlam(lknt,2) =-idlam(lknt-1,2)
58798  idlam(lknt,3) =-idlam(lknt-1,3)
58799  xlam(lknt) = xlam(lknt-1)
58800 C...KINEMATICS CHECK
58801  IF (xlam(lknt).EQ.0d0) THEN
58802  lknt=lknt-2
58803  ENDIF
58804  ENDIF
58805  130 CONTINUE
58806  ENDIF
58807  ENDIF
58808  RETURN
58809  END
58810 
58811 C*********************************************************************
58812 
58813 C...PYRVSB
58814 C...Auxiliary function to PYRVSF for calculating R-Violating
58815 C...sfermion widths. Though the decay products are most often treated
58816 C...as massless in the calculation, the kinematical boundary of phase
58817 C...space is tested using the true masses.
58818 C...MODE = 1: All decay products massive
58819 C...MODE = 2: Decay product 1 massless
58820 C...MODE = 3: Decay product 2 massless
58821 C...MODE = 4: All decay products massless
58822 
58823  FUNCTION pyrvsb(KFIN,ID1,ID2,RM2,MODE)
58824 
58825  IMPLICIT DOUBLE PRECISION (a-h,o-z)
58826  IMPLICIT integer(i-n)
58827  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58828  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58829  SAVE /pydat1/,/pydat2/
58830  DOUBLE PRECISION sm(3)
58831  INTEGER pycomp, kc(3)
58832  kc(1)=pycomp(kfin)
58833  kc(2)=pycomp(id1)
58834  kc(3)=pycomp(id2)
58835  sm(1)=pmas(kc(1),1)**2
58836  sm(2)=pmas(kc(2),1)**2
58837  sm(3)=pmas(kc(3),1)**2
58838 C...Kinematics check
58839  IF ((sm(1)-(pmas(kc(2),1)+pmas(kc(3),1))**2).LE.0d0) THEN
58840  pyrvsb=0d0
58841  RETURN
58842  ENDIF
58843 C...CM momenta squared
58844  IF (mode.EQ.1) THEN
58845  p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(2),1)+pmas(kc(3),1))**2)
58846  & * (sm(1)-(pmas(kc(2),1)-pmas(kc(3),1))**2)
58847  ELSE IF (mode.EQ.2) THEN
58848  p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(3),1))**2)**2
58849  ELSE IF (mode.EQ.3) THEN
58850  p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(2),1))**2)**2
58851  ELSE
58852  p2cm=sm(1)/4.
58853  ENDIF
58854 C...Calculate Width
58855  pyrvsb=rm2*sqrt(max(0d0,p2cm))/(8*paru(1)*sm(1))
58856  RETURN
58857  END
58858 
58859 C*********************************************************************
58860 
58861 C...PYRVGW
58862 C...Generalized Matrix Element for R-Violating 3-body widths.
58863 C...P. Z. Skands
58864  SUBROUTINE pyrvgw(KFIN,ID1,ID2,ID3,XLAM)
58865 
58866  IMPLICIT DOUBLE PRECISION (a-h,o-z)
58867  IMPLICIT integer(i-n)
58868  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
58869  &kexcit=4000000,kdimen=5000000)
58870  parameter(eps=1d-4)
58871  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58872  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58873  & ,dcmass,kfr(3)
58874  common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
58875  & sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
58876  DOUBLE PRECISION xlim(3,3)
58877  INTEGER kc(0:3), pycomp
58878  LOGICAL dcmass, dcheck(6)
58879  SAVE /pydat2/,/pyrvnv/,/pyssmt/
58880 
58881  xlam = 0d0
58882 
58883  kc(0) = pycomp(kfin)
58884  kc(1) = pycomp(id1)
58885  kc(2) = pycomp(id2)
58886  kc(3) = pycomp(id3)
58887  rms(0) = pmas(kc(0),1)
58888  rms(1) = pymrun(id1,pmas(kc(1),1)**2)
58889  rms(2) = pymrun(id2,pmas(kc(2),1)**2)
58890  rms(3) = pymrun(id3,pmas(kc(3),1)**2)
58891 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58892  xlim(1,1)=(rms(1)+rms(2))**2
58893  xlim(1,2)=(rms(0)-rms(3))**2
58894  xlim(1,3)=xlim(1,2)-xlim(1,1)
58895  xlim(2,1)=(rms(2)+rms(3))**2
58896  xlim(2,2)=(rms(0)-rms(1))**2
58897  xlim(2,3)=xlim(2,2)-xlim(2,1)
58898  xlim(3,1)=(rms(1)+rms(3))**2
58899  xlim(3,2)=(rms(0)-rms(2))**2
58900  xlim(3,3)=xlim(3,2)-xlim(3,1)
58901 C...Check Phase Space
58902  IF (xlim(1,3).LT.0d0.OR.xlim(2,3).LT.0d0.OR.xlim(3,3).LT.0d0) THEN
58903  RETURN
58904  ENDIF
58905 
58906 C...INITIALIZE RESONANCE INFORMATION
58907  DO 110 jres = 1,3
58908  DO 100 imass = 1,2
58909  ires = 2*(jres-1)+imass
58910  intres(ires,1) = 0
58911  dcheck(ires) =.false.
58912 C...NO RIGHT-HANDED NEUTRINOS
58913  IF (((imass.EQ.2).AND.((iabs(kfr(jres)).EQ.12).or
58914  & .(iabs(kfr(jres)).EQ.14).OR.(iabs(kfr(jres)).EQ.16))).or
58915  & .kfr(jres).EQ.0) goto 100
58916  res(ires,1) = pmas(pycomp(imass*ksusy1+iabs(kfr(jres))),1)
58917  res(ires,2) = pmas(pycomp(imass*ksusy1+iabs(kfr(jres))),2)
58918  intres(ires,1) = iabs(kfr(jres))
58919  intres(ires,2) = imass
58920  IF (kfr(jres).LT.0) intres(ires,3) = 1
58921  IF (kfr(jres).GT.0) intres(ires,3) = 0
58922  100 CONTINUE
58923  110 CONTINUE
58924 
58925 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58926 
58927 C...RESONANCE CONTRIBUTIONS
58928 C...(Only sum contributions where the resonance is off shell).
58929 C...Store whether diagram on/off in DCHECK.
58930 C...LOOP OVER MASS STATES
58931  DO 120 j=1,2
58932  idr=j
58933  IF(intres(idr,1).NE.0) THEN
58934 
58935  tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
58936  IF ((rms(0).LT.(rms(1)+res(idr,1)).OR.(res(idr,1).LT.(rms(2)
58937  & +rms(3)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
58938  dcheck(idr) =.true.
58939  xlam = xlam + tmix * pyrvi1(2,3,1)
58940  ENDIF
58941  ENDIF
58942 
58943  idr=j+2
58944  IF(intres(idr,1).NE.0) THEN
58945  tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
58946  IF ((rms(0).LT.(rms(2)+res(idr,1)).OR.(res(idr,1).LT.(rms(1)
58947  & +rms(3)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
58948  dcheck(idr) =.true.
58949  xlam = xlam + tmix * pyrvi1(1,3,2)
58950  ENDIF
58951  ENDIF
58952 
58953  idr=j+4
58954  IF(intres(idr,1).NE.0) THEN
58955  tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
58956  IF ((rms(0).LT.(rms(3)+res(idr,1)).OR.(res(idr,1).LT.(rms(1)
58957  & +rms(2)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
58958  dcheck(idr) =.true.
58959  xlam = xlam + tmix * pyrvi1(1,2,3)
58960  ENDIF
58961  ENDIF
58962  120 CONTINUE
58963 C... L-R INTERFERENCES
58964 C... (Only add contributions where both contributing diagrams
58965 C... are non-resonant).
58966  idr=1
58967  IF (dcheck(1).AND.dcheck(2)) THEN
58968 C...Bug corrected 11/12 2001. Skands.
58969  xlam = xlam + 2d0 * pyrvi2(2,3,1)
58970  & * sfmix(intres(1,1),2+intres(1,3)-1)
58971  & * sfmix(intres(2,1),4+intres(2,3)-1)
58972  ENDIF
58973 
58974  idr=3
58975  IF (dcheck(3).AND.dcheck(4)) THEN
58976  xlam = xlam + 2d0 * pyrvi2(1,3,2)
58977  & * sfmix(intres(3,1),2+intres(3,3)-1)
58978  & * sfmix(intres(4,1),4+intres(4,3)-1)
58979  ENDIF
58980 
58981  idr=5
58982  IF (dcheck(5).AND.dcheck(6)) THEN
58983  xlam = xlam + 2d0 * pyrvi2(1,2,3)
58984  & * sfmix(intres(5,1),2+intres(5,3)-1)
58985  & * sfmix(intres(6,1),4+intres(6,3)-1)
58986  ENDIF
58987 C... TRUE INTERFERENCES
58988 C... (Only add contributions where both contributing diagrams
58989 C... are non-resonant).
58990  pref=-2d0
58991  IF ((kfin-ksusy1).EQ.24.OR.(kfin-ksusy1).EQ.37) pref=2d0
58992  DO 140 ikr1 = 1,2
58993  DO 130 ikr2 = 1,2
58994  idr = ikr1+2
58995  idr2 = ikr2
58996  IF (dcheck(idr).AND.dcheck(idr2)) THEN
58997  xlam = xlam + pref*pyrvi3(1,3,2) *
58998  & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
58999  & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
59000  ENDIF
59001 
59002  idr = ikr1+4
59003  idr2 = ikr2
59004  IF (dcheck(idr).AND.dcheck(idr2)) THEN
59005  xlam = xlam + pref*pyrvi3(1,2,3) *
59006  & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
59007  & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
59008  ENDIF
59009 
59010  idr = ikr1+4
59011  idr2 = ikr2+2
59012  IF (dcheck(idr).AND.dcheck(idr2)) THEN
59013  xlam = xlam + pref*pyrvi3(2,1,3) *
59014  & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
59015  & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
59016  ENDIF
59017  130 CONTINUE
59018  140 CONTINUE
59019 
59020  RETURN
59021  END
59022 
59023 C*********************************************************************
59024 
59025 C...PYRVI1
59026 C...Function to integrate resonance contributions
59027 
59028  FUNCTION pyrvi1(ID1,ID2,ID3)
59029 
59030  IMPLICIT NONE
59031  DOUBLE PRECISION lo,hi,pyrvi1,pyrvg1,pygaus
59032  DOUBLE PRECISION res, ab, rm, resm, resw, a, b, rms
59033  INTEGER id1,id2,id3, idr, idr2, kfr, intres
59034  LOGICAL mflag,dcmass
59035  EXTERNAL pyrvg1,pygaus
59036  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
59037  & ,dcmass,kfr(3)
59038  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
59039  SAVE/pyrvnv/,/pyrvpm/
59040 C...Initialize mass and width information
59041  pyrvi1 = 0d0
59042  rm(0) = rms(0)
59043  rm(1) = rms(id1)
59044  rm(2) = rms(id2)
59045  rm(3) = rms(id3)
59046  resm(1)= res(idr,1)
59047  resw(1)= res(idr,2)
59048 C...A->B and B->A for antisparticles
59049  a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
59050  b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
59051 C...Integration boundaries and mass flag
59052  lo = (rm(1)+rm(2))**2
59053  hi = (rm(0)-rm(3))**2
59054  mflag = dcmass
59055  pyrvi1 = pygaus(pyrvg1,lo,hi,1d-3)
59056  RETURN
59057  END
59058 
59059 C*********************************************************************
59060 
59061 C...PYRVI2
59062 C...Function to integrate L-R interference contributions
59063 
59064  FUNCTION pyrvi2(ID1,ID2,ID3)
59065 
59066  IMPLICIT NONE
59067  DOUBLE PRECISION lo,hi,pyrvi2, pyrvg2, pygaus
59068  DOUBLE PRECISION res, ab, rm, resm, resw, a, b, rms
59069  INTEGER id1,id2,id3, idr, idr2, kfr, intres
59070  LOGICAL mflag,dcmass
59071  EXTERNAL pyrvg2,pygaus
59072  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
59073  & ,dcmass,kfr(3)
59074  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
59075  SAVE/pyrvnv/,/pyrvpm/
59076 C...Initialize mass and width information
59077  pyrvi2 = 0d0
59078  rm(0) = rms(0)
59079  rm(1) = rms(id1)
59080  rm(2) = rms(id2)
59081  rm(3) = rms(id3)
59082  resm(1)= res(idr,1)
59083  resw(1)= res(idr,2)
59084  resm(2)= res(idr+1,1)
59085  resw(2)= res(idr+1,2)
59086 C...A->B and B->A for antisparticles
59087  a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
59088  b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
59089  a(2) = ab(1+intres(idr+1,3),intres(idr+1,1),intres(idr+1,2))
59090  b(2) = ab(2-intres(idr+1,3),intres(idr+1,1),intres(idr+1,2))
59091 C...Boundaries and mass flag
59092  lo = (rm(1)+rm(2))**2
59093  hi = (rm(0)-rm(3))**2
59094  mflag = dcmass
59095  pyrvi2 = pygaus(pyrvg2,lo,hi,1d-3)
59096  RETURN
59097  END
59098 
59099 C*********************************************************************
59100 
59101 C...PYRVI3
59102 C...Function to integrate true interference contributions
59103 
59104  FUNCTION pyrvi3(ID1,ID2,ID3)
59105 
59106  IMPLICIT NONE
59107  DOUBLE PRECISION lo,hi,pyrvi3, pyrvg3, pygaus
59108  DOUBLE PRECISION res, ab, rm, resm, resw, a, b, rms
59109  INTEGER id1,id2,id3, idr, idr2, kfr, intres
59110  LOGICAL mflag,dcmass
59111  EXTERNAL pyrvg3,pygaus
59112  common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
59113  & ,dcmass,kfr(3)
59114  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
59115  SAVE/pyrvnv/,/pyrvpm/
59116 C...Initialize mass and width information
59117  pyrvi3 = 0d0
59118  rm(0) = rms(0)
59119  rm(1) = rms(id1)
59120  rm(2) = rms(id2)
59121  rm(3) = rms(id3)
59122  resm(1)= res(idr,1)
59123  resw(1)= res(idr,2)
59124  resm(2)= res(idr2,1)
59125  resw(2)= res(idr2,2)
59126 C...A -> B and B -> A for antisparticles
59127  a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
59128  b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
59129  a(2) = ab(1+intres(idr2,3),intres(idr2,1),intres(idr2,2))
59130  b(2) = ab(2-intres(idr2,3),intres(idr2,1),intres(idr2,2))
59131 C...Boundaries and mass flag
59132  lo = (rm(1)+rm(2))**2
59133  hi = (rm(0)-rm(3))**2
59134  mflag = dcmass
59135  pyrvi3 = pygaus(pyrvg3,lo,hi,1d-3)
59136  RETURN
59137  END
59138 
59139 C*********************************************************************
59140 
59141 C...PYRVG1
59142 C...Integrand for resonance contributions
59143 
59144  FUNCTION pyrvg1(X)
59145 
59146  IMPLICIT NONE
59147  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
59148  DOUBLE PRECISION x, rm, a, b, resm, resw, deltay,pyrvr
59149  DOUBLE PRECISION rvr,pyrvg1,e2,e3,c1,sr1,sr2,a1,a2
59150  LOGICAL mflag
59151  SAVE/pyrvpm/
59152  rvr = pyrvr(x,resm(1),resw(1))
59153  c1 = 2d0*sqrt(max(0d0,x))
59154  IF (.NOT.mflag) THEN
59155  e2 = x/c1
59156  e3 = (rm(0)**2-x)/c1
59157  deltay = 4d0*e2*e3
59158  pyrvg1 = deltay*rvr*x*(a(1)**2+b(1)**2)*(rm(0)**2-x)
59159  ELSE
59160  e2 = (x-rm(1)**2+rm(2)**2)/c1
59161  e3 = (rm(0)**2-x-rm(3)**2)/c1
59162  sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
59163  sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
59164  deltay = 4d0*sr1*sr2
59165  a1 = 4.*a(1)*b(1)*rm(3)*rm(0)
59166  a2 = (a(1)**2+b(1)**2)*(rm(0)**2+rm(3)**2-x)
59167  pyrvg1 = deltay*rvr*(x-rm(1)**2-rm(2)**2)*(a1+a2)
59168  ENDIF
59169  RETURN
59170  END
59171 
59172 C*********************************************************************
59173 
59174 C...PYRVG2
59175 C...Integrand for L-R interference contributions
59176 
59177  FUNCTION pyrvg2(X)
59178 
59179  IMPLICIT NONE
59180  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
59181  DOUBLE PRECISION x, rm, a, b, resm, resw, deltay, pyrvs
59182  DOUBLE PRECISION rvs,pyrvg2,e2,e3,c1,sr1,sr2
59183  LOGICAL mflag
59184  SAVE/pyrvpm/
59185  c1 = 2d0*sqrt(max(0d0,x))
59186  rvs = pyrvs(x,x,resm(1),resw(1),resm(2),resw(2))
59187  IF (.NOT.mflag) THEN
59188  e2 = x/c1
59189  e3 = (rm(0)**2-x)/c1
59190  deltay = 4d0*e2*e3
59191  pyrvg2 = deltay*rvs*x*(a(1)*a(2)+b(1)*b(2))*(rm(0)**2-x)
59192  ELSE
59193  e2 = (x-rm(1)**2+rm(2)**2)/c1
59194  e3 = (rm(0)**2-x-rm(3)**2)/c1
59195  sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
59196  sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
59197  deltay = 4d0*sr1*sr2
59198  pyrvg2 = deltay*rvs*(x-rm(1)**2-rm(2)**2)*((a(1)*a(2)
59199  & + b(1)*b(2))*(rm(0)**2+rm(3)**2-x)
59200  & + 2d0*(a(1)*b(2)+a(2)*b(1))*rm(3)*rm(0))
59201  ENDIF
59202  RETURN
59203  END
59204 
59205 C*********************************************************************
59206 
59207 C...PYRVG3
59208 C...Function to do Y integration over true interference contributions
59209 
59210  FUNCTION pyrvg3(X)
59211 
59212  IMPLICIT NONE
59213  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
59214 C...Second Dalitz variable for PYRVG4
59215  common/pyg2dx/x1
59216  DOUBLE PRECISION rm, a, b, resm, resw, x, x1
59217  DOUBLE PRECISION e2, e3, c1, sq1, sr1, sr2, ymin, ymax
59218  DOUBLE PRECISION pyrvg3, pyrvg4, pygau2
59219  LOGICAL mflag
59220  EXTERNAL pygau2,pyrvg4
59221  SAVE/pyrvpm/,/pyg2dx/
59222  pyrvg3=0d0
59223  c1=2d0*sqrt(max(1d-9,x))
59224  x1=x
59225  IF (.NOT.mflag) THEN
59226  e2 = x/c1
59227  e3 = (rm(0)**2-x)/c1
59228  ymin = 0d0
59229  ymax = 4d0*e2*e3
59230  ELSE
59231  e2 = (x-rm(1)**2+rm(2)**2)/c1
59232  e3 = (rm(0)**2-x-rm(3)**2)/c1
59233  sq1 = (e2+e3)**2
59234  sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
59235  sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
59236  ymin = sq1-(sr1+sr2)**2
59237  ymax = sq1-(sr1-sr2)**2
59238  ENDIF
59239  pyrvg3 = pygau2(pyrvg4,ymin,ymax,1d-3)
59240  RETURN
59241  END
59242 
59243 C*********************************************************************
59244 
59245 C...PYRVG4
59246 C...Integrand for true intereference contributions
59247 
59248  FUNCTION pyrvg4(Y)
59249 
59250  IMPLICIT NONE
59251  common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
59252  common/pyg2dx/x
59253  DOUBLE PRECISION x, y, pyrvg4, rm, a, b, resm, resw, rvs, pyrvs
59254  LOGICAL mflag
59255  SAVE /pyrvpm/,/pyg2dx/
59256  pyrvg4=0d0
59257  rvs=pyrvs(x,y,resm(1),resw(1),resm(2),resw(2))
59258  IF (.NOT.mflag) THEN
59259  pyrvg4 = rvs*b(1)*b(2)*x*y
59260  ELSE
59261  pyrvg4 = rvs*(rm(1)*rm(3)*a(1)*a(2)*(x+y-rm(1)**2-rm(3)**2)
59262  & + rm(1)*rm(0)*b(1)*a(2)*(y-rm(2)**2-rm(3)**2)
59263  & + rm(3)*rm(0)*a(1)*b(2)*(x-rm(1)**2-rm(2)**2)
59264  & + b(1)*b(2)*(x*y-(rm(1)*rm(3))**2-(rm(0)*rm(2))**2))
59265  ENDIF
59266  RETURN
59267  END
59268 
59269 C*********************************************************************
59270 
59271 C...PYRVR
59272 C...Breit-Wigner for resonance contributions
59273 
59274  FUNCTION pyrvr(Mab2,RM,RW)
59275 
59276  IMPLICIT NONE
59277  DOUBLE PRECISION mab2,rm,rw,pyrvr
59278  pyrvr = 1d0/((mab2-rm**2)**2+rm**2*rw**2)
59279  RETURN
59280  END
59281 
59282 C*********************************************************************
59283 
59284 C...PYRVS
59285 C...Interference function
59286 
59287  FUNCTION pyrvs(X,Y,M1,W1,M2,W2)
59288 
59289  IMPLICIT NONE
59290  DOUBLE PRECISION x, y, pyrvs, pyrvr, m1, m2, w1, w2
59291  pyrvs = pyrvr(x,m1,w1)*pyrvr(y,m2,w2)*((x-m1**2)*(y-m2**2)
59292  & +w1*w2*m1*m2)
59293  RETURN
59294  END
59295 
59296 C*********************************************************************
59297 
59298 C...PY1ENT
59299 C...Stores one parton/particle in commonblock PYJETS.
59300 
59301  SUBROUTINE py1ent(IP,KF,PE,THE,PHI)
59302 
59303 C...Double precision and integer declarations.
59304  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59305  IMPLICIT INTEGER(i-n)
59306  INTEGER pyk,pychge,pycomp
59307 C...Commonblocks.
59308  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59309  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59310  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59311  SAVE /pyjets/,/pydat1/,/pydat2/
59312 
59313 C...Standard checks.
59314  mstu(28)=0
59315  IF(mstu(12).NE.12345) CALL pylist(0)
59316  ipa=max(1,iabs(ip))
59317  IF(ipa.GT.mstu(4)) CALL pyerrm(21,
59318  &'(PY1ENT:) writing outside PYJETS memory')
59319  kc=pycomp(kf)
59320  IF(kc.EQ.0) CALL pyerrm(12,'(PY1ENT:) unknown flavour code')
59321 
59322 C...Find mass. Reset K, P and V vectors.
59323  pm=0d0
59324  IF(mstu(10).EQ.1) pm=p(ipa,5)
59325  IF(mstu(10).GE.2) pm=pymass(kf)
59326  DO 100 j=1,5
59327  k(ipa,j)=0
59328  p(ipa,j)=0d0
59329  v(ipa,j)=0d0
59330  100 CONTINUE
59331 
59332 C...Store parton/particle in K and P vectors.
59333  k(ipa,1)=1
59334  IF(ip.LT.0) k(ipa,1)=2
59335  k(ipa,2)=kf
59336  p(ipa,5)=pm
59337  p(ipa,4)=max(pe,pm)
59338  pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
59339  p(ipa,1)=pa*sin(the)*cos(phi)
59340  p(ipa,2)=pa*sin(the)*sin(phi)
59341  p(ipa,3)=pa*cos(the)
59342 
59343 C...Set N. Optionally fragment/decay.
59344  n=ipa
59345  IF(ip.EQ.0) CALL pyexec
59346 
59347  RETURN
59348  END
59349 
59350 C*********************************************************************
59351 
59352 C...PY2ENT
59353 C...Stores two partons/particles in their CM frame,
59354 C...with the first along the +z axis.
59355 
59356  SUBROUTINE py2ent(IP,KF1,KF2,PECM)
59357 
59358 C...Double precision and integer declarations.
59359  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59360  IMPLICIT INTEGER(i-n)
59361  INTEGER pyk,pychge,pycomp
59362 C...Commonblocks.
59363  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59364  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59365  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59366  SAVE /pyjets/,/pydat1/,/pydat2/
59367 
59368 C...Standard checks.
59369  mstu(28)=0
59370  IF(mstu(12).NE.12345) CALL pylist(0)
59371  ipa=max(1,iabs(ip))
59372  IF(ipa.GT.mstu(4)-1) CALL pyerrm(21,
59373  &'(PY2ENT:) writing outside PYJETS memory')
59374  kc1=pycomp(kf1)
59375  kc2=pycomp(kf2)
59376  IF(kc1.EQ.0.OR.kc2.EQ.0) CALL pyerrm(12,
59377  &'(PY2ENT:) unknown flavour code')
59378 
59379 C...Find masses. Reset K, P and V vectors.
59380  pm1=0d0
59381  IF(mstu(10).EQ.1) pm1=p(ipa,5)
59382  IF(mstu(10).GE.2) pm1=pymass(kf1)
59383  pm2=0d0
59384  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
59385  IF(mstu(10).GE.2) pm2=pymass(kf2)
59386  DO 110 i=ipa,ipa+1
59387  DO 100 j=1,5
59388  k(i,j)=0
59389  p(i,j)=0d0
59390  v(i,j)=0d0
59391  100 CONTINUE
59392  110 CONTINUE
59393 
59394 C...Check flavours.
59395  kq1=kchg(kc1,2)*isign(1,kf1)
59396  kq2=kchg(kc2,2)*isign(1,kf2)
59397  IF(mstu(19).EQ.1) THEN
59398  mstu(19)=0
59399  ELSE
59400  IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL pyerrm(2,
59401  & '(PY2ENT:) unphysical flavour combination')
59402  ENDIF
59403  k(ipa,2)=kf1
59404  k(ipa+1,2)=kf2
59405 
59406 C...Store partons/particles in K vectors for normal case.
59407  IF(ip.GE.0) THEN
59408  k(ipa,1)=1
59409  IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
59410  k(ipa+1,1)=1
59411 
59412 C...Store partons in K vectors for parton shower evolution.
59413  ELSE
59414  k(ipa,1)=3
59415  k(ipa+1,1)=3
59416  k(ipa,4)=mstu(5)*(ipa+1)
59417  k(ipa,5)=k(ipa,4)
59418  k(ipa+1,4)=mstu(5)*ipa
59419  k(ipa+1,5)=k(ipa+1,4)
59420  ENDIF
59421 
59422 C...Check kinematics and store partons/particles in P vectors.
59423  IF(pecm.LE.pm1+pm2) CALL pyerrm(13,
59424  &'(PY2ENT:) energy smaller than sum of masses')
59425  pa=sqrt(max(0d0,(pecm**2-pm1**2-pm2**2)**2-(2d0*pm1*pm2)**2))/
59426  &(2d0*pecm)
59427  p(ipa,3)=pa
59428  p(ipa,4)=sqrt(pm1**2+pa**2)
59429  p(ipa,5)=pm1
59430  p(ipa+1,3)=-pa
59431  p(ipa+1,4)=sqrt(pm2**2+pa**2)
59432  p(ipa+1,5)=pm2
59433 
59434 C...Set N. Optionally fragment/decay.
59435  n=ipa+1
59436  IF(ip.EQ.0) CALL pyexec
59437 
59438  RETURN
59439  END
59440 
59441 C*********************************************************************
59442 
59443 C...PY3ENT
59444 C...Stores three partons or particles in their CM frame,
59445 C...with the first along the +z axis and the third in the (x,z)
59446 C...plane with x > 0.
59447 
59448  SUBROUTINE py3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
59449 
59450 C...Double precision and integer declarations.
59451  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59452  IMPLICIT INTEGER(i-n)
59453  INTEGER pyk,pychge,pycomp
59454 C...Commonblocks.
59455  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59456  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59457  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59458  SAVE /pyjets/,/pydat1/,/pydat2/
59459 
59460 C...Standard checks.
59461  mstu(28)=0
59462  IF(mstu(12).NE.12345) CALL pylist(0)
59463  ipa=max(1,iabs(ip))
59464  IF(ipa.GT.mstu(4)-2) CALL pyerrm(21,
59465  &'(PY3ENT:) writing outside PYJETS memory')
59466  kc1=pycomp(kf1)
59467  kc2=pycomp(kf2)
59468  kc3=pycomp(kf3)
59469  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL pyerrm(12,
59470  &'(PY3ENT:) unknown flavour code')
59471 
59472 C...Find masses. Reset K, P and V vectors.
59473  pm1=0d0
59474  IF(mstu(10).EQ.1) pm1=p(ipa,5)
59475  IF(mstu(10).GE.2) pm1=pymass(kf1)
59476  pm2=0d0
59477  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
59478  IF(mstu(10).GE.2) pm2=pymass(kf2)
59479  pm3=0d0
59480  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
59481  IF(mstu(10).GE.2) pm3=pymass(kf3)
59482  DO 110 i=ipa,ipa+2
59483  DO 100 j=1,5
59484  k(i,j)=0
59485  p(i,j)=0d0
59486  v(i,j)=0d0
59487  100 CONTINUE
59488  110 CONTINUE
59489 
59490 C...Check flavours.
59491  kq1=kchg(kc1,2)*isign(1,kf1)
59492  kq2=kchg(kc2,2)*isign(1,kf2)
59493  kq3=kchg(kc3,2)*isign(1,kf3)
59494  IF(mstu(19).EQ.1) THEN
59495  mstu(19)=0
59496  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
59497  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
59498  & kq1+kq3.EQ.4)) THEN
59499  ELSE
59500  CALL pyerrm(2,'(PY3ENT:) unphysical flavour combination')
59501  ENDIF
59502  k(ipa,2)=kf1
59503  k(ipa+1,2)=kf2
59504  k(ipa+2,2)=kf3
59505 
59506 C...Store partons/particles in K vectors for normal case.
59507  IF(ip.GE.0) THEN
59508  k(ipa,1)=1
59509  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
59510  k(ipa+1,1)=1
59511  IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
59512  k(ipa+2,1)=1
59513 
59514 C...Store partons in K vectors for parton shower evolution.
59515  ELSE
59516  k(ipa,1)=3
59517  k(ipa+1,1)=3
59518  k(ipa+2,1)=3
59519  kcs=4
59520  IF(kq1.EQ.-1) kcs=5
59521  k(ipa,kcs)=mstu(5)*(ipa+1)
59522  k(ipa,9-kcs)=mstu(5)*(ipa+2)
59523  k(ipa+1,kcs)=mstu(5)*(ipa+2)
59524  k(ipa+1,9-kcs)=mstu(5)*ipa
59525  k(ipa+2,kcs)=mstu(5)*ipa
59526  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
59527  ENDIF
59528 
59529 C...Check kinematics.
59530  mkerr=0
59531  IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*(2d0-x1-x3)*pecm.LE.pm2.OR.
59532  &0.5d0*x3*pecm.LE.pm3) mkerr=1
59533  pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
59534  pa2=sqrt(max(1d-10,(0.5d0*(2d0-x1-x3)*pecm)**2-pm2**2))
59535  pa3=sqrt(max(1d-10,(0.5d0*x3*pecm)**2-pm3**2))
59536  cthe2=(pa3**2-pa1**2-pa2**2)/(2d0*pa1*pa2)
59537  cthe3=(pa2**2-pa1**2-pa3**2)/(2d0*pa1*pa3)
59538  IF(abs(cthe2).GE.1.001d0.OR.abs(cthe3).GE.1.001d0) mkerr=1
59539  cthe3=max(-1d0,min(1d0,cthe3))
59540  IF(mkerr.NE.0) CALL pyerrm(13,
59541  &'(PY3ENT:) unphysical kinematical variable setup')
59542 
59543 C...Store partons/particles in P vectors.
59544  p(ipa,3)=pa1
59545  p(ipa,4)=sqrt(pa1**2+pm1**2)
59546  p(ipa,5)=pm1
59547  p(ipa+2,1)=pa3*sqrt(1d0-cthe3**2)
59548  p(ipa+2,3)=pa3*cthe3
59549  p(ipa+2,4)=sqrt(pa3**2+pm3**2)
59550  p(ipa+2,5)=pm3
59551  p(ipa+1,1)=-p(ipa+2,1)
59552  p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
59553  p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
59554  p(ipa+1,5)=pm2
59555 
59556 C...Set N. Optionally fragment/decay.
59557  n=ipa+2
59558  IF(ip.EQ.0) CALL pyexec
59559 
59560  RETURN
59561  END
59562 
59563 C*********************************************************************
59564 
59565 C...PY4ENT
59566 C...Stores four partons or particles in their CM frame, with
59567 C...the first along the +z axis, the last in the xz plane with x > 0
59568 C...and the second having y < 0 and y > 0 with equal probability.
59569 
59570  SUBROUTINE py4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
59571 
59572 C...Double precision and integer declarations.
59573  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59574  IMPLICIT INTEGER(i-n)
59575  INTEGER pyk,pychge,pycomp
59576 C...Commonblocks.
59577  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59578  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59579  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59580  SAVE /pyjets/,/pydat1/,/pydat2/
59581 
59582 C...Standard checks.
59583  mstu(28)=0
59584  IF(mstu(12).NE.12345) CALL pylist(0)
59585  ipa=max(1,iabs(ip))
59586  IF(ipa.GT.mstu(4)-3) CALL pyerrm(21,
59587  &'(PY4ENT:) writing outside PYJETS momory')
59588  kc1=pycomp(kf1)
59589  kc2=pycomp(kf2)
59590  kc3=pycomp(kf3)
59591  kc4=pycomp(kf4)
59592  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL pyerrm(12,
59593  &'(PY4ENT:) unknown flavour code')
59594 
59595 C...Find masses. Reset K, P and V vectors.
59596  pm1=0d0
59597  IF(mstu(10).EQ.1) pm1=p(ipa,5)
59598  IF(mstu(10).GE.2) pm1=pymass(kf1)
59599  pm2=0d0
59600  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
59601  IF(mstu(10).GE.2) pm2=pymass(kf2)
59602  pm3=0d0
59603  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
59604  IF(mstu(10).GE.2) pm3=pymass(kf3)
59605  pm4=0d0
59606  IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
59607  IF(mstu(10).GE.2) pm4=pymass(kf4)
59608  DO 110 i=ipa,ipa+3
59609  DO 100 j=1,5
59610  k(i,j)=0
59611  p(i,j)=0d0
59612  v(i,j)=0d0
59613  100 CONTINUE
59614  110 CONTINUE
59615 
59616 C...Check flavours.
59617  kq1=kchg(kc1,2)*isign(1,kf1)
59618  kq2=kchg(kc2,2)*isign(1,kf2)
59619  kq3=kchg(kc3,2)*isign(1,kf3)
59620  kq4=kchg(kc4,2)*isign(1,kf4)
59621  IF(mstu(19).EQ.1) THEN
59622  mstu(19)=0
59623  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
59624  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
59625  & kq1+kq4.EQ.4)) THEN
59626  ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0d0)
59627  & THEN
59628  ELSE
59629  CALL pyerrm(2,'(PY4ENT:) unphysical flavour combination')
59630  ENDIF
59631  k(ipa,2)=kf1
59632  k(ipa+1,2)=kf2
59633  k(ipa+2,2)=kf3
59634  k(ipa+3,2)=kf4
59635 
59636 C...Store partons/particles in K vectors for normal case.
59637  IF(ip.GE.0) THEN
59638  k(ipa,1)=1
59639  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
59640  k(ipa+1,1)=1
59641  IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
59642  & k(ipa+1,1)=2
59643  k(ipa+2,1)=1
59644  IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
59645  k(ipa+3,1)=1
59646 
59647 C...Store partons for parton shower evolution from q-g-g-qbar or
59648 C...g-g-g-g event.
59649  ELSEIF(kq1+kq2.NE.0) THEN
59650  k(ipa,1)=3
59651  k(ipa+1,1)=3
59652  k(ipa+2,1)=3
59653  k(ipa+3,1)=3
59654  kcs=4
59655  IF(kq1.EQ.-1) kcs=5
59656  k(ipa,kcs)=mstu(5)*(ipa+1)
59657  k(ipa,9-kcs)=mstu(5)*(ipa+3)
59658  k(ipa+1,kcs)=mstu(5)*(ipa+2)
59659  k(ipa+1,9-kcs)=mstu(5)*ipa
59660  k(ipa+2,kcs)=mstu(5)*(ipa+3)
59661  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
59662  k(ipa+3,kcs)=mstu(5)*ipa
59663  k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
59664 
59665 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
59666  ELSE
59667  k(ipa,1)=3
59668  k(ipa+1,1)=3
59669  k(ipa+2,1)=3
59670  k(ipa+3,1)=3
59671  k(ipa,4)=mstu(5)*(ipa+1)
59672  k(ipa,5)=k(ipa,4)
59673  k(ipa+1,4)=mstu(5)*ipa
59674  k(ipa+1,5)=k(ipa+1,4)
59675  k(ipa+2,4)=mstu(5)*(ipa+3)
59676  k(ipa+2,5)=k(ipa+2,4)
59677  k(ipa+3,4)=mstu(5)*(ipa+2)
59678  k(ipa+3,5)=k(ipa+3,4)
59679  ENDIF
59680 
59681 C...Check kinematics.
59682  mkerr=0
59683  IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*x2*pecm.LE.pm2.OR.
59684  &0.5d0*(2d0-x1-x2-x4)*pecm.LE.pm3.OR.0.5d0*x4*pecm.LE.pm4)
59685  &mkerr=1
59686  pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
59687  pa2=sqrt(max(1d-10,(0.5d0*x2*pecm)**2-pm2**2))
59688  pa4=sqrt(max(1d-10,(0.5d0*x4*pecm)**2-pm4**2))
59689  x24=x1+x2+x4-1d0-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
59690  cthe4=(x1*x4-2d0*x14)*pecm**2/(4d0*pa1*pa4)
59691  IF(abs(cthe4).GE.1.002d0) mkerr=1
59692  cthe4=max(-1d0,min(1d0,cthe4))
59693  sthe4=sqrt(1d0-cthe4**2)
59694  cthe2=(x1*x2-2d0*x12)*pecm**2/(4d0*pa1*pa2)
59695  IF(abs(cthe2).GE.1.002d0) mkerr=1
59696  cthe2=max(-1d0,min(1d0,cthe2))
59697  sthe2=sqrt(1d0-cthe2**2)
59698  cphi2=((x2*x4-2d0*x24)*pecm**2-4d0*pa2*cthe2*pa4*cthe4)/
59699  &max(1d-8*pecm**2,4d0*pa2*sthe2*pa4*sthe4)
59700  IF(abs(cphi2).GE.1.05d0) mkerr=1
59701  cphi2=max(-1d0,min(1d0,cphi2))
59702  IF(mkerr.EQ.1) CALL pyerrm(13,
59703  &'(PY4ENT:) unphysical kinematical variable setup')
59704 
59705 C...Store partons/particles in P vectors.
59706  p(ipa,3)=pa1
59707  p(ipa,4)=sqrt(pa1**2+pm1**2)
59708  p(ipa,5)=pm1
59709  p(ipa+3,1)=pa4*sthe4
59710  p(ipa+3,3)=pa4*cthe4
59711  p(ipa+3,4)=sqrt(pa4**2+pm4**2)
59712  p(ipa+3,5)=pm4
59713  p(ipa+1,1)=pa2*sthe2*cphi2
59714  p(ipa+1,2)=pa2*sthe2*sqrt(1d0-cphi2**2)*(-1d0)**int(pyr(0)+0.5d0)
59715  p(ipa+1,3)=pa2*cthe2
59716  p(ipa+1,4)=sqrt(pa2**2+pm2**2)
59717  p(ipa+1,5)=pm2
59718  p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
59719  p(ipa+2,2)=-p(ipa+1,2)
59720  p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
59721  p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
59722  p(ipa+2,5)=pm3
59723 
59724 C...Set N. Optionally fragment/decay.
59725  n=ipa+3
59726  IF(ip.EQ.0) CALL pyexec
59727 
59728  RETURN
59729  END
59730 
59731 C*********************************************************************
59732 
59733 C...PY2FRM
59734 C...An interface from a two-fermion generator to include
59735 C...parton showers and hadronization.
59736 
59737  SUBROUTINE py2frm(IRAD,ITAU,ICOM)
59738 
59739 C...Double precision and integer declarations.
59740  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59741  IMPLICIT INTEGER(i-n)
59742  INTEGER pyk,pychge,pycomp
59743 C...Commonblocks.
59744  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59745  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59746  SAVE /pyjets/,/pydat1/
59747 C...Local arrays.
59748  dimension ijoin(2),intau(2)
59749 
59750 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59751  IF(icom.EQ.0) THEN
59752  mstu(28)=0
59753  CALL pyhepc(2)
59754  ENDIF
59755 
59756 C...Loop through entries and pick up all final fermions/antifermions.
59757  i1=0
59758  i2=0
59759  DO 100 i=1,n
59760  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
59761  kfa=iabs(k(i,2))
59762  IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
59763  IF(k(i,2).GT.0) THEN
59764  IF(i1.EQ.0) THEN
59765  i1=i
59766  ELSE
59767  CALL pyerrm(16,'(PY2FRM:) more than one fermion')
59768  ENDIF
59769  ELSE
59770  IF(i2.EQ.0) THEN
59771  i2=i
59772  ELSE
59773  CALL pyerrm(16,'(PY2FRM:) more than one antifermion')
59774  ENDIF
59775  ENDIF
59776  ENDIF
59777  100 CONTINUE
59778 
59779 C...Check that event is arranged according to conventions.
59780  IF(i1.EQ.0.OR.i2.EQ.0) THEN
59781  CALL pyerrm(16,'(PY2FRM:) event contains too few fermions')
59782  ENDIF
59783  IF(i2.LT.i1) THEN
59784  CALL pyerrm(6,'(PY2FRM:) fermions arranged in wrong order')
59785  ENDIF
59786 
59787 C...Check whether fermion pair is quarks or leptons.
59788  IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
59789  iql12=1
59790  ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
59791  iql12=2
59792  ELSE
59793  CALL pyerrm(16,'(PY2FRM:) fermion pair inconsistent')
59794  ENDIF
59795 
59796 C...Decide whether to allow or not photon radiation in showers.
59797  mstj(41)=2
59798  IF(irad.EQ.0) mstj(41)=1
59799 
59800 C...Do colour joining and parton showers.
59801  ip1=i1
59802  ip2=i2
59803  IF(iql12.EQ.1) THEN
59804  ijoin(1)=ip1
59805  ijoin(2)=ip2
59806  CALL pyjoin(2,ijoin)
59807  ENDIF
59808  IF(iql12.EQ.1.OR.irad.EQ.1) THEN
59809  pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
59810  & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
59811  CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
59812  ENDIF
59813 
59814 C...Do fragmentation and decays. Possibly except tau decay.
59815  IF(itau.EQ.0) THEN
59816  ntau=0
59817  DO 110 i=1,n
59818  IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
59819  ntau=ntau+1
59820  intau(ntau)=i
59821  k(i,1)=11
59822  ENDIF
59823  110 CONTINUE
59824  ENDIF
59825  CALL pyexec
59826  IF(itau.EQ.0) THEN
59827  DO 120 i=1,ntau
59828  k(intau(i),1)=1
59829  120 CONTINUE
59830  ENDIF
59831 
59832 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59833  IF(icom.EQ.0) THEN
59834  mstu(28)=0
59835  CALL pyhepc(1)
59836  ENDIF
59837 
59838  END
59839 
59840 C*********************************************************************
59841 
59842 C...PY4FRM
59843 C...An interface from a four-fermion generator to include
59844 C...parton showers and hadronization.
59845 
59846  SUBROUTINE py4frm(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
59847 
59848 C...Double precision and integer declarations.
59849  IMPLICIT DOUBLE PRECISION(a-h, o-z)
59850  IMPLICIT INTEGER(i-n)
59851  INTEGER pyk,pychge,pycomp
59852 C...Commonblocks.
59853  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59854  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59855  common/pypars/mstp(200),parp(200),msti(200),pari(200)
59856  common/pyint1/mint(400),vint(400)
59857  SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
59858 C...Local arrays.
59859  dimension ijoin(2),intau(4)
59860 
59861 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59862  IF(icom.EQ.0) THEN
59863  mstu(28)=0
59864  CALL pyhepc(2)
59865  ENDIF
59866 
59867 C...Loop through entries and pick up all final fermions/antifermions.
59868  i1=0
59869  i2=0
59870  i3=0
59871  i4=0
59872  DO 100 i=1,n
59873  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
59874  kfa=iabs(k(i,2))
59875  IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
59876  IF(k(i,2).GT.0) THEN
59877  IF(i1.EQ.0) THEN
59878  i1=i
59879  ELSEIF(i3.EQ.0) THEN
59880  i3=i
59881  ELSE
59882  CALL pyerrm(16,'(PY4FRM:) more than two fermions')
59883  ENDIF
59884  ELSE
59885  IF(i2.EQ.0) THEN
59886  i2=i
59887  ELSEIF(i4.EQ.0) THEN
59888  i4=i
59889  ELSE
59890  CALL pyerrm(16,'(PY4FRM:) more than two antifermions')
59891  ENDIF
59892  ENDIF
59893  ENDIF
59894  100 CONTINUE
59895 
59896 C...Check that event is arranged according to conventions.
59897  IF(i3.EQ.0.OR.i4.EQ.0) THEN
59898  CALL pyerrm(16,'(PY4FRM:) event contains too few fermions')
59899  ENDIF
59900  IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
59901  CALL pyerrm(6,'(PY4FRM:) fermions arranged in wrong order')
59902  ENDIF
59903 
59904 C...Check which fermion pairs are quarks and which leptons.
59905  IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
59906  iql12=1
59907  ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
59908  iql12=2
59909  ELSE
59910  CALL pyerrm(16,'(PY4FRM:) first fermion pair inconsistent')
59911  ENDIF
59912  IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
59913  iql34=1
59914  ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
59915  iql34=2
59916  ELSE
59917  CALL pyerrm(16,'(PY4FRM:) second fermion pair inconsistent')
59918  ENDIF
59919 
59920 C...Decide whether to allow or not photon radiation in showers.
59921  mstj(41)=2
59922  IF(irad.EQ.0) mstj(41)=1
59923 
59924 C...Decide on dipole pairing.
59925  ip1=i1
59926  ip2=i2
59927  ip3=i3
59928  ip4=i4
59929  IF(iql12.EQ.iql34) THEN
59930  r1sq=a1sq
59931  r2sq=a2sq
59932  delta=atotsq-a1sq-a2sq
59933  IF(istrat.EQ.1) THEN
59934  IF(delta.GT.0d0) r1sq=r1sq+delta
59935  IF(delta.LT.0d0) r2sq=max(0d0,r2sq+delta)
59936  ELSEIF(istrat.EQ.2) THEN
59937  IF(delta.GT.0d0) r2sq=r2sq+delta
59938  IF(delta.LT.0d0) r1sq=max(0d0,r1sq+delta)
59939  ENDIF
59940  IF(r2sq.GT.pyr(0)*(r1sq+r2sq)) THEN
59941  ip2=i4
59942  ip4=i2
59943  ENDIF
59944  ENDIF
59945 
59946 C...If colour reconnection then bookkeep W+W- or Z0Z0
59947 C...and copy q qbar q qbar consecutively.
59948  IF(mstp(115).GE.1.AND.iql12.EQ.1.AND.iql34.EQ.1) THEN
59949  k(n+1,1)=11
59950  k(n+1,3)=ip1
59951  k(n+1,4)=n+3
59952  k(n+1,5)=n+4
59953  k(n+2,1)=11
59954  k(n+2,3)=ip3
59955  k(n+2,4)=n+5
59956  k(n+2,5)=n+6
59957  IF(k(ip1,2)+k(ip2,2).EQ.0) THEN
59958  k(n+1,2)=23
59959  k(n+2,2)=23
59960  mint(1)=22
59961  ELSEIF(pychge(k(ip1,2)).GT.0) THEN
59962  k(n+1,2)=24
59963  k(n+2,2)=-24
59964  mint(1)=25
59965  ELSE
59966  k(n+1,2)=-24
59967  k(n+2,2)=24
59968  mint(1)=25
59969  ENDIF
59970  DO 110 j=1,5
59971  k(n+3,j)=k(ip1,j)
59972  k(n+4,j)=k(ip2,j)
59973  k(n+5,j)=k(ip3,j)
59974  k(n+6,j)=k(ip4,j)
59975  p(n+1,j)=p(ip1,j)+p(ip2,j)
59976  p(n+2,j)=p(ip3,j)+p(ip4,j)
59977  p(n+3,j)=p(ip1,j)
59978  p(n+4,j)=p(ip2,j)
59979  p(n+5,j)=p(ip3,j)
59980  p(n+6,j)=p(ip4,j)
59981  v(n+1,j)=v(ip1,j)
59982  v(n+2,j)=v(ip3,j)
59983  v(n+3,j)=v(ip1,j)
59984  v(n+4,j)=v(ip2,j)
59985  v(n+5,j)=v(ip3,j)
59986  v(n+6,j)=v(ip4,j)
59987  110 CONTINUE
59988  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59989  & p(n+1,3)**2))
59990  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59991  & p(n+2,3)**2))
59992  k(n+3,3)=n+1
59993  k(n+4,3)=n+1
59994  k(n+5,3)=n+2
59995  k(n+6,3)=n+2
59996 C...Remove original q qbar q qbar and update counters.
59997  k(ip1,1)=k(ip1,1)+10
59998  k(ip2,1)=k(ip2,1)+10
59999  k(ip3,1)=k(ip3,1)+10
60000  k(ip4,1)=k(ip4,1)+10
60001  iw1=n+1
60002  iw2=n+2
60003  nsd1=n+2
60004  ip1=n+3
60005  ip2=n+4
60006  ip3=n+5
60007  ip4=n+6
60008  n=n+6
60009  ENDIF
60010 
60011 C...Do colour joinings and parton showers.
60012  IF(iql12.EQ.1) THEN
60013  ijoin(1)=ip1
60014  ijoin(2)=ip2
60015  CALL pyjoin(2,ijoin)
60016  ENDIF
60017  IF(iql12.EQ.1.OR.irad.EQ.1) THEN
60018  pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
60019  & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
60020  CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
60021  ENDIF
60022  naft1=n
60023  IF(iql34.EQ.1) THEN
60024  ijoin(1)=ip3
60025  ijoin(2)=ip4
60026  CALL pyjoin(2,ijoin)
60027  ENDIF
60028  IF(iql34.EQ.1.OR.irad.EQ.1) THEN
60029  pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
60030  & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
60031  CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
60032  ENDIF
60033 
60034 C...Optionally do colour reconnection.
60035  mint(32)=0
60036  msti(32)=0
60037  IF(mstp(115).GE.1.AND.iql12.EQ.1.AND.iql34.EQ.1) THEN
60038  CALL pyreco(iw1,iw2,nsd1,naft1)
60039  msti(32)=mint(32)
60040  ENDIF
60041 
60042 C...Do fragmentation and decays. Possibly except tau decay.
60043  IF(itau.EQ.0) THEN
60044  ntau=0
60045  DO 120 i=1,n
60046  IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
60047  ntau=ntau+1
60048  intau(ntau)=i
60049  k(i,1)=11
60050  ENDIF
60051  120 CONTINUE
60052  ENDIF
60053  CALL pyexec
60054  IF(itau.EQ.0) THEN
60055  DO 130 i=1,ntau
60056  k(intau(i),1)=1
60057  130 CONTINUE
60058  ENDIF
60059 
60060 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60061  IF(icom.EQ.0) THEN
60062  mstu(28)=0
60063  CALL pyhepc(1)
60064  ENDIF
60065 
60066  END
60067 
60068 C*********************************************************************
60069 
60070 C...PY6FRM
60071 C...An interface from a six-fermion generator to include
60072 C...parton showers and hadronization.
60073 
60074  SUBROUTINE py6frm(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
60075 
60076 C...Double precision and integer declarations.
60077  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60078  IMPLICIT INTEGER(i-n)
60079  INTEGER pyk,pychge,pycomp
60080 C...Commonblocks.
60081  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
60082  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60083  SAVE /pyjets/,/pydat1/
60084 C...Local arrays.
60085  dimension ijoin(2),intau(6),beta(3),betao(3),betan(3)
60086 
60087 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60088  IF(icom.EQ.0) THEN
60089  mstu(28)=0
60090  CALL pyhepc(2)
60091  ENDIF
60092 
60093 C...Loop through entries and pick up all final fermions/antifermions.
60094  i1=0
60095  i2=0
60096  i3=0
60097  i4=0
60098  i5=0
60099  i6=0
60100  DO 100 i=1,n
60101  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
60102  kfa=iabs(k(i,2))
60103  IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
60104  IF(k(i,2).GT.0) THEN
60105  IF(i1.EQ.0) THEN
60106  i1=i
60107  ELSEIF(i3.EQ.0) THEN
60108  i3=i
60109  ELSEIF(i5.EQ.0) THEN
60110  i5=i
60111  ELSE
60112  CALL pyerrm(16,'(PY6FRM:) more than three fermions')
60113  ENDIF
60114  ELSE
60115  IF(i2.EQ.0) THEN
60116  i2=i
60117  ELSEIF(i4.EQ.0) THEN
60118  i4=i
60119  ELSEIF(i6.EQ.0) THEN
60120  i6=i
60121  ELSE
60122  CALL pyerrm(16,'(PY6FRM:) more than three antifermions')
60123  ENDIF
60124  ENDIF
60125  ENDIF
60126  100 CONTINUE
60127 
60128 C...Check that event is arranged according to conventions.
60129  IF(i5.EQ.0.OR.i6.EQ.0) THEN
60130  CALL pyerrm(16,'(PY6FRM:) event contains too few fermions')
60131  ENDIF
60132  IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3.OR.i5.LT.i4.OR.i6.LT.i5) THEN
60133  CALL pyerrm(6,'(PY6FRM:) fermions arranged in wrong order')
60134  ENDIF
60135 
60136 C...Check which fermion pairs are quarks and which leptons.
60137  IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
60138  iql12=1
60139  ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
60140  iql12=2
60141  ELSE
60142  CALL pyerrm(16,'(PY6FRM:) first fermion pair inconsistent')
60143  ENDIF
60144  IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
60145  iql34=1
60146  ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
60147  iql34=2
60148  ELSE
60149  CALL pyerrm(16,'(PY6FRM:) second fermion pair inconsistent')
60150  ENDIF
60151  IF(iabs(k(i5,2)).LT.10.AND.iabs(k(i6,2)).LT.10) THEN
60152  iql56=1
60153  ELSEIF(iabs(k(i5,2)).GT.10.AND.iabs(k(i6,2)).GT.10) THEN
60154  iql56=2
60155  ELSE
60156  CALL pyerrm(16,'(PY6FRM:) third fermion pair inconsistent')
60157  ENDIF
60158 
60159 C...Decide whether to allow or not photon radiation in showers.
60160  mstj(41)=2
60161  IF(irad.EQ.0) mstj(41)=1
60162 
60163 C...Allow dipole pairings only among leptons and quarks separately.
60164  p12d=p12
60165  p13d=0d0
60166  IF(iql34.EQ.iql56) p13d=p13
60167  p21d=0d0
60168  IF(iql12.EQ.iql34) p21d=p21
60169  p23d=0d0
60170  IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p23d=p23
60171  p31d=0d0
60172  IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p31d=p31
60173  p32d=0d0
60174  IF(iql12.EQ.iql56) p32d=p32
60175 
60176 C...Decide whether t+tbar.
60177  itop=0
60178  IF(pyr(0).LT.ptop) THEN
60179  itop=1
60180 
60181 C...If t+tbar: reconstruct t's.
60182  it=n+1
60183  itb=n+2
60184  DO 110 j=1,5
60185  k(it,j)=0
60186  k(itb,j)=0
60187  p(it,j)=p(i1,j)+p(i3,j)+p(i4,j)
60188  p(itb,j)=p(i2,j)+p(i5,j)+p(i6,j)
60189  v(it,j)=0d0
60190  v(itb,j)=0d0
60191  110 CONTINUE
60192  k(it,1)=1
60193  k(itb,1)=1
60194  k(it,2)=6
60195  k(itb,2)=-6
60196  p(it,5)=sqrt(max(0d0,p(it,4)**2-p(it,1)**2-p(it,2)**2-
60197  & p(it,3)**2))
60198  p(itb,5)=sqrt(max(0d0,p(itb,4)**2-p(itb,1)**2-p(itb,2)**2-
60199  & p(itb,3)**2))
60200  n=n+2
60201 
60202 C...If t+tbar: colour join t's and let them shower.
60203  ijoin(1)=it
60204  ijoin(2)=itb
60205  CALL pyjoin(2,ijoin)
60206  pmtts=(p(it,4)+p(itb,4))**2-(p(it,1)+p(itb,1))**2-
60207  & (p(it,2)+p(itb,2))**2-(p(it,3)+p(itb,3))**2
60208  CALL pyshow(it,itb,sqrt(max(0d0,pmtts)))
60209 
60210 C...If t+tbar: pick up the t's after shower.
60211  itnew=it
60212  itbnew=itb
60213  DO 120 i=itb+1,n
60214  IF(k(i,2).EQ.6) itnew=i
60215  IF(k(i,2).EQ.-6) itbnew=i
60216  120 CONTINUE
60217 
60218 C...If t+tbar: loop over two top systems.
60219  DO 200 it1=1,2
60220  IF(it1.EQ.1) THEN
60221  ito=it
60222  itn=itnew
60223  ibo=i1
60224  iw1=i3
60225  iw2=i4
60226  ELSE
60227  ito=itb
60228  itn=itbnew
60229  ibo=i2
60230  iw1=i5
60231  iw2=i6
60232  ENDIF
60233  IF(iabs(k(ibo,2)).NE.5) CALL pyerrm(6,
60234  & '(PY6FRM:) not b in t decay')
60235 
60236 C...If t+tbar: find boost from original to new top frame.
60237  DO 130 j=1,3
60238  betao(j)=p(ito,j)/p(ito,4)
60239  betan(j)=p(itn,j)/p(itn,4)
60240  130 CONTINUE
60241 
60242 C...If t+tbar: boost copy of b by t shower and connect it in colour.
60243  n=n+1
60244  ib=n
60245  k(ib,1)=3
60246  k(ib,2)=k(ibo,2)
60247  k(ib,3)=itn
60248  DO 140 j=1,5
60249  p(ib,j)=p(ibo,j)
60250  v(ib,j)=0d0
60251  140 CONTINUE
60252  CALL pyrobo(ib,ib,0d0,0d0,-betao(1),-betao(2),-betao(3))
60253  CALL pyrobo(ib,ib,0d0,0d0,betan(1),betan(2),betan(3))
60254  k(ib,4)=mstu(5)*itn
60255  k(ib,5)=mstu(5)*itn
60256  k(itn,4)=k(itn,4)+ib
60257  k(itn,5)=k(itn,5)+ib
60258  k(itn,1)=k(itn,1)+10
60259  k(ibo,1)=k(ibo,1)+10
60260 
60261 C...If t+tbar: construct W recoiling against b.
60262  n=n+1
60263  iw=n
60264  DO 150 j=1,5
60265  k(iw,j)=0
60266  v(iw,j)=0d0
60267  150 CONTINUE
60268  k(iw,1)=1
60269  kchw=pychge(k(iw1,2))+pychge(k(iw2,2))
60270  IF(iabs(kchw).EQ.3) THEN
60271  k(iw,2)=isign(24,kchw)
60272  ELSE
60273  CALL pyerrm(16,'(PY6FRM:) fermion pair inconsistent with W')
60274  ENDIF
60275  k(iw,3)=iw1
60276 
60277 C...If t+tbar: construct W momentum, including boost by t shower.
60278  DO 160 j=1,4
60279  p(iw,j)=p(iw1,j)+p(iw2,j)
60280  160 CONTINUE
60281  p(iw,5)=sqrt(max(0d0,p(iw,4)**2-p(iw,1)**2-p(iw,2)**2-
60282  & p(iw,3)**2))
60283  CALL pyrobo(iw,iw,0d0,0d0,-betao(1),-betao(2),-betao(3))
60284  CALL pyrobo(iw,iw,0d0,0d0,betan(1),betan(2),betan(3))
60285 
60286 C...If t+tbar: boost b and W to top rest frame.
60287  DO 170 j=1,3
60288  beta(j)=(p(ib,j)+p(iw,j))/(p(ib,4)+p(iw,4))
60289  170 CONTINUE
60290  CALL pyrobo(ib,ib,0d0,0d0,-beta(1),-beta(2),-beta(3))
60291  CALL pyrobo(iw,iw,0d0,0d0,-beta(1),-beta(2),-beta(3))
60292 
60293 C...If t+tbar: let b shower and pick up modified W.
60294  pmts=(p(ib,4)+p(iw,4))**2-(p(ib,1)+p(iw,1))**2-
60295  & (p(ib,2)+p(iw,2))**2-(p(ib,3)+p(iw,3))**2
60296  CALL pyshow(ib,iw,sqrt(max(0d0,pmts)))
60297  DO 180 i=iw,n
60298  IF(iabs(k(i,2)).EQ.24) iwm=i
60299  180 CONTINUE
60300 
60301 C...If t+tbar: take copy of W decay products.
60302  DO 190 j=1,5
60303  k(n+1,j)=k(iw1,j)
60304  p(n+1,j)=p(iw1,j)
60305  v(n+1,j)=v(iw1,j)
60306  k(n+2,j)=k(iw2,j)
60307  p(n+2,j)=p(iw2,j)
60308  v(n+2,j)=v(iw2,j)
60309  190 CONTINUE
60310  k(iw1,1)=k(iw1,1)+10
60311  k(iw2,1)=k(iw2,1)+10
60312  k(iwm,1)=k(iwm,1)+10
60313  k(iwm,4)=n+1
60314  k(iwm,5)=n+2
60315  k(n+1,3)=iwm
60316  k(n+2,3)=iwm
60317  IF(it1.EQ.1) THEN
60318  i3=n+1
60319  i4=n+2
60320  ELSE
60321  i5=n+1
60322  i6=n+2
60323  ENDIF
60324  n=n+2
60325 
60326 C...If t+tbar: boost W decay products, first by effects of t shower,
60327 C...then by those of b shower. b and its shower simple boost back.
60328  CALL pyrobo(n-1,n,0d0,0d0,-betao(1),-betao(2),-betao(3))
60329  CALL pyrobo(n-1,n,0d0,0d0,betan(1),betan(2),betan(3))
60330  CALL pyrobo(n-1,n,0d0,0d0,-beta(1),-beta(2),-beta(3))
60331  CALL pyrobo(n-1,n,0d0,0d0,-p(iw,1)/p(iw,4),
60332  & -p(iw,2)/p(iw,4),-p(iw,3)/p(iw,4))
60333  CALL pyrobo(n-1,n,0d0,0d0,p(iwm,1)/p(iwm,4),
60334  & p(iwm,2)/p(iwm,4),p(iwm,3)/p(iwm,4))
60335  CALL pyrobo(ib,ib,0d0,0d0,beta(1),beta(2),beta(3))
60336  CALL pyrobo(iw,n,0d0,0d0,beta(1),beta(2),beta(3))
60337  200 CONTINUE
60338  ENDIF
60339 
60340 C...Decide on dipole pairing.
60341  ip1=i1
60342  ip3=i3
60343  ip5=i5
60344  prn=pyr(0)*(p12d+p13d+p21d+p23d+p31d+p32d)
60345  IF(itop.EQ.1.OR.prn.LT.p12d) THEN
60346  ip2=i2
60347  ip4=i4
60348  ip6=i6
60349  ELSEIF(prn.LT.p12d+p13d) THEN
60350  ip2=i2
60351  ip4=i6
60352  ip6=i4
60353  ELSEIF(prn.LT.p12d+p13d+p21d) THEN
60354  ip2=i4
60355  ip4=i2
60356  ip6=i6
60357  ELSEIF(prn.LT.p12d+p13d+p21d+p23d) THEN
60358  ip2=i4
60359  ip4=i6
60360  ip6=i2
60361  ELSEIF(prn.LT.p12d+p13d+p21d+p23d+p31d) THEN
60362  ip2=i6
60363  ip4=i2
60364  ip6=i4
60365  ELSE
60366  ip2=i6
60367  ip4=i4
60368  ip6=i2
60369  ENDIF
60370 
60371 C...Do colour joinings and parton showers
60372 C...(except ones already made for t+tbar).
60373  IF(itop.EQ.0) THEN
60374  IF(iql12.EQ.1) THEN
60375  ijoin(1)=ip1
60376  ijoin(2)=ip2
60377  CALL pyjoin(2,ijoin)
60378  ENDIF
60379  IF(iql12.EQ.1.OR.irad.EQ.1) THEN
60380  pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
60381  & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
60382  CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
60383  ENDIF
60384  ENDIF
60385  IF(iql34.EQ.1) THEN
60386  ijoin(1)=ip3
60387  ijoin(2)=ip4
60388  CALL pyjoin(2,ijoin)
60389  ENDIF
60390  IF(iql34.EQ.1.OR.irad.EQ.1) THEN
60391  pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
60392  & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
60393  CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
60394  ENDIF
60395  IF(iql56.EQ.1) THEN
60396  ijoin(1)=ip5
60397  ijoin(2)=ip6
60398  CALL pyjoin(2,ijoin)
60399  ENDIF
60400  IF(iql56.EQ.1.OR.irad.EQ.1) THEN
60401  pm56s=(p(ip5,4)+p(ip6,4))**2-(p(ip5,1)+p(ip6,1))**2-
60402  & (p(ip5,2)+p(ip6,2))**2-(p(ip5,3)+p(ip6,3))**2
60403  CALL pyshow(ip5,ip6,sqrt(max(0d0,pm56s)))
60404  ENDIF
60405 
60406 C...Do fragmentation and decays. Possibly except tau decay.
60407  IF(itau.EQ.0) THEN
60408  ntau=0
60409  DO 210 i=1,n
60410  IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
60411  ntau=ntau+1
60412  intau(ntau)=i
60413  k(i,1)=11
60414  ENDIF
60415  210 CONTINUE
60416  ENDIF
60417  CALL pyexec
60418  IF(itau.EQ.0) THEN
60419  DO 220 i=1,ntau
60420  k(intau(i),1)=1
60421  220 CONTINUE
60422  ENDIF
60423 
60424 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60425  IF(icom.EQ.0) THEN
60426  mstu(28)=0
60427  CALL pyhepc(1)
60428  ENDIF
60429 
60430  END
60431 
60432 C*********************************************************************
60433 
60434 C...PY4JET
60435 C...An interface from a four-parton generator to include
60436 C...parton showers and hadronization.
60437 
60438  SUBROUTINE py4jet(PMAX,IRAD,ICOM)
60439 
60440 C...Double precision and integer declarations.
60441  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60442  IMPLICIT INTEGER(i-n)
60443  INTEGER pyk,pychge,pycomp
60444 C...Commonblocks.
60445  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
60446  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60447  SAVE /pyjets/,/pydat1/
60448 C...Local arrays.
60449  dimension ijoin(2),ptot(4),beta(3)
60450 
60451 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60452  IF(icom.EQ.0) THEN
60453  mstu(28)=0
60454  CALL pyhepc(2)
60455  ENDIF
60456 
60457 C...Loop through entries and pick up all final partons.
60458  i1=0
60459  i2=0
60460  i3=0
60461  i4=0
60462  DO 100 i=1,n
60463  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
60464  kfa=iabs(k(i,2))
60465  IF((kfa.GE.1.AND.kfa.LE.6).OR.kfa.EQ.21) THEN
60466  IF(k(i,2).GT.0.AND.k(i,2).LE.6) THEN
60467  IF(i1.EQ.0) THEN
60468  i1=i
60469  ELSEIF(i3.EQ.0) THEN
60470  i3=i
60471  ELSE
60472  CALL pyerrm(16,'(PY4JET:) more than two quarks')
60473  ENDIF
60474  ELSEIF(k(i,2).LT.0) THEN
60475  IF(i2.EQ.0) THEN
60476  i2=i
60477  ELSEIF(i4.EQ.0) THEN
60478  i4=i
60479  ELSE
60480  CALL pyerrm(16,'(PY4JET:) more than two antiquarks')
60481  ENDIF
60482  ELSE
60483  IF(i3.EQ.0) THEN
60484  i3=i
60485  ELSEIF(i4.EQ.0) THEN
60486  i4=i
60487  ELSE
60488  CALL pyerrm(16,'(PY4JET:) more than two gluons')
60489  ENDIF
60490  ENDIF
60491  ENDIF
60492  100 CONTINUE
60493 
60494 C...Check that event is arranged according to conventions.
60495  IF(i1.EQ.0.OR.i2.EQ.0.OR.i3.EQ.0.OR.i4.EQ.0) THEN
60496  CALL pyerrm(16,'(PY4JET:) event contains too few partons')
60497  ENDIF
60498  IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
60499  CALL pyerrm(6,'(PY4JET:) partons arranged in wrong order')
60500  ENDIF
60501 
60502 C...Check whether second pair are quarks or gluons.
60503  IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
60504  iqg34=1
60505  ELSEIF(k(i3,2).EQ.21.AND.k(i4,2).EQ.21) THEN
60506  iqg34=2
60507  ELSE
60508  CALL pyerrm(16,'(PY4JET:) second parton pair inconsistent')
60509  ENDIF
60510 
60511 C...Boost partons to their cm frame.
60512  DO 110 j=1,4
60513  ptot(j)=p(i1,j)+p(i2,j)+p(i3,j)+p(i4,j)
60514  110 CONTINUE
60515  ecm=sqrt(max(0d0,ptot(4)**2-ptot(1)**2-ptot(2)**2-ptot(3)**2))
60516  DO 120 j=1,3
60517  beta(j)=ptot(j)/ptot(4)
60518  120 CONTINUE
60519  CALL pyrobo(i1,i1,0d0,0d0,-beta(1),-beta(2),-beta(3))
60520  CALL pyrobo(i2,i2,0d0,0d0,-beta(1),-beta(2),-beta(3))
60521  CALL pyrobo(i3,i3,0d0,0d0,-beta(1),-beta(2),-beta(3))
60522  CALL pyrobo(i4,i4,0d0,0d0,-beta(1),-beta(2),-beta(3))
60523  nsav=n
60524 
60525 C...Decide and set up shower history for q qbar q' qbar' events.
60526  IF(iqg34.EQ.1) THEN
60527  w1=py4jtw(0,i1,i3,i4)
60528  w2=py4jtw(0,i2,i3,i4)
60529  IF(w1.GT.pyr(0)*(w1+w2)) THEN
60530  CALL py4jts(0,i1,i3,i4,i2,qmax)
60531  ELSE
60532  CALL py4jts(0,i2,i3,i4,i1,qmax)
60533  ENDIF
60534 
60535 C...Decide and set up shower history for q qbar g g events.
60536  ELSE
60537  w1=py4jtw(i1,i3,i2,i4)
60538  w2=py4jtw(i1,i4,i2,i3)
60539  w3=py4jtw(0,i3,i1,i4)
60540  w4=py4jtw(0,i4,i1,i3)
60541  w5=py4jtw(0,i3,i2,i4)
60542  w6=py4jtw(0,i4,i2,i3)
60543  w7=py4jtw(0,i1,i3,i4)
60544  w8=py4jtw(0,i2,i3,i4)
60545  wr=(w1+w2+w3+w4+w5+w6+w7+w8)*pyr(0)
60546  IF(w1.GT.wr) THEN
60547  CALL py4jts(i1,i3,i2,i4,0,qmax)
60548  ELSEIF(w1+w2.GT.wr) THEN
60549  CALL py4jts(i1,i4,i2,i3,0,qmax)
60550  ELSEIF(w1+w2+w3.GT.wr) THEN
60551  CALL py4jts(0,i3,i1,i4,i2,qmax)
60552  ELSEIF(w1+w2+w3+w4.GT.wr) THEN
60553  CALL py4jts(0,i4,i1,i3,i2,qmax)
60554  ELSEIF(w1+w2+w3+w4+w5.GT.wr) THEN
60555  CALL py4jts(0,i3,i2,i4,i1,qmax)
60556  ELSEIF(w1+w2+w3+w4+w5+w6.GT.wr) THEN
60557  CALL py4jts(0,i4,i2,i3,i1,qmax)
60558  ELSEIF(w1+w2+w3+w4+w5+w6+w7.GT.wr) THEN
60559  CALL py4jts(0,i1,i3,i4,i2,qmax)
60560  ELSE
60561  CALL py4jts(0,i2,i3,i4,i1,qmax)
60562  ENDIF
60563  ENDIF
60564 
60565 C...Boost back original partons and mark them as deleted.
60566  CALL pyrobo(i1,i1,0d0,0d0,beta(1),beta(2),beta(3))
60567  CALL pyrobo(i2,i2,0d0,0d0,beta(1),beta(2),beta(3))
60568  CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
60569  CALL pyrobo(i4,i4,0d0,0d0,beta(1),beta(2),beta(3))
60570  k(i1,1)=k(i1,1)+10
60571  k(i2,1)=k(i2,1)+10
60572  k(i3,1)=k(i3,1)+10
60573  k(i4,1)=k(i4,1)+10
60574 
60575 C...Rotate shower initiating partons to be along z axis.
60576  phi=pyangl(p(nsav+1,1),p(nsav+1,2))
60577  CALL pyrobo(nsav+1,nsav+6,0d0,-phi,0d0,0d0,0d0)
60578  the=pyangl(p(nsav+1,3),p(nsav+1,1))
60579  CALL pyrobo(nsav+1,nsav+6,-the,0d0,0d0,0d0,0d0)
60580 
60581 C...Set up copy of shower initiating partons as on mass shell.
60582  DO 140 i=n+1,n+2
60583  DO 130 j=1,5
60584  k(i,j)=0
60585  p(i,j)=0d0
60586  v(i,j)=v(i1,j)
60587  130 CONTINUE
60588  k(i,1)=1
60589  k(i,2)=k(i-6,2)
60590  140 CONTINUE
60591  IF(k(nsav+1,2).EQ.k(i1,2)) THEN
60592  k(n+1,3)=i1
60593  p(n+1,5)=p(i1,5)
60594  k(n+2,3)=i2
60595  p(n+2,5)=p(i2,5)
60596  ELSE
60597  k(n+1,3)=i2
60598  p(n+1,5)=p(i2,5)
60599  k(n+2,3)=i1
60600  p(n+2,5)=p(i1,5)
60601  ENDIF
60602  pabs=sqrt(max(0d0,(ecm**2-p(n+1,5)**2-p(n+2,5)**2)**2-
60603  &(2d0*p(n+1,5)*p(n+2,5))**2))/(2d0*ecm)
60604  p(n+1,3)=pabs
60605  p(n+1,4)=sqrt(pabs**2+p(n+1,5)**2)
60606  p(n+2,3)=-pabs
60607  p(n+2,4)=sqrt(pabs**2+p(n+2,5)**2)
60608  n=n+2
60609 
60610 C...Decide whether to allow or not photon radiation in showers.
60611 C...Connect up colours.
60612  mstj(41)=2
60613  IF(irad.EQ.0) mstj(41)=1
60614  ijoin(1)=n-1
60615  ijoin(2)=n
60616  CALL pyjoin(2,ijoin)
60617 
60618 C...Decide on maximum virtuality and do parton shower.
60619  IF(pmax.LT.parj(82)) THEN
60620  pqmax=qmax
60621  ELSE
60622  pqmax=pmax
60623  ENDIF
60624  CALL pyshow(nsav+1,-100,pqmax)
60625 
60626 C...Rotate and boost back system.
60627  CALL pyrobo(nsav+1,n,the,phi,beta(1),beta(2),beta(3))
60628 
60629 C...Do fragmentation and decays.
60630  CALL pyexec
60631 
60632 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60633  IF(icom.EQ.0) THEN
60634  mstu(28)=0
60635  CALL pyhepc(1)
60636  ENDIF
60637 
60638  RETURN
60639  END
60640 
60641 C*********************************************************************
60642 
60643 C...PY4JTW
60644 C...Auxiliary to PY4JET, to evaluate weight of configuration.
60645 
60646  FUNCTION py4jtw(IA1,IA2,IA3,IA4)
60647 
60648 C...Double precision and integer declarations.
60649  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60650  IMPLICIT INTEGER(i-n)
60651  INTEGER pyk,pychge,pycomp
60652 C...Commonblocks.
60653  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
60654  SAVE /pyjets/
60655 
60656 C...First case: when both original partons radiate.
60657 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
60658  IF(ia1.NE.0) THEN
60659  DO 100 j=1,4
60660  p(n+1,j)=p(ia1,j)+p(ia2,j)
60661  p(n+2,j)=p(ia3,j)+p(ia4,j)
60662  100 CONTINUE
60663  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
60664  & p(n+1,3)**2))
60665  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
60666  & p(n+2,3)**2))
60667  z1=p(ia1,4)/p(n+1,4)
60668  wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-p(ia1,5)**2)
60669  z2=p(ia3,4)/p(n+2,4)
60670  wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-p(ia3,5)**2)
60671 
60672 C...Second case: when one original parton radiates to three.
60673 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
60674  ELSE
60675  DO 110 j=1,4
60676  p(n+2,j)=p(ia3,j)+p(ia4,j)
60677  p(n+1,j)=p(n+2,j)+p(ia2,j)
60678  110 CONTINUE
60679  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
60680  & p(n+1,3)**2))
60681  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
60682  & p(n+2,3)**2))
60683  IF(k(ia2,2).EQ.21) THEN
60684  z1=p(n+2,4)/p(n+1,4)
60685  wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
60686  & p(ia3,5)**2)
60687  ELSE
60688  z1=p(ia2,4)/p(n+1,4)
60689  wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
60690  & p(ia2,5)**2)
60691  ENDIF
60692  z2=p(ia3,4)/p(n+2,4)
60693  IF(k(ia2,2).EQ.21) THEN
60694  wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-
60695  & p(ia3,5)**2)
60696  ELSEIF(k(ia3,2).EQ.21) THEN
60697  wt2=3d0*((1d0-z2*(1d0-z2))**2/(z2*(1d0-z2)))/p(n+2,5)**2
60698  ELSE
60699  wt2=0.5d0*(z2**2+(1d0-z2)**2)
60700  ENDIF
60701  ENDIF
60702 
60703 C...Total weight.
60704  py4jtw=wt1*wt2
60705 
60706  RETURN
60707  END
60708 
60709 C*********************************************************************
60710 
60711 C...PY4JTS
60712 C...Auxiliary to PY4JET, to set up chosen configuration.
60713 
60714  SUBROUTINE py4jts(IA1,IA2,IA3,IA4,IA5,QMAX)
60715 
60716 C...Double precision and integer declarations.
60717  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60718  IMPLICIT INTEGER(i-n)
60719  INTEGER pyk,pychge,pycomp
60720 C...Commonblocks.
60721  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
60722  SAVE /pyjets/
60723 
60724 C...Reset info.
60725  DO 110 i=n+1,n+6
60726  DO 100 j=1,5
60727  k(i,j)=0
60728  v(i,j)=v(ia2,j)
60729  100 CONTINUE
60730  k(i,1)=16
60731  110 CONTINUE
60732 
60733 C...First case: when both original partons radiate.
60734 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
60735  IF(ia1.NE.0) THEN
60736 
60737 C...Set up flavour and history pointers for new partons.
60738  k(n+1,2)=k(ia1,2)
60739  k(n+2,2)=k(ia3,2)
60740  k(n+3,2)=k(ia1,2)
60741  k(n+4,2)=k(ia2,2)
60742  k(n+5,2)=k(ia3,2)
60743  k(n+6,2)=k(ia4,2)
60744  k(n+1,3)=ia1
60745  k(n+1,4)=n+3
60746  k(n+1,5)=n+4
60747  k(n+2,3)=ia3
60748  k(n+2,4)=n+5
60749  k(n+2,5)=n+6
60750  k(n+3,3)=n+1
60751  k(n+4,3)=n+1
60752  k(n+5,3)=n+2
60753  k(n+6,3)=n+2
60754 
60755 C...Set up momenta for new partons.
60756  DO 120 j=1,5
60757  p(n+1,j)=p(ia1,j)+p(ia2,j)
60758  p(n+2,j)=p(ia3,j)+p(ia4,j)
60759  p(n+3,j)=p(ia1,j)
60760  p(n+4,j)=p(ia2,j)
60761  p(n+5,j)=p(ia3,j)
60762  p(n+6,j)=p(ia4,j)
60763  120 CONTINUE
60764  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
60765  & p(n+1,3)**2))
60766  p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
60767  & p(n+2,3)**2))
60768  qmax=min(p(n+1,5),p(n+2,5))
60769 
60770 C...Second case: q radiates twice.
60771 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
60772 C...IA5=N+2 does not radiate.
60773  ELSEIF(k(ia2,2).EQ.21) THEN
60774 
60775 C...Set up flavour and history pointers for new partons.
60776  k(n+1,2)=k(ia3,2)
60777  k(n+2,2)=k(ia5,2)
60778  k(n+3,2)=k(ia3,2)
60779  k(n+4,2)=k(ia2,2)
60780  k(n+5,2)=k(ia3,2)
60781  k(n+6,2)=k(ia4,2)
60782  k(n+1,3)=ia3
60783  k(n+1,4)=n+3
60784  k(n+1,5)=n+4
60785  k(n+2,3)=ia5
60786  k(n+3,3)=n+1
60787  k(n+3,4)=n+5
60788  k(n+3,5)=n+6
60789  k(n+4,3)=n+1
60790  k(n+5,3)=n+3
60791  k(n+6,3)=n+3
60792 
60793 C...Set up momenta for new partons.
60794  DO 130 j=1,5
60795  p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
60796  p(n+2,j)=p(ia5,j)
60797  p(n+3,j)=p(ia3,j)+p(ia4,j)
60798  p(n+4,j)=p(ia2,j)
60799  p(n+5,j)=p(ia3,j)
60800  p(n+6,j)=p(ia4,j)
60801  130 CONTINUE
60802  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
60803  & p(n+1,3)**2))
60804  p(n+3,5)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,1)**2-p(n+3,2)**2-
60805  & p(n+3,3)**2))
60806  qmax=p(n+3,5)
60807 
60808 C...Third case: q radiates g, g branches.
60809 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
60810 C...IA5=N+2 does not radiate.
60811  ELSE
60812 
60813 C...Set up flavour and history pointers for new partons.
60814  k(n+1,2)=k(ia2,2)
60815  k(n+2,2)=k(ia5,2)
60816  k(n+3,2)=k(ia2,2)
60817  k(n+4,2)=21
60818  k(n+5,2)=k(ia3,2)
60819  k(n+6,2)=k(ia4,2)
60820  k(n+1,3)=ia2
60821  k(n+1,4)=n+3
60822  k(n+1,5)=n+4
60823  k(n+2,3)=ia5
60824  k(n+3,3)=n+1
60825  k(n+4,3)=n+1
60826  k(n+4,4)=n+5
60827  k(n+4,5)=n+6
60828  k(n+5,3)=n+4
60829  k(n+6,3)=n+4
60830 
60831 C...Set up momenta for new partons.
60832  DO 140 j=1,5
60833  p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
60834  p(n+2,j)=p(ia5,j)
60835  p(n+3,j)=p(ia2,j)
60836  p(n+4,j)=p(ia3,j)+p(ia4,j)
60837  p(n+5,j)=p(ia3,j)
60838  p(n+6,j)=p(ia4,j)
60839  140 CONTINUE
60840  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
60841  & p(n+1,3)**2))
60842  p(n+4,5)=sqrt(max(0d0,p(n+4,4)**2-p(n+4,1)**2-p(n+4,2)**2-
60843  & p(n+4,3)**2))
60844  qmax=p(n+4,5)
60845 
60846  ENDIF
60847  n=n+6
60848 
60849  RETURN
60850  END
60851 
60852 C*********************************************************************
60853 
60854 C...PYJOIN
60855 C...Connects a sequence of partons with colour flow indices,
60856 C...as required for subsequent shower evolution (or other operations).
60857 
60858  SUBROUTINE pyjoin(NJOIN,IJOIN)
60859 
60860 C...Double precision and integer declarations.
60861  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60862  IMPLICIT INTEGER(i-n)
60863  INTEGER pyk,pychge,pycomp
60864 C...Commonblocks.
60865  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
60866  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60867  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
60868  SAVE /pyjets/,/pydat1/,/pydat2/
60869 C...Local array.
60870  dimension ijoin(*)
60871 
60872 C...Check that partons are of right types to be connected.
60873  IF(njoin.LT.2) goto 120
60874  kqsum=0
60875  DO 100 ijn=1,njoin
60876  i=ijoin(ijn)
60877  IF(i.LE.0.OR.i.GT.n) goto 120
60878  IF(k(i,1).LT.1.OR.k(i,1).GT.3) goto 120
60879  kc=pycomp(k(i,2))
60880  IF(kc.EQ.0) goto 120
60881  kq=kchg(kc,2)*isign(1,k(i,2))
60882  IF(kq.EQ.0) goto 120
60883  IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) goto 120
60884  IF(kq.NE.2) kqsum=kqsum+kq
60885  IF(ijn.EQ.1) kqs=kq
60886  100 CONTINUE
60887  IF(kqsum.NE.0) goto 120
60888 
60889 C...Connect the partons sequentially (closing for gluon loop).
60890  kcs=(9-kqs)/2
60891  IF(kqs.EQ.2) kcs=int(4.5d0+pyr(0))
60892  DO 110 ijn=1,njoin
60893  i=ijoin(ijn)
60894  k(i,1)=3
60895  IF(ijn.NE.1) ip=ijoin(ijn-1)
60896  IF(ijn.EQ.1) ip=ijoin(njoin)
60897  IF(ijn.NE.njoin) in=ijoin(ijn+1)
60898  IF(ijn.EQ.njoin) in=ijoin(1)
60899  k(i,kcs)=mstu(5)*in
60900  k(i,9-kcs)=mstu(5)*ip
60901  IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
60902  IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
60903  110 CONTINUE
60904 
60905 C...Error exit: no action taken.
60906  RETURN
60907  120 CALL pyerrm(12,
60908  &'(PYJOIN:) given entries can not be joined by one string')
60909 
60910  RETURN
60911  END
60912 
60913 C*********************************************************************
60914 
60915 C...PYGIVE
60916 C...Sets values of commonblock variables.
60917 
60918  SUBROUTINE pygive(CHIN)
60919 
60920 C...Double precision and integer declarations.
60921  IMPLICIT DOUBLE PRECISION(a-h, o-z)
60922  IMPLICIT INTEGER(i-n)
60923  INTEGER pyk,pychge,pycomp
60924 C...Commonblocks.
60925  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
60926  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60927  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
60928  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
60929  common/pydat4/chaf(500,2)
60930  CHARACTER chaf*16
60931  common/pydatr/mrpy(6),rrpy(100)
60932  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
60933  common/pypars/mstp(200),parp(200),msti(200),pari(200)
60934  common/pyint1/mint(400),vint(400)
60935  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
60936  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
60937  common/pyint4/mwid(500),wids(500,5)
60938  common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
60939  common/pyint6/proc(0:500)
60940  CHARACTER proc*28
60941  common/pyint7/sigt(0:6,0:6,0:5)
60942  common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
60943  &xpdir(-6:6)
60944  common/pymssm/imss(0:99),rmss(0:99)
60945  common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
60946  common/pytcsm/itcm(0:99),rtcm(0:99)
60947  common/pypued/iued(0:99),rued(0:99)
60948  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,
60949  &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,
60950  &/pyint6/,/pyint7/,/pyint8/,/pymssm/,/pymsrv/,/pytcsm/,/pypued/
60951 C...Local arrays and character variables.
60952  CHARACTER chin*(*),chfix*104,chbit*104,chold*8,chnew*8,chold2*28,
60953  &chnew2*28,chnam*6,chvar(56)*6,chalp(2)*26,chind*8,chini*10,
60954  &chinr*16,chdig*10
60955  dimension msvar(56,8)
60956 
60957 C...For each variable to be translated give: name,
60958 C...integer/real/character, no. of indices, lower&upper index bounds.
60959  DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60960  &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60961  &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60962  &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60963  &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60964  &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60965  &'ITCM','RTCM','IUED','RUED'/
60966  DATA ((msvar(i,j),j=1,8),i=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60967  &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60968  &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60969  &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60970  &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60971  &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60972  &1,1,1,6,4*0, 2,1,1,100,4*0,
60973  &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60974  &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60975  &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60976  &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60977  &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60978  &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60979  &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60980  &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60981  &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60982  &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60983  &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60984  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
60985  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, chdig/'1234567890'/
60986 
60987 C...Length of character variable. Subdivide it into instructions.
60988  IF(mstu(12).NE.12345.AND.chin.NE.'mstu(12)=12345'.AND.
60989  &chin.NE.'MSTU(12)=12345') CALL pylist(0)
60990  chbit=chin//' '
60991  lbit=101
60992  100 lbit=lbit-1
60993  IF(chbit(lbit:lbit).EQ.' ') goto 100
60994  ltot=0
60995  DO 110 lcom=1,lbit
60996  IF(chbit(lcom:lcom).EQ.' ') goto 110
60997  ltot=ltot+1
60998  chfix(ltot:ltot)=chbit(lcom:lcom)
60999  110 CONTINUE
61000  llow=0
61001  120 lhig=llow+1
61002  130 lhig=lhig+1
61003  IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') goto 130
61004  lbit=lhig-llow-1
61005  chbit(1:lbit)=chfix(llow+1:lhig-1)
61006 
61007 C...Send off decay-mode on/off commands to PYONOF.
61008  ionof=0
61009  DO 135 ldig=1,10
61010  IF(chbit(1:1).EQ.chdig(ldig:ldig)) ionof=1
61011  135 CONTINUE
61012  IF(ionof.EQ.1) THEN
61013  CALL pyonof(chin)
61014  RETURN
61015  ENDIF
61016 
61017 C...Peel off any text following exclamation mark.
61018  lhig2=lbit
61019  DO 140 llow2=lhig2,1,-1
61020  IF(chbit(llow2:llow2).EQ.'!') lbit=llow2-1
61021  140 CONTINUE
61022  IF(lbit.EQ.0) RETURN
61023 
61024 C...Identify commonblock variable.
61025  lnam=1
61026  150 lnam=lnam+1
61027  IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
61028  &lnam.LE.6) goto 150
61029  chnam=chbit(1:lnam-1)//' '
61030  DO 170 lcom=1,lnam-1
61031  DO 160 lalp=1,26
61032  IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
61033  & chalp(2)(lalp:lalp)
61034  160 CONTINUE
61035  170 CONTINUE
61036  ivar=0
61037  DO 180 iv=1,56
61038  IF(chnam.EQ.chvar(iv)) ivar=iv
61039  180 CONTINUE
61040  IF(ivar.EQ.0) THEN
61041  CALL pyerrm(18,'(PYGIVE:) do not recognize variable '//chnam)
61042  llow=lhig
61043  IF(llow.LT.ltot) goto 120
61044  RETURN
61045  ENDIF
61046 
61047 C...Identify any indices.
61048  i1=0
61049  i2=0
61050  i3=0
61051  nindx=0
61052  IF(chbit(lnam:lnam).EQ.'(') THEN
61053  lind=lnam
61054  190 lind=lind+1
61055  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 190
61056  chind=' '
61057  IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c')
61058  & .AND.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17.OR.
61059  & ivar.EQ.37)) THEN
61060  chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
61061  READ(chind,'(I8)') kf
61062  i1=pycomp(kf)
61063  ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
61064  & 'c') THEN
61065  CALL pyerrm(18,'(PYGIVE:) not allowed to use C index for '//
61066  & chnam)
61067  llow=lhig
61068  IF(llow.LT.ltot) goto 120
61069  RETURN
61070  ELSE
61071  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
61072  READ(chind,'(I8)') i1
61073  ENDIF
61074  lnam=lind
61075  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
61076  nindx=1
61077  ENDIF
61078  IF(chbit(lnam:lnam).EQ.',') THEN
61079  lind=lnam
61080  200 lind=lind+1
61081  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 200
61082  chind=' '
61083  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
61084  READ(chind,'(I8)') i2
61085  lnam=lind
61086  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
61087  nindx=2
61088  ENDIF
61089  IF(chbit(lnam:lnam).EQ.',') THEN
61090  lind=lnam
61091  210 lind=lind+1
61092  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 210
61093  chind=' '
61094  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
61095  READ(chind,'(I8)') i3
61096  lnam=lind+1
61097  nindx=3
61098  ENDIF
61099 
61100 C...Check that indices allowed.
61101  ierr=0
61102  IF(nindx.NE.msvar(ivar,2)) ierr=1
61103  IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
61104  &ierr=2
61105  IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
61106  &ierr=3
61107  IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
61108  &ierr=4
61109  IF(chbit(lnam:lnam).NE.'=') ierr=5
61110  IF(ierr.GE.1) THEN
61111  CALL pyerrm(18,'(PYGIVE:) unallowed indices for '//
61112  & chbit(1:lnam-1))
61113  llow=lhig
61114  IF(llow.LT.ltot) goto 120
61115  RETURN
61116  ENDIF
61117 
61118 C...Save old value of variable.
61119  IF(ivar.EQ.1) THEN
61120  iold=n
61121  ELSEIF(ivar.EQ.2) THEN
61122  iold=k(i1,i2)
61123  ELSEIF(ivar.EQ.3) THEN
61124  rold=p(i1,i2)
61125  ELSEIF(ivar.EQ.4) THEN
61126  rold=v(i1,i2)
61127  ELSEIF(ivar.EQ.5) THEN
61128  iold=mstu(i1)
61129  ELSEIF(ivar.EQ.6) THEN
61130  rold=paru(i1)
61131  ELSEIF(ivar.EQ.7) THEN
61132  iold=mstj(i1)
61133  ELSEIF(ivar.EQ.8) THEN
61134  rold=parj(i1)
61135  ELSEIF(ivar.EQ.9) THEN
61136  iold=kchg(i1,i2)
61137  ELSEIF(ivar.EQ.10) THEN
61138  rold=pmas(i1,i2)
61139  ELSEIF(ivar.EQ.11) THEN
61140  rold=parf(i1)
61141  ELSEIF(ivar.EQ.12) THEN
61142  rold=vckm(i1,i2)
61143  ELSEIF(ivar.EQ.13) THEN
61144  iold=mdcy(i1,i2)
61145  ELSEIF(ivar.EQ.14) THEN
61146  iold=mdme(i1,i2)
61147  ELSEIF(ivar.EQ.15) THEN
61148  rold=brat(i1)
61149  ELSEIF(ivar.EQ.16) THEN
61150  iold=kfdp(i1,i2)
61151  ELSEIF(ivar.EQ.17) THEN
61152  chold=chaf(i1,i2)(1:8)
61153  ELSEIF(ivar.EQ.18) THEN
61154  iold=mrpy(i1)
61155  ELSEIF(ivar.EQ.19) THEN
61156  rold=rrpy(i1)
61157  ELSEIF(ivar.EQ.20) THEN
61158  iold=msel
61159  ELSEIF(ivar.EQ.21) THEN
61160  iold=msub(i1)
61161  ELSEIF(ivar.EQ.22) THEN
61162  iold=kfin(i1,i2)
61163  ELSEIF(ivar.EQ.23) THEN
61164  rold=ckin(i1)
61165  ELSEIF(ivar.EQ.24) THEN
61166  iold=mstp(i1)
61167  ELSEIF(ivar.EQ.25) THEN
61168  rold=parp(i1)
61169  ELSEIF(ivar.EQ.26) THEN
61170  iold=msti(i1)
61171  ELSEIF(ivar.EQ.27) THEN
61172  rold=pari(i1)
61173  ELSEIF(ivar.EQ.28) THEN
61174  iold=mint(i1)
61175  ELSEIF(ivar.EQ.29) THEN
61176  rold=vint(i1)
61177  ELSEIF(ivar.EQ.30) THEN
61178  iold=iset(i1)
61179  ELSEIF(ivar.EQ.31) THEN
61180  iold=kfpr(i1,i2)
61181  ELSEIF(ivar.EQ.32) THEN
61182  rold=coef(i1,i2)
61183  ELSEIF(ivar.EQ.33) THEN
61184  iold=icol(i1,i2,i3)
61185  ELSEIF(ivar.EQ.34) THEN
61186  rold=xsfx(i1,i2)
61187  ELSEIF(ivar.EQ.35) THEN
61188  iold=isig(i1,i2)
61189  ELSEIF(ivar.EQ.36) THEN
61190  rold=sigh(i1)
61191  ELSEIF(ivar.EQ.37) THEN
61192  iold=mwid(i1)
61193  ELSEIF(ivar.EQ.38) THEN
61194  rold=wids(i1,i2)
61195  ELSEIF(ivar.EQ.39) THEN
61196  iold=ngen(i1,i2)
61197  ELSEIF(ivar.EQ.40) THEN
61198  rold=xsec(i1,i2)
61199  ELSEIF(ivar.EQ.41) THEN
61200  chold2=proc(i1)
61201  ELSEIF(ivar.EQ.42) THEN
61202  rold=sigt(i1,i2,i3)
61203  ELSEIF(ivar.EQ.43) THEN
61204  rold=xpvmd(i1)
61205  ELSEIF(ivar.EQ.44) THEN
61206  rold=xpanl(i1)
61207  ELSEIF(ivar.EQ.45) THEN
61208  rold=xpanh(i1)
61209  ELSEIF(ivar.EQ.46) THEN
61210  rold=xpbeh(i1)
61211  ELSEIF(ivar.EQ.47) THEN
61212  rold=xpdir(i1)
61213  ELSEIF(ivar.EQ.48) THEN
61214  iold=imss(i1)
61215  ELSEIF(ivar.EQ.49) THEN
61216  rold=rmss(i1)
61217  ELSEIF(ivar.EQ.50) THEN
61218  rold=rvlam(i1,i2,i3)
61219  ELSEIF(ivar.EQ.51) THEN
61220  rold=rvlamp(i1,i2,i3)
61221  ELSEIF(ivar.EQ.52) THEN
61222  rold=rvlamb(i1,i2,i3)
61223  ELSEIF(ivar.EQ.53) THEN
61224  iold=itcm(i1)
61225  ELSEIF(ivar.EQ.54) THEN
61226  rold=rtcm(i1)
61227  ELSEIF(ivar.EQ.55) THEN
61228  iold=iued(i1)
61229  ELSEIF(ivar.EQ.56) THEN
61230  rold=rued(i1)
61231  ENDIF
61232 
61233 C...Print current value of variable. Loop back.
61234  IF(lnam.GE.lbit) THEN
61235  chbit(lnam:14)=' '
61236  chbit(15:60)=' has the value '
61237  IF(msvar(ivar,1).EQ.1) THEN
61238  WRITE(chbit(51:60),'(I10)') iold
61239  ELSEIF(msvar(ivar,1).EQ.2) THEN
61240  WRITE(chbit(47:60),'(F14.5)') rold
61241  ELSEIF(msvar(ivar,1).EQ.3) THEN
61242  chbit(53:60)=chold
61243  ELSE
61244  chbit(33:60)=chold
61245  ENDIF
61246  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
61247  llow=lhig
61248  IF(llow.LT.ltot) goto 120
61249  RETURN
61250  ENDIF
61251 
61252 C...Read in new variable value.
61253  IF(msvar(ivar,1).EQ.1) THEN
61254  chini=' '
61255  chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
61256  READ(chini,'(I10)') inew
61257  ELSEIF(msvar(ivar,1).EQ.2) THEN
61258  chinr=' '
61259  chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
61260  READ(chinr,*) rnew
61261  ELSEIF(msvar(ivar,1).EQ.3) THEN
61262  chnew=chbit(lnam+1:lbit)//' '
61263  ELSE
61264  chnew2=chbit(lnam+1:lbit)//' '
61265  ENDIF
61266 
61267 C...Store new variable value.
61268  IF(ivar.EQ.1) THEN
61269  n=inew
61270  ELSEIF(ivar.EQ.2) THEN
61271  k(i1,i2)=inew
61272  ELSEIF(ivar.EQ.3) THEN
61273  p(i1,i2)=rnew
61274  ELSEIF(ivar.EQ.4) THEN
61275  v(i1,i2)=rnew
61276  ELSEIF(ivar.EQ.5) THEN
61277  mstu(i1)=inew
61278  ELSEIF(ivar.EQ.6) THEN
61279  paru(i1)=rnew
61280  ELSEIF(ivar.EQ.7) THEN
61281  mstj(i1)=inew
61282  ELSEIF(ivar.EQ.8) THEN
61283  parj(i1)=rnew
61284  ELSEIF(ivar.EQ.9) THEN
61285  kchg(i1,i2)=inew
61286  ELSEIF(ivar.EQ.10) THEN
61287  pmas(i1,i2)=rnew
61288  ELSEIF(ivar.EQ.11) THEN
61289  parf(i1)=rnew
61290  ELSEIF(ivar.EQ.12) THEN
61291  vckm(i1,i2)=rnew
61292  ELSEIF(ivar.EQ.13) THEN
61293  mdcy(i1,i2)=inew
61294  ELSEIF(ivar.EQ.14) THEN
61295  mdme(i1,i2)=inew
61296  ELSEIF(ivar.EQ.15) THEN
61297  brat(i1)=rnew
61298  ELSEIF(ivar.EQ.16) THEN
61299  kfdp(i1,i2)=inew
61300  ELSEIF(ivar.EQ.17) THEN
61301  chaf(i1,i2)=chnew
61302  ELSEIF(ivar.EQ.18) THEN
61303  mrpy(i1)=inew
61304  ELSEIF(ivar.EQ.19) THEN
61305  rrpy(i1)=rnew
61306  ELSEIF(ivar.EQ.20) THEN
61307  msel=inew
61308  ELSEIF(ivar.EQ.21) THEN
61309  msub(i1)=inew
61310  ELSEIF(ivar.EQ.22) THEN
61311  kfin(i1,i2)=inew
61312  ELSEIF(ivar.EQ.23) THEN
61313  ckin(i1)=rnew
61314  ELSEIF(ivar.EQ.24) THEN
61315  mstp(i1)=inew
61316  ELSEIF(ivar.EQ.25) THEN
61317  parp(i1)=rnew
61318  ELSEIF(ivar.EQ.26) THEN
61319  msti(i1)=inew
61320  ELSEIF(ivar.EQ.27) THEN
61321  pari(i1)=rnew
61322  ELSEIF(ivar.EQ.28) THEN
61323  mint(i1)=inew
61324  ELSEIF(ivar.EQ.29) THEN
61325  vint(i1)=rnew
61326  ELSEIF(ivar.EQ.30) THEN
61327  iset(i1)=inew
61328  ELSEIF(ivar.EQ.31) THEN
61329  kfpr(i1,i2)=inew
61330  ELSEIF(ivar.EQ.32) THEN
61331  coef(i1,i2)=rnew
61332  ELSEIF(ivar.EQ.33) THEN
61333  icol(i1,i2,i3)=inew
61334  ELSEIF(ivar.EQ.34) THEN
61335  xsfx(i1,i2)=rnew
61336  ELSEIF(ivar.EQ.35) THEN
61337  isig(i1,i2)=inew
61338  ELSEIF(ivar.EQ.36) THEN
61339  sigh(i1)=rnew
61340  ELSEIF(ivar.EQ.37) THEN
61341  mwid(i1)=inew
61342  ELSEIF(ivar.EQ.38) THEN
61343  wids(i1,i2)=rnew
61344  ELSEIF(ivar.EQ.39) THEN
61345  ngen(i1,i2)=inew
61346  ELSEIF(ivar.EQ.40) THEN
61347  xsec(i1,i2)=rnew
61348  ELSEIF(ivar.EQ.41) THEN
61349  proc(i1)=chnew2
61350  ELSEIF(ivar.EQ.42) THEN
61351  sigt(i1,i2,i3)=rnew
61352  ELSEIF(ivar.EQ.43) THEN
61353  xpvmd(i1)=rnew
61354  ELSEIF(ivar.EQ.44) THEN
61355  xpanl(i1)=rnew
61356  ELSEIF(ivar.EQ.45) THEN
61357  xpanh(i1)=rnew
61358  ELSEIF(ivar.EQ.46) THEN
61359  xpbeh(i1)=rnew
61360  ELSEIF(ivar.EQ.47) THEN
61361  xpdir(i1)=rnew
61362  ELSEIF(ivar.EQ.48) THEN
61363  imss(i1)=inew
61364  ELSEIF(ivar.EQ.49) THEN
61365  rmss(i1)=rnew
61366  ELSEIF(ivar.EQ.50) THEN
61367  rvlam(i1,i2,i3)=rnew
61368  ELSEIF(ivar.EQ.51) THEN
61369  rvlamp(i1,i2,i3)=rnew
61370  ELSEIF(ivar.EQ.52) THEN
61371  rvlamb(i1,i2,i3)=rnew
61372  ELSEIF(ivar.EQ.53) THEN
61373  itcm(i1)=inew
61374  ELSEIF(ivar.EQ.54) THEN
61375  rtcm(i1)=rnew
61376  ELSEIF(ivar.EQ.55) THEN
61377  iued(i1)=inew
61378  ELSEIF(ivar.EQ.56) THEN
61379  rued(i1)=rnew
61380  ENDIF
61381 
61382 C...Write old and new value. Loop back.
61383  chbit(lnam:14)=' '
61384  chbit(15:60)=' changed from to '
61385  IF(msvar(ivar,1).EQ.1) THEN
61386  WRITE(chbit(33:42),'(I10)') iold
61387  WRITE(chbit(51:60),'(I10)') inew
61388  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
61389  ELSEIF(msvar(ivar,1).EQ.2) THEN
61390  WRITE(chbit(29:42),'(F14.5)') rold
61391  WRITE(chbit(47:60),'(F14.5)') rnew
61392  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
61393  ELSEIF(msvar(ivar,1).EQ.3) THEN
61394  chbit(35:42)=chold
61395  chbit(53:60)=chnew
61396  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
61397  ELSE
61398  chbit(15:88)=' changed from '//chold2//' to '//chnew2
61399  IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
61400  ENDIF
61401  llow=lhig
61402  IF(llow.LT.ltot) goto 120
61403 
61404 C...Format statement for output on unit MSTU(11) (by default 6).
61405  5000 FORMAT(5x,a60)
61406  5100 FORMAT(5x,a88)
61407 
61408  RETURN
61409  END
61410 
61411 C*********************************************************************
61412 
61413 C...PYONOF
61414 C...Switches on and off decay channel by search for match.
61415 
61416  SUBROUTINE pyonof(CHIN)
61417 
61418 C...Double precision and integer declarations.
61419  IMPLICIT DOUBLE PRECISION(a-h, o-z)
61420  IMPLICIT INTEGER(i-n)
61421  INTEGER pyk,pychge,pycomp
61422 C...Commonblocks.
61423  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
61424  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
61425  SAVE /pydat1/,/pydat3/
61426 C...Local arrays and character variables.
61427  INTEGER kfcmp(10),kftmp(10)
61428  CHARACTER chin*(*),chtmp*104,chfix*104,chmode*10,chcode*8,
61429  &chalp(2)*26
61430  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
61431  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
61432 
61433 C...Determine length of character variable.
61434  chtmp=chin//' '
61435  lbeg=0
61436  100 lbeg=lbeg+1
61437  IF(chtmp(lbeg:lbeg).EQ.' ') goto 100
61438  lend=lbeg-1
61439  105 lend=lend+1
61440  IF(lend.LE.100.AND.chtmp(lend:lend).NE.'!') goto 105
61441  110 lend=lend-1
61442  IF(chtmp(lend:lend).EQ.' ') goto 110
61443  len=1+lend-lbeg
61444  chfix(1:len)=chtmp(lbeg:lend)
61445 
61446 C...Find colon separator and particle code.
61447  lcolon=0
61448  120 lcolon=lcolon+1
61449  IF(chfix(lcolon:lcolon).NE.':') goto 120
61450  chcode=' '
61451  chcode(10-lcolon:8)=chfix(1:lcolon-1)
61452  READ(chcode,'(I8)',err=300) kf
61453  kc=pycomp(kf)
61454 
61455 C...Done if unknown code or no decay channels.
61456  IF(kc.EQ.0) THEN
61457  CALL pyerrm(18,'(PYONOF:) unrecognized particle '//chcode)
61458  RETURN
61459  ENDIF
61460  idcbeg=mdcy(kc,2)
61461  idclen=mdcy(kc,3)
61462  IF(idcbeg.EQ.0.OR.idclen.EQ.0) THEN
61463  CALL pyerrm(18,'(PYONOF:) no decay channels for '//chcode)
61464  RETURN
61465  ENDIF
61466 
61467 C...Find command name up to blank or equal sign.
61468  lsep=lcolon
61469  130 lsep=lsep+1
61470  IF(lsep.LE.len.AND.chfix(lsep:lsep).NE.' '.AND.
61471  &chfix(lsep:lsep).NE.'=') goto 130
61472  chmode=' '
61473  lmode=lsep-lcolon-1
61474  chmode(1:lmode)=chfix(lcolon+1:lsep-1)
61475 
61476 C...Convert to uppercase.
61477  DO 150 lcom=1,lmode
61478  DO 140 lalp=1,26
61479  IF(chmode(lcom:lcom).EQ.chalp(1)(lalp:lalp))
61480  & chmode(lcom:lcom)=chalp(2)(lalp:lalp)
61481  140 CONTINUE
61482  150 CONTINUE
61483 
61484 C...Identify command. Failed if not identified.
61485  mode=0
61486  IF(chmode.EQ.'ALLOFF') mode=1
61487  IF(chmode.EQ.'ALLON') mode=2
61488  IF(chmode.EQ.'OFFIFANY') mode=3
61489  IF(chmode.EQ.'ONIFANY') mode=4
61490  IF(chmode.EQ.'OFFIFALL') mode=5
61491  IF(chmode.EQ.'ONIFALL') mode=6
61492  IF(chmode.EQ.'OFFIFMATCH') mode=7
61493  IF(chmode.EQ.'ONIFMATCH') mode=8
61494  IF(mode.EQ.0) THEN
61495  CALL pyerrm(18,'(PYONOF:) unknown command '//chmode)
61496  RETURN
61497  ENDIF
61498 
61499 C...Simple cases when all on or all off.
61500  IF(mode.EQ.1.OR.mode.EQ.2) THEN
61501  WRITE(mstu(11),1000) kf,chmode
61502  DO 160 idc=idcbeg,idcbeg+idclen-1
61503  IF(mdme(idc,1).LT.0) goto 160
61504  mdme(idc,1)=mode-1
61505  160 CONTINUE
61506  RETURN
61507  ENDIF
61508 
61509 C...Identify matching list.
61510  ncmp=0
61511  lbeg=lsep
61512  170 lbeg=lbeg+1
61513  IF(lbeg.GT.len) goto 190
61514  IF(lbeg.LT.len.AND.(chfix(lbeg:lbeg).EQ.' '.OR.
61515  &chfix(lbeg:lbeg).EQ.'='.OR.chfix(lbeg:lbeg).EQ.',')) goto 170
61516  lend=lbeg-1
61517  180 lend=lend+1
61518  IF(lend.LT.len.AND.chfix(lend:lend).NE.' '.AND.
61519  &chfix(lend:lend).NE.'='.AND.chfix(lend:lend).NE.',') goto 180
61520  IF(lend.LT.len) lend=lend-1
61521  chcode=' '
61522  chcode(8-lend+lbeg:8)=chfix(lbeg:lend)
61523  READ(chcode,'(I8)',err=300) kfread
61524  ncmp=ncmp+1
61525  kfcmp(ncmp)=iabs(kfread)
61526  lbeg=lend
61527  IF(ncmp.LT.10) goto 170
61528  190 CONTINUE
61529  WRITE(mstu(11),1100) kf,chmode,(kfcmp(icmp),icmp=1,ncmp)
61530 
61531 C...Only one matching required.
61532  IF(mode.EQ.3.OR.mode.EQ.4) THEN
61533  DO 220 idc=idcbeg,idcbeg+idclen-1
61534  IF(mdme(idc,1).LT.0) goto 220
61535  DO 210 ikf=1,5
61536  kfnow=iabs(kfdp(idc,ikf))
61537  IF(kfnow.EQ.0) goto 210
61538  DO 200 icmp=1,ncmp
61539  IF(kfcmp(icmp).EQ.kfnow) THEN
61540  mdme(idc,1)=mode-3
61541  goto 220
61542  ENDIF
61543  200 CONTINUE
61544  210 CONTINUE
61545  220 CONTINUE
61546  RETURN
61547  ENDIF
61548 
61549 C...Multiple matchings required.
61550  DO 260 idc=idcbeg,idcbeg+idclen-1
61551  IF(mdme(idc,1).LT.0) goto 260
61552  ntmp=ncmp
61553  DO 230 itmp=1,ntmp
61554  kftmp(itmp)=kfcmp(itmp)
61555  230 CONTINUE
61556  nfin=0
61557  DO 250 ikf=1,5
61558  kfnow=iabs(kfdp(idc,ikf))
61559  IF(kfnow.EQ.0) goto 250
61560  nfin=nfin+1
61561  DO 240 itmp=1,ntmp
61562  IF(kftmp(itmp).EQ.kfnow) THEN
61563  kftmp(itmp)=kftmp(ntmp)
61564  ntmp=ntmp-1
61565  goto 250
61566  ENDIF
61567  240 CONTINUE
61568  250 CONTINUE
61569  IF(ntmp.EQ.0.AND.mode.LE.6) mdme(idc,1)=mode-5
61570  IF(ntmp.EQ.0.AND.nfin.EQ.ncmp.AND.mode.GE.7)
61571  & mdme(idc,1)=mode-7
61572  260 CONTINUE
61573  RETURN
61574 
61575 C...Error exit for impossible read of particle code.
61576  300 CALL pyerrm(18,'(PYONOF:) could not interpret particle code '
61577  &//chcode)
61578 
61579 C...Formats for output.
61580  1000 FORMAT(' Decays for',i8,' set ',a10)
61581  1100 FORMAT(' Decays for',i8,' set ',a10,' if match',10i8)
61582 
61583  RETURN
61584  END
61585 C*********************************************************************
61586 
61587 C...PYTUNE
61588 C...Presets for a few specific underlying-event and min-bias tunes
61589 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
61590 C...others require particular versions of pythia (e.g. the SCI and GAL
61591 C...models). See below for details.
61592  SUBROUTINE pytune(MYTUNE)
61593 C
61594 C ITUNE NAME (detailed descriptions below)
61595 C 0 Default : No settings changed => defaults.
61596 C
61597 C ====== Old UE, Q2-ordered showers ====================================
61598 C 100 A : Rick Field's CDF Tune A (Oct 2002)
61599 C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
61600 C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
61601 C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
61602 C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
61603 C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
61604 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
61605 C 107 ACR : Tune A modified with new CR model (Mar 2007)
61606 C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
61607 C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
61608 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
61609 C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
61610 C 111 AW-Pro : Tune AW, -"- (Oct 2008)
61611 C 112 BW-Pro : Tune BW, -"- (Oct 2008)
61612 C 113 DW-Pro : Tune DW, -"- (Oct 2008)
61613 C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
61614 C 115 QW-Pro : Tune QW, -"- (Oct 2008)
61615 C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
61616 C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
61617 C 118 D6-Pro : Tune D6, -"- (Oct 2008)
61618 C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
61619 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
61620 C 129 Pro-Q2O : Professor Q2-ordered tune (Feb 2009)
61621 C ---- LHC tune variations on Pro-Q2O
61622 C 136 Q12-F1 : Variation with wide fragmentation function (Mar 2012)
61623 C 137 Q12-F2 : Variation with narrow fragmentation function (Mar 2012)
61624 C
61625 C ====== Intermediate and Hybrid Models ================================
61626 C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
61627 C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
61628 C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
61629 C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
61630 C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
61631 C
61632 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
61633 C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
61634 C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
61635 C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
61636 C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
61637 C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
61638 C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
61639 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
61640 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
61641 C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
61642 C 311 S1-Pro : S1 -"- (Oct 2008)
61643 C 312 S2-Pro : S2 -"- (Oct 2008)
61644 C 313 S0A-Pro : S0A -"- (Oct 2008)
61645 C 314 NOCR-Pro : NOCR -"- (Oct 2008)
61646 C 315 Old-Pro : Old -"- (Oct 2008)
61647 C 316 ATLAS MC08 : pT-ordered showers, CTEQ6L1 (2008)
61648 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
61649 C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
61650 C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
61651 C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
61652 C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
61653 C balance & different scaling to LHC & RHIC (Feb 2009)
61654 C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
61655 C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
61656 C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
61657 C 327 Perugia 10: Alternative to Perugia 0, with more FSR (May 2010)
61658 C off ISR, more BR breakup, more strangeness
61659 C 328 Perugia K : Alternative to Perugia 2010, with a (May 2010)
61660 C K-factor applied to MPI cross sections
61661 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
61662 C 329 Pro-pTO : Professor pT-ordered tune w. S0 CR model (Feb 2009)
61663 C ---- Tunes introduced in 6.4.23:
61664 C 330 ATLAS MC09 : pT-ordered showers, LO* PDFs (2009)
61665 C 331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009)
61666 C 334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI (Oct 2010)
61667 C 335 Pro-pT* : Professor Tune with LO* (Mar 2009)
61668 C 336 Pro-pT6 : Professor Tune with CTEQ6LL (Mar 2009)
61669 C 339 Pro-pT** : Professor Tune with LO** (Mar 2009)
61670 C 340 AMBT1 : First ATLAS tune including 7 TeV data (May 2010)
61671 C 341 Z1 : First CMS tune including 7 TeV data (Aug 2010)
61672 C 342 Z1-LEP : CMS tune Z1, with improved LEP parameters (Oct 2010)
61673 C 343 Z2 : Retune of Z1 by Field w CTEQ6L1 PDFs (2010)
61674 C 344 Z2-LEP : Retune of Z1 by Skands w CTEQ6L1 PDFs (Feb 2011)
61675 C 345 AMBT2B-CT6L : 2nd ATLAS MB tune, vers 'B', w CTEQ6L1 (Jul 2011)
61676 C 346 AUET2B-CT6L : UE tune accompanying AMBT2B (Jul 2011)
61677 C 347 AUET2B-CT66 : AUET2 with CTEQ 6.6 NLO PDFs (Nov 2011)
61678 C 348 AUET2B-CT10 : AUET2 with CTEQ 10 NLO PDFs (Nov 2011)
61679 C 349 AUET2B-NN21 : AUET2 with NNPDF 2.1 NLO PDFs (Nov 2011)
61680 C 350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011)
61681 C 351 P2011 radHi : Variation with alphaS(pT/2)
61682 C 352 P2011 radLo : Variation with alphaS(2pT)
61683 C 353 P2011 mpiHi : Variation with more semi-hard MPI
61684 C 354 P2011 noCR : Variation without color reconnections
61685 C 355 P2011 LO** : Perugia 2011 using MSTW LO** PDFs (Mar 2011)
61686 C 356 P2011 C6 : Perugia 2011 using CTEQ6L1 PDFs (Mar 2011)
61687 C 357 P2011 T16 : Variation with PARP(90)=0.32 away from 7 TeV
61688 C 358 P2011 T32 : Variation with PARP(90)=0.16 awat from 7 TeV
61689 C 359 P2011 TeV : Perugia 2011 optimized for Tevatron (Mar 2011)
61690 C 360 S Global : Schulz-Skands Global fit (Mar 2011)
61691 C 361 S 7000 : Schulz-Skands at 7000 GeV (Mar 2011)
61692 C 362 S 1960 : Schulz-Skands at 1960 GeV (Mar 2011)
61693 C 363 S 1800 : Schulz-Skands at 1800 GeV (Mar 2011)
61694 C 364 S 900 : Schulz-Skands at 900 GeV (Mar 2011)
61695 C 365 S 630 : Schulz-Skands at 630 GeV (Mar 2011)
61696 C
61697 C 370 P12 : Retune of Perugia 2011 w CTEQ6L1 (Oct 2012)
61698 C 371 P12-radHi : Variation with alphaS(pT/2)
61699 C 372 P12-radLo : Variation with alphaS(2pT)
61700 C 373 P12-mpiHi : Variation with more semi-hard MPI
61701 C 374 P12-loCR : Variation using lower CR strength -> more Nch
61702 C 375 P12-noCR : Variation without any color reconnections
61703 C 376 P12-FL : Variation with more longitudinal fragmentation
61704 C 377 P12-FT : Variation with more transverse fragmentation
61705 C 378 P12-M8LO : Variation using MSTW 2008 LO PDFs
61706 C 379 P12-LO** : Variation using MRST LO** PDFs
61707 C 380 P12-val0 : Variation with PARP(87)=0D0 (Jul 2013)
61708 C 381 P12-ueHi : Variation with lower pT0 (more soft UE activity)
61709 C 382 P12-ueLo : Variation with higher pT0 (less soft UE activity)
61710 C 383 P12-IBK : Perugia 2012 with Innsbruck ee fragmentation parameters
61711 
61712 C 390 IBK-CTEQ5L : Innsbruck pp tune with CTEQ5 LO PDFs (Jul 2013)
61713 C 391 IBK-CTEQ6LL : with CTEQ6LL LO PDFs
61714 C 392 IBK-MSTW08LO : with MSTW08 LO PDFS
61715 C 393 IBK-CTEQ66NLO : with CTEQ6 NLO PDFs
61716 C 394 IBK-CT10NLO : with CT10 NLO PDFs
61717 C 395 IBK-MSTW08NLO : with MSTW08 NLO PDFs
61718 C 396 IBK-MSTW08LO* : with MSTW07 LO* PDFs
61719 C 397 IBK-MRSTLO** : with MRSTMCal (LO**) PDFs
61720 C 398 IBK-CT09MC2 : with CTEQ09MC2 PDFs
61721 
61722 C ======= The Uppsala models ===========================================
61723 C 1201 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
61724 C 1202 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
61725 C 1401 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
61726 C 1402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
61727 C
61728 C More details;
61729 C
61730 C Quick Dictionary:
61731 C BE : Bose-Einstein
61732 C BR : Beam Remnants
61733 C CR : Colour Reconnections
61734 C HAD: Hadronization
61735 C ISR/FSR: Initial-State Radiation / Final-State Radiation
61736 C FSI: Final-State Interactions (=CR+BE)
61737 C MB : Minimum-bias
61738 C MI : Multiple Interactions
61739 C UE : Underlying Event
61740 C
61741 C=======================================================================
61742 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
61743 C=======================================================================
61744 C
61745 C A (100) and AW (101). CTEQ5L parton distributions
61746 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61747 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61748 C...Key feature: extensively compared to CDF data (R.D. Field).
61749 C...* Large starting scale for ISR (PARP(67)=4)
61750 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
61751 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61752 C
61753 C BW (102). CTEQ5L parton distributions
61754 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61755 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61756 C...Key feature: extensively compared to CDF data (R.D. Field).
61757 C...NB: Can also be run with Pythia 6.2 or 6.312+
61758 C...* Small starting scale for ISR (PARP(67)=1)
61759 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
61760 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61761 C
61762 C DW (103) and DWT (104). CTEQ5L parton distributions
61763 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61764 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61765 C...Key feature: extensively compared to CDF data (R.D. Field).
61766 C...NB: Can also be run with Pythia 6.2 or 6.312+
61767 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
61768 C...* DWT has a different reference energy, the same as the "S" models
61769 C... below, leading to more UE activity at the LHC, but less at RHIC.
61770 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61771 C
61772 C QW (105). CTEQ61 parton distributions
61773 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61774 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61775 C...Key feature: uses CTEQ61 (external pdf library must be linked)
61776 C
61777 C ATLAS-DC2 (106). CTEQ5L parton distributions
61778 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61779 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61780 C...Key feature: tune used by the ATLAS collaboration.
61781 C
61782 C ACR (107). CTEQ5L parton distributions
61783 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
61784 C...Key feature: Tune A modified to use annealing CR.
61785 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
61786 C
61787 C D6 (108) and D6T (109). CTEQ6L parton distributions
61788 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
61789 C
61790 C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
61791 C Old UE model, Q2-ordered showers.
61792 C...Key feature: Rick Field's family of tunes revamped with the
61793 C...Professor Q2-ordered final-state shower and fragmentation tunes
61794 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
61795 C...Key feature: improved descriptions of LEP data.
61796 C
61797 C Pro-Q2O (129). CTEQ5L parton distributions
61798 C Old UE model, Q2-ordered showers.
61799 C...Key feature: Complete retune of old model by Professor, including
61800 C...large amounts of both LEP and Tevatron data.
61801 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
61802 C...extreme in this tune, corresponding to using mu_R = pT/3 .
61803 C
61804 C=======================================================================
61805 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
61806 C=======================================================================
61807 C
61808 C IM1 (200). Intermediate model, Q2-ordered showers,
61809 C CTEQ5L parton distributions
61810 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
61811 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
61812 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
61813 C
61814 C APT (201). Old UE model, pT-ordered final-state showers,
61815 C CTEQ5L parton distributions
61816 C...Key feature: Rick Field's Tune A, but with new final-state showers
61817 C
61818 C APT-Pro (211). Old UE model, pT-ordered final-state showers,
61819 C CTEQ5L parton distributions
61820 C...Key feature: APT revamped with the Professor pT-ordered final-state
61821 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
61822 C...Perugia MPI workshop in October 2008.
61823 C
61824 C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
61825 C CTEQ5L parton distributions
61826 C...Key feature: APT-Pro with final-state showers off the MPI,
61827 C...lower ISR renormalization scale to improve agreement with the
61828 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
61829 C...to min-bias at 630 GeV.
61830 C
61831 C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
61832 C CTEQ6L1 parton distributions.
61833 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
61834 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
61835 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
61836 C
61837 C=======================================================================
61838 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
61839 C=======================================================================
61840 C
61841 C S0 (300) and S0A (303). CTEQ5L parton distributions
61842 C...Key feature: large amount of multiple interactions
61843 C...* Somewhat faster than the other colour annealing scenarios.
61844 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
61845 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
61846 C...* Small amount of radiation.
61847 C...* Large amount of low-pT MI
61848 C...* Low degree of proton lumpiness (broad matter dist.)
61849 C...* CR Type S (driven by free triplets), of medium strength.
61850 C...* See: Pythia6402 update notes or later.
61851 C
61852 C S1 (301). CTEQ5L parton distributions
61853 C...Key feature: large amount of radiation.
61854 C...* Large amount of low-pT perturbative ISR
61855 C...* Large amount of FSR off ISR partons
61856 C...* Small amount of low-pT multiple interactions
61857 C...* Moderate degree of proton lumpiness
61858 C...* Least aggressive CR type (S+S Type I), but with large strength
61859 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61860 C
61861 C S2 (302). CTEQ5L parton distributions
61862 C...Key feature: very lumpy proton + gg string cluster formation allowed
61863 C...* Small amount of radiation
61864 C...* Moderate amount of low-pT MI
61865 C...* High degree of proton lumpiness (more spiky matter distribution)
61866 C...* Most aggressive CR type (S+S Type II), but with small strength
61867 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61868 C
61869 C NOCR (304). CTEQ5L parton distributions
61870 C...Key feature: no colour reconnections (NB: "Best fit" only).
61871 C...* NB: <pT>(Nch) problematic in this tune.
61872 C...* Small amount of radiation
61873 C...* Small amount of low-pT MI
61874 C...* Low degree of proton lumpiness
61875 C...* Large BR composite x enhancement factor
61876 C...* Most clever colour flow without CR ("Lambda ordering")
61877 C
61878 C ATLAS-CSC (306). CTEQ6L parton distributions
61879 C...Key feature: 11-parameter ATLAS tune of the new framework.
61880 C...* Old (pre-annealing) colour reconnections a la 305.
61881 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61882 C
61883 C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
61884 C...Key feature: the S0 family of tunes revamped with the Professor
61885 C...pT-ordered final-state shower and fragmentation tunes presented by
61886 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
61887 C...Key feature: improved descriptions of LEP data.
61888 C
61889 C ATLAS MC08 (316). CTEQ6L1 parton distributions
61890 C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs
61891 C...* Warning: uses Peterson fragmentation function for heavy quarks
61892 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61893 C
61894 C Perugia-0 (320). CTEQ5L parton distributions.
61895 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
61896 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
61897 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
61898 C...beam-remnant breakup (more baryon number transport), and suppression
61899 C...of CR in high-pT string pieces.
61900 C
61901 C Perugia-HARD (321). CTEQ5L parton distributions.
61902 C...Key feature: More ISR, More FSR, Less MPI, Less BR
61903 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
61904 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
61905 C...baryon number transport), and more fragmentation pT.
61906 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
61907 C...DY pT spectrum is HARD.
61908 C
61909 C Perugia-SOFT (322). CTEQ5L parton distributions.
61910 C...Key feature: Less ISR, Less FSR, More MPI, More BR
61911 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
61912 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
61913 C...number transport), and less fragmentation pT.
61914 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
61915 C...DY pT spectrum is SOFT
61916 C
61917 C Perugia-3 (323). CTEQ5L parton distributions.
61918 C...Key feature: variant of Perugia-0 with more extreme energy scaling
61919 C...properties while still agreeing with Tevatron data from 630 to 1960.
61920 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61921 C...allows FSR off the active end of dipoles stretched to the remnant.
61922 C
61923 C Perugia-NOCR (324). CTEQ5L parton distributions.
61924 C...Key feature: Retune of NOCR-Pro with better scaling properties to
61925 C...lower energies and somewhat better agreement with Tevatron data
61926 C...at 1800/1960.
61927 C
61928 C Perugia-* (325). MRST LO* parton distributions for generators
61929 C...Key feature: first attempt at using the LO* distributions
61930 C...(external pdf library must be linked).
61931 C
61932 C Perugia-6 (326). CTEQ6L1 parton distributions
61933 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61934 C
61935 C Perugia-2010 (327). CTEQ5L parton distributions
61936 C...Key feature: Retune of Perugia 0 to attempt to better describe
61937 C...strangeness yields at RHIC and at LEP. Also increased the amount
61938 C...of FSR off ISR following the conclusions in arXiv:1001.4082.
61939 C...Increased the amount of beam blowup, causing more baryon transport
61940 C...into the detector, to further explore this possibility. Using
61941 C...a new color-reconnection model that relies on determining a thrust
61942 C...axis for the events and then computing reconnection probabilities for
61943 C...the individual string pieces based on the actual string densities
61944 C...per rapidity interval along that thrust direction.
61945 C
61946 C Perugia-K (328). CTEQ5L parton distributions
61947 C...Key feature: uses a ``K'' factor on the MPI cross sections
61948 C...This gives a larger rate of minijets and pushes the underlying-event
61949 C...activity towards higher pT. To compensate for the increased activity
61950 C...at higher pT, the infared regularization scale is larger for this tune.
61951 C
61952 C Pro-pTO (329). CTEQ5L parton distributions
61953 C...Key feature: Complete retune of new model by Professor, including
61954 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61955 C
61956 C ATLAS MC09 (330). LO* parton distributions
61957 C...Key feature: Good overall agreement with Tevatron and early LHC data.
61958 C...Similar to Perugia *.
61959 C
61960 C ATLAS MC09c (331). LO* parton distributions
61961 C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data.
61962 C...Similar to Perugia *. Retuned CR model with respect to MC09.
61963 C
61964 C Pro-pT* (335) LO* parton distributions
61965 C...Key feature: Retune of Pro-PTO with MRST LO* PDFs.
61966 C
61967 C Pro-pT6 (336). CTEQ6L1 parton distributions
61968 C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs.
61969 C
61970 C Pro-pT** (339). LO** parton distributions
61971 C...Key feature: Retune of Pro-PTO with MRST LO** PDFs.
61972 C
61973 C AMBT1 (340). LO* parton distributions
61974 C...Key feature: First ATLAS tune including 7-TeV LHC data.
61975 C...Mainly retuned CR and mass distribution with respect to MC09c.
61976 C...Note: cannot be run standalone since it uses external PDFs.
61977 C
61978 C CMSZ1 (341). CTEQ5L parton distributions
61979 C...Key feature: First CMS tune including 7-TeV LHC data.
61980 C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs,
61981 C...has a lower pT0 at the Tevatron, which scales faster with energy.
61982 C
61983 C Z1-LEP (342). CTEQ5L parton distributions
61984 C...Key feature: CMS tune Z1 with improved LEP parameters, mostly
61985 C...taken from the Professor/Perugia tunes, with a few minor updates.
61986 C
61987 C...More recent Perugia tunes: see arXiv:1005.3457
61988 C
61989 C...Schulz-Skands tunes: see arXiv:1103.3649
61990 
61991 
61992 C...Global statements
61993  IMPLICIT DOUBLE PRECISION(a-h, o-z)
61994  INTEGER pyk,pychge,pycomp
61995 
61996 C...Commonblocks.
61997  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
61998  common/pypars/mstp(200),parp(200),msti(200),pari(200)
61999 
62000 C...SAVE statements
62001  SAVE /pydat1/,/pypars/
62002 
62003 C...Internal parameters
62004  parameter(mxtuns=500)
62005  CHARACTER*8 chdoc
62006  parameter(chdoc='Aug 2013')
62007  CHARACTER*16 chnams(0:mxtuns), chname
62008  CHARACTER*42 chmstj(50), chmstp(100), chparp(100),
62009  & chparj(100), chmstu(101:121), chparu(101:121)
62010  CHARACTER*60 ch60
62011  CHARACTER*70 ch70
62012  DATA (chnams(i),i=0,1)/'Default',' '/
62013  DATA (chnams(i),i=100,119)/
62014  & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
62015  & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
62016  1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
62017  1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
62018  1 'Tune D6-Pro','Tune D6T-Pro'/
62019  DATA (chnams(i),i=120,129)/
62020  & 9*' ','Pro-Q2O'/
62021  DATA (chnams(i),i=130,139)/
62022  & 'Q12','Q12-radHi','Q12-radLo','Q12-mpiHi','Q12-noCR',
62023  & 'Q12-M','Q12-F1','Q12-F2','Q12-LE','Q12-TeV'/
62024  DATA (chnams(i),i=300,309)/
62025  & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
62026  5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
62027  DATA (chnams(i),i=310,316)/
62028  & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
62029  & 'NOCR-Pro','Old-Pro','ATLAS MC08'/
62030  DATA (chnams(i),i=320,329)/
62031  & 'Perugia 0','Perugia HARD','Perugia SOFT',
62032  & 'Perugia 3','Perugia NOCR','Perugia LO*',
62033  & 'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/
62034  DATA (chnams(i),i=330,349)/
62035  & 'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*',
62036  & 'Pro-PT6',' ',' ','Pro-PT**',
62037  4 'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP',
62038  4 'AMBT2B-CT6L1','AUET2B-CT6L1','AUET2B-CT66','AUET2B-CT10',
62039  4 'AUET2B-NN21'/
62040  DATA (chnams(i),i=350,359)/
62041  & 'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi',
62042  & 'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1',
62043  & 'P2011 T16','P2011 T32','P2011 Tevatron'/
62044  DATA (chnams(i),i=360,369)/
62045  & 'S Global','S 7000','S 1960','S 1800',
62046  & 'S 900','S 630', 4*' '/
62047  DATA (chnams(i),i=370,379)/
62048  & 'P12','P12-radHi','P12-radLo','P12-mpiHi','P12-loCR',
62049  & 'P12-noCR','P12-FL','P12-FT','P12-M8LO','P12-LO**'/
62050  DATA (chnams(i),i=380,399)/
62051  & 'P12-val0','P12-ueHi','P12-ueLo','P12-IBK',6*' ',
62052  9 'Innsbruck C5LO','Innsbruck C6LO','Innsbruck M8LO',
62053  & 'Innsbruck C66NLO','Innsbruck C10NLO',
62054  & 'Innsbruck M8NLO','Innsbruck LO*','Innsbruck LO**',
62055  & 'Innsbruck C9MC2',
62056  & ' '/
62057  DATA (chnams(i),i=200,229)/
62058  & 'IM Tune 1','Tune APT',8*' ',
62059  & ' ','Tune APT-Pro',8*' ',
62060  & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
62061  DATA (chnams(i),i=400,409)/
62062  & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
62063  DATA (chmstj(i),i=11,20)/
62064  & 'HAD choice of fragmentation function(s)',4*' ',
62065  & 'HAD treatment of small-mass systems',4*' '/
62066  DATA (chmstj(i),i=41,50)/
62067  & 'FSR type (Q2 or pT) for old framework',9*' '/
62068  DATA (chmstp(i),i=1,10)/
62069  & 2*' ','INT switch for choice of LambdaQCD',7*' '/
62070  DATA (chmstp(i),i=31,40)/
62071  & 2*' ','"K" switch for K-factor on/off & type',7*' '/
62072  DATA (chmstp(i),i=51,100)/
62073  5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
62074  6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
62075  6 'ISR coherence option for 1st emission',
62076  6 'ISR phase space choice & ME corrections',' ',
62077  7 'ISR IR regularization scheme',' ',
62078  7 'IFSR scheme for non-decay FSR',8*' ',
62079  8 'UE model',
62080  8 'UE hadron transverse mass distribution',5*' ',
62081  8 'BR composite scheme','BR color scheme',
62082  9 'BR primordial kT compensation',
62083  9 'BR primordial kT distribution',
62084  9 'BR energy partitioning scheme',2*' ',
62085  9 'FSI color (re-)connection model',5*' '/
62086  DATA (chparp(i),i=1,10)/
62087  & 'ME/UE LambdaQCD',9*' '/
62088  DATA (chparp(i),i=31,40)/
62089  & ' ','"K" K-factor',8*' '/
62090  DATA (chparp(i),i=61,100)/
62091  6 'ISR LambdaQCD','ISR IR cutoff',' ',
62092  6 'ISR renormalization scale prefactor',
62093  6 2*' ','ISR Q2max factor',3*' ',
62094  7 'IFSR Q2max factor in non-s-channel procs',
62095  7 'IFSR LambdaQCD (outside resonance decays)',4*' ',
62096  7 'FSI color reco high-pT damping strength',
62097  7 'FSI color reconnection strength',
62098  7 'BR composite x enhancement','BR breakup suppression',
62099  8 2*'UE IR cutoff at reference ecm',
62100  8 2*'UE mass distribution parameter',
62101  8 'UE gg color correlated fraction','UE total gg fraction',
62102  8 'UE qq enhancement at low pT','UE qq enh scale / pT0',
62103  8 'UE IR cutoff reference ecm',
62104  8 'UE IR cutoff ecm scaling power',
62105  9 'BR primordial kT width <|kT|>',' ',
62106  9 'BR primordial kT UV cutoff',7*' '/
62107  DATA (chparj(i),i=1,30)/
62108  & 'HAD diquark suppression','HAD strangeness suppression',
62109  & 'HAD strange diquark suppression',
62110  & 'HAD vector diquark suppression','HAD P(popcorn)',
62111  & 'HAD extra popcorn B(s)-M-B(s) supp',
62112  & 'HAD extra popcorn B-M(s)-B supp',
62113  & 3*' ',
62114  1 'HAD P(vector meson), u and d only',
62115  1 'HAD P(vector meson), contains s',
62116  1 'HAD P(vector meson), heavy quarks',
62117  1 'HAD P(L=1;S=0,J=1)','HAD P(L=1;S=1,J=0)',
62118  1 'HAD P(L=1;S=1,J=1)','HAD P(L=1;S=1,J=2)',
62119  1 'HAD extra spin-3/2 baryon supp',
62120  1 'HAD extra leading-baryon supp',' ',
62121  2 'HAD fragmentation pT',' ',' ',' ',
62122  2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
62123  DATA (chparj(i),i=41,90)/
62124  4 'HAD string parameter a(Meson)','HAD string parameter b',
62125  4 2*' ','HAD string a(Baryon)-a(Meson)',
62126  4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
62127  4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
62128  5 3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ',
62129  6 10*' ',10*' ',
62130  8 'FSR LambdaQCD (inside resonance decays)',
62131  & 'FSR IR cutoff',8*' '/
62132  DATA (chmstu(i),i=111,120)/
62133  1 ' ','INT n(flavors) for LambdaQCD',8*' '/
62134  DATA (chparu(i),i=111,120)/
62135  1 ' ','INT LambdaQCD',8*' '/
62136 
62137 C...1) Shorthand notation
62138  m13=mstu(13)
62139  m11=mstu(11)
62140  IF (mytune.LE.mxtuns.AND.mytune.GE.0) THEN
62141  chname=chnams(mytune)
62142  IF (mytune.EQ.0) goto 9999
62143  ELSE
62144  CALL pyerrm(9,'(PYTUNE:) Tune number > max. Using defaults.')
62145  goto 9999
62146  ENDIF
62147 
62148 C... 2) Hello World
62149  IF (m13.GE.1) WRITE(m11,5000) chdoc
62150 
62151 C... Hardcode some defaults
62152 C... Get Lambda from PDF
62153  mstp(3) = 2
62154 C... CTEQ5L1 PDFs
62155  mstp(52) = 1
62156  mstp(51) = 7
62157 C... No K-factor
62158  mstp(33) = 0
62159 C... Low-pT qq enhancement factor and pT/pT0 ratio
62160  parp(87) = 0.7d0
62161  parp(88) = 0.5d0
62162 C... Hard-initialize L=1 meson rates to old default: 0.0
62163  parj(14) = 0d0
62164  parj(15) = 0d0
62165  parj(16) = 0d0
62166  parj(17) = 0d0
62167 
62168 C... 3) Tune parameters
62169  itune = mytune
62170 
62171 C=======================================================================
62172 C...ATLAS MC08
62173 
62174  IF (itune.EQ.316) THEN
62175 
62176  IF (m13.GE.1) WRITE(m11,5010) itune, chname
62177  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
62178  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62179  & ' with tune.')
62180  ENDIF
62181 
62182 C...First set some explicit defaults from 6.4.20
62183 C...# Old defaults
62184  mstj(11) = 4
62185 C...# Old default flavour parameters
62186  parj(1) = 0.1
62187  parj(2) = 0.3
62188  parj(3) = 0.40
62189  parj(4) = 0.05
62190  parj(11) = 0.5
62191  parj(12) = 0.6
62192  parj(21) = 0.36
62193  parj(41) = 0.30
62194  parj(42) = 0.58
62195  parj(46) = 1.0
62196  parj(82) = 1.0
62197 
62198 C...PDFs: CTEQ6L1 for 326
62199  mstp(52)=2
62200  mstp(51)=10042
62201 
62202 C...UE and ISR switches
62203  mstp(81)=21
62204  mstp(82)=4
62205  mstp(70)=0
62206  mstp(72)=1
62207 
62208 C...CR:
62209  mstp(95)=2
62210  parp(78)=0.3
62211  parp(77)=0.0
62212  parp(80)=0.1
62213 
62214 C...Primordial kT
62215  parp(91)=2.0d0
62216  parp(93)=5.0d0
62217 
62218 C...MPI:
62219  parp(82)=2.1
62220  parp(83)=0.8
62221  parp(84)=0.7
62222  parp(89)=1800.0
62223  parp(90)=0.16
62224 
62225 C...FSR inside resonance decays
62226  parj(81)=0.29
62227 
62228 C...Fragmentation (warning: uses Peterson)
62229  mstj(11)=3
62230  parj(54)=-0.07
62231  parj(55)=-0.006
62232 
62233  IF (m13.GE.1) THEN
62234  ch60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62235  WRITE(m11,5030) ch60
62236  ch60='Physics model: '//
62237  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62238  WRITE(m11,5030) ch60
62239  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
62240  WRITE(m11,5030) ch60
62241 
62242 C...Output
62243  WRITE(m11,5030) ' '
62244  WRITE(m11,5040) 51, mstp(51), chmstp(51)
62245  WRITE(m11,5040) 52, mstp(52), chmstp(52)
62246  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
62247  IF (mstp(70).EQ.0) THEN
62248  WRITE(m11,5050) 62, parp(62), chparp(62)
62249  ENDIF
62250  WRITE(m11,5040) 64, mstp(64), chmstp(64)
62251  WRITE(m11,5050) 64, parp(64), chparp(64)
62252  WRITE(m11,5040) 67, mstp(67), chmstp(67)
62253  WRITE(m11,5050) 67, parp(67), chparp(67)
62254  WRITE(m11,5040) 68, mstp(68), chmstp(68)
62255  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62256  WRITE(m11,5030) ch60
62257  WRITE(m11,5040) 70, mstp(70), chmstp(70)
62258  WRITE(m11,5040) 72, mstp(72), chmstp(72)
62259  WRITE(m11,5050) 71, parp(71), chparp(71)
62260  WRITE(m11,5060) 81, parj(81), chparj(81)
62261  WRITE(m11,5060) 82, parj(82), chparj(82)
62262  WRITE(m11,5040) 33, mstp(33), chmstp(33)
62263  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62264  WRITE(m11,5050) 82, parp(82), chparp(82)
62265  WRITE(m11,5050) 89, parp(89), chparp(89)
62266  WRITE(m11,5050) 90, parp(90), chparp(90)
62267  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62268  WRITE(m11,5050) 83, parp(83), chparp(83)
62269  WRITE(m11,5050) 84, parp(84), chparp(84)
62270  IF (mstp(82).GE.2) THEN
62271  WRITE(m11,5050) 87, parp(87), chparp(87)
62272  IF (parp(87).GE.0d0)
62273  & WRITE(m11,5050) 88, parp(88), chparp(88)
62274  ENDIF
62275  WRITE(m11,5040) 88, mstp(88), chmstp(88)
62276  WRITE(m11,5040) 89, mstp(89), chmstp(89)
62277  WRITE(m11,5050) 79, parp(79), chparp(79)
62278  WRITE(m11,5050) 80, parp(80), chparp(80)
62279  WRITE(m11,5040) 91, mstp(91), chmstp(91)
62280  WRITE(m11,5050) 91, parp(91), chparp(91)
62281  WRITE(m11,5050) 93, parp(93), chparp(93)
62282  WRITE(m11,5040) 95, mstp(95), chmstp(95)
62283  IF (mstp(95).GE.1) THEN
62284  WRITE(m11,5050) 78, parp(78), chparp(78)
62285  IF (mstp(95).GE.2) WRITE(m11,5050) 77, parp(77), chparp(77)
62286  ENDIF
62287 
62288  ENDIF
62289 
62290 C=======================================================================
62291 C...ATLAS MC09, MC09c, AMBT1, AMBT2B, AUET2B + NLO PDF vars
62292 C...CMS Z1 (R. Field), Z1-LEP
62293 
62294  ELSEIF (itune.EQ.330.OR.itune.EQ.331.OR.itune.EQ.340.OR.
62295  & itune.GE.341.AND.itune.LE.349) THEN
62296 
62297  IF (m13.GE.1) WRITE(m11,5010) itune, chname
62298  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
62299  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62300  & ' with tune.')
62301  ENDIF
62302 
62303 C...pT-ordered shower default for everything
62304  mstj(41) = 12
62305 
62306 C...FSR inside resonance decays, base value (modified by individual tunes)
62307  parj(81) = 0.29
62308 
62309 C...First set some explicit defaults from 6.4.20
62310  IF (itune.LE.341.OR.itune.EQ.343) THEN
62311 C... # Old defaults
62312  mstj(11) = 4
62313 C...# Old default flavour parameters
62314  parj(1) = 0.1
62315  parj(2) = 0.3
62316  parj(3) = 0.40
62317  parj(4) = 0.05
62318  parj(11) = 0.5
62319  parj(12) = 0.6
62320  parj(21) = 0.36
62321  parj(41) = 0.30
62322  parj(42) = 0.58
62323  parj(46) = 1.0
62324  parj(82) = 1.0
62325  ELSE IF (itune.LE.344) THEN
62326 C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia
62327  parj( 1) = 0.08d0
62328  parj( 2) = 0.21d0
62329  parj( 3) = 0.94
62330  parj( 4) = 0.04d0
62331  parj(11) = 0.35d0
62332  parj(12) = 0.35d0
62333  parj(13) = 0.54
62334  parj(25) = 0.63
62335  parj(26) = 0.12
62336 C...# Switch on Bowler:
62337  mstj(11) = 5
62338 C...# Fragmentation
62339  parj(21) = 0.34d0
62340  parj(41) = 0.35d0
62341  parj(42) = 0.80d0
62342  parj(47) = 1.0
62343  parj(81) = 0.26d0
62344  parj(82) = 1.0d0
62345  ELSE
62346 C... A*T2 tunes, from ATL-PHYS-PUB-2011-008
62347  parj( 1) = 0.073
62348  parj( 2) = 0.202
62349  parj( 3) = 0.950
62350  parj( 4) = 0.033
62351  parj(11) = 0.309
62352  parj(12) = 0.402
62353  parj(13) = 0.544
62354  parj(25) = 0.628
62355  parj(26) = 0.129
62356 C...# Switch on Bowler:
62357  mstj(11) = 5
62358 C... # Fragmentation
62359  parj(21) = 0.30
62360  parj(41) = 0.368
62361  parj(42) = 1.004
62362  parj(47) = 0.873
62363  parj(81) = 0.256
62364  parj(82) = 0.830
62365  ENDIF
62366 
62367 C...Default scales and alphaS choices
62368  IF (itune.GE.345) THEN
62369  mstp(3) = 1
62370  paru(112) = 0.192
62371  parp(1) = 0.192
62372  parp(61) = 0.192
62373  ENDIF
62374 
62375 C...PDFs: MRST LO*
62376  mstp(52) = 2
62377  mstp(51) = 20650
62378  IF (itune.EQ.341.OR.itune.EQ.342) THEN
62379 C...Z1 uses CTEQ5L
62380  mstp(52) = 1
62381  mstp(51) = 7
62382  ELSEIF (itune.EQ.343.OR.itune.EQ.344) THEN
62383 C...Z2 uses CTEQ6L
62384  mstp(52) = 2
62385  mstp(51) = 10042
62386  ELSEIF (itune.EQ.345.OR.itune.EQ.346) THEN
62387 C...AMBT2B, AUET2B use CTEQ6L1
62388  mstp(52) = 2
62389  mstp(51) = 10042
62390  ELSEIF (itune.EQ.347) THEN
62391 C...AUET2B-CT66 uses CTEQ66 NLO PDFs
62392  mstp(52) = 2
62393  mstp(51) = 10550
62394  ELSEIF (itune.EQ.348) THEN
62395 C...AUET2B-CT10 uses CTEQ10 NLO PDFs
62396  mstp(52) = 2
62397  mstp(51) = 10800
62398  ELSEIF (itune.EQ.349) THEN
62399 C...AUET2B-NN21 uses NNPDF 2.1 NLO PDF
62400  mstp(52) = 2
62401  mstp(51) = 192800
62402  ENDIF
62403 
62404 C...UE and ISR switches
62405  mstp(81) = 21
62406  mstp(82) = 4
62407  mstp(70) = 0
62408  mstp(72) = 1
62409 
62410 C...CR:
62411  mstp(95) = 6
62412  parp(78) = 0.3
62413  parp(77) = 0.0
62414  parp(80) = 0.1
62415  IF (itune.EQ.331) THEN
62416  parp(78) = 0.224
62417  ELSEIF (itune.EQ.340) THEN
62418 C...AMBT1
62419  parp(77) = 1.016d0
62420  parp(78) = 0.538d0
62421  ELSEIF (itune.GE.341.AND.itune.LE.344) THEN
62422 C...Z1 and Z2 use the AMBT1 CR values
62423  parp(77) = 1.016d0
62424  parp(78) = 0.538d0
62425  ELSEIF (itune.EQ.345) THEN
62426 C...AMBT2B
62427  parp(77) = 0.357d0
62428  parp(78) = 0.235d0
62429  ELSEIF (itune.EQ.346) THEN
62430 C...AUET2B
62431  parp(77) = 0.491d0
62432  parp(78) = 0.311d0
62433  ELSEIF (itune.EQ.347) THEN
62434 C...AUET2B-CT66
62435  parp(77) = 0.505d0
62436  parp(78) = 0.385d0
62437  ELSEIF (itune.EQ.348) THEN
62438 C...AUET2B-CT10
62439  parp(77) = 0.125d0
62440  parp(78) = 0.309d0
62441  ELSEIF (itune.EQ.349) THEN
62442 C...AUET2B-NN21
62443  parp(77) = 0.498d0
62444  parp(78) = 0.354d0
62445  ENDIF
62446 
62447 C...MPI:
62448  parp(82) = 2.3
62449  parp(83) = 0.8
62450  parp(84) = 0.7
62451  parp(89) = 1800.0
62452  parp(90) = 0.25
62453  IF (itune.EQ.331) THEN
62454  parp(82) = 2.315
62455  parp(90) = 0.2487
62456  ELSEIF (itune.EQ.340) THEN
62457  parp(82) = 2.292d0
62458  parp(83) = 0.356d0
62459  parp(84) = 0.651
62460  parp(90) = 0.25d0
62461  ELSEIF (itune.EQ.341.OR.itune.EQ.342) THEN
62462  parp(82) = 1.932d0
62463  parp(83) = 0.356d0
62464  parp(84) = 0.651
62465  parp(90) = 0.275d0
62466  ELSEIF (itune.EQ.343.OR.itune.EQ.344) THEN
62467  parp(82) = 1.832d0
62468  parp(83) = 0.356d0
62469  parp(84) = 0.651
62470  parp(90) = 0.275d0
62471  ELSEIF (itune.EQ.345) THEN
62472  parp(82) = 2.34
62473  parp(83) = 0.356
62474  parp(84) = 0.605
62475  parp(90) = 0.246
62476  ELSEIF (itune.EQ.346) THEN
62477  parp(82) = 2.26
62478  parp(83) = 0.356
62479  parp(84) = 0.443
62480  parp(90) = 0.249
62481  ELSEIF (itune.EQ.347) THEN
62482  parp(82) = 1.87
62483  parp(83) = 0.356
62484  parp(84) = 0.561
62485  parp(90) = 0.189
62486  ELSEIF (itune.EQ.348) THEN
62487  parp(82) = 1.89
62488  parp(83) = 0.356
62489  parp(84) = 0.415
62490  parp(90) = 0.182
62491  ELSEIF (itune.EQ.349) THEN
62492  parp(82) = 1.86
62493  parp(83) = 0.356
62494  parp(84) = 0.588
62495  parp(90) = 0.177
62496  ENDIF
62497 
62498 C...Primordial kT
62499  parp(91) = 2.0d0
62500  parp(93) = 5d0
62501  IF (itune.GE.340) THEN
62502  parp(93) = 10d0
62503  ENDIF
62504  IF (itune.GE.345) THEN
62505  parp(91) = 2.0
62506  ENDIF
62507 
62508 C...ISR
62509  IF (itune.EQ.345.OR.itune.EQ.346) THEN
62510  mstp(64) = 2
62511  parp(62) = 1.13
62512  parp(64) = 0.68
62513  parp(67) = 1.0
62514  ELSE IF (itune.EQ.347) THEN
62515  mstp(64) = 2
62516  parp(62) = 0.946
62517  parp(64) = 1.032
62518  parp(67) = 1.0
62519  ELSE IF (itune.EQ.348) THEN
62520  mstp(64) = 2
62521  parp(62) = 0.312
62522  parp(64) = 0.939
62523  parp(67) = 1.0
62524  ELSE IF (itune.EQ.349) THEN
62525  mstp(64) = 2
62526  parp(62) = 1.246
62527  parp(64) = 0.771
62528  parp(67) = 1.0
62529  ELSE IF (itune.GE.340) THEN
62530  parp(62) = 1.025
62531  ENDIF
62532 
62533 C...FSR off ISR (LambdaQCD) for A*ET2B tunes
62534  IF (itune.GE.345) THEN
62535  mstp(72) = 2
62536  parp(72) = 0.527
62537  IF (itune.EQ.348) THEN
62538  parp(72) = 0.537
62539  ENDIF
62540  ENDIF
62541 
62542  IF (m13.GE.1) THEN
62543  IF (itune.LT.340) THEN
62544  ch60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62545  ELSEIF (itune.EQ.340) THEN
62546  ch60='Tuned by ATLAS, ATLAS-CONF-2010-031'
62547  ELSEIF (itune.EQ.341) THEN
62548  ch60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62549  WRITE(m11,5030) ch60
62550  ch60='Z1 variation tuned by R. D. Field (CMS)'
62551  ELSEIF (itune.EQ.342) THEN
62552  ch60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62553  WRITE(m11,5030) ch60
62554  ch60='Z1 variation retuned by R. D. Field (CMS)'
62555  WRITE(m11,5030) ch60
62556  ch60='Z1-LEP variation retuned by Professor / P. Skands'
62557  ELSEIF (itune.EQ.343) THEN
62558  ch60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62559  WRITE(m11,5030) ch60
62560  ch60='Z2 variation retuned by R. D. Field (CMS)'
62561  ELSEIF (itune.EQ.344) THEN
62562  ch60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62563  WRITE(m11,5030) ch60
62564  ch60='Z2 variation retuned by R. D. Field (CMS)'
62565  WRITE(m11,5030) ch60
62566  ch60='Z2-LEP variation retuned by Professor / P. Skands'
62567  ELSEIF (itune.EQ.345.OR.itune.EQ.346) THEN
62568  ch60='A*T2B tunes by ATLAS, ATL-PHYS-PUB-2011-009'
62569  ELSEIF (itune.GE.347) THEN
62570  ch60='A*T2B-NLO tunes by ATLAS, ATL-PHYS-PUB-2011-014'
62571  WRITE(m11,5030) ch60
62572  ch60='Warning: NLO PDFs are NOT recommended!'
62573  ENDIF
62574  WRITE(m11,5030) ch60
62575  ch60='Physics Model: '//
62576  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62577  WRITE(m11,5030) ch60
62578  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
62579  WRITE(m11,5030) ch60
62580 
62581 C...Output
62582  WRITE(m11,5030) ' '
62583  WRITE(m11,5040) 51, mstp(51), chmstp(51)
62584  WRITE(m11,5040) 52, mstp(52), chmstp(52)
62585  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
62586  IF (mstp(3).EQ.1) THEN
62587  WRITE(m11,6100) 112, mstu(112), chmstu(112)
62588  WRITE(m11,6110) 112, paru(112), chparu(112)
62589  WRITE(m11,5050) 1, parp(1) , chparp( 1)
62590  ENDIF
62591  WRITE(m11,5060) 81, parj(81), chparj(81)
62592  IF (mstp(3).EQ.1) THEN
62593  WRITE(m11,5050) 72, parp(72) , chparp( 72)
62594  WRITE(m11,5050) 61, parp(61) , chparp( 61)
62595  ENDIF
62596  WRITE(m11,5040) 64, mstp(64), chmstp(64)
62597  WRITE(m11,5050) 64, parp(64), chparp(64)
62598  WRITE(m11,5040) 67, mstp(67), chmstp(67)
62599  WRITE(m11,5050) 67, parp(67), chparp(67)
62600  WRITE(m11,5040) 68, mstp(68), chmstp(68)
62601  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62602  WRITE(m11,5030) ch60
62603  WRITE(m11,5040) 70, mstp(70), chmstp(70)
62604  IF (mstp(70).EQ.0) THEN
62605  WRITE(m11,5050) 62, parp(62), chparp(62)
62606  ENDIF
62607  WRITE(m11,5040) 72, mstp(72), chmstp(72)
62608  WRITE(m11,5050) 71, parp(71), chparp(71)
62609  WRITE(m11,5050) 72, parp(72), chparp(72)
62610  WRITE(m11,5060) 82, parj(82), chparj(82)
62611  WRITE(m11,5040) 33, mstp(33), chmstp(33)
62612  WRITE(m11,5040) 81, mstp(81), chmstp(81)
62613  WRITE(m11,5050) 82, parp(82), chparp(82)
62614  WRITE(m11,5050) 89, parp(89), chparp(89)
62615  WRITE(m11,5050) 90, parp(90), chparp(90)
62616  WRITE(m11,5040) 82, mstp(82), chmstp(82)
62617  WRITE(m11,5050) 83, parp(83), chparp(83)
62618  WRITE(m11,5050) 84, parp(84), chparp(84)
62619  IF (mstp(82).GE.2) THEN
62620  WRITE(m11,5050) 87, parp(87), chparp(87)
62621  IF (parp(87).GE.0d0)
62622  & WRITE(m11,5050) 88, parp(88), chparp(88)
62623  ENDIF
62624  WRITE(m11,5040) 88, mstp(88), chmstp(88)
62625  WRITE(m11,5040) 89, mstp(89), chmstp(89)
62626  WRITE(m11,5050) 79, parp(79), chparp(79)
62627  WRITE(m11,5050) 80, parp(80), chparp(80)
62628  WRITE(m11,5040) 91, mstp(91), chmstp(91)
62629  WRITE(m11,5050) 91, parp(91), chparp(91)
62630  WRITE(m11,5050) 93, parp(93), chparp(93)
62631  WRITE(m11,5040) 95, mstp(95), chmstp(95)
62632  IF (mstp(95).GE.1) THEN
62633  WRITE(m11,5050) 78, parp(78), chparp(78)
62634  IF (mstp(95).GE.2) WRITE(m11,5050) 77, parp(77), chparp(77)
62635  ENDIF
62636 
62637  ENDIF
62638 
62639 C=======================================================================
62640 C...S0, S1, S2, S0A, NOCR, Rap,
62641 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
62642 C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K
62643 C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT**
62644 C...Perugia 2011 (incl variations)
62645 C...Schulz-Skands tunes
62646  ELSEIF ((itune.GE.300.AND.itune.LE.305)
62647  & .OR.(itune.GE.310.AND.itune.LE.315)
62648  & .OR.(itune.GE.320.AND.itune.LE.329)
62649  & .OR.(itune.GE.334.AND.itune.LE.336).OR.itune.EQ.339
62650  & .OR.(itune.GE.350.AND.itune.LE.389)) THEN
62651  IF (m13.GE.1) WRITE(m11,5010) itune, chname
62652  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
62653  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62654  & ' with tune.')
62655  ELSEIF(itune.GE.320.AND.itune.LE.339.AND.itune.NE.324.AND.
62656  & itune.NE.334.AND.
62657  & (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.419)))
62658  & THEN
62659  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62660  & ' with tune.')
62661  ELSEIF((itune.EQ.327.OR.itune.EQ.328.OR.itune.GE.350).AND.
62662  & (mstp(181).LE.5.OR.
62663  & (mstp(181).EQ.6.AND.mstp(182).LE.422)))
62664  & THEN
62665  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62666  & ' with tune.')
62667  ENDIF
62668 
62669 C...Use 327 as base tune for 350-359 and 370-379 (Perugia 2011 and 2012)
62670  itunsv = itune
62671  IF (itune.GE.350.AND.itune.LE.359) itune = 327
62672  IF (itune.GE.370.AND.itune.LE.389) itune = 327
62673 C...Use 320 as base tune for 360+ (Schulz-Skands)
62674  IF (itune.GE.360) itune = 320
62675 
62676 C...HAD: Use Professor's LEP pars if ITUNE >= 310
62677 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
62678  IF (itune.LT.310) THEN
62679 C...# Old defaults
62680  mstj(11) = 4
62681 C...# Old default flavour parameters
62682  parj(1) = 0.1
62683  parj(2) = 0.3
62684  parj(3) = 0.40
62685  parj(4) = 0.05
62686  parj(11) = 0.5
62687  parj(12) = 0.6
62688  parj(21) = 0.36
62689  parj(41) = 0.30
62690  parj(42) = 0.58
62691  parj(46) = 1.0
62692  parj(82) = 1.0
62693 
62694  ELSEIF (itune.GE.310) THEN
62695 C...# Tuned flavour parameters:
62696  parj(1) = 0.073
62697  parj(2) = 0.2
62698  parj(3) = 0.94
62699  parj(4) = 0.032
62700  parj(11) = 0.31
62701  parj(12) = 0.4
62702  parj(13) = 0.54
62703  parj(25) = 0.63
62704  parj(26) = 0.12
62705 C...# Always use pT-ordered shower:
62706  mstj(41) = 12
62707 C...# Switch on Bowler:
62708  mstj(11) = 5
62709 C...# Fragmentation
62710  parj(21) = 0.313
62711  parj(41) = 0.49
62712  parj(42) = 1.2
62713  parj(47) = 1.0
62714  parj(81) = 0.257
62715  parj(82) = 0.8
62716 
62717 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
62718  IF (itune.EQ.321) parj(21) = 0.34d0
62719  IF (itune.EQ.322) parj(21) = 0.28d0
62720 
62721 C...HAD: P-2010 and P-K use different strangeness parameters
62722 C... indicated by LEP and RHIC yields.
62723 C...(only 5% different from Professor values, so should be within acceptable
62724 C...theoretical uncertainty range)
62725 C...(No attempt made to retune other flavor parameters post facto)
62726  IF (itune.EQ.327.OR.itune.EQ.328.OR.itune.EQ.334) THEN
62727  parj( 1) = 0.08d0
62728  parj( 2) = 0.21d0
62729  parj( 4) = 0.04d0
62730  parj(11) = 0.35d0
62731  parj(12) = 0.35d0
62732  parj(21) = 0.36d0
62733  parj(41) = 0.35d0
62734  parj(42) = 0.90d0
62735  parj(81) = 0.26d0
62736  parj(82) = 1.0d0
62737  ENDIF
62738  ENDIF
62739 
62740 C...Remove middle digit now for Professor variants, since identical pars
62741  ituneb=itune
62742  IF (itune.GE.310.AND.itune.LE.319) THEN
62743  ituneb=(itune/100)*100+mod(itune,10)
62744  ENDIF
62745 
62746 C...PDFs: all use CTEQ5L as starting point
62747  mstp(52) = 1
62748  mstp(51) = 7
62749  IF (itune.EQ.325.OR.itune.EQ.335) THEN
62750 C...MRST LO* for 325 and 335
62751  mstp(52) = 2
62752  mstp(51) = 20650
62753  ELSEIF (itune.EQ.326.OR.itune.EQ.336) THEN
62754 C...CTEQ6L1 for 326 and 336
62755  mstp(52) = 2
62756  mstp(51) = 10042
62757  ELSEIF (itune.EQ.339) THEN
62758 C...MRST LO** for 339
62759  mstp(52) = 2
62760  mstp(51) = 20651
62761  ENDIF
62762 
62763 C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF
62764  mstp(3) = 2
62765  IF (itune.EQ.327.OR.itune.EQ.328.OR.itune.EQ.334) THEN
62766  mstp(3) = 1
62767 C...Hardcode CTEQ5L values for ME and ISR
62768  mstu(112) = 4
62769  paru(112) = 0.192d0
62770  parp(61) = 0.192d0
62771  parp( 1) = 0.192d0
62772 C...but use LEP value also for non-res FSR
62773  parp(72) = 0.260d0
62774  ENDIF
62775 
62776 C...ISR: use Lambda_MSbar with default scale for S0(A)
62777  mstp(64) = 2
62778  parp(64) = 1d0
62779  IF (itune.EQ.320.OR.itune.EQ.323.OR.itune.EQ.324.OR.itune.EQ.334
62780  & .OR.itune.EQ.326.OR.itune.EQ.327.OR.itune.EQ.328) THEN
62781 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
62782  mstp(64) = 3
62783  parp(64) = 1d0
62784  ELSEIF (itune.EQ.321) THEN
62785 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
62786  mstp(64) = 3
62787  parp(64) = 0.25d0
62788  ELSEIF (itune.EQ.322) THEN
62789 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
62790  mstp(64) = 2
62791  parp(64) = 2d0
62792  ELSEIF (itune.EQ.325) THEN
62793 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
62794  mstp(64) = 3
62795  parp(64) = 2d0
62796  ELSEIF (itune.EQ.329.OR.itune.EQ.335.OR.itune.EQ.336.OR.
62797  & itune.EQ.339) THEN
62798 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
62799  mstp(64) = 2
62800  parp(64) = 1.3d0
62801  IF (itune.EQ.335) parp(64) = 0.92d0
62802  IF (itune.EQ.336) parp(64) = 0.89d0
62803  IF (itune.EQ.339) parp(64) = 0.97d0
62804  ENDIF
62805 
62806 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
62807  mstp(67) = 2
62808  parp(67) = 4d0
62809 C...Perugia tunes have stronger suppression, except HARD
62810  IF ((itune.GE.320.AND.itune.LE.328).OR.itune.EQ.334) THEN
62811  parp(67) = 1d0
62812  IF (itune.EQ.321) parp(67) = 4d0
62813  IF (itune.EQ.322) parp(67) = 0.25d0
62814  ENDIF
62815 
62816 C...ISR IR cutoff type and FSR off ISR setting:
62817 C...Smooth ISR, low FSR-off-ISR
62818  mstp(70) = 2
62819  mstp(72) = 0
62820  IF (ituneb.EQ.301) THEN
62821 C...S1, S1-Pro: sharp ISR, high FSR
62822  mstp(70) = 0
62823  mstp(72) = 1
62824  ELSEIF (itune.EQ.320.OR.itune.EQ.324.OR.itune.EQ.326
62825  & .OR.itune.EQ.325) THEN
62826 C...Perugia default is smooth ISR, high FSR-off-ISR
62827  mstp(70) = 2
62828  mstp(72) = 1
62829  ELSEIF (itune.EQ.321) THEN
62830 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
62831  mstp(70) = 0
62832  parp(62) = 1.25d0
62833  mstp(72) = 1
62834  ELSEIF (itune.EQ.322) THEN
62835 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
62836  mstp(70) = 1
62837  parp(81) = 1.5d0
62838  mstp(72) = 0
62839  ELSEIF (itune.EQ.323) THEN
62840 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62841  mstp(70) = 0
62842  parp(62) = 1.25d0
62843  mstp(72) = 2
62844  ELSEIF (itune.EQ.327.OR.itune.EQ.328.OR.itune.EQ.334) THEN
62845 C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62846  mstp(70) = 2
62847  mstp(72) = 2
62848  ENDIF
62849 
62850 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
62851 C...by Professor tunes (with HARD and SOFT variations)
62852  parp(71) = 4d0
62853  IF ((itune.GE.320.AND.itune.LE.328).OR.itune.EQ.334) THEN
62854  parp(71) = 2d0
62855  IF (itune.EQ.321) parp(71) = 4d0
62856  IF (itune.EQ.322) parp(71) = 1d0
62857  ENDIF
62858  IF (itune.EQ.329) parp(71) = 2d0
62859  IF (itune.EQ.335) parp(71) = 1.29d0
62860  IF (itune.EQ.336) parp(71) = 1.72d0
62861  IF (itune.EQ.339) parp(71) = 1.20d0
62862 
62863 C...FSR: Lambda_FSR scale (only if not using professor)
62864  IF (itune.LT.310) parj(81) = 0.23d0
62865  IF (itune.EQ.321) parj(81) = 0.30d0
62866  IF (itune.EQ.322) parj(81) = 0.20d0
62867 
62868 C...K-factor : only 328 uses a K-factor on the UE cross sections
62869  mstp(33) = 0
62870  IF (itune.EQ.328) THEN
62871  mstp(33) = 10
62872  parp(32) = 1.5
62873  ENDIF
62874 C...UE on, new model
62875  mstp(81) = 21
62876 
62877 C...UE: hadron-hadron overlap profile (expOfPow for all)
62878  mstp(82) = 5
62879 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
62880  parp(83) = 1.6d0
62881  IF (ituneb.EQ.301) parp(83) = 1.4d0
62882  IF (ituneb.EQ.302) parp(83) = 1.2d0
62883 C...NOCR variants have very smooth distributions
62884  IF (ituneb.EQ.304) parp(83) = 1.8d0
62885  IF (ituneb.EQ.305) parp(83) = 2.0d0
62886  IF ((itune.GE.320.AND.itune.LE.328).OR.itune.EQ.334) THEN
62887 C...Perugia variants have slightly smoother profiles by default
62888 C...(to compensate for more tail by added radiation)
62889 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
62890  parp(83) = 1.7d0
62891  IF (itune.EQ.322) parp(83) = 1.5d0
62892  IF (itune.EQ.327) parp(83) = 1.5d0
62893  IF (itune.EQ.328) parp(83) = 1.5d0
62894 C...NOCR variants have smoother mass profiles
62895  IF (itune.EQ.324) parp(83) = 1.8d0
62896  IF (itune.EQ.334) parp(83) = 1.8d0
62897  ENDIF
62898 C...Professor-pT0 also has very smooth distribution
62899  IF (itune.EQ.329) parp(83) = 1.8
62900  IF (itune.EQ.335) parp(83) = 1.68
62901  IF (itune.EQ.336) parp(83) = 1.72
62902  IF (itune.EQ.339) parp(83) = 1.67
62903 
62904 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
62905  parp(82) = 1.85d0
62906  IF (ituneb.EQ.301) parp(82) = 2.1d0
62907  IF (ituneb.EQ.302) parp(82) = 1.9d0
62908  IF (ituneb.EQ.304) parp(82) = 2.05d0
62909  IF (ituneb.EQ.305) parp(82) = 1.9d0
62910  IF ((itune.GE.320.AND.itune.LE.328).OR.itune.EQ.334) THEN
62911 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
62912 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
62913 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
62914 C...slightly higher, due to increased activity.
62915  parp(82) = 2.0d0
62916  IF (itune.EQ.321) parp(82) = 2.3d0
62917  IF (itune.EQ.322) parp(82) = 1.9d0
62918  IF (itune.EQ.323) parp(82) = 2.2d0
62919  IF (itune.EQ.324) parp(82) = 1.95d0
62920  IF (itune.EQ.325) parp(82) = 2.2d0
62921  IF (itune.EQ.326) parp(82) = 1.95d0
62922  IF (itune.EQ.327) parp(82) = 2.05d0
62923  IF (itune.EQ.328) parp(82) = 2.45d0
62924  IF (itune.EQ.334) parp(82) = 2.15d0
62925  ENDIF
62926 C...Professor-pT0 maintains low pT0 vaue
62927  IF (itune.EQ.329) parp(82) = 1.85d0
62928  IF (itune.EQ.335) parp(82) = 2.10d0
62929  IF (itune.EQ.336) parp(82) = 1.83d0
62930  IF (itune.EQ.339) parp(82) = 2.28d0
62931 
62932 C...UE: IR cutoff reference energy and default energy scaling pace
62933  parp(89) = 1800d0
62934  parp(90) = 0.16d0
62935 C...S0A, S0A-Pro have tune A energy scaling
62936  IF (ituneb.EQ.303) parp(90) = 0.25d0
62937  IF ((itune.GE.320.AND.itune.LE.328).OR.itune.EQ.334) THEN
62938 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
62939  parp(90) = 0.26
62940  IF (itune.EQ.321) parp(90) = 0.30d0
62941  IF (itune.EQ.322) parp(90) = 0.24d0
62942  IF (itune.EQ.323) parp(90) = 0.32d0
62943  IF (itune.EQ.324) parp(90) = 0.24d0
62944 C...LO* and CTEQ6L1 tunes have slower energy scaling
62945  IF (itune.EQ.325) parp(90) = 0.23d0
62946  IF (itune.EQ.326) parp(90) = 0.22d0
62947  ENDIF
62948 C...Professor-pT0 has intermediate scaling
62949  IF (itune.EQ.329) parp(90) = 0.22d0
62950  IF (itune.EQ.335) parp(90) = 0.20d0
62951  IF (itune.EQ.336) parp(90) = 0.20d0
62952  IF (itune.EQ.339) parp(90) = 0.21d0
62953 
62954 C...BR: MPI initiator color connections rap-ordered by default
62955 C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered
62956  mstp(89) = 1
62957  IF (ituneb.EQ.304.OR.itune.EQ.324) mstp(89) = 2
62958  IF (itune.EQ.322) mstp(89) = 0
62959  IF (itune.EQ.327) mstp(89) = 0
62960  IF (itune.EQ.328) mstp(89) = 0
62961 
62962 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
62963  parp(80) = 0.01d0
62964  IF (itune.GE.320.AND.itune.LE.328) THEN
62965 C...Perugia tunes have more beam blowup by default
62966  parp(80) = 0.05d0
62967  IF (itune.EQ.321) parp(80) = 0.01
62968  IF (itune.EQ.323) parp(80) = 0.03
62969  IF (itune.EQ.324) parp(80) = 0.01
62970  IF (itune.EQ.327) parp(80) = 0.1
62971  IF (itune.EQ.328) parp(80) = 0.1
62972  ENDIF
62973 
62974 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
62975  mstp(88) = 0
62976  parp(79) = 2d0
62977  IF (ituneb.EQ.304) parp(79) = 3d0
62978  IF (itune.EQ.329) parp(79) = 1.18
62979  IF (itune.EQ.335) parp(79) = 1.11
62980  IF (itune.EQ.336) parp(79) = 1.10
62981  IF (itune.EQ.339) parp(79) = 3.69
62982 
62983 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
62984  mstp(91) = 1
62985  parp(91) = 2d0
62986  parp(93) = 10d0
62987 C...Perugia-HARD only uses 1.0 GeV
62988  IF (itune.EQ.321) parp(91) = 1.0d0
62989 C...Perugia-3 only uses 1.5 GeV
62990  IF (itune.EQ.323) parp(91) = 1.5d0
62991 C...Professor-pT0 uses 7-GeV cutoff
62992  IF (itune.EQ.329) parp(93) = 7.0
62993  IF (itune.EQ.335) THEN
62994  parp(91) = 2.15
62995  parp(93) = 6.79
62996  ELSEIF (itune.EQ.336) THEN
62997  parp(91) = 1.85
62998  parp(93) = 6.86
62999  ELSEIF (itune.EQ.339) THEN
63000  parp(91) = 2.11
63001  parp(93) = 5.08
63002  ENDIF
63003 
63004 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
63005  mstp(95) = 6
63006 C...S1, S1-Pro: use S1
63007  IF (ituneb.EQ.301) mstp(95) = 2
63008 C...S2, S2-Pro: use S2
63009  IF (ituneb.EQ.302) mstp(95) = 4
63010 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
63011  IF (itune.EQ.304.OR.itune.EQ.314.OR.itune.EQ.324.OR.
63012  & itune.EQ.334) mstp(95) = 0
63013 C..."Old" and "Old"-Pro: use old CR
63014  IF (ituneb.EQ.305) mstp(95) = 1
63015 C...Perugia 2010 and K use Paquis model
63016  IF (itune.EQ.327.OR.itune.EQ.328) mstp(95) = 8
63017 
63018 C...FSI: CR strength and high-pT dampening, default is S0
63019  parp(77) = 0d0
63020  IF (itune.LT.320.OR.itune.EQ.329.OR.itune.GE.335) THEN
63021  parp(78) = 0.2d0
63022  IF (ituneb.EQ.301) parp(78) = 0.35d0
63023  IF (ituneb.EQ.302) parp(78) = 0.15d0
63024  IF (ituneb.EQ.304) parp(78) = 0.0d0
63025  IF (ituneb.EQ.305) parp(78) = 1.0d0
63026  IF (itune.EQ.329) parp(78) = 0.17d0
63027  IF (itune.EQ.335) parp(78) = 0.14d0
63028  IF (itune.EQ.336) parp(78) = 0.17d0
63029  IF (itune.EQ.339) parp(78) = 0.13d0
63030  ELSE
63031 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
63032  parp(78) = 0.33
63033  parp(77) = 0.9d0
63034  IF (itune.EQ.321) THEN
63035 C...HARD has HIGH amount of CR
63036  parp(78) = 0.37d0
63037  parp(77) = 0.4d0
63038  ELSEIF (itune.EQ.322) THEN
63039 C...SOFT has LOW amount of CR
63040  parp(78) = 0.15d0
63041  parp(77) = 0.5d0
63042  ELSEIF (itune.EQ.323) THEN
63043 C...Scaling variant appears to need slightly more than default
63044  parp(78) = 0.35d0
63045  parp(77) = 0.6d0
63046  ELSEIF (itune.EQ.324.OR.itune.EQ.334) THEN
63047 C...NOCR has no CR
63048  parp(78) = 0d0
63049  parp(77) = 0d0
63050  ELSEIF (itune.EQ.327) THEN
63051 C...2010
63052  parp(78) = 0.035d0
63053  parp(77) = 1d0
63054  ELSEIF (itune.EQ.328) THEN
63055 C...K
63056  parp(78) = 0.033d0
63057  parp(77) = 1d0
63058  ENDIF
63059  ENDIF
63060 
63061 C================
63062 C...Perugia 2011 and 2012 tunes
63063 C...(written as modifications on top of Perugia 2010)
63064 C================
63065  IF ( (itunsv.GE.350.AND.itunsv.LE.359)
63066  & .OR.(itunsv.GE.370.AND.itunsv.LE.389) ) THEN
63067  itune = itunsv
63068 C... Scale setting for matching applications.
63069 C... Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity
63070 C... (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16)
63071  mstp(64) = 2
63072  mstu(112) = 5
63073 C... This sets the Lambda scale for ISR, IFSR, and FSR
63074  parp(61) = 0.26d0
63075  parp(72) = 0.26d0
63076  parj(81) = 0.26d0
63077 C... This sets the Lambda scale for QCD hard interactions (important for the
63078 C... UE dijet cross sections. Here we still use an MSbar value, rather than
63079 C... a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L
63080 C... value corresponds to a Lambda5 of 0.146 for comparison, so quite close.)
63081  parp(1) = 0.16d0
63082  paru(112) = 0.16d0
63083 C... For matching applications, PARP(71) and PARP(67) = 1
63084  parp(67) = 1d0
63085  parp(71) = 1d0
63086 C... Primordial kT: only use 1 GeV
63087  mstp(91) = 1
63088  parp(91) = 1d0
63089 C... ADDITIONAL LESSONS WRT PERUGIA 2010
63090 C... ALICE taught us: need less baryon transport than SOFT
63091  mstp(89) = 0
63092  parp(80) = 0.015
63093 C... Small adjustments at LEP (slightly softer frag functions, esp for baryons)
63094  parj(21) = 0.33
63095  parj(41) = 0.35
63096  parj(42) = 0.8
63097  parj(45) = 0.55
63098 C... Increase Lambda/K ratio and other strange baryon yields
63099  parj(1) = 0.087d0
63100  parj(3) = 0.95d0
63101  parj(4) = 0.043d0
63102  parj(6) = 1.0d0
63103  parj(7) = 1.0d0
63104 C... Also reduce total strangeness yield a bit, with higher K*/K
63105  parj(2) = 0.19d0
63106  parj(12) = 0.40d0
63107 C... Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual
63108  mstp(70) = 0
63109  mstp(72) = 2
63110  parp(62) = 1.5d0
63111 C... Holger taught us a smoother proton is preferred at high energies
63112 C... Just use a simple Gaussian
63113  mstp(82) = 3
63114 C... Scaling of pt0 cutoff
63115  parp(90) = 0.265
63116 C... Now retune pT0 to give right UE activity.
63117 C... Low CR strength indicated by LHC tunes
63118 C... (also keep low to get <pT>(Nch) a bit down for pT>100MeV samples)
63119  parp(78) = 0.036d0
63120 C... Choose 7 TeV as new reference scale
63121  parp(89) = 7000.0d0
63122  parp(82) = 2.93d0
63123 C================
63124 C... P2011 Variations
63125 C================
63126  IF (itune.EQ.351) THEN
63127 C... radHi: high Lambda scale for ISR, IFSR, and FSR
63128 C... ( ca 10% more particles at LEP after retune )
63129  parp(61) = 0.52d0
63130  parp(72) = 0.52d0
63131  parj(81) = 0.52d0
63132 C... Retune cutoff scales to compensate partially
63133 C... (though higher cutoff causes faster multiplicity drop at low energies)
63134  parp(62) = 1.75d0
63135  parj(82) = 1.75d0
63136  parp(82) = 3.00d0
63137 C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
63138 C... (since more radiation otherwise generates faster mult growth)
63139  parp(90) = 0.28
63140  ELSEIF (itune.EQ.352) THEN
63141 C... radLo: low Lambda scale for ISR, IFSR, and FSR
63142 C... ( ca 10% less particles at LEP after retune )
63143  parp(61) = 0.13d0
63144  parp(72) = 0.13d0
63145  parj(81) = 0.13d0
63146 C... Retune cutoff scales to compensate partially
63147  parp(62) = 1.00d0
63148  parj(82) = 0.75d0
63149  parp(82) = 2.95d0
63150 C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
63151 C... (since less radiation otherwise generates slower mult growth)
63152  parp(90) = 0.24
63153  ELSEIF (itune.EQ.353) THEN
63154 C... mpiHi: high Lambda scale for MPI
63155  parp(1) = 0.26d0
63156  paru(112) = 0.26d0
63157  parp(82) = 3.35d0
63158  parp(90) = 0.26d0
63159  ELSEIF (itune.EQ.354) THEN
63160  mstp(95) = 0
63161  parp(82) = 3.05d0
63162  ELSEIF (itune.EQ.355) THEN
63163 C... LO**
63164  mstp(52) = 2
63165  mstp(51) = 20651
63166  parp(62) = 1.5d0
63167 C... Compensate for higher <pT> with less CR
63168  parp(78) = 0.034
63169  parp(82) = 3.40d0
63170 C... Need slower energy scaling than CTEQ5L
63171  parp(90) = 0.23d0
63172  ELSEIF (itune.EQ.356) THEN
63173 C... CTEQ6L1
63174  mstp(52) = 2
63175  mstp(51) = 10042
63176  parp(82) = 2.65d0
63177 C... Need slower cutoff scaling than CTEQ5L
63178  parp(90) = 0.22d0
63179  ELSEIF (itune.EQ.357) THEN
63180 C... T16
63181  parp(90) = 0.16
63182  ELSEIF (itune.EQ.358) THEN
63183 C... T32
63184  parp(90) = 0.32
63185  ELSEIF (itune.EQ.359) THEN
63186 C... Tevatron
63187  parp(89) = 1800d0
63188  parp(90) = 0.28
63189  parp(82) = 2.10
63190  parp(78) = 0.05
63191  ENDIF
63192 
63193 C================
63194 C... Perugia 2012 Variations
63195 C================
63196  IF (itune.GE.370) THEN
63197 C... CTEQ6L1 Baseline
63198  mstp(52) = 2
63199  mstp(51) = 10042
63200  parp(82) = 2.65d0
63201 C... Needs slower cutoff scaling than CTEQ5L
63202  parp(90) = 0.24d0
63203 C... Slightly lower CR strength than Perugia 2011
63204  parp(78) = 0.035d0
63205 C... Adjusted fragmentation parameters wrt 2011
63206  parj(1) = 0.085d0
63207  parj(2) = 0.2
63208  parj(3) = 0.92
63209  parj(25) = 0.70
63210  parj(26) = 0.135
63211  parj(41) = 0.45
63212  parj(42) = 1.0
63213  parj(45) = 0.86
63214  ENDIF
63215 C... Variations
63216  IF (itune.EQ.371) THEN
63217 C... radHi: high Lambda scale for ISR, IFSR, and FSR
63218 C... ( ca 10% more particles at LEP after retune )
63219  parp(61) = 0.52d0
63220  parp(72) = 0.52d0
63221  parj(81) = 0.52d0
63222 C... Retune cutoff scales to compensate partially
63223 C... (though higher cutoff causes faster multiplicity drop at low energies)
63224  parp(62) = 1.75d0
63225  parj(82) = 1.75d0
63226  parp(82) = 2.725d0
63227 C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
63228 C... (since more radiation otherwise generates faster mult growth)
63229  parp(90) = 0.25
63230  ELSEIF (itune.EQ.372) THEN
63231 C... radLo: low Lambda scale for ISR, IFSR, and FSR
63232 C... ( ca 10% less particles at LEP after retune )
63233  parp(61) = 0.13d0
63234  parp(72) = 0.13d0
63235  parj(81) = 0.13d0
63236 C... Retune cutoff scales to compensate partially
63237  parp(62) = 1.00d0
63238  parj(82) = 0.75d0
63239  parp(82) = 2.6d0
63240 C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
63241 C... (since less radiation otherwise generates slower mult growth)
63242  parp(90) = 0.23
63243  ELSEIF (itune.EQ.373) THEN
63244 C... mpiHi: high Lambda scale for MPI
63245  parp(1) = 0.26d0
63246  paru(112) = 0.26d0
63247  parp(82) = 3.0d0
63248  parp(90) = 0.24d0
63249  ELSEIF (itune.EQ.374) THEN
63250 C... LOCR : uses global CR model. Less extreme alternative to noCR.
63251  mstp(95) = 6
63252  parp(78) = 0.25d0
63253  parp(82) = 2.7d0
63254  parp(83) = 1.50d0
63255  parp(90) = 0.24
63256  ELSEIF (itune.EQ.375) THEN
63257 C... NOCR : with higher pT0
63258  mstp(95) = 0
63259  parp(82) = 2.80d0
63260  ELSEIF (itune.EQ.376) THEN
63261 C... hadF1 (harder frag function, smaller n.p. pT)
63262  parj(21) = 0.30
63263  parj(41) = 0.36
63264  parj(42) = 1.0
63265  parj(45) = 0.75
63266  ELSEIF (itune.EQ.377) THEN
63267 C... hadF2 (softer frag function, larger n.p. pT)
63268  parj(21) = 0.36
63269  parj(41) = 0.45
63270  parj(42) = 0.75
63271  parj(45) = 0.9
63272  ELSEIF (itune.EQ.378) THEN
63273 C... MSTW08LO
63274  mstp(52) = 2
63275  mstp(51) = 21000
63276  parp(82) = 2.9d0
63277 C...Uses a large LambdaQCD MSbar value (close to CMW one)
63278 C...(Nominally, MSTW 2008 alphaS(mZ) = 0.139)
63279  parp(1) = 0.26d0
63280  paru(112) = 0.26d0
63281 C...Tentative (fast) energy scaling
63282  parp(90) = 0.29
63283  ELSEIF (itune.EQ.379) THEN
63284 C... MSTW LO**
63285  mstp(52) = 2
63286  mstp(51) = 20651
63287  parp(62) = 1.5d0
63288 C... Use a smaller LambdaQCD MSbar than with CTEQ
63289  parp(1) = 0.14d0
63290  paru(112) = 0.14d0
63291 C... Compensate for higher <pT> with less CR
63292  parp(78) = 0.034
63293  parp(82) = 3.25d0
63294 C...Tentative scaling
63295  parp(90) = 0.25
63296  ELSEIF (itune.EQ.380) THEN
63297 C... val0: remove artificial valence-domination of low-pT scatterings
63298 C... slightly faster energy scaling of pT0 cutoff (slower mult growth)
63299  parp(87)=0d0
63300  parp(90)=0.245
63301  ELSEIF (itune.EQ.381) THEN
63302 C... ueHi: lower pT0 value, slower pT0 scaling
63303  parp(82)=2.46d0
63304  parp(90)=0.23
63305  ELSEIF (itune.EQ.382) THEN
63306 C... ueLo: higher pT0 value, faster pT0 scaling
63307  parp(82)=2.92d0
63308  parp(90)=0.26
63309  ELSEIF (itune.EQ.383) THEN
63310 C... IBK: same as Perugia 2012, but with Innsbruck ee fragm parameters
63311 C... Different Lambdas
63312  mstp(3) = 1
63313 C... Lund+Bowler scheme for HQ fragment.
63314  mstj(11) = 5
63315 C... old baryon model
63316  mstj(12) = 2
63317 C... 2=PYSHOW 12=PYPTFS for gluon and photon emiss.
63318  mstj(41) = 12
63319 C... Lambda_LLA
63320  parj(81) = 0.261
63321 C... p_tmin cutoff (set by hand)
63322  parj(82) = 0.90
63323 C... sigma_pt
63324  parj(21) = 0.329
63325 C... A of LSFF
63326  parj(41) = 0.425
63327 C... B of LSFF
63328  parj(42) = 1.65
63329 C... r_c
63330  parj(46) = 1.42
63331 C... r_b
63332  parj(47) = 0.975
63333 C... reset popcorn parameters
63334  parj( 6) = 0.5
63335  parj( 7) = 0.5
63336 C... V_u,d
63337  parj(11) = 0.549
63338 C... V_s
63339  parj(12) = 0.450
63340 C... V_c,b
63341  parj(13) = 0.500
63342 C... L=1 mesons rates
63343  parj(17) = 0.20
63344  parj(14) = 0.12
63345  parj(15) = 0.04
63346  parj(16) = 0.12
63347 C... eta suppr.
63348  parj(25) = 1.000
63349 C... eta-prime suppr.
63350  parj(26) = 0.245
63351 C... s/u
63352  parj( 2) = 0.268
63353 C... qq/q
63354  parj( 1) = 0.128
63355 C... su/du
63356  parj( 3) = 0.772
63357 C... (qq)_1
63358  parj( 4) = 0.05
63359 C... end-point baryon suppress.
63360  parj(19) = 0.402
63361 C... reset a(Baryon)-a(Meson) parameter to default value
63362  parj(45) = 0.50
63363  ENDIF
63364 C================
63365 C...Schulz-Skands 2011 tunes
63366 C...(written as modifications on top of Perugia 0)
63367 C================
63368  ELSEIF (itunsv.GE.360.AND.itunsv.LE.365) THEN
63369  itune = itunsv
63370 
63371  IF (itune.EQ.360) THEN
63372  parp(78) = 0.40d0
63373  parp(82) = 2.19d0
63374  parp(83) = 1.45d0
63375  parp(89) = 1800.0d0
63376  parp(90) = 0.27d0
63377  ELSEIF (itune.EQ.361) THEN
63378  parp(78) = 0.20d0
63379  parp(82) = 2.75d0
63380  parp(83) = 1.73d0
63381  parp(89) = 7000.0d0
63382  ELSEIF (itune.EQ.362) THEN
63383  parp(78) = 0.31d0
63384  parp(82) = 1.97d0
63385  parp(83) = 1.98d0
63386  parp(89) = 1960.0d0
63387  ELSEIF (itune.EQ.363) THEN
63388  parp(78) = 0.35d0
63389  parp(82) = 1.91d0
63390  parp(83) = 2.02d0
63391  parp(89) = 1800.0d0
63392  ELSEIF (itune.EQ.364) THEN
63393  parp(78) = 0.33d0
63394  parp(82) = 1.69d0
63395  parp(83) = 1.92d0
63396  parp(89) = 900.0d0
63397  ELSEIF (itune.EQ.365) THEN
63398  parp(78) = 0.47d0
63399  parp(82) = 1.61d0
63400  parp(83) = 1.50d0
63401  parp(89) = 630.0d0
63402  ENDIF
63403 
63404  ENDIF
63405 
63406 C...Switch off trial joinings
63407  mstp(96) = 0
63408 
63409 C...S0 (300), S0A (303)
63410  IF (ituneb.EQ.300.OR.ituneb.EQ.303) THEN
63411  IF (m13.GE.1) THEN
63412  ch60='see P. Skands & D. Wicke, hep-ph/0703081'
63413  WRITE(m11,5030) ch60
63414  ch60='M. Sandhoff & P. Skands, in hep-ph/0604120'
63415  WRITE(m11,5030) ch60
63416  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63417  WRITE(m11,5030) ch60
63418  IF (itune.GE.310) THEN
63419  ch60='LEP parameters tuned by Professor,'//
63420  & ' hep-ph/0907.2973'
63421  WRITE(m11,5030) ch60
63422  ENDIF
63423  ENDIF
63424 
63425 C...S1 (301)
63426  ELSEIF(ituneb.EQ.301) THEN
63427  IF (m13.GE.1) THEN
63428  ch60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63429  WRITE(m11,5030) ch60
63430  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63431  WRITE(m11,5030) ch60
63432  IF (itune.GE.310) THEN
63433  ch60='LEP parameters tuned by Professor,'//
63434  & ' hep-ph/0907.2973'
63435  WRITE(m11,5030) ch60
63436  ENDIF
63437  ENDIF
63438 
63439 C...S2 (302)
63440  ELSEIF(ituneb.EQ.302) THEN
63441  IF (m13.GE.1) THEN
63442  ch60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63443  WRITE(m11,5030) ch60
63444  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63445  WRITE(m11,5030) ch60
63446  IF (itune.GE.310) THEN
63447  ch60='LEP parameters tuned by Professor,'//
63448  & ' hep-ph/0907.2973'
63449  WRITE(m11,5030) ch60
63450  ENDIF
63451  ENDIF
63452 
63453 C...NOCR (304)
63454  ELSEIF(ituneb.EQ.304) THEN
63455  IF (m13.GE.1) THEN
63456  ch60='"best try" without colour reconnections'
63457  WRITE(m11,5030) ch60
63458  ch60='see P. Skands & D. Wicke, hep-ph/0703081'
63459  WRITE(m11,5030) ch60
63460  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63461  WRITE(m11,5030) ch60
63462  IF (itune.GE.310) THEN
63463  ch60='LEP parameters tuned by Professor,'//
63464  & ' hep-ph/0907.2973'
63465  WRITE(m11,5030) ch60
63466  ENDIF
63467  ENDIF
63468 
63469 C..."Lo FSR" retune (305)
63470  ELSEIF(ituneb.EQ.305) THEN
63471  IF (m13.GE.1) THEN
63472  ch60='"Lo FSR retune" with primitive colour reconnections'
63473  WRITE(m11,5030) ch60
63474  ch60='see T. Sjostrand & P. Skands, hep-ph/0408302'
63475  WRITE(m11,5030) ch60
63476  IF (itune.GE.310) THEN
63477  ch60='LEP parameters tuned by Professor,'//
63478  & ' hep-ph/0907.2973'
63479  WRITE(m11,5030) ch60
63480  ENDIF
63481  ENDIF
63482 
63483 C...Perugia Tunes (320-328 and 334)
63484  ELSEIF((itune.GE.320.AND.itune.LE.328).OR.itune.EQ.334) THEN
63485  IF (m13.GE.1) THEN
63486  ch60='Tuned by P. Skands, hep-ph/1005.3457'
63487  WRITE(m11,5030) ch60
63488  ch60='Physics Model: '//
63489  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63490  WRITE(m11,5030) ch60
63491  IF (itune.LE.326) THEN
63492  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63493  WRITE(m11,5030) ch60
63494  ch60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63495  WRITE(m11,5030) ch60
63496  ENDIF
63497  IF (itune.EQ.325) THEN
63498  ch70='NB! This tune requires MRST LO* pdfs to be '//
63499  & 'externally linked'
63500  WRITE(m11,5035) ch70
63501  ELSEIF (itune.EQ.326) THEN
63502  ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
63503  & 'externally linked'
63504  WRITE(m11,5035) ch70
63505  ELSEIF (itune.EQ.321) THEN
63506  ch60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
63507  WRITE(m11,5030) ch60
63508  ELSEIF (itune.EQ.322) THEN
63509  ch60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
63510  WRITE(m11,5030) ch60
63511  ENDIF
63512  ENDIF
63513 
63514 C...Professor-pTO (329)
63515  ELSEIF(itune.EQ.329.OR.itune.EQ.335.OR.itune.EQ.336.OR.
63516  & itune.EQ.339) THEN
63517  IF (m13.GE.1) THEN
63518  ch60='Tuned by Professor, hep-ph/0907.2973'
63519  WRITE(m11,5030) ch60
63520  ch60='Physics Model: '//
63521  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63522  WRITE(m11,5030) ch60
63523  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63524  WRITE(m11,5030) ch60
63525  ENDIF
63526 
63527 C...Perugia 2011 Tunes (350-359)
63528  ELSEIF(itune.GE.350.AND.itune.LE.359) THEN
63529  IF (m13.GE.1) THEN
63530  ch60='Tuned by P. Skands, hep-ph/1005.3457'
63531  WRITE(m11,5030) ch60
63532  ch60='Physics Model: '//
63533  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63534  WRITE(m11,5030) ch60
63535  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63536  WRITE(m11,5030) ch60
63537  IF (itune.EQ.355) THEN
63538  ch70='NB! This tune requires MRST LO** pdfs to be '//
63539  & 'externally linked'
63540  WRITE(m11,5035) ch70
63541  ELSEIF (itune.EQ.356) THEN
63542  ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
63543  & 'externally linked'
63544  WRITE(m11,5035) ch70
63545  ENDIF
63546  ENDIF
63547 
63548 C...Schulz-Skands Tunes (360-365)
63549  ELSEIF(itune.GE.360.AND.itune.LE.365) THEN
63550  IF (m13.GE.1) THEN
63551  ch60='Tuned by H. Schulz & P. Skands, MCNET-11-07'
63552  WRITE(m11,5030) ch60
63553  ch60='Based on Perugia 0, hep-ph/1005.3457'
63554  WRITE(m11,5030) ch60
63555  ch60='Physics Model: '//
63556  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63557  WRITE(m11,5030) ch60
63558  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63559  WRITE(m11,5030) ch60
63560  ENDIF
63561 
63562 C...Perugia 2012 Tunes (370-389)
63563  ELSEIF(itune.GE.370.AND.itune.LE.389) THEN
63564  IF (m13.GE.1) THEN
63565  ch60='Tuned by P. Skands, hep-ph/1005.3457'
63566  WRITE(m11,5030) ch60
63567  IF (itune.EQ.383) THEN
63568  ch60='with Innsbruck (IBK) ee fragmentation parameters'
63569  WRITE(m11,5030) ch60
63570  ENDIF
63571  ch60='Physics Model: '//
63572  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63573  WRITE(m11,5030) ch60
63574  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63575  WRITE(m11,5030) ch60
63576  IF (itune.EQ.378) THEN
63577  ELSEIF (itune.EQ.379) THEN
63578  ch70='NB! This tune requires MRST 2008 LO** pdfs to be '//
63579  & 'externally linked'
63580  WRITE(m11,5035) ch70
63581  ELSE
63582  ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
63583  & 'externally linked'
63584  WRITE(m11,5035) ch70
63585  ENDIF
63586  ENDIF
63587 
63588  ENDIF
63589 
63590 C...Output
63591  IF (m13.GE.1) THEN
63592  WRITE(m11,5030) ' '
63593  WRITE(m11,5040) 51, mstp(51), chmstp(51)
63594  WRITE(m11,5040) 52, mstp(52), chmstp(52)
63595  IF (mstp(33).GE.10) THEN
63596  WRITE(m11,5050) 32, parp(32), chparp(32)
63597  ENDIF
63598  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
63599  IF (mstp(3).EQ.1) THEN
63600  WRITE(m11,6100) 112, mstu(112), chmstu(112)
63601  WRITE(m11,6110) 112, paru(112), chparu(112)
63602  WRITE(m11,5050) 1, parp(1) , chparp( 1)
63603  ENDIF
63604  WRITE(m11,5060) 81, parj(81), chparj(81)
63605  IF (mstp(3).EQ.1) THEN
63606  WRITE(m11,5050) 72, parp(72) , chparp( 72)
63607  WRITE(m11,5050) 61, parp(61) , chparp( 61)
63608  ENDIF
63609  WRITE(m11,5040) 64, mstp(64), chmstp(64)
63610  WRITE(m11,5050) 64, parp(64), chparp(64)
63611  WRITE(m11,5040) 67, mstp(67), chmstp(67)
63612  WRITE(m11,5040) 68, mstp(68), chmstp(68)
63613  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63614  WRITE(m11,5030) ch60
63615  WRITE(m11,5050) 67, parp(67), chparp(67)
63616  WRITE(m11,5040) 72, mstp(72), chmstp(72)
63617  WRITE(m11,5050) 71, parp(71), chparp(71)
63618  WRITE(m11,5040) 70, mstp(70), chmstp(70)
63619  IF (mstp(70).EQ.0) THEN
63620  WRITE(m11,5050) 62, parp(62), chparp(62)
63621  ELSEIF (mstp(70).EQ.1) THEN
63622  WRITE(m11,5050) 81, parp(81), chparp(62)
63623  ch60='(Note: PARP(81) replaces PARP(62).)'
63624  WRITE(m11,5030) ch60
63625  ENDIF
63626  WRITE(m11,5060) 82, parj(82), chparj(82)
63627  WRITE(m11,5040) 33, mstp(33), chmstp(33)
63628  WRITE(m11,5040) 81, mstp(81), chmstp(81)
63629  WRITE(m11,5050) 82, parp(82), chparp(82)
63630  IF (mstp(70).EQ.2) THEN
63631  ch60='(Note: PARP(82) replaces PARP(62).)'
63632  WRITE(m11,5030) ch60
63633  ENDIF
63634  WRITE(m11,5050) 89, parp(89), chparp(89)
63635  WRITE(m11,5050) 90, parp(90), chparp(90)
63636  WRITE(m11,5040) 82, mstp(82), chmstp(82)
63637  IF (mstp(82).EQ.5) THEN
63638  WRITE(m11,5050) 83, parp(83), chparp(83)
63639  ELSEIF (mstp(82).EQ.4) THEN
63640  WRITE(m11,5050) 83, parp(83), chparp(83)
63641  WRITE(m11,5050) 84, parp(84), chparp(84)
63642  ENDIF
63643  IF (mstp(82).GE.2) THEN
63644  WRITE(m11,5050) 87, parp(87), chparp(87)
63645  IF (parp(87).GE.0d0)
63646  & WRITE(m11,5050) 88, parp(88), chparp(88)
63647  ENDIF
63648  WRITE(m11,5040) 88, mstp(88), chmstp(88)
63649  WRITE(m11,5040) 89, mstp(89), chmstp(89)
63650  WRITE(m11,5050) 79, parp(79), chparp(79)
63651  WRITE(m11,5050) 80, parp(80), chparp(80)
63652  WRITE(m11,5040) 91, mstp(91), chmstp(91)
63653  WRITE(m11,5050) 91, parp(91), chparp(91)
63654  WRITE(m11,5050) 93, parp(93), chparp(93)
63655  WRITE(m11,5040) 95, mstp(95), chmstp(95)
63656  IF (mstp(95).GE.1) THEN
63657  WRITE(m11,5050) 78, parp(78), chparp(78)
63658  IF (mstp(95).GE.2) WRITE(m11,5050) 77, parp(77), chparp(77)
63659  ENDIF
63660 
63661  ENDIF
63662 
63663 C=======================================================================
63664 C...Innsbruck tunes (provided by N. Firdous and G. Rudolph, Innsbruck)
63665 C...390-395
63666  ELSEIF (itune.GE.390.AND.itune.LE.395) THEN
63667  IF (m13.GE.1) WRITE(m11,5010) itune, chname
63668  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.419))THEN
63669  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63670  & ' with tune.')
63671  ENDIF
63672 
63673 C... 1) Set the IBK ee fragmentation parameters (March 2012)
63674 C... Lund+Bowler scheme for HQ fragment.
63675  mstj(11) = 5
63676 C... old baryon model
63677  mstj(12) = 2
63678 C... 2=PYSHOW 12=PYPTFS for gluon and photon emiss.
63679  mstj(41) = 12
63680 C... Lambda_LLA
63681  parj(81) = 0.261
63682 C... p_tmin cutoff (set by hand)
63683  parj(82) = 0.90
63684 C... sigma_pt
63685  parj(21) = 0.329
63686 C... A of LSFF
63687  parj(41) = 0.425
63688 C... B of LSFF
63689  parj(42) = 1.65
63690 C... r_c
63691  parj(46) = 1.42
63692 C... r_b
63693  parj(47) = 0.975
63694 C... V_u,d
63695  parj(11) = 0.549
63696 C... V_s
63697  parj(12) = 0.450
63698 C... V_c,b
63699  parj(13) = 0.500
63700 C... L=1 mesons rates
63701  parj(17) = 0.20
63702  parj(14) = 0.12
63703  parj(15) = 0.04
63704  parj(16) = 0.12
63705 C... eta suppr.
63706  parj(25) = 1.000
63707 C... eta-prime suppr.
63708  parj(26) = 0.245
63709 C... s/u
63710  parj( 2) = 0.268
63711 C... qq/q
63712  parj( 1) = 0.128
63713 C... su/du
63714  parj( 3) = 0.772
63715 C... (qq)_1
63716  parj( 4) = 0.05
63717 C... end-point baryon suppress.
63718  parj(19) = 0.402
63719 C... reset a(Baryon)-a(Meson) parameter to default value
63720  parj(45) = 0.50
63721 
63722 C... 2) Set the global IBK pp tune parameters
63723 C... Different Lambda_QCD
63724  mstp( 3) = 1
63725 C... N_flavors = 5
63726  mstu(112) = 5
63727 C... MPI & BR master switch
63728  mstp( 81) = 21
63729 C... alpha_s(Q**2) choice in ISR (def=2)
63730  mstp( 64) = 2
63731 C... ISR regularisation (def=1)
63732  mstp( 70) = 2
63733 C... ptmax scale for rad betw ISR partons (def=1)
63734  mstp( 72) = 2
63735 C... MPI structure: matter overlap (def=4)
63736  mstp( 82) = 5
63737 C... collapse of junction configur. (def=1)
63738  mstp( 88) = 0
63739 C... CR: annealing model (def=1)
63740  mstp( 95) = 6
63741 C... Lam_QCD for ISR
63742  parp( 61) = 0.190
63743 C... K-factor in alpha_s for ISR (def=1.)
63744  parp( 64) = 1.0
63745 C... max.virt. scale factor for ISR (def=4.)
63746  parp( 67) = 1.0
63747 C... max.virt. scale factor for FSR (def=4.)
63748  parp( 71) = 1.0
63749 C... CR suppression for fast moving strings (def=0.)
63750  parp( 77) = 0.90
63751 C... PT0 reference Ecm (def=1800 GeV)
63752  parp( 89) = 7000.0
63753 C... beam remnant x enhancement (def=2.)
63754  parp( 79) = 1.50
63755 C... beam remnant breakup suppression (def=0.1)
63756  parp( 80) = 0.06
63757 C... intrinsic kT width (def=2.0)
63758  parp( 91) = 2.0
63759 C... intrinsic kT cutoff(def=5.0)
63760  parp( 93) = 10.0
63761 
63762 C... 3) Set the tune-specific IBK pp tune parameters
63763  IF (itune.EQ.390) THEN
63764 C... CTEQ5L
63765  mstp(51)=7
63766  mstp(52)=1
63767  parp(82)=2.942
63768  parp(90)=0.2450
63769  parp(83)=1.817
63770  parp(78)=0.433
63771  parp( 1)=0.163
63772  paru(112)=0.163
63773  parp(72)=0.531
63774  ELSEIF (itune.EQ.391) THEN
63775 C... CTEQ6LL
63776  mstp(51)=10042
63777  mstp(52)=2
63778  parp(82)=2.625
63779  parp(90)=0.2178
63780  parp(83)=1.863
63781  parp(78)=0.461
63782  parp( 1)=0.141
63783  paru(112)=0.141
63784  parp(72)=0.475
63785  ELSEIF (itune.EQ.392) THEN
63786 C... MSTW08LO
63787  mstp(51)=21000
63788  mstp(52)=2
63789  parp(82)=2.889
63790  parp(90)=0.2832
63791  parp(83)=1.785
63792  parp(78)=0.478
63793  parp( 1)=0.199
63794  paru(112)=0.199
63795  parp(72)=0.657
63796  ELSEIF (itune.EQ.393) THEN
63797 C... CTEQ66 NLO
63798  mstp(51)=10550
63799  mstp(52)=2
63800  parp(82)=2.172
63801  parp(90)=0.1818
63802  parp(83)=1.939
63803  parp(78)=0.513
63804  parp( 1)=0.173
63805  paru(112)=0.173
63806  parp(72)=0.456
63807  ELSEIF (itune.EQ.394) THEN
63808 C... CT10 NLO
63809  mstp(51)=10800
63810  mstp(52)=2
63811  parp(82)=2.090
63812  parp(90)=0.1687
63813  parp(83)=1.939
63814  parp(78)=0.517
63815  parp( 1)=0.177
63816  paru(112)=0.177
63817  parp(72)=0.463
63818  ELSEIF (itune.EQ.395) THEN
63819 C... MSTW08NLO
63820  mstp(51)=21100
63821  mstp(52)=2
63822  parp(82)=1.773
63823  parp(90)=0.1780
63824  parp(83)=1.882
63825  parp(78)=0.590
63826  parp( 1)=0.161
63827  paru(112)=0.161
63828  parp(72)=0.367
63829  ELSEIF (itune.EQ.396) THEN
63830 C... MRST07LO*
63831  mstp(51)=20650
63832  mstp(52)=2
63833  parp(82)=2.619
63834  parp(90)=0.2286
63835  parp(83)=1.812
63836  parp(78)=0.471
63837  parp( 1)=0.082
63838  paru(112)=0.082
63839  parp(72)=0.500
63840  ELSEIF (itune.EQ.397) THEN
63841 C... MRSTMCal (LO**)
63842  mstp(51)=20651
63843  mstp(52)=2
63844  parp(82)=2.802
63845  parp(90)=0.2220
63846  parp(83)=1.821
63847  parp(78)=0.441
63848  parp( 1)=0.080
63849  paru(112)=0.080
63850  parp(72)=0.519
63851  ELSEIF (itune.EQ.398) THEN
63852 C...CT09MC2
63853  mstp(51)=10772
63854  mstp(52)=2
63855  parp(82)=2.355
63856  parp(90)=0.2062
63857  parp(83)=1.893
63858  parp(78)=0.509
63859  parp( 1)=0.058
63860  paru(112)=0.058
63861  parp(72)=0.401
63862  ENDIF
63863 
63864 C...Output
63865  IF (m13.GE.1) THEN
63866  ch60='Tune provided by N. Firdous & G. Rudolph (Innsbruck)'
63867  WRITE(m11,5030) ch60
63868  ch60='Physics Model: '//
63869  & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63870  WRITE(m11,5030) ch60
63871  ch60='CR by P. Skands & D. Wicke, hep-ph/0703081'
63872  WRITE(m11,5030) ch60
63873  IF (itune.GE.391) THEN
63874  ch70='NB ! This tune requires LHAPDF to be '//
63875  & 'externally linked'
63876  WRITE(m11,5035) ch70
63877  ENDIF
63878  WRITE(m11,5030) ' '
63879  WRITE(m11,5040) 51, mstp(51), chmstp(51)
63880  WRITE(m11,5040) 52, mstp(52), chmstp(52)
63881  IF (mstp(33).GE.10) THEN
63882  WRITE(m11,5050) 32, parp(32), chparp(32)
63883  ENDIF
63884  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
63885  IF (mstp(3).EQ.1) THEN
63886  WRITE(m11,6100) 112, mstu(112), chmstu(112)
63887  WRITE(m11,6110) 112, paru(112), chparu(112)
63888  WRITE(m11,5050) 1, parp(1) , chparp( 1)
63889  ENDIF
63890  WRITE(m11,5060) 81, parj(81), chparj(81)
63891  IF (mstp(3).EQ.1) THEN
63892  WRITE(m11,5050) 72, parp(72) , chparp( 72)
63893  WRITE(m11,5050) 61, parp(61) , chparp( 61)
63894  ENDIF
63895  WRITE(m11,5040) 64, mstp(64), chmstp(64)
63896  WRITE(m11,5050) 64, parp(64), chparp(64)
63897  WRITE(m11,5040) 67, mstp(67), chmstp(67)
63898  WRITE(m11,5040) 68, mstp(68), chmstp(68)
63899  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63900  WRITE(m11,5030) ch60
63901  WRITE(m11,5050) 67, parp(67), chparp(67)
63902  WRITE(m11,5040) 72, mstp(72), chmstp(72)
63903  WRITE(m11,5050) 71, parp(71), chparp(71)
63904  WRITE(m11,5040) 70, mstp(70), chmstp(70)
63905  IF (mstp(70).EQ.0) THEN
63906  WRITE(m11,5050) 62, parp(62), chparp(62)
63907  ELSEIF (mstp(70).EQ.1) THEN
63908  WRITE(m11,5050) 81, parp(81), chparp(62)
63909  ch60='(Note: PARP(81) replaces PARP(62).)'
63910  WRITE(m11,5030) ch60
63911  ENDIF
63912  WRITE(m11,5060) 82, parj(82), chparj(82)
63913  WRITE(m11,5040) 33, mstp(33), chmstp(33)
63914  WRITE(m11,5040) 81, mstp(81), chmstp(81)
63915  WRITE(m11,5050) 82, parp(82), chparp(82)
63916  IF (mstp(70).EQ.2) THEN
63917  ch60='(Note: PARP(82) replaces PARP(62).)'
63918  WRITE(m11,5030) ch60
63919  ENDIF
63920  WRITE(m11,5050) 89, parp(89), chparp(89)
63921  WRITE(m11,5050) 90, parp(90), chparp(90)
63922  WRITE(m11,5040) 82, mstp(82), chmstp(82)
63923  IF (mstp(82).EQ.5) THEN
63924  WRITE(m11,5050) 83, parp(83), chparp(83)
63925  ELSEIF (mstp(82).EQ.4) THEN
63926  WRITE(m11,5050) 83, parp(83), chparp(83)
63927  WRITE(m11,5050) 84, parp(84), chparp(84)
63928  ENDIF
63929  IF (mstp(82).GE.2) THEN
63930  WRITE(m11,5050) 87, parp(87), chparp(87)
63931  IF (parp(87).GE.0d0)
63932  & WRITE(m11,5050) 88, parp(88), chparp(88)
63933  ENDIF
63934  WRITE(m11,5040) 88, mstp(88), chmstp(88)
63935  WRITE(m11,5040) 89, mstp(89), chmstp(89)
63936  WRITE(m11,5050) 79, parp(79), chparp(79)
63937  WRITE(m11,5050) 80, parp(80), chparp(80)
63938  WRITE(m11,5040) 91, mstp(91), chmstp(91)
63939  WRITE(m11,5050) 91, parp(91), chparp(91)
63940  WRITE(m11,5050) 93, parp(93), chparp(93)
63941  WRITE(m11,5040) 95, mstp(95), chmstp(95)
63942  IF (mstp(95).GE.1) THEN
63943  WRITE(m11,5050) 78, parp(78), chparp(78)
63944  IF (mstp(95).GE.2) WRITE(m11,5050) 77, parp(77), chparp(77)
63945  ENDIF
63946 
63947  ENDIF
63948 C=======================================================================
63949 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
63950  ELSEIF (itune.EQ.306) THEN
63951  IF (m13.GE.1) WRITE(m11,5010) itune, chname
63952  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
63953  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63954  & ' with tune.')
63955  ENDIF
63956 
63957 C...PDFs
63958  mstp(52) = 2
63959  mstp(54) = 2
63960  mstp(51) = 10042
63961  mstp(53) = 10042
63962 C...ISR
63963 C PARP(64) = 1D0
63964 C...UE on, new model.
63965  mstp(81) = 21
63966 C...Energy scaling
63967  parp(89) = 1800d0
63968  parp(90) = 0.22d0
63969 C...Switch off trial joinings
63970  mstp(96) = 0
63971 C...Primordial kT cutoff
63972 
63973  IF (m13.GE.1) THEN
63974  ch60='see presentations by A. Moraes (ATLAS),'
63975  WRITE(m11,5030) ch60
63976  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63977  WRITE(m11,5030) ch60
63978  WRITE(m11,5030) ' '
63979  ch70='NB! This tune requires CTEQ6.1 pdfs to be '//
63980  & 'externally linked'
63981  WRITE(m11,5035) ch70
63982  ENDIF
63983 C...Smooth ISR, low FSR
63984  mstp(70) = 2
63985  mstp(72) = 0
63986 C...pT0
63987  parp(82) = 1.9d0
63988 C...Transverse density profile.
63989  mstp(82) = 4
63990  parp(83) = 0.3d0
63991  parp(84) = 0.5d0
63992 C...ISR & FSR in interactions after the first (default)
63993  mstp(84) = 1
63994  mstp(85) = 1
63995 C...No double-counting (default)
63996  mstp(86) = 2
63997 C...Companion quark parent gluon (1-x) power
63998  mstp(87) = 4
63999 C...Primordial kT compensation along chaings (default = 0 : uniform)
64000  mstp(90) = 1
64001 C...Colour Reconnections
64002  mstp(95) = 1
64003  parp(78) = 0.2d0
64004 C...Lambda_FSR scale.
64005  parj(81) = 0.23d0
64006 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
64007  mstp(89) = 1
64008  mstp(88) = 0
64009 C PARP(79) = 2D0
64010  parp(80) = 0.01d0
64011 C...Peterson charm frag, and c and b hadr parameters
64012  mstj(11) = 3
64013  parj(54) = -0.07
64014  parj(55) = -0.006
64015 C... Output
64016  IF (m13.GE.1) THEN
64017  WRITE(m11,5030) ' '
64018  WRITE(m11,5040) 51, mstp(51), chmstp(51)
64019  WRITE(m11,5040) 52, mstp(52), chmstp(52)
64020  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
64021  WRITE(m11,5050) 64, parp(64), chparp(64)
64022  WRITE(m11,5040) 68, mstp(68), chmstp(68)
64023  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64024  WRITE(m11,5030) ch60
64025  WRITE(m11,5040) 70, mstp(70), chmstp(70)
64026  WRITE(m11,5040) 72, mstp(72), chmstp(72)
64027  WRITE(m11,5050) 71, parp(71), chparp(71)
64028  WRITE(m11,5060) 81, parj(81), chparj(81)
64029  ch60='(Note: PARJ(81) changed from 0.14! See update notes)'
64030  WRITE(m11,5030) ch60
64031  WRITE(m11,5040) 33, mstp(33), chmstp(33)
64032  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64033  WRITE(m11,5050) 82, parp(82), chparp(82)
64034  WRITE(m11,5050) 89, parp(89), chparp(89)
64035  WRITE(m11,5050) 90, parp(90), chparp(90)
64036  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64037  WRITE(m11,5050) 83, parp(83), chparp(83)
64038  WRITE(m11,5050) 84, parp(84), chparp(84)
64039  IF (mstp(82).GE.2) THEN
64040  WRITE(m11,5050) 87, parp(87), chparp(87)
64041  IF (parp(87).GE.0d0)
64042  & WRITE(m11,5050) 88, parp(88), chparp(88)
64043  ENDIF
64044  WRITE(m11,5040) 88, mstp(88), chmstp(88)
64045  WRITE(m11,5040) 89, mstp(89), chmstp(89)
64046  WRITE(m11,5040) 90, mstp(90), chmstp(90)
64047  WRITE(m11,5050) 79, parp(79), chparp(79)
64048  WRITE(m11,5050) 80, parp(80), chparp(80)
64049  WRITE(m11,5050) 93, parp(93), chparp(93)
64050  WRITE(m11,5040) 95, mstp(95), chmstp(95)
64051  WRITE(m11,5050) 78, parp(78), chparp(78)
64052 
64053  ENDIF
64054 
64055 C=======================================================================
64056 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
64057 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
64058 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129)
64059  ELSEIF ((itune.GE.100.AND.itune.LE.106).OR.itune.EQ.108.OR.
64060  & itune.EQ.109.OR.(itune.GE.110.AND.itune.LE.116).OR.
64061  & itune.EQ.118.OR.itune.EQ.119.OR.itune.EQ.129) THEN
64062  IF (m13.GE.1.AND.itune.NE.106.AND.itune.NE.129) THEN
64063  WRITE(m11,5010) itune, chname
64064  ch60='see R.D. Field, in hep-ph/0610012'
64065  WRITE(m11,5030) ch60
64066  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64067  WRITE(m11,5030) ch60
64068  IF (itune.GE.110.AND.itune.LE.119) THEN
64069  ch60='LEP parameters tuned by Professor, hep-ph/0907.2973'
64070  WRITE(m11,5030) ch60
64071  ENDIF
64072  ELSEIF (m13.GE.1.AND.itune.EQ.129) THEN
64073  WRITE(m11,5010) itune, chname
64074  ch60='Tuned by Professor, hep-ph/0907.2973'
64075  WRITE(m11,5030) ch60
64076  ch60='Physics Model: '//
64077  & 'T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64078  WRITE(m11,5030) ch60
64079  ENDIF
64080 
64081 C...Make sure we start from old default fragmentation parameters
64082  parj(81) = 0.29
64083  parj(82) = 1.0
64084 
64085 C...Use Professor's LEP pars if ITUNE >= 110
64086 C...(i.e., for A-Pro, DW-Pro etc)
64087  IF (itune.LT.110) THEN
64088 C...# Old defaults
64089  mstj(11) = 4
64090  parj(1) = 0.1
64091  parj(2) = 0.3
64092  parj(3) = 0.40
64093  parj(4) = 0.05
64094  parj(11) = 0.5
64095  parj(12) = 0.6
64096  parj(21) = 0.36
64097  parj(41) = 0.30
64098  parj(42) = 0.58
64099  parj(46) = 1.0
64100  parj(81) = 0.29
64101  parj(82) = 1.0
64102  ELSE
64103 C...# Tuned flavour parameters:
64104  parj(1) = 0.073
64105  parj(2) = 0.2
64106  parj(3) = 0.94
64107  parj(4) = 0.032
64108  parj(11) = 0.31
64109  parj(12) = 0.4
64110  parj(13) = 0.54
64111  parj(25) = 0.63
64112  parj(26) = 0.12
64113 C...# Switch on Bowler:
64114  mstj(11) = 5
64115 C...# Fragmentation
64116  parj(21) = 0.325
64117  parj(41) = 0.5
64118  parj(42) = 0.6
64119  parj(47) = 0.67
64120  parj(81) = 0.29
64121  parj(82) = 1.65
64122  ENDIF
64123 
64124 C...Remove middle digit now for Professor variants, since identical pars
64125  ituneb=itune
64126  IF (itune.GE.110.AND.itune.LE.119) THEN
64127  ituneb=(itune/100)*100+mod(itune,10)
64128  ENDIF
64129 
64130 C...Multiple interactions on, old framework
64131  mstp(81) = 1
64132 C...Fast IR cutoff energy scaling by default
64133  parp(89) = 1800d0
64134  parp(90) = 0.25d0
64135 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
64136  mstp(51) = 7
64137  mstp(52) = 1
64138  IF (ituneb.EQ.105) THEN
64139  mstp(51) = 10150
64140  mstp(52) = 2
64141  ELSEIF(ituneb.EQ.108.OR.ituneb.EQ.109) THEN
64142  mstp(52) = 2
64143  mstp(54) = 2
64144  mstp(51) = 10042
64145  mstp(53) = 10042
64146  ENDIF
64147 C...Double Gaussian matter distribution.
64148  mstp(82) = 4
64149  parp(83) = 0.5d0
64150  parp(84) = 0.4d0
64151 C...FSR activity.
64152  parp(71) = 4d0
64153 C...Fragmentation functions and c and b parameters
64154 C...(only if not using Professor)
64155  IF (itune.LE.109) THEN
64156  mstj(11) = 4
64157  parj(54) = -0.05
64158  parj(55) = -0.005
64159  ENDIF
64160 
64161 C...Tune A and AW
64162  IF(ituneb.EQ.100.OR.ituneb.EQ.101) THEN
64163 C...pT0.
64164  parp(82) = 2.0d0
64165 c...String drawing almost completely minimizes string length.
64166  parp(85) = 0.9d0
64167  parp(86) = 0.95d0
64168 C...ISR cutoff, muR scale factor, and phase space size
64169  parp(62) = 1d0
64170  parp(64) = 1d0
64171  parp(67) = 4d0
64172 C...Intrinsic kT, size, and max
64173  mstp(91) = 1
64174  parp(91) = 1d0
64175  parp(93) = 5d0
64176 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
64177  IF (ituneb.EQ.101) THEN
64178  parp(62) = 1.25d0
64179  parp(64) = 0.2d0
64180  parp(91) = 2.1d0
64181  parp(92) = 15.0d0
64182  ENDIF
64183 
64184 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
64185  ELSEIF (ituneb.EQ.102) THEN
64186 C...pT0.
64187  parp(82) = 1.9d0
64188 c...String drawing completely minimizes string length.
64189  parp(85) = 1.0d0
64190  parp(86) = 1.0d0
64191 C...ISR cutoff, muR scale factor, and phase space size
64192  parp(62) = 1.25d0
64193  parp(64) = 0.2d0
64194  parp(67) = 1d0
64195 C...Intrinsic kT, size, and max
64196  mstp(91) = 1
64197  parp(91) = 2.1d0
64198  parp(93) = 15d0
64199 
64200 C...Tune DW
64201  ELSEIF (ituneb.EQ.103) THEN
64202 C...pT0.
64203  parp(82) = 1.9d0
64204 c...String drawing completely minimizes string length.
64205  parp(85) = 1.0d0
64206  parp(86) = 1.0d0
64207 C...ISR cutoff, muR scale factor, and phase space size
64208  parp(62) = 1.25d0
64209  parp(64) = 0.2d0
64210  parp(67) = 2.5d0
64211 C...Intrinsic kT, size, and max
64212  mstp(91) = 1
64213  parp(91) = 2.1d0
64214  parp(93) = 15d0
64215 
64216 C...Tune DWT
64217  ELSEIF (ituneb.EQ.104) THEN
64218 C...pT0.
64219  parp(82) = 1.9409d0
64220 C...Run II ref scale and slow scaling
64221  parp(89) = 1960d0
64222  parp(90) = 0.16d0
64223 c...String drawing completely minimizes string length.
64224  parp(85) = 1.0d0
64225  parp(86) = 1.0d0
64226 C...ISR cutoff, muR scale factor, and phase space size
64227  parp(62) = 1.25d0
64228  parp(64) = 0.2d0
64229  parp(67) = 2.5d0
64230 C...Intrinsic kT, size, and max
64231  mstp(91) = 1
64232  parp(91) = 2.1d0
64233  parp(93) = 15d0
64234 
64235 C...Tune QW
64236  ELSEIF(ituneb.EQ.105) THEN
64237  IF (m13.GE.1) THEN
64238  WRITE(m11,5030) ' '
64239  ch70='NB! This tune requires CTEQ6.1 pdfs to be '//
64240  & 'externally linked'
64241  WRITE(m11,5035) ch70
64242  ENDIF
64243 C...pT0.
64244  parp(82) = 1.1d0
64245 c...String drawing completely minimizes string length.
64246  parp(85) = 1.0d0
64247  parp(86) = 1.0d0
64248 C...ISR cutoff, muR scale factor, and phase space size
64249  parp(62) = 1.25d0
64250  parp(64) = 0.2d0
64251  parp(67) = 2.5d0
64252 C...Intrinsic kT, size, and max
64253  mstp(91) = 1
64254  parp(91) = 2.1d0
64255  parp(93) = 15d0
64256 
64257 C...Tune D6 and D6T
64258  ELSEIF(ituneb.EQ.108.OR.ituneb.EQ.109) THEN
64259  IF (m13.GE.1) THEN
64260  WRITE(m11,5030) ' '
64261  ch70='NB! This tune requires CTEQ6L pdfs to be '//
64262  & 'externally linked'
64263  WRITE(m11,5035) ch70
64264  ENDIF
64265 C...The "Rick" proton, double gauss with 0.5/0.4
64266  mstp(82) = 4
64267  parp(83) = 0.5d0
64268  parp(84) = 0.4d0
64269 c...String drawing completely minimizes string length.
64270  parp(85) = 1.0d0
64271  parp(86) = 1.0d0
64272  IF (ituneb.EQ.108) THEN
64273 C...D6: pT0, Run I ref scale, and fast energy scaling
64274  parp(82) = 1.8d0
64275  parp(89) = 1800d0
64276  parp(90) = 0.25d0
64277  ELSE
64278 C...D6T: pT0, Run II ref scale, and slow energy scaling
64279  parp(82) = 1.8387d0
64280  parp(89) = 1960d0
64281  parp(90) = 0.16d0
64282  ENDIF
64283 C...ISR cutoff, muR scale factor, and phase space size
64284  parp(62) = 1.25d0
64285  parp(64) = 0.2d0
64286  parp(67) = 2.5d0
64287 C...Intrinsic kT, size, and max
64288  mstp(91) = 1
64289  parp(91) = 2.1d0
64290  parp(93) = 15d0
64291 
64292 C...Old ATLAS-DC2 5-parameter tune
64293  ELSEIF(ituneb.EQ.106) THEN
64294  IF (m13.GE.1) THEN
64295  WRITE(m11,5010) itune, chname
64296  ch60='see A. Moraes et al., SN-ATLAS-2006-057,'
64297  WRITE(m11,5030) ch60
64298  ch60=' R. Field in hep-ph/0610012,'
64299  WRITE(m11,5030) ch60
64300  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64301  WRITE(m11,5030) ch60
64302  ENDIF
64303 C... pT0.
64304  parp(82) = 1.8d0
64305 C... Different ref and rescaling pacee
64306  parp(89) = 1000d0
64307  parp(90) = 0.16d0
64308 C... Parameters of mass distribution
64309  parp(83) = 0.5d0
64310  parp(84) = 0.5d0
64311 C... Old default string drawing
64312  parp(85) = 0.33d0
64313  parp(86) = 0.66d0
64314 C... ISR, phase space equivalent to Tune B
64315  parp(62) = 1d0
64316  parp(64) = 1d0
64317  parp(67) = 1d0
64318 C... FSR
64319  parp(71) = 4d0
64320 C... Intrinsic kT
64321  mstp(91) = 1
64322  parp(91) = 1d0
64323  parp(93) = 5d0
64324 
64325 C...Professor's Pro-Q2O Tune
64326  ELSEIF(itune.EQ.129) THEN
64327  parp(62) = 2.9
64328  parp(64) = 0.14
64329  parp(67) = 2.65
64330  parp(82) = 1.9
64331  parp(83) = 0.83
64332  parp(84) = 0.6
64333  parp(85) = 0.86
64334  parp(86) = 0.93
64335  parp(89) = 1800d0
64336  parp(90) = 0.22
64337  mstp(91) = 1
64338  parp(91) = 2.1
64339  parp(93) = 5.0
64340 
64341  ENDIF
64342 
64343 C... Output
64344  IF (m13.GE.1) THEN
64345  WRITE(m11,5030) ' '
64346  WRITE(m11,5040) 51, mstp(51), chmstp(51)
64347  WRITE(m11,5040) 52, mstp(52), chmstp(52)
64348  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
64349  WRITE(m11,5050) 62, parp(62), chparp(62)
64350  WRITE(m11,5050) 64, parp(64), chparp(64)
64351  WRITE(m11,5050) 67, parp(67), chparp(67)
64352  WRITE(m11,5040) 68, mstp(68), chmstp(68)
64353  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64354  WRITE(m11,5030) ch60
64355  WRITE(m11,5050) 71, parp(71), chparp(71)
64356  WRITE(m11,5060) 81, parj(81), chparj(81)
64357  WRITE(m11,5060) 82, parj(82), chparj(82)
64358  WRITE(m11,5040) 33, mstp(33), chmstp(33)
64359  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64360  WRITE(m11,5050) 82, parp(82), chparp(82)
64361  WRITE(m11,5050) 89, parp(89), chparp(89)
64362  WRITE(m11,5050) 90, parp(90), chparp(90)
64363  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64364  WRITE(m11,5050) 83, parp(83), chparp(83)
64365  WRITE(m11,5050) 84, parp(84), chparp(84)
64366  IF (mstp(82).GE.2) THEN
64367  WRITE(m11,5050) 87, parp(87), chparp(87)
64368  IF (parp(87).GE.0d0)
64369  & WRITE(m11,5050) 88, parp(88), chparp(88)
64370  ENDIF
64371  WRITE(m11,5050) 85, parp(85), chparp(85)
64372  WRITE(m11,5050) 86, parp(86), chparp(86)
64373  WRITE(m11,5040) 91, mstp(91), chmstp(91)
64374  WRITE(m11,5050) 91, parp(91), chparp(91)
64375  WRITE(m11,5050) 93, parp(93), chparp(93)
64376 
64377  ENDIF
64378 
64379 C=======================================================================
64380 C... ACR, tune A with new CR (107)
64381  ELSEIF(itune.EQ.107.OR.itune.EQ.117) THEN
64382  IF (m13.GE.1) THEN
64383  WRITE(m11,5010) itune, chname
64384  ch60='Tune A modified with new colour reconnections'
64385  WRITE(m11,5030) ch60
64386  ch60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
64387  WRITE(m11,5030) ch60
64388  ch60='see P. Skands & D. Wicke, hep-ph/0703081,'
64389  WRITE(m11,5030) ch60
64390  ch60=' R. Field, in hep-ph/0610012 (Tune A),'
64391  WRITE(m11,5030) ch60
64392  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64393  WRITE(m11,5030) ch60
64394  IF (itune.EQ.117) THEN
64395  ch60='LEP parameters tuned by Professor, hep-ph/0907.2973'
64396  WRITE(m11,5030) ch60
64397  ENDIF
64398  ENDIF
64399  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.406))THEN
64400  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
64401  & ' with tune. Using defaults.')
64402  goto 100
64403  ENDIF
64404 
64405 C...Make sure we start from old default fragmentation parameters
64406  parj(81) = 0.29
64407  parj(82) = 1.0
64408 
64409 C...Use Professor's LEP pars if ITUNE >= 110
64410 C...(i.e., for A-Pro, DW-Pro etc)
64411  IF (itune.LT.110) THEN
64412 C...# Old defaults
64413  mstj(11) = 4
64414 C...# Old default flavour parameters
64415  parj(21) = 0.36
64416  parj(41) = 0.30
64417  parj(42) = 0.58
64418  parj(46) = 1.0
64419  parj(82) = 1.0
64420  ELSE
64421 C...# Tuned flavour parameters:
64422  parj(1) = 0.073
64423  parj(2) = 0.2
64424  parj(3) = 0.94
64425  parj(4) = 0.032
64426  parj(11) = 0.31
64427  parj(12) = 0.4
64428  parj(13) = 0.54
64429  parj(25) = 0.63
64430  parj(26) = 0.12
64431 C...# Switch on Bowler:
64432  mstj(11) = 5
64433 C...# Fragmentation
64434  parj(21) = 0.325
64435  parj(41) = 0.5
64436  parj(42) = 0.6
64437  parj(47) = 0.67
64438  parj(81) = 0.29
64439  parj(82) = 1.65
64440  ENDIF
64441 
64442  mstp(81) = 1
64443  parp(89) = 1800d0
64444  parp(90) = 0.25d0
64445  mstp(82) = 4
64446  parp(83) = 0.5d0
64447  parp(84) = 0.4d0
64448  mstp(51) = 7
64449  mstp(52) = 1
64450  parp(71) = 4d0
64451  parp(82) = 2.0d0
64452  parp(85) = 0.0d0
64453  parp(86) = 0.66d0
64454  parp(62) = 1d0
64455  parp(64) = 1d0
64456  parp(67) = 4d0
64457  mstp(91) = 1
64458  parp(91) = 1d0
64459  parp(93) = 5d0
64460  mstp(95) = 6
64461 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
64462  parp(78) = 0.09d0
64463 C...Frag functions (only if not using Professor)
64464  IF (itune.LE.109) THEN
64465  mstj(11) = 4
64466  parj(54) = -0.05
64467  parj(55) = -0.005
64468  ENDIF
64469 
64470 C...Output
64471  IF (m13.GE.1) THEN
64472  WRITE(m11,5030) ' '
64473  WRITE(m11,5040) 51, mstp(51), chmstp(51)
64474  WRITE(m11,5040) 52, mstp(52), chmstp(52)
64475  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
64476  WRITE(m11,5050) 62, parp(62), chparp(62)
64477  WRITE(m11,5050) 64, parp(64), chparp(64)
64478  WRITE(m11,5050) 67, parp(67), chparp(67)
64479  WRITE(m11,5040) 68, mstp(68), chmstp(68)
64480  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64481  WRITE(m11,5030) ch60
64482  WRITE(m11,5050) 71, parp(71), chparp(71)
64483  WRITE(m11,5060) 81, parj(81), chparj(81)
64484  WRITE(m11,5060) 82, parj(82), chparj(82)
64485  WRITE(m11,5040) 33, mstp(33), chmstp(33)
64486  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64487  WRITE(m11,5050) 82, parp(82), chparp(82)
64488  WRITE(m11,5050) 89, parp(89), chparp(89)
64489  WRITE(m11,5050) 90, parp(90), chparp(90)
64490  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64491  WRITE(m11,5050) 83, parp(83), chparp(83)
64492  WRITE(m11,5050) 84, parp(84), chparp(84)
64493  IF (mstp(82).GE.2) THEN
64494  WRITE(m11,5050) 87, parp(87), chparp(87)
64495  IF (parp(87).GE.0d0)
64496  & WRITE(m11,5050) 88, parp(88), chparp(88)
64497  ENDIF
64498  WRITE(m11,5050) 85, parp(85), chparp(85)
64499  WRITE(m11,5050) 86, parp(86), chparp(86)
64500  WRITE(m11,5040) 91, mstp(91), chmstp(91)
64501  WRITE(m11,5050) 91, parp(91), chparp(91)
64502  WRITE(m11,5050) 93, parp(93), chparp(93)
64503  WRITE(m11,5040) 95, mstp(95), chmstp(95)
64504  WRITE(m11,5050) 78, parp(78), chparp(78)
64505 
64506  ENDIF
64507 
64508 C=======================================================================
64509 C...Intermediate model. Rap tune
64510 C...(retuned to post-6.406 IR factorization)
64511  ELSEIF(itune.EQ.200) THEN
64512  IF (m13.GE.1) THEN
64513  WRITE(m11,5010) itune, chname
64514  ch60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
64515  WRITE(m11,5030) ch60
64516  ENDIF
64517  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
64518  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
64519  & ' with tune.')
64520  ENDIF
64521 C...PDF
64522  mstp(51) = 7
64523  mstp(52) = 1
64524 C...ISR
64525  parp(62) = 1d0
64526  parp(64) = 1d0
64527  parp(67) = 4d0
64528 C...FSR
64529  parp(71) = 4d0
64530  parj(81) = 0.29d0
64531 C...UE
64532  mstp(81) = 11
64533  parp(82) = 2.25d0
64534  parp(89) = 1800d0
64535  parp(90) = 0.25d0
64536 C... ExpOfPow(1.8) overlap profile
64537  mstp(82) = 5
64538  parp(83) = 1.8d0
64539 C... Valence qq
64540  mstp(88) = 0
64541 C... Rap Tune
64542  mstp(89) = 1
64543 C... Default diquark, BR-g-BR supp
64544  parp(79) = 2d0
64545  parp(80) = 0.01d0
64546 C... Final state reconnect.
64547  mstp(95) = 1
64548  parp(78) = 0.55d0
64549 C...Fragmentation functions and c and b parameters
64550  mstj(11) = 4
64551  parj(54) = -0.05
64552  parj(55) = -0.005
64553 C... Output
64554  IF (m13.GE.1) THEN
64555  WRITE(m11,5030) ' '
64556  WRITE(m11,5040) 51, mstp(51), chmstp(51)
64557  WRITE(m11,5040) 52, mstp(52), chmstp(52)
64558  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
64559  WRITE(m11,5050) 62, parp(62), chparp(62)
64560  WRITE(m11,5050) 64, parp(64), chparp(64)
64561  WRITE(m11,5050) 67, parp(67), chparp(67)
64562  WRITE(m11,5040) 68, mstp(68), chmstp(68)
64563  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64564  WRITE(m11,5030) ch60
64565  WRITE(m11,5050) 71, parp(71), chparp(71)
64566  WRITE(m11,5060) 81, parj(81), chparj(81)
64567  WRITE(m11,5040) 33, mstp(33), chmstp(33)
64568  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64569  WRITE(m11,5050) 82, parp(82), chparp(82)
64570  WRITE(m11,5050) 89, parp(89), chparp(89)
64571  WRITE(m11,5050) 90, parp(90), chparp(90)
64572  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64573  WRITE(m11,5050) 83, parp(83), chparp(83)
64574  IF (mstp(82).GE.2) THEN
64575  WRITE(m11,5050) 87, parp(87), chparp(87)
64576  IF (parp(87).GE.0d0)
64577  & WRITE(m11,5050) 88, parp(88), chparp(88)
64578  ENDIF
64579  WRITE(m11,5040) 88, mstp(88), chmstp(88)
64580  WRITE(m11,5040) 89, mstp(89), chmstp(89)
64581  WRITE(m11,5050) 79, parp(79), chparp(79)
64582  WRITE(m11,5050) 80, parp(80), chparp(80)
64583  WRITE(m11,5050) 93, parp(93), chparp(93)
64584  WRITE(m11,5040) 95, mstp(95), chmstp(95)
64585  WRITE(m11,5050) 78, parp(78), chparp(78)
64586 
64587  ENDIF
64588 
64589 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
64590 C...Old model for ISR and UE, new pT-ordered model for FSR
64591  ELSEIF(itune.EQ.201.OR.itune.EQ.211.OR.itune.EQ.221.or
64592  & .itune.EQ.226) THEN
64593  IF (m13.GE.1) THEN
64594  WRITE(m11,5010) itune, chname
64595  ch60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
64596  WRITE(m11,5030) ch60
64597  ch60=' R.D. Field, in hep-ph/0610012 (Tune A)'
64598  WRITE(m11,5030) ch60
64599  ch60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64600  WRITE(m11,5030) ch60
64601  ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
64602  WRITE(m11,5030) ch60
64603  IF (itune.EQ.211.OR.itune.GE.221) THEN
64604  ch60='LEP parameters tuned by Professor, hep-ph/0907.2973'
64605  WRITE(m11,5030) ch60
64606  ENDIF
64607  ENDIF
64608  IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.411))THEN
64609  CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
64610  & ' with tune.')
64611  ENDIF
64612 C...First set as if Pythia tune A
64613 C...Multiple interactions on, old framework
64614  mstp(81) = 1
64615 C...Fast IR cutoff energy scaling by default
64616  parp(89) = 1800d0
64617  parp(90) = 0.25d0
64618 C...Default CTEQ5L (internal)
64619  mstp(51) = 7
64620  mstp(52) = 1
64621 C...Double Gaussian matter distribution.
64622  mstp(82) = 4
64623  parp(83) = 0.5d0
64624  parp(84) = 0.4d0
64625 C...FSR activity.
64626  parp(71) = 4d0
64627 c...String drawing almost completely minimizes string length.
64628  parp(85) = 0.9d0
64629  parp(86) = 0.95d0
64630 C...ISR cutoff, muR scale factor, and phase space size
64631  parp(62) = 1d0
64632  parp(64) = 1d0
64633  parp(67) = 4d0
64634 C...Intrinsic kT, size, and max
64635  mstp(91) = 1
64636  parp(91) = 1d0
64637  parp(93) = 5d0
64638 C...Use 2 GeV of primordial kT for "Perugia" version
64639  IF (itune.EQ.221) THEN
64640  parp(91) = 2d0
64641  parp(93) = 10d0
64642  ENDIF
64643 C...Use pT-ordered FSR
64644  mstj(41) = 12
64645 C...Lambda_FSR scale for pT-ordering
64646  parj(81) = 0.23d0
64647 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
64648  parp(82) = 2.05d0
64649 C...Fragmentation functions and c and b parameters
64650 C...(overwritten for 211, i.e., if using Professor pars)
64651  parj(54) = -0.05
64652  parj(55) = -0.005
64653 
64654 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
64655  IF (itune.LT.210) THEN
64656 C...# Old defaults
64657  mstj(11) = 4
64658 C...# Old default flavour parameters
64659  parj(21) = 0.36
64660  parj(41) = 0.30
64661  parj(42) = 0.58
64662  parj(46) = 1.0
64663  parj(82) = 1.0
64664  ELSE
64665 C...# Tuned flavour parameters:
64666  parj(1) = 0.073
64667  parj(2) = 0.2
64668  parj(3) = 0.94
64669  parj(4) = 0.032
64670  parj(11) = 0.31
64671  parj(12) = 0.4
64672  parj(13) = 0.54
64673  parj(25) = 0.63
64674  parj(26) = 0.12
64675 C...# Always use pT-ordered shower:
64676  mstj(41) = 12
64677 C...# Switch on Bowler:
64678  mstj(11) = 5
64679 C...# Fragmentation
64680  parj(21) = 3.1327e-01
64681  parj(41) = 4.8989e-01
64682  parj(42) = 1.2018e+00
64683  parj(47) = 1.0000e+00
64684  parj(81) = 2.5696e-01
64685  parj(82) = 8.0000e-01
64686  ENDIF
64687 
64688 C...221, 226 : Perugia-APT and Perugia-APT6
64689  IF (itune.EQ.221.OR.itune.EQ.226) THEN
64690 
64691  parp(64) = 0.5d0
64692  parp(82) = 2.05d0
64693  parp(90) = 0.26d0
64694  parp(91) = 2.0d0
64695 C...The Perugia variants use Steve's showers off the old MPI
64696  mstp(152) = 1
64697 C...And use a lower PARP(71) as suggested by Professor tunings
64698 C...(although not certain that applies to Q2-pT2 hybrid)
64699  parp(71) = 2.5d0
64700 
64701 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
64702  IF (itune.EQ.226) THEN
64703  ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
64704  & 'externally linked'
64705  WRITE(m11,5035) ch70
64706  mstp(52) = 2
64707  mstp(51) = 10042
64708  parp(82) = 1.95d0
64709  ENDIF
64710 
64711  ENDIF
64712 
64713 C... Output
64714  IF (m13.GE.1) THEN
64715  WRITE(m11,5030) ' '
64716  WRITE(m11,5040) 51, mstp(51), chmstp(51)
64717  WRITE(m11,5040) 52, mstp(52), chmstp(52)
64718  WRITE(m11,5040) 3, mstp( 3), chmstp( 3)
64719  WRITE(m11,5050) 62, parp(62), chparp(62)
64720  WRITE(m11,5050) 64, parp(64), chparp(64)
64721  WRITE(m11,5050) 67, parp(67), chparp(67)
64722  WRITE(m11,5040) 68, mstp(68), chmstp(68)
64723  ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64724  WRITE(m11,5030) ch60
64725  WRITE(m11,5070) 41, mstj(41), chmstj(41)
64726  WRITE(m11,5050) 71, parp(71), chparp(71)
64727  WRITE(m11,5060) 81, parj(81), chparj(81)
64728  WRITE(m11,5040) 33, mstp(33), chmstp(33)
64729  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64730  WRITE(m11,5050) 82, parp(82), chparp(82)
64731  WRITE(m11,5050) 89, parp(89), chparp(89)
64732  WRITE(m11,5050) 90, parp(90), chparp(90)
64733  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64734  WRITE(m11,5050) 83, parp(83), chparp(83)
64735  WRITE(m11,5050) 84, parp(84), chparp(84)
64736  IF (mstp(82).GE.2) THEN
64737  WRITE(m11,5050) 87, parp(87), chparp(87)
64738  IF (parp(87).GE.0d0)
64739  & WRITE(m11,5050) 88, parp(88), chparp(88)
64740  ENDIF
64741  WRITE(m11,5050) 85, parp(85), chparp(85)
64742  WRITE(m11,5050) 86, parp(86), chparp(86)
64743  WRITE(m11,5040) 91, mstp(91), chmstp(91)
64744  WRITE(m11,5050) 91, parp(91), chparp(91)
64745  WRITE(m11,5050) 93, parp(93), chparp(93)
64746 
64747  ENDIF
64748 
64749 C======================================================================
64750 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
64751  ELSEIF(chname.EQ.'GAL Tune 0'.OR.chname.EQ.'GAL Tune 1') THEN
64752  IF (m13.GE.1) THEN
64753  WRITE(m11,5010) itune, chname
64754  ch60='see J. Rathsman, PLB452(1999)364'
64755  WRITE(m11,5030) ch60
64756  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64757  WRITE(m11,5030) ch60
64758  ENDIF
64759 C...GAL Recommended settings from Uppsala web page
64760  mstp(95) = 13
64761  parp(78) = 0.10
64762  mstj(16) = 0
64763  parj(42) = 0.45
64764  parj(82) = 2.0
64765  parp(62) = 2.0
64766  mstp(81) = 1
64767  mstp(82) = 1
64768  parp(81) = 1.9
64769  mstp(92) = 1
64770  IF(chname.EQ.'GAL Tune 1') THEN
64771 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
64772  mstp(82) = 4
64773  parp(83) = 0.25d0
64774  parp(84) = 0.5d0
64775  parp(82) = 1.75
64776  IF (m13.GE.1) THEN
64777  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64778  WRITE(m11,5050) 82, parp(82), chparp(82)
64779  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64780  WRITE(m11,5050) 83, parp(83), chparp(83)
64781  WRITE(m11,5050) 84, parp(84), chparp(84)
64782  ENDIF
64783  ELSE
64784  IF (m13.GE.1) THEN
64785  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64786  WRITE(m11,5050) 81, parp(81), chparp(81)
64787  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64788  ENDIF
64789  ENDIF
64790 C...Output
64791  IF (m13.GE.1) THEN
64792  WRITE(m11,5050) 62, parp(62), chparp(62)
64793  WRITE(m11,5060) 82, parj(82), chparj(82)
64794  WRITE(m11,5040) 92, mstp(92), chmstp(92)
64795  WRITE(m11,5040) 95, mstp(95), chmstp(95)
64796  WRITE(m11,5050) 78, parp(78), chparp(78)
64797  WRITE(m11,5060) 42, parj(42), chparj(42)
64798  WRITE(m11,5070) 16, mstj(16), chmstj(16)
64799  ENDIF
64800  ELSEIF(chname.EQ.'SCI Tune 0'.OR.chname.EQ.'SCI Tune 1') THEN
64801  IF (m13.GE.1) THEN
64802  WRITE(m11,5010) itune, chname
64803  ch60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
64804  WRITE(m11,5030) ch60
64805  ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64806  WRITE(m11,5030) ch60
64807  WRITE(m11,5030) ' '
64808  ch70='NB! The SCI model must be run with modified '//
64809  & 'Pythia v6.215:'
64810  WRITE(m11,5035) ch70
64811  ch70='available from http://www.isv.uu.se/thep/MC/scigal/'
64812  WRITE(m11,5035) ch70
64813  WRITE(m11,5030) ' '
64814  ENDIF
64815 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
64816  mstp(81) = 1
64817  mstp(82) = 1
64818  parp(81) = 2.2
64819  mstp(92) = 1
64820  mstp(95) = 11
64821  parp(78) = 0.50
64822  mstj(16) = 0
64823  IF (chname.EQ.'SCI Tune 1') THEN
64824 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
64825  mstp(81) = 1
64826  mstp(82) = 3
64827  parp(82) = 2.4
64828  parp(83) = 0.5d0
64829  parp(62) = 1.5
64830  parp(84) = 0.25d0
64831  IF (m13.GE.1) THEN
64832  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64833  WRITE(m11,5050) 82, parp(82), chparp(82)
64834  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64835  WRITE(m11,5050) 83, parp(83), chparp(83)
64836  WRITE(m11,5050) 62, parp(62), chparp(62)
64837  ENDIF
64838  ELSE
64839  IF (m13.GE.1) THEN
64840  WRITE(m11,5040) 81, mstp(81), chmstp(81)
64841  WRITE(m11,5050) 81, parp(81), chparp(81)
64842  WRITE(m11,5040) 82, mstp(82), chmstp(82)
64843  ENDIF
64844  ENDIF
64845 C...Output
64846  IF (m13.GE.1) THEN
64847  WRITE(m11,5040) 92, mstp(92), chmstp(92)
64848  WRITE(m11,5040) 95, mstp(95), chmstp(95)
64849  WRITE(m11,5050) 78, parp(78), chparp(78)
64850  WRITE(m11,5070) 16, mstj(16), chmstj(16)
64851  ENDIF
64852 
64853  ELSE
64854  IF (mstu(13).GE.1) WRITE(m11,5020) itune
64855 
64856  ENDIF
64857 
64858 C...Output of LEP parameters, common to all models
64859  IF (m13.GE.1) THEN
64860  WRITE(m11,5080)
64861  WRITE(m11,5070) 11, mstj(11), chmstj(11)
64862  IF (mstj(11).EQ.3) THEN
64863  ch60='Warning: using Peterson fragmentation function'
64864  WRITE(m11,5030) ch60
64865  ENDIF
64866 
64867  WRITE(m11,5060) 1, parj( 1), chparj( 1)
64868  WRITE(m11,5060) 2, parj( 2), chparj( 2)
64869  WRITE(m11,5060) 3, parj( 3), chparj( 3)
64870  WRITE(m11,5060) 4, parj( 4), chparj( 4)
64871  WRITE(m11,5060) 5, parj( 5), chparj( 5)
64872  WRITE(m11,5060) 6, parj( 6), chparj( 6)
64873  WRITE(m11,5060) 7, parj( 7), chparj( 7)
64874 
64875  WRITE(m11,5060) 11, parj(11), chparj(11)
64876  WRITE(m11,5060) 12, parj(12), chparj(12)
64877  WRITE(m11,5060) 13, parj(13), chparj(13)
64878 
64879  WRITE(m11,5060) 14, parj(14), chparj(14)
64880  WRITE(m11,5060) 15, parj(15), chparj(15)
64881  WRITE(m11,5060) 16, parj(16), chparj(16)
64882  WRITE(m11,5060) 17, parj(17), chparj(17)
64883  WRITE(m11,5060) 18, parj(18), chparj(18)
64884  WRITE(m11,5060) 19, parj(19), chparj(19)
64885 
64886  WRITE(m11,5060) 21, parj(21), chparj(21)
64887 
64888  WRITE(m11,5060) 25, parj(25), chparj(25)
64889  WRITE(m11,5060) 26, parj(26), chparj(26)
64890 
64891  WRITE(m11,5060) 41, parj(41), chparj(41)
64892  WRITE(m11,5060) 42, parj(42), chparj(42)
64893  WRITE(m11,5060) 45, parj(45), chparj(45)
64894 
64895  IF (mstj(11).LE.3) THEN
64896  WRITE(m11,5060) 54, parj(54), chparj(54)
64897  WRITE(m11,5060) 55, parj(55), chparj(55)
64898  ELSE
64899  WRITE(m11,5060) 46, parj(46), chparj(46)
64900  ENDIF
64901  IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
64902  ENDIF
64903 
64904  100 IF (mstu(13).GE.1) WRITE(m11,6000)
64905 
64906  9999 RETURN
64907 
64908  5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ',
64909  & 'Presets for underlying-event (and min-bias)',21x,'*'/' *',
64910  & 12x,'Last Change : ',a8,' - P. Skands',30x,'*'/' *',76x,'*')
64911  5010 FORMAT(' *',3x,i4,1x,a16,52x,'*')
64912  5020 FORMAT(' *',3x,'Tune ',i4, ' not recognized. Using defaults.')
64913  5030 FORMAT(' *',3x,10x,a60,3x,'*')
64914  5035 FORMAT(' *',3x,a70,3x,'*')
64915  5040 FORMAT(' *',5x,'MSTP(',i2,') = ',i12,3x,a42,3x,'*')
64916  5050 FORMAT(' *',5x,'PARP(',i2,') = ',f12.4,3x,a40,5x,'*')
64917  5060 FORMAT(' *',5x,'PARJ(',i2,') = ',f12.4,3x,a40,5x,'*')
64918  5070 FORMAT(' *',5x,'MSTJ(',i2,') = ',i12,3x,a40,5x,'*')
64919  5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*')
64920  6100 FORMAT(' *',5x,'MSTU(',i3,')= ',i12,3x,a42,3x,'*')
64921  6110 FORMAT(' *',5x,'PARU(',i3,')= ',f12.4,3x,a42,3x,'*')
64922 C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
64923 C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
64924  6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
64925 C 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
64926 C 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
64927 
64928  END
64929 
64930 C*********************************************************************
64931 
64932 C...PYEXEC
64933 C...Administrates the fragmentation and decay chain.
64934 
64935  SUBROUTINE pyexec
64936 
64937 C...Double precision and integer declarations.
64938  IMPLICIT DOUBLE PRECISION(a-h, o-z)
64939  IMPLICIT INTEGER(i-n)
64940  INTEGER pyk,pychge,pycomp
64941 C...Commonblocks.
64942  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
64943  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
64944  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
64945  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
64946  common/pyint1/mint(400),vint(400)
64947  common/pyint4/mwid(500),wids(500,5)
64948  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint1/,/pyint4/
64949 C...Local array.
64950  dimension ps(2,6),ijoin(100)
64951 
64952 C...Initialize and reset.
64953  mstu(24)=0
64954  IF(mstu(12).NE.12345) CALL pylist(0)
64955  mstu(29)=0
64956  mstu(31)=mstu(31)+1
64957  mstu(1)=0
64958  mstu(2)=0
64959  mstu(3)=0
64960  IF(mstu(17).LE.0) mstu(90)=0
64961  mcons=1
64962 
64963 C...Sum up momentum, energy and charge for starting entries.
64964  nsav=n
64965  DO 110 i=1,2
64966  DO 100 j=1,6
64967  ps(i,j)=0d0
64968  100 CONTINUE
64969  110 CONTINUE
64970  DO 130 i=1,n
64971  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 130
64972  DO 120 j=1,4
64973  ps(1,j)=ps(1,j)+p(i,j)
64974  120 CONTINUE
64975  ps(1,6)=ps(1,6)+pychge(k(i,2))
64976  130 CONTINUE
64977  paru(21)=ps(1,4)
64978 
64979 C...Start by all decays of coloured resonances involved in shower.
64980  norig=n
64981  DO 140 i=1,norig
64982  IF(k(i,1).EQ.3) THEN
64983  kc=pycomp(k(i,2))
64984  IF(mwid(kc).NE.0.AND.kchg(kc,2).NE.0) CALL pyresd(i)
64985  ENDIF
64986  140 CONTINUE
64987 
64988 C...Prepare system for subsequent fragmentation/decay.
64989  CALL pyprep(0)
64990  IF(mint(51).NE.0) RETURN
64991 
64992 C...Loop through jet fragmentation and particle decays.
64993  mbe=0
64994  150 mbe=mbe+1
64995  ip=0
64996  160 ip=ip+1
64997  kc=0
64998  IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=pycomp(k(ip,2))
64999  IF(kc.EQ.0) THEN
65000 
65001 C...Deal with any remaining undecayed resonance
65002 C...(normally the task of PYEVNT, so seldom used).
65003  ELSEIF(mwid(kc).NE.0) THEN
65004  ibeg=ip
65005  IF(kchg(kc,2).NE.0.AND.k(i,1).NE.3) THEN
65006  ibeg=ip+1
65007  170 ibeg=ibeg-1
65008  IF(ibeg.GE.2.AND.k(ibeg,1).EQ.2) goto 170
65009  IF(k(ibeg,1).NE.2) ibeg=ibeg+1
65010  iend=ip-1
65011  180 iend=iend+1
65012  IF(iend.LT.n.AND.k(iend,1).EQ.2) goto 180
65013  IF(iend.LT.n.AND.kchg(pycomp(k(iend,2)),2).EQ.0) goto 180
65014  njoin=0
65015  DO 190 i=ibeg,iend
65016  IF(kchg(pycomp(k(iend,2)),2).NE.0) THEN
65017  njoin=njoin+1
65018  ijoin(njoin)=i
65019  ENDIF
65020  190 CONTINUE
65021  ENDIF
65022  CALL pyresd(ip)
65023  CALL pyprep(ibeg)
65024  IF(mint(51).NE.0) RETURN
65025 
65026 C...Particle decay if unstable and allowed. Save long-lived particle
65027 C...decays until second pass after Bose-Einstein effects.
65028  ELSEIF(kchg(kc,2).EQ.0) THEN
65029  IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe
65030  & .EQ.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
65031  & CALL pydecy(ip)
65032 
65033 C...Decay products may develop a shower.
65034  IF(mstj(92).GT.0) THEN
65035  ip1=mstj(92)
65036  qmax=sqrt(max(0d0,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
65037  & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
65038  mint(33)=0
65039  CALL pyshow(ip1,ip1+1,qmax)
65040  CALL pyprep(ip1)
65041  IF(mint(51).NE.0) RETURN
65042  mstj(92)=0
65043  ELSEIF(mstj(92).LT.0) THEN
65044  ip1=-mstj(92)
65045  mint(33)=0
65046  CALL pyshow(ip1,-3,p(ip,5))
65047  CALL pyprep(ip1)
65048  IF(mint(51).NE.0) RETURN
65049  mstj(92)=0
65050  ENDIF
65051 
65052 C...Jet fragmentation: string or independent fragmentation.
65053  ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
65054  mfrag=mstj(1)
65055  IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
65056  IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
65057  IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
65058  & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
65059  IF(kchg(pycomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
65060  ENDIF
65061  ENDIF
65062  IF(mfrag.EQ.1) CALL pystrf(ip)
65063  IF(mfrag.EQ.2) CALL pyindf(ip)
65064  IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
65065  IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
65066  ENDIF
65067 
65068 C...Loop back if enough space left in PYJETS and no error abort.
65069  IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
65070  ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
65071  goto 160
65072  ELSEIF(ip.LT.n) THEN
65073  CALL pyerrm(11,'(PYEXEC:) no more memory left in PYJETS')
65074  ENDIF
65075 
65076 C...Include simple Bose-Einstein effect parametrization if desired.
65077  IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
65078  CALL pyboei(nsav)
65079  goto 150
65080  ENDIF
65081 
65082 C...Check that momentum, energy and charge were conserved.
65083  DO 210 i=1,n
65084  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 210
65085  DO 200 j=1,4
65086  ps(2,j)=ps(2,j)+p(i,j)
65087  200 CONTINUE
65088  ps(2,6)=ps(2,6)+pychge(k(i,2))
65089  210 CONTINUE
65090  pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
65091  &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1d0+abs(ps(2,4))+abs(ps(1,4)))
65092  IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL pyerrm(15,
65093  &'(PYEXEC:) four-momentum was not conserved')
65094  IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1d0) CALL pyerrm(15,
65095  &'(PYEXEC:) charge was not conserved')
65096 
65097  RETURN
65098  END
65099 
65100 C*********************************************************************
65101 
65102 C...PYPREP
65103 C...Rearranges partons along strings.
65104 C...Special considerations for systems with junctions, with
65105 C...possibility of junction-antijunction annihilation.
65106 C...Allows small systems to collapse into one or two particles.
65107 C...Checks flavours and colour singlet invariant masses.
65108 
65109  SUBROUTINE pyprep(IP)
65110 
65111 C...Double precision and integer declarations.
65112  IMPLICIT DOUBLE PRECISION(a-h, o-z)
65113  INTEGER pyk,pychge,pycomp
65114 C...Commonblocks.
65115  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
65116  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
65117  common/pypars/mstp(200),parp(200),msti(200),pari(200)
65118  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
65119  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
65120  common/pyint1/mint(400),vint(400)
65121 C...The common block of colour tags.
65122  common/pyctag/nct,mct(4000,2)
65123  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint1/,/pyctag/,
65124  &/pypars/
65125  DATA nerrpr/0/
65126  SAVE nerrpr
65127 C...Local arrays.
65128  dimension dps(5),dpc(5),ue(3),pg(5),e1(3),e2(3),e3(3),e4(3),
65129  &ecl(3),ijunc(10,0:4),ipiece(30,0:4),kfend(4),kfq(4),
65130  &ijur(4),pju(4,6),irng(4,2),tjj(2,5),t(5),pul(3,5),
65131  &ijcp(0:6),tjuold(5)
65132  CHARACTER chtmp*6
65133 
65134 C...Function to give four-product.
65135  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)
65136 
65137 C...Rearrange parton shower product listing along strings: begin loop.
65138  mstu(24)=0
65139  nold=n
65140  i1=n
65141  njunc=0
65142  npiece=0
65143  njjstr=0
65144  mstu32=mstu(32)+1
65145  DO 100 i=max(1,ip),n
65146 C...First store junction positions.
65147  IF(k(i,1).EQ.42) THEN
65148  njunc=njunc+1
65149  ijunc(njunc,0)=i
65150  ijunc(njunc,4)=0
65151  ENDIF
65152  100 CONTINUE
65153 
65154  DO 250 mqgst=1,3
65155  DO 240 i=max(1,ip),n
65156 C...Special treatment for junctions
65157  IF (k(i,1).LE.0) goto 240
65158  IF(k(i,1).EQ.42) THEN
65159 C...MQGST=2: Look for junction-junction strings (not detected in the
65160 C...main search below).
65161  IF (mqgst.EQ.2.AND.npiece.NE.3*njunc) THEN
65162  IF (njjstr.EQ.0) THEN
65163  njjstr = (3*njunc-npiece)/2
65164  ENDIF
65165 C...Check how many already identified strings end on this junction
65166  ilc=0
65167  DO 110 j=1,npiece
65168  IF (ipiece(j,4).EQ.i) ilc=ilc+1
65169  110 CONTINUE
65170 C...If less than 3, remaining must be to another junction
65171  IF (ilc.LT.3) THEN
65172  IF (ilc.NE.2) THEN
65173 C...Multiple j-j connections not handled yet.
65174  CALL pyerrm(2,
65175  & '(PYPREP:) Too many junction-junction strings.')
65176  mint(51)=1
65177  RETURN
65178  ENDIF
65179 C...The colour information in the junction is unreadable for the
65180 C...colour space search further down in this routine, so we must
65181 C...start on the colour mother of this junction and then "artificially"
65182 C...prevent the colour mother from connecting here again.
65183  itjunc=mod(k(i,4)/mstu(5),mstu(5))
65184  kcs=4
65185  IF (mod(itjunc,2).EQ.0) kcs=5
65186 C...Switch colour if the junction-junction leg is presumably a
65187 C...junction mother leg rather than a junction daughter leg.
65188  IF (itjunc.GE.3) kcs=9-kcs
65189  IF (mint(33).EQ.0) THEN
65190 C...Find the unconnected leg and reorder junction daughter pointers so
65191 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
65192 C...piece.
65193  ia=mod(k(i,4),mstu(5))
65194  IF (k(ia,kcs)/mstu(5)**2.GE.2) THEN
65195  itmp=mod(k(i,5),mstu(5))
65196  IF (k(itmp,kcs)/mstu(5)**2.GE.2) THEN
65197  itmp=mod(k(i,5)/mstu(5),mstu(5))
65198  k(i,5)=k(i,5)+(ia-itmp)*mstu(5)
65199  ELSE
65200  k(i,5)=k(i,5)+(ia-itmp)
65201  ENDIF
65202  k(i,4)=k(i,4)+(itmp-ia)
65203  ia=itmp
65204  ENDIF
65205  IF (itjunc.LE.2) THEN
65206 C...Beam baryon junction
65207  k(ia,kcs) = k(ia,kcs) + 2*mstu(5)**2
65208  k(i,kcs) = k(i,kcs) + 1*mstu(5)**2
65209 C...Else 1 -> 2 decay junction
65210  ELSE
65211  k(ia,kcs) = k(ia,kcs) + mstu(5)**2
65212  k(i,kcs) = k(i,kcs) + 2*mstu(5)**2
65213  ENDIF
65214  i1beg = i1
65215  nstp = 0
65216  goto 170
65217 C...Alternatively use colour tag information.
65218  ELSE
65219 C...Find a final state parton with appropriate dangling colour tag.
65220  jct=0
65221  ia=0
65222  ijumo=k(i,3)
65223  DO 140 j1=max(1,ip),n
65224  IF (k(j1,1).NE.3) goto 140
65225 C...Check for matching final-state colour tag
65226  imatch=0
65227  DO 120 j2=max(1,ip),n
65228  IF (k(j2,1).NE.3) goto 120
65229  IF (mct(j1,kcs-3).EQ.mct(j2,6-kcs)) imatch=1
65230  120 CONTINUE
65231  IF (imatch.EQ.1) goto 140
65232 C...Check whether this colour tag belongs to the present junction
65233 C...by seeing whether any parton with this colour tag has the same
65234 C...mother as the junction.
65235  jct=mct(j1,kcs-3)
65236  imatch=0
65237  DO 130 j2=mint(84)+1,n
65238  imo2=k(j2,3)
65239 C...First scattering partons have IMO1 = 3 and 4.
65240  IF (imo2.EQ.mint(83)+3.OR.imo2.EQ.mint(83)+4)
65241  & imo2=imo2-2
65242  IF (mct(j2,kcs-3).EQ.jct.AND.imo2.EQ.ijumo)
65243  & imatch=1
65244  130 CONTINUE
65245  IF (imatch.EQ.0) goto 140
65246  ia=j1
65247  140 CONTINUE
65248 C...Check for junction-junction strings without intermediate final state
65249 C...glue (not detected above).
65250  IF (ia.EQ.0) THEN
65251  DO 160 mju=1,njunc
65252  iju2=ijunc(mju,0)
65253  IF (iju2.EQ.i) goto 160
65254  itju2=mod(k(iju2,4)/mstu(5),mstu(5))
65255 C...Only opposite types of junctions can connect to each other.
65256  IF (mod(itju2,2).EQ.mod(itjunc,2)) goto 160
65257  is=0
65258  DO 150 j=1,npiece
65259  IF (ipiece(j,4).EQ.iju2) is=is+1
65260  150 CONTINUE
65261  IF (is.EQ.3) goto 160
65262  ib=i
65263  ia=iju2
65264  160 CONTINUE
65265  ENDIF
65266 C...Switch to other side of adjacent parton and step from there.
65267  kcs=9-kcs
65268  i1beg = i1
65269  nstp = 0
65270  goto 170
65271  ENDIF
65272  ELSE IF (ilc.NE.3) THEN
65273  ENDIF
65274  ENDIF
65275  ENDIF
65276 
65277 C...Look for coloured string endpoint, or (later) leftover gluon.
65278  IF(k(i,1).NE.3) goto 240
65279  kc=pycomp(k(i,2))
65280  IF(kc.EQ.0) goto 240
65281  kq=kchg(kc,2)
65282  IF(kq.EQ.0.OR.(mqgst.LE.2.AND.kq.EQ.2)) goto 240
65283 
65284 C...Pick up loose string end.
65285  kcs=4
65286  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
65287  ia=i
65288  ib=i
65289  i1beg=i1
65290  nstp=0
65291  170 nstp=nstp+1
65292  IF(nstp.GT.4*n) THEN
65293  CALL pyerrm(14,'(PYPREP:) caught in infinite loop')
65294  mint(51)=1
65295  RETURN
65296  ENDIF
65297 
65298 C...Copy undecayed parton. Finished if reached string endpoint.
65299  IF(k(ia,1).EQ.3) THEN
65300  IF(i1.GE.mstu(4)-mstu32-5) THEN
65301  CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
65302  mint(51)=1
65303  mstu(24)=1
65304  RETURN
65305  ENDIF
65306  i1=i1+1
65307  k(i1,1)=2
65308  IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) k(i1,1)=1
65309  k(i1,2)=k(ia,2)
65310  k(i1,3)=ia
65311  k(i1,4)=0
65312  k(i1,5)=0
65313  DO 180 j=1,5
65314  p(i1,j)=p(ia,j)
65315  v(i1,j)=v(ia,j)
65316  180 CONTINUE
65317  k(ia,1)=k(ia,1)+10
65318  IF(k(i1,1).EQ.1) goto 240
65319  ENDIF
65320 
65321 C...Also finished (for now) if reached junction; then copy to end.
65322  IF(k(ia,1).EQ.42) THEN
65323  ncopy=i1-i1beg
65324  IF(i1.GE.mstu(4)-mstu32-ncopy-5) THEN
65325  CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
65326  mint(51)=1
65327  mstu(24)=1
65328  RETURN
65329  ENDIF
65330  IF (mqgst.LE.2.AND.ncopy.NE.0) THEN
65331  DO 200 icopy=1,ncopy
65332  DO 190 j=1,5
65333  k(mstu(4)-mstu32-icopy,j)=k(i1beg+icopy,j)
65334  p(mstu(4)-mstu32-icopy,j)=p(i1beg+icopy,j)
65335  v(mstu(4)-mstu32-icopy,j)=v(i1beg+icopy,j)
65336  190 CONTINUE
65337  200 CONTINUE
65338  ENDIF
65339 C...For junction-junction strings, find end leg and reorder junction
65340 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
65341 C...junction-junction string piece.
65342  IF (k(i,1).EQ.42.AND.mint(33).EQ.0) THEN
65343  itmp=mod(k(ia,4),mstu(5))
65344  IF (itmp.NE.ib) THEN
65345  IF (mod(k(ia,5),mstu(5)).EQ.ib) THEN
65346  k(ia,5)=k(ia,5)+(itmp-ib)
65347  ELSE
65348  k(ia,5)=k(ia,5)+(itmp-ib)*mstu(5)
65349  ENDIF
65350  k(ia,4)=k(ia,4)+(ib-itmp)
65351  ENDIF
65352  ENDIF
65353  npiece=npiece+1
65354 C...IPIECE:
65355 C...0: endpoint in original ER
65356 C...1:
65357 C...2:
65358 C...3: Parton immediately next to junction
65359 C...4: Junction
65360  ipiece(npiece,0)=i
65361  ipiece(npiece,1)=mstu32+1
65362  ipiece(npiece,2)=mstu32+ncopy
65363  ipiece(npiece,3)=ib
65364  ipiece(npiece,4)=ia
65365  mstu32=mstu32+ncopy
65366  i1=i1beg
65367  goto 240
65368  ENDIF
65369 
65370 C...GOTO next parton in colour space.
65371  ib=ia
65372  IF (mint(33).EQ.0) THEN
65373  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5
65374  & )).NE.0) THEN
65375  ia=mod(k(ib,kcs),mstu(5))
65376  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
65377  mrev=0
65378  ELSE
65379  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
65380  & mstu(5)).EQ.0) kcs=9-kcs
65381  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
65382  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
65383  mrev=1
65384  ENDIF
65385  IF(ia.LE.0.OR.ia.GT.n) THEN
65386  CALL pyerrm(12,'(PYPREP:) colour rearrangement failed')
65387  IF(nerrpr.LT.5) THEN
65388  nerrpr=nerrpr+1
65389  WRITE(mstu(11),*) 'started at:', i
65390  WRITE(mstu(11),*) 'ended going from',ib,' to',ia
65391  WRITE(mstu(11),*) 'MQGST =',mqgst
65392  CALL pylist(4)
65393  ENDIF
65394  mint(51)=1
65395  RETURN
65396  ENDIF
65397  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5)
65398  & ,mstu(5)).EQ.ib) THEN
65399  IF(mrev.EQ.1) kcs=9-kcs
65400  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
65401  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
65402  ELSE
65403  IF(mrev.EQ.0) kcs=9-kcs
65404  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
65405  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
65406  ENDIF
65407  IF(ia.NE.i) goto 170
65408 C...Use colour tag information
65409  ELSE
65410 C...First create colour tags starting on IB if none already present.
65411  IF (mct(ib,kcs-3).EQ.0) THEN
65412  CALL pycttr(ib,kcs,ib)
65413  IF(mint(51).NE.0) RETURN
65414  ENDIF
65415  jct=mct(ib,kcs-3)
65416  ifound=0
65417 C...Find final state tag partner
65418  DO 210 it=max(1,ip),n
65419  IF (it.EQ.ib) goto 210
65420  IF (mct(it,6-kcs).EQ.jct.AND.k(it,1).LT.10.AND.k(it,1).gt
65421  & .0) THEN
65422  ifound=ifound+1
65423  ia=it
65424  ENDIF
65425  210 CONTINUE
65426 C...Just copy and goto next if exactly one partner found.
65427  IF (ifound.EQ.1) THEN
65428  goto 170
65429 C...When no match found, match is presumably junction.
65430  ELSEIF (ifound.EQ.0.AND.mqgst.LE.2) THEN
65431 C...Check whether this colour tag matches a junction
65432 C...by seeing whether any parton with this colour tag has the same
65433 C...mother as a junction.
65434 C...NB: Only type 1 and 2 junctions handled presently.
65435  DO 230 iju=1,njunc
65436  ijumo=k(ijunc(iju,0),3)
65437  itjunc=mod(k(ijunc(iju,0),4)/mstu(5),mstu(5))
65438 C...Colours only connect to junctions, anti-colours to antijunctions:
65439  IF (mod(itjunc+1,2)+1.NE.kcs-3) goto 230
65440  imatch=0
65441  DO 220 j1=max(1,ip),n
65442  IF (k(j1,1).LE.0) goto 220
65443 C...First scattering partons have IMO1 = 3 and 4.
65444  imo=k(j1,3)
65445  IF (imo.EQ.mint(83)+3.OR.imo.EQ.mint(83)+4)
65446  & imo=imo-2
65447  IF (mct(j1,kcs-3).EQ.jct.AND.imo.EQ.ijumo.AND.mod(k(j1
65448  & ,3+itjunc)/mstu(5),mstu(5)).EQ.ijunc(iju,0))
65449  & imatch=1
65450 C...Attempt at handling type > 3 junctions also. Not tested.
65451  IF (itjunc.GE.3.AND.mct(j1,6-kcs).EQ.jct.AND.imo.eq
65452  & .ijumo) imatch=1
65453  220 CONTINUE
65454  IF (imatch.EQ.0) goto 230
65455  ia=ijunc(iju,0)
65456  ifound=ifound+1
65457  230 CONTINUE
65458 
65459  IF (ifound.EQ.1) THEN
65460  goto 170
65461  ELSEIF (ifound.EQ.0) THEN
65462  WRITE(chtmp,'(I6)') jct
65463  CALL pyerrm(12,'(PYPREP:) no matching colour tag: '
65464  & //chtmp)
65465  IF(nerrpr.LT.5) THEN
65466  nerrpr=nerrpr+1
65467  CALL pylist(4)
65468  ENDIF
65469  mint(51)=1
65470  RETURN
65471  ENDIF
65472  ELSEIF (ifound.GE.2) THEN
65473  WRITE(chtmp,'(I6)') jct
65474  CALL pyerrm(12
65475  & ,'(PYPREP:) too many occurences of colour line: '//
65476  & chtmp)
65477  IF(nerrpr.LT.5) THEN
65478  nerrpr=nerrpr+1
65479  CALL pylist(4)
65480  ENDIF
65481  mint(51)=1
65482  RETURN
65483  ENDIF
65484  ENDIF
65485  k(i1,1)=1
65486  240 CONTINUE
65487  250 CONTINUE
65488 
65489 C...Junction systems remain.
65490  iju=0
65491  ijus=0
65492  ijucnt=0
65493  mrev=0
65494  ijjstr=0
65495  260 ijucnt=ijucnt+1
65496  IF (ijucnt.LE.njunc) THEN
65497 C...If we are not processing a j-j string, treat this junction as new.
65498  IF (ijjstr.EQ.0) THEN
65499  iju=ijunc(ijucnt,0)
65500  mrev=0
65501 C...If junction has already been read, ignore it.
65502  IF (ijunc(ijucnt,4).EQ.1) goto 260
65503 C...If we are on a j-j string, goto second j-j junction.
65504  ELSE
65505  ijucnt=ijucnt-1
65506  iju=ijus
65507  ENDIF
65508 C...Mark selected junction read.
65509  DO 270 j=1,njunc
65510  IF (ijunc(j,0).EQ.iju) ijunc(j,4)=1
65511  270 CONTINUE
65512 C...Determine junction type
65513  itjunc = mod(k(iju,4)/mstu(5),mstu(5))
65514 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
65515 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
65516 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
65517  IF (itjunc.GE.1.AND.itjunc.LE.6) THEN
65518  ihk=0
65519  280 ihk=ihk+1
65520 C...Find which quarks belong to given junction.
65521  ihf=0
65522  DO 290 ipc=1,npiece
65523  IF (ipiece(ipc,4).EQ.iju) THEN
65524  ihf=ihf+1
65525  IF (ihf.EQ.ihk) iend=ipiece(ipc,3)
65526  ENDIF
65527  IF (ihk.EQ.3.AND.ipiece(ipc,0).EQ.iju) iend=ipiece(ipc,3)
65528  290 CONTINUE
65529 C...IHK = 3 is special. Either normal string piece, or j-j string.
65530  IF(ihk.EQ.3) THEN
65531  IF (mrev.NE.1) THEN
65532  DO 300 ipc=1,npiece
65533 C...If there is a j-j string starting on the present junction which has
65534 C...zero length, insert next junction immediately.
65535  IF (ipiece(ipc,0).EQ.iju.AND.k(ipiece(ipc,4),1)
65536  & .EQ.42.AND.ipiece(ipc,1)-1-ipiece(ipc,2).EQ.0) THEN
65537  ijjstr = 1
65538  goto 340
65539  ENDIF
65540  300 CONTINUE
65541  mrev = 1
65542 C...If MREV is 1 and IHK is 3 we are finished with this system.
65543  ELSE
65544  mrev=0
65545  goto 260
65546  ENDIF
65547  ENDIF
65548 
65549 C...If we've gotten this far, then either IHK < 3, or
65550 C...an interjunction string exists, or just a third normal string.
65551  ijunc(ijucnt,ihk)=0
65552  ijjstr = 0
65553 C..Order pieces belonging to this junction. Also look for j-j.
65554  DO 310 ipc=1,npiece
65555  IF (ipiece(ipc,3).EQ.iend) ijunc(ijucnt,ihk)=ipc
65556  IF (ihk.EQ.3.AND.ipiece(ipc,0).EQ.ijunc(ijucnt,0)
65557  & .AND.k(ipiece(ipc,4),1).EQ.42) THEN
65558  ijunc(ijucnt,ihk)=ipc
65559  ijjstr = 1
65560  mrev = 0
65561  ENDIF
65562  310 CONTINUE
65563 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
65564  ipc=ijunc(ijucnt,ihk)
65565 C...Temporary solution to cover for bug.
65566  IF(ipc.LE.0) THEN
65567  CALL pyerrm(12,'(PYPREP:) fails to hook up junctions')
65568  mint(51)=1
65569  RETURN
65570  ENDIF
65571  DO 330 icp=ipiece(ipc,1+mrev),ipiece(ipc,2-mrev),1-2*mrev
65572  i1=i1+1
65573  DO 320 j=1,5
65574  k(i1,j)=k(mstu(4)-icp,j)
65575  p(i1,j)=p(mstu(4)-icp,j)
65576  v(i1,j)=v(mstu(4)-icp,j)
65577  320 CONTINUE
65578  330 CONTINUE
65579  k(i1,1)=2
65580 C...Mark last quark.
65581  IF (mrev.EQ.1.AND.ihk.GE.2) k(i1,1)=1
65582 C...Do not insert junctions at wrong places.
65583  IF(ihk.LT.2.OR.mrev.NE.0) goto 360
65584 C...Insert junction.
65585  340 ijus = iju
65586  IF (ihk.EQ.3) THEN
65587 C...Shift to end junction if a j-j string has been processed.
65588  IF (ijjstr.NE.0) ijus = ipiece(ipc,4)
65589  mrev= 1
65590  ENDIF
65591  i1=i1+1
65592  DO 350 j=1,5
65593  k(i1,j)=0
65594  p(i1,j)=0.
65595  v(i1,j)=0.
65596  350 CONTINUE
65597  k(i1,1)=41
65598  k(ijus,1)=k(ijus,1)+10
65599  k(i1,2)=k(ijus,2)
65600  k(i1,3)=ijus
65601  360 IF (ihk.LT.3) goto 280
65602  ELSE
65603  CALL pyerrm(12,'(PYPREP:) Unknown junction type')
65604  mint(51)=1
65605  RETURN
65606  ENDIF
65607  IF (ijucnt.NE.njunc) goto 260
65608  ENDIF
65609  n=i1
65610 
65611 C...Rearrange three strings from junction, e.g. in case one has been
65612 C...shortened by shower, so the last is the largest-energy one.
65613  IF(njunc.GE.1) THEN
65614 C...Find systems with exactly one junction.
65615  mjun1=0
65616  nbeg=nold+1
65617  DO 470 i=nold+1,n
65618  IF(k(i,1).NE.1.AND.k(i,1).NE.41) THEN
65619  ELSEIF(k(i,1).EQ.41) THEN
65620  mjun1=mjun1+1
65621  ELSEIF(k(i,1).EQ.1.AND.mjun1.NE.1) THEN
65622  mjun1=0
65623  nbeg=i+1
65624  ELSE
65625  nend=i
65626 C...Sum up energy-momentum in each junction string.
65627  DO 370 j=1,5
65628  pju(1,j)=0d0
65629  pju(2,j)=0d0
65630  pju(3,j)=0d0
65631  370 CONTINUE
65632  nju=0
65633  DO 390 i1=nbeg,nend
65634  IF(k(i1,2).NE.21) THEN
65635  nju=nju+1
65636  ijur(nju)=i1
65637  ENDIF
65638  DO 380 j=1,5
65639  pju(min(nju,3),j)=pju(min(nju,3),j)+p(i1,j)
65640  380 CONTINUE
65641  390 CONTINUE
65642 C...Find which of them has highest energy (minus mass) in rest frame.
65643  DO 400 j=1,5
65644  pju(4,j)=pju(1,j)+pju(2,j)+pju(3,j)
65645  400 CONTINUE
65646  pmju=sqrt(max(0d0,pju(4,4)**2-pju(4,1)**2-pju(4,2)**2-
65647  & pju(4,3)**2))
65648  DO 410 i2=1,3
65649  pju(i2,6)=(pju(4,4)*pju(i2,4)-pju(4,1)*pju(i2,1)-
65650  & pju(4,2)*pju(i2,2)-pju(4,3)*pju(i2,3))/pmju-pju(i2,5)
65651  410 CONTINUE
65652  IF(pju(3,6).LT.min(pju(1,6),pju(2,6))) THEN
65653 C...Decide how to rearrange so that new last has highest energy.
65654  IF(pju(1,6).LT.pju(2,6)) THEN
65655  irng(1,1)=ijur(1)
65656  irng(1,2)=ijur(2)-1
65657  irng(2,1)=ijur(4)
65658  irng(2,2)=ijur(3)+1
65659  irng(4,1)=ijur(3)-1
65660  irng(4,2)=ijur(2)
65661  ELSE
65662  irng(1,1)=ijur(4)
65663  irng(1,2)=ijur(3)+1
65664  irng(2,1)=ijur(2)
65665  irng(2,2)=ijur(3)-1
65666  irng(4,1)=ijur(2)-1
65667  irng(4,2)=ijur(1)
65668  ENDIF
65669  irng(3,1)=ijur(3)
65670  irng(3,2)=ijur(3)
65671 C...Copy in correct order below bottom of current event record.
65672  i2=n
65673  DO 440 ii=1,4
65674  DO 430 i1=irng(ii,1),irng(ii,2),
65675  & isign(1,irng(ii,2)-irng(ii,1))
65676  i2=i2+1
65677  IF(i2.GE.mstu(4)-mstu32-5) THEN
65678  CALL pyerrm(11,
65679  & '(PYPREP:) no more memory left in PYJETS')
65680  mint(51)=1
65681  mstu(24)=1
65682  RETURN
65683  ENDIF
65684  DO 420 j=1,5
65685  k(i2,j)=k(i1,j)
65686  p(i2,j)=p(i1,j)
65687  v(i2,j)=v(i1,j)
65688  420 CONTINUE
65689  IF(k(i2,1).EQ.1) k(i2,1)=2
65690  430 CONTINUE
65691  440 CONTINUE
65692  k(i2,1)=1
65693 C...Copy back up, overwriting but now in correct order.
65694  DO 460 i1=nbeg,nend
65695  i2=i1-nbeg+n+1
65696  DO 450 j=1,5
65697  k(i1,j)=k(i2,j)
65698  p(i1,j)=p(i2,j)
65699  v(i1,j)=v(i2,j)
65700  450 CONTINUE
65701  460 CONTINUE
65702  ENDIF
65703  mjun1=0
65704  nbeg=i+1
65705  ENDIF
65706  470 CONTINUE
65707 
65708 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
65709 C...to two q-qbar systems.
65710 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
65711  IF (mstj(19).NE.1) THEN
65712  mjun1 = 0
65713  jjglue = 0
65714  nbeg = nold+1
65715 C...Force collapse when MSTJ(19)=2.
65716  IF (mstj(19).EQ.2) THEN
65717  delmjj = 1d9
65718  delmqq = 0d0
65719  ENDIF
65720 C...Find systems with exactly two junctions.
65721  DO 700 i=nold+1,n
65722 C...Count junctions
65723  IF (k(i,1).EQ.41) THEN
65724  mjun1 = mjun1+1
65725 C...Check for interjunction gluons
65726  IF (mjun1.EQ.2.AND.k(i-1,1).NE.41) THEN
65727  jjglue = 1
65728  ENDIF
65729  ELSEIF(k(i,1).EQ.1.AND.(mjun1.NE.2)) THEN
65730 C...If end of system reached with either zero or one junction, restart
65731 C...with next system.
65732  mjun1 = 0
65733  jjglue = 0
65734  nbeg = i+1
65735  ELSEIF(k(i,1).EQ.1) THEN
65736 C...If end of system reached with exactly two junctions, compute string
65737 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
65738 C...length measure for the (q-qbar)(q-qbar) topology.
65739  nend=i
65740 C...Loop down through chain.
65741  isid=0
65742  DO 480 i1=nbeg,nend
65743 C...Store string piece division locations in event record
65744  IF (k(i1,2).NE.21) THEN
65745  isid = isid+1
65746  ijcp(isid) = i1
65747  ENDIF
65748  480 CONTINUE
65749 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
65750  isw=0
65751  IF (pyr(0).LT.0.5d0) isw=1
65752 C...Randomly choose which qqbar string gets the jj gluons.
65753  igs=1
65754  IF (pyr(0).GT.0.5d0) igs=2
65755 C...Only compute string lengths when no topology forced.
65756  IF (mstj(19).EQ.0) THEN
65757 C...Repeat following for each junction
65758  DO 570 iju=1,2
65759 C...Initialize iterative procedure for finding JRF
65760  ijrfit=0
65761  DO 490 ix=1,3
65762  tjuold(ix)=0d0
65763  490 CONTINUE
65764  tjuold(4)=1d0
65765 C...Start iteration. Sum up momenta in string pieces
65766  500 DO 540 ijs=1,3
65767 C...JD=-1 for first junction, +1 for second junction.
65768 C...Find out where piece starts and ends and which direction to go.
65769  jd=2*iju-3
65770  IF (ijs.LE.2) THEN
65771  ia = ijcp((iju-1)*7 - jd*(ijs+1)) + jd
65772  ib = ijcp((iju-1)*7 - jd*ijs)
65773  ELSEIF (ijs.EQ.3) THEN
65774  jd =-jd
65775  ia = ijcp((iju-1)*7 + jd*(ijs)) + jd
65776  ib = ijcp((iju-1)*7 + jd*(ijs+3))
65777  ENDIF
65778 C...Initialize junction pull 4-vector.
65779  DO 510 j=1,5
65780  pul(ijs,j)=0d0
65781  510 CONTINUE
65782 C...Initialize weight
65783  pwt = 0d0
65784  pwtold = 0d0
65785 C...Sum up (weighted) momenta along each string piece
65786  DO 530 isp=ia,ib,jd
65787 C...If present parton not last in chain
65788  IF (isp.NE.ia.AND.isp.NE.ib) THEN
65789 C...If last parton was a junction, store present weight
65790  IF (k(isp-jd,2).EQ.88) THEN
65791  pwtold = pwt
65792 C...If last parton was a quark, reset to stored weight.
65793  ELSEIF (k(isp-jd,2).NE.21) THEN
65794  pwt = pwtold
65795  ENDIF
65796  ENDIF
65797 C...Skip next parton if weight already large
65798  IF (pwt.GT.10d0) goto 530
65799 C...Compute momentum in TJUOLD frame:
65800  tdp=tjuold(1)*p(isp,1)+tjuold(2)*p(isp,2)+tjuold(3
65801  & )*p(isp,3)
65802  bfc=tdp/(1d0+tjuold(4))+p(isp,4)
65803  DO 520 j=1,3
65804  tmp=p(isp,j)+tjuold(j)*bfc
65805  pul(ijs,j)=pul(ijs,j)+tmp*exp(-pwt)
65806  520 CONTINUE
65807 C...Boosted energy
65808  tmp=tjuold(4)*p(isp,4)+tdp
65809  pul(ijs,4)=pul(ijs,j)+tmp*exp(-pwt)
65810 C...Update weight
65811  pwt=pwt+tmp/parj(48)
65812 C...Put |p| rather than m in 5th slot
65813  pul(ijs,5)=sqrt(pul(ijs,1)**2+pul(ijs,2)**2
65814  & +pul(ijs,3)**2)
65815  530 CONTINUE
65816  540 CONTINUE
65817 C...Compute boost
65818  ijrfit=ijrfit+1
65819  CALL pyjurf(pul,t)
65820 C...Combine new boost (T) with old boost (TJUOLD)
65821  tmp=t(1)*tjuold(1)+t(2)*tjuold(2)+t(3)*tjuold(3)
65822  DO 550 ix=1,3
65823  tjuold(ix)=t(ix)+tjuold(ix)*(tmp/(1d0+tjuold(4))+t(4
65824  & ))
65825  550 CONTINUE
65826  tjuold(4)=sqrt(1d0+tjuold(1)**2+tjuold(2)**2+tjuold(3)
65827  & **2)
65828 C...If last boost small, accept JRF, else iterate.
65829 C...Also prevent possibility of infinite loop.
65830  IF (abs((t(4)-1d0)/tjuold(4)).GT.0.01d0.AND.
65831  & ijrfit.LT.mstj(18))THEN
65832  goto 500
65833  ELSEIF (ijrfit.GE.mstj(18)) THEN
65834  CALL pyerrm(1,'(PYPREP:) failed to converge on JRF')
65835  ENDIF
65836 C...Store final boost, with change of sign since TJJ motion vector.
65837  DO 560 ix=1,3
65838  tjj(iju,ix)=-tjuold(ix)
65839  560 CONTINUE
65840  tjj(iju,4)=sqrt(1d0+tjj(iju,1)**2+tjj(iju,2)**2
65841  & +tjj(iju,3)**2)
65842  570 CONTINUE
65843 C...String length measure for (q-qbar)(q-qbar) topology.
65844 C...Note only momenta of nearest partons used (since rest of system
65845 C...identical).
65846  IF (jjglue.EQ.0) THEN
65847  delmqq=4d0*four(ijcp(2)-1,ijcp(4+isw)+1)*four(ijcp(3)
65848  & -1,ijcp(5-isw)+1)
65849  ELSE
65850 C...Put jj gluons on selected string (IGS selected randomly above).
65851  IF (igs.EQ.1) THEN
65852  delmqq=8d0*four(ijcp(2)-1,ijcp(4)-1)*four(ijcp(3)+1
65853  & ,ijcp(4+isw)+1)*four(ijcp(3)-1,ijcp(5-isw)+1)
65854  ELSE
65855  delmqq=8d0*four(ijcp(2)-1,ijcp(4+isw)+1)
65856  & *four(ijcp(3)-1,ijcp(4)-1)*four(ijcp(3)+1
65857  & ,ijcp(5-isw)+1)
65858  ENDIF
65859  ENDIF
65860 C...String length measure for q-q-j-j-q-q topology.
65861  t1g1=0d0
65862  t2g2=0d0
65863  t1t2=0d0
65864  t1p1=0d0
65865  t1p2=0d0
65866  t2p3=0d0
65867  t2p4=0d0
65868  isgn=-1
65869 C...Note only momenta of nearest partons used (since rest of system
65870 C...identical).
65871  DO 580 ix=1,4
65872  IF (ix.EQ.4) isgn=1
65873  t1p1=t1p1+isgn*tjj(1,ix)*p(ijcp(2)-1,ix)
65874  t1p2=t1p2+isgn*tjj(1,ix)*p(ijcp(3)-1,ix)
65875  t2p3=t2p3+isgn*tjj(2,ix)*p(ijcp(4)+1,ix)
65876  t2p4=t2p4+isgn*tjj(2,ix)*p(ijcp(5)+1,ix)
65877  IF (jjglue.EQ.0) THEN
65878 C...Junction motion vector dot product gives length when inter-junction
65879 C...gluons absent.
65880  t1t2=t1t2+isgn*tjj(1,ix)*tjj(2,ix)
65881  ELSE
65882 C...Junction motion vector dot products with gluon momenta give length
65883 C...when inter-junction gluons present.
65884  t1g1=t1g1+isgn*tjj(1,ix)*p(ijcp(3)+1,ix)
65885  t2g2=t2g2+isgn*tjj(2,ix)*p(ijcp(4)-1,ix)
65886  ENDIF
65887  580 CONTINUE
65888  delmjj=16d0*t1p1*t1p2*t2p3*t2p4
65889  IF (jjglue.EQ.0) THEN
65890  delmjj=delmjj*(t1t2+sqrt(t1t2**2-1))
65891  ELSE
65892  delmjj=delmjj*4d0*t1g1*t2g2
65893  ENDIF
65894  ENDIF
65895 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
65896 C...(Always the case for MSTJ(19)=2 due to initialization above)
65897  IF (delmjj.GT.delmqq) THEN
65898 C...Put new system at end of event record
65899  ncop=n
65900  DO 650 ist=1,2
65901  DO 600 icop=ijcp(ist),ijcp(ist+1)-1
65902  ncop=ncop+1
65903  DO 590 ix=1,5
65904  p(ncop,ix)=p(icop,ix)
65905  k(ncop,ix)=k(icop,ix)
65906  590 CONTINUE
65907  600 CONTINUE
65908  IF (jjglue.NE.0.AND.ist.EQ.igs) THEN
65909 C...Insert inter-junction gluon string piece (reversed)
65910  njjgl=0
65911  DO 620 icop=ijcp(4)-1,ijcp(3)+1,-1
65912  njjgl=njjgl+1
65913  ncop=ncop+1
65914  DO 610 ix=1,5
65915  p(ncop,ix)=p(icop,ix)
65916  k(ncop,ix)=k(icop,ix)
65917  610 CONTINUE
65918  620 CONTINUE
65919  ENDIF
65920  ifc=-2*ist+3
65921  DO 640 icop=ijcp(ist+ifc*isw+3)+1,ijcp(ist+ifc*isw+4)
65922  ncop=ncop+1
65923  DO 630 ix=1,5
65924  p(ncop,ix)=p(icop,ix)
65925  k(ncop,ix)=k(icop,ix)
65926  630 CONTINUE
65927  640 CONTINUE
65928  k(ncop,1)=1
65929  650 CONTINUE
65930 C...Copy system back in right order
65931  DO 670 icop=nbeg,nend-2
65932  DO 660 ix=1,5
65933  p(icop,ix)=p(n+icop-nbeg+1,ix)
65934  k(icop,ix)=k(n+icop-nbeg+1,ix)
65935  660 CONTINUE
65936  670 CONTINUE
65937 C...Shift down rest of event record
65938  DO 690 icop=nend+1,n
65939  DO 680 ix=1,5
65940  p(icop-2,ix)=p(icop,ix)
65941  k(icop-2,ix)=k(icop,ix)
65942  680 CONTINUE
65943  690 CONTINUE
65944 C...Update length of event record.
65945  n=n-2
65946  ENDIF
65947  mjun1=0
65948  nbeg=i+1
65949  ENDIF
65950  700 CONTINUE
65951  ENDIF
65952  ENDIF
65953 
65954 C...Done if no checks on small-mass systems.
65955  IF(mstj(14).LT.0) RETURN
65956  IF(mstj(14).EQ.0) goto 1140
65957 
65958 C...Find lowest-mass colour singlet jet system.
65959  ns=n
65960  710 nsin=n-ns
65961  pdmin=1d0+parj(32)
65962  ic=0
65963  DO 770 i=max(1,ip),n
65964  IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
65965  ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
65966  nsin=nsin+1
65967  ic=i
65968  DO 720 j=1,4
65969  dps(j)=p(i,j)
65970  720 CONTINUE
65971  mstj(93)=1
65972  dps(5)=pymass(k(i,2))
65973  ELSEIF(k(i,1).EQ.2.AND.k(i,2).NE.21) THEN
65974  DO 730 j=1,4
65975  dps(j)=dps(j)+p(i,j)
65976  730 CONTINUE
65977  mstj(93)=1
65978  dps(5)=dps(5)+pymass(k(i,2))
65979  ELSEIF(k(i,1).EQ.2) THEN
65980  DO 740 j=1,4
65981  dps(j)=dps(j)+p(i,j)
65982  740 CONTINUE
65983  ELSEIF(ic.NE.0.AND.kchg(pycomp(k(i,2)),2).NE.0) THEN
65984  DO 750 j=1,4
65985  dps(j)=dps(j)+p(i,j)
65986  750 CONTINUE
65987  mstj(93)=1
65988  dps(5)=dps(5)+pymass(k(i,2))
65989  pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-
65990  & dps(5)
65991  IF(pd.LT.pdmin) THEN
65992  pdmin=pd
65993  DO 760 j=1,5
65994  dpc(j)=dps(j)
65995  760 CONTINUE
65996  ic1=ic
65997  ic2=i
65998  ENDIF
65999  ic=0
66000  ELSE
66001  nsin=nsin+1
66002  ENDIF
66003  770 CONTINUE
66004 
66005 C...Done if lowest-mass system above threshold for string frag.
66006  IF(pdmin.GE.parj(32)) goto 1140
66007 
66008 C...Fill small-mass system as cluster.
66009  nsav=n
66010  pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
66011  k(n+1,1)=11
66012  k(n+1,2)=91
66013  k(n+1,3)=ic1
66014  p(n+1,1)=dpc(1)
66015  p(n+1,2)=dpc(2)
66016  p(n+1,3)=dpc(3)
66017  p(n+1,4)=dpc(4)
66018  p(n+1,5)=pecm
66019 
66020 C...Set up history, assuming cluster -> 2 hadrons.
66021  nbody=2
66022  k(n+1,4)=n+2
66023  k(n+1,5)=n+3
66024  k(n+2,1)=1
66025  k(n+3,1)=1
66026  IF(mstu(16).NE.2) THEN
66027  k(n+2,3)=n+1
66028  k(n+3,3)=n+1
66029  ELSE
66030  k(n+2,3)=ic1
66031  k(n+3,3)=ic2
66032  ENDIF
66033  k(n+2,4)=0
66034  k(n+3,4)=0
66035  k(n+2,5)=0
66036  k(n+3,5)=0
66037  v(n+1,5)=0d0
66038  v(n+2,5)=0d0
66039  v(n+3,5)=0d0
66040 
66041 C...Find total flavour content - complicated by presence of junctions.
66042  nq=0
66043  ndiq=0
66044  DO 780 i=ic1,ic2
66045  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.k(i,2).NE.21) THEN
66046  nq=nq+1
66047  kfq(nq)=k(i,2)
66048  IF(iabs(k(i,2)).GT.1000) ndiq=ndiq+1
66049  ENDIF
66050  780 CONTINUE
66051 
66052 C...If several diquarks, split up one to give even number of flavours.
66053  IF(nq.EQ.3.AND.ndiq.GE.2) THEN
66054  i1=3
66055  IF(iabs(kfq(3)).LT.1000) i1=1
66056  kfq(4)=isign(mod(iabs(kfq(i1))/100,10),kfq(i1))
66057  kfq(i1)=kfq(i1)/1000
66058  nq=4
66059  ndiq=ndiq-1
66060  ENDIF
66061 
66062 C...If four quark ends, join two to diquark.
66063  IF(nq.EQ.4.AND.ndiq.EQ.0) THEN
66064  i1=1
66065  i2=2
66066  IF(kfq(i1)*kfq(i2).LT.0) i2=3
66067  IF(i2.EQ.3.AND.kfq(i1)*kfq(i2).LT.0) i2=4
66068  kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
66069  IF(kfq(i1).EQ.kfq(i2)) kfls=3
66070  kfq(i1)=isign(1000*max(iabs(kfq(i1)),iabs(kfq(i2)))+
66071  & 100*min(iabs(kfq(i1)),iabs(kfq(i2)))+kfls,kfq(i1))
66072  kfq(i2)=kfq(4)
66073  nq=3
66074  ndiq=1
66075  ENDIF
66076 
66077 C...If two quark ends, plus quark or diquark, join quarks to diquark.
66078  IF(nq.EQ.3) THEN
66079  i1=1
66080  i2=2
66081  IF(iabs(kfq(i1)).GT.1000) i1=3
66082  IF(iabs(kfq(i2)).GT.1000) i2=3
66083  kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
66084  IF(kfq(i1).EQ.kfq(i2)) kfls=3
66085  kfq(i1)=isign(1000*max(iabs(kfq(i1)),iabs(kfq(i2)))+
66086  & 100*min(iabs(kfq(i1)),iabs(kfq(i2)))+kfls,kfq(i1))
66087  kfq(i2)=kfq(3)
66088  nq=2
66089  ndiq=ndiq+1
66090  ENDIF
66091 
66092 C...Form two particles from flavours of lowest-mass system, if feasible.
66093  ntry = 0
66094  790 ntry = ntry + 1
66095 
66096 C...Open string with two specified endpoint flavours.
66097  IF(nq.EQ.2) THEN
66098  kc1=pycomp(kfq(1))
66099  kc2=pycomp(kfq(2))
66100  IF(kc1.EQ.0.OR.kc2.EQ.0) goto 1140
66101  kq1=kchg(kc1,2)*isign(1,kfq(1))
66102  kq2=kchg(kc2,2)*isign(1,kfq(2))
66103  IF(kq1+kq2.NE.0) goto 1140
66104 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
66105  800 k1=kfq(1)
66106  IF(iabs(kfq(2)).GT.1000) k1=kfq(2)
66107  mstu(125)=0
66108  CALL pydcyk(k1,0,kfln,k(n+2,2))
66109  CALL pydcyk(kfq(1)+kfq(2)-k1,-kfln,kfldmp,k(n+3,2))
66110  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 800
66111 
66112 C...Open string with four specified flavours.
66113  ELSEIF(nq.EQ.4) THEN
66114  kc1=pycomp(kfq(1))
66115  kc2=pycomp(kfq(2))
66116  kc3=pycomp(kfq(3))
66117  kc4=pycomp(kfq(4))
66118  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) goto 1140
66119  kq1=kchg(kc1,2)*isign(1,kfq(1))
66120  kq2=kchg(kc2,2)*isign(1,kfq(2))
66121  kq3=kchg(kc3,2)*isign(1,kfq(3))
66122  kq4=kchg(kc4,2)*isign(1,kfq(4))
66123  IF(kq1+kq2+kq3+kq4.NE.0) goto 1140
66124 C...Combine flavours pairwise to form two hadrons.
66125  810 i1=1
66126  i2=2
66127  IF(kq1*kq2.GT.0.OR.(iabs(kfq(1)).GT.1000.AND.
66128  & iabs(kfq(2)).GT.1000)) i2=3
66129  IF(i2.EQ.3.AND.(kq1*kq3.GT.0.OR.(iabs(kfq(1)).GT.1000.AND.
66130  & iabs(kfq(3)).GT.1000))) i2=4
66131  i3=3
66132  IF(i2.EQ.3) i3=2
66133  i4=10-i1-i2-i3
66134  CALL pydcyk(kfq(i1),kfq(i2),kfldmp,k(n+2,2))
66135  CALL pydcyk(kfq(i3),kfq(i4),kfldmp,k(n+3,2))
66136  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 810
66137 
66138 C...Closed string.
66139  ELSE
66140  IF(iabs(k(ic2,2)).NE.21) goto 1140
66141 C...No room for popcorn mesons in closed string -> 2 hadrons.
66142  mstu(125)=0
66143  820 CALL pydcyk(1+int((2d0+parj(2))*pyr(0)),0,kfln,kfdmp)
66144  CALL pydcyk(kfln,0,kflm,k(n+2,2))
66145  CALL pydcyk(-kfln,-kflm,kfldmp,k(n+3,2))
66146  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 820
66147  ENDIF
66148  p(n+2,5)=pymass(k(n+2,2))
66149  p(n+3,5)=pymass(k(n+3,2))
66150 
66151 C...If it does not work: try again (a number of times), give up (if no
66152 C...place to shuffle momentum or too many flavours), or form one hadron.
66153  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) THEN
66154  IF(ntry.LT.mstj(17).OR.(nq.EQ.4.AND.ntry.LT.5*mstj(17))) THEN
66155  goto 790
66156  ELSEIF(nsin.EQ.1.OR.nq.EQ.4) THEN
66157  goto 1140
66158  ELSE
66159  goto 890
66160  END IF
66161  END IF
66162 
66163 C...Perform two-particle decay of jet system.
66164 C...First step: find reference axis in decaying system rest frame.
66165 C...(Borrow slot N+2 for temporary direction.)
66166  DO 830 j=1,4
66167  p(n+2,j)=p(ic1,j)
66168  830 CONTINUE
66169  DO 850 i=ic1+1,ic2-1
66170  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
66171  & kchg(pycomp(k(i,2)),2).NE.0) THEN
66172  frac1=four(ic2,i)/(four(ic1,i)+four(ic2,i))
66173  DO 840 j=1,4
66174  p(n+2,j)=p(n+2,j)+frac1*p(i,j)
66175  840 CONTINUE
66176  ENDIF
66177  850 CONTINUE
66178  CALL pyrobo(n+2,n+2,0d0,0d0,-dpc(1)/dpc(4),-dpc(2)/dpc(4),
66179  &-dpc(3)/dpc(4))
66180  the1=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
66181  phi1=pyangl(p(n+2,1),p(n+2,2))
66182 
66183 C...Second step: generate isotropic/anisotropic decay.
66184  pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
66185  &(p(n+2,5)-p(n+3,5))**2))/(2d0*pecm)
66186  860 ue(3)=pyr(0)
66187  IF(parj(21).LE.0.01d0) ue(3)=1d0
66188  pt2=(1d0-ue(3)**2)*pa**2
66189  IF(mstj(16).LE.0) THEN
66190  prev=0.5d0
66191  ELSE
66192  IF(exp(-pt2/(2d0*max(0.01d0,parj(21))**2)).LT.pyr(0)) goto 860
66193  pr1=p(n+2,5)**2+pt2
66194  pr2=p(n+3,5)**2+pt2
66195  alambd=sqrt(max(0d0,(pecm**2-pr1-pr2)**2-4d0*pr1*pr2))
66196  prevcf=parj(42)
66197  IF(mstj(11).EQ.2) prevcf=parj(39)
66198  prev=1d0/(1d0+exp(min(50d0,prevcf*alambd*parj(40))))
66199  ENDIF
66200  IF(pyr(0).LT.prev) ue(3)=-ue(3)
66201  phi=paru(2)*pyr(0)
66202  ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
66203  ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
66204  DO 870 j=1,3
66205  p(n+2,j)=pa*ue(j)
66206  p(n+3,j)=-pa*ue(j)
66207  870 CONTINUE
66208  p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
66209  p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
66210 
66211 C...Third step: move back to event frame and set production vertex.
66212  CALL pyrobo(n+2,n+3,the1,phi1,dpc(1)/dpc(4),dpc(2)/dpc(4),
66213  &dpc(3)/dpc(4))
66214  DO 880 j=1,4
66215  v(n+1,j)=v(ic1,j)
66216  v(n+2,j)=v(ic1,j)
66217  v(n+3,j)=v(ic2,j)
66218  880 CONTINUE
66219  n=n+3
66220  goto 1120
66221 
66222 C...Else form one particle, if possible.
66223  890 nbody=1
66224  k(n+1,5)=n+2
66225  DO 900 j=1,4
66226  v(n+1,j)=v(ic1,j)
66227  v(n+2,j)=v(ic1,j)
66228  900 CONTINUE
66229 
66230 C...Select hadron flavour from available quark flavours.
66231  910 IF(nq.EQ.2.AND.iabs(kfq(1)).GT.100.AND.iabs(kfq(2)).GT.100) THEN
66232  goto 1140
66233  ELSEIF(nq.EQ.2) THEN
66234  CALL pykfdi(kfq(1),kfq(2),kfldmp,k(n+2,2))
66235  ELSE
66236  kfln=1+int((2d0+parj(2))*pyr(0))
66237  CALL pykfdi(kfln,-kfln,kfldmp,k(n+2,2))
66238  ENDIF
66239  IF(k(n+2,2).EQ.0) goto 910
66240  p(n+2,5)=pymass(k(n+2,2))
66241 
66242 C...Use old algorithm for E/p conservation? (EN)
66243  IF (mstj(16).LE.0) goto 1080
66244 
66245 C...Find the string piece closest to the cluster by a loop
66246 C...over the undecayed partons not in present cluster. (EN)
66247  dglomi=1d30
66248  ibeg=0
66249  i0=0
66250  njunc=0
66251  DO 940 i1=max(1,ip),n-1
66252  IF(k(i1,1).EQ.1) njunc=0
66253  IF(k(i1,1).EQ.41) njunc=njunc+1
66254  IF(k(i1,1).EQ.41) goto 940
66255  IF(i1.GE.ic1-1.AND.i1.LE.ic2) THEN
66256  i0=0
66257  ELSEIF(k(i1,1).EQ.2) THEN
66258  IF(i0.EQ.0) i0=i1
66259  i2=i1
66260  920 i2=i2+1
66261  IF(k(i2,1).EQ.41) goto 940
66262  IF(k(i2,1).GT.10) goto 920
66263  IF(kchg(pycomp(k(i2,2)),2).EQ.0) goto 920
66264  IF(k(i1,2).EQ.21.AND.k(i2,2).NE.21.AND.k(i2,1).NE.1.AND.
66265  & njunc.EQ.0) goto 940
66266  IF(k(i1,2).NE.21.AND.k(i2,2).EQ.21.AND.njunc.NE.0) goto 940
66267  IF(k(i1,2).NE.21.AND.k(i2,2).NE.21.AND.(i1.GT.i0.OR.
66268  & k(i2,1).NE.1)) goto 940
66269 
66270 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
66271  DO 930 j=1,3
66272  e1(j)=p(i1,j)/p(i1,4)
66273  e2(j)=p(i2,j)/p(i2,4)
66274  ecl(j)=p(n+1,j)/p(n+1,4)
66275  e3(j)=e2(j)-e1(j)
66276  e4(j)=ecl(j)-e1(j)
66277  930 CONTINUE
66278 
66279 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
66280  e3s=e3(1)**2+e3(2)**2+e3(3)**2
66281  e4s=e4(1)**2+e4(2)**2+e4(3)**2
66282  e34=e3(1)*e4(1)+e3(2)*e4(2)+e3(3)*e4(3)
66283  IF(e34.LE.0d0) THEN
66284  ddmin=e4s
66285  ELSEIF(e34.LT.e3s) THEN
66286  ddmin=e4s-e34**2/e3s
66287  ELSE
66288  ddmin=e4s-2d0*e34+e3s
66289  ENDIF
66290 
66291 C...Is this the smallest so far?
66292  IF(ddmin.LT.dglomi) THEN
66293  dglomi=ddmin
66294  ibeg=i0
66295  ipcs=i1
66296  ENDIF
66297  ELSEIF(k(i1,1).EQ.1.AND.kchg(pycomp(k(i1,2)),2).NE.0) THEN
66298  i0=0
66299  ENDIF
66300  940 CONTINUE
66301 
66302 C... Check if there are any strings to connect to the new gluon. (EN)
66303  IF (ibeg.EQ.0) goto 1080
66304 
66305 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
66306  IF (p(n+1,5).GE.p(n+2,5)) THEN
66307 
66308 C...Construct 'gluon' that is needed to put hadron on the mass shell.
66309  frac=p(n+2,5)/p(n+1,5)
66310  DO 950 j=1,5
66311  p(n+2,j)=frac*p(n+1,j)
66312  pg(j)=(1d0-frac)*p(n+1,j)
66313  950 CONTINUE
66314 
66315 C... Copy string with new gluon put in.
66316  n=n+2
66317  i=ibeg-1
66318  960 i=i+1
66319  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 960
66320  IF(kchg(pycomp(k(i,2)),2).EQ.0.AND.k(i,1).NE.41) goto 960
66321  n=n+1
66322  DO 970 j=1,5
66323  k(n,j)=k(i,j)
66324  p(n,j)=p(i,j)
66325  v(n,j)=v(i,j)
66326  970 CONTINUE
66327  k(i,1)=k(i,1)+10
66328  k(i,4)=n
66329  k(i,5)=n
66330  k(n,3)=i
66331  IF(i.EQ.ipcs) THEN
66332  n=n+1
66333  DO 980 j=1,5
66334  k(n,j)=k(n-1,j)
66335  p(n,j)=pg(j)
66336  v(n,j)=v(n-1,j)
66337  980 CONTINUE
66338  k(n,2)=21
66339  k(n,3)=nsav+1
66340  ENDIF
66341  IF(k(i,1).EQ.12.OR.k(i,1).EQ.51) goto 960
66342  goto 1120
66343 
66344 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
66345 C...from string piece endpoints.
66346  ELSE
66347 
66348 C...Begin by copying string that should give energy to cluster.
66349  n=n+2
66350  i=ibeg-1
66351  990 i=i+1
66352  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 990
66353  IF(kchg(pycomp(k(i,2)),2).EQ.0.AND.k(i,1).NE.41) goto 990
66354  n=n+1
66355  DO 1000 j=1,5
66356  k(n,j)=k(i,j)
66357  p(n,j)=p(i,j)
66358  v(n,j)=v(i,j)
66359  1000 CONTINUE
66360  k(i,1)=k(i,1)+10
66361  k(i,4)=n
66362  k(i,5)=n
66363  k(n,3)=i
66364  IF(i.EQ.ipcs) i1=n
66365  IF(k(i,1).EQ.12.OR.k(i,1).EQ.51) goto 990
66366  i2=i1+1
66367 
66368 C...Set initial Phad.
66369  DO 1010 j=1,4
66370  p(nsav+2,j)=p(nsav+1,j)
66371  1010 CONTINUE
66372 
66373 C...Calculate Pg, a part of which will be added to Phad later. (EN)
66374  1020 IF(mstj(16).EQ.1) THEN
66375  alpha=1d0
66376  beta=1d0
66377  ELSE
66378  alpha=four(nsav+1,i2)/four(i1,i2)
66379  beta=four(nsav+1,i1)/four(i1,i2)
66380  ENDIF
66381  DO 1030 j=1,4
66382  pg(j)=alpha*p(i1,j)+beta*p(i2,j)
66383  1030 CONTINUE
66384  pg(5)=sqrt(max(1d-20,pg(4)**2-pg(1)**2-pg(2)**2-pg(3)**2))
66385 
66386 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
66387  pmscol=p(nsav+2,4)**2-p(nsav+2,1)**2-p(nsav+2,2)**2-
66388  & p(nsav+2,3)**2
66389  pclpg=(p(nsav+2,4)*pg(4)-p(nsav+2,1)*pg(1)-
66390  & p(nsav+2,2)*pg(2)-p(nsav+2,3)*pg(3))/pg(5)**2
66391  delta=sqrt(pclpg**2+(p(nsav+2,5)**2-pmscol)/pg(5)**2)-pclpg
66392 
66393 C...If all gluon energy eaten, zero it and take a step back.
66394  iter=0
66395  IF(delta*alpha.GT.1d0.AND.i1.GT.nsav+3.AND.k(i1,2).EQ.21) THEN
66396  iter=1
66397  DO 1040 j=1,4
66398  p(nsav+2,j)=p(nsav+2,j)+p(i1,j)
66399  p(i1,j)=0d0
66400  1040 CONTINUE
66401  p(i1,5)=0d0
66402  k(i1,1)=k(i1,1)+10
66403  i1=i1-1
66404  IF(k(i1,1).EQ.41) iter=-1
66405  ENDIF
66406  IF(delta*beta.GT.1d0.AND.i2.LT.n.AND.k(i2,2).EQ.21) THEN
66407  iter=1
66408  DO 1050 j=1,4
66409  p(nsav+2,j)=p(nsav+2,j)+p(i2,j)
66410  p(i2,j)=0d0
66411  1050 CONTINUE
66412  p(i2,5)=0d0
66413  k(i2,1)=k(i2,1)+10
66414  i2=i2+1
66415  IF(k(i2,1).EQ.41) iter=-1
66416  ENDIF
66417  IF(iter.EQ.1) goto 1020
66418 
66419 C...If also all endpoint energy eaten, revert to old procedure.
66420  IF((1d0-delta*alpha)*p(i1,4).LT.p(i1,5).OR.
66421  & (1d0-delta*beta)*p(i2,4).LT.p(i2,5).OR.iter.EQ.-1) THEN
66422  DO 1060 i=nsav+3,n
66423  im=k(i,3)
66424  k(im,1)=k(im,1)-10
66425  k(im,4)=0
66426  k(im,5)=0
66427  1060 CONTINUE
66428  n=nsav
66429  goto 1080
66430  ENDIF
66431 
66432 C... Construct the collapsed hadron and modified string partons.
66433  DO 1070 j=1,4
66434  p(nsav+2,j)=p(nsav+2,j)+delta*pg(j)
66435  p(i1,j)=(1d0-delta*alpha)*p(i1,j)
66436  p(i2,j)=(1d0-delta*beta)*p(i2,j)
66437  1070 CONTINUE
66438  p(i1,5)=(1d0-delta*alpha)*p(i1,5)
66439  p(i2,5)=(1d0-delta*beta)*p(i2,5)
66440 
66441 C...Finished with string collapse in new scheme.
66442  goto 1120
66443  ENDIF
66444 
66445 C... Use old algorithm; by choice or when in trouble.
66446  1080 CONTINUE
66447 C...Find parton/particle which combines to largest extra mass.
66448  ir=0
66449  ha=0d0
66450  hsm=0d0
66451  DO 1100 mcomb=1,3
66452  IF(ir.NE.0) goto 1100
66453  DO 1090 i=max(1,ip),n
66454  IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2
66455  & .AND.k(i,1).GE.1.AND.k(i,1).LE.2)) goto 1090
66456  IF(mcomb.EQ.1) kci=pycomp(k(i,2))
66457  IF(mcomb.EQ.1.AND.kci.EQ.0) goto 1090
66458  IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) goto 1090
66459  IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
66460  & goto 1090
66461  hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
66462  hsr=2d0*hcr+pecm**2-p(n+2,5)**2-2d0*p(n+2,5)*p(i,5)
66463  IF(hsr.GT.hsm) THEN
66464  ir=i
66465  ha=hcr
66466  hsm=hsr
66467  ENDIF
66468  1090 CONTINUE
66469  1100 CONTINUE
66470 
66471 C...Shuffle energy and momentum to put new particle on mass shell.
66472  IF(ir.NE.0) THEN
66473  hb=pecm**2+ha
66474  hc=p(n+2,5)**2+ha
66475  hd=p(ir,5)**2+ha
66476  hk2=0.5d0*(hb*sqrt(max(0d0,((hb+hc)**2-4d0*(hb+hd)*p(n+2,5)**2)/
66477  & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
66478  hk1=(0.5d0*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
66479  DO 1110 j=1,4
66480  p(n+2,j)=(1d0+hk1)*dpc(j)-hk2*p(ir,j)
66481  p(ir,j)=(1d0+hk2)*p(ir,j)-hk1*dpc(j)
66482  1110 CONTINUE
66483  n=n+2
66484  ELSE
66485  CALL pyerrm(3,'(PYPREP:) no match for collapsing cluster')
66486  RETURN
66487  ENDIF
66488 
66489 C...Mark collapsed system and store daughter pointers. Iterate.
66490  1120 DO 1130 i=ic1,ic2
66491  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
66492  & kchg(pycomp(k(i,2)),2).NE.0) THEN
66493  k(i,1)=k(i,1)+10
66494  IF(mstu(16).NE.2) THEN
66495  k(i,4)=nsav+1
66496  k(i,5)=nsav+1
66497  ELSE
66498  k(i,4)=nsav+2
66499  k(i,5)=nsav+1+nbody
66500  ENDIF
66501  ENDIF
66502  IF(k(i,1).EQ.41) k(i,1)=k(i,1)+10
66503  1130 CONTINUE
66504  IF(n.LT.mstu(4)-mstu(32)-5) goto 710
66505 
66506 C...Check flavours and invariant masses in parton systems.
66507  1140 np=0
66508  kfn=0
66509  kqs=0
66510  nju=0
66511  DO 1150 j=1,5
66512  dps(j)=0d0
66513  1150 CONTINUE
66514  DO 1180 i=max(1,ip),n
66515  IF(k(i,1).EQ.41) nju=nju+1
66516  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 1180
66517  kc=pycomp(k(i,2))
66518  IF(kc.EQ.0) goto 1180
66519  kq=kchg(kc,2)*isign(1,k(i,2))
66520  IF(kq.EQ.0) goto 1180
66521  np=np+1
66522  IF(kq.NE.2) THEN
66523  kfn=kfn+1
66524  kqs=kqs+kq
66525  mstj(93)=1
66526  dps(5)=dps(5)+pymass(k(i,2))
66527  ENDIF
66528  DO 1160 j=1,4
66529  dps(j)=dps(j)+p(i,j)
66530  1160 CONTINUE
66531  IF(k(i,1).EQ.1) THEN
66532  nferr=0
66533  IF(nju.EQ.0.AND.np.NE.1) THEN
66534  IF(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0) nferr=1
66535  ELSEIF(nju.EQ.1) THEN
66536  IF(kfn.NE.3.OR.iabs(kqs).NE.3) nferr=1
66537  ELSEIF(nju.EQ.2) THEN
66538  IF(kfn.NE.4.OR.kqs.NE.0) nferr=1
66539  ELSEIF(nju.GE.3) THEN
66540  nferr=1
66541  ENDIF
66542  IF(nferr.EQ.1) THEN
66543  CALL pyerrm(2,'(PYPREP:) unphysical flavour combination')
66544  mint(51)=1
66545  RETURN
66546  ENDIF
66547  IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
66548  & (0.9d0*parj(32)+dps(5))**2) CALL pyerrm(3,
66549  & '(PYPREP:) too small mass in jet system')
66550  np=0
66551  kfn=0
66552  kqs=0
66553  nju=0
66554  DO 1170 j=1,5
66555  dps(j)=0d0
66556  1170 CONTINUE
66557  ENDIF
66558  1180 CONTINUE
66559 
66560  RETURN
66561  END
66562 
66563 C*********************************************************************
66564 
66565 C...PYSTRF
66566 C...Handles the fragmentation of an arbitrary colour singlet
66567 C...jet system according to the Lund string fragmentation model.
66568 
66569  SUBROUTINE pystrf(IP)
66570 
66571 C...Double precision and integer declarations.
66572  IMPLICIT DOUBLE PRECISION(a-h, o-z)
66573  IMPLICIT INTEGER(i-n)
66574  INTEGER pyk,pychge,pycomp
66575 C...Commonblocks.
66576  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
66577  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
66578  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
66579  SAVE /pyjets/,/pydat1/,/pydat2/
66580 C...Local arrays. All MOPS variables ends with MO
66581  dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
66582  &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(6),pju(5,5),
66583  &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8),
66584  &inmo(9),pm2qmo(2),xtmo(2),ejstr(2),ijuori(2),ibarrk(2),
66585  &pbst(3,5),tjuold(5)
66586 
66587 C...Function: four-product of two vectors.
66588  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)
66589  dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
66590  &dp(i,3)*dp(j,3)
66591 
66592 C...Reset counters.
66593  mstj(91)=0
66594  nsav=n
66595  mstu90=mstu(90)
66596  np=0
66597  kqsum=0
66598  DO 100 j=1,5
66599  dps(j)=0d0
66600  100 CONTINUE
66601  mju(1)=0
66602  mju(2)=0
66603  ntryfn=0
66604  ijuori(1)=0
66605  ijuori(2)=0
66606 
66607 C...Identify parton system.
66608  i=ip-1
66609  110 i=i+1
66610  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
66611  CALL pyerrm(12,'(PYSTRF:) failed to reconstruct jet system')
66612  IF(mstu(21).GE.1) RETURN
66613  ENDIF
66614  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 110
66615  kc=pycomp(k(i,2))
66616  IF(kc.EQ.0) goto 110
66617  kq=kchg(kc,2)*isign(1,k(i,2))
66618  IF(kq.EQ.0.AND.k(i,1).NE.41) goto 110
66619  IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
66620  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
66621  IF(mstu(21).GE.1) RETURN
66622  ENDIF
66623 
66624 C...Take copy of partons to be considered. Check flavour sum.
66625  np=np+1
66626  DO 120 j=1,5
66627  k(n+np,j)=k(i,j)
66628  p(n+np,j)=p(i,j)
66629  IF(j.NE.4) dps(j)=dps(j)+p(i,j)
66630  120 CONTINUE
66631  dps(4)=dps(4)+sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66632  k(n+np,3)=i
66633  IF(kq.NE.2) kqsum=kqsum+kq
66634  IF(k(i,1).EQ.41) THEN
66635  IF(mod(kqsum,2).EQ.0.AND.mju(1).EQ.0) THEN
66636  mju(1)=n+np
66637  ijuori(1)=i
66638  ELSE
66639  mju(2)=n+np
66640  ijuori(2)=i
66641  ENDIF
66642  ENDIF
66643  IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) goto 110
66644  IF(mod(kqsum,3).NE.0) THEN
66645  CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')
66646  IF(mstu(21).GE.1) RETURN
66647  ENDIF
66648  IF(mju(1).GT.0.OR.mju(2).GT.0) mstu(29)=1
66649 
66650 C...Boost copied system to CM frame (for better numerical precision).
66651  IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
66652  mbst=0
66653  mstu(33)=1
66654  CALL pyrobo(n+1,n+np,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
66655  & -dps(3)/dps(4))
66656  ELSE
66657  mbst=1
66658  hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
66659  DO 130 i=n+1,n+np
66660  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
66661  IF(p(i,3).GT.0d0) THEN
66662  hhpez=max(1d-10,(p(i,4)+p(i,3))/hhbz)
66663  p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
66664  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
66665  ELSE
66666  hhpez=max(1d-10,(p(i,4)-p(i,3))*hhbz)
66667  p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
66668  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
66669  ENDIF
66670  130 CONTINUE
66671  ENDIF
66672 
66673 C...Search for very nearby partons that may be recombined.
66674  ntryr=0
66675  ntrywr=0
66676  paru12=paru(12)
66677  paru13=paru(13)
66678  mju(3)=mju(1)
66679  mju(4)=mju(2)
66680  nr=np
66681  nrmin=2
66682  IF(mju(1).GT.0) nrmin=nrmin+2
66683  IF(mju(2).GT.0) nrmin=nrmin+2
66684  140 IF(nr.GT.nrmin) THEN
66685  pdrmin=2d0*paru12
66686  DO 150 i=n+1,n+nr
66687  IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) goto 150
66688  i1=i+1
66689  IF(i.EQ.n+nr) i1=n+1
66690  IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) goto 150
66691  IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
66692  & goto 150
66693  IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21)
66694  & goto 150
66695  pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
66696  & p(i1,2)**2+p(i1,3)**2))
66697  pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
66698  pdr=4d0*(pap-pvp)**2/max(1d-6,paru13**2*pap+2d0*(pap-pvp))
66699  IF(pdr.LT.pdrmin) THEN
66700  ir=i
66701  pdrmin=pdr
66702  ENDIF
66703  150 CONTINUE
66704 
66705 C...Recombine very nearby partons to avoid machine precision problems.
66706  IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
66707  DO 160 j=1,4
66708  p(n+1,j)=p(n+1,j)+p(n+nr,j)
66709  160 CONTINUE
66710  p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
66711  & p(n+1,3)**2))
66712  nr=nr-1
66713  goto 140
66714  ELSEIF(pdrmin.LT.paru12) THEN
66715  DO 170 j=1,4
66716  p(ir,j)=p(ir,j)+p(ir+1,j)
66717  170 CONTINUE
66718  p(ir,5)=sqrt(max(0d0,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
66719  & p(ir,3)**2))
66720  IF(mju(2).NE.0.AND.ir.GT.mju(2)) k(ir,2)=k(ir+1,2)
66721  DO 190 i=ir+1,n+nr-1
66722  k(i,1)=k(i+1,1)
66723  k(i,2)=k(i+1,2)
66724  DO 180 j=1,5
66725  p(i,j)=p(i+1,j)
66726  180 CONTINUE
66727  190 CONTINUE
66728  IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
66729  nr=nr-1
66730  IF(mju(1).GT.ir) mju(1)=mju(1)-1
66731  IF(mju(2).GT.ir) mju(2)=mju(2)-1
66732  goto 140
66733  ENDIF
66734  ENDIF
66735  ntryr=ntryr+1
66736 
66737 C...Reset particle counter. Skip ahead if no junctions are present;
66738 C...this is usually the case!
66739  nrs=max(5*nr+11,np)
66740  ntry=0
66741  200 ntry=ntry+1
66742  IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
66743  paru12=4d0*paru12
66744  paru13=2d0*paru13
66745  goto 140
66746  ELSEIF(ntry.GT.100.OR.ntryr.GT.100) THEN
66747  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
66748  IF(mstu(21).EQ.2) mstu(90)=0
66749  IF(mstu(21).GE.1) RETURN
66750  ENDIF
66751  i=n+nrs
66752  mstu(90)=mstu90
66753  IF(mju(1).EQ.0.AND.mju(2).EQ.0) goto 650
66754  IF(mstj(12).GE.4) CALL pyerrm(29,'(PYSTRF:) sorry,'//
66755  & ' junction strings not handled by MSTJ(12)>3 options')
66756  DO 640 jt=1,2
66757  njs(jt)=0
66758  IF(mju(jt).EQ.0) goto 640
66759  js=3-2*jt
66760 
66761 C++SKANDS
66762 C...Find and sum up momentum on three sides of junction.
66763 C...Begin with previous boost = zero.
66764  ijrfit=0
66765  DO 210 ix=1,3
66766  tjuold(ix)=0d0
66767  210 CONTINUE
66768 C...Prevent IJU (specifically IJU(5)) from containing junk below
66769  DO 215 iu=1,6
66770  iju(iu)=0
66771  215 CONTINUE
66772  tjuold(4)=1d0
66773  220 iu=0
66774 C...Beginning and end of string system in event record.
66775  i1beg=n+1+(jt-1)*(nr-1)
66776  i1end=n+nr+(jt-1)*(1-nr)
66777 C...Look for junction string piece end points
66778  DO 230 i1=i1beg,i1end,js
66779  IF(k(i1,2).NE.21.AND.iu.LE.5.AND.ijrfit.EQ.0) THEN
66780 C...Store junction string piece end points.
66781 C 1-junction systems 2-junction systems
66782 C IU : 1 2 3 4 1 2 3 4 5 6
66783 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
66784  iu=iu+1
66785  iju(iu)=i1
66786  ENDIF
66787 C...Sum over momenta, from junction outwards.
66788  230 CONTINUE
66789  DO 280 iu=1,3
66790  pwt=0d0
66791 C...Initialize junction drag and string piece 4-vectors.
66792  DO 240 j=1,5
66793  pbst(iu,j)=0d0
66794  pju(iu,j)=0d0
66795  240 CONTINUE
66796 C...First two branches. Inwards out means opposite direction to JS.
66797 C...(JS is 1 for JT=1, -1 for JT=2)
66798  IF (iu.LT.3) THEN
66799  i1a=iju(iu+1)-js
66800  i1b=iju(iu)
66801  idir=-js
66802 C...Last branch (gq or gjgqgq). Direction now reversed.
66803  ELSE
66804  i1a=iju(iu)+js
66805  i1b=i1end
66806  idir=js
66807  ENDIF
66808  DO 270 i1=i1a,i1b,idir
66809 C...Sum up momentum directions with exponential suppression
66810 C...for use in finding junction rest frame below.
66811  IF (k(i1,2).EQ.88) THEN
66812 C...gjgqgq type system encountered. Use current PWT as start
66813 C...for both strings.
66814  pwtold=pwt
66815  ELSE
66816  IF (i1.EQ.iju(5)+idir) pwt=pwtold
66817 C...Sum up string piece (boosted) 4-momenta.
66818  DO 250 j=1,4
66819  pju(iu,j)=pju(iu,j)+p(i1,j)
66820  250 CONTINUE
66821 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
66822 C...boost is zero, see above). Skip parton if suppression factor large.
66823  IF (pwt.GT.10d0) goto 270
66824 C...Compute momentum in current frame:
66825  tdp=tjuold(1)*p(i1,1)+tjuold(2)*p(i1,2)+tjuold(3)*p(i1,3)
66826  bfc=tdp/(1d0+tjuold(4))+p(i1,4)
66827  DO 260 j=1,3
66828  ptmp=p(i1,j)+tjuold(j)*bfc
66829  pbst(iu,j)=pbst(iu,j)+ptmp*exp(-pwt)
66830  260 CONTINUE
66831 C...Boosted energy
66832  ptmp=tjuold(4)*p(i1,4)+tdp
66833  pbst(iu,4)=pbst(iu,j)+ptmp*exp(-pwt)
66834  pwt=pwt+ptmp/parj(48)
66835  ENDIF
66836  270 CONTINUE
66837 C...Put |p| rather than m in 5th slot.
66838  pbst(iu,5)=sqrt(pbst(iu,1)**2+pbst(iu,2)**2+pbst(iu,3)**2)
66839  pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
66840  280 CONTINUE
66841 
66842 C...Calculate boost from present frame to next JRF candidate.
66843  ijrfit=ijrfit+1
66844  CALL pyjurf(pbst,tju)
66845 
66846 C...After some iterations do not take full step in new direction.
66847  IF(ijrfit.GT.5) THEN
66848  reduce=0.8d0**(ijrfit-5)
66849  tju(1)=reduce*tju(1)
66850  tju(2)=reduce*tju(2)
66851  tju(3)=reduce*tju(3)
66852  tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
66853  ENDIF
66854 
66855 C...Combine new boost (TJU) with old boost (TJUOLD)
66856  tmp=tju(1)*tjuold(1)+tju(2)*tjuold(2)+tju(3)*tjuold(3)
66857  DO 290 ix=1,3
66858  tjuold(ix)=tju(ix)+tjuold(ix)*(tmp/(1d0+tjuold(4))+tju(4))
66859  290 CONTINUE
66860  tjuold(4)=sqrt(1d0+tjuold(1)**2+tjuold(2)**2+tjuold(3)**2)
66861 
66862 C...If last boost small, accept JRF, else iterate.
66863 C...Also prevent possibility of infinite loop.
66864  IF (abs((tju(4)-1d0)/tjuold(4)).GT.0.01d0.AND.
66865  & ijrfit.LT.mstj(18)) THEN
66866  goto 220
66867  ELSEIF (ijrfit.GE.mstj(18)) THEN
66868  CALL pyerrm(1,'(PYSTRF:) failed to converge on JRF')
66869  ENDIF
66870 
66871 C...Now store total boost in TJU and change perception.
66872 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
66873 C...TJU = junction motion vector in string CM, so the sign changes.
66874  DO 300 j=1,3
66875  tju(j)=-tjuold(j)
66876  300 CONTINUE
66877  tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
66878 
66879 C--SKANDS
66880 
66881 C...Calculate string piece energies in junction rest frame.
66882  DO 310 iu=1,3
66883  pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
66884  & tju(3)*pju(iu,3)
66885  pbst(iu,5)=tju(4)*pbst(iu,4)-tju(1)*pbst(iu,1)-
66886  & tju(2)*pbst(iu,2)-tju(3)*pbst(iu,3)
66887  310 CONTINUE
66888 
66889 C...Start preparing for fragmentation of two strings from junction.
66890  ista=i
66891  ntryer=0
66892  320 ntryer=ntryer+1
66893  mstu(90)=mstu90
66894  i=ista
66895  DO 620 iu=1,2
66896  ns=iabs(iju(iu+1)-iju(iu))
66897 
66898 C...Junction strings: find longitudinal string directions.
66899  DO 350 is=1,ns
66900  is1=iju(iu)+js*(is-1)
66901  is2=iju(iu)+js*is
66902  DO 330 j=1,5
66903  dp(1,j)=0.5d0*p(is1,j)
66904  IF(is.EQ.1) dp(1,j)=p(is1,j)
66905  dp(2,j)=0.5d0*p(is2,j)
66906  IF(is.EQ.ns) dp(2,j)=(-pbst(iu,j)+2d0*pbst(iu,5)*tju(j))*
66907  & (pju(iu,5)/pbst(iu,5))
66908  330 CONTINUE
66909  IF(is.EQ.ns) dp(2,5)=sqrt(max(0d0,pju(iu,4)**2-
66910  & pju(iu,1)**2-pju(iu,2)**2-pju(iu,3)**2))
66911  dp(3,5)=dfour(1,1)
66912  dp(4,5)=dfour(2,2)
66913  dhkc=dfour(1,2)
66914  IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN
66915  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
66916  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
66917  dp(3,5)=0d0
66918  dp(4,5)=0d0
66919  dhkc=dfour(1,2)
66920  ENDIF
66921  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
66922  dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
66923  dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
66924  in1=n+nr+4*is-3
66925  p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
66926  DO 340 j=1,4
66927  p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
66928  p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
66929  340 CONTINUE
66930  350 CONTINUE
66931 
66932 C...Junction strings: initialize flavour, momentum and starting pos.
66933  isav=i
66934  mstu91=mstu(90)
66935  360 ntry=ntry+1
66936  IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
66937  paru12=4d0*paru12
66938  paru13=2d0*paru13
66939  goto 140
66940  ELSEIF(ntry.GT.100) THEN
66941  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
66942  IF(mstu(21).EQ.2) mstu(90)=0
66943  IF(mstu(21).GE.1) RETURN
66944  ENDIF
66945  i=isav
66946  mstu(90)=mstu91
66947  irankj=0
66948  ie(1)=k(n+1+(jt/2)*(np-1),3)
66949  IF (mod(jt+iu,2).NE.0) THEN
66950  ie(1)=k(iju(iu),3)
66951  IF (np-nr.NE.0) THEN
66952 C...If gluons have disappeared. Original IJU must be used.
66953  it=ip
66954  ne=1
66955  370 it=it+1
66956  IF (k(it,2).NE.21) THEN
66957  ne=ne+1
66958  ENDIF
66959  IF (ne.EQ.iu+4*(jt-1)) THEN
66960  ie(1)=it
66961  ELSEIF (it.LE.ip+np) THEN
66962  goto 370
66963  ELSE
66964  CALL pyerrm(14,'(PYSTRF:) '//
66965  & 'Original IJU could not be reconstructed!')
66966  ENDIF
66967  ENDIF
66968  ENDIF
66969  in(4)=n+nr+1
66970  in(5)=in(4)+1
66971  in(6)=n+nr+4*ns+1
66972  DO 390 jq=1,2
66973  DO 380 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
66974  p(in1,1)=2-jq
66975  p(in1,2)=jq-1
66976  p(in1,3)=1d0
66977  380 CONTINUE
66978  390 CONTINUE
66979  kfl(1)=k(iju(iu),2)
66980  px(1)=0d0
66981  py(1)=0d0
66982  gam(1)=0d0
66983  DO 400 j=1,5
66984  pju(iu+3,j)=0d0
66985  400 CONTINUE
66986 
66987 C...Junction strings: find initial transverse directions.
66988  DO 410 j=1,4
66989  dp(1,j)=p(in(4),j)
66990  dp(2,j)=p(in(4)+1,j)
66991  dp(3,j)=0d0
66992  dp(4,j)=0d0
66993  410 CONTINUE
66994  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
66995  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
66996  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
66997  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
66998  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
66999  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
67000  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
67001  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
67002  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
67003  dhc12=dfour(1,2)
67004  dhcx1=dfour(3,1)/dhc12
67005  dhcx2=dfour(3,2)/dhc12
67006  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
67007  dhcy1=dfour(4,1)/dhc12
67008  dhcy2=dfour(4,2)/dhc12
67009  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
67010  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
67011  DO 420 j=1,4
67012  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
67013  p(in(6),j)=dp(3,j)
67014  p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
67015  & dhcyx*dp(3,j))
67016  420 CONTINUE
67017 
67018 C...Junction strings: produce new particle, origin.
67019  430 i=i+1
67020  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
67021  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
67022  IF(mstu(21).GE.1) RETURN
67023  ENDIF
67024  irankj=irankj+1
67025  k(i,1)=1
67026  k(i,3)=ie(1)
67027  k(i,4)=0
67028  k(i,5)=0
67029 
67030 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
67031  440 CALL pykfdi(kfl(1),0,kfl(3),k(i,2))
67032  IF(k(i,2).EQ.0) goto 360
67033  IF(irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
67034  & iabs(kfl(3)).GT.10) THEN
67035  IF(pyr(0).GT.parj(19)) goto 440
67036  ENDIF
67037  p(i,5)=pymass(k(i,2))
67038  CALL pyptdi(kfl(1),px(3),py(3))
67039  pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
67040  CALL pyzdis(kfl(1),kfl(3),pr(1),z)
67041  IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
67042  & mstu(90).LT.8) THEN
67043  mstu(90)=mstu(90)+1
67044  mstu(90+mstu(90))=i
67045  paru(90+mstu(90))=z
67046  ENDIF
67047  gam(3)=(1d0-z)*(gam(1)+pr(1)/z)
67048  DO 450 j=1,3
67049  in(j)=in(3+j)
67050  450 CONTINUE
67051 
67052 C...Junction strings: stepping within 'low' string region.
67053  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
67054  & p(in(1),5)**2.GE.pr(1)) THEN
67055  p(in(1)+2,4)=z*p(in(1)+2,3)
67056  p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
67057  DO 460 j=1,4
67058  p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
67059  460 CONTINUE
67060  goto 560
67061 C...Has used up energy of junction string, i.e. no more hadrons in it.
67062  ELSEIF(in(1)+1.EQ.in(2).AND.in(1).EQ.n+nr+4*ns-3) THEN
67063  DO 470 j=1,5
67064  p(i,j)=0d0
67065  470 CONTINUE
67066  goto 600
67067 C...Stepping from 'low' string region
67068  ELSEIF(in(1)+1.EQ.in(2)) THEN
67069  p(in(2)+2,4)=p(in(2)+2,3)
67070  p(in(2)+2,1)=1d0
67071  in(2)=in(2)+4
67072  IF(in(2).GT.n+nr+4*ns) goto 360
67073  IF(four(in(1),in(2)).LE.1d-2) THEN
67074  p(in(1)+2,4)=p(in(1)+2,3)
67075  p(in(1)+2,1)=0d0
67076  in(1)=in(1)+4
67077  ENDIF
67078  ENDIF
67079 
67080 C...Junction strings: find new transverse directions.
67081  480 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
67082  & in(1).GT.in(2)) goto 360
67083  IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
67084  DO 490 j=1,4
67085  dp(1,j)=p(in(1),j)
67086  dp(2,j)=p(in(2),j)
67087  dp(3,j)=0d0
67088  dp(4,j)=0d0
67089  490 CONTINUE
67090  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
67091  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
67092  dhc12=dfour(1,2)
67093  IF(dhc12.LE.1d-2) THEN
67094  p(in(1)+2,4)=p(in(1)+2,3)
67095  p(in(1)+2,1)=0d0
67096  in(1)=in(1)+4
67097  goto 480
67098  ENDIF
67099  in(3)=n+nr+4*ns+5
67100  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
67101  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
67102  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
67103  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
67104  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
67105  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
67106  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
67107  dhcx1=dfour(3,1)/dhc12
67108  dhcx2=dfour(3,2)/dhc12
67109  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
67110  dhcy1=dfour(4,1)/dhc12
67111  dhcy2=dfour(4,2)/dhc12
67112  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
67113  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
67114  DO 500 j=1,4
67115  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
67116  p(in(3),j)=dp(3,j)
67117  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
67118  & dhcyx*dp(3,j))
67119  500 CONTINUE
67120 C...Express pT with respect to new axes, if sensible.
67121  pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
67122  pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
67123  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
67124  px(3)=pxp
67125  py(3)=pyp
67126  ENDIF
67127  ENDIF
67128 
67129 C...Junction strings: sum up known four-momentum, coefficients for m2.
67130  DO 530 j=1,4
67131  dhg(j)=0d0
67132  p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
67133  & py(3)*p(in(3)+1,j)
67134  DO 510 in1=in(4),in(1)-4,4
67135  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
67136  510 CONTINUE
67137  DO 520 in2=in(5),in(2)-4,4
67138  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
67139  520 CONTINUE
67140  530 CONTINUE
67141  dhm(1)=four(i,i)
67142  dhm(2)=2d0*four(i,in(1))
67143  dhm(3)=2d0*four(i,in(2))
67144  dhm(4)=2d0*four(in(1),in(2))
67145 
67146 C...Junction strings: find coefficients for Gamma expression.
67147  DO 550 in2=in(1)+1,in(2),4
67148  DO 540 in1=in(1),in2-1,4
67149  dhc=2d0*four(in1,in2)
67150  dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
67151  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
67152  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
67153  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
67154  540 CONTINUE
67155  550 CONTINUE
67156 
67157 C...Junction strings: solve (m2, Gamma) equation system for energies.
67158  dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
67159  IF(abs(dhs1).LT.1d-4) goto 360
67160  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
67161  & (p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
67162  dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
67163  p(in(2)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
67164  & abs(dhs1)-dhs2/dhs1)
67165  IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0d0) goto 360
67166  p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
67167  & (dhm(2)+dhm(4)*p(in(2)+2,4))
67168 
67169 C...Junction strings: step to new region if necessary.
67170  IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
67171  p(in(2)+2,4)=p(in(2)+2,3)
67172  p(in(2)+2,1)=1d0
67173  in(2)=in(2)+4
67174  IF(in(2).GT.n+nr+4*ns) goto 360
67175  IF(four(in(1),in(2)).LE.1d-2) THEN
67176  p(in(1)+2,4)=p(in(1)+2,3)
67177  p(in(1)+2,1)=0d0
67178  in(1)=in(1)+4
67179  ENDIF
67180  goto 480
67181  ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
67182  p(in(1)+2,4)=p(in(1)+2,3)
67183  p(in(1)+2,1)=0d0
67184  in(1)=in(1)+4
67185  goto 480
67186  ENDIF
67187 
67188 C...Junction strings: particle four-momentum, remainder, loop back.
67189  560 DO 570 j=1,4
67190  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+
67191  & p(in(2)+2,4)*p(in(2),j)
67192  pju(iu+3,j)=pju(iu+3,j)+p(i,j)
67193  570 CONTINUE
67194  IF(p(i,4).LT.p(i,5)) goto 360
67195  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
67196  & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
67197  IF(pju(iu+3,5).LT.pju(iu,5)) THEN
67198  kfl(1)=-kfl(3)
67199  px(1)=-px(3)
67200  py(1)=-py(3)
67201  gam(1)=gam(3)
67202  IF(in(3).NE.in(6)) THEN
67203  DO 580 j=1,4
67204  p(in(6),j)=p(in(3),j)
67205  p(in(6)+1,j)=p(in(3)+1,j)
67206  580 CONTINUE
67207  ENDIF
67208  DO 590 jq=1,2
67209  in(3+jq)=in(jq)
67210  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
67211  p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
67212  590 CONTINUE
67213  goto 430
67214  ENDIF
67215 
67216 C...Junction strings: save quantities left after each string.
67217  IF(iabs(kfl(1)).GT.10) goto 360
67218  600 i=i-1
67219  IF(mstu(90+mstu(90)).EQ.i+1) mstu(90)=mstu(90)-1
67220  kfjh(iu)=kfl(1)
67221  DO 610 j=1,4
67222  pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
67223  610 CONTINUE
67224 
67225 C...Junction strings: loopback if much unused energy in both strings.
67226  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
67227  & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
67228  ejstr(iu)=pju(iu,5)-pju(iu+3,5)
67229  620 CONTINUE
67230  IF((min(ejstr(1),ejstr(2)).GT.parj(49).OR.
67231  & ejstr(1).GT.parj(49)+pyr(0)*parj(50).OR.
67232  & ejstr(2).GT.parj(49)+pyr(0)*parj(50))
67233  & .AND.ntryer.LT.10) goto 320
67234 
67235 C...Junction strings: put together to new effective string endpoint.
67236  njs(jt)=i-ista
67237  kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
67238  IF(kfjh(1).EQ.kfjh(2)) kfls=3
67239  kfjs(jt)=isign(1000*max(iabs(kfjh(1)),iabs(kfjh(2)))+
67240  & 100*min(iabs(kfjh(1)),iabs(kfjh(2)))+kfls,kfjh(1))
67241  DO 630 j=1,4
67242  pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
67243  pjs(jt+2,j)=pju(4,j)+pju(5,j)
67244  630 CONTINUE
67245  pjs(jt,5)=sqrt(max(0d0,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
67246  & pjs(jt,3)**2))
67247  pjs(jt+2,5)=0d0
67248  640 CONTINUE
67249 
67250 C...Open versus closed strings. Choose breakup region for latter.
67251  650 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
67252  ns=mju(2)-mju(1)
67253  nb=mju(1)-n
67254  ELSEIF(mju(1).NE.0) THEN
67255  ns=n+nr-mju(1)
67256  nb=mju(1)-n
67257  ELSEIF(mju(2).NE.0) THEN
67258  ns=mju(2)-n
67259  nb=1
67260  ELSEIF(iabs(k(n+1,2)).NE.21) THEN
67261  ns=nr-1
67262  nb=1
67263  ELSE
67264  ns=nr+1
67265  w2sum=0d0
67266  DO 660 is=1,nr
67267  p(n+nr+is,1)=0.5d0*four(n+is,n+is+1-nr*(is/nr))
67268  w2sum=w2sum+p(n+nr+is,1)
67269  660 CONTINUE
67270  w2ran=pyr(0)*w2sum
67271  nb=0
67272  670 nb=nb+1
67273  w2sum=w2sum-p(n+nr+nb,1)
67274  IF(w2sum.GT.w2ran.AND.nb.LT.nr) goto 670
67275  ENDIF
67276 
67277 C...Find longitudinal string directions (i.e. lightlike four-vectors).
67278  DO 700 is=1,ns
67279  is1=n+is+nb-1-nr*((is+nb-2)/nr)
67280  is2=n+is+nb-nr*((is+nb-1)/nr)
67281  DO 680 j=1,5
67282  dp(1,j)=p(is1,j)
67283  IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5d0*dp(1,j)
67284  IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
67285  dp(2,j)=p(is2,j)
67286  IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5d0*dp(2,j)
67287  IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
67288  680 CONTINUE
67289  IF(is1.EQ.mju(1)) dp(1,5)=sqrt(max(0d0,dp(1,4)**2-dp(1,1)**2-
67290  & dp(1,2)**2-dp(1,3)**2))
67291  IF(is2.EQ.mju(2)) dp(2,5)=sqrt(max(0d0,dp(2,4)**2-dp(2,1)**2-
67292  & dp(2,2)**2-dp(2,3)**2))
67293  dp(3,5)=dfour(1,1)
67294  dp(4,5)=dfour(2,2)
67295  dhkc=dfour(1,2)
67296  IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) goto 200
67297  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
67298  dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
67299  dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
67300  in1=n+nr+4*is-3
67301  p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
67302  DO 690 j=1,4
67303  p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
67304  p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
67305  690 CONTINUE
67306  700 CONTINUE
67307 
67308 C...Begin initialization: sum up energy, set starting position.
67309  isav=i
67310  mstu91=mstu(90)
67311  710 ntry=ntry+1
67312  IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
67313  paru12=4d0*paru12
67314  paru13=2d0*paru13
67315  goto 140
67316  ELSEIF(ntry.GT.100) THEN
67317  CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
67318  IF(mstu(21).EQ.2) mstu(90)=0
67319  IF(mstu(21).GE.1) RETURN
67320  ENDIF
67321  i=isav
67322  mstu(90)=mstu91
67323  DO 730 j=1,4
67324  p(n+nrs,j)=0d0
67325  DO 720 is=1,nr
67326  p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
67327  720 CONTINUE
67328  730 CONTINUE
67329  DO 750 jt=1,2
67330  irank(jt)=0
67331  IF(mju(jt).NE.0) irank(jt)=njs(jt)
67332  IF(ns.GT.nr) irank(jt)=1
67333  ibarrk(jt)=0
67334  ie(jt)=k(n+1+(jt/2)*(np-1),3)
67335  in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
67336  in(3*jt+2)=in(3*jt+1)+1
67337  in(3*jt+3)=n+nr+4*ns+2*jt-1
67338  DO 740 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
67339  p(in1,1)=2-jt
67340  p(in1,2)=jt-1
67341  p(in1,3)=1d0
67342  740 CONTINUE
67343  750 CONTINUE
67344 
67345 C.. MOPS variables and switches
67346  nrvmo=0
67347  xbmo=1d0
67348  mstu(121)=0
67349  mstu(122)=0
67350 
67351 C...Initialize flavour and pT variables for open string.
67352  IF(ns.LT.nr) THEN
67353  px(1)=0d0
67354  py(1)=0d0
67355  IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL pyptdi(0,px(1),py(1))
67356  px(2)=-px(1)
67357  py(2)=-py(1)
67358  DO 760 jt=1,2
67359  kfl(jt)=k(ie(jt),2)
67360  IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
67361  IF(mju(jt).NE.0.AND.iabs(kfl(jt)).GT.1000) ibarrk(jt)=1
67362  mstj(93)=1
67363  pmq(jt)=pymass(kfl(jt))
67364  gam(jt)=0d0
67365  760 CONTINUE
67366 
67367 C...Closed string: random initial breakup flavour, pT and vertex.
67368  ELSE
67369  kfl(3)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
67370  ibmo=0
67371  770 CALL pykfdi(kfl(3),0,kfl(1),kdump)
67372 C.. Closed string: first vertex diq attempt => enforced second
67373 C.. vertex diq
67374  IF(iabs(kfl(1)).GT.10)THEN
67375  ibmo=1
67376  mstu(121)=0
67377  goto 770
67378  ENDIF
67379  IF(ibmo.EQ.1) mstu(121)=-1
67380  kfl(2)=-kfl(1)
67381  CALL pyptdi(kfl(1),px(1),py(1))
67382  px(2)=-px(1)
67383  py(2)=-py(1)
67384  pr3=min(25d0,0.1d0*p(n+nr+1,5)**2)
67385  780 CALL pyzdis(kfl(1),kfl(2),pr3,z)
67386  zr=pr3/(z*p(n+nr+1,5)**2)
67387  IF(zr.GE.1d0) goto 780
67388  DO 790 jt=1,2
67389  mstj(93)=1
67390  pmq(jt)=pymass(kfl(jt))
67391  gam(jt)=pr3*(1d0-z)/z
67392  in1=n+nr+3+4*(jt/2)*(ns-1)
67393  p(in1,jt)=1d0-z
67394  p(in1,3-jt)=jt-1
67395  p(in1,3)=(2-jt)*(1d0-z)+(jt-1)*z
67396  p(in1+1,jt)=zr
67397  p(in1+1,3-jt)=2-jt
67398  p(in1+1,3)=(2-jt)*(1d0-zr)+(jt-1)*zr
67399  790 CONTINUE
67400  ENDIF
67401 C.. MOPS variables
67402  DO 800 jt=1,2
67403  xtmo(jt)=1d0
67404  pm2qmo(jt)=pmq(jt)**2
67405  IF(iabs(kfl(jt)).GT.10) pm2qmo(jt)=0d0
67406  800 CONTINUE
67407 
67408 C...Find initial transverse directions (i.e. spacelike four-vectors).
67409  DO 840 jt=1,2
67410  IF(jt.EQ.1.OR.ns.EQ.nr-1.OR.mju(1)+mju(2).NE.0) THEN
67411  in1=in(3*jt+1)
67412  in3=in(3*jt+3)
67413  DO 810 j=1,4
67414  dp(1,j)=p(in1,j)
67415  dp(2,j)=p(in1+1,j)
67416  dp(3,j)=0d0
67417  dp(4,j)=0d0
67418  810 CONTINUE
67419  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
67420  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
67421  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
67422  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
67423  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
67424  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
67425  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
67426  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
67427  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
67428  dhc12=dfour(1,2)
67429  dhcx1=dfour(3,1)/dhc12
67430  dhcx2=dfour(3,2)/dhc12
67431  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
67432  dhcy1=dfour(4,1)/dhc12
67433  dhcy2=dfour(4,2)/dhc12
67434  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
67435  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
67436  DO 820 j=1,4
67437  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
67438  p(in3,j)=dp(3,j)
67439  p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
67440  & dhcyx*dp(3,j))
67441  820 CONTINUE
67442  ELSE
67443  DO 830 j=1,4
67444  p(in3+2,j)=p(in3,j)
67445  p(in3+3,j)=p(in3+1,j)
67446  830 CONTINUE
67447  ENDIF
67448  840 CONTINUE
67449 
67450 C...Remove energy used up in junction string fragmentation.
67451  IF(mju(1)+mju(2).GT.0) THEN
67452  DO 860 jt=1,2
67453  IF(njs(jt).EQ.0) goto 860
67454  DO 850 j=1,4
67455  p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
67456  850 CONTINUE
67457  860 CONTINUE
67458  parjst=parj(33)
67459  IF(mstj(11).EQ.2) parjst=parj(34)
67460  wmin=parjst+pmq(1)+pmq(2)
67461  wrem2=four(n+nrs,n+nrs)
67462  IF(p(n+nrs,4).LT.0d0.OR.wrem2.LT.wmin**2) THEN
67463  ntrywr=ntrywr+1
67464  IF(mod(ntrywr,20).NE.0) ntryr=ntryr-1
67465  goto 140
67466  ENDIF
67467  ENDIF
67468 
67469 C...Produce new particle: side, origin.
67470  870 i=i+1
67471  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
67472  CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
67473  IF(mstu(21).GE.1) RETURN
67474  ENDIF
67475 C.. New side priority for popcorn systems
67476  IF(mstu(121).LE.0)THEN
67477  jt=1.5d0+pyr(0)
67478  IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
67479  IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
67480  ENDIF
67481  jr=3-jt
67482  js=3-2*jt
67483  irank(jt)=irank(jt)+1
67484  k(i,1)=1
67485  k(i,4)=0
67486  k(i,5)=0
67487 
67488 C...Generate flavour, hadron and pT.
67489  880 k(i,3)=ie(jt)
67490  CALL pykfdi(kfl(jt),0,kfl(3),k(i,2))
67491  IF(k(i,2).EQ.0) goto 710
67492  mu90mo=mstu(90)
67493  IF(mstu(121).EQ.-1) goto 910
67494  IF(irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
67495  &iabs(kfl(3)).GT.10) THEN
67496  IF(pyr(0).GT.parj(19)) goto 880
67497  ENDIF
67498  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
67499  &k(i,3)=ijuori(jt)
67500  p(i,5)=pymass(k(i,2))
67501  CALL pyptdi(kfl(jt),px(3),py(3))
67502  pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
67503 
67504 C...Final hadrons for small invariant mass.
67505  mstj(93)=1
67506  pmq(3)=pymass(kfl(3))
67507  parjst=parj(33)
67508  IF(mstj(11).EQ.2) parjst=parj(34)
67509  wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
67510  IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
67511  &wmin-0.5d0*parj(36)*pmq(3)
67512  wrem2=four(n+nrs,n+nrs)
67513  IF(wrem2.LT.0.10d0) goto 710
67514  IF(wrem2.LT.max(wmin*(1d0+(2d0*pyr(0)-1d0)*parj(37)),
67515  &parj(32)+pmq(1)+pmq(2))**2) goto 1080
67516 
67517 C...Choose z, which gives Gamma. Shift z for heavy flavours.
67518  CALL pyzdis(kfl(jt),kfl(3),pr(jt),z)
67519  IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
67520  &mstu(90).LT.8) THEN
67521  mstu(90)=mstu(90)+1
67522  mstu(90+mstu(90))=i
67523  paru(90+mstu(90))=z
67524  ENDIF
67525  kfl1a=iabs(kfl(1))
67526  kfl2a=iabs(kfl(2))
67527  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
67528  &mod(kfl2a/1000,10)).GE.4) THEN
67529  pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
67530  pw12=sqrt(max(0d0,(wrem2-pr(1)-pr(2))**2-4d0*pr(1)*pr(2)))
67531  z=(wrem2+pr(jt)-pr(jr)+pw12*(2d0*z-1d0))/(2d0*wrem2)
67532  pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
67533  IF((1d0-z)*(wrem2-pr(jt)/z).LT.pr(jr)) goto 1080
67534  ENDIF
67535  gam(3)=(1d0-z)*(gam(jt)+pr(jt)/z)
67536 
67537 C.. MOPS baryon model modification
67538  xtmo3=(1d0-z)*xtmo(jt)
67539  IF(iabs(kfl(3)).LE.10) nrvmo=0
67540  IF(iabs(kfl(3)).GT.10.AND.mstj(12).GE.4) THEN
67541  gtstmo=1d0
67542  ptstmo=1d0
67543  rtstmo=pyr(0)
67544  IF(iabs(kfl(jt)).LE.10)THEN
67545  xbmo=min(xtmo3,1d0-(2d-10))
67546  gbmo=gam(3)
67547  pmmo=0d0
67548  pgmo=gbmo+log(1d0-xbmo)*pm2qmo(jt)
67549  gtstmo=1d0-parf(192)**pgmo
67550  ELSE
67551  IF(irank(jt).EQ.1) THEN
67552  gbmo=gam(jt)
67553  pmmo=0d0
67554  xbmo=1d0
67555  ENDIF
67556  IF(xbmo.LT.1d0-(1d-10))THEN
67557  pgnmo=gbmo*xtmo3/xbmo+pm2qmo(jt)*log(1d0-xtmo3)
67558  gtstmo=(1d0-parf(192)**pgnmo)/(1d0-parf(192)**pgmo)
67559  pgmo=pgnmo
67560  ENDIF
67561  IF(mstj(12).GE.5)THEN
67562  pmnmo=sqrt((xbmo-xtmo3)*(gam(3)/xtmo3-gbmo/xbmo))
67563  pmmo=pmmo+pmas(pycomp(k(i,2)),1)-pmas(pycomp(k(i,2)),3)
67564  ptstmo=exp((pmmo-pmnmo)*parf(193))
67565  pmmo=pmnmo
67566  ENDIF
67567  ENDIF
67568 
67569 C.. MOPS Accepting popcorn system hadron.
67570  IF(ptstmo*gtstmo.GT.rtstmo) THEN
67571  IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) THEN
67572  nrvmo=i-n-nr
67573  IF(i+nrvmo.GT.mstu(4)-mstu(32)-5) THEN
67574  CALL pyerrm(11,
67575  & '(PYSTRF:) no more memory left in PYJETS')
67576  IF(mstu(21).GE.1) RETURN
67577  ENDIF
67578  imo=i
67579  kflmo=kfl(jt)
67580  pmqmo=pmq(jt)
67581  pxmo=px(jt)
67582  pymo=py(jt)
67583  gammo=gam(jt)
67584  irmo=irank(jt)
67585  xmo=xtmo(jt)
67586  DO 900 j=1,9
67587  IF(j.LE.5) THEN
67588  DO 890 line=1,i-n-nr
67589  p(mstu(4)-mstu(32)-line,j)=p(n+nr+line,j)
67590  k(mstu(4)-mstu(32)-line,j)=k(n+nr+line,j)
67591  890 CONTINUE
67592  ENDIF
67593  inmo(j)=in(j)
67594  900 CONTINUE
67595  ENDIF
67596  ELSE
67597 C..Reject popcorn system, flag=-1 if enforcing new one
67598  mstu(121)=-1
67599  IF(ptstmo.GT.rtstmo) mstu(121)=-2
67600  ENDIF
67601  ENDIF
67602 
67603 
67604 C..Lift restoring string outside MOPS block
67605  910 IF(mstu(121).LT.0) THEN
67606  IF(mstu(121).EQ.-2) mstu(121)=0
67607  mstu(90)=mu90mo
67608  nrvmo=0
67609  IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) goto 880
67610  i=imo
67611  kfl(jt)=kflmo
67612  pmq(jt)=pmqmo
67613  px(jt)=pxmo
67614  py(jt)=pymo
67615  gam(jt)=gammo
67616  irank(jt)=irmo
67617  xtmo(jt)=xmo
67618  DO 930 j=1,9
67619  IF(j.LE.5) THEN
67620  DO 920 line=1,i-n-nr
67621  p(n+nr+line,j)=p(mstu(4)-mstu(32)-line,j)
67622  k(n+nr+line,j)=k(mstu(4)-mstu(32)-line,j)
67623  920 CONTINUE
67624  ENDIF
67625  in(j)=inmo(j)
67626  930 CONTINUE
67627  goto 880
67628  ENDIF
67629  xtmo(jt)=xtmo3
67630 C.. MOPS end of modification
67631 
67632  DO 940 j=1,3
67633  in(j)=in(3*jt+j)
67634  940 CONTINUE
67635 
67636 C...Stepping within or from 'low' string region easy.
67637  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
67638  &p(in(1),5)**2.GE.pr(jt)) THEN
67639  p(in(jt)+2,4)=z*p(in(jt)+2,3)
67640  p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
67641  DO 950 j=1,4
67642  p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
67643  950 CONTINUE
67644  goto 1040
67645  ELSEIF(in(1)+1.EQ.in(2)) THEN
67646  p(in(jr)+2,4)=p(in(jr)+2,3)
67647  p(in(jr)+2,jt)=1d0
67648  in(jr)=in(jr)+4*js
67649  IF(js*in(jr).GT.js*in(4*jr)) goto 710
67650  IF(four(in(1),in(2)).LE.1d-2) THEN
67651  p(in(jt)+2,4)=p(in(jt)+2,3)
67652  p(in(jt)+2,jt)=0d0
67653  in(jt)=in(jt)+4*js
67654  ENDIF
67655  ENDIF
67656 
67657 C...Find new transverse directions (i.e. spacelike string vectors).
67658  960 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
67659  &in(1).GT.in(2)) goto 710
67660  IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
67661  DO 970 j=1,4
67662  dp(1,j)=p(in(1),j)
67663  dp(2,j)=p(in(2),j)
67664  dp(3,j)=0d0
67665  dp(4,j)=0d0
67666  970 CONTINUE
67667  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
67668  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
67669  dhc12=dfour(1,2)
67670  IF(dhc12.LE.1d-2) THEN
67671  p(in(jt)+2,4)=p(in(jt)+2,3)
67672  p(in(jt)+2,jt)=0d0
67673  in(jt)=in(jt)+4*js
67674  goto 960
67675  ENDIF
67676  in(3)=n+nr+4*ns+5
67677  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
67678  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
67679  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
67680  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
67681  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
67682  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
67683  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
67684  dhcx1=dfour(3,1)/dhc12
67685  dhcx2=dfour(3,2)/dhc12
67686  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
67687  dhcy1=dfour(4,1)/dhc12
67688  dhcy2=dfour(4,2)/dhc12
67689  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
67690  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
67691  DO 980 j=1,4
67692  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
67693  p(in(3),j)=dp(3,j)
67694  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
67695  & dhcyx*dp(3,j))
67696  980 CONTINUE
67697 C...Express pT with respect to new axes, if sensible.
67698  pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
67699  & four(in(3*jt+3)+1,in(3)))
67700  pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
67701  & four(in(3*jt+3)+1,in(3)+1))
67702  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
67703  px(3)=pxp
67704  py(3)=pyp
67705  ENDIF
67706  ENDIF
67707 
67708 C...Sum up known four-momentum. Gives coefficients for m2 expression.
67709  DO 1010 j=1,4
67710  dhg(j)=0d0
67711  p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
67712  & px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
67713  DO 990 in1=in(3*jt+1),in(1)-4*js,4*js
67714  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
67715  990 CONTINUE
67716  DO 1000 in2=in(3*jt+2),in(2)-4*js,4*js
67717  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
67718  1000 CONTINUE
67719  1010 CONTINUE
67720  dhm(1)=four(i,i)
67721  dhm(2)=2d0*four(i,in(1))
67722  dhm(3)=2d0*four(i,in(2))
67723  dhm(4)=2d0*four(in(1),in(2))
67724 
67725 C...Find coefficients for Gamma expression.
67726  DO 1030 in2=in(1)+1,in(2),4
67727  DO 1020 in1=in(1),in2-1,4
67728  dhc=2d0*four(in1,in2)
67729  dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
67730  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
67731  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
67732  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
67733  1020 CONTINUE
67734  1030 CONTINUE
67735 
67736 C...Solve (m2, Gamma) equation system for energies taken.
67737  dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
67738  IF(abs(dhs1).LT.1d-4) goto 710
67739  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
67740  &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
67741  dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
67742  p(in(jr)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
67743  &abs(dhs1)-dhs2/dhs1)
67744  IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0d0) goto 710
67745  p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
67746  &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
67747 
67748 C...Step to new region if necessary.
67749  IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
67750  p(in(jr)+2,4)=p(in(jr)+2,3)
67751  p(in(jr)+2,jt)=1d0
67752  in(jr)=in(jr)+4*js
67753  IF(js*in(jr).GT.js*in(4*jr)) goto 710
67754  IF(four(in(1),in(2)).LE.1d-2) THEN
67755  p(in(jt)+2,4)=p(in(jt)+2,3)
67756  p(in(jt)+2,jt)=0d0
67757  in(jt)=in(jt)+4*js
67758  ENDIF
67759  goto 960
67760  ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
67761  p(in(jt)+2,4)=p(in(jt)+2,3)
67762  p(in(jt)+2,jt)=0d0
67763  in(jt)=in(jt)+4*js
67764  goto 960
67765  ENDIF
67766 
67767 C...Four-momentum of particle. Remaining quantities. Loop back.
67768  1040 DO 1050 j=1,4
67769  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
67770  p(n+nrs,j)=p(n+nrs,j)-p(i,j)
67771  1050 CONTINUE
67772  IF(p(in(1)+2,4).GT.1d0+paru(14).OR.p(in(1)+2,4).LT.-paru(14).OR.
67773  &p(in(2)+2,4).GT.1d0+paru(14).OR.p(in(2)+2,4).LT.-paru(14))
67774  &goto 200
67775  IF(p(i,4).LT.p(i,5)) goto 710
67776  kfl(jt)=-kfl(3)
67777  pmq(jt)=pmq(3)
67778  px(jt)=-px(3)
67779  py(jt)=-py(3)
67780  gam(jt)=gam(3)
67781  IF(in(3).NE.in(3*jt+3)) THEN
67782  DO 1060 j=1,4
67783  p(in(3*jt+3),j)=p(in(3),j)
67784  p(in(3*jt+3)+1,j)=p(in(3)+1,j)
67785  1060 CONTINUE
67786  ENDIF
67787  DO 1070 jq=1,2
67788  in(3*jt+jq)=in(jq)
67789  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
67790  p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
67791  1070 CONTINUE
67792  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
67793  &ibarrk(jt)=0
67794  goto 870
67795 
67796 C...Final hadron: side, flavour, hadron, mass.
67797  1080 i=i+1
67798  k(i,1)=1
67799  k(i,3)=ie(jr)
67800  k(i,4)=0
67801  k(i,5)=0
67802  CALL pykfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
67803  IF(k(i,2).EQ.0) goto 710
67804  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i-1,2)),10000).GT.1000)
67805  &ibarrk(jt)=0
67806  IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
67807  &k(i,3)=ijuori(jt)
67808  IF(ibarrk(jr).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
67809  &k(i,3)=ijuori(jr)
67810  p(i,5)=pymass(k(i,2))
67811  pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
67812 
67813 C...Final two hadrons: find common setup of four-vectors.
67814  jq=1
67815  IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.
67816  &p(in(7)+2,3)*p(in(8)+2,3)*four(in(7),in(8))) jq=2
67817  dhc12=four(in(3*jq+1),in(3*jq+2))
67818  dhr1=four(n+nrs,in(3*jq+2))/dhc12
67819  dhr2=four(n+nrs,in(3*jq+1))/dhc12
67820  IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
67821  px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
67822  py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
67823  pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
67824  & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
67825  ENDIF
67826 
67827 C...Solve kinematics for final two hadrons, if possible.
67828  wrem2=2d0*dhr1*dhr2*dhc12
67829  fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
67830  IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1d0) goto 200
67831  IF(fd.GE.1d0) goto 710
67832  fa=wrem2+pr(jt)-pr(jr)
67833  fb=sqrt(max(0d0,fa**2-4d0*wrem2*pr(jt)))
67834  prevcf=parj(42)
67835  IF(mstj(11).EQ.2) prevcf=parj(39)
67836  prev=1d0/(1d0+exp(min(50d0,prevcf*fb*parj(40))))
67837  fb=sign(fb,js*(pyr(0)-prev))
67838  kfl1a=iabs(kfl(1))
67839  kfl2a=iabs(kfl(2))
67840  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
67841  &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0d0,fa**2-
67842  &4d0*wrem2*pr(jt))),dble(js))
67843  DO 1090 j=1,4
67844  p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
67845  & p(in(3*jq+3)+1,j)+0.5d0*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
67846  & dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
67847  p(i,j)=p(n+nrs,j)-p(i-1,j)
67848  1090 CONTINUE
67849  IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) goto 710
67850  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
67851  dm2f2=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
67852  IF(dm2f1.GT.1d-10*p(i-1,4)**2.OR.dm2f2.GT.1d-10*p(i,4)**2) THEN
67853  ntryfn=ntryfn+1
67854  IF(ntryfn.LT.100) goto 140
67855  CALL pyerrm(13,'(PYSTRF:) bad energies for final two hadrons')
67856  ENDIF
67857 
67858 C...Mark jets as fragmented and give daughter pointers.
67859  n=i-nrs+1
67860  DO 1100 i=nsav+1,nsav+np
67861  im=k(i,3)
67862  k(im,1)=k(im,1)+10
67863  IF(mstu(16).NE.2) THEN
67864  k(im,4)=nsav+1
67865  k(im,5)=nsav+1
67866  ELSE
67867  k(im,4)=nsav+2
67868  k(im,5)=n
67869  ENDIF
67870  1100 CONTINUE
67871 
67872 C...Document string system. Move up particles.
67873  nsav=nsav+1
67874  k(nsav,1)=11
67875  k(nsav,2)=92
67876  k(nsav,3)=ip
67877  k(nsav,4)=nsav+1
67878  k(nsav,5)=n
67879  DO 1110 j=1,4
67880  p(nsav,j)=dps(j)
67881  v(nsav,j)=v(ip,j)
67882  1110 CONTINUE
67883  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
67884  v(nsav,5)=0d0
67885  DO 1130 i=nsav+1,n
67886  DO 1120 j=1,5
67887  k(i,j)=k(i+nrs-1,j)
67888  p(i,j)=p(i+nrs-1,j)
67889  v(i,j)=0d0
67890  1120 CONTINUE
67891  1130 CONTINUE
67892  mstu91=mstu(90)
67893  DO 1140 iz=mstu90+1,mstu91
67894  mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
67895  paru9t(iz)=paru(90+iz)
67896  1140 CONTINUE
67897  mstu(90)=mstu90
67898 
67899 C...Order particles in rank along the chain. Update mother pointer.
67900  DO 1160 i=nsav+1,n
67901  DO 1150 j=1,5
67902  k(i-nsav+n,j)=k(i,j)
67903  p(i-nsav+n,j)=p(i,j)
67904  1150 CONTINUE
67905  1160 CONTINUE
67906  i1=nsav
67907  DO 1190 i=n+1,2*n-nsav
67908  IF(k(i,3).NE.ie(1).AND.k(i,3).NE.ijuori(1)) goto 1190
67909  i1=i1+1
67910  DO 1170 j=1,5
67911  k(i1,j)=k(i,j)
67912  p(i1,j)=p(i,j)
67913  1170 CONTINUE
67914  IF(mstu(16).NE.2) k(i1,3)=nsav
67915  DO 1180 iz=mstu90+1,mstu91
67916  IF(mstu9t(iz).EQ.i) THEN
67917  mstu(90)=mstu(90)+1
67918  mstu(90+mstu(90))=i1
67919  paru(90+mstu(90))=paru9t(iz)
67920  ENDIF
67921  1180 CONTINUE
67922  1190 CONTINUE
67923  DO 1220 i=2*n-nsav,n+1,-1
67924  IF(k(i,3).EQ.ie(1).OR.k(i,3).EQ.ijuori(1)) goto 1220
67925  i1=i1+1
67926  DO 1200 j=1,5
67927  k(i1,j)=k(i,j)
67928  p(i1,j)=p(i,j)
67929  1200 CONTINUE
67930  IF(mstu(16).NE.2) k(i1,3)=nsav
67931  DO 1210 iz=mstu90+1,mstu91
67932  IF(mstu9t(iz).EQ.i) THEN
67933  mstu(90)=mstu(90)+1
67934  mstu(90+mstu(90))=i1
67935  paru(90+mstu(90))=paru9t(iz)
67936  ENDIF
67937  1210 CONTINUE
67938  1220 CONTINUE
67939 
67940 C...Boost back particle system. Set production vertices.
67941  IF(mbst.EQ.0) THEN
67942  mstu(33)=1
67943  CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),
67944  & dps(3)/dps(4))
67945  ELSE
67946  DO 1230 i=nsav+1,n
67947  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
67948  IF(p(i,3).GT.0d0) THEN
67949  hhpez=(p(i,4)+p(i,3))*hhbz
67950  p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
67951  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
67952  ELSE
67953  hhpez=(p(i,4)-p(i,3))/hhbz
67954  p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
67955  p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
67956  ENDIF
67957  1230 CONTINUE
67958  ENDIF
67959  DO 1250 i=nsav+1,n
67960  DO 1240 j=1,4
67961  v(i,j)=v(ip,j)
67962  1240 CONTINUE
67963  1250 CONTINUE
67964 
67965  RETURN
67966  END
67967 
67968 C*********************************************************************
67969 
67970 C...PYJURF
67971 C...From three given input vectors in PJU the boost VJU from
67972 C...the "lab frame" to the junction rest frame is constructed.
67973 
67974  SUBROUTINE pyjurf(PJU,VJU)
67975 
67976 C...Double precision and integer declarations.
67977  IMPLICIT DOUBLE PRECISION(a-h, o-z)
67978  IMPLICIT INTEGER(i-n)
67979 
67980 C...Input, output and local arrays.
67981  dimension pju(3,5),vju(5),psum(5),a(3,3),penew(3),pcm(5,5)
67982  DATA twopi/6.283186d0/
67983 
67984 C...Calculate masses and other invariants.
67985  DO 100 j=1,4
67986  psum(j)=pju(1,j)+pju(2,j)+pju(3,j)
67987  100 CONTINUE
67988  psum2=psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2
67989  psum(5)=sqrt(psum2)
67990  DO 120 i=1,3
67991  DO 110 j=1,3
67992  a(i,j)=pju(i,4)*pju(j,4)-pju(i,1)*pju(j,1)-
67993  & pju(i,2)*pju(j,2)-pju(i,3)*pju(j,3)
67994  110 CONTINUE
67995  120 CONTINUE
67996 
67997 C...Pick I to be most massive parton and J to be the one closest to I.
67998  itry=0
67999  i=1
68000  IF(a(2,2).GT.a(1,1)) i=2
68001  IF(a(3,3).GT.max(a(1,1),a(2,2))) i=3
68002  130 itry=itry+1
68003  j=1+mod(i,3)
68004  k=1+mod(j,3)
68005  IF(a(i,k)**2*a(j,j).LT.a(i,j)**2*a(k,k)) THEN
68006  k=1+mod(i,3)
68007  j=1+mod(k,3)
68008  ENDIF
68009  pmi2=a(i,i)
68010  pmj2=a(j,j)
68011  pmk2=a(k,k)
68012  aij=a(i,j)
68013  aik=a(i,k)
68014  ajk=a(j,k)
68015 
68016 C...Trivial find new parton energies if all three partons are massless.
68017  IF(pmi2.LT.1d-4) THEN
68018  pei=sqrt(2d0*aik*aij/(3d0*ajk))
68019  pej=sqrt(2d0*ajk*aij/(3d0*aik))
68020  pek=sqrt(2d0*aik*ajk/(3d0*aij))
68021 
68022 C...Else find momentum range for parton I and values at extremes.
68023  ELSE
68024  paimin=0d0
68025  peimin=sqrt(pmi2)
68026  pejmin=aij/peimin
68027  pekmin=aik/peimin
68028  pajmin=sqrt(max(0d0,pejmin**2-pmj2))
68029  pakmin=sqrt(max(0d0,pekmin**2-pmk2))
68030  fmin=pejmin*pekmin+0.5d0*pajmin*pakmin-ajk
68031  peimax=(aij+aik)/sqrt(pmj2+pmk2+2d0*ajk)
68032  IF(pmj2.GT.1d-4) peimax=aij/sqrt(pmj2)
68033  paimax=sqrt(max(0d0,peimax**2-pmi2))
68034  hi=peimax**2-0.25d0*paimax**2
68035  pajmax=(peimax*sqrt(max(0d0,aij**2-pmj2*hi))-
68036  & 0.5d0*paimax*aij)/hi
68037  pakmax=(peimax*sqrt(max(0d0,aik**2-pmk2*hi))-
68038  & 0.5d0*paimax*aik)/hi
68039  pejmax=sqrt(pajmax**2+pmj2)
68040  pekmax=sqrt(pakmax**2+pmk2)
68041  fmax=pejmax*pekmax+0.5d0*pajmax*pakmax-ajk
68042 
68043 C...If unexpected values at upper endpoint then pick another parton.
68044  IF(fmax.GT.0d0.AND.itry.LE.2) THEN
68045  i1=1+mod(i,3)
68046  IF(a(i1,i1).GE.1d-4) THEN
68047  i=i1
68048  goto 130
68049  ENDIF
68050  itry=itry+1
68051  i1=1+mod(i,3)
68052  IF(itry.LE.2.AND.a(i1,i1).GE.1d-4) THEN
68053  i=i1
68054  goto 130
68055  ENDIF
68056  ENDIF
68057 
68058 C..Start binary + linear search to find solution inside range.
68059  iter=0
68060  itmin=0
68061  itmax=0
68062  pai=0.5d0*(paimin+paimax)
68063  140 iter=iter+1
68064 
68065 C...Derive momentum of other two partons and distance to root.
68066  pei=sqrt(pai**2+pmi2)
68067  hi=pei**2-0.25d0*pai**2
68068  paj=(pei*sqrt(max(0d0,aij**2-pmj2*hi))-0.5d0*pai*aij)/hi
68069  pej=sqrt(paj**2+pmj2)
68070  pak=(pei*sqrt(max(0d0,aik**2-pmk2*hi))-0.5d0*pai*aik)/hi
68071  pek=sqrt(pak**2+pmk2)
68072  fnow=pej*pek+0.5d0*paj*pak-ajk
68073 
68074 C...Pick next I momentum to explore, hopefully closer to root.
68075  IF(fnow.GT.0d0) THEN
68076  paimin=pai
68077  fmin=fnow
68078  itmin=itmin+1
68079  ELSE
68080  paimax=pai
68081  fmax=fnow
68082  itmax=itmax+1
68083  ENDIF
68084  IF((iter.LT.10.OR.itmin.LE.1.OR.itmax.LE.1).AND.iter.LT.20)
68085  & THEN
68086  pai=0.5d0*(paimin+paimax)
68087  goto 140
68088  ELSEIF(iter.LT.40.AND.fmin.GT.0d0.AND.fmax.LT.0d0.AND.
68089  & abs(fnow).GT.1d-12*psum2) THEN
68090  pai=paimin+(paimax-paimin)*fmin/(fmin-fmax)
68091  goto 140
68092  ENDIF
68093  ENDIF
68094 
68095 C...Now know energies in junction rest frame.
68096  penew(i)=pei
68097  penew(j)=pej
68098  penew(k)=pek
68099 
68100 C...Boost (copy of) partons to their rest frame.
68101  vxcm=-psum(1)/psum(5)
68102  vycm=-psum(2)/psum(5)
68103  vzcm=-psum(3)/psum(5)
68104  gamcm=sqrt(1d0+vxcm**2+vycm**2+vzcm**2)
68105  DO 150 i=1,3
68106  fac1=pju(i,1)*vxcm+pju(i,2)*vycm+pju(i,3)*vzcm
68107  fac2=fac1/(1d0+gamcm)+pju(i,4)
68108  pcm(i,1)=pju(i,1)+fac2*vxcm
68109  pcm(i,2)=pju(i,2)+fac2*vycm
68110  pcm(i,3)=pju(i,3)+fac2*vzcm
68111  pcm(i,4)=pju(i,4)*gamcm+fac1
68112  pcm(i,5)=sqrt(pcm(i,1)**2+pcm(i,2)**2+pcm(i,3)**2)
68113  150 CONTINUE
68114 
68115 C...Construct difference vectors and boost to junction rest frame.
68116  DO 160 j=1,3
68117  pcm(4,j)=pcm(1,j)/pcm(1,4)-pcm(2,j)/pcm(2,4)
68118  pcm(5,j)=pcm(1,j)/pcm(1,4)-pcm(3,j)/pcm(3,4)
68119  160 CONTINUE
68120  pcm(4,4)=penew(1)/pcm(1,4)-penew(2)/pcm(2,4)
68121  pcm(5,4)=penew(1)/pcm(1,4)-penew(3)/pcm(3,4)
68122  pcm4s=pcm(4,1)**2+pcm(4,2)**2+pcm(4,3)**2
68123  pcm5s=pcm(5,1)**2+pcm(5,2)**2+pcm(5,3)**2
68124  pcm45=pcm(4,1)*pcm(5,1)+pcm(4,2)*pcm(5,2)+pcm(4,3)*pcm(5,3)
68125  c4=(pcm5s*pcm(4,4)-pcm45*pcm(5,4))/(pcm4s*pcm5s-pcm45**2)
68126  c5=(pcm4s*pcm(5,4)-pcm45*pcm(4,4))/(pcm4s*pcm5s-pcm45**2)
68127  vxju=c4*pcm(4,1)+c5*pcm(5,1)
68128  vyju=c4*pcm(4,2)+c5*pcm(5,2)
68129  vzju=c4*pcm(4,3)+c5*pcm(5,3)
68130  gamju=sqrt(1d0+vxju**2+vyju**2+vzju**2)
68131 
68132 C...Add two boosts, giving final result.
68133  fcm=(vxju*vxcm+vyju*vycm+vzju*vzcm)/(1+gamcm)+gamju
68134  vju(1)=vxju+fcm*vxcm
68135  vju(2)=vyju+fcm*vycm
68136  vju(3)=vzju+fcm*vzcm
68137  vju(4)=sqrt(1d0+vju(1)**2+vju(2)**2+vju(3)**2)
68138  vju(5)=1d0
68139 
68140 C...In case of error in reconstruction: revert to CM frame of system.
68141  cth12=(pcm(1,1)*pcm(2,1)+pcm(1,2)*pcm(2,2)+pcm(1,3)*pcm(2,3))/
68142  &(pcm(1,5)*pcm(2,5))
68143  cth13=(pcm(1,1)*pcm(3,1)+pcm(1,2)*pcm(3,2)+pcm(1,3)*pcm(3,3))/
68144  &(pcm(1,5)*pcm(3,5))
68145  cth23=(pcm(2,1)*pcm(3,1)+pcm(2,2)*pcm(3,2)+pcm(2,3)*pcm(3,3))/
68146  &(pcm(2,5)*pcm(3,5))
68147  errccm=(cth12+0.5d0)**2+(cth13+0.5d0)**2+(cth23+0.5d0)**2
68148  errtcm=twopi-acos(cth12)-acos(cth13)-acos(cth23)
68149  DO 170 i=1,3
68150  fac1=pju(i,1)*vju(1)+pju(i,2)*vju(2)+pju(i,3)*vju(3)
68151  fac2=fac1/(1d0+vju(4))+pju(i,4)
68152  pcm(i,1)=pju(i,1)+fac2*vju(1)
68153  pcm(i,2)=pju(i,2)+fac2*vju(2)
68154  pcm(i,3)=pju(i,3)+fac2*vju(3)
68155  pcm(i,4)=pju(i,4)*vju(4)+fac1
68156  pcm(i,5)=sqrt(pcm(i,1)**2+pcm(i,2)**2+pcm(i,3)**2)
68157  170 CONTINUE
68158  cth12=(pcm(1,1)*pcm(2,1)+pcm(1,2)*pcm(2,2)+pcm(1,3)*pcm(2,3))/
68159  &(pcm(1,5)*pcm(2,5))
68160  cth13=(pcm(1,1)*pcm(3,1)+pcm(1,2)*pcm(3,2)+pcm(1,3)*pcm(3,3))/
68161  &(pcm(1,5)*pcm(3,5))
68162  cth23=(pcm(2,1)*pcm(3,1)+pcm(2,2)*pcm(3,2)+pcm(2,3)*pcm(3,3))/
68163  &(pcm(2,5)*pcm(3,5))
68164  errcju=(cth12+0.5d0)**2+(cth13+0.5d0)**2+(cth23+0.5d0)**2
68165  errtju=twopi-acos(cth12)-acos(cth13)-acos(cth23)
68166  IF(errcju+errtju.GT.errccm+errtcm) THEN
68167  vju(1)=vxcm
68168  vju(2)=vycm
68169  vju(3)=vzcm
68170  vju(4)=gamcm
68171  ENDIF
68172 
68173  RETURN
68174  END
68175 
68176 C*********************************************************************
68177 
68178 C...PYINDF
68179 C...Handles the fragmentation of a jet system (or a single
68180 C...jet) according to independent fragmentation models.
68181 
68182  SUBROUTINE pyindf(IP)
68183 
68184 C...Double precision and integer declarations.
68185  IMPLICIT DOUBLE PRECISION(a-h, o-z)
68186  IMPLICIT INTEGER(i-n)
68187  INTEGER pyk,pychge,pycomp
68188 C...Commonblocks.
68189  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
68190  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
68191  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
68192  SAVE /pyjets/,/pydat1/,/pydat2/
68193 C...Local arrays.
68194  dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
68195  &kflo(2),pxo(2),pyo(2),wo(2)
68196 
68197 C.. MOPS error message
68198  IF(mstj(12).GT.3) CALL pyerrm(9,'(PYINDF:) MSTJ(12)>3 options'//
68199  &' are not treated as expected in independent fragmentation')
68200 
68201 C...Reset counters. Identify parton system and take copy. Check flavour.
68202  nsav=n
68203  mstu90=mstu(90)
68204  njet=0
68205  kqsum=0
68206  DO 100 j=1,5
68207  dps(j)=0d0
68208  100 CONTINUE
68209  i=ip-1
68210  110 i=i+1
68211  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
68212  CALL pyerrm(12,'(PYINDF:) failed to reconstruct jet system')
68213  IF(mstu(21).GE.1) RETURN
68214  ENDIF
68215  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 110
68216  kc=pycomp(k(i,2))
68217  IF(kc.EQ.0) goto 110
68218  kq=kchg(kc,2)*isign(1,k(i,2))
68219  IF(kq.EQ.0) goto 110
68220  njet=njet+1
68221  IF(kq.NE.2) kqsum=kqsum+kq
68222  DO 120 j=1,5
68223  k(nsav+njet,j)=k(i,j)
68224  p(nsav+njet,j)=p(i,j)
68225  dps(j)=dps(j)+p(i,j)
68226  120 CONTINUE
68227  k(nsav+njet,3)=i
68228  IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
68229  &k(i+1,1).EQ.2)) goto 110
68230  IF(njet.NE.1.AND.kqsum.NE.0) THEN
68231  CALL pyerrm(12,'(PYINDF:) unphysical flavour combination')
68232  IF(mstu(21).GE.1) RETURN
68233  ENDIF
68234 
68235 C...Boost copied system to CM frame. Find CM energy and sum flavours.
68236  IF(njet.NE.1) THEN
68237  mstu(33)=1
68238  CALL pyrobo(nsav+1,nsav+njet,0d0,0d0,-dps(1)/dps(4),
68239  & -dps(2)/dps(4),-dps(3)/dps(4))
68240  ENDIF
68241  pecm=0d0
68242  DO 130 j=1,3
68243  nfi(j)=0
68244  130 CONTINUE
68245  DO 140 i=nsav+1,nsav+njet
68246  pecm=pecm+p(i,4)
68247  kfa=iabs(k(i,2))
68248  IF(kfa.LE.3) THEN
68249  nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
68250  ELSEIF(kfa.GT.1000) THEN
68251  kfla=mod(kfa/1000,10)
68252  kflb=mod(kfa/100,10)
68253  IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
68254  IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
68255  ENDIF
68256  140 CONTINUE
68257 
68258 C...Loop over attempts made. Reset counters.
68259  ntry=0
68260  150 ntry=ntry+1
68261  IF(ntry.GT.200) THEN
68262  CALL pyerrm(14,'(PYINDF:) caught in infinite loop')
68263  IF(mstu(21).GE.1) RETURN
68264  ENDIF
68265  n=nsav+njet
68266  mstu(90)=mstu90
68267  DO 160 j=1,3
68268  nfl(j)=nfi(j)
68269  ifet(j)=0
68270  kflf(j)=0
68271  160 CONTINUE
68272 
68273 C...Loop over jets to be fragmented.
68274  DO 230 ip1=nsav+1,nsav+njet
68275  mstj(91)=0
68276  nsav1=n
68277  mstu91=mstu(90)
68278 
68279 C...Initial flavour and momentum values. Jet along +z axis.
68280  kflh=iabs(k(ip1,2))
68281  IF(kflh.GT.10) kflh=mod(kflh/1000,10)
68282  kflo(2)=0
68283  wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
68284 
68285 C...Initial values for quark or diquark jet.
68286  170 IF(iabs(k(ip1,2)).NE.21) THEN
68287  nstr=1
68288  kflo(1)=k(ip1,2)
68289  CALL pyptdi(0,pxo(1),pyo(1))
68290  wo(1)=wf
68291 
68292 C...Initial values for gluon treated like random quark jet.
68293  ELSEIF(mstj(2).LE.2) THEN
68294  nstr=1
68295  IF(mstj(2).EQ.2) mstj(91)=1
68296  kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
68297  CALL pyptdi(0,pxo(1),pyo(1))
68298  wo(1)=wf
68299 
68300 C...Initial values for gluon treated like quark-antiquark jet pair,
68301 C...sharing energy according to Altarelli-Parisi splitting function.
68302  ELSE
68303  nstr=2
68304  IF(mstj(2).EQ.4) mstj(91)=1
68305  kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
68306  kflo(2)=-kflo(1)
68307  CALL pyptdi(0,pxo(1),pyo(1))
68308  pxo(2)=-pxo(1)
68309  pyo(2)=-pyo(1)
68310  wo(1)=wf*pyr(0)**(1d0/3d0)
68311  wo(2)=wf-wo(1)
68312  ENDIF
68313 
68314 C...Initial values for rank, flavour, pT and W+.
68315  DO 220 istr=1,nstr
68316  180 i=n
68317  mstu(90)=mstu91
68318  irank=0
68319  kfl1=kflo(istr)
68320  px1=pxo(istr)
68321  py1=pyo(istr)
68322  w=wo(istr)
68323 
68324 C...New hadron. Generate flavour and hadron species.
68325  190 i=i+1
68326  IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
68327  CALL pyerrm(11,'(PYINDF:) no more memory left in PYJETS')
68328  IF(mstu(21).GE.1) RETURN
68329  ENDIF
68330  irank=irank+1
68331  k(i,1)=1
68332  k(i,3)=ip1
68333  k(i,4)=0
68334  k(i,5)=0
68335  200 CALL pykfdi(kfl1,0,kfl2,k(i,2))
68336  IF(k(i,2).EQ.0) goto 180
68337  IF(irank.EQ.1.AND.iabs(kfl1).LE.10.AND.iabs(kfl2).GT.10) THEN
68338  IF(pyr(0).GT.parj(19)) goto 200
68339  ENDIF
68340 
68341 C...Find hadron mass. Generate four-momentum.
68342  p(i,5)=pymass(k(i,2))
68343  CALL pyptdi(kfl1,px2,py2)
68344  p(i,1)=px1+px2
68345  p(i,2)=py1+py2
68346  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
68347  CALL pyzdis(kfl1,kfl2,pr,z)
68348  mzsav=0
68349  IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
68350  mzsav=1
68351  mstu(90)=mstu(90)+1
68352  mstu(90+mstu(90))=i
68353  paru(90+mstu(90))=z
68354  ENDIF
68355  p(i,3)=0.5d0*(z*w-pr/max(1d-4,z*w))
68356  p(i,4)=0.5d0*(z*w+pr/max(1d-4,z*w))
68357  IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
68358  & p(i,3).LE.0.001d0) THEN
68359  IF(w.GE.p(i,5)+0.5d0*parj(32)) goto 180
68360  p(i,3)=0.0001d0
68361  p(i,4)=sqrt(pr)
68362  z=p(i,4)/w
68363  ENDIF
68364 
68365 C...Remaining flavour and momentum.
68366  kfl1=-kfl2
68367  px1=-px2
68368  py1=-py2
68369  w=(1d0-z)*w
68370  DO 210 j=1,5
68371  v(i,j)=0d0
68372  210 CONTINUE
68373 
68374 C...Check if pL acceptable. Go back for new hadron if enough energy.
68375  IF(mstj(3).GE.0.AND.p(i,3).LT.0d0) THEN
68376  i=i-1
68377  IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
68378  ENDIF
68379  IF(w.GT.parj(31)) goto 190
68380  n=i
68381  220 CONTINUE
68382  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1d0*parj(32)
68383  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) goto 170
68384 
68385 C...Rotate jet to new direction.
68386  the=pyangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
68387  phi=pyangl(p(ip1,1),p(ip1,2))
68388  mstu(33)=1
68389  CALL pyrobo(nsav1+1,n,the,phi,0d0,0d0,0d0)
68390  k(k(ip1,3),4)=nsav1+1
68391  k(k(ip1,3),5)=n
68392 
68393 C...End of jet generation loop. Skip conservation in some cases.
68394  230 CONTINUE
68395  IF(njet.EQ.1.OR.mstj(3).LE.0) goto 490
68396  IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) goto 150
68397 
68398 C...Subtract off produced hadron flavours, finished if zero.
68399  DO 240 i=nsav+njet+1,n
68400  kfa=iabs(k(i,2))
68401  kfla=mod(kfa/1000,10)
68402  kflb=mod(kfa/100,10)
68403  kflc=mod(kfa/10,10)
68404  IF(kfla.EQ.0) THEN
68405  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
68406  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
68407  ELSE
68408  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
68409  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
68410  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
68411  ENDIF
68412  240 CONTINUE
68413  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
68414  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
68415  IF(nreq.EQ.0) goto 320
68416 
68417 C...Take away flavour of low-momentum particles until enough freedom.
68418  nrem=0
68419  250 irem=0
68420  p2min=pecm**2
68421  DO 260 i=nsav+njet+1,n
68422  p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
68423  IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
68424  IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
68425  260 CONTINUE
68426  IF(irem.EQ.0) goto 150
68427  k(irem,1)=7
68428  kfa=iabs(k(irem,2))
68429  kfla=mod(kfa/1000,10)
68430  kflb=mod(kfa/100,10)
68431  kflc=mod(kfa/10,10)
68432  IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
68433  IF(k(irem,1).EQ.8) goto 250
68434  IF(kfla.EQ.0) THEN
68435  isgn=isign(1,k(irem,2))*(-1)**kflb
68436  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
68437  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
68438  ELSE
68439  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
68440  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
68441  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
68442  ENDIF
68443  nrem=nrem+1
68444  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
68445  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
68446  IF(nreq.GT.nrem) goto 250
68447  DO 270 i=nsav+njet+1,n
68448  IF(k(i,1).EQ.8) k(i,1)=1
68449  270 CONTINUE
68450 
68451 C...Find combination of existing and new flavours for hadron.
68452  280 nfet=2
68453  IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
68454  IF(nreq.LT.nrem) nfet=1
68455  IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
68456  DO 290 j=1,nfet
68457  ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*pyr(0)
68458  kflf(j)=isign(1,nfl(1))
68459  IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
68460  IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
68461  290 CONTINUE
68462  IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
68463  &goto 280
68464  IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
68465  &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)
68466  &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) goto 280
68467  IF(nfet.EQ.0) kflf(1)=1+int((2d0+parj(2))*pyr(0))
68468  IF(nfet.EQ.0) kflf(2)=-kflf(1)
68469  IF(nfet.EQ.1) kflf(2)=isign(1+int((2d0+parj(2))*pyr(0)),-kflf(1))
68470  IF(nfet.LE.2) kflf(3)=0
68471  IF(kflf(3).NE.0) THEN
68472  kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
68473  & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
68474  IF(kflf(1).EQ.kflf(3).OR.(1d0+3d0*parj(4))*pyr(0).GT.1d0)
68475  & kflfc=kflfc+isign(2,kflfc)
68476  ELSE
68477  kflfc=kflf(1)
68478  ENDIF
68479  CALL pykfdi(kflfc,kflf(2),kfldmp,kf)
68480  IF(kf.EQ.0) goto 280
68481  DO 300 j=1,max(2,nfet)
68482  nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
68483  300 CONTINUE
68484 
68485 C...Store hadron at random among free positions.
68486  npos=min(1+int(pyr(0)*nrem),nrem)
68487  DO 310 i=nsav+njet+1,n
68488  IF(k(i,1).EQ.7) npos=npos-1
68489  IF(k(i,1).EQ.1.OR.npos.NE.0) goto 310
68490  k(i,1)=1
68491  k(i,2)=kf
68492  p(i,5)=pymass(k(i,2))
68493  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
68494  310 CONTINUE
68495  nrem=nrem-1
68496  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
68497  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
68498  IF(nrem.GT.0) goto 280
68499 
68500 C...Compensate for missing momentum in global scheme (3 options).
68501  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
68502  DO 340 j=1,3
68503  psi(j)=0d0
68504  DO 330 i=nsav+njet+1,n
68505  psi(j)=psi(j)+p(i,j)
68506  330 CONTINUE
68507  340 CONTINUE
68508  psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
68509  pws=0d0
68510  DO 350 i=nsav+njet+1,n
68511  IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
68512  IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
68513  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
68514  IF(mod(mstj(3),5).EQ.3) pws=pws+1d0
68515  350 CONTINUE
68516  DO 370 i=nsav+njet+1,n
68517  IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
68518  IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
68519  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
68520  IF(mod(mstj(3),5).EQ.3) pw=1d0
68521  DO 360 j=1,3
68522  p(i,j)=p(i,j)-psi(j)*pw/pws
68523  360 CONTINUE
68524  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
68525  370 CONTINUE
68526 
68527 C...Compensate for missing momentum withing each jet separately.
68528  ELSEIF(mod(mstj(3),5).EQ.4) THEN
68529  DO 390 i=n+1,n+njet
68530  k(i,1)=0
68531  DO 380 j=1,5
68532  p(i,j)=0d0
68533  380 CONTINUE
68534  390 CONTINUE
68535  DO 410 i=nsav+njet+1,n
68536  ir1=k(i,3)
68537  ir2=n+ir1-nsav
68538  k(ir2,1)=k(ir2,1)+1
68539  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
68540  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
68541  DO 400 j=1,3
68542  p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
68543  400 CONTINUE
68544  p(ir2,4)=p(ir2,4)+p(i,4)
68545  p(ir2,5)=p(ir2,5)+pls
68546  410 CONTINUE
68547  pss=0d0
68548  DO 420 i=n+1,n+njet
68549  IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8d0*p(i,5)+0.2d0))
68550  420 CONTINUE
68551  DO 440 i=nsav+njet+1,n
68552  ir1=k(i,3)
68553  ir2=n+ir1-nsav
68554  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
68555  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
68556  DO 430 j=1,3
68557  p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1d0/(p(ir2,5)*pss)-1d0)*
68558  & pls*p(ir1,j)
68559  430 CONTINUE
68560  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
68561  440 CONTINUE
68562  ENDIF
68563 
68564 C...Scale momenta for energy conservation.
68565  IF(mod(mstj(3),5).NE.0) THEN
68566  pms=0d0
68567  pes=0d0
68568  pqs=0d0
68569  DO 450 i=nsav+njet+1,n
68570  pms=pms+p(i,5)
68571  pes=pes+p(i,4)
68572  pqs=pqs+p(i,5)**2/p(i,4)
68573  450 CONTINUE
68574  IF(pms.GE.pecm) goto 150
68575  neco=0
68576  460 neco=neco+1
68577  pfac=(pecm-pqs)/(pes-pqs)
68578  pes=0d0
68579  pqs=0d0
68580  DO 480 i=nsav+njet+1,n
68581  DO 470 j=1,3
68582  p(i,j)=pfac*p(i,j)
68583  470 CONTINUE
68584  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
68585  pes=pes+p(i,4)
68586  pqs=pqs+p(i,5)**2/p(i,4)
68587  480 CONTINUE
68588  IF(neco.LT.10.AND.abs(pecm-pes).GT.2d-6*pecm) goto 460
68589  ENDIF
68590 
68591 C...Origin of produced particles and parton daughter pointers.
68592  490 DO 500 i=nsav+njet+1,n
68593  IF(mstu(16).NE.2) k(i,3)=nsav+1
68594  IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
68595  500 CONTINUE
68596  DO 510 i=nsav+1,nsav+njet
68597  i1=k(i,3)
68598  k(i1,1)=k(i1,1)+10
68599  IF(mstu(16).NE.2) THEN
68600  k(i1,4)=nsav+1
68601  k(i1,5)=nsav+1
68602  ELSE
68603  k(i1,4)=k(i1,4)-njet+1
68604  k(i1,5)=k(i1,5)-njet+1
68605  IF(k(i1,5).LT.k(i1,4)) THEN
68606  k(i1,4)=0
68607  k(i1,5)=0
68608  ENDIF
68609  ENDIF
68610  510 CONTINUE
68611 
68612 C...Document independent fragmentation system. Remove copy of jets.
68613  nsav=nsav+1
68614  k(nsav,1)=11
68615  k(nsav,2)=93
68616  k(nsav,3)=ip
68617  k(nsav,4)=nsav+1
68618  k(nsav,5)=n-njet+1
68619  DO 520 j=1,4
68620  p(nsav,j)=dps(j)
68621  v(nsav,j)=v(ip,j)
68622  520 CONTINUE
68623  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
68624  v(nsav,5)=0d0
68625  DO 540 i=nsav+njet,n
68626  DO 530 j=1,5
68627  k(i-njet+1,j)=k(i,j)
68628  p(i-njet+1,j)=p(i,j)
68629  v(i-njet+1,j)=v(i,j)
68630  530 CONTINUE
68631  540 CONTINUE
68632  n=n-njet+1
68633  DO 550 iz=mstu90+1,mstu(90)
68634  mstu(90+iz)=mstu(90+iz)-njet+1
68635  550 CONTINUE
68636 
68637 C...Boost back particle system. Set production vertices.
68638  IF(njet.NE.1) CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),
68639  &dps(2)/dps(4),dps(3)/dps(4))
68640  DO 570 i=nsav+1,n
68641  DO 560 j=1,4
68642  v(i,j)=v(ip,j)
68643  560 CONTINUE
68644  570 CONTINUE
68645 
68646  RETURN
68647  END
68648 
68649 C*********************************************************************
68650 
68651 C...PYDECY
68652 C...Handles the decay of unstable particles.
68653 
68654  SUBROUTINE pydecy(IP)
68655 
68656 C...Double precision and integer declarations.
68657  IMPLICIT DOUBLE PRECISION(a-h, o-z)
68658  IMPLICIT INTEGER(i-n)
68659  INTEGER pyk,pychge,pycomp
68660 C...Commonblocks.
68661  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
68662  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
68663  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
68664  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
68665  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
68666 C...Local arrays.
68667  dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
68668  &wtcor(10),ptau(4),pcmtau(4),dbetau(3)
68669  CHARACTER cidc*4
68670  DATA wtcor/2d0,5d0,15d0,60d0,250d0,1500d0,1.2d4,1.2d5,150d0,16d0/
68671 
68672 C...Functions: momentum in two-particle decays and four-product.
68673  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2d0*a)
68674  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)
68675 
68676 C...Initial values.
68677  ntry=0
68678  nsav=n
68679  kfa=iabs(k(ip,2))
68680  kfs=isign(1,k(ip,2))
68681  kc=pycomp(kfa)
68682  mstj(92)=0
68683 
68684 C...Choose lifetime and determine decay vertex.
68685  IF(k(ip,1).EQ.5) THEN
68686  v(ip,5)=0d0
68687  ELSEIF(k(ip,1).NE.4) THEN
68688  v(ip,5)=-pmas(kc,4)*log(pyr(0))
68689  ENDIF
68690  DO 100 j=1,4
68691  vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
68692  100 CONTINUE
68693 
68694 C...Determine whether decay allowed or not.
68695  mout=0
68696  IF(mstj(22).EQ.2) THEN
68697  IF(pmas(kc,4).GT.parj(71)) mout=1
68698  ELSEIF(mstj(22).EQ.3) THEN
68699  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
68700  ELSEIF(mstj(22).EQ.4) THEN
68701  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
68702  IF(abs(vdcy(3)).GT.parj(74)) mout=1
68703  ENDIF
68704  IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
68705  k(ip,1)=4
68706  RETURN
68707  ENDIF
68708 
68709 C...Interface to external tau decay library (for tau polarization).
68710  IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
68711 
68712 C...Starting values for pointers and momenta.
68713  itau=ip
68714  DO 110 j=1,4
68715  ptau(j)=p(itau,j)
68716  pcmtau(j)=p(itau,j)
68717  110 CONTINUE
68718 
68719 C...Iterate to find position and code of mother of tau.
68720  imtau=itau
68721  120 imtau=k(imtau,3)
68722 
68723  IF(imtau.EQ.0) THEN
68724 C...If no known origin then impossible to do anything further.
68725  kforig=0
68726  iorig=0
68727 
68728  ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN
68729 C...If tau -> tau + gamma then add gamma energy and loop.
68730  IF(k(k(imtau,4),2).EQ.22) THEN
68731  DO 130 j=1,4
68732  pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)
68733  130 CONTINUE
68734  ELSEIF(k(k(imtau,5),2).EQ.22) THEN
68735  DO 140 j=1,4
68736  pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)
68737  140 CONTINUE
68738  ENDIF
68739  goto 120
68740 
68741  ELSEIF(iabs(k(imtau,2)).GT.100) THEN
68742 C...If coming from weak decay of hadron then W is not stored in record,
68743 C...but can be reconstructed by adding neutrino momentum.
68744  kforig=-isign(24,k(itau,2))
68745  iorig=0
68746  DO 160 ii=k(imtau,4),k(imtau,5)
68747  IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN
68748  DO 150 j=1,4
68749  pcmtau(j)=pcmtau(j)+p(ii,j)
68750  150 CONTINUE
68751  ENDIF
68752  160 CONTINUE
68753 
68754  ELSE
68755 C...If coming from resonance decay then find latest copy of this
68756 C...resonance (may not completely agree).
68757  kforig=k(imtau,2)
68758  iorig=imtau
68759  DO 170 ii=imtau+1,ip-1
68760  IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.
68761  & abs(p(ii,5)-p(iorig,5)).LT.1d-5*p(iorig,5)) iorig=ii
68762  170 CONTINUE
68763  DO 180 j=1,4
68764  pcmtau(j)=p(iorig,j)
68765  180 CONTINUE
68766  ENDIF
68767 
68768 C...Boost tau to rest frame of production process (where known)
68769 C...and rotate it to sit along +z axis.
68770  DO 190 j=1,3
68771  dbetau(j)=pcmtau(j)/pcmtau(4)
68772  190 CONTINUE
68773  IF(kforig.NE.0) CALL pyrobo(itau,itau,0d0,0d0,-dbetau(1),
68774  & -dbetau(2),-dbetau(3))
68775  phitau=pyangl(p(itau,1),p(itau,2))
68776  CALL pyrobo(itau,itau,0d0,-phitau,0d0,0d0,0d0)
68777  thetau=pyangl(p(itau,3),p(itau,1))
68778  CALL pyrobo(itau,itau,-thetau,0d0,0d0,0d0,0d0)
68779 
68780 C...Call tau decay routine (if meaningful) and fill extra info.
68781  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
68782  CALL pytaud(itau,iorig,kforig,ndecay)
68783  DO 200 ii=nsav+1,nsav+ndecay
68784  k(ii,1)=1
68785  k(ii,3)=ip
68786  k(ii,4)=0
68787  k(ii,5)=0
68788  200 CONTINUE
68789  n=nsav+ndecay
68790  ENDIF
68791 
68792 C...Boost back decay tau and decay products.
68793  DO 210 j=1,4
68794  p(itau,j)=ptau(j)
68795  210 CONTINUE
68796  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
68797  CALL pyrobo(nsav+1,n,thetau,phitau,0d0,0d0,0d0)
68798  IF(kforig.NE.0) CALL pyrobo(nsav+1,n,0d0,0d0,dbetau(1),
68799  & dbetau(2),dbetau(3))
68800 
68801 C...Skip past ordinary tau decay treatment.
68802  mmat=0
68803  mbst=0
68804  nd=0
68805  goto 630
68806  ENDIF
68807  ENDIF
68808 
68809 C...B-Bbar mixing: flip sign of meson appropriately.
68810  mmix=0
68811  IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
68812  xbbmix=parj(76)
68813  IF(kfa.EQ.531) xbbmix=parj(77)
68814  IF(sin(0.5d0*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.pyr(0)) mmix=1
68815  IF(mmix.EQ.1) kfs=-kfs
68816  ENDIF
68817 
68818 C...Check existence of decay channels. Particle/antiparticle rules.
68819  kca=kc
68820  IF(mdcy(kc,2).GT.0) THEN
68821  mdmdcy=mdme(mdcy(kc,2),2)
68822  IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
68823  ENDIF
68824  IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
68825  CALL pyerrm(9,'(PYDECY:) no decay channel defined')
68826  RETURN
68827  ENDIF
68828  IF(mod(kfa/1000,10).EQ.0.AND.kca.EQ.85) kfs=-kfs
68829  IF(kchg(kc,3).EQ.0) THEN
68830  kfsp=1
68831  kfsn=0
68832  IF(pyr(0).GT.0.5d0) kfs=-kfs
68833  ELSEIF(kfs.GT.0) THEN
68834  kfsp=1
68835  kfsn=0
68836  ELSE
68837  kfsp=0
68838  kfsn=1
68839  ENDIF
68840 
68841 C...Sum branching ratios of allowed decay channels.
68842  220 nope=0
68843  brsu=0d0
68844  DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
68845  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
68846  & kfsn*mdme(idl,1).NE.3) goto 230
68847  IF(mdme(idl,2).GT.100) goto 230
68848  nope=nope+1
68849  brsu=brsu+brat(idl)
68850  230 CONTINUE
68851  IF(nope.EQ.0) THEN
68852  CALL pyerrm(2,'(PYDECY:) all decay channels closed by user')
68853  RETURN
68854  ENDIF
68855 
68856 C...Select decay channel among allowed ones.
68857  240 rbr=brsu*pyr(0)
68858  idl=mdcy(kca,2)-1
68859  250 idl=idl+1
68860  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
68861  &kfsn*mdme(idl,1).NE.3) THEN
68862  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
68863  ELSEIF(mdme(idl,2).GT.100) THEN
68864  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
68865  ELSE
68866  idc=idl
68867  rbr=rbr-brat(idl)
68868  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0d0) goto 250
68869  ENDIF
68870 
68871 C...Start readout of decay channel: matrix element, reset counters.
68872  mmat=mdme(idc,2)
68873  260 ntry=ntry+1
68874  IF(mod(ntry,200).EQ.0) THEN
68875  WRITE(cidc,'(I4)') idc
68876 C...Do not print warning for some well-known special cases.
68877  IF(kfa.NE.113.AND.kfa.NE.115.AND.kfa.NE.215)
68878  & CALL pyerrm(4,'(PYDECY:) caught in loop for decay channel'//
68879  & cidc)
68880  goto 240
68881  ENDIF
68882  IF(ntry.GT.1000) THEN
68883  CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
68884  IF(mstu(21).GE.1) RETURN
68885  ENDIF
68886  i=n
68887  np=0
68888  nq=0
68889  mbst=0
68890  IF(mmat.GE.11.AND.p(ip,4).GT.20d0*p(ip,5)) mbst=1
68891  DO 270 j=1,4
68892  pv(1,j)=0d0
68893  IF(mbst.EQ.0) pv(1,j)=p(ip,j)
68894  270 CONTINUE
68895  IF(mbst.EQ.1) pv(1,4)=p(ip,5)
68896  pv(1,5)=p(ip,5)
68897  ps=0d0
68898  psq=0d0
68899  mrem=0
68900  mhaddy=0
68901  IF(kfa.GT.80) mhaddy=1
68902 C.. Random flavour and popcorn system memory.
68903  irndmo=0
68904  jtmo=0
68905  mstu(121)=0
68906  mstu(125)=10
68907 
68908 C...Read out decay products. Convert to standard flavour code.
68909  jtmax=5
68910  IF(mdme(idc+1,2).EQ.101) jtmax=10
68911  DO 280 jt=1,jtmax
68912  IF(jt.LE.5) kp=kfdp(idc,jt)
68913  IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
68914  IF(kp.EQ.0) goto 280
68915  kpa=iabs(kp)
68916  kcp=pycomp(kpa)
68917  IF(kpa.GT.80) mhaddy=1
68918  IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
68919  kfp=kp
68920  ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
68921  kfp=kfs*kp
68922  ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
68923  kfp=-kfs*mod(kfa/10,10)
68924  ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
68925  kfp=kfs*(100*mod(kfa/10,100)+3)
68926  ELSEIF(kpa.EQ.81) THEN
68927  kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
68928  ELSEIF(kp.EQ.82) THEN
68929  CALL pydcyk(-kfs*int(1d0+(2d0+parj(2))*pyr(0)),0,kfp,kdump)
68930  IF(kfp.EQ.0) goto 260
68931  kfp=-kfp
68932  irndmo=1
68933  mstj(93)=1
68934  IF(pv(1,5).LT.parj(32)+2d0*pymass(kfp)) goto 260
68935  ELSEIF(kp.EQ.-82) THEN
68936  kfp=mstu(124)
68937  ENDIF
68938  IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=pycomp(kfp)
68939 
68940 C...Add decay product to event record or to quark flavour list.
68941  kfpa=iabs(kfp)
68942  kqp=kchg(kcp,2)
68943  IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
68944  nq=nq+1
68945  kflo(nq)=kfp
68946 C...set rndmflav popcorn system pointer
68947  IF(kp.EQ.82.AND.mstu(121).GT.0) jtmo=nq
68948  mstj(93)=2
68949  psq=psq+pymass(kflo(nq))
68950  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
68951  & mod(nq,2).EQ.1) THEN
68952  nq=nq-1
68953  ps=ps-p(i,5)
68954  k(i,1)=1
68955  kfi=k(i,2)
68956  CALL pykfdi(kfp,kfi,kfldmp,k(i,2))
68957  IF(k(i,2).EQ.0) goto 260
68958  mstj(93)=1
68959  p(i,5)=pymass(k(i,2))
68960  ps=ps+p(i,5)
68961  ELSE
68962  i=i+1
68963  np=np+1
68964  IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
68965  IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
68966  k(i,1)=1+mod(nq,2)
68967  IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
68968  IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
68969  k(i,2)=kfp
68970  k(i,3)=ip
68971  k(i,4)=0
68972  k(i,5)=0
68973  p(i,5)=pymass(kfp)
68974  ps=ps+p(i,5)
68975  ENDIF
68976  280 CONTINUE
68977 
68978 C...Check masses for resonance decays.
68979  IF(mhaddy.EQ.0) THEN
68980  IF(ps+parj(64).GT.pv(1,5)) goto 240
68981  ENDIF
68982 
68983 C...Choose decay multiplicity in phase space model.
68984  290 IF(mmat.GE.11.AND.mmat.LE.30) THEN
68985  psp=ps
68986  cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1d0))
68987  IF(mmat.EQ.12) cnde=cnde+parj(63)
68988  300 ntry=ntry+1
68989 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
68990  IF(irndmo.EQ.0) THEN
68991  mstu(121)=0
68992  jtmo=0
68993  ELSEIF(irndmo.EQ.1) THEN
68994  irndmo=2
68995  ELSE
68996  goto 260
68997  ENDIF
68998  IF(ntry.GT.1000) THEN
68999  CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
69000  IF(mstu(21).GE.1) RETURN
69001  ENDIF
69002  IF(mmat.LE.20) THEN
69003  gauss=sqrt(-2d0*cnde*log(max(1d-10,pyr(0))))*
69004  & sin(paru(2)*pyr(0))
69005  nd=0.5d0+0.5d0*np+0.25d0*nq+cnde+gauss
69006  IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) goto 300
69007  IF(mmat.EQ.13.AND.nd.EQ.2) goto 300
69008  IF(mmat.EQ.14.AND.nd.LE.3) goto 300
69009  IF(mmat.EQ.15.AND.nd.LE.4) goto 300
69010  ELSE
69011  nd=mmat-20
69012  ENDIF
69013 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
69014  mstu(125)=nd-nq/2
69015  IF(mstu(121).GT.mstu(125)) goto 300
69016 
69017 C...Form hadrons from flavour content.
69018  DO 310 jt=1,nq
69019  kfl1(jt)=kflo(jt)
69020  310 CONTINUE
69021  IF(nd.EQ.np+nq/2) goto 330
69022  DO 320 i=n+np+1,n+nd-nq/2
69023 C.. Stick to started popcorn system, else pick side at random
69024  jt=jtmo
69025  IF(jt.EQ.0) jt=1+int((nq-1)*pyr(0))
69026  CALL pydcyk(kfl1(jt),0,kfl2,k(i,2))
69027  IF(k(i,2).EQ.0) goto 300
69028  mstu(125)=mstu(125)-1
69029  jtmo=0
69030  IF(mstu(121).GT.0) jtmo=jt
69031  kfl1(jt)=-kfl2
69032  320 CONTINUE
69033  330 jt=2
69034  jt2=3
69035  jt3=4
69036  IF(nq.EQ.4.AND.pyr(0).LT.parj(66)) jt=4
69037  IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
69038  & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
69039  IF(jt.EQ.3) jt2=2
69040  IF(jt.EQ.4) jt3=2
69041  CALL pydcyk(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
69042  IF(k(n+nd-nq/2+1,2).EQ.0) goto 300
69043  IF(nq.EQ.4) CALL pydcyk(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
69044  IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) goto 300
69045 
69046 C...Check that sum of decay product masses not too large.
69047  ps=psp
69048  DO 340 i=n+np+1,n+nd
69049  k(i,1)=1
69050  k(i,3)=ip
69051  k(i,4)=0
69052  k(i,5)=0
69053  p(i,5)=pymass(k(i,2))
69054  ps=ps+p(i,5)
69055  340 CONTINUE
69056  IF(ps+parj(64).GT.pv(1,5)) goto 300
69057 
69058 C...Rescale energy to subtract off spectator quark mass.
69059  ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44)
69060  & .AND.np.GE.3) THEN
69061  ps=ps-p(n+np,5)
69062  pqt=(p(n+np,5)+parj(65))/pv(1,5)
69063  DO 350 j=1,5
69064  p(n+np,j)=pqt*pv(1,j)
69065  pv(1,j)=(1d0-pqt)*pv(1,j)
69066  350 CONTINUE
69067  IF(ps+parj(64).GT.pv(1,5)) goto 260
69068  nd=np-1
69069  mrem=1
69070 
69071 C...Fully specified final state: check mass broadening effects.
69072  ELSE
69073  IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) goto 260
69074  nd=np
69075  ENDIF
69076 
69077 C...Determine position of grandmother, number of sisters.
69078  nm=0
69079  kfas=0
69080  msgn=0
69081  IF(mmat.EQ.3) THEN
69082  im=k(ip,3)
69083  IF(im.LT.0.OR.im.GE.ip) im=0
69084  IF(im.NE.0) kfam=iabs(k(im,2))
69085  IF(im.NE.0) THEN
69086  DO 360 il=max(ip-2,im+1),min(ip+2,n)
69087  IF(k(il,3).EQ.im) nm=nm+1
69088  IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
69089  360 CONTINUE
69090  IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
69091  & mod(kfam/1000,10).NE.0) nm=0
69092  IF(nm.EQ.2) THEN
69093  kfas=iabs(k(isis,2))
69094  IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
69095  & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
69096  ENDIF
69097  ENDIF
69098  ENDIF
69099 
69100 C...Kinematics of one-particle decays.
69101  IF(nd.EQ.1) THEN
69102  DO 370 j=1,4
69103  p(n+1,j)=p(ip,j)
69104  370 CONTINUE
69105  goto 630
69106  ENDIF
69107 
69108 C...Calculate maximum weight ND-particle decay.
69109  pv(nd,5)=p(n+nd,5)
69110  IF(nd.GE.3) THEN
69111  wtmax=1d0/wtcor(nd-2)
69112  pmax=pv(1,5)-ps+p(n+nd,5)
69113  pmin=0d0
69114  DO 380 il=nd-1,1,-1
69115  pmax=pmax+p(n+il,5)
69116  pmin=pmin+p(n+il+1,5)
69117  wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
69118  380 CONTINUE
69119  ENDIF
69120 
69121 C...Find virtual gamma mass in Dalitz decay.
69122  390 IF(nd.EQ.2) THEN
69123  ELSEIF(mmat.EQ.2) THEN
69124  pmes=4d0*pmas(11,1)**2
69125  pmrho2=pmas(131,1)**2
69126  pgrho2=pmas(131,2)**2
69127  400 pmst=pmes*(p(ip,5)**2/pmes)**pyr(0)
69128  wt=(1+0.5d0*pmes/pmst)*sqrt(max(0d0,1d0-pmes/pmst))*
69129  & (1d0-pmst/p(ip,5)**2)**3*(1d0+pgrho2/pmrho2)/
69130  & ((1d0-pmst/pmrho2)**2+pgrho2/pmrho2)
69131  IF(wt.LT.pyr(0)) goto 400
69132  pv(2,5)=max(2.00001d0*pmas(11,1),sqrt(pmst))
69133 
69134 C...M-generator gives weight. If rejected, try again.
69135  ELSE
69136  410 rord(1)=1d0
69137  DO 440 il1=2,nd-1
69138  rsav=pyr(0)
69139  DO 420 il2=il1-1,1,-1
69140  IF(rsav.LE.rord(il2)) goto 430
69141  rord(il2+1)=rord(il2)
69142  420 CONTINUE
69143  430 rord(il2+1)=rsav
69144  440 CONTINUE
69145  rord(nd)=0d0
69146  wt=1d0
69147  DO 450 il=nd-1,1,-1
69148  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*
69149  & (pv(1,5)-ps)
69150  wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
69151  450 CONTINUE
69152  IF(wt.LT.pyr(0)*wtmax) goto 410
69153  ENDIF
69154 
69155 C...Perform two-particle decays in respective CM frame.
69156  460 DO 480 il=1,nd-1
69157  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
69158  ue(3)=2d0*pyr(0)-1d0
69159  phi=paru(2)*pyr(0)
69160  ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
69161  ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
69162  DO 470 j=1,3
69163  p(n+il,j)=pa*ue(j)
69164  pv(il+1,j)=-pa*ue(j)
69165  470 CONTINUE
69166  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
69167  pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
69168  480 CONTINUE
69169 
69170 C...Lorentz transform decay products to lab frame.
69171  DO 490 j=1,4
69172  p(n+nd,j)=pv(nd,j)
69173  490 CONTINUE
69174  DO 530 il=nd-1,1,-1
69175  DO 500 j=1,3
69176  be(j)=pv(il,j)/pv(il,4)
69177  500 CONTINUE
69178  ga=pv(il,4)/pv(il,5)
69179  DO 520 i=n+il,n+nd
69180  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
69181  DO 510 j=1,3
69182  p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
69183  510 CONTINUE
69184  p(i,4)=ga*(p(i,4)+bep)
69185  520 CONTINUE
69186  530 CONTINUE
69187 
69188 C...Check that no infinite loop in matrix element weight.
69189  ntry=ntry+1
69190  IF(ntry.GT.800) goto 560
69191 
69192 C...Matrix elements for omega and phi decays.
69193  IF(mmat.EQ.1) THEN
69194  wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
69195  & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
69196  & +2d0*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
69197  IF(max(wt*wtcor(9)/p(ip,5)**6,0.001d0).LT.pyr(0)) goto 390
69198 
69199 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
69200  ELSEIF(mmat.EQ.2) THEN
69201  four12=four(n+1,n+2)
69202  four13=four(n+1,n+3)
69203  wt=(pmst-0.5d0*pmes)*(four12**2+four13**2)+
69204  & pmes*(four12*four13+four12**2+four13**2)
69205  IF(wt.LT.pyr(0)*0.25d0*pmst*(p(ip,5)**2-pmst)**2) goto 460
69206 
69207 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
69208 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
69209 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
69210  ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
69211  four10=four(ip,im)
69212  four12=four(ip,n+1)
69213  four02=four(im,n+1)
69214  pms1=p(ip,5)**2
69215  pms0=p(im,5)**2
69216  pms2=p(n+1,5)**2
69217  IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
69218  IF(kfas.EQ.22) hnum=pms1*(2d0*four10*four12*four02-
69219  & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
69220  hnum=max(1d-6*pms1**2*pms0*pms2,hnum)
69221  hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
69222  IF(hnum.LT.pyr(0)*hden) goto 460
69223 
69224 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
69225  ELSEIF(mmat.EQ.4) THEN
69226  hx1=2d0*four(ip,n+1)/p(ip,5)**2
69227  hx2=2d0*four(ip,n+2)/p(ip,5)**2
69228  hx3=2d0*four(ip,n+3)/p(ip,5)**2
69229  wt=((1d0-hx1)/(hx2*hx3))**2+((1d0-hx2)/(hx1*hx3))**2+
69230  & ((1d0-hx3)/(hx1*hx2))**2
69231  IF(wt.LT.2d0*pyr(0)) goto 390
69232  IF(k(ip+1,2).EQ.22.AND.(1d0-hx1)*p(ip,5)**2.LT.4d0*parj(32)**2)
69233  & goto 390
69234 
69235 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
69236  ELSEIF(mmat.EQ.41) THEN
69237  IF(mbst.EQ.0) hx1=2d0*four(ip,n+1)/p(ip,5)**2
69238  IF(mbst.EQ.1) hx1=2d0*p(n+1,4)/p(ip,5)
69239  hxm=min(0.75d0,2d0*(1d0-ps/p(ip,5)))
69240  IF(hx1*(3d0-2d0*hx1).LT.pyr(0)*hxm*(3d0-2d0*hxm)) goto 390
69241 
69242 C...Matrix elements for weak decays (only semileptonic for c and b)
69243  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
69244  & .AND.nd.EQ.3) THEN
69245  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
69246  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
69247  IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 390
69248  ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
69249  DO 550 j=1,4
69250  p(n+np+1,j)=0d0
69251  DO 540 is=n+3,n+np
69252  p(n+np+1,j)=p(n+np+1,j)+p(is,j)
69253  540 CONTINUE
69254  550 CONTINUE
69255  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
69256  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
69257  IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 390
69258  ENDIF
69259 
69260 C...Scale back energy and reattach spectator.
69261  560 IF(mrem.EQ.1) THEN
69262  DO 570 j=1,5
69263  pv(1,j)=pv(1,j)/(1d0-pqt)
69264  570 CONTINUE
69265  nd=nd+1
69266  mrem=0
69267  ENDIF
69268 
69269 C...Low invariant mass for system with spectator quark gives particle,
69270 C...not two jets. Readjust momenta accordingly.
69271  IF(mmat.EQ.31.AND.nd.EQ.3) THEN
69272  mstj(93)=1
69273  pm2=pymass(k(n+2,2))
69274  mstj(93)=1
69275  pm3=pymass(k(n+3,2))
69276  IF(p(n+2,5)**2+p(n+3,5)**2+2d0*four(n+2,n+3).GE.
69277  & (parj(32)+pm2+pm3)**2) goto 630
69278  k(n+2,1)=1
69279  kftemp=k(n+2,2)
69280  CALL pykfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
69281  IF(k(n+2,2).EQ.0) goto 260
69282  p(n+2,5)=pymass(k(n+2,2))
69283  ps=p(n+1,5)+p(n+2,5)
69284  pv(2,5)=p(n+2,5)
69285  mmat=0
69286  nd=2
69287  goto 460
69288  ELSEIF(mmat.EQ.44) THEN
69289  mstj(93)=1
69290  pm3=pymass(k(n+3,2))
69291  mstj(93)=1
69292  pm4=pymass(k(n+4,2))
69293  IF(p(n+3,5)**2+p(n+4,5)**2+2d0*four(n+3,n+4).GE.
69294  & (parj(32)+pm3+pm4)**2) goto 600
69295  k(n+3,1)=1
69296  kftemp=k(n+3,2)
69297  CALL pykfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
69298  IF(k(n+3,2).EQ.0) goto 260
69299  p(n+3,5)=pymass(k(n+3,2))
69300  DO 580 j=1,3
69301  p(n+3,j)=p(n+3,j)+p(n+4,j)
69302  580 CONTINUE
69303  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)
69304  ha=p(n+1,4)**2-p(n+2,4)**2
69305  hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
69306  hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
69307  & (p(n+1,3)-p(n+2,3))**2
69308  hd=(pv(1,4)-p(n+3,4))**2
69309  he=ha**2-2d0*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
69310  hf=hd*hc-hb**2
69311  hg=hd*hc-ha*hb
69312  hh=(sqrt(hg**2+he*hf)-hg)/(2d0*hf)
69313  DO 590 j=1,3
69314  pcor=hh*(p(n+1,j)-p(n+2,j))
69315  p(n+1,j)=p(n+1,j)+pcor
69316  p(n+2,j)=p(n+2,j)-pcor
69317  590 CONTINUE
69318  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)
69319  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)
69320  nd=nd-1
69321  ENDIF
69322 
69323 C...Check invariant mass of W jets. May give one particle or start over.
69324  600 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
69325  &.AND.iabs(k(n+1,2)).LT.10) THEN
69326  pmr=sqrt(max(0d0,p(n+1,5)**2+p(n+2,5)**2+2d0*four(n+1,n+2)))
69327  mstj(93)=1
69328  pm1=pymass(k(n+1,2))
69329  mstj(93)=1
69330  pm2=pymass(k(n+2,2))
69331  IF(pmr.GT.parj(32)+pm1+pm2) goto 610
69332  kfldum=int(1.5d0+pyr(0))
69333  CALL pykfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
69334  CALL pykfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
69335  IF(kf1.EQ.0.OR.kf2.EQ.0) goto 260
69336  psm=pymass(kf1)+pymass(kf2)
69337  IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) goto 610
69338  IF(mmat.GE.43.AND.pmr.GT.0.2d0*parj(32)+psm) goto 610
69339  IF(mmat.EQ.48) goto 390
69340  IF(nd.EQ.4.OR.kfa.EQ.15) goto 260
69341  k(n+1,1)=1
69342  kftemp=k(n+1,2)
69343  CALL pykfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
69344  IF(k(n+1,2).EQ.0) goto 260
69345  p(n+1,5)=pymass(k(n+1,2))
69346  k(n+2,2)=k(n+3,2)
69347  p(n+2,5)=p(n+3,5)
69348  ps=p(n+1,5)+p(n+2,5)
69349  IF(ps+parj(64).GT.pv(1,5)) goto 260
69350  pv(2,5)=p(n+3,5)
69351  mmat=0
69352  nd=2
69353  goto 460
69354  ENDIF
69355 
69356 C...Phase space decay of partons from W decay.
69357  610 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
69358  kflo(1)=k(n+1,2)
69359  kflo(2)=k(n+2,2)
69360  k(n+1,1)=k(n+3,1)
69361  k(n+1,2)=k(n+3,2)
69362  DO 620 j=1,5
69363  pv(1,j)=p(n+1,j)+p(n+2,j)
69364  p(n+1,j)=p(n+3,j)
69365  620 CONTINUE
69366  pv(1,5)=pmr
69367  n=n+1
69368  np=0
69369  nq=2
69370  ps=0d0
69371  mstj(93)=2
69372  psq=pymass(kflo(1))
69373  mstj(93)=2
69374  psq=psq+pymass(kflo(2))
69375  mmat=11
69376  goto 290
69377  ENDIF
69378 
69379 C...Boost back for rapidly moving particle.
69380  630 n=n+nd
69381  IF(mbst.EQ.1) THEN
69382  DO 640 j=1,3
69383  be(j)=p(ip,j)/p(ip,4)
69384  640 CONTINUE
69385  ga=p(ip,4)/p(ip,5)
69386  DO 660 i=nsav+1,n
69387  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
69388  DO 650 j=1,3
69389  p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
69390  650 CONTINUE
69391  p(i,4)=ga*(p(i,4)+bep)
69392  660 CONTINUE
69393  ENDIF
69394 
69395 C...Fill in position of decay vertex.
69396  DO 680 i=nsav+1,n
69397  DO 670 j=1,4
69398  v(i,j)=vdcy(j)
69399  670 CONTINUE
69400  v(i,5)=0d0
69401  680 CONTINUE
69402 
69403 C...Set up for parton shower evolution from jets.
69404  IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
69405  k(nsav+1,1)=3
69406  k(nsav+2,1)=3
69407  k(nsav+3,1)=3
69408  k(nsav+1,4)=mstu(5)*(nsav+2)
69409  k(nsav+1,5)=mstu(5)*(nsav+3)
69410  k(nsav+2,4)=mstu(5)*(nsav+3)
69411  k(nsav+2,5)=mstu(5)*(nsav+1)
69412  k(nsav+3,4)=mstu(5)*(nsav+1)
69413  k(nsav+3,5)=mstu(5)*(nsav+2)
69414  mstj(92)=-(nsav+1)
69415  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
69416  k(nsav+2,1)=3
69417  k(nsav+3,1)=3
69418  k(nsav+2,4)=mstu(5)*(nsav+3)
69419  k(nsav+2,5)=mstu(5)*(nsav+3)
69420  k(nsav+3,4)=mstu(5)*(nsav+2)
69421  k(nsav+3,5)=mstu(5)*(nsav+2)
69422  mstj(92)=nsav+2
69423  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
69424  & iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
69425  k(nsav+1,1)=3
69426  k(nsav+2,1)=3
69427  k(nsav+1,4)=mstu(5)*(nsav+2)
69428  k(nsav+1,5)=mstu(5)*(nsav+2)
69429  k(nsav+2,4)=mstu(5)*(nsav+1)
69430  k(nsav+2,5)=mstu(5)*(nsav+1)
69431  mstj(92)=nsav+1
69432  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
69433  & iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
69434  mstj(92)=nsav+1
69435  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
69436  & THEN
69437  k(nsav+1,1)=3
69438  k(nsav+2,1)=3
69439  k(nsav+3,1)=3
69440  kcp=pycomp(k(nsav+1,2))
69441  kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
69442  jcon=4
69443  IF(kqp.LT.0) jcon=5
69444  k(nsav+1,jcon)=mstu(5)*(nsav+2)
69445  k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
69446  k(nsav+2,jcon)=mstu(5)*(nsav+3)
69447  k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
69448  mstj(92)=nsav+1
69449  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
69450  k(nsav+1,1)=3
69451  k(nsav+3,1)=3
69452  k(nsav+1,4)=mstu(5)*(nsav+3)
69453  k(nsav+1,5)=mstu(5)*(nsav+3)
69454  k(nsav+3,4)=mstu(5)*(nsav+1)
69455  k(nsav+3,5)=mstu(5)*(nsav+1)
69456  mstj(92)=nsav+1
69457  ENDIF
69458 
69459 C...Mark decayed particle; special option for B-Bbar mixing.
69460  IF(k(ip,1).EQ.5) k(ip,1)=15
69461  IF(k(ip,1).LE.10) k(ip,1)=11
69462  IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
69463  k(ip,4)=nsav+1
69464  k(ip,5)=n
69465 
69466  RETURN
69467  END
69468 
69469 
69470 C*********************************************************************
69471 
69472 C...PYDCYK
69473 C...Handles flavour production in the decay of unstable particles
69474 C...and small string clusters.
69475 
69476  SUBROUTINE pydcyk(KFL1,KFL2,KFL3,KF)
69477 
69478 C...Double precision and integer declarations.
69479  IMPLICIT DOUBLE PRECISION(a-h, o-z)
69480  IMPLICIT INTEGER(i-n)
69481  INTEGER pyk,pychge,pycomp
69482 C...Commonblocks.
69483  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
69484  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
69485  SAVE /pydat1/,/pydat2/
69486 
69487 
69488 C.. Call PYKFDI directly if no popcorn option is on
69489  IF(mstj(12).LT.2) THEN
69490  CALL pykfdi(kfl1,kfl2,kfl3,kf)
69491  mstu(124)=kfl3
69492  RETURN
69493  ENDIF
69494 
69495  kfl3=0
69496  kf=0
69497  IF(kfl1.EQ.0) RETURN
69498  kf1a=iabs(kfl1)
69499  kf2a=iabs(kfl2)
69500 
69501  nsto=130
69502  nmax=min(mstu(125),10)
69503 
69504 C.. Identify rank 0 cluster qq
69505  irank=1
69506  IF(kf1a.GT.10.AND.kf1a.LT.10000) irank=0
69507 
69508  IF(kf2a.GT.0)THEN
69509 C.. Join jets: Fails if store not empty
69510  IF(mstu(121).GT.0) THEN
69511  mstu(121)=0
69512  RETURN
69513  ENDIF
69514  CALL pykfdi(kfl1,kfl2,kfl3,kf)
69515  ELSEIF(kf1a.GT.10.AND.mstu(121).GT.0)THEN
69516 C.. Pick popcorn meson from store, return same qq, decrease store
69517  kf=mstu(nsto+mstu(121))
69518  kfl3=-kfl1
69519  mstu(121)=mstu(121)-1
69520  ELSE
69521 C.. Generate new flavour. Then done if no diquark is generated
69522  100 CALL pykfdi(kfl1,0,kfl3,kf)
69523  IF(mstu(121).EQ.-1) goto 100
69524  mstu(124)=kfl3
69525  IF(kf.EQ.0.OR.iabs(kfl3).LE.10) RETURN
69526 
69527 C.. Simple case if no dynamical popcorn suppressions are considered
69528  IF(mstj(12).LT.4) THEN
69529  IF(mstu(121).EQ.0) RETURN
69530  nmes=1
69531  kfprev=-kfl3
69532  CALL pykfdi(kfprev,0,kfl3,kfm)
69533 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
69534  IF(iabs(kfl3).LE.10)THEN
69535  kfl3=-kfprev
69536  RETURN
69537  ENDIF
69538  goto 120
69539  ENDIF
69540 
69541 C test output qq against fake Gamma, then return if no popcorn.
69542  gb=2d0
69543  IF(irank.NE.0)THEN
69544  CALL pyzdis(1,2103,5d0,z)
69545  gb=5d0*(1d0-z)/z
69546  IF(1d0-parf(192)**gb.LT.pyr(0)) THEN
69547  mstu(121)=0
69548  goto 100
69549  ENDIF
69550  ENDIF
69551  IF(mstu(121).EQ.0) RETURN
69552 
69553 C..Set store size memory. Pick fake dynamical variables of qq.
69554  nmes=mstu(121)
69555  CALL pyptdi(1,px3,py3)
69556  x=1d0
69557  popm=0d0
69558  g=gb
69559  popg=gb
69560 
69561 C.. Pick next popcorn meson, test with fake dynamical variables
69562  110 kfprev=-kfl3
69563  px1=-px3
69564  py1=-py3
69565  CALL pykfdi(kfprev,0,kfl3,kfm)
69566  IF(mstu(121).EQ.-1) goto 100
69567  CALL pyptdi(kfl3,px3,py3)
69568  pm=pymass(kfm)**2+(px1+px3)**2+(py1+py3)**2
69569  CALL pyzdis(kfprev,kfl3,pm,z)
69570  g=(1d0-z)*(g+pm/z)
69571  x=(1d0-z)*x
69572 
69573  ptst=1d0
69574  gtst=1d0
69575  rtst=pyr(0)
69576  IF(mstj(12).GT.4)THEN
69577  popmn=sqrt((1d0-x)*(g/x-gb))
69578  popm=popm+pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
69579  ptst=exp((popm-popmn)*parf(193))
69580  popm=popmn
69581  ENDIF
69582  IF(irank.NE.0)THEN
69583  popgn=x*gb
69584  gtst=(1d0-parf(192)**popgn)/(1d0-parf(192)**popg)
69585  popg=popgn
69586  ENDIF
69587  IF(rtst.GT.ptst*gtst)THEN
69588  mstu(121)=0
69589  IF(rtst.GT.ptst) mstu(121)=-1
69590  goto 100
69591  ENDIF
69592 
69593 C.. Store meson
69594  120 IF(nmes.LE.nmax) mstu(nsto+mstu(121)+1)=kfm
69595  IF(mstu(121).GT.0) goto 110
69596 
69597 C.. Test accepted system size. If OK set global popcorn size variable.
69598  IF(nmes.GT.nmax)THEN
69599  kf=0
69600  kfl3=0
69601  RETURN
69602  ENDIF
69603  mstu(121)=nmes
69604  ENDIF
69605 
69606  RETURN
69607  END
69608 
69609 C********************************************************************
69610 
69611 C...PYKFDI
69612 C...Generates a new flavour pair and combines off a hadron
69613 
69614  SUBROUTINE pykfdi(KFL1,KFL2,KFL3,KF)
69615 
69616 C...Double precision and integer declarations.
69617  IMPLICIT DOUBLE PRECISION(a-h, o-z)
69618  IMPLICIT INTEGER(i-n)
69619  INTEGER pyk,pychge,pycomp
69620 C...Commonblocks.
69621  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
69622  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
69623  SAVE /pydat1/,/pydat2/
69624 C...Local arrays.
69625  dimension pd(7)
69626 
69627  IF(mstu(123).EQ.0.AND.mstj(12).GE.0) CALL pykfin
69628 
69629 C...Default flavour values. Input consistency checks.
69630  kf1a=iabs(kfl1)
69631  kf2a=iabs(kfl2)
69632  kfl3=0
69633  kf=0
69634  IF(kf1a.EQ.0) RETURN
69635  IF(kf2a.NE.0)THEN
69636  IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
69637  IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
69638  IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
69639  ENDIF
69640 
69641 C...Check if tabulated flavour probabilities are to be used.
69642  IF(mstj(15).EQ.1) THEN
69643  IF(mstj(12).GE.5) CALL pyerrm(29,
69644  & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
69645  & ' together with MSTJ(12)>=5 modification')
69646  ktab1=-1
69647  IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
69648  kfl1a=mod(kf1a/1000,10)
69649  kfl1b=mod(kf1a/100,10)
69650  kfl1s=mod(kf1a,10)
69651  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
69652  & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
69653  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
69654  IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
69655  ktab2=0
69656  IF(kf2a.NE.0) THEN
69657  ktab2=-1
69658  IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
69659  kfl2a=mod(kf2a/1000,10)
69660  kfl2b=mod(kf2a/100,10)
69661  kfl2s=mod(kf2a,10)
69662  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
69663  & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
69664  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
69665  ENDIF
69666  IF(ktab1.GE.0.AND.ktab2.GE.0) goto 140
69667  ENDIF
69668 
69669 C.. Recognize rank 0 diquark case
69670  100 irank=1
69671  kfdiq=max(kf1a,kf2a)
69672  IF(kfdiq.GT.10.AND.kfdiq.LT.10000) irank=0
69673 
69674 C.. Join two flavours to meson or baryon. Test for popcorn.
69675  IF(kf2a.GT.0)THEN
69676  mbary=0
69677  IF(kfdiq.GT.10) THEN
69678  IF(irank.EQ.0.AND.mstj(12).LT.5)
69679  & CALL pynmes(kfdiq)
69680  IF(mstu(121).NE.0) THEN
69681  mstu(121)=0
69682  RETURN
69683  ENDIF
69684  mbary=2
69685  ENDIF
69686  kfqold=kf1a
69687  kfqver=kf2a
69688  goto 130
69689  ENDIF
69690 
69691 C.. Separate incoming flavours, curtain flavour consistency check
69692  kfin=kfl1
69693  kfqold=kf1a
69694  kfqpop=kf1a/10000
69695  IF(kf1a.GT.10)THEN
69696  kfin=-kfl1
69697  kfl1a=mod(kf1a/1000,10)
69698  kfl1b=mod(kf1a/100,10)
69699  IF(irank.EQ.0)THEN
69700  qawt=1d0
69701  IF(kfl1a.GE.3) qawt=parf(136+kfl1a/4)
69702  IF(kfl1b.GE.3) qawt=qawt/parf(136+kfl1b/4)
69703  kfqpop=kfl1a+(kfl1b-kfl1a)*int(1d0/(qawt+1d0)+pyr(0))
69704  ENDIF
69705  IF(kfqpop.NE.kfl1b.AND.kfqpop.NE.kfl1a) THEN
69706  mstu(121)=0
69707  RETURN
69708  ENDIF
69709  kfqold=kfl1a+kfl1b-kfqpop
69710  ENDIF
69711 
69712 C...Meson/baryon choice. Set number of mesons if starting a popcorn
69713 C...system.
69714  110 mbary=0
69715  IF(kf1a.LE.10.AND.mstj(12).GT.0)THEN
69716  IF(mstu(121).EQ.-1.OR.(1d0+parj(1))*pyr(0).GT.1d0)THEN
69717  mbary=1
69718  CALL pynmes(0)
69719  ENDIF
69720  ELSEIF(kf1a.GT.10)THEN
69721  mbary=2
69722  IF(irank.EQ.0) CALL pynmes(kf1a)
69723  IF(mstu(121).GT.0) mbary=-1
69724  ENDIF
69725 
69726 C..x->H+q: Choose single vertex quark. Jump to form hadron.
69727  IF(mbary.EQ.0.OR.mbary.EQ.2)THEN
69728  kfqver=1+int((2d0+parj(2))*pyr(0))
69729  kfl3=isign(kfqver,-kfin)
69730  goto 130
69731  ENDIF
69732 
69733 C..x->H+qq: (IDW=proper PARF position for diquark weights)
69734  idw=160
69735  IF(mbary.EQ.1)THEN
69736  IF(mstu(121).EQ.0) idw=150
69737  sqwt=parf(idw+1)
69738  IF(mstu(121).GT.0) sqwt=sqwt*parf(135)*parf(138)**mstu(121)
69739  kfqpop=1+int((2d0+sqwt)*pyr(0))
69740 C.. Shift to s-curtain parameters if needed
69741  IF(kfqpop.GE.3.AND.mstj(12).GE.5)THEN
69742  parf(194)=parf(138)*parf(139)
69743  parf(193)=parj(8)+parj(9)
69744  ENDIF
69745  ENDIF
69746 
69747 C.. x->H+qq: Get vertex quark
69748  IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
69749  idw=mstu(122)
69750  mstu(121)=mstu(121)-1
69751  IF(idw.EQ.170) THEN
69752  IF(mstu(121).EQ.0)THEN
69753  ipos=3*min(kfqpop-1,2)+min(kfqold-1,2)
69754  ELSE
69755  ipos=3*3+3*max(0,min(kfqpop-2,1))+min(kfqold-1,2)
69756  ENDIF
69757  ELSE
69758  IF(mstu(121).EQ.0)THEN
69759  ipos=3*5+5*min(kfqpop-1,3)+min(kfqold-1,4)
69760  ELSE
69761  ipos=3*5+5*4+min(kfqold-1,4)
69762  ENDIF
69763  ENDIF
69764  ipos=200+30*ipos+1
69765 
69766  imes=-1
69767  rmes=pyr(0)*parf(194)
69768  120 imes=imes+1
69769  rmes=rmes-parf(ipos+imes)
69770  IF(imes.EQ.30) THEN
69771  mstu(121)=-1
69772  kf=-111
69773  RETURN
69774  ENDIF
69775  IF(rmes.GT.0d0) goto 120
69776  kmul=imes/5
69777  kfj=2*kmul+1
69778  IF(kmul.EQ.2) kfj=10003
69779  IF(kmul.EQ.3) kfj=10001
69780  IF(kmul.EQ.4) kfj=20003
69781  IF(kmul.EQ.5) kfj=5
69782  idiag=0
69783  kfqver=mod(imes,5)+1
69784  IF(kfqver.GE.kfqold) kfqver=kfqver+1
69785  IF(kfqver.GT.3)THEN
69786  idiag=kfqver-3
69787  kfqver=kfqold
69788  ENDIF
69789  ELSE
69790  IF(mbary.EQ.-1) idw=170
69791  sqwt=parf(idw+2)
69792  IF(kfqpop.EQ.3) sqwt=parf(idw+3)
69793  IF(kfqpop.GT.3) sqwt=parf(idw+3)*(1d0/parf(idw+5)+1d0)/2d0
69794  kfqver=min(3,1+int((2d0+sqwt)*pyr(0)))
69795  IF(kfqpop.LT.3.AND.kfqver.LT.3)THEN
69796  kfqver=kfqpop
69797  IF(pyr(0).GT.parf(idw+4)) kfqver=3-kfqpop
69798  ENDIF
69799  ENDIF
69800 
69801 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
69802  kflds=3
69803  IF(kfqpop.NE.kfqver)THEN
69804  swt=parf(idw+7)
69805  IF(kfqver.EQ.3) swt=parf(idw+6)
69806  IF(kfqpop.GE.3) swt=parf(idw+5)
69807  IF((1d0+swt)*pyr(0).LT.1d0) kflds=1
69808  ENDIF
69809  kfdiq=900*max(kfqver,kfqpop)+100*(kfqver+kfqpop)+kflds
69810  & +10000*kfqpop
69811  kfl3=isign(kfdiq,kfin)
69812 
69813 C..x->M+y: flavour for meson.
69814  130 IF(mbary.LE.0)THEN
69815  kfla=max(kfqold,kfqver)
69816  kflb=min(kfqold,kfqver)
69817  kfs=isign(1,kfl1)
69818  IF(kfla.NE.kfqold) kfs=-kfs
69819 C... Form meson, with spin and flavour mixing for diagonal states.
69820  IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
69821  IF(idiag.GT.0) kf=110*idiag+kfj
69822  IF(idiag.EQ.0) kf=(100*kfla+10*kflb+kfj)*kfs*(-1)**kfla
69823  RETURN
69824  ENDIF
69825  IF(kfla.LE.2) kmul=int(parj(11)+pyr(0))
69826  IF(kfla.EQ.3) kmul=int(parj(12)+pyr(0))
69827  IF(kfla.GE.4) kmul=int(parj(13)+pyr(0))
69828  IF(kmul.EQ.0.AND.parj(14).GT.0d0)THEN
69829  IF(pyr(0).LT.parj(14)) kmul=2
69830  ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0d0)THEN
69831  rmul=pyr(0)
69832  IF(rmul.LT.parj(15)) kmul=3
69833  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
69834  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
69835  ENDIF
69836  kfls=3
69837  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
69838  IF(kmul.EQ.5) kfls=5
69839  IF(kfla.NE.kflb)THEN
69840  kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
69841  ELSE
69842  rmix=pyr(0)
69843  imix=2*kfla+10*kmul
69844  IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
69845  & int(rmix+parf(imix)))+kfls
69846  IF(kfla.GE.4) kf=110*kfla+kfls
69847  ENDIF
69848  IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
69849  IF(kmul.EQ.4) kf=kf+isign(20000,kf)
69850 
69851 C..Optional extra suppression of eta and eta'.
69852 C..Allow shift to qq->B+q in old version (set IRANK to 0)
69853  IF(kf.EQ.221.OR.kf.EQ.331)THEN
69854  IF(pyr(0).GT.parj(25+kf/300))THEN
69855  IF(kf2a.GT.0) goto 130
69856  IF(mstj(12).LT.4) irank=0
69857  goto 110
69858  ENDIF
69859  ENDIF
69860  mstu(121)=0
69861 
69862 C.. x->B+y: Flavour for baryon
69863  ELSE
69864  kfla=kfqver
69865  IF(kf1a.LE.10) kfla=kfqold
69866  kflb=mod(kfdiq/1000,10)
69867  kflc=mod(kfdiq/100,10)
69868  kflds=mod(kfdiq,10)
69869  kfld=max(kfla,kflb,kflc)
69870  kflf=min(kfla,kflb,kflc)
69871  kfle=kfla+kflb+kflc-kfld-kflf
69872 
69873 C... SU(6) factors for formation of baryon.
69874  kbary=3
69875  kdmax=5
69876  kflg=kflb
69877  IF(kflb.NE.kflc)THEN
69878  kbary=2*kflds-1
69879  kdmax=1+kflds/2
69880  IF(kflb.GT.2) kdmax=kdmax+2
69881  ENDIF
69882  IF(kfla.NE.kflb.AND.kfla.NE.kflc)THEN
69883  kbary=kbary+1
69884  kflg=kfla
69885  ENDIF
69886 
69887  su6max=parf(140+kdmax)
69888  su6dec=parj(18)
69889  su6s =parf(146)
69890  IF(mstj(12).GE.5.AND.irank.EQ.0) THEN
69891  su6max=1d0
69892  su6dec=1d0
69893  su6s =1d0
69894  ENDIF
69895  su6oct=parf(60+kbary)
69896  IF(kflg.GT.max(kfla+kflb-kflg,2))THEN
69897  su6oct=su6oct*4*su6s/(3*su6s+1)
69898  IF(kbary.EQ.2) su6oct=parf(60+kbary)*4/(3*su6s+1)
69899  ELSE
69900  IF(kbary.EQ.6) su6oct=su6oct*(3+su6s)/(3*su6s+1)
69901  ENDIF
69902  su6wt=su6oct+su6dec*parf(70+kbary)
69903 
69904 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
69905  IF(su6wt.LT.pyr(0)*su6max.AND.kf2a.EQ.0)THEN
69906  mstu(121)=0
69907  IF(mstj(12).LE.2.AND.mbary.EQ.1) mstu(121)=-1
69908  goto 110
69909  ENDIF
69910 
69911 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
69912  ksig=1
69913  kfls=2
69914  IF(su6wt*pyr(0).GT.su6oct) kfls=4
69915  IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf)THEN
69916  ksig=kflds/3
69917  IF(kfla.NE.kfld) ksig=int(3*su6s/(3*su6s+kflds**2)+pyr(0))
69918  ENDIF
69919  kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
69920  IF(ksig.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
69921  ENDIF
69922  RETURN
69923 
69924 C...Use tabulated probabilities to select new flavour and hadron.
69925  140 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
69926  kt3l=1
69927  kt3u=6
69928  ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
69929  kt3l=1
69930  kt3u=6
69931  ELSEIF(ktab2.EQ.0) THEN
69932  kt3l=1
69933  kt3u=22
69934  ELSE
69935  kt3l=ktab2
69936  kt3u=ktab2
69937  ENDIF
69938  rfl=0d0
69939  DO 160 kts=0,2
69940  DO 150 kt3=kt3l,kt3u
69941  rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
69942  150 CONTINUE
69943  160 CONTINUE
69944  rfl=pyr(0)*rfl
69945  DO 180 kts=0,2
69946  ktabs=kts
69947  DO 170 kt3=kt3l,kt3u
69948  ktab3=kt3
69949  rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
69950  IF(rfl.LE.0d0) goto 190
69951  170 CONTINUE
69952  180 CONTINUE
69953  190 CONTINUE
69954 
69955 C...Reconstruct flavour of produced quark/diquark.
69956  IF(ktab3.LE.6) THEN
69957  kfl3a=ktab3
69958  kfl3b=0
69959  kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
69960  ELSE
69961  kfl3a=1
69962  IF(ktab3.GE.8) kfl3a=2
69963  IF(ktab3.GE.11) kfl3a=3
69964  IF(ktab3.GE.16) kfl3a=4
69965  kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
69966  kfl3=1000*kfl3a+100*kfl3b+1
69967  IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
69968  & kfl3+2
69969  kfl3=isign(kfl3,kfl1*(13-2*ktab1))
69970  ENDIF
69971 
69972 C...Reconstruct meson code.
69973  IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
69974  &kfl3b.NE.0)) THEN
69975  rfl=pyr(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
69976  & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
69977  kf=110+2*ktabs+1
69978  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
69979  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
69980  & 25*ktabs)) kf=330+2*ktabs+1
69981  ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
69982  kfla=max(ktab1,ktab3)
69983  kflb=min(ktab1,ktab3)
69984  kfs=isign(1,kfl1)
69985  IF(kfla.NE.kf1a) kfs=-kfs
69986  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
69987  ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
69988  kfs=isign(1,kfl1)
69989  IF(kfl1a.EQ.kfl3a) THEN
69990  kfla=max(kfl1b,kfl3b)
69991  kflb=min(kfl1b,kfl3b)
69992  IF(kfla.NE.kfl1b) kfs=-kfs
69993  ELSEIF(kfl1a.EQ.kfl3b) THEN
69994  kfla=kfl3a
69995  kflb=kfl1b
69996  kfs=-kfs
69997  ELSEIF(kfl1b.EQ.kfl3a) THEN
69998  kfla=kfl1a
69999  kflb=kfl3b
70000  ELSEIF(kfl1b.EQ.kfl3b) THEN
70001  kfla=max(kfl1a,kfl3a)
70002  kflb=min(kfl1a,kfl3a)
70003  IF(kfla.NE.kfl1a) kfs=-kfs
70004  ELSE
70005  CALL pyerrm(2,'(PYKFDI:) no matching flavours for qq -> qq')
70006  goto 100
70007  ENDIF
70008  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
70009 
70010 C...Reconstruct baryon code.
70011  ELSE
70012  IF(ktab1.GE.7) THEN
70013  kfla=kfl3a
70014  kflb=kfl1a
70015  kflc=kfl1b
70016  ELSE
70017  kfla=kfl1a
70018  kflb=kfl3a
70019  kflc=kfl3b
70020  ENDIF
70021  kfld=max(kfla,kflb,kflc)
70022  kflf=min(kfla,kflb,kflc)
70023  kfle=kfla+kflb+kflc-kfld-kflf
70024  IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
70025  IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
70026  ENDIF
70027 
70028 C...Check that constructed flavour code is an allowed one.
70029  IF(kfl2.NE.0) kfl3=0
70030  kc=pycomp(kf)
70031  IF(kc.EQ.0) THEN
70032  CALL pyerrm(2,'(PYKFDI:) user-defined flavour probabilities '//
70033  & 'failed')
70034  goto 100
70035  ENDIF
70036 
70037  RETURN
70038  END
70039 
70040 C*********************************************************************
70041 
70042 C...PYNMES
70043 C...Generates number of popcorn mesons and stores some relevant
70044 C...parameters.
70045 
70046  SUBROUTINE pynmes(KFDIQ)
70047 
70048 C...Double precision and integer declarations.
70049  IMPLICIT DOUBLE PRECISION(a-h, o-z)
70050  IMPLICIT INTEGER(i-n)
70051  INTEGER pyk,pychge,pycomp
70052 C...Commonblocks.
70053  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
70054  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
70055  SAVE /pydat1/,/pydat2/
70056 
70057  mstu(121)=0
70058  IF(mstj(12).LT.2) RETURN
70059 
70060 C..Old version: Get 1 or 0 popcorn mesons
70061  IF(mstj(12).LT.5)THEN
70062  popwt=parf(131)
70063  IF(kfdiq.NE.0) THEN
70064  kfdiqa=iabs(kfdiq)
70065  kfa=mod(kfdiqa/1000,10)
70066  kfb=mod(kfdiqa/100,10)
70067  kfs=mod(kfdiqa,10)
70068  popwt=parf(132)
70069  IF(kfa.EQ.3) popwt=parf(133)
70070  IF(kfb.EQ.3) popwt=parf(134)
70071  IF(kfs.EQ.1) popwt=popwt*sqrt(parj(4))
70072  ENDIF
70073  mstu(121)=int(popwt/(1d0+popwt)+pyr(0))
70074  RETURN
70075  ENDIF
70076 
70077 C..New version: Store popcorn- or rank 0 diquark parameters
70078  mstu(122)=170
70079  parf(193)=parj(8)
70080  parf(194)=parf(139)
70081  IF(kfdiq.NE.0) THEN
70082  mstu(122)=180
70083  parf(193)=parj(10)
70084  parf(194)=parf(140)
70085  ENDIF
70086  IF(parf(194).LT.1d-5.OR.parf(194).GT.1d0-1d-5) THEN
70087  IF(parf(194).GT.1d0-1d-5) CALL pyerrm(9,
70088  & '(PYNMES:) Neglecting too large popcorn possibility')
70089  RETURN
70090  ENDIF
70091 
70092 C..New version: Get number of popcorn mesons
70093  100 rtst=pyr(0)
70094  mstu(121)=-1
70095  110 mstu(121)=mstu(121)+1
70096  rtst=rtst/parf(194)
70097  IF(rtst.LT.1d0) goto 110
70098  IF(kfdiq.EQ.0.AND.pyr(0)*(2d0+parf(135)*parf(161)).GT.
70099  & (2d0+parf(135)*parf(161)*parf(138)**mstu(121))) goto 100
70100  RETURN
70101  END
70102 
70103 C***************************************************************
70104 
70105 C...PYKFIN
70106 C...Precalculates a set of diquark and popcorn weights.
70107 
70108  SUBROUTINE pykfin
70109 
70110 C...Double precision and integer declarations.
70111  IMPLICIT DOUBLE PRECISION(a-h, o-z)
70112  IMPLICIT INTEGER(i-n)
70113  INTEGER pyk,pychge,pycomp
70114 C...Commonblocks.
70115  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
70116  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
70117  SAVE /pydat1/,/pydat2/
70118 
70119  dimension su6(12),su6m(7),qbb(7),qbm(7),dmb(14)
70120 
70121 
70122  mstu(123)=1
70123 C..Diquark indices for dimensional variables
70124  iud1=1
70125  iuu1=2
70126  ius0=3
70127  isu0=4
70128  ius1=5
70129  isu1=6
70130  iss1=7
70131 
70132 C.. *** SU(6) factors **
70133 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
70134  parf(146)=1d0
70135  IF(mstj(12).GE.5) parf(146)=3d0*parj(18)/(2d0*parj(18)+1d0)
70136  IF(parj(18).LT.1d0-1d-5.AND.mstj(12).LT.5) CALL pyerrm(9,
70137  & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
70138  DO 100 i=1,6
70139  su6(i)=parf(60+i)
70140  su6(6+i)=su6(i)*4*parf(146)/(3*parf(146)+1)
70141  100 CONTINUE
70142  su6(8)=su6(2)*4/(3*parf(146)+1)
70143  su6(6)=su6(6)*(3+parf(146))/(3*parf(146)+1)
70144  DO 110 i=1,6
70145  su6(i)=su6(i)+parj(18)*parf(70+i)
70146  su6(6+i)=su6(6+i)+parj(18)*parf(70+i)
70147  110 CONTINUE
70148 
70149 C..SU(6)max q q' s,c,b
70150  su6mud =max(su6(1) , su6(8) )
70151  su6m(iud1)=max(su6(5) , su6(12))
70152  su6m(isu0)=max(su6(7) ,su6(2),su6mud )
70153  su6m(iuu1)=max(su6(3) ,su6(4),su6(10))
70154  su6m(isu1)=max(su6(11),su6(6),su6m(iud1))
70155  su6m(ius0)=su6m(isu0)
70156  su6m(iss1)=su6m(iuu1)
70157  su6m(ius1)=su6m(isu1)
70158 
70159 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
70160  parf(141)=su6mud
70161  parf(142)=su6m(iud1)
70162  parf(143)=su6m(isu0)
70163  parf(144)=su6m(isu1)
70164  parf(145)=su6m(iss1)
70165 
70166 C..diquark SU(6) survival =
70167 C..sum over quark (quark tunnel weight)*(SU(6)).
70168  pud0=(2d0*su6(1)+parj(2)*su6(8))
70169  dmb(isu0)=(su6(7)+su6(2)+parj(2)*su6(1))/pud0
70170  dmb(ius0)=dmb(isu0)
70171  dmb(iss1)=(2d0*su6(4)+parj(2)*su6(3))/pud0
70172  dmb(iuu1)=(su6(3)+su6(4)+parj(2)*su6(10))/pud0
70173  dmb(isu1)=(su6(11)+su6(6)+parj(2)*su6(5))/pud0
70174  dmb(ius1)=dmb(isu1)
70175  dmb(iud1)=(2d0*su6(5)+parj(2)*su6(12))/pud0
70176 
70177 C.. *** Tunneling factors for Diquark production***
70178 C.. T: half a curtain pair = sqrt(curtain pair factor)
70179  IF(mstj(12).GE.5) THEN
70180  pmud0=pymass(2101)
70181  pmud1=pymass(2103)-pmud0
70182  pmus0=pymass(3201)-pmud0
70183  pmus1=pymass(3203)-pmus0-pmud0
70184  pmss1=pymass(3303)-pmus0-pmud0
70185  qbb(isu0)=exp(-(parj(9)+parj(8))*pmus0-parj(9)*parf(191))
70186  qbb(ius0)=exp(-parj(8)*pmus0)
70187  qbb(iss1)=exp(-(parj(9)+parj(8))*pmss1)*qbb(isu0)
70188  qbb(iuu1)=exp(-parj(8)*pmud1)
70189  qbb(isu1)=exp(-(parj(9)+parj(8))*pmus1)*qbb(isu0)
70190  qbb(ius1)=exp(-parj(8)*pmus1)*qbb(ius0)
70191  qbb(iud1)=qbb(iuu1)
70192  ELSE
70193  par2m=sqrt(parj(2))
70194  par3m=sqrt(parj(3))
70195  par4m=sqrt(parj(4))
70196  qbb(isu0)=par2m*par3m
70197  qbb(ius0)=par3m
70198  qbb(iss1)=par2m*parj(3)*par4m
70199  qbb(iuu1)=par4m
70200  qbb(isu1)=par4m*qbb(isu0)
70201  qbb(ius1)=par4m*qbb(ius0)
70202  qbb(iud1)=par4m
70203  ENDIF
70204 
70205 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
70206  qbm(isu0)=qbb(isu0)
70207  qbm(ius0)=parj(2)*qbb(ius0)
70208  qbm(iss1)=parj(2)*6d0*qbb(iss1)
70209  qbm(iuu1)=6d0*qbb(iuu1)
70210  qbm(isu1)=3d0*qbb(isu1)
70211  qbm(ius1)=parj(2)*3d0*qbb(ius1)
70212  qbm(iud1)=3d0*qbb(iud1)
70213 
70214 C.. Combine T and tau to diquark weight for q-> B+B+..
70215  DO 120 i=1,7
70216  qbb(i)=qbb(i)*qbm(i)
70217  120 CONTINUE
70218 
70219  IF(mstj(12).GE.5)THEN
70220 C..New version: tau for rank 0 diquark.
70221  dmb(7+isu0)=exp(-parj(10)*pmus0)
70222  dmb(7+ius0)=parj(2)*dmb(7+isu0)
70223  dmb(7+iss1)=6d0*parj(2)*exp(-parj(10)*pmss1)*dmb(7+isu0)
70224  dmb(7+iuu1)=6d0*exp(-parj(10)*pmud1)
70225  dmb(7+isu1)=3d0*exp(-parj(10)*pmus1)*dmb(7+isu0)
70226  dmb(7+ius1)=parj(2)*dmb(7+isu1)
70227  dmb(7+iud1)=dmb(7+iuu1)/2d0
70228 
70229 C..New version: curtain flavour ratios.
70230 C.. s/u for q->B+M+...
70231 C.. s/u for rank 0 diquark: su -> ...M+B+...
70232 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
70233  wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
70234  parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
70235  wu=1d0+dmb(7+iud1)+dmb(7+ius0)+dmb(7+ius1)+dmb(7+iuu1)
70236  parf(136)=(2d0*(dmb(7+isu0)+dmb(7+isu1))+dmb(7+iss1))/wu
70237  parf(137)=(dmb(7+isu0)+dmb(7+isu1))*
70238  & (2d0+dmb(7+iss1)/(2d0*dmb(7+isu1)))/wu
70239  ELSE
70240 C..Old version: reset unused rank 0 diquark weights and
70241 C.. unused diquark SU(6) survival weights
70242  DO 130 i=1,7
70243  IF(mstj(12).LT.3) dmb(i)=1d0
70244  dmb(7+i)=1d0
70245  130 CONTINUE
70246 
70247 C..Old version: Shuffle PARJ(7) into tau
70248  qbm(ius0)=qbm(ius0)*parj(7)
70249  qbm(iss1)=qbm(iss1)*parj(7)
70250  qbm(ius1)=qbm(ius1)*parj(7)
70251 
70252 C..Old version: curtain flavour ratios.
70253 C.. s/u for q->B+M+...
70254 C.. s/u for rank 0 diquark: su -> ...M+B+...
70255 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
70256  wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
70257  parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
70258  parf(136)=parf(135)*parj(6)*qbm(isu0)/qbm(ius0)
70259  parf(137)=(1d0+qbm(iud1))*(2d0+qbm(ius0))/wu
70260  ENDIF
70261 
70262 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
70263 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
70264  DO 140 i=1,7
70265  dmb(7+i)=dmb(7+i)*dmb(i)
70266  dmb(i)=dmb(i)*qbm(i)
70267  qbm(i)=qbm(i)*su6m(i)/su6mud
70268  qbb(i)=qbb(i)*su6m(i)/su6mud
70269  140 CONTINUE
70270 
70271 C.. *** Popcorn factors ***
70272 
70273  IF(mstj(12).LT.5)THEN
70274 C.. Old version: Resulting popcorn weights.
70275  parf(138)=parj(6)
70276  ws=parf(135)*parf(138)
70277  wq=wu*parj(5)/3d0
70278  parf(132)=wq*qbm(iud1)/qbb(iud1)
70279  parf(133)=wq*
70280  & (qbm(ius1)/qbb(ius1)+ws*qbm(isu1)/qbb(isu1))/2d0
70281  parf(134)=wq*ws*qbm(iss1)/qbb(iss1)
70282  parf(131)=wq*(1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1)+
70283  & ws*(qbm(isu0)+qbm(isu1)+qbm(iss1)/2d0))/
70284  & (1d0+qbb(iud1)+qbb(iuu1)+
70285  & 2d0*(qbb(ius0)+qbb(ius1))+qbb(iss1)/2d0)
70286  ELSE
70287 C..New version: Store weights for popcorn mesons,
70288 C..get prel. popcorn weights.
70289  DO 150 ipos=201,1400
70290  parf(ipos)=0d0
70291  150 CONTINUE
70292  DO 160 i=138,140
70293  parf(i)=0d0
70294  160 CONTINUE
70295  ipos=200
70296  parf(193)=parj(8)
70297  DO 240 mr=0,7,7
70298  IF(mr.EQ.7) parf(193)=parj(10)
70299  sqwt=2d0*(dmb(mr+ius0)+dmb(mr+ius1))/
70300  & (1d0+dmb(mr+iud1)+dmb(mr+iuu1))
70301  qqwt=dmb(mr+iuu1)/(1d0+dmb(mr+iud1)+dmb(mr+iuu1))
70302  DO 230 nmes=0,1
70303  IF(nmes.EQ.1) sqwt=parj(2)
70304  DO 220 kfqpop=1,4
70305  IF(mr.EQ.0.AND.kfqpop.GT.3) goto 220
70306  IF(nmes.EQ.0.AND.kfqpop.GE.3)THEN
70307  sqwt=dmb(mr+iss1)/(dmb(mr+isu0)+dmb(mr+isu1))
70308  qqwt=0.5d0
70309  IF(mr.EQ.0) parf(193)=parj(8)+parj(9)
70310  IF(kfqpop.EQ.4) sqwt=sqwt*(1d0/dmb(7+isu1)+1d0)/2d0
70311  ENDIF
70312  DO 210 kfqold =1,5
70313  IF(mr.EQ.0.AND.kfqold.GT.3) goto 210
70314  IF(nmes.EQ.1) THEN
70315  IF(mr.EQ.0.AND.kfqpop.EQ.1) goto 210
70316  IF(mr.EQ.7.AND.kfqpop.NE.1) goto 210
70317  ENDIF
70318  wttot=0d0
70319  wtfail=0d0
70320  DO 190 kmul=0,5
70321  pjwt=parj(12+kmul)
70322  IF(kmul.EQ.0) pjwt=1d0-parj(14)
70323  IF(kmul.EQ.1) pjwt=1d0-parj(15)-parj(16)-parj(17)
70324  IF(pjwt.LE.0d0) goto 190
70325  IF(pjwt.GT.1d0) pjwt=1d0
70326  imes=5*kmul
70327  imix=2*kfqold+10*kmul
70328  kfj=2*kmul+1
70329  IF(kmul.EQ.2) kfj=10003
70330  IF(kmul.EQ.3) kfj=10001
70331  IF(kmul.EQ.4) kfj=20003
70332  IF(kmul.EQ.5) kfj=5
70333  DO 180 kfqver =1,3
70334  kfla=max(kfqold,kfqver)
70335  kflb=min(kfqold,kfqver)
70336  swt=parj(11+kfla/3+kfla/4)
70337  IF(kmul.EQ.0.OR.kmul.EQ.2) swt=1d0-swt
70338  swt=swt*pjwt
70339  qwt=sqwt/(2d0+sqwt)
70340  IF(kfqver.LT.3)THEN
70341  IF(kfqver.EQ.kfqpop) qwt=(1d0-qwt)*qqwt
70342  IF(kfqver.NE.kfqpop) qwt=(1d0-qwt)*(1d0-qqwt)
70343  ENDIF
70344  IF(kfqver.NE.kfqold)THEN
70345  imes=imes+1
70346  kfm=100*kfla+10*kflb+kfj
70347  pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
70348  parf(ipos+imes)=qwt*swt*exp(-parf(193)*pmm)
70349  wttot=wttot+parf(ipos+imes)
70350  ELSE
70351  DO 170 id=3,5
70352  IF(id.EQ.3) dwt=1d0-parf(imix-1)
70353  IF(id.EQ.4) dwt=parf(imix-1)-parf(imix)
70354  IF(id.EQ.5) dwt=parf(imix)
70355  kfm=110*(id-2)+kfj
70356  pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
70357  parf(ipos+5*kmul+id)=qwt*swt*dwt*exp(-parf(193)*pmm)
70358  IF(kmul.EQ.0.AND.id.GT.3) THEN
70359  wtfail=wtfail+qwt*swt*dwt*(1d0-parj(21+id))
70360  parf(ipos+5*kmul+id)=
70361  & parf(ipos+5*kmul+id)*parj(21+id)
70362  ENDIF
70363  wttot=wttot+parf(ipos+5*kmul+id)
70364  170 CONTINUE
70365  ENDIF
70366  180 CONTINUE
70367  190 CONTINUE
70368  DO 200 imes=1,30
70369  parf(ipos+imes)=parf(ipos+imes)/(1d0-wtfail)
70370  200 CONTINUE
70371  IF(mr.EQ.7) parf(140)=
70372  & max(parf(140),wttot/(1d0-wtfail))
70373  IF(mr.EQ.0) parf(139-kfqpop/3)=
70374  & max(parf(139-kfqpop/3),wttot/(1d0-wtfail))
70375  ipos=ipos+30
70376  210 CONTINUE
70377  220 CONTINUE
70378  230 CONTINUE
70379  240 CONTINUE
70380  IF(parf(139).GT.1d-10) parf(138)=parf(138)/parf(139)
70381  mstu(121)=0
70382 
70383  ENDIF
70384 
70385 C..Recombine diquark weights to flavour and spin ratios
70386  parf(151)=(2d0*(qbb(isu0)+qbb(isu1))+qbb(iss1))/
70387  & (1d0+qbb(iud1)+qbb(iuu1)+qbb(ius0)+qbb(ius1))
70388  parf(152)=2d0*(qbb(ius0)+qbb(ius1))/(1d0+qbb(iud1)+qbb(iuu1))
70389  parf(153)=qbb(iss1)/(qbb(isu0)+qbb(isu1))
70390  parf(154)=qbb(iuu1)/(1d0+qbb(iud1)+qbb(iuu1))
70391  parf(155)=qbb(isu1)/qbb(isu0)
70392  parf(156)=qbb(ius1)/qbb(ius0)
70393  parf(157)=qbb(iud1)
70394 
70395  parf(161)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/
70396  & (1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1))
70397  parf(162)=2d0*(qbm(ius0)+qbm(ius1))/(1d0+qbm(iud1)+qbm(iuu1))
70398  parf(163)=qbm(iss1)/(qbm(isu0)+qbm(isu1))
70399  parf(164)=qbm(iuu1)/(1d0+qbm(iud1)+qbm(iuu1))
70400  parf(165)=qbm(isu1)/qbm(isu0)
70401  parf(166)=qbm(ius1)/qbm(ius0)
70402  parf(167)=qbm(iud1)
70403 
70404  parf(171)=(2d0*(dmb(isu0)+dmb(isu1))+dmb(iss1))/
70405  & (1d0+dmb(iud1)+dmb(iuu1)+dmb(ius0)+dmb(ius1))
70406  parf(172)=2d0*(dmb(ius0)+dmb(ius1))/(1d0+dmb(iud1)+dmb(iuu1))
70407  parf(173)=dmb(iss1)/(dmb(isu0)+dmb(isu1))
70408  parf(174)=dmb(iuu1)/(1d0+dmb(iud1)+dmb(iuu1))
70409  parf(175)=dmb(isu1)/dmb(isu0)
70410  parf(176)=dmb(ius1)/dmb(ius0)
70411  parf(177)=dmb(iud1)
70412 
70413  parf(185)=dmb(7+isu1)/dmb(7+isu0)
70414  parf(186)=dmb(7+ius1)/dmb(7+ius0)
70415  parf(187)=dmb(7+iud1)
70416 
70417  RETURN
70418  END
70419 
70420 
70421 C*********************************************************************
70422 
70423 C...PYPTDI
70424 C...Generates transverse momentum according to a Gaussian.
70425 
70426  SUBROUTINE pyptdi(KFL,PX,PY)
70427 
70428 C...Double precision and integer declarations.
70429  IMPLICIT DOUBLE PRECISION(a-h, o-z)
70430  IMPLICIT INTEGER(i-n)
70431  INTEGER pyk,pychge,pycomp
70432 C...Commonblocks.
70433  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
70434  SAVE /pydat1/
70435 
70436 C...Generate p_T and azimuthal angle, gives p_x and p_y.
70437  kfla=iabs(kfl)
70438  pt=parj(21)*sqrt(-log(max(1d-10,pyr(0))))
70439  IF(parj(23).GT.pyr(0)) pt=parj(24)*pt
70440  IF(mstj(91).EQ.1) pt=parj(22)*pt
70441  IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0d0
70442  phi=paru(2)*pyr(0)
70443  px=pt*cos(phi)
70444  py=pt*sin(phi)
70445 
70446  RETURN
70447  END
70448 
70449 C*********************************************************************
70450 
70451 C...PYZDIS
70452 C...Generates the longitudinal splitting variable z.
70453 
70454  SUBROUTINE pyzdis(KFL1,KFL2,PR,Z)
70455 
70456 C...Double precision and integer declarations.
70457  IMPLICIT DOUBLE PRECISION(a-h, o-z)
70458  IMPLICIT INTEGER(i-n)
70459  INTEGER pyk,pychge,pycomp
70460 C...Commonblocks.
70461  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
70462  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
70463  SAVE /pydat1/,/pydat2/
70464 
70465 C...Check if heavy flavour fragmentation.
70466  kfla=iabs(kfl1)
70467  kflb=iabs(kfl2)
70468  kflh=kfla
70469  IF(kfla.GE.10) kflh=mod(kfla/1000,10)
70470 
70471 C...Lund symmetric scaling function: determine parameters of shape.
70472  IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
70473  &mstj(11).GE.4) THEN
70474  fa=parj(41)
70475  IF(mstj(91).EQ.1) fa=parj(43)
70476  IF(kflb.GE.10) fa=fa+parj(45)
70477  fbb=parj(42)
70478  IF(mstj(91).EQ.1) fbb=parj(44)
70479  fb=fbb*pr
70480  fc=1d0
70481  IF(kfla.GE.10) fc=fc-parj(45)
70482  IF(kflb.GE.10) fc=fc+parj(45)
70483  IF(mstj(11).GE.4.AND.(kflh.EQ.4.OR.kflh.EQ.5)) THEN
70484  fred=parj(46)
70485  IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
70486  fc=fc+fred*fbb*parf(100+kflh)**2
70487  ENDIF
70488  mc=1
70489  IF(abs(fc-1d0).GT.0.01d0) mc=2
70490 
70491 C...Determine position of maximum. Special cases for a = 0 or a = c.
70492  IF(fa.LT.0.02d0) THEN
70493  ma=1
70494  zmax=1d0
70495  IF(fc.GT.fb) zmax=fb/fc
70496  ELSEIF(abs(fc-fa).LT.0.01d0) THEN
70497  ma=2
70498  zmax=fb/(fb+fc)
70499  ELSE
70500  ma=3
70501  zmax=0.5d0*(fb+fc-sqrt((fb-fc)**2+4d0*fa*fb))/(fc-fa)
70502  IF(zmax.GT.0.9999d0.AND.fb.GT.100d0) zmax=min(zmax,1d0-fa/fb)
70503  ENDIF
70504 
70505 C...Subdivide z range if distribution very peaked near endpoint.
70506  mmax=2
70507  IF(zmax.LT.0.1d0) THEN
70508  mmax=1
70509  zdiv=2.75d0*zmax
70510  IF(mc.EQ.1) THEN
70511  fint=1d0-log(zdiv)
70512  ELSE
70513  zdivc=zdiv**(1d0-fc)
70514  fint=1d0+(1d0-1d0/zdivc)/(fc-1d0)
70515  ENDIF
70516  ELSEIF(zmax.GT.0.85d0.AND.fb.GT.1d0) THEN
70517  mmax=3
70518  fscb=sqrt(4d0+(fc/fb)**2)
70519  zdiv=fscb-1d0/zmax-(fc/fb)*log(zmax*0.5d0*(fscb+fc/fb))
70520  IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1d0-zmax)
70521  zdiv=min(zmax,max(0d0,zdiv))
70522  fint=1d0+fb*(1d0-zdiv)
70523  ENDIF
70524 
70525 C...Choice of z, preweighted for peaks at low or high z.
70526  100 z=pyr(0)
70527  fpre=1d0
70528  IF(mmax.EQ.1) THEN
70529  IF(fint*pyr(0).LE.1d0) THEN
70530  z=zdiv*z
70531  ELSEIF(mc.EQ.1) THEN
70532  z=zdiv**z
70533  fpre=zdiv/z
70534  ELSE
70535  z=(zdivc+z*(1d0-zdivc))**(1d0/(1d0-fc))
70536  fpre=(zdiv/z)**fc
70537  ENDIF
70538  ELSEIF(mmax.EQ.3) THEN
70539  IF(fint*pyr(0).LE.1d0) THEN
70540  z=zdiv+log(z)/fb
70541  fpre=exp(fb*(z-zdiv))
70542  ELSE
70543  z=zdiv+z*(1d0-zdiv)
70544  ENDIF
70545  ENDIF
70546 
70547 C...Weighting according to correct formula.
70548  IF(z.LE.0d0.OR.z.GE.1d0) goto 100
70549  fexp=fc*log(zmax/z)+fb*(1d0/zmax-1d0/z)
70550  IF(ma.GE.2) fexp=fexp+fa*log((1d0-z)/(1d0-zmax))
70551  fval=exp(max(-50d0,min(50d0,fexp)))
70552  IF(fval.LT.pyr(0)*fpre) goto 100
70553 
70554 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
70555  ELSE
70556  fc=parj(50+max(1,kflh))
70557  IF(mstj(91).EQ.1) fc=parj(59)
70558  110 z=pyr(0)
70559  IF(fc.GE.0d0.AND.fc.LE.1d0) THEN
70560  IF(fc.GT.pyr(0)) z=1d0-z**(1d0/3d0)
70561  ELSEIF(fc.GT.-1.AND.fc.LT.0d0) THEN
70562  IF(-4d0*fc*z*(1d0-z)**2.LT.pyr(0)*((1d0-z)**2-fc*z)**2)
70563  & goto 110
70564  ELSE
70565  IF(fc.GT.0d0) z=1d0-z**(1d0/fc)
70566  IF(fc.LT.0d0) z=z**(-1d0/fc)
70567  ENDIF
70568  ENDIF
70569 
70570  RETURN
70571  END
70572 
70573 C*********************************************************************
70574 
70575 C...PYSHOW
70576 C...Generates timelike parton showers from given partons.
70577 
70578  SUBROUTINE pyshow(IP1,IP2,QMAX)
70579 
70580 C...Double precision and integer declarations.
70581  IMPLICIT DOUBLE PRECISION(a-h, o-z)
70582  IMPLICIT INTEGER(i-n)
70583  INTEGER pyk,pychge,pycomp
70584 C...Parameter statement to help give large particle numbers.
70585  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
70586  &kexcit=4000000,kdimen=5000000)
70587  parameter(maxnur=1000)
70588 C...Commonblocks.
70589  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
70590  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
70591  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
70592  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
70593  common/pypars/mstp(200),parp(200),msti(200),pari(200)
70594  common/pyint1/mint(400),vint(400)
70595  SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
70596 C...Local arrays.
70597  dimension pmth(5,140),ps(5),pma(100),pmsd(100),iep(100),ipa(100),
70598  &kfla(100),kfld(100),kfl(100),itry(100),isi(100),isl(100),dp(100),
70599  &dpt(5,4),ksh(0:140),kcii(2),niis(2),iiis(2,2),theiis(2,2),
70600  &phiiis(2,2),isii(2),isset(2),iscol(0:140),ischg(0:140),
70601  &iref(1000)
70602 
70603 C...Check that QMAX not too low.
70604  IF(mstj(41).LE.0) THEN
70605  RETURN
70606  ELSEIF(mstj(41).EQ.1.OR.mstj(41).EQ.11) THEN
70607  IF(qmax.LE.parj(82).AND.ip2.GE.-80) RETURN
70608  ELSE
70609  IF(qmax.LE.min(parj(82),parj(83),parj(90)).AND.ip2.GE.-80)
70610  & RETURN
70611  ENDIF
70612 
70613 C...Store positions of shower initiating partons.
70614  mpspd=0
70615  IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
70616  npa=1
70617  ipa(1)=ip1
70618  ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
70619  & mstu(32))) THEN
70620  npa=2
70621  ipa(1)=ip1
70622  ipa(2)=ip2
70623  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0
70624  & .AND.ip2.GE.-80) THEN
70625  npa=iabs(ip2)
70626  DO 100 i=1,npa
70627  ipa(i)=ip1+i-1
70628  100 CONTINUE
70629  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.
70630  &ip2.EQ.-100) THEN
70631  mpspd=1
70632  npa=2
70633  ipa(1)=ip1+6
70634  ipa(2)=ip1+7
70635  ELSE
70636  CALL pyerrm(12,
70637  & '(PYSHOW:) failed to reconstruct showering system')
70638  IF(mstu(21).GE.1) RETURN
70639  ENDIF
70640 
70641 C...Send off to PYPTFS for pT-ordered evolution if requested,
70642 C...if at least 2 partons, and without predefined shower branchings.
70643  IF((mstj(41).EQ.11.OR.mstj(41).EQ.12).AND.npa.GE.2.AND.
70644  &mpspd.EQ.0) THEN
70645  npart=npa
70646  DO 110 ii=1,npart
70647  ipart(ii)=ipa(ii)
70648  ptpart(ii)=0.5d0*qmax
70649  110 CONTINUE
70650  CALL pyptfs(2,0.5d0*qmax,0d0,ptgen)
70651  RETURN
70652  ENDIF
70653 
70654 C...Initialization of cutoff masses etc.
70655  DO 120 ifl=0,40
70656  iscol(ifl)=0
70657  ischg(ifl)=0
70658  ksh(ifl)=0
70659  120 CONTINUE
70660  iscol(21)=1
70661  ksh(21)=1
70662  pmth(1,21)=pymass(21)
70663  pmth(2,21)=sqrt(pmth(1,21)**2+0.25d0*parj(82)**2)
70664  pmth(3,21)=2d0*pmth(2,21)
70665  pmth(4,21)=pmth(3,21)
70666  pmth(5,21)=pmth(3,21)
70667  pmth(1,22)=pymass(22)
70668  pmth(2,22)=sqrt(pmth(1,22)**2+0.25d0*parj(83)**2)
70669  pmth(3,22)=2d0*pmth(2,22)
70670  pmth(4,22)=pmth(3,22)
70671  pmth(5,22)=pmth(3,22)
70672  pmqth1=parj(82)
70673  IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
70674  pmqt1e=min(pmqth1,parj(90))
70675  pmqth2=pmth(2,21)
70676  IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
70677  pmqt2e=min(pmqth2,0.5d0*parj(90))
70678  DO 130 ifl=1,5
70679  iscol(ifl)=1
70680  IF(mstj(41).GE.2) ischg(ifl)=1
70681  ksh(ifl)=1
70682  pmth(1,ifl)=pymass(ifl)
70683  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*pmqth1**2)
70684  pmth(3,ifl)=pmth(2,ifl)+pmqth2
70685  pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(82)**2)+pmth(2,21)
70686  pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)+pmth(2,22)
70687  130 CONTINUE
70688  DO 140 ifl=11,15,2
70689  IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ischg(ifl)=1
70690  IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ksh(ifl)=1
70691  pmth(1,ifl)=pymass(ifl)
70692  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(90)**2)
70693  pmth(3,ifl)=pmth(2,ifl)+0.5d0*parj(90)
70694  pmth(4,ifl)=pmth(3,ifl)
70695  pmth(5,ifl)=pmth(3,ifl)
70696  140 CONTINUE
70697  pt2min=max(0.5d0*parj(82),1.1d0*parj(81))**2
70698  alams=parj(81)**2
70699  alfm=log(pt2min/alams)
70700 
70701 C...Check on phase space available for emission.
70702  irej=0
70703  DO 150 j=1,5
70704  ps(j)=0d0
70705  150 CONTINUE
70706  pm=0d0
70707  kfla(2)=0
70708  DO 170 i=1,npa
70709  kfla(i)=iabs(k(ipa(i),2))
70710  pma(i)=p(ipa(i),5)
70711 C...Special cutoff masses for initial partons (may be a heavy quark,
70712 C...squark, ..., and need not be on the mass shell).
70713  ir=30+i
70714  IF(npa.LE.1) iref(i)=ir
70715  IF(npa.GE.2) iref(i+1)=ir
70716  iscol(ir)=0
70717  ischg(ir)=0
70718  ksh(ir)=0
70719  IF(kfla(i).LE.8) THEN
70720  iscol(ir)=1
70721  IF(mstj(41).GE.2) ischg(ir)=1
70722  ELSEIF(kfla(i).EQ.11.OR.kfla(i).EQ.13.OR.kfla(i).EQ.15.OR.
70723  & kfla(i).EQ.17) THEN
70724  IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ischg(ir)=1
70725  ELSEIF(kfla(i).EQ.21) THEN
70726  iscol(ir)=1
70727  ELSEIF((kfla(i).GE.ksusy1+1.AND.kfla(i).LE.ksusy1+8).OR.
70728  & (kfla(i).GE.ksusy2+1.AND.kfla(i).LE.ksusy2+8)) THEN
70729  iscol(ir)=1
70730  ELSEIF(kfla(i).EQ.ksusy1+21) THEN
70731  iscol(ir)=1
70732 C...QUARKONIA+++
70733 C...same for QQ~[3S18]
70734  ELSEIF(mstp(148).GE.1.AND.(kfla(i).EQ.9900443.OR.
70735  & kfla(i).EQ.9900553)) THEN
70736  iscol(ir)=1
70737 C...QUARKONIA---
70738  ENDIF
70739 
70740 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
70741 C...(only intended for studying the effects of switching such rad on/off)
70742  IF (mstj(39).GT.0.AND.kfla(i).EQ.mstj(39)) THEN
70743  iscol(ir)=0
70744  ischg(ir)=0
70745  ENDIF
70746 
70747  IF(iscol(ir).EQ.1.OR.ischg(ir).EQ.1) ksh(ir)=1
70748  pmth(1,ir)=pma(i)
70749  IF(iscol(ir).EQ.1.AND.ischg(ir).EQ.1) THEN
70750  pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*pmqth1**2)
70751  pmth(3,ir)=pmth(2,ir)+pmqth2
70752  pmth(4,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(82)**2)+pmth(2,21)
70753  pmth(5,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(83)**2)+pmth(2,22)
70754  ELSEIF(iscol(ir).EQ.1) THEN
70755  pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(82)**2)
70756  pmth(3,ir)=pmth(2,ir)+0.5d0*parj(82)
70757  pmth(4,ir)=pmth(3,ir)
70758  pmth(5,ir)=pmth(3,ir)
70759  ELSEIF(ischg(ir).EQ.1) THEN
70760  pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(90)**2)
70761  pmth(3,ir)=pmth(2,ir)+0.5d0*parj(90)
70762  pmth(4,ir)=pmth(3,ir)
70763  pmth(5,ir)=pmth(3,ir)
70764  ENDIF
70765  IF(ksh(ir).EQ.1) pma(i)=pmth(3,ir)
70766  pm=pm+pma(i)
70767  IF(ksh(ir).EQ.0.OR.pma(i).GT.10d0*qmax) irej=irej+1
70768  DO 160 j=1,4
70769  ps(j)=ps(j)+p(ipa(i),j)
70770  160 CONTINUE
70771  170 CONTINUE
70772  IF(irej.EQ.npa.AND.ip2.GE.-7) RETURN
70773  ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
70774  IF(npa.EQ.1) ps(5)=ps(4)
70775  IF(ps(5).LE.pm+pmqt1e) RETURN
70776 
70777 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70778  kfsrce=0
70779  IF(ip2.LE.0) THEN
70780  ELSEIF(k(ip1,3).EQ.k(ip2,3).AND.k(ip1,3).GT.0) THEN
70781  kfsrce=iabs(k(k(ip1,3),2))
70782  ELSE
70783  ipar1=max(1,k(ip1,3))
70784  ipar2=max(1,k(ip2,3))
70785  IF(k(ipar1,3).EQ.k(ipar2,3).AND.k(ipar1,3).GT.0)
70786  & kfsrce=iabs(k(k(ipar1,3),2))
70787  ENDIF
70788  itypes=0
70789  IF(kfsrce.GE.1.AND.kfsrce.LE.8) itypes=1
70790  IF(kfsrce.GE.ksusy1+1.AND.kfsrce.LE.ksusy1+8) itypes=2
70791  IF(kfsrce.GE.ksusy2+1.AND.kfsrce.LE.ksusy2+8) itypes=2
70792  IF(kfsrce.GE.21.AND.kfsrce.LE.24) itypes=3
70793  IF(kfsrce.GE.32.AND.kfsrce.LE.34) itypes=3
70794  IF(kfsrce.EQ.25.OR.(kfsrce.GE.35.AND.kfsrce.LE.37)) itypes=4
70795  IF(kfsrce.GE.ksusy1+22.AND.kfsrce.LE.ksusy1+37) itypes=5
70796  IF(kfsrce.EQ.ksusy1+21) itypes=6
70797 
70798 C...Identify two primary showerers.
70799  itype1=0
70800  IF(kfla(1).GE.1.AND.kfla(1).LE.8) itype1=1
70801  IF(kfla(1).GE.ksusy1+1.AND.kfla(1).LE.ksusy1+8) itype1=2
70802  IF(kfla(1).GE.ksusy2+1.AND.kfla(1).LE.ksusy2+8) itype1=2
70803  IF(kfla(1).GE.21.AND.kfla(1).LE.24) itype1=3
70804  IF(kfla(1).GE.32.AND.kfla(1).LE.34) itype1=3
70805  IF(kfla(1).EQ.25.OR.(kfla(1).GE.35.AND.kfla(1).LE.37)) itype1=4
70806  IF(kfla(1).GE.ksusy1+22.AND.kfla(1).LE.ksusy1+37) itype1=5
70807  IF(kfla(1).EQ.ksusy1+21) itype1=6
70808  itype2=0
70809  IF(kfla(2).GE.1.AND.kfla(2).LE.8) itype2=1
70810  IF(kfla(2).GE.ksusy1+1.AND.kfla(2).LE.ksusy1+8) itype2=2
70811  IF(kfla(2).GE.ksusy2+1.AND.kfla(2).LE.ksusy2+8) itype2=2
70812  IF(kfla(2).GE.21.AND.kfla(2).LE.24) itype2=3
70813  IF(kfla(2).GE.32.AND.kfla(2).LE.34) itype2=3
70814  IF(kfla(2).EQ.25.OR.(kfla(2).GE.35.AND.kfla(2).LE.37)) itype2=4
70815  IF(kfla(2).GE.ksusy1+22.AND.kfla(2).LE.ksusy1+37) itype2=5
70816  IF(kfla(2).EQ.ksusy1+21) itype2=6
70817 
70818 C...Order of showerers. Presence of gluino.
70819  itypmn=min(itype1,itype2)
70820  itypmx=max(itype1,itype2)
70821  iord=1
70822  IF(itype1.GT.itype2) iord=2
70823  iglui=0
70824  IF(itype1.EQ.6.OR.itype2.EQ.6) iglui=1
70825 
70826 C...Check if 3-jet matrix elements to be used.
70827  m3jc=0
70828  alpha=0.5d0
70829  IF(npa.EQ.2.AND.mstj(47).GE.1.AND.mpspd.EQ.0) THEN
70830  IF(mstj(38).NE.0) THEN
70831  m3jc=mstj(38)
70832  alpha=parj(80)
70833  mstj(38)=0
70834  ELSEIF(mstj(47).GE.6) THEN
70835  m3jc=mstj(47)
70836  ELSE
70837  iclass=1
70838  icombi=4
70839 
70840 C...Vector/axial vector -> q + qbar; q -> q + V.
70841  IF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.(itypes.EQ.0.OR.
70842  & itypes.EQ.3)) THEN
70843  iclass=2
70844  IF(kfsrce.EQ.21.OR.kfsrce.EQ.22) THEN
70845  icombi=1
70846  ELSEIF(kfsrce.EQ.23.OR.(kfsrce.EQ.0.AND.
70847  & k(ipa(1),2)+k(ipa(2),2).EQ.0)) THEN
70848 C...gamma*/Z0: assume e+e- initial state if unknown.
70849  ei=-1d0
70850  IF(kfsrce.EQ.23) THEN
70851  iannfl=k(k(ip1,3),3)
70852  IF(iannfl.NE.0) THEN
70853  kannfl=iabs(k(iannfl,2))
70854  IF(kannfl.GE.1.AND.kannfl.LE.18) ei=kchg(kannfl,1)/3d0
70855  ENDIF
70856  ENDIF
70857  ai=sign(1d0,ei+0.1d0)
70858  vi=ai-4d0*ei*paru(102)
70859  ef=kchg(kfla(1),1)/3d0
70860  af=sign(1d0,ef+0.1d0)
70861  vf=af-4d0*ef*paru(102)
70862  xwc=1d0/(16d0*paru(102)*(1d0-paru(102)))
70863  sh=ps(5)**2
70864  sqmz=pmas(23,1)**2
70865  sqwz=ps(5)*pmas(23,2)
70866  sbwz=1d0/((sh-sqmz)**2+sqwz**2)
70867  vect=ei**2*ef**2+2d0*ei*vi*ef*vf*xwc*sh*(sh-sqmz)*sbwz+
70868  & (vi**2+ai**2)*vf**2*xwc**2*sh**2*sbwz
70869  axiv=(vi**2+ai**2)*af**2*xwc**2*sh**2*sbwz
70870  icombi=3
70871  alpha=vect/(vect+axiv)
70872  ELSEIF(kfsrce.EQ.24.OR.kfsrce.EQ.0) THEN
70873  icombi=4
70874  ENDIF
70875 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70876  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.5) THEN
70877  iclass=2
70878  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
70879  & itypes.EQ.1)) THEN
70880  iclass=3
70881 
70882 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70883  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.4) THEN
70884  iclass=4
70885  IF(kfsrce.EQ.25.OR.kfsrce.EQ.35.OR.kfsrce.EQ.37) THEN
70886  icombi=1
70887  ELSEIF(kfsrce.EQ.36) THEN
70888  icombi=2
70889  ENDIF
70890  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
70891  & itypes.EQ.1)) THEN
70892  iclass=5
70893 
70894 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70895  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
70896  & itypes.EQ.3)) THEN
70897  iclass=6
70898  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
70899  & itypes.EQ.2)) THEN
70900  iclass=7
70901  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.itypes.EQ.4) THEN
70902  iclass=8
70903  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
70904  & itypes.EQ.2)) THEN
70905  iclass=9
70906 
70907 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70908  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
70909  & itypes.EQ.5)) THEN
70910  iclass=10
70911  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
70912  & itypes.EQ.2)) THEN
70913  iclass=11
70914  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
70915  & itypes.EQ.1)) THEN
70916  iclass=12
70917 
70918 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70919  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.itypes.EQ.6) THEN
70920  iclass=13
70921  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
70922  & itypes.EQ.2)) THEN
70923  iclass=14
70924  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
70925  & itypes.EQ.1)) THEN
70926  iclass=15
70927 
70928 C...g -> ~g + ~g (eikonal approximation).
70929  ELSEIF(itypmn.EQ.6.AND.itypmx.EQ.6.AND.itypes.EQ.0) THEN
70930  iclass=16
70931  ENDIF
70932 
70933 C...Revert to eikonal approximation for gluon in final state.
70934  IF(kfla1.EQ.21.OR.kfla2.EQ.21) iclass=1
70935 
70936  m3jc=5*iclass+icombi
70937  ENDIF
70938  ENDIF
70939 
70940 C...Find if interference with initial state partons.
70941  miis=0
70942  IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2.AND.kfsrce.EQ.0
70943  &.AND.mpspd.EQ.0) miis=mstj(50)
70944  IF(mstj(50).GE.4.AND.mstj(50).LE.6.AND.npa.EQ.2.AND.mpspd.EQ.0)
70945  &miis=mstj(50)-3
70946  IF(miis.NE.0) THEN
70947  DO 190 i=1,2
70948  kcii(i)=0
70949  kca=pycomp(kfla(i))
70950  IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
70951  niis(i)=0
70952  IF(kcii(i).NE.0) THEN
70953  DO 180 j=1,2
70954  icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
70955  IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
70956  & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
70957  niis(i)=niis(i)+1
70958  iiis(i,niis(i))=icsi
70959  ENDIF
70960  180 CONTINUE
70961  ENDIF
70962  190 CONTINUE
70963  IF(niis(1)+niis(2).EQ.0) miis=0
70964  ENDIF
70965 
70966 C...Boost interfering initial partons to rest frame
70967 C...and reconstruct their polar and azimuthal angles.
70968  IF(miis.NE.0) THEN
70969  DO 210 i=1,2
70970  DO 200 j=1,5
70971  k(n+i,j)=k(ipa(i),j)
70972  p(n+i,j)=p(ipa(i),j)
70973  v(n+i,j)=0d0
70974  200 CONTINUE
70975  210 CONTINUE
70976  DO 230 i=3,2+niis(1)
70977  DO 220 j=1,5
70978  k(n+i,j)=k(iiis(1,i-2),j)
70979  p(n+i,j)=p(iiis(1,i-2),j)
70980  v(n+i,j)=0d0
70981  220 CONTINUE
70982  230 CONTINUE
70983  DO 250 i=3+niis(1),2+niis(1)+niis(2)
70984  DO 240 j=1,5
70985  k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
70986  p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
70987  v(n+i,j)=0d0
70988  240 CONTINUE
70989  250 CONTINUE
70990  CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,0d0,-ps(1)/ps(4),
70991  & -ps(2)/ps(4),-ps(3)/ps(4))
70992  phi=pyangl(p(n+1,1),p(n+1,2))
70993  CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,-phi,0d0,0d0,0d0)
70994  the=pyangl(p(n+1,3),p(n+1,1))
70995  CALL pyrobo(n+1,n+2+niis(1)+niis(2),-the,0d0,0d0,0d0,0d0)
70996  DO 260 i=3,2+niis(1)
70997  theiis(1,i-2)=pyangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
70998  phiiis(1,i-2)=pyangl(p(n+i,1),p(n+i,2))
70999  260 CONTINUE
71000  DO 270 i=3+niis(1),2+niis(1)+niis(2)
71001  theiis(2,i-2-niis(1))=paru(1)-pyangl(p(n+i,3),
71002  & sqrt(p(n+i,1)**2+p(n+i,2)**2))
71003  phiiis(2,i-2-niis(1))=pyangl(p(n+i,1),p(n+i,2))
71004  270 CONTINUE
71005  ENDIF
71006 
71007 C...Boost 3 or more partons to their rest frame.
71008  IF(npa.GE.3) CALL pyrobo(ipa(1),ipa(npa),0d0,0d0,-ps(1)/ps(4),
71009  &-ps(2)/ps(4),-ps(3)/ps(4))
71010 
71011 C...Define imagined single initiator of shower for parton system.
71012  ns=n
71013  IF(n.GT.mstu(4)-mstu(32)-10) THEN
71014  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
71015  IF(mstu(21).GE.1) RETURN
71016  ENDIF
71017  280 n=ns
71018  IF(npa.GE.2) THEN
71019  k(n+1,1)=11
71020  k(n+1,2)=21
71021  k(n+1,3)=0
71022  k(n+1,4)=0
71023  k(n+1,5)=0
71024  p(n+1,1)=0d0
71025  p(n+1,2)=0d0
71026  p(n+1,3)=0d0
71027  p(n+1,4)=ps(5)
71028  p(n+1,5)=ps(5)
71029  v(n+1,5)=ps(5)**2
71030  n=n+1
71031  iref(1)=21
71032  ENDIF
71033 
71034 C...Loop over partons that may branch.
71035  nep=npa
71036  im=ns
71037  IF(npa.EQ.1) im=ns-1
71038  290 im=im+1
71039  IF(n.GT.ns) THEN
71040  IF(im.GT.n) goto 600
71041  kflm=iabs(k(im,2))
71042  ir=iref(im-ns)
71043  IF(ksh(ir).EQ.0) goto 290
71044  IF(p(im,5).LT.pmth(2,ir)) goto 290
71045  igm=k(im,3)
71046  ELSE
71047  igm=-1
71048  ENDIF
71049  IF(n+nep.GT.mstu(4)-mstu(32)-10) THEN
71050  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
71051  IF(mstu(21).GE.1) RETURN
71052  ENDIF
71053 
71054 C...Position of aunt (sister to branching parton).
71055 C...Origin and flavour of daughters.
71056  iau=0
71057  IF(igm.GT.0) THEN
71058  IF(k(im-1,3).EQ.igm) iau=im-1
71059  IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
71060  ENDIF
71061  IF(igm.GE.0) THEN
71062  k(im,4)=n+1
71063  DO 300 i=1,nep
71064  k(n+i,3)=im
71065  300 CONTINUE
71066  ELSE
71067  k(n+1,3)=ipa(1)
71068  ENDIF
71069  IF(igm.LE.0) THEN
71070  DO 310 i=1,nep
71071  k(n+i,2)=k(ipa(i),2)
71072  310 CONTINUE
71073  ELSEIF(kflm.NE.21) THEN
71074  k(n+1,2)=k(im,2)
71075  k(n+2,2)=k(im,5)
71076  iref(n+1-ns)=iref(im-ns)
71077  iref(n+2-ns)=iabs(k(n+2,2))
71078  ELSEIF(k(im,5).EQ.21) THEN
71079  k(n+1,2)=21
71080  k(n+2,2)=21
71081  iref(n+1-ns)=21
71082  iref(n+2-ns)=21
71083  ELSE
71084  k(n+1,2)=k(im,5)
71085  k(n+2,2)=-k(im,5)
71086  iref(n+1-ns)=iabs(k(n+1,2))
71087  iref(n+2-ns)=iabs(k(n+2,2))
71088  ENDIF
71089 
71090 C...Reset flags on daughters and tries made.
71091  DO 320 ip=1,nep
71092  k(n+ip,1)=3
71093  k(n+ip,4)=0
71094  k(n+ip,5)=0
71095  kfld(ip)=iabs(k(n+ip,2))
71096  IF(kchg(pycomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
71097  itry(ip)=0
71098  isl(ip)=0
71099  isi(ip)=0
71100  IF(ksh(iref(n+ip-ns)).EQ.1) isi(ip)=1
71101  320 CONTINUE
71102  islm=0
71103 
71104 C...Maximum virtuality of daughters.
71105  IF(igm.LE.0) THEN
71106  DO 330 i=1,npa
71107  IF(npa.GE.3) p(n+i,4)=p(ipa(i),4)
71108  p(n+i,5)=min(qmax,ps(5))
71109  ir=iref(n+i-ns)
71110  IF(ip2.LE.-8) p(n+i,5)=max(p(n+i,5),2d0*pmth(3,ir))
71111  IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
71112  330 CONTINUE
71113  ELSE
71114  IF(mstj(43).LE.2) pem=v(im,2)
71115  IF(mstj(43).GE.3) pem=p(im,4)
71116  p(n+1,5)=min(p(im,5),v(im,1)*pem)
71117  p(n+2,5)=min(p(im,5),(1d0-v(im,1))*pem)
71118  IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
71119  ENDIF
71120  DO 340 i=1,nep
71121  pmsd(i)=p(n+i,5)
71122  IF(isi(i).EQ.1) THEN
71123  ir=iref(n+i-ns)
71124  IF(p(n+i,5).LE.pmth(3,ir)) p(n+i,5)=pmth(1,ir)
71125  ENDIF
71126  v(n+i,5)=p(n+i,5)**2
71127  340 CONTINUE
71128 
71129 C...Choose one of the daughters for evolution.
71130  350 inum=0
71131  IF(nep.EQ.1) inum=1
71132  DO 360 i=1,nep
71133  IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
71134  360 CONTINUE
71135  DO 370 i=1,nep
71136  IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
71137  ir=iref(n+i-ns)
71138  IF(p(n+i,5).GE.pmth(2,ir)) inum=i
71139  ENDIF
71140  370 CONTINUE
71141  IF(inum.EQ.0) THEN
71142  rmax=0d0
71143  DO 380 i=1,nep
71144  IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqt2e) THEN
71145  rpm=p(n+i,5)/pmsd(i)
71146  ir=iref(n+i-ns)
71147  IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ir)) THEN
71148  rmax=rpm
71149  inum=i
71150  ENDIF
71151  ENDIF
71152  380 CONTINUE
71153  ENDIF
71154 
71155 C...Cancel choice of predetermined daughter already treated.
71156  inum=max(1,inum)
71157  inumt=inum
71158  IF(mpspd.EQ.1.AND.igm.EQ.0.AND.itry(inumt).GE.1) THEN
71159  IF(k(ip1-1+inum,4).GT.0) inum=3-inum
71160  ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2.AND.itry(inumt).GE.1) THEN
71161  IF(kfld(inumt).NE.21.AND.k(ip1+2,4).GT.0) inum=3-inum
71162  IF(kfld(inumt).EQ.21.AND.k(ip1+3,4).GT.0) inum=3-inum
71163  ENDIF
71164 
71165 C...Store information on choice of evolving daughter.
71166  iep(1)=n+inum
71167  DO 390 i=2,nep
71168  iep(i)=iep(i-1)+1
71169  IF(iep(i).GT.n+nep) iep(i)=n+1
71170  390 CONTINUE
71171  DO 400 i=1,nep
71172  kfl(i)=iabs(k(iep(i),2))
71173  400 CONTINUE
71174  itry(inum)=itry(inum)+1
71175  IF(itry(inum).GT.200) THEN
71176  CALL pyerrm(14,'(PYSHOW:) caught in infinite loop')
71177  IF(mstu(21).GE.1) RETURN
71178  ENDIF
71179  z=0.5d0
71180  ir=iref(iep(1)-ns)
71181  IF(ksh(ir).EQ.0) goto 450
71182  IF(p(iep(1),5).LT.pmth(2,ir)) goto 450
71183 
71184 C...Check if evolution already predetermined for daughter.
71185  ipspd=0
71186  IF(mpspd.EQ.1.AND.igm.EQ.0) THEN
71187  IF(k(ip1-1+inum,4).GT.0) ipspd=ip1-1+inum
71188  ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2) THEN
71189  IF(kfl(1).NE.21.AND.k(ip1+2,4).GT.0) ipspd=ip1+2
71190  IF(kfl(1).EQ.21.AND.k(ip1+3,4).GT.0) ipspd=ip1+3
71191  ENDIF
71192  IF(inum.EQ.1.OR.inum.EQ.2) THEN
71193  isset(inum)=0
71194  IF(ipspd.NE.0) isset(inum)=1
71195  ENDIF
71196 
71197 C...Select side for interference with initial state partons.
71198  IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
71199  iii=iep(1)-ns-1
71200  isii(iii)=0
71201  IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
71202  isii(iii)=1
71203  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
71204  IF(pyr(0).GT.0.5d0) isii(iii)=1
71205  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
71206  isii(iii)=1
71207  IF(pyr(0).GT.0.5d0) isii(iii)=2
71208  ENDIF
71209  ENDIF
71210 
71211 C...Calculate allowed z range.
71212  IF(nep.EQ.1) THEN
71213  pmed=ps(4)
71214  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
71215  pmed=p(im,5)
71216  ELSE
71217  IF(inum.EQ.1) pmed=v(im,1)*pem
71218  IF(inum.EQ.2) pmed=(1d0-v(im,1))*pem
71219  ENDIF
71220  IF(mod(mstj(43),2).EQ.1) THEN
71221  zc=pmth(2,21)/pmed
71222  zce=pmth(2,22)/pmed
71223  IF(iscol(ir).EQ.0) zce=0.5d0*parj(90)/pmed
71224  ELSE
71225  zc=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,21)/pmed)**2)))
71226  IF(zc.LT.1d-6) zc=(pmth(2,21)/pmed)**2
71227  pmtmpe=pmth(2,22)
71228  IF(iscol(ir).EQ.0) pmtmpe=0.5d0*parj(90)
71229  zce=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmtmpe/pmed)**2)))
71230  IF(zce.LT.1d-6) zce=(pmtmpe/pmed)**2
71231  ENDIF
71232  zc=min(zc,0.491d0)
71233  zce=min(zce,0.49991d0)
71234  IF(((mstj(41).EQ.1.AND.zc.GT.0.49d0).OR.(mstj(41).GE.2.AND.
71235  &min(zc,zce).GT.0.4999d0)).AND.ipspd.EQ.0) THEN
71236  p(iep(1),5)=pmth(1,ir)
71237  v(iep(1),5)=p(iep(1),5)**2
71238  goto 450
71239  ENDIF
71240 
71241 C...Integral of Altarelli-Parisi z kernel for QCD.
71242 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
71243  IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
71244  fbr=6d0*log((1d0-zc)/zc)+mstj(45)*0.5d0
71245 C...QUARKONIA+++
71246 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
71247  ELSEIF(mstj(49).EQ.0.AND.mstp(149).GE.0.AND.
71248  & (kfl(1).EQ.9900443.OR.kfl(1).EQ.9900553)) THEN
71249  fbr=6d0*log((1d0-zc)/zc)
71250 C...QUARKONIA---
71251  ELSEIF(mstj(49).EQ.0) THEN
71252  fbr=(8d0/3d0)*log((1d0-zc)/zc)
71253  IF(iglui.EQ.1.AND.ir.GE.31) fbr=fbr*(9d0/4d0)
71254 
71255 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
71256  ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
71257  fbr=(parj(87)+mstj(45)*parj(88))*(1d0-2d0*zc)
71258  ELSEIF(mstj(49).EQ.1) THEN
71259  fbr=(1d0-2d0*zc)/3d0
71260  IF(igm.EQ.0.AND.m3jc.GE.1) fbr=4d0*fbr
71261 
71262 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
71263  ELSEIF(kfl(1).EQ.21) THEN
71264  fbr=6d0*mstj(45)*(0.5d0-zc)
71265  ELSE
71266  fbr=2d0*log((1d0-zc)/zc)
71267  ENDIF
71268 
71269 C...Reset QCD probability for colourless.
71270  IF(iscol(ir).EQ.0) fbr=0d0
71271 
71272 C...Integral of Altarelli-Parisi kernel for photon emission.
71273  fbre=0d0
71274  IF(mstj(41).GE.2.AND.ischg(ir).EQ.1) THEN
71275  IF(kfl(1).LE.18) THEN
71276  fbre=(kchg(kfl(1),1)/3d0)**2*2d0*log((1d0-zce)/zce)
71277  ENDIF
71278  IF(mstj(41).EQ.10) fbre=parj(84)*fbre
71279  ENDIF
71280 
71281 C...Inner veto algorithm starts. Find maximum mass for evolution.
71282  410 pms=v(iep(1),5)
71283  IF(igm.GE.0) THEN
71284  pm2=0d0
71285  DO 420 i=2,nep
71286  pm=p(iep(i),5)
71287  iri=iref(iep(i)-ns)
71288  IF(ksh(iri).EQ.1) pm=pmth(2,iri)
71289  pm2=pm2+pm
71290  420 CONTINUE
71291  pms=min(pms,(p(im,5)-pm2)**2)
71292  ENDIF
71293 
71294 C...Select mass for daughter in QCD evolution.
71295  b0=27d0/6d0
71296  DO 430 iff=4,mstj(45)
71297  IF(pms.GT.4d0*pmth(2,iff)**2) b0=(33d0-2d0*iff)/6d0
71298  430 CONTINUE
71299 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
71300  pmsc=max(0.5d0*parj(82),pms-pmth(1,ir)**2)
71301 C...Already predetermined choice.
71302  IF(ipspd.NE.0) THEN
71303  pmsqcd=p(ipspd,5)**2
71304  ELSEIF(fbr.LT.1d-3) THEN
71305  pmsqcd=0d0
71306  ELSEIF(mstj(44).LE.0) THEN
71307  pmsqcd=pmsc*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(111)*fbr)))
71308  ELSEIF(mstj(44).EQ.1) THEN
71309  pmsqcd=4d0*alams*(0.25d0*pmsc/alams)**(pyr(0)**(b0/fbr))
71310  ELSE
71311  pmsqcd=pmsc*exp(max(-50d0,alfm*b0*log(pyr(0))/fbr))
71312  ENDIF
71313 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
71314  IF(ipspd.EQ.0) pmsqcd=pmsqcd+pmth(1,ir)**2
71315  IF(zc.GT.0.49d0.OR.pmsqcd.LE.pmth(4,ir)**2) pmsqcd=pmth(2,ir)**2
71316  v(iep(1),5)=pmsqcd
71317  mce=1
71318 
71319 C...Select mass for daughter in QED evolution.
71320  IF(mstj(41).GE.2.AND.ischg(ir).EQ.1.AND.ipspd.EQ.0) THEN
71321 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
71322  pmse=max(0.5d0*parj(83),pms-pmth(1,ir)**2)
71323  IF(fbre.LT.1d-3) THEN
71324  pmsqed=0d0
71325  ELSE
71326  pmsqed=pmse*exp(max(-50d0,log(pyr(0))*paru(2)/
71327  & (paru(101)*fbre)))
71328  ENDIF
71329 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
71330  pmsqed=pmsqed+pmth(1,ir)**2
71331  IF(zce.GT.0.4999d0.OR.pmsqed.LE.pmth(5,ir)**2) pmsqed=
71332  & pmth(2,ir)**2
71333  IF(pmsqed.GT.pmsqcd) THEN
71334  v(iep(1),5)=pmsqed
71335  mce=2
71336  ENDIF
71337  ENDIF
71338 
71339 C...Check whether daughter mass below cutoff.
71340  p(iep(1),5)=sqrt(v(iep(1),5))
71341  IF(p(iep(1),5).LE.pmth(3,ir)) THEN
71342  p(iep(1),5)=pmth(1,ir)
71343  v(iep(1),5)=p(iep(1),5)**2
71344  goto 450
71345  ENDIF
71346 
71347 C...Already predetermined choice of z, and flavour in g -> qqbar.
71348  IF(ipspd.NE.0) THEN
71349  ipsgd1=k(ipspd,4)
71350  ipsgd2=k(ipspd,5)
71351  pmsgd1=p(ipsgd1,5)**2
71352  pmsgd2=p(ipsgd2,5)**2
71353  alamps=sqrt(max(1d-10,(pmsqcd-pmsgd1-pmsgd2)**2-
71354  & 4d0*pmsgd1*pmsgd2))
71355  z=0.5d0*(pmsqcd*(2d0*p(ipsgd1,4)/p(ipspd,4)-1d0)+alamps-
71356  & pmsgd1+pmsgd2)/alamps
71357  z=max(0.00001d0,min(0.99999d0,z))
71358  IF(kfl(1).NE.21) THEN
71359  k(iep(1),5)=21
71360  ELSE
71361  k(iep(1),5)=iabs(k(ipsgd1,2))
71362  ENDIF
71363 
71364 C...Select z value of branching: q -> qgamma.
71365  ELSEIF(mce.EQ.2) THEN
71366  z=1d0-(1d0-zce)*(zce/(1d0-zce))**pyr(0)
71367  IF(1d0+z**2.LT.2d0*pyr(0)) goto 410
71368  k(iep(1),5)=22
71369 
71370 C...QUARKONIA+++
71371 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
71372  ELSEIF(mstj(49).EQ.0.AND.
71373  & (kfl(1).EQ.9900443.OR.kfl(1).EQ.9900553)) THEN
71374  z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
71375 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
71376  IF(mstp(149).LE.0.OR.pyr(0).GT.0.5d0) z=1d0-z
71377  IF((1d0-z*(1d0-z))**2.LT.pyr(0)) goto 410
71378  k(iep(1),5)=21
71379 C...QUARKONIA---
71380 
71381 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
71382  ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
71383  z=1d0-(1d0-zc)*(zc/(1d0-zc))**pyr(0)
71384 C...Only do z weighting when no ME correction afterwards.
71385  IF(m3jc.EQ.0.AND.1d0+z**2.LT.2d0*pyr(0)) goto 410
71386  k(iep(1),5)=21
71387  ELSEIF(mstj(49).EQ.0.AND.mstj(45)*0.5d0.LT.pyr(0)*fbr) THEN
71388  z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
71389  IF(pyr(0).GT.0.5d0) z=1d0-z
71390  IF((1d0-z*(1d0-z))**2.LT.pyr(0)) goto 410
71391  k(iep(1),5)=21
71392  ELSEIF(mstj(49).NE.1) THEN
71393  z=pyr(0)
71394  IF(z**2+(1d0-z)**2.LT.pyr(0)) goto 410
71395  kflb=1+int(mstj(45)*pyr(0))
71396  pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
71397  IF(pmq.GE.1d0) goto 410
71398  IF(mstj(44).LE.2.OR.mstj(44).EQ.4) THEN
71399  IF(z.LT.zc.OR.z.GT.1d0-zc) goto 410
71400  pmq0=4d0*pmth(2,21)**2/v(iep(1),5)
71401  IF(mod(mstj(43),2).EQ.0.AND.(1d0+0.5d0*pmq)*sqrt(1d0-pmq)
71402  & .LT.pyr(0)*(1d0+0.5d0*pmq0)*sqrt(1d0-pmq0)) goto 410
71403  ELSE
71404  IF((1d0+0.5d0*pmq)*sqrt(1d0-pmq).LT.pyr(0)) goto 410
71405  ENDIF
71406  k(iep(1),5)=kflb
71407 
71408 C...Ditto for scalar gluon model.
71409  ELSEIF(kfl(1).NE.21) THEN
71410  z=1d0-sqrt(zc**2+pyr(0)*(1d0-2d0*zc))
71411  k(iep(1),5)=21
71412  ELSEIF(pyr(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
71413  z=zc+(1d0-2d0*zc)*pyr(0)
71414  k(iep(1),5)=21
71415  ELSE
71416  z=zc+(1d0-2d0*zc)*pyr(0)
71417  kflb=1+int(mstj(45)*pyr(0))
71418  pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
71419  IF(pmq.GE.1d0) goto 410
71420  k(iep(1),5)=kflb
71421  ENDIF
71422 
71423 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
71424  IF(mce.EQ.1.AND.mstj(44).GE.2.AND.ipspd.EQ.0) THEN
71425  IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.
71426  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
71427  IF(alfm/log(v(iep(1),5)*0.25d0/alams).LT.pyr(0)) goto 410
71428  ELSE
71429  pt2app=z*(1d0-z)*v(iep(1),5)
71430  IF(mstj(44).GE.4) pt2app=pt2app*
71431  & (1d0-pmth(1,ir)**2/v(iep(1),5))**2
71432  IF(pt2app.LT.pt2min) goto 410
71433  IF(alfm/log(pt2app/alams).LT.pyr(0)) goto 410
71434  ENDIF
71435  ENDIF
71436 
71437 C...Check if z consistent with chosen m.
71438  IF(kfl(1).EQ.21) THEN
71439  irgd1=iabs(k(iep(1),5))
71440  irgd2=irgd1
71441  ELSE
71442  irgd1=ir
71443  irgd2=iabs(k(iep(1),5))
71444  ENDIF
71445  IF(nep.EQ.1) THEN
71446  ped=ps(4)
71447  ELSEIF(nep.GE.3) THEN
71448  ped=p(iep(1),4)
71449  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
71450  ped=0.5d0*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
71451  ELSE
71452  IF(iep(1).EQ.n+1) ped=v(im,1)*pem
71453  IF(iep(1).EQ.n+2) ped=(1d0-v(im,1))*pem
71454  ENDIF
71455  IF(mod(mstj(43),2).EQ.1) THEN
71456  pmqth3=0.5d0*parj(82)
71457  IF(irgd2.EQ.22) pmqth3=0.5d0*parj(83)
71458  IF(irgd2.EQ.22.AND.iscol(ir).EQ.0) pmqth3=0.5d0*parj(90)
71459  pmq1=(pmth(1,irgd1)**2+pmqth3**2)/v(iep(1),5)
71460  pmq2=(pmth(1,irgd2)**2+pmqth3**2)/v(iep(1),5)
71461  zd=sqrt(max(0d0,(1d0-v(iep(1),5)/ped**2)*((1d0-pmq1-pmq2)**2-
71462  & 4d0*pmq1*pmq2)))
71463  zh=1d0+pmq1-pmq2
71464  ELSE
71465  zd=sqrt(max(0d0,1d0-v(iep(1),5)/ped**2))
71466  zh=1d0
71467  ENDIF
71468  IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.
71469  &(mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
71470  ELSEIF(ipspd.NE.0) THEN
71471  ELSE
71472  zl=0.5d0*(zh-zd)
71473  zu=0.5d0*(zh+zd)
71474  IF(z.LT.zl.OR.z.GT.zu) goto 410
71475  ENDIF
71476  IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1d0-zl)/max(1d-20,zl*
71477  &(1d0-zu)))
71478  IF(kfl(1).NE.21) v(iep(1),3)=log((1d0-zl)/max(1d-10,1d0-zu))
71479 
71480 C...Width suppression for q -> q + g.
71481  IF(mstj(40).NE.0.AND.kfl(1).NE.21.AND.ipspd.EQ.0) THEN
71482  IF(igm.EQ.0) THEN
71483  eglu=0.5d0*ps(5)*(1d0-z)*(1d0+v(iep(1),5)/v(ns+1,5))
71484  ELSE
71485  eglu=pmed*(1d0-z)
71486  ENDIF
71487  chi=parj(89)**2/(parj(89)**2+eglu**2)
71488  IF(mstj(40).EQ.1) THEN
71489  IF(chi.LT.pyr(0)) goto 410
71490  ELSEIF(mstj(40).EQ.2) THEN
71491  IF(1d0-chi.LT.pyr(0)) goto 410
71492  ENDIF
71493  ENDIF
71494 
71495 C...Three-jet matrix element correction.
71496  IF(m3jc.GE.1) THEN
71497  wme=1d0
71498  wshow=1d0
71499 
71500 C...QED matrix elements: only for massless case so far.
71501  IF(mce.EQ.2.AND.igm.EQ.0) THEN
71502  x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
71503  x2=1d0-v(iep(1),5)/v(ns+1,5)
71504  x3=(1d0-x1)+(1d0-x2)
71505  ki1=k(ipa(inum),2)
71506  ki2=k(ipa(3-inum),2)
71507  qf1=kchg(pycomp(ki1),1)*isign(1,ki1)/3d0
71508  qf2=kchg(pycomp(ki2),1)*isign(1,ki2)/3d0
71509  wshow=qf1**2*(1d0-x1)/x3*(1d0+(x1/(2d0-x2))**2)+
71510  & qf2**2*(1d0-x2)/x3*(1d0+(x2/(2d0-x1))**2)
71511  wme=(qf1*(1d0-x1)/x3-qf2*(1d0-x2)/x3)**2*(x1**2+x2**2)
71512  ELSEIF(mce.EQ.2) THEN
71513 
71514 C...QCD matrix elements, including mass effects.
71515  ELSEIF(mstj(49).NE.1.AND.k(iep(1),2).NE.21) THEN
71516  ps1me=v(iep(1),5)
71517  pm1me=pmth(1,ir)
71518  m3jcc=m3jc
71519  IF(ir.GE.31.AND.igm.EQ.0) THEN
71520 C...QCD ME: original parton, first branching.
71521  pm2me=pmth(1,63-ir)
71522  ecmme=ps(5)
71523  ELSEIF(ir.GE.31) THEN
71524 C...QCD ME: original parton, subsequent branchings.
71525  pm2me=pmth(1,63-ir)
71526  pedme=pem*(v(im,1)+(1d0-v(im,1))*ps1me/v(im,5))
71527  ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
71528  ELSEIF(k(im,2).EQ.21) THEN
71529 C...QCD ME: secondary partons, first branching.
71530  pm2me=pm1me
71531  zmme=v(im,1)
71532  IF(iep(1).GT.iep(2)) zmme=1d0-zmme
71533  pmlme=sqrt(max(0d0,(v(im,5)-ps1me-pm2me**2)**2-
71534  & 4d0*ps1me*pm2me**2))
71535  pedme=pem*(0.5d0*(v(im,5)-pmlme+ps1me-pm2me**2)+pmlme*zmme)/
71536  & v(im,5)
71537  ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
71538  m3jcc=66
71539  ELSE
71540 C...QCD ME: secondary partons, subsequent branchings.
71541  pm2me=pm1me
71542  pedme=pem*(v(im,1)+(1d0-v(im,1))*ps1me/v(im,5))
71543  ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
71544  m3jcc=66
71545  ENDIF
71546 C...Construct ME variables.
71547  r1me=pm1me/ecmme
71548  r2me=pm2me/ecmme
71549  x1=(1d0+ps1me/ecmme**2-r2me**2)*(z+(1d0-z)*pm1me**2/ps1me)
71550  x2=1d0+r2me**2-ps1me/ecmme**2
71551 C...Call ME, with right order important for two inequivalent showerers.
71552  IF(ir.EQ.iord+30) THEN
71553  wme=pymael(m3jcc,x1,x2,r1me,r2me,alpha)
71554  ELSE
71555  wme=pymael(m3jcc,x2,x1,r2me,r1me,alpha)
71556  ENDIF
71557 C...Split up total ME when two radiating partons.
71558  isprad=1
71559  IF((m3jcc.GE.16.AND.m3jcc.LE.19).OR.
71560  & (m3jcc.GE.26.AND.m3jcc.LE.29).OR.
71561  & (m3jcc.GE.36.AND.m3jcc.LE.39).OR.
71562  & (m3jcc.GE.46.AND.m3jcc.LE.49).OR.
71563  & (m3jcc.GE.56.AND.m3jcc.LE.64)) isprad=0
71564  IF(isprad.EQ.1) wme=wme*max(1d-10,1d0+r1me**2-r2me**2-x1)/
71565  & max(1d-10,2d0-x1-x2)
71566 C...Evaluate shower rate to be compared with.
71567  wshow=2d0/(max(1d-10,2d0-x1-x2)*
71568  & max(1d-10,1d0+r2me**2-r1me**2-x2))
71569  IF(iglui.EQ.1.AND.ir.GE.31) wshow=(9d0/4d0)*wshow
71570  ELSEIF(mstj(49).NE.1) THEN
71571 
71572 C...Toy model scalar theory matrix elements; no mass effects.
71573  ELSE
71574  x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
71575  x2=1d0-v(iep(1),5)/v(ns+1,5)
71576  x3=(1d0-x1)+(1d0-x2)
71577  wshow=4d0*x3*((1d0-x1)/(2d0-x2)**2+(1d0-x2)/(2d0-x1)**2)
71578  wme=x3**2
71579  IF(mstj(102).GE.2) wme=x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*
71580  & parj(171)
71581  ENDIF
71582 
71583  IF(wme.LT.pyr(0)*wshow) goto 410
71584  ENDIF
71585 
71586 C...Impose angular ordering by rejection of nonordered emission.
71587  IF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2.AND.ipspd.EQ.0) THEN
71588  pemao=v(im,1)*p(im,4)
71589  IF(iep(1).EQ.n+2) pemao=(1d0-v(im,1))*p(im,4)
71590  IF(ir.GE.31.AND.mstj(42).GE.5) THEN
71591  maod=0
71592  ELSEIF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.(mstj(42).EQ.4
71593  & .OR.mstj(42).EQ.7)) THEN
71594  maod=0
71595  ELSEIF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.(mstj(42).EQ.3
71596  & .OR.mstj(42).EQ.6)) THEN
71597  maod=1
71598  pmdao=pmth(2,k(iep(1),5))
71599  the2id=z*(1d0-z)*pemao**2/(v(iep(1),5)-4d0*pmdao**2)
71600  ELSE
71601  maod=1
71602  the2id=z*(1d0-z)*pemao**2/v(iep(1),5)
71603  IF(mstj(42).GE.3.AND.mstj(42).NE.5) the2id=the2id*
71604  & (1d0+pmth(1,ir)**2*(1d0-z)/(v(iep(1),5)*z))**2
71605  ENDIF
71606  maom=1
71607  iaom=im
71608  440 IF(k(iaom,5).EQ.22) THEN
71609  iaom=k(iaom,3)
71610  IF(k(iaom,3).LE.ns) maom=0
71611  IF(maom.EQ.1) goto 440
71612  ENDIF
71613  IF(maom.EQ.1.AND.maod.EQ.1) THEN
71614  the2im=v(iaom,1)*(1d0-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
71615  IF(the2id.LT.the2im) goto 410
71616  ENDIF
71617  ENDIF
71618 
71619 C...Impose user-defined maximum angle at first branching.
71620  IF(mstj(48).EQ.1.AND.ipspd.EQ.0) THEN
71621  IF(nep.EQ.1.AND.im.EQ.ns) THEN
71622  the2id=z*(1d0-z)*ps(4)**2/v(iep(1),5)
71623  IF(parj(85)**2*the2id.LT.1d0) goto 410
71624  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
71625  the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
71626  IF(parj(85)**2*the2id.LT.1d0) goto 410
71627  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
71628  the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
71629  IF(parj(86)**2*the2id.LT.1d0) goto 410
71630  ENDIF
71631  ENDIF
71632 
71633 C...Impose angular constraint in first branching from interference
71634 C...with initial state partons.
71635  IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
71636  the2d=max((1d0-z)/z,z/(1d0-z))*v(iep(1),5)/(0.5d0*p(im,4))**2
71637  IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
71638  IF(the2d.GT.theiis(1,isii(1))**2) goto 410
71639  ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
71640  IF(the2d.GT.theiis(2,isii(2))**2) goto 410
71641  ENDIF
71642  ENDIF
71643 
71644 C...End of inner veto algorithm. Check if only one leg evolved so far.
71645  450 v(iep(1),1)=z
71646  isl(1)=0
71647  isl(2)=0
71648  IF(nep.EQ.1) goto 490
71649  IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) goto 350
71650  DO 460 i=1,nep
71651  ir=iref(n+i-ns)
71652  IF(itry(i).EQ.0.AND.ksh(ir).EQ.1) THEN
71653  IF(p(n+i,5).GE.pmth(2,ir)) goto 350
71654  ENDIF
71655  460 CONTINUE
71656 
71657 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
71658  IF(nep.GE.3) THEN
71659  pmsum=0d0
71660  DO 470 i=1,nep
71661  pmsum=pmsum+p(n+i,5)
71662  470 CONTINUE
71663  IF(pmsum.GE.ps(5)) goto 350
71664  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
71665  DO 480 i1=n+1,n+2
71666  irda=iref(i1-ns)
71667  IF(ksh(irda).EQ.0) goto 480
71668  IF(p(i1,5).LT.pmth(2,irda)) goto 480
71669  IF(irda.EQ.21) THEN
71670  irgd1=iabs(k(i1,5))
71671  irgd2=irgd1
71672  ELSE
71673  irgd1=irda
71674  irgd2=iabs(k(i1,5))
71675  ENDIF
71676  i2=2*n+3-i1
71677  IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
71678  ped=0.5d0*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
71679  ELSE
71680  IF(i1.EQ.n+1) zm=v(im,1)
71681  IF(i1.EQ.n+2) zm=1d0-v(im,1)
71682  pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
71683  & 4d0*v(n+1,5)*v(n+2,5))
71684  ped=pem*(0.5d0*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/
71685  & v(im,5)
71686  ENDIF
71687  IF(mod(mstj(43),2).EQ.1) THEN
71688  pmqth3=0.5d0*parj(82)
71689  IF(irgd2.EQ.22) pmqth3=0.5d0*parj(83)
71690  IF(irgd2.EQ.22.AND.iscol(irda).EQ.0) pmqth3=0.5d0*parj(90)
71691  pmq1=(pmth(1,irgd1)**2+pmqth3**2)/v(i1,5)
71692  pmq2=(pmth(1,irgd2)**2+pmqth3**2)/v(i1,5)
71693  zd=sqrt(max(0d0,(1d0-v(i1,5)/ped**2)*((1d0-pmq1-pmq2)**2-
71694  & 4d0*pmq1*pmq2)))
71695  zh=1d0+pmq1-pmq2
71696  ELSE
71697  zd=sqrt(max(0d0,1d0-v(i1,5)/ped**2))
71698  zh=1d0
71699  ENDIF
71700  IF(irda.EQ.21.AND.irgd1.LT.10.AND.
71701  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
71702  ELSE
71703  zl=0.5d0*(zh-zd)
71704  zu=0.5d0*(zh+zd)
71705  IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
71706  & isset(1).EQ.0) THEN
71707  isl(1)=1
71708  ELSEIF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
71709  & isset(2).EQ.0) THEN
71710  isl(2)=1
71711  ENDIF
71712  ENDIF
71713  IF(irda.EQ.21) v(i1,4)=log(zu*(1d0-zl)/max(1d-20,
71714  & zl*(1d0-zu)))
71715  IF(irda.NE.21) v(i1,4)=log((1d0-zl)/max(1d-10,1d0-zu))
71716  480 CONTINUE
71717  IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
71718  isl(3-islm)=0
71719  islm=3-islm
71720  ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
71721  zdr1=max(0d0,v(n+1,3)/max(1d-6,v(n+1,4))-1d0)
71722  zdr2=max(0d0,v(n+2,3)/max(1d-6,v(n+2,4))-1d0)
71723  IF(zdr2.GT.pyr(0)*(zdr1+zdr2)) isl(1)=0
71724  IF(isl(1).EQ.1) isl(2)=0
71725  IF(isl(1).EQ.0) islm=1
71726  IF(isl(2).EQ.0) islm=2
71727  ENDIF
71728  IF(isl(1).EQ.1.OR.isl(2).EQ.1) goto 350
71729  ENDIF
71730  ird1=iref(n+1-ns)
71731  ird2=iref(n+2-ns)
71732  IF(igm.GT.0) THEN
71733  IF(mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
71734  & pmth(2,ird1).OR.p(n+2,5).GE.pmth(2,ird2))) THEN
71735  pmq1=v(n+1,5)/v(im,5)
71736  pmq2=v(n+2,5)/v(im,5)
71737  zd=sqrt(max(0d0,(1d0-v(im,5)/pem**2)*((1d0-pmq1-pmq2)**2-
71738  & 4d0*pmq1*pmq2)))
71739  zh=1d0+pmq1-pmq2
71740  zl=0.5d0*(zh-zd)
71741  zu=0.5d0*(zh+zd)
71742  IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) goto 350
71743  ENDIF
71744  ENDIF
71745 
71746 C...Accepted branch. Construct four-momentum for initial partons.
71747  490 mazip=0
71748  mazic=0
71749  IF(nep.EQ.1) THEN
71750  p(n+1,1)=0d0
71751  p(n+1,2)=0d0
71752  p(n+1,3)=sqrt(max(0d0,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
71753  & p(n+1,5))))
71754  p(n+1,4)=p(ipa(1),4)
71755  v(n+1,2)=p(n+1,4)
71756  ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
71757  ped1=0.5d0*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
71758  p(n+1,1)=0d0
71759  p(n+1,2)=0d0
71760  p(n+1,3)=sqrt(max(0d0,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
71761  p(n+1,4)=ped1
71762  p(n+2,1)=0d0
71763  p(n+2,2)=0d0
71764  p(n+2,3)=-p(n+1,3)
71765  p(n+2,4)=p(im,5)-ped1
71766  v(n+1,2)=p(n+1,4)
71767  v(n+2,2)=p(n+2,4)
71768  ELSEIF(nep.GE.3) THEN
71769 C...Rescale all momenta for energy conservation.
71770  loop=0
71771  pes=0d0
71772  pqs=0d0
71773  DO 510 i=1,nep
71774  DO 500 j=1,4
71775  p(n+i,j)=p(ipa(i),j)
71776  500 CONTINUE
71777  pes=pes+p(n+i,4)
71778  pqs=pqs+p(n+i,5)**2/p(n+i,4)
71779  510 CONTINUE
71780  520 loop=loop+1
71781  fac=(ps(5)-pqs)/(pes-pqs)
71782  pes=0d0
71783  pqs=0d0
71784  DO 540 i=1,nep
71785  DO 530 j=1,3
71786  p(n+i,j)=fac*p(n+i,j)
71787  530 CONTINUE
71788  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)
71789  v(n+i,2)=p(n+i,4)
71790  pes=pes+p(n+i,4)
71791  pqs=pqs+p(n+i,5)**2/p(n+i,4)
71792  540 CONTINUE
71793  IF(loop.LT.10.AND.abs(pes-ps(5)).GT.1d-12*ps(5)) goto 520
71794 
71795 C...Construct transverse momentum for ordinary branching in shower.
71796  ELSE
71797  zm=v(im,1)
71798  looppt=0
71799  550 looppt=looppt+1
71800  pzm=sqrt(max(0d0,(pem+p(im,5))*(pem-p(im,5))))
71801  pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4d0*v(n+1,5)*v(n+2,5)
71802  IF(pzm.LE.0d0) THEN
71803  pts=0d0
71804  ELSEIF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
71805  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
71806  pts=pmls*zm*(1d0-zm)/v(im,5)
71807  ELSEIF(mod(mstj(43),2).EQ.1) THEN
71808  pts=(pem**2*(zm*(1d0-zm)*v(im,5)-(1d0-zm)*v(n+1,5)-
71809  & zm*v(n+2,5))-0.25d0*pmls)/pzm**2
71810  ELSE
71811  pts=pmls*(zm*(1d0-zm)*pem**2/v(im,5)-0.25d0)/pzm**2
71812  ENDIF
71813  IF(pts.LT.0d0.AND.looppt.LT.10) THEN
71814  zm=0.05d0+0.9d0*zm
71815  goto 550
71816  ELSEIF(pts.LT.0d0) THEN
71817  goto 280
71818  ENDIF
71819  pt=sqrt(max(0d0,pts))
71820 
71821 C...Global statistics.
71822  mint(353)=mint(353)+1
71823  vint(353)=vint(353)+pt
71824  IF (mint(353).EQ.1) vint(358)=pt
71825 
71826 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
71827  hazip=0d0
71828  IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21
71829  & .AND.iau.NE.0) THEN
71830  IF(k(igm,3).NE.0) mazip=1
71831  zau=v(igm,1)
71832  IF(iau.EQ.im+1) zau=1d0-v(igm,1)
71833  IF(mazip.EQ.0) zau=0d0
71834  IF(k(igm,2).NE.21) THEN
71835  hazip=2d0*zau/(1d0+zau**2)
71836  ELSE
71837  hazip=(zau/(1d0-zau*(1d0-zau)))**2
71838  ENDIF
71839  IF(k(n+1,2).NE.21) THEN
71840  hazip=hazip*(-2d0*zm*(1d0-zm))/(1d0-2d0*zm*(1d0-zm))
71841  ELSE
71842  hazip=hazip*(zm*(1d0-zm)/(1d0-zm*(1d0-zm)))**2
71843  ENDIF
71844  ENDIF
71845 
71846 C...Find coefficient of azimuthal asymmetry due to soft gluon
71847 C...interference.
71848  hazic=0d0
71849  IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
71850  & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
71851  IF(k(igm,3).NE.0) mazic=n+1
71852  IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
71853  IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
71854  & zm.GT.0.5d0) mazic=n+2
71855  IF(k(iau,2).EQ.22) mazic=0
71856  zs=zm
71857  IF(mazic.EQ.n+2) zs=1d0-zm
71858  zgm=v(igm,1)
71859  IF(iau.EQ.im-1) zgm=1d0-v(igm,1)
71860  IF(mazic.EQ.0) zgm=1d0
71861  IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*
71862  & sqrt((1d0-zs)*(1d0-zgm)/(zs*zgm))
71863  hazic=min(0.95d0,hazic)
71864  ENDIF
71865  ENDIF
71866 
71867 C...Construct energies for ordinary branching in shower.
71868  560 IF(nep.EQ.2.AND.igm.GT.0) THEN
71869  IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
71870  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
71871  p(n+1,4)=0.5d0*(pem*(v(im,5)+v(n+1,5)-v(n+2,5))+
71872  & pzm*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
71873  ELSEIF(mod(mstj(43),2).EQ.1) THEN
71874  p(n+1,4)=pem*v(im,1)
71875  ELSE
71876  p(n+1,4)=pem*(0.5d0*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
71877  & sqrt(pmls)*zm)/v(im,5)
71878  ENDIF
71879 
71880 C...Already predetermined choice of phi angle or not
71881  phi=paru(2)*pyr(0)
71882  IF(mpspd.EQ.1.AND.igm.EQ.ns+1) THEN
71883  ipspd=ip1+im-ns-2
71884  IF(k(ipspd,4).GT.0) THEN
71885  ipsgd1=k(ipspd,4)
71886  IF(im.EQ.ns+2) THEN
71887  phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
71888  ELSE
71889  phi=pyangl(-p(ipsgd1,1),p(ipsgd1,2))
71890  ENDIF
71891  ENDIF
71892  ELSEIF(mpspd.EQ.1.AND.igm.EQ.ns+2) THEN
71893  ipspd=ip1+im-ns-2
71894  IF(k(ipspd,4).GT.0) THEN
71895  ipsgd1=k(ipspd,4)
71896  phipsm=pyangl(p(ipspd,1),p(ipspd,2))
71897  thepsm=pyangl(p(ipspd,3),sqrt(p(ipspd,1)**2+p(ipspd,2)**2))
71898  CALL pyrobo(ipsgd1,ipsgd1,0d0,-phipsm,0d0,0d0,0d0)
71899  CALL pyrobo(ipsgd1,ipsgd1,-thepsm,0d0,0d0,0d0,0d0)
71900  phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
71901  CALL pyrobo(ipsgd1,ipsgd1,thepsm,phipsm,0d0,0d0,0d0)
71902  ENDIF
71903  ENDIF
71904 
71905 C...Construct momenta for ordinary branching in shower.
71906  p(n+1,1)=pt*cos(phi)
71907  p(n+1,2)=pt*sin(phi)
71908  IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
71909  & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
71910  p(n+1,3)=0.5d0*(pzm*(v(im,5)+v(n+1,5)-v(n+2,5))+
71911  & pem*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
71912  ELSEIF(pzm.GT.0d0) THEN
71913  p(n+1,3)=0.5d0*(v(n+2,5)-v(n+1,5)-v(im,5)+
71914  & 2d0*pem*p(n+1,4))/pzm
71915  ELSE
71916  p(n+1,3)=0d0
71917  ENDIF
71918  p(n+2,1)=-p(n+1,1)
71919  p(n+2,2)=-p(n+1,2)
71920  p(n+2,3)=pzm-p(n+1,3)
71921  p(n+2,4)=pem-p(n+1,4)
71922  IF(mstj(43).LE.2) THEN
71923  v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
71924  v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
71925  ENDIF
71926  ENDIF
71927 
71928 C...Rotate and boost daughters.
71929  IF(igm.GT.0) THEN
71930  IF(mstj(43).LE.2) THEN
71931  bex=p(igm,1)/p(igm,4)
71932  bey=p(igm,2)/p(igm,4)
71933  bez=p(igm,3)/p(igm,4)
71934  ga=p(igm,4)/p(igm,5)
71935  gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1d0+ga)-
71936  & p(im,4))
71937  ELSE
71938  bex=0d0
71939  bey=0d0
71940  bez=0d0
71941  ga=1d0
71942  gabep=0d0
71943  ENDIF
71944  ptimb=sqrt((p(im,1)+gabep*bex)**2+(p(im,2)+gabep*bey)**2)
71945  the=pyangl(p(im,3)+gabep*bez,ptimb)
71946  IF(ptimb.GT.1d-4) THEN
71947  phi=pyangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
71948  ELSE
71949  phi=0d0
71950  ENDIF
71951  DO 570 i=n+1,n+2
71952  dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
71953  & sin(the)*cos(phi)*p(i,3)
71954  dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
71955  & sin(the)*sin(phi)*p(i,3)
71956  dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
71957  dp(4)=p(i,4)
71958  dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
71959  dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
71960  p(i,1)=dp(1)+dgabp*bex
71961  p(i,2)=dp(2)+dgabp*bey
71962  p(i,3)=dp(3)+dgabp*bez
71963  p(i,4)=ga*(dp(4)+dbp)
71964  570 CONTINUE
71965  ENDIF
71966 
71967 C...Weight with azimuthal distribution, if required.
71968  IF(mazip.NE.0.OR.mazic.NE.0) THEN
71969  DO 580 j=1,3
71970  dpt(1,j)=p(im,j)
71971  dpt(2,j)=p(iau,j)
71972  dpt(3,j)=p(n+1,j)
71973  580 CONTINUE
71974  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
71975  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
71976  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
71977  DO 590 j=1,3
71978  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/max(1d-10,dpmm)
71979  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/max(1d-10,dpmm)
71980  590 CONTINUE
71981  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
71982  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
71983  IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
71984  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
71985  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
71986  IF(mazip.NE.0) THEN
71987  IF(1d0+hazip*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(hazip)))
71988  & goto 560
71989  ENDIF
71990  IF(mazic.NE.0) THEN
71991  IF(mazic.EQ.n+2) cad=-cad
71992  IF((1d0-hazic)*(1d0-hazic*cad)/(1d0+hazic**2-2d0*hazic*cad)
71993  & .LT.pyr(0)) goto 560
71994  ENDIF
71995  ENDIF
71996  ENDIF
71997 
71998 C...Azimuthal anisotropy due to interference with initial state partons.
71999  IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
72000  &k(n+2,2).EQ.21)) THEN
72001  iii=im-ns-1
72002  IF(isii(iii).GE.1) THEN
72003  iaziid=n+1
72004  IF(k(n+1,2).NE.21) iaziid=n+2
72005  IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
72006  & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
72007  theiid=pyangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
72008  IF(iii.EQ.2) theiid=paru(1)-theiid
72009  phiiid=pyangl(p(iaziid,1),p(iaziid,2))
72010  hazii=min(0.95d0,theiid/theiis(iii,isii(iii)))
72011  cad=cos(phiiid-phiiis(iii,isii(iii)))
72012  phirel=abs(phiiid-phiiis(iii,isii(iii)))
72013  IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
72014  IF((1d0-hazii)*(1d0-hazii*cad)/(1d0+hazii**2-2d0*hazii*cad)
72015  & .LT.pyr(0)) goto 560
72016  ENDIF
72017  ENDIF
72018 
72019 C...Continue loop over partons that may branch, until none left.
72020  IF(igm.GE.0) k(im,1)=14
72021  n=n+nep
72022  nep=2
72023  IF(n.GT.mstu(4)-mstu(32)-10) THEN
72024  CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
72025  IF(mstu(21).GE.1) n=ns
72026  IF(mstu(21).GE.1) RETURN
72027  ENDIF
72028  goto 290
72029 
72030 C...Set information on imagined shower initiator.
72031  600 IF(npa.GE.2) THEN
72032  k(ns+1,1)=11
72033  k(ns+1,2)=94
72034  k(ns+1,3)=ip1
72035  IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
72036  k(ns+1,4)=ns+2
72037  k(ns+1,5)=ns+1+npa
72038  iim=1
72039  ELSE
72040  iim=0
72041  ENDIF
72042 
72043 C...Reconstruct string drawing information.
72044  DO 610 i=ns+1+iim,n
72045  kq=kchg(pycomp(k(i,2)),2)
72046  IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
72047  k(i,1)=1
72048  ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
72049  & iabs(k(i,2)).LE.18) THEN
72050  k(i,1)=1
72051  ELSEIF(k(i,1).LE.10) THEN
72052  k(i,4)=mstu(5)*(k(i,4)/mstu(5))
72053  k(i,5)=mstu(5)*(k(i,5)/mstu(5))
72054  ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
72055  id1=mod(k(i,4),mstu(5))
72056  IF(kq.EQ.1.AND.k(i,2).GT.0) id1=mod(k(i,4),mstu(5))+1
72057  IF(kq.EQ.2.AND.(k(id1,2).EQ.21.OR.k(id1+1,2).EQ.21).AND.
72058  & pyr(0).GT.0.5d0) id1=mod(k(i,4),mstu(5))+1
72059  id2=2*mod(k(i,4),mstu(5))+1-id1
72060  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
72061  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
72062  k(id1,4)=k(id1,4)+mstu(5)*i
72063  k(id1,5)=k(id1,5)+mstu(5)*id2
72064  k(id2,4)=k(id2,4)+mstu(5)*id1
72065  k(id2,5)=k(id2,5)+mstu(5)*i
72066  ELSE
72067  id1=mod(k(i,4),mstu(5))
72068  id2=id1+1
72069  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
72070  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
72071  IF(kq.EQ.1.OR.k(id1,1).GE.11) THEN
72072  k(id1,4)=k(id1,4)+mstu(5)*i
72073  k(id1,5)=k(id1,5)+mstu(5)*i
72074  ELSE
72075  k(id1,4)=0
72076  k(id1,5)=0
72077  ENDIF
72078  k(id2,4)=0
72079  k(id2,5)=0
72080  ENDIF
72081  610 CONTINUE
72082 
72083 C...Transformation from CM frame.
72084  IF(npa.EQ.1) THEN
72085  the=pyangl(p(ipa(1),3),sqrt(p(ipa(1),1)**2+p(ipa(1),2)**2))
72086  phi=pyangl(p(ipa(1),1),p(ipa(1),2))
72087  mstu(33)=1
72088  CALL pyrobo(ns+1,n,the,phi,0d0,0d0,0d0)
72089  ELSEIF(npa.EQ.2) THEN
72090  bex=ps(1)/ps(4)
72091  bey=ps(2)/ps(4)
72092  bez=ps(3)/ps(4)
72093  ga=ps(4)/ps(5)
72094  gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
72095  & /(1d0+ga)-p(ipa(1),4))
72096  the=pyangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
72097  & +gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
72098  phi=pyangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
72099  mstu(33)=1
72100  CALL pyrobo(ns+1,n,the,phi,bex,bey,bez)
72101  ELSE
72102  CALL pyrobo(ipa(1),ipa(npa),0d0,0d0,ps(1)/ps(4),ps(2)/ps(4),
72103  & ps(3)/ps(4))
72104  mstu(33)=1
72105  CALL pyrobo(ns+1,n,0d0,0d0,ps(1)/ps(4),ps(2)/ps(4),ps(3)/ps(4))
72106  ENDIF
72107 
72108 C...Decay vertex of shower.
72109  DO 630 i=ns+1,n
72110  DO 620 j=1,5
72111  v(i,j)=v(ip1,j)
72112  620 CONTINUE
72113  630 CONTINUE
72114 
72115 C...Delete trivial shower, else connect initiators.
72116  IF(n.LE.ns+npa+iim) THEN
72117  n=ns
72118  ELSE
72119  DO 640 ip=1,npa
72120  k(ipa(ip),1)=14
72121  k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
72122  k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
72123  k(ns+iim+ip,3)=ipa(ip)
72124  IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
72125  IF(k(ns+iim+ip,1).NE.1) THEN
72126  k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
72127  k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
72128  ENDIF
72129  640 CONTINUE
72130  ENDIF
72131 
72132  RETURN
72133  END
72134 
72135 C*********************************************************************
72136 
72137 C...PYPTFS
72138 C...Generates pT-ordered timelike final-state parton showers.
72139 
72140 C...MODE defines how to find radiators and recoilers.
72141 C... = 0 : based on colour flow between undecayed partons.
72142 C... = 1 : for IPART <= NPARTD only consider primary partons,
72143 C... whether decayed or not; else as above.
72144 C... = 2 : based on common history, whether decayed or not.
72145 C... = 3 : use (or create) MCT color information to shower partons
72146 
72147  SUBROUTINE pyptfs(MODE,PTMAX,PTMIN,PTGEN)
72148 
72149 C...Double precision and integer declarations.
72150  IMPLICIT DOUBLE PRECISION(a-h, o-z)
72151  IMPLICIT INTEGER(i-n)
72152  INTEGER pyk,pychge,pycomp
72153 C...Parameter statement to help give large particle numbers.
72154  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
72155  &kexcit=4000000,kdimen=5000000)
72156 C...Parameter statement for maximum size of showers.
72157  parameter(maxnur=1000)
72158 C...Commonblocks.
72159  common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
72160  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72161  common/pyctag/nct,mct(4000,2)
72162  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72163  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72164  common/pypars/mstp(200),parp(200),msti(200),pari(200)
72165  common/pyint1/mint(400),vint(400)
72166  SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pydat2/,/pypars/,
72167  &/pyint1/
72168 C...Local arrays.
72169  dimension ipos(2*maxnur),irec(2*maxnur),iflg(2*maxnur),
72170  &iscol(2*maxnur),ischg(2*maxnur),ptsca(2*maxnur),imesav(2*maxnur),
72171  &pt2sav(2*maxnur),zsav(2*maxnur),shtsav(2*maxnur),
72172 C...Array to identify the initial-final dipoles
72173  &irif(2*maxnur),
72174  &mesys(maxnur,0:2),psum(5),dpt(5,4)
72175 C...Statement functions.
72176  shat(l,j)=(p(l,4)+p(j,4))**2-(p(l,1)+p(j,1))**2-
72177  &(p(l,2)+p(j,2))**2-(p(l,3)+p(j,3))**2
72178  dotp(l,j)=p(l,4)*p(j,4)-p(l,1)*p(j,1)-p(l,2)*p(j,2)-p(l,3)*p(j,3)
72179 
72180 C...Initial values. Check that valid system.
72181  ptgen=0d0
72182  IF(mstj(41).NE.1.AND.mstj(41).NE.2.AND.mstj(41).NE.11.AND.
72183  &mstj(41).NE.12) RETURN
72184  IF(npart.LE.0) THEN
72185  CALL pyerrm(2,'(PYPTFS:) showering system too small')
72186  RETURN
72187  ENDIF
72188  pt2cmx=ptmax**2
72189  iord=1
72190 
72191 C...Mass thresholds and Lambda for QCD evolution.
72192  pmb=pmas(5,1)
72193  pmc=pmas(4,1)
72194  alam5=parj(81)
72195  alam4=alam5*(pmb/alam5)**(2d0/25d0)
72196  alam3=alam4*(pmc/alam4)**(2d0/27d0)
72197  pmbs=pmb**2
72198  pmcs=pmc**2
72199  alam5s=alam5**2
72200  alam4s=alam4**2
72201  alam3s=alam3**2
72202 
72203 C...Cutoff scale for QCD evolution. Starting pT2.
72204  nflav=max(0,min(5,mstj(45)))
72205  pt0c=0.5d0*parj(82)
72206  pt2cmn=max(ptmin,pt0c,1.1d0*alam3)**2
72207 
72208 C...Parameters for QED evolution.
72209  aem2pi=paru(101)/paru(2)
72210  pt0eq=0.5d0*parj(83)
72211  pt0el=0.5d0*parj(90)
72212 
72213 C...Reset. Remove irrelevant colour tags.
72214  nevol=0
72215  DO 100 j=1,4
72216  psum(j)=0d0
72217  100 CONTINUE
72218  DO 110 i=mint(84)+1,n
72219  IF(k(i,2).GT.0.AND.k(i,2).LT.6) THEN
72220  k(i,5)=0
72221  mct(i,2)=0
72222  ENDIF
72223  IF(k(i,2).LT.0.AND.k(i,2).GT.-6) THEN
72224  k(i,4)=0
72225  mct(i,1)=0
72226  ENDIF
72227  110 CONTINUE
72228  nparts=npart
72229 
72230 C...Identify two hardest outgoing partons
72231 c.....Must do this all beforehand
72232  ifp1=0
72233  ifp2=0
72234  ptfp1=0d0
72235  ptfp2=0d0
72236  DO 115 ip=1,npart
72237  i=ipart(ip)
72238 C...Haven't tested this yet -- should identify final-state partons
72239 C....in LHE files
72240 C...Mother must be one of the original partons
72241  IF(k(i,3).GT.mint(84)+2) goto 115
72242 C...Removes resonance decay products
72243  IF(k(k(i,3),3).GT.0) goto 115
72244  IF(ptpart(ip).GT.ptfp1) THEN
72245  ptfp2=ptfp1
72246  ifp2=ifp1
72247  ptfp1=ptpart(ip)
72248  ifp1=i
72249  ELSEIF(ptpart(ip).GT.ptfp2) THEN
72250  ifp2=i
72251  ptfp2=ptpart(ip)
72252  ENDIF
72253  115 CONTINUE
72254 C...Begin loop to set up showering partons. Sum four-momenta.
72255  DO 230 ip=1,npart
72256  i=ipart(ip)
72257  IF(mode.NE.1.OR.i.GT.npartd) THEN
72258  IF(k(i,1).GT.10) goto 230
72259  ELSEIF(k(i,3).GT.mint(84)) THEN
72260  IF(k(i,3).GT.mint(84)+2) goto 230
72261  ELSE
72262  IF(k(k(i,3),3).GT.mint(83)+6) goto 230
72263  ENDIF
72264  DO 120 j=1,4
72265  psum(j)=psum(j)+p(i,j)
72266  120 CONTINUE
72267 
72268 C...Find colour and charge, but skip diquarks.
72269  IF(iabs(k(i,2)).GT.1000.AND.iabs(k(i,2)).LT.10000) goto 230
72270  kcol=pyk(i,12)
72271  kcha=pyk(i,6)
72272 
72273 C...QUARKONIA++
72274  IF (iabs(k(i,2)).GE.9900101.AND.iabs(k(i,2)).LE.9910555) THEN
72275  IF (mstp(148).GE.1) THEN
72276 C...Temporary: force no radiation from quarkonia since not yet treated
72277  CALL pyerrm(11,'(PYPTFS:) quarkonia showers not yet in'
72278  & //' PYPTFS, switched off')
72279  CALL pygive('MSTP(148)=0')
72280  ENDIF
72281  IF (mstp(148).EQ.0) THEN
72282 C...Skip quarkonia if radiation switched off
72283  goto 230
72284  ENDIF
72285  ENDIF
72286 C...QUARKONIA--
72287 
72288 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
72289 C...(only intended for studying the effects of switching such rad on/off)
72290  IF (mstj(39).GT.0.AND.iabs(k(i,2)).EQ.mstj(39)) THEN
72291  goto 230
72292  ENDIF
72293 
72294 C...Either colour or anticolour charge radiates; for gluon both.
72295  DO 180 jsgcol=1,-1,-2
72296  IF(kcol.EQ.jsgcol.OR.kcol.EQ.2) THEN
72297  jcol=4+(1-jsgcol)/2
72298  jcolr=9-jcol
72299 
72300 C...Basic info about radiating parton.
72301  nevol=nevol+1
72302  ipos(nevol)=i
72303  iflg(nevol)=0
72304  iscol(nevol)=jsgcol
72305  ischg(nevol)=0
72306  ptsca(nevol)=ptpart(ip)
72307  irif(nevol)=0
72308 
72309 C...Begin search for colour recoiler when MODE = 0 or 1.
72310  IF(mode.LE.1) THEN
72311 C...Find sister with matching anticolour to the radiating parton.
72312  irold=i
72313  irnew=k(irold,jcol)/mstu(5)
72314  move=1
72315 
72316 C...Skip radiation off loose colour ends.
72317  130 IF(irnew.EQ.0) THEN
72318  nevol=nevol-1
72319  goto 180
72320 
72321 C...Optionally skip radiation on dipole to beam remnant.
72322  ELSEIF(mstp(72).LE.1.AND.irnew.GT.mint(53)) THEN
72323  nevol=nevol-1
72324  goto 180
72325 
72326 C...For now always skip radiation on dipole to junction.
72327  ELSEIF(k(irnew,2).EQ.88) THEN
72328  nevol=nevol-1
72329  goto 180
72330 
72331 C...For MODE=1: if reached primary then done.
72332  ELSEIF(mode.EQ.1.AND.irnew.GT.mint(84)+2.AND.
72333  & irnew.LE.npartd) THEN
72334 
72335 C...If sister stable and points back then done.
72336  ELSEIF(move.EQ.1.AND.k(irnew,jcolr)/mstu(5).EQ.irold)
72337  & THEN
72338  IF(k(irnew,1).LT.10) THEN
72339 
72340 C...If sister unstable then go to her daughter.
72341  ELSE
72342  irold=irnew
72343  irnew=mod(k(irnew,jcolr),mstu(5))
72344  move=2
72345  goto 130
72346  ENDIF
72347 
72348 C...If found mother then look for aunt.
72349  ELSEIF(move.EQ.1.AND.mod(k(irnew,jcol),mstu(5)).EQ.
72350  & irold) THEN
72351  irold=irnew
72352  irnew=k(irold,jcol)/mstu(5)
72353  goto 130
72354 
72355 C...If daughter stable then done.
72356  ELSEIF(move.EQ.2.AND.k(irnew,jcolr)/mstu(5).EQ.irold)
72357  & THEN
72358  IF(k(irnew,1).LT.10) THEN
72359 
72360 C...If daughter unstable then go to granddaughter.
72361  ELSE
72362  irold=irnew
72363  irnew=mod(k(irnew,jcolr),mstu(5))
72364  move=2
72365  goto 130
72366  ENDIF
72367 
72368 C...If daughter points to another daughter then done or move up.
72369  ELSEIF(move.EQ.2.AND.mod(k(irnew,jcol),mstu(5)).EQ.
72370  & irold) THEN
72371  IF(k(irnew,1).LT.10) THEN
72372  ELSE
72373  irold=irnew
72374  irnew=k(irnew,jcol)/mstu(5)
72375  move=1
72376  goto 130
72377  ENDIF
72378  ENDIF
72379 
72380 C...Begin search for colour recoiler when MODE = 2.
72381  ELSEIF (mode.EQ.2) THEN
72382  irold=i
72383  irnew=k(irold,jcol)/mstu(5)
72384  140 IF (irnew.LE.0.OR.irnew.GT.n) THEN
72385 C...If no color partner found, pick at random among other primaries
72386 C...(e.g., when the color line is traced all the way to the beam)
72387  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
72388  irnew=ipart(1+mod(ip+istep-1,npart))
72389  ELSEIF(k(irnew,jcolr)/mstu(5).NE.irold) THEN
72390 C...Step up to mother if radiating parton already branched.
72391  IF(k(irnew,2).EQ.k(irold,2)) THEN
72392  irold=irnew
72393  irnew=k(irold,jcol)/mstu(5)
72394  goto 140
72395 C...Pick sister by history if no anticolour available.
72396  ELSE
72397  IF(irold.GT.1.AND.k(irold-1,3).EQ.k(irold,3)) THEN
72398  irnew=irold-1
72399  ELSEIF(irold.LT.n.AND.k(irold+1,3).EQ.k(irold,3))
72400  & THEN
72401  irnew=irold+1
72402 C...Last resort: pick at random among other primaries.
72403  ELSE
72404  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
72405  irnew=ipart(1+mod(ip+istep-1,npart))
72406  ENDIF
72407  ENDIF
72408  ENDIF
72409 C...Trace down if sister branched.
72410  150 IF(k(irnew,1).GT.10) THEN
72411  irtmp=mod(k(irnew,jcolr),mstu(5))
72412 C...If no correct color-daughter found, swap.
72413  IF (irtmp.EQ.0) THEN
72414  jcol=9-jcol
72415  jcolr=9-jcolr
72416  irtmp=mod(k(irnew,jcolr),mstu(5))
72417  ENDIF
72418  irnew=irtmp
72419  goto 150
72420  ENDIF
72421  ELSEIF (mode.EQ.3) THEN
72422 C...The following will add MCT colour tracing for unprepped events
72423 C...If not done, trace Les Houches colour tags for this dipole
72424  jcolsv=jcol
72425  IF (mct(i,jcol-3).EQ.0) THEN
72426 C...Special end code -1 : trace to color partner or 0, return in IEND
72427  iend=-1
72428  CALL pycttr(i,jcol,iend)
72429 C...Clean up mother/daughter 'read' tags set by PYCTTR
72430  jcol=jcolsv
72431  DO 160 ir=1,n
72432  k(ir,4)=mod(k(ir,4),mstu(5)**2)
72433  k(ir,5)=mod(k(ir,5),mstu(5)**2)
72434  mct(ir,1)=0
72435  mct(ir,2)=0
72436  160 CONTINUE
72437  ELSE
72438  iend=0
72439  DO 170 ir=1,n
72440  IF (k(ir,1).GT.0.AND.mct(ir,6-jcol).EQ.mct(i,jcol-3))
72441  & iend=ir
72442  170 CONTINUE
72443  ENDIF
72444 C...If no color partner, then we hit beam
72445  IF (iend.LE.0) THEN
72446 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
72447  IF (mstp(72).LE.1) THEN
72448  nevol=nevol-1
72449  goto 180
72450  ELSE
72451 C...Else try a random partner
72452  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
72453  irnew=ipart(1+mod(ip+istep-1,npart))
72454  ENDIF
72455  ELSE
72456 C...Else save recoiling colour partner
72457  irnew=iend
72458  ENDIF
72459 
72460  ENDIF
72461 
72462 C...Now found other end of colour dipole.
72463  irec(nevol)=irnew
72464 C...Determine if this is an initial-final dipole
72465 c.....Check ALSO that mother is initial
72466 C...Recoiler originates from > 100
72467 C...Parton originates from < 100 (usually 7,8, etc.)
72468  IF(k(irnew,3).GT.mint(84)) THEN
72469  IF(k(i,3).LE.mint(84)+2) irif(nevol)=1
72470  ELSE
72471  irif(nevol)=0
72472  ENDIF
72473  ENDIF
72474  180 CONTINUE
72475 
72476 C...Also electrical charge may radiate; so far only quarks and leptons.
72477  IF((mstj(41).EQ.2.OR.mstj(41).EQ.12).AND.kcha.NE.0.AND.
72478  & iabs(k(i,2)).LE.18) THEN
72479 
72480 C...Basic info about radiating parton.
72481  nevol=nevol+1
72482  ipos(nevol)=i
72483  iflg(nevol)=0
72484  iscol(nevol)=0
72485  ischg(nevol)=kcha
72486  ptsca(nevol)=ptpart(ip)
72487  irif(nevol)=0
72488 
72489 C...Pick nearest (= smallest invariant mass) charged particle
72490 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
72491  IF(mode.LE.1) THEN
72492  irnew=0
72493  pm2min=vint(2)
72494  DO 190 ip2=1,npart+n-mint(53)
72495  IF(ip2.EQ.ip) goto 190
72496  IF(ip2.LE.npart) THEN
72497  i2=ipart(ip2)
72498  IF(mode.NE.1.OR.i2.GT.npartd) THEN
72499  IF(k(i2,1).GT.10) goto 190
72500  ELSEIF(k(i2,3).GT.mint(84)) THEN
72501  IF(k(i2,3).GT.mint(84)+2) goto 190
72502  ELSE
72503  IF(k(k(i2,3),3).GT.mint(83)+6) goto 190
72504  ENDIF
72505  ELSE
72506  i2=mint(53)+ip2-npart
72507  ENDIF
72508  IF(kchg(pycomp(k(i2,2)),1).EQ.0) goto 190
72509  pm2inv=(p(i,4)+p(i2,4))**2-(p(i,1)+p(i2,1))**2-
72510  & (p(i,2)+p(i2,2))**2-(p(i,3)+p(i2,3))**2
72511  IF(pm2inv.LT.pm2min) THEN
72512  irnew=i2
72513  pm2min=pm2inv
72514  ENDIF
72515  190 CONTINUE
72516  IF(irnew.EQ.0) THEN
72517  nevol=nevol-1
72518  goto 230
72519  ENDIF
72520 
72521 C...Begin search for charge recoiler when MODE = 2.
72522  ELSE
72523  irold=i
72524 C...Pick sister by history; step up if parton already branched.
72525  200 IF(k(irold,3).GT.0.AND.k(k(irold,3),2).EQ.k(irold,2)) THEN
72526  irold=k(irold,3)
72527  goto 200
72528  ENDIF
72529  IF(irold.GT.1.AND.k(irold-1,3).EQ.k(irold,3)) THEN
72530  irnew=irold-1
72531  ELSEIF(irold.LT.n.AND.k(irold+1,3).EQ.k(irold,3)) THEN
72532  irnew=irold+1
72533 C...Last resort: pick at random among other primaries.
72534  ELSE
72535  istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
72536  irnew=ipart(1+mod(ip+istep-1,npart))
72537  ENDIF
72538 C...Trace down if sister branched.
72539  210 IF(k(irnew,1).GT.10) THEN
72540  DO 220 ir=irnew+1,n
72541  IF(k(ir,3).EQ.irnew.AND.k(ir,2).EQ.k(irnew,2)) THEN
72542  irnew=ir
72543  goto 210
72544  ENDIF
72545  220 CONTINUE
72546  ENDIF
72547  ENDIF
72548  irec(nevol)=irnew
72549  ENDIF
72550 
72551 C...End loop to set up showering partons. System invariant mass.
72552  230 CONTINUE
72553  IF(nevol.LE.0) RETURN
72554  IF (mode.EQ.3.AND.nevol.LE.1) RETURN
72555  psum(5)=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
72556 
72557 C...Check if 3-jet matrix elements to be used.
72558  m3jc=0
72559  alpha=0.5d0
72560  nmesys=0
72561  IF(mstj(47).GE.1) THEN
72562 
72563 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
72564  kfsrce=0
72565  ipart1=k(ipart(1),3)
72566  ipart2=k(ipart(2),3)
72567  240 IF(ipart1.EQ.ipart2.AND.ipart1.GT.0) THEN
72568  kfsrce=iabs(k(ipart1,2))
72569  ELSEIF(ipart1.GT.ipart2.AND.ipart2.GT.0) THEN
72570  ipart1=k(ipart1,3)
72571  goto 240
72572  ELSEIF(ipart2.GT.ipart1.AND.ipart1.GT.0) THEN
72573  ipart2=k(ipart2,3)
72574  goto 240
72575  ENDIF
72576  itypes=0
72577  IF(kfsrce.GE.1.AND.kfsrce.LE.8) itypes=1
72578  IF(kfsrce.GE.ksusy1+1.AND.kfsrce.LE.ksusy1+8) itypes=2
72579  IF(kfsrce.GE.ksusy2+1.AND.kfsrce.LE.ksusy2+8) itypes=2
72580  IF(kfsrce.GE.21.AND.kfsrce.LE.24) itypes=3
72581  IF(kfsrce.GE.32.AND.kfsrce.LE.34) itypes=3
72582  IF(kfsrce.EQ.25.OR.(kfsrce.GE.35.AND.kfsrce.LE.37)) itypes=4
72583  IF(kfsrce.GE.ksusy1+22.AND.kfsrce.LE.ksusy1+37) itypes=5
72584  IF(kfsrce.EQ.ksusy1+21) itypes=6
72585 
72586 C...Identify two primary showerers.
72587  kfla1=iabs(k(ipart(1),2))
72588  itype1=0
72589  IF(kfla1.GE.1.AND.kfla1.LE.8) itype1=1
72590  IF(kfla1.GE.ksusy1+1.AND.kfla1.LE.ksusy1+8) itype1=2
72591  IF(kfla1.GE.ksusy2+1.AND.kfla1.LE.ksusy2+8) itype1=2
72592  IF(kfla1.GE.21.AND.kfla1.LE.24) itype1=3
72593  IF(kfla1.GE.32.AND.kfla1.LE.34) itype1=3
72594  IF(kfla1.EQ.25.OR.(kfla1.GE.35.AND.kfla1.LE.37)) itype1=4
72595  IF(kfla1.GE.ksusy1+22.AND.kfla1.LE.ksusy1+37) itype1=5
72596  IF(kfla1.EQ.ksusy1+21) itype1=6
72597  kfla2=iabs(k(ipart(2),2))
72598  itype2=0
72599  IF(kfla2.GE.1.AND.kfla2.LE.8) itype2=1
72600  IF(kfla2.GE.ksusy1+1.AND.kfla2.LE.ksusy1+8) itype2=2
72601  IF(kfla2.GE.ksusy2+1.AND.kfla2.LE.ksusy2+8) itype2=2
72602  IF(kfla2.GE.21.AND.kfla2.LE.24) itype2=3
72603  IF(kfla2.GE.32.AND.kfla2.LE.34) itype2=3
72604  IF(kfla2.EQ.25.OR.(kfla2.GE.35.AND.kfla2.LE.37)) itype2=4
72605  IF(kfla2.GE.ksusy1+22.AND.kfla2.LE.ksusy1+37) itype2=5
72606  IF(kfla2.EQ.ksusy1+21) itype2=6
72607 
72608 C...Order of showerers. Presence of gluino.
72609  itypmn=min(itype1,itype2)
72610  itypmx=max(itype1,itype2)
72611  iord=1
72612  IF(itype1.GT.itype2) iord=2
72613  iglui=0
72614  IF(itype1.EQ.6.OR.itype2.EQ.6) iglui=1
72615 
72616 C...Require exactly two primary showerers for ME corrections.
72617  nprim=0
72618  IF(ipart1.GT.0) THEN
72619  DO 250 i=1,n
72620  IF(k(i,3).EQ.ipart1.AND.k(i,2).NE.k(ipart1,2)) nprim=nprim+1
72621  250 CONTINUE
72622  ENDIF
72623  IF(nprim.NE.2) THEN
72624 
72625 C...Predetermined and default matrix element kinds.
72626  ELSEIF(mstj(38).NE.0) THEN
72627  m3jc=mstj(38)
72628  alpha=parj(80)
72629  mstj(38)=0
72630  ELSEIF(mstj(47).GE.6) THEN
72631  m3jc=mstj(47)
72632  ELSE
72633  iclass=1
72634  icombi=4
72635 
72636 C...Vector/axial vector -> q + qbar; q -> q + V.
72637  IF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.(itypes.EQ.0.OR.
72638  & itypes.EQ.3)) THEN
72639  iclass=2
72640  IF(kfsrce.EQ.21.OR.kfsrce.EQ.22) THEN
72641  icombi=1
72642  ELSEIF(kfsrce.EQ.23.OR.(kfsrce.EQ.0.AND.
72643  & k(ipart(1),2)+k(ipart(2),2).EQ.0)) THEN
72644 C...gamma*/Z0: assume e+e- initial state if unknown.
72645  ei=-1d0
72646  IF(kfsrce.EQ.23) THEN
72647  iannfl=ipart1
72648  IF(k(iannfl,2).EQ.23) iannfl=k(iannfl,3)
72649  IF(iannfl.GT.0) THEN
72650  IF(k(iannfl,2).EQ.23) iannfl=k(iannfl,3)
72651  ENDIF
72652  IF(iannfl.NE.0) THEN
72653  kannfl=iabs(k(iannfl,2))
72654  IF(kannfl.GE.1.AND.kannfl.LE.18) ei=kchg(kannfl,1)/3d0
72655  ENDIF
72656  ENDIF
72657  ai=sign(1d0,ei+0.1d0)
72658  vi=ai-4d0*ei*paru(102)
72659  ef=kchg(kfla1,1)/3d0
72660  af=sign(1d0,ef+0.1d0)
72661  vf=af-4d0*ef*paru(102)
72662  xwc=1d0/(16d0*paru(102)*(1d0-paru(102)))
72663  sh=psum(5)**2
72664  sqmz=pmas(23,1)**2
72665  sqwz=psum(5)*pmas(23,2)
72666  sbwz=1d0/((sh-sqmz)**2+sqwz**2)
72667  vect=ei**2*ef**2+2d0*ei*vi*ef*vf*xwc*sh*(sh-sqmz)*sbwz+
72668  & (vi**2+ai**2)*vf**2*xwc**2*sh**2*sbwz
72669  axiv=(vi**2+ai**2)*af**2*xwc**2*sh**2*sbwz
72670  icombi=3
72671  alpha=vect/(vect+axiv)
72672  ELSEIF(kfsrce.EQ.24.OR.kfsrce.EQ.0) THEN
72673  icombi=4
72674  ENDIF
72675 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
72676  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.5) THEN
72677  iclass=2
72678  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
72679  & itypes.EQ.1)) THEN
72680  iclass=3
72681 
72682 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
72683  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.4) THEN
72684  iclass=4
72685  IF(kfsrce.EQ.25.OR.kfsrce.EQ.35.OR.kfsrce.EQ.37) THEN
72686  icombi=1
72687  ELSEIF(kfsrce.EQ.36) THEN
72688  icombi=2
72689  ENDIF
72690  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
72691  & itypes.EQ.1)) THEN
72692  iclass=5
72693 
72694 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
72695  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
72696  & itypes.EQ.3)) THEN
72697  iclass=6
72698  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
72699  & itypes.EQ.2)) THEN
72700  iclass=7
72701  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.itypes.EQ.4) THEN
72702  iclass=8
72703  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
72704  & itypes.EQ.2)) THEN
72705  iclass=9
72706 
72707 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
72708  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
72709  & itypes.EQ.5)) THEN
72710  iclass=10
72711  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
72712  & itypes.EQ.2)) THEN
72713  iclass=11
72714  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
72715  & itypes.EQ.1)) THEN
72716  iclass=12
72717 
72718 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
72719  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.itypes.EQ.6) THEN
72720  iclass=13
72721  ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
72722  & itypes.EQ.2)) THEN
72723  iclass=14
72724  ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
72725  & itypes.EQ.1)) THEN
72726  iclass=15
72727 
72728 C...g -> ~g + ~g (eikonal approximation).
72729  ELSEIF(itypmn.EQ.6.AND.itypmx.EQ.6.AND.itypes.EQ.0) THEN
72730  iclass=16
72731  ENDIF
72732 
72733 C...Revert to eikonal approximation for gluon in final state.
72734  IF(kfla1.EQ.21.OR.kfla2.EQ.21) iclass=1
72735 
72736  m3jc=5*iclass+icombi
72737  ENDIF
72738 
72739 C...Store pair that together define matrix element treatment.
72740  IF(m3jc.NE.0) THEN
72741  nmesys=1
72742  mesys(nmesys,0)=m3jc
72743  mesys(nmesys,1)=ipart(1)
72744  mesys(nmesys,2)=ipart(2)
72745  ENDIF
72746 
72747 C...Store qqbar or l+l- pairs for QED radiation.
72748  IF(kfla1.LE.18.AND.kfla2.LE.18) THEN
72749  nmesys=nmesys+1
72750  mesys(nmesys,0)=101
72751  IF(k(ipart(1),2)+k(ipart(2),2).EQ.0) mesys(nmesys,0)=102
72752  mesys(nmesys,1)=ipart(1)
72753  mesys(nmesys,2)=ipart(2)
72754  ENDIF
72755 
72756 C...Store other qqbar/l+l- pairs from g/gamma branchings.
72757  DO 290 i1=1,n
72758  IF(k(i1,1).GT.10.OR.iabs(k(i1,2)).GT.18) goto 290
72759  i1m=k(i1,3)
72760  260 IF(i1m.GT.0) THEN
72761  IF(k(i1m,2).EQ.k(i1,2)) THEN
72762  i1m=k(i1m,3)
72763  goto 260
72764  ENDIF
72765  ENDIF
72766 C...Move up this check to avoid out-of-bounds.
72767  IF(i1m.EQ.0) goto 290
72768  IF(k(i1m,2).NE.21.AND.k(i1m,2).NE.22) goto 290
72769  DO 280 i2=i1+1,n
72770  IF(k(i2,1).GT.10.OR.k(i2,2)+k(i1,2).NE.0) goto 280
72771  i2m=k(i2,3)
72772  270 IF(i2m.GT.0) THEN
72773  IF(k(i2m,2).EQ.k(i2,2)) THEN
72774  i2m=k(i2m,3)
72775  goto 270
72776  ENDIF
72777  ENDIF
72778  IF(i1m.EQ.i2m.AND.i1m.GT.0) THEN
72779  nmesys=nmesys+1
72780  mesys(nmesys,0)=66
72781  mesys(nmesys,1)=i1
72782  mesys(nmesys,2)=i2
72783  nmesys=nmesys+1
72784  mesys(nmesys,0)=102
72785  mesys(nmesys,1)=i1
72786  mesys(nmesys,2)=i2
72787  ENDIF
72788  280 CONTINUE
72789  290 CONTINUE
72790  ENDIF
72791 
72792 C..Loopback point for counting number of emissions.
72793  ngen=0
72794  300 ngen=ngen+1
72795 
72796 C...Begin loop to evolve all existing partons, if required.
72797  310 imx=0
72798  pt2mx=0d0
72799  DO 380 ievol=1,nevol
72800  IF(iflg(ievol).EQ.0) THEN
72801 
72802 C...Basic info on radiator and recoil.
72803  i=ipos(ievol)
72804  ir=irec(ievol)
72805  sht=shat(i,ir)
72806  pm2i=p(i,5)**2
72807  pm2r=p(ir,5)**2
72808 
72809 C...Skip any particles that are "turned off"
72810  IF (mstj(39).GT.0.AND.iabs(k(i,2)).EQ.mstj(39)) goto 380
72811 
72812 C...Invariant mass of "dipole".Starting value for pT evolution.
72813  shtcor=(sqrt(sht)-p(ir,5))**2-pm2i
72814  pt2=min(pt2cmx,0.25d0*shtcor,ptsca(ievol)**2)
72815 C.........else if IREC is potentially a soft gluon from the initial state
72816 C...Change the showering scale for initial-final dipoles
72817  IF(irif(ievol).EQ.1) THEN
72818 C...Make sure the recoiler is a different parton
72819  IF(i.EQ.ifp1) THEN
72820  ir=ifp2
72821  ELSE
72822  ir=ifp1
72823  ENDIF
72824 C...Recalculate quantities for new recoiler
72825  pm2r=p(ir,5)**2
72826  sht=shat(i,ir)
72827  shtcor=(sqrt(sht)-p(ir,5))**2-pm2i
72828  pt2new=min(pt2cmx,0.25d0*shtcor,ptsca(ievol)**2)
72829 C...If new pT2 is less than original, then don't change
72830  IF(pt2new.LE.pt2) THEN
72831  ir=irec(ievol)
72832  pm2r=p(ir,5)**2
72833  sht=shat(i,ir)
72834  shtcor=(sqrt(sht)-p(ir,5))**2-pm2i
72835  ELSE
72836  pt2=pt2new
72837  ENDIF
72838 C...Once the max scale is below threshold, turn off
72839 C IF(PT2NEW.EQ.PT2CMX) IRIF(IEVOL)=0
72840  ENDIF
72841 
72842 
72843 C...Case of evolution by QCD branching.
72844  IF(iscol(ievol).NE.0) THEN
72845 
72846 C...Parton-by-parton maximum scale from initial conditions.
72847  IF(mstp(72).EQ.0) THEN
72848  DO 320 iprt=1,nparts
72849  IF(ir.EQ.ipart(iprt)) pt2=min(pt2,ptpart(iprt)**2)
72850  320 CONTINUE
72851  ENDIF
72852 
72853 C...If kinematically impossible then do not evolve.
72854  IF(pt2.LT.pt2cmn) THEN
72855  iflg(ievol)=-1
72856  goto 380
72857  ENDIF
72858 
72859 C...Check if part of system for which ME corrections should be applied.
72860  imesys=0
72861  DO 330 ime=1,nmesys
72862  IF((i.EQ.mesys(ime,1).OR.i.EQ.mesys(ime,2)).AND.
72863  & mesys(ime,0).LT.100) imesys=ime
72864  330 CONTINUE
72865 
72866 C...Special flag for colour octet states.
72867 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
72868  moct=0
72869  kc = pycomp(k(i,2))
72870  IF(k(i,2).EQ.21) THEN
72871  moct=1
72872  ELSEIF(kchg(kc,2).EQ.2) THEN
72873  moct=2
72874  ENDIF
72875 C...QUARKONIA++
72876  IF(mstp(148).GE.1.AND.iabs(k(i,2)).EQ.9900101.AND.
72877  & iabs(k(i,2)).LE.9910555) moct=2
72878 C...QUARKONIA--
72879 
72880 
72881 C...Upper estimate for matrix element weighting and colour factor.
72882 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
72883  wtpsgl=2d0
72884  colfac=4d0/3d0
72885  IF(moct.GE.1) colfac=3d0/2d0
72886  IF(iglui.EQ.1.AND.imesys.EQ.1.AND.moct.EQ.0) colfac=3d0
72887  wtpsqq=0.5d0*0.5d0*nflav
72888 
72889 C...Determine overestimated z range: switch at c and b masses.
72890  340 izrg=1
72891  pt2mne=pt2cmn
72892  b0=27d0/6d0
72893  alams=alam3s
72894  IF(pt2.GT.1.01d0*pmcs) THEN
72895  izrg=2
72896  pt2mne=pmcs
72897  b0=25d0/6d0
72898  alams=alam4s
72899  ENDIF
72900  IF(pt2.GT.1.01d0*pmbs) THEN
72901  izrg=3
72902  pt2mne=pmbs
72903  b0=23d0/6d0
72904  alams=alam5s
72905  ENDIF
72906  zmncut=0.5d0-sqrt(max(0d0,0.25d0-pt2mne/shtcor))
72907  IF(zmncut.LT.1d-8) zmncut=pt2mne/shtcor
72908 
72909 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
72910  evemgl=wtpsgl*colfac*log(1d0/zmncut-1d0)/b0
72911  evcoef=evemgl
72912  IF(moct.EQ.1) THEN
72913  evemqq=wtpsqq*(1d0-2d0*zmncut)/b0
72914  evcoef=evcoef+evemqq
72915  ENDIF
72916 
72917 C...Pick pT2 (in overestimated z range).
72918  350 pt2=alams*(pt2/alams)**(pyr(0)**(1d0/evcoef))
72919 
72920 C...Loopback if crossed c/b mass thresholds.
72921  IF(izrg.EQ.3.AND.pt2.LT.pmbs) THEN
72922  pt2=pmbs
72923  goto 340
72924  ENDIF
72925  IF(izrg.EQ.2.AND.pt2.LT.pmcs) THEN
72926  pt2=pmcs
72927  goto 340
72928  ENDIF
72929 
72930 C...Finish if below lower cutoff.
72931  IF(pt2.LT.pt2cmn) THEN
72932  iflg(ievol)=-1
72933  goto 380
72934  ENDIF
72935 
72936 C...Check if we switch back to original "small" dipole
72937 C.....Should only have to check once if IR != IREC(IEVOL)
72938 C...IR has changed and IRIF flag is set and pT2 is "small"
72939  IF(ir.NE.irec(ievol).AND.irif(ievol).NE.0.AND.
72940  $ pt2.LT.0.25d0*shat(i,irec(ievol))) THEN
72941 C...Switch back to original recoiler and recalculate
72942  ir=irec(ievol)
72943  pm2r=p(ir,5)**2
72944  sht=shat(i,ir)
72945  shtcor=(sqrt(sht)-p(ir,5))**2-pm2i
72946  ENDIF
72947 
72948 
72949 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
72950 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
72951  iflag=1
72952  IF(moct.EQ.1.AND.evemgl.LT.pyr(0)*evcoef) iflag=2
72953 
72954 C...Pick z: dz/(1-z) or dz.
72955  IF(iflag.EQ.1) THEN
72956  z=1d0-zmncut*(1d0/zmncut-1d0)**pyr(0)
72957  ELSE
72958  z=zmncut+pyr(0)*(1d0-2d0*zmncut)
72959  ENDIF
72960 
72961 C...Loopback if outside allowed range for given pT2.
72962  zmnnow=0.5d0-sqrt(max(0d0,0.25d0-pt2/shtcor))
72963  IF(zmnnow.LT.1d-8) zmnnow=pt2/shtcor
72964  IF(z.LE.zmnnow.OR.z.GE.1d0-zmnnow) goto 350
72965  pm2=pm2i+pt2/(z*(1d0-z))
72966  IF(z*(1d0-z).LE.pm2*sht/(sht+pm2-pm2r)**2) goto 350
72967 
72968 C...No weighting for primary partons; to be done later on.
72969  IF(imesys.GT.0) THEN
72970 
72971 C...Weighting of q->qg/X->Xg branching.
72972  ELSEIF(iflag.EQ.1.AND.moct.NE.1) THEN
72973  IF(1d0+z**2.LT.wtpsgl*pyr(0)) goto 350
72974 
72975 C...Weighting of g->gg branching.
72976  ELSEIF(iflag.EQ.1) THEN
72977  IF(1d0+z**3.LT.wtpsgl*pyr(0)) goto 350
72978 
72979 C...Flavour choice and weighting of g->qqbar branching.
72980  ELSE
72981  kfq=min(5,1+int(nflav*pyr(0)))
72982  pmq=pmas(kfq,1)
72983  rootqq=sqrt(max(0d0,1d0-4d0*pmq**2/pm2))
72984  wtme=rootqq*(z**2+(1d0-z)**2)
72985  IF(wtme.LT.pyr(0)) goto 350
72986  iflag=10+kfq
72987  ENDIF
72988 
72989 C...Case of evolution by QED branching.
72990  ELSEIF(ischg(ievol).NE.0) THEN
72991 
72992 C...If kinematically impossible then do not evolve.
72993  pt2emn=pt0eq**2
72994  IF(iabs(k(i,2)).GT.10) pt2emn=pt0el**2
72995  IF(pt2.LT.pt2emn) THEN
72996  iflg(ievol)=-1
72997  goto 380
72998  ENDIF
72999 
73000 C...Check if part of system for which ME corrections should be applied.
73001  imesys=0
73002  DO 360 ime=1,nmesys
73003  IF((i.EQ.mesys(ime,1).OR.i.EQ.mesys(ime,2)).AND.
73004  & mesys(ime,0).GT.100) imesys=ime
73005  360 CONTINUE
73006 
73007 C...Charge. Matrix element weighting factor.
73008  chg=ischg(ievol)/3d0
73009  wtpsga=2d0
73010 
73011 C...Determine overestimated z range. Find evolution coefficient.
73012  zmncut=0.5d0-sqrt(max(0d0,0.25d0-pt2emn/shtcor))
73013  IF(zmncut.LT.1d-8) zmncut=pt2emn/shtcor
73014  evcoef=aem2pi*chg**2*wtpsga*log(1d0/zmncut-1d0)
73015 
73016 C...Pick pT2 (in overestimated z range).
73017  370 pt2=pt2*pyr(0)**(1d0/evcoef)
73018 
73019 C...Finish if below lower cutoff.
73020  IF(pt2.LT.pt2emn) THEN
73021  iflg(ievol)=-1
73022  goto 380
73023  ENDIF
73024 
73025 C...Pick z: dz/(1-z).
73026  z=1d0-zmncut*(1d0/zmncut-1d0)**pyr(0)
73027 
73028 C...Loopback if outside allowed range for given pT2.
73029  zmnnow=0.5d0-sqrt(max(0d0,0.25d0-pt2/shtcor))
73030  IF(zmnnow.LT.1d-8) zmnnow=pt2/shtcor
73031  IF(z.LE.zmnnow.OR.z.GE.1d0-zmnnow) goto 370
73032  pm2=pm2i+pt2/(z*(1d0-z))
73033  IF(z*(1d0-z).LE.pm2*sht/(sht+pm2-pm2r)**2) goto 370
73034 
73035 C...Weighting by branching kernel, except if ME weighting later.
73036  IF(imesys.EQ.0) THEN
73037  IF(1d0+z**2.LT.wtpsga*pyr(0)) goto 370
73038  ENDIF
73039  iflag=3
73040  ENDIF
73041 
73042 C...Save acceptable branching.
73043 C...If the recoiler changed, update
73044  irec(ievol)=ir
73045  iflg(ievol)=iflag
73046  imesav(ievol)=imesys
73047  pt2sav(ievol)=pt2
73048  zsav(ievol)=z
73049  shtsav(ievol)=sht
73050  ENDIF
73051 
73052 C...Check if branching has highest pT.
73053  IF(iflg(ievol).GE.1.AND.pt2sav(ievol).GT.pt2mx) THEN
73054  imx=ievol
73055  pt2mx=pt2sav(ievol)
73056  ENDIF
73057  380 CONTINUE
73058 
73059 C...Finished if no more branchings to be done.
73060  IF(imx.EQ.0) goto 520
73061 
73062 C...Restore info on hardest branching to be processed.
73063  i=ipos(imx)
73064  ir=irec(imx)
73065  kcol=iscol(imx)
73066  kcha=ischg(imx)
73067  imesys=imesav(imx)
73068  pt2=pt2sav(imx)
73069  z=zsav(imx)
73070  sht=shtsav(imx)
73071  pm2i=p(i,5)**2
73072  pm2r=p(ir,5)**2
73073  pm2=pm2i+pt2/(z*(1d0-z))
73074 
73075 
73076 C...Special flag for colour octet states.
73077  moct=0
73078  kc = pycomp(k(i,2))
73079  IF(k(i,2).EQ.21) THEN
73080  moct=1
73081  ELSEIF(kchg(kc,2).EQ.2) THEN
73082  moct=2
73083  ENDIF
73084 C...QUARKONIA++
73085  IF(mstp(148).GE.1.AND.iabs(k(i,2)).GE.9900101.AND.
73086  & iabs(k(i,2)).LE.9910555) moct=2
73087 C...QUARKONIA--
73088 
73089 C...Restore further info for g->qqbar branching.
73090  kfq=0
73091  IF(iflg(imx).GT.10) THEN
73092  kfq=iflg(imx)-10
73093  pmq=pmas(kfq,1)
73094  rootqq=sqrt(max(0d0,1d0-4d0*pmq**2/pm2))
73095  ENDIF
73096 
73097 C...For branching g include azimuthal asymmetries from polarization.
73098  asypol=0d0
73099  IF(moct.EQ.1.AND.mod(mstj(46),2).EQ.1) THEN
73100 C...Trace grandmother via intermediate recoil copies.
73101  kfgm=0
73102  im=i
73103  390 IF(k(im,3).NE.k(im-1,3).AND.k(im,3).NE.k(im+1,3).AND.
73104  & k(im,3).GT.0) THEN
73105  im=k(im,3)
73106  IF(im.GT.mint(84)) goto 390
73107  ENDIF
73108  igm=k(im,3)
73109  IF(igm.GT.mint(84).AND.igm.LT.im.AND.im.LE.i)
73110  & kfgm=iabs(k(igm,2))
73111 C...Define approximate energy sharing by identifying aunt.
73112  iau=im+1
73113  IF(iau.GT.n-3.OR.k(iau,3).NE.igm) iau=im-1
73114  IF(kfgm.NE.0.AND.(kfgm.LE.6.OR.kfgm.EQ.21)) THEN
73115  zold=p(im,4)/(p(im,4)+p(iau,4))
73116 C...Coefficient from gluon production.
73117  IF(kfgm.LE.6) THEN
73118  asypol=2d0*(1d0-zold)/(1d0+(1d0-zold)**2)
73119  ELSE
73120  asypol=((1d0-zold)/(1d0-zold*(1d0-zold)))**2
73121  ENDIF
73122 C...Coefficient from gluon decay.
73123  IF(kfq.EQ.0) THEN
73124  asypol=asypol*(z*(1d0-z)/(1d0-z*(1d0-z)))**2
73125  ELSE
73126  asypol=-asypol*2d0*z*(1d0-z)/(1d0-2d0*z*(1d0-z))
73127  ENDIF
73128  ENDIF
73129  ENDIF
73130 
73131 C...Create new slots for branching products and recoil.
73132  inew=n+1
73133  ignew=n+2
73134  irnew=n+3
73135  n=n+3
73136 
73137 C...Update location of hard final-state parton
73138  IF(i.EQ.ifp1) THEN
73139  ifp1=inew
73140  ELSEIF(i.EQ.ifp2) THEN
73141  ifp2=inew
73142  ENDIF
73143 C...Update location of recoiler
73144  IF(ir.EQ.ifp1) THEN
73145  ifp1=irnew
73146  ELSEIF(ir.EQ.ifp2) THEN
73147  ifp2=irnew
73148  ENDIF
73149 
73150 
73151 C...Set status, flavour and mother of new ones.
73152  k(inew,1)=k(i,1)
73153  k(ignew,1)=3
73154  IF(kcha.NE.0) k(ignew,1)=1
73155  k(irnew,1)=k(ir,1)
73156  IF(kfq.EQ.0) THEN
73157  k(inew,2)=k(i,2)
73158  k(ignew,2)=21
73159  IF(kcha.NE.0) k(ignew,2)=22
73160  ELSE
73161  k(inew,2)=-isign(kfq,kcol)
73162  k(ignew,2)=-k(inew,2)
73163  ENDIF
73164  k(irnew,2)=k(ir,2)
73165  k(inew,3)=i
73166  k(ignew,3)=i
73167  k(irnew,3)=ir
73168 
73169 C...Find rest frame and angles of branching+recoil.
73170  DO 400 j=1,5
73171  p(inew,j)=p(i,j)
73172  p(ignew,j)=0d0
73173  p(irnew,j)=p(ir,j)
73174  400 CONTINUE
73175  betax=(p(inew,1)+p(irnew,1))/(p(inew,4)+p(irnew,4))
73176  betay=(p(inew,2)+p(irnew,2))/(p(inew,4)+p(irnew,4))
73177  betaz=(p(inew,3)+p(irnew,3))/(p(inew,4)+p(irnew,4))
73178  CALL pyrobo(inew,irnew,0d0,0d0,-betax,-betay,-betaz)
73179  phi=pyangl(p(inew,1),p(inew,2))
73180  theta=pyangl(p(inew,3),sqrt(p(inew,1)**2+p(inew,2)**2))
73181 
73182 C...Derive kinematics of branching: generics (like g->gg).
73183  DO 410 j=1,4
73184  p(inew,j)=0d0
73185  p(irnew,j)=0d0
73186  410 CONTINUE
73187  pem=0.5d0*(sht+pm2-pm2r)/sqrt(sht)
73188  pzm=0.5d0*sqrt(max(0d0,(sht-pm2-pm2r)**2-4d0*pm2*pm2r)/sht)
73189  pt2cor=pm2*(pem**2*z*(1d0-z)-0.25d0*pm2)/pzm**2
73190  ptcor=sqrt(max(0d0,pt2cor))
73191  pzn=(pem**2*z-0.5d0*pm2)/pzm
73192  pzg=(pem**2*(1d0-z)-0.5d0*pm2)/pzm
73193 C...Specific kinematics reduction for q->qg with m_q > 0.
73194  IF(moct.NE.1) THEN
73195  ptcor=(1d0-pm2i/pm2)*ptcor
73196  pzn=pzn+pm2i*pzg/pm2
73197  pzg=(1d0-pm2i/pm2)*pzg
73198 C...Specific kinematics reduction for g->qqbar with m_q > 0.
73199  ELSEIF(kfq.NE.0) THEN
73200  p(inew,5)=pmq
73201  p(ignew,5)=pmq
73202  ptcor=rootqq*ptcor
73203  pzn=0.5d0*((1d0+rootqq)*pzn+(1d0-rootqq)*pzg)
73204  pzg=pzm-pzn
73205  ENDIF
73206 
73207 C...Pick phi and construct kinematics of branching.
73208  420 phirot=paru(2)*pyr(0)
73209  p(inew,1)=ptcor*cos(phirot)
73210  p(inew,2)=ptcor*sin(phirot)
73211  p(inew,3)=pzn
73212  p(inew,4)=sqrt(ptcor**2+p(inew,3)**2+p(inew,5)**2)
73213  p(ignew,1)=-p(inew,1)
73214  p(ignew,2)=-p(inew,2)
73215  p(ignew,3)=pzg
73216  p(ignew,4)=sqrt(ptcor**2+p(ignew,3)**2+p(ignew,5)**2)
73217  p(irnew,1)=0d0
73218  p(irnew,2)=0d0
73219  p(irnew,3)=-pzm
73220  p(irnew,4)=0.5d0*(sht+pm2r-pm2)/sqrt(sht)
73221 
73222 C...Boost branching system to lab frame.
73223  CALL pyrobo(inew,irnew,theta,phi,betax,betay,betaz)
73224 
73225 C...Renew choice of phi angle according to polarization asymmetry.
73226  IF(abs(asypol).GT.1d-3) THEN
73227  DO 430 j=1,3
73228  dpt(1,j)=p(i,j)
73229  dpt(2,j)=p(iau,j)
73230  dpt(3,j)=p(inew,j)
73231  430 CONTINUE
73232  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
73233  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
73234  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
73235  DO 440 j=1,3
73236  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/max(1d-10,dpmm)
73237  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/max(1d-10,dpmm)
73238  440 CONTINUE
73239  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
73240  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
73241  IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
73242  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
73243  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
73244  IF(1d0+asypol*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(asypol)))
73245  & goto 420
73246  ENDIF
73247  ENDIF
73248 
73249 C...Matrix element corrections for primary partons when requested.
73250  IF(imesys.GT.0) THEN
73251  m3jc=mesys(imesys,0)
73252 
73253 C...Identify recoiling partner and set up three-body kinematics.
73254  irp=mesys(imesys,1)
73255  IF(irp.EQ.i) irp=mesys(imesys,2)
73256  IF(irp.EQ.ir) irp=irnew
73257  DO 450 j=1,4
73258  psum(j)=p(inew,j)+p(irp,j)+p(ignew,j)
73259  450 CONTINUE
73260  psum(5)=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-
73261  & psum(3)**2))
73262  x1=2d0*(psum(4)*p(inew,4)-psum(1)*p(inew,1)-psum(2)*p(inew,2)-
73263  & psum(3)*p(inew,3))/psum(5)**2
73264  x2=2d0*(psum(4)*p(irp,4)-psum(1)*p(irp,1)-psum(2)*p(irp,2)-
73265  & psum(3)*p(irp,3))/psum(5)**2
73266  x3=2d0-x1-x2
73267  r1me=p(inew,5)/psum(5)
73268  r2me=p(irp,5)/psum(5)
73269 
73270 C...Matrix elements for gluon emission.
73271  IF(m3jc.LT.100) THEN
73272 
73273 C...Call ME, with right order important for two inequivalent showerers.
73274  IF(mesys(imesys,iord).EQ.i) THEN
73275  wme=pymael(m3jc,x1,x2,r1me,r2me,alpha)
73276  ELSE
73277  wme=pymael(m3jc,x2,x1,r2me,r1me,alpha)
73278  ENDIF
73279 
73280 C...Split up total ME when two radiating partons.
73281  isprad=1
73282  IF((m3jc.GE.16.AND.m3jc.LE.19).OR.(m3jc.GE.26.AND.m3jc.LE.29)
73283  & .OR.(m3jc.GE.36.AND.m3jc.LE.39).OR.(m3jc.GE.46.AND.m3jc.LE.49)
73284  & .OR.(m3jc.GE.56.AND.m3jc.LE.64)) isprad=0
73285  IF(isprad.EQ.1) wme=wme*max(1d-10,1d0+r1me**2-r2me**2-x1)/
73286  & max(1d-10,2d0-x1-x2)
73287 
73288 C...Evaluate shower rate.
73289  wps=2d0/(max(1d-10,2d0-x1-x2)*
73290  & max(1d-10,1d0+r2me**2-r1me**2-x2))
73291  IF(iglui.EQ.1) wps=(9d0/4d0)*wps
73292 
73293 C...Matrix elements for photon emission: still rather primitive.
73294  ELSE
73295 
73296 C...For generic charge combination currently only massless expression.
73297  IF(m3jc.EQ.101) THEN
73298  chg1=kchg(pycomp(k(i,2)),1)*isign(1,k(i,2))/3d0
73299  chg2=kchg(pycomp(k(irp,2)),1)*isign(1,k(irp,2))/3d0
73300  wme=(chg1*(1d0-x1)/x3-chg2*(1d0-x2)/x3)**2*(x1**2+x2**2)
73301  wps=2d0*(chg1**2*(1d0-x1)/x3+chg2**2*(1d0-x2)/x3)
73302 
73303 C...For flavour neutral system assume vector source and include masses.
73304  ELSE
73305  wme=pymael(11,x1,x2,r1me,r2me,0d0)*max(1d-10,
73306  & 1d0+r1me**2-r2me**2-x1)/max(1d-10,2d0-x1-x2)
73307  wps=2d0/(max(1d-10,2d0-x1-x2)*
73308  & max(1d-10,1d0+r2me**2-r1me**2-x2))
73309  ENDIF
73310  ENDIF
73311 
73312 C...Perform weighting with W_ME/W_PS.
73313  IF(wme.LT.pyr(0)*wps) THEN
73314  n=n-3
73315  iflg(imx)=0
73316  pt2cmx=pt2
73317  goto 310
73318  ENDIF
73319  ENDIF
73320 
73321 C...Now for sure accepted branching. Save highest pT.
73322  IF(ngen.EQ.1) ptgen=sqrt(pt2)
73323 
73324 C...Update status for obsolete ones. Bookkeep the moved original parton
73325 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
73326 C...Do not bookkeep radiated photon, since it cannot radiate further.
73327  k(i,1)=k(i,1)+10
73328  k(ir,1)=k(ir,1)+10
73329  DO 460 ip=1,npart
73330  IF(ipart(ip).EQ.i) ipart(ip)=inew
73331  IF(ipart(ip).EQ.ir) ipart(ip)=irnew
73332  460 CONTINUE
73333  IF(kcha.EQ.0) THEN
73334  npart=npart+1
73335  ipart(npart)=ignew
73336  ENDIF
73337 
73338 C...Initialize colour flow of branching.
73339 C...Use both old and new style colour tags for flexibility.
73340  k(inew,4)=0
73341  k(ignew,4)=0
73342  k(inew,5)=0
73343  k(ignew,5)=0
73344  jcolp=4+(1-kcol)/2
73345  jcoln=9-jcolp
73346  mct(inew,1)=0
73347  mct(inew,2)=0
73348  mct(ignew,1)=0
73349  mct(ignew,2)=0
73350  mct(irnew,1)=0
73351  mct(irnew,2)=0
73352 
73353 C...Trivial colour flow for l->lgamma and q->qgamma.
73354  IF(iabs(kcha).EQ.3) THEN
73355  k(i,4)=inew
73356  k(i,5)=ignew
73357  ELSEIF(kcha.NE.0) THEN
73358  IF(k(i,4).NE.0) THEN
73359  k(i,4)=k(i,4)+inew
73360  k(inew,4)=mstu(5)*i
73361  mct(inew,1)=mct(i,1)
73362  ENDIF
73363  IF(k(i,5).NE.0) THEN
73364  k(i,5)=k(i,5)+inew
73365  k(inew,5)=mstu(5)*i
73366  mct(inew,2)=mct(i,2)
73367  ENDIF
73368 
73369 C...Set colour flow for q->qg and g->gg.
73370  ELSEIF(kfq.EQ.0) THEN
73371  k(i,jcolp)=k(i,jcolp)+ignew
73372  k(ignew,jcolp)=mstu(5)*i
73373  k(inew,jcolp)=mstu(5)*ignew
73374  k(ignew,jcoln)=mstu(5)*inew
73375  mct(ignew,jcolp-3)=mct(i,jcolp-3)
73376  nct=nct+1
73377  mct(inew,jcolp-3)=nct
73378  mct(ignew,jcoln-3)=nct
73379  IF(moct.GE.1) THEN
73380  k(i,jcoln)=k(i,jcoln)+inew
73381  k(inew,jcoln)=mstu(5)*i
73382  mct(inew,jcoln-3)=mct(i,jcoln-3)
73383  ENDIF
73384 
73385 C...Set colour flow for g->qqbar.
73386  ELSE
73387  k(i,jcoln)=k(i,jcoln)+inew
73388  k(inew,jcoln)=mstu(5)*i
73389  k(i,jcolp)=k(i,jcolp)+ignew
73390  k(ignew,jcolp)=mstu(5)*i
73391  mct(inew,jcoln-3)=mct(i,jcoln-3)
73392  mct(ignew,jcolp-3)=mct(i,jcolp-3)
73393  ENDIF
73394 
73395 C...Daughter info for colourless recoiling parton.
73396  IF(k(ir,4).EQ.0.AND.k(ir,5).EQ.0) THEN
73397  k(ir,4)=irnew
73398  k(ir,5)=irnew
73399  k(irnew,4)=0
73400  k(irnew,5)=0
73401 
73402 C...Colour of recoiling parton sails through unchanged.
73403  ELSE
73404  IF(k(ir,4).NE.0) THEN
73405  k(ir,4)=k(ir,4)+irnew
73406  k(irnew,4)=mstu(5)*ir
73407  mct(irnew,1)=mct(ir,1)
73408  ENDIF
73409  IF(k(ir,5).NE.0) THEN
73410  k(ir,5)=k(ir,5)+irnew
73411  k(irnew,5)=mstu(5)*ir
73412  mct(irnew,2)=mct(ir,2)
73413  ENDIF
73414  ENDIF
73415 
73416 C...Vertex information trivial.
73417  DO 470 j=1,5
73418  v(inew,j)=v(i,j)
73419  v(ignew,j)=v(i,j)
73420  v(irnew,j)=v(ir,j)
73421  470 CONTINUE
73422 
73423 C...Update list of old radiators.
73424  DO 480 ievol=1,nevol
73425 C... A) radiator-recoiler mother pair for this branching
73426  IF(ipos(ievol).EQ.i.AND.irec(ievol).EQ.ir) THEN
73427  ipos(ievol)=inew
73428 C... A2) QCD branching and color side matches, radiated parton follows recoiler
73429  IF(kcol.NE.0.AND.iscol(ievol).EQ.kcol) ipos(ievol)=ignew
73430  irec(ievol)=irnew
73431  iflg(ievol)=0
73432  ELSEIF(ipos(ievol).EQ.i) THEN
73433 C... B) other dipoles with I as radiator simply get INEW as new radiator
73434  ipos(ievol)=inew
73435  iflg(ievol)=0
73436  ELSEIF(ipos(ievol).EQ.ir.AND.irec(ievol).EQ.i) THEN
73437 C... C) the "mirror image" of the parent dipole
73438  ipos(ievol)=irnew
73439  irec(ievol)=inew
73440 C... C2) QCD branching and color side matches, radiated parton follows recoiler
73441  IF(kcol.NE.0.AND.iscol(ievol).NE.kcol.AND.iscol(ievol).NE.0)
73442  & irec(ievol)=ignew
73443  iflg(ievol)=0
73444  ELSEIF(ipos(ievol).EQ.ir) THEN
73445 C... D) other dipoles with IR as radiator simply get IRNEW as new radiator
73446  ipos(ievol)=irnew
73447  iflg(ievol)=0
73448  ENDIF
73449 C... Update links of old connected partons.
73450  IF(irec(ievol).EQ.i) THEN
73451  irec(ievol)=inew
73452  iflg(ievol)=0
73453  ELSEIF(irec(ievol).EQ.ir) THEN
73454  irec(ievol)=irnew
73455  iflg(ievol)=0
73456  ENDIF
73457  480 CONTINUE
73458 
73459 C...q->qg or g->gg: create new gluon radiators.
73460  IF(kcol.NE.0.AND.kfq.EQ.0) THEN
73461  nevol=nevol+1
73462  ipos(nevol)=inew
73463  irec(nevol)=ignew
73464  iflg(nevol)=0
73465  iscol(nevol)=kcol
73466  ischg(nevol)=0
73467  ptsca(nevol)=sqrt(pt2)
73468  irif(nevol)=0
73469  nevol=nevol+1
73470  ipos(nevol)=ignew
73471  irec(nevol)=inew
73472  iflg(nevol)=0
73473  iscol(nevol)=-kcol
73474  ischg(nevol)=0
73475  ptsca(nevol)=ptsca(nevol-1)
73476  irif(nevol)=0
73477 C...g->qqbar: create new photon radiators.
73478  ELSEIF(kcol.EQ.2.AND.kfq.NE.0) THEN
73479  nevol=nevol+1
73480  ipos(nevol)=inew
73481  irec(nevol)=ignew
73482  iflg(nevol)=0
73483  iscol(nevol)=0
73484  ischg(nevol)=pyk(inew,6)
73485  ptsca(nevol)=sqrt(pt2)
73486  irif(nevol)=0
73487  nevol=nevol+1
73488  ipos(nevol)=ignew
73489  irec(nevol)=inew
73490  iflg(nevol)=0
73491  iscol(nevol)=0
73492  ischg(nevol)=pyk(ignew,6)
73493  ptsca(nevol)=sqrt(pt2)
73494  irif(nevol)=0
73495  ENDIF
73496 
73497 C...Check color and charge connections,
73498 C...Rewire if better partners can be found (screening, etc)
73499  DO 500 ievol=1,nevol
73500  kcol = iscol(ievol)
73501  kcha = ischg(ievol)
73502  irtmp = irec(ievol)
73503  itmp = ipos(ievol)
73504 C...Do not modify QED dipoles
73505  IF (kcha.NE.0) THEN
73506  goto 500
73507 C...Also skip dipole ends that are switched off
73508  ELSEIF (iflg(ievol).LE.-1) THEN
73509  goto 500
73510  ELSEIF (kcol.NE.0) THEN
73511 C...QCD dipoles. Check if current recoiler has appropriate color charge
73512  kcolr = pyk(irtmp,12)
73513  IF (kcolr.EQ.2.OR.kcolr.EQ.-kcol) goto 500
73514 C...If not, look for closest recoiler with appropriate color charge
73515  rm2min = psum(5)**2
73516  jmx = 0
73517  isgood = 0
73518  DO 490 jevol=1,nevol
73519 C...Skip self
73520  IF (jevol.EQ.ievol) goto 490
73521  jtmp = ipos(jevol)
73522  IF (jtmp.EQ.itmp) goto 490
73523  jcol = iscol(jevol)
73524 C...Skip dipole ends that are switched off
73525  IF (iflg(jevol).LE.-1) goto 490
73526 C...Skip QED dipole ends
73527  IF (ischg(jevol).NE.0) goto 490
73528 C... Skip wrong-color if at least one correct-color partner already found
73529  IF (isgood.NE.0.AND.jcol.NE.-kcol.AND.jcol.NE.2) goto 490
73530 C...Accept if smallest m2 so far, or if first with correct color
73531  rm2 = dotp(itmp,jtmp)
73532  isgnow = 0
73533  IF (jcol.EQ.-kcol.OR.jcol.EQ.2) isgnow=1
73534  IF (rm2.LT.rm2min.OR.isgnow.GT.isgood) THEN
73535  isgood = isgnow
73536  rm2min = rm2
73537  jmx = jevol
73538  ENDIF
73539  490 CONTINUE
73540 C...Update recoiler and reset dipole if new best partner found
73541  IF (jmx.NE.0) THEN
73542  irec(ievol) = ipos(jmx)
73543  iflg(ievol) = 0
73544  ENDIF
73545  ENDIF
73546  500 CONTINUE
73547 
73548 C...TMP! print out list of dipoles
73549 C DO 580 IEVOL=1,NEVOL
73550 C KCHA = ISCHG(IEVOL)
73551 C IF (KCHA.NE.0) THEN
73552 C print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL)
73553 C ELSE
73554 C print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL)
73555 C ENDIF
73556 C 580 CONTINUE
73557 
73558 C...Update matrix elements parton list and add new for g/gamma->qqbar.
73559  DO 510 ime=1,nmesys
73560  IF(mesys(ime,1).EQ.i) mesys(ime,1)=inew
73561  IF(mesys(ime,2).EQ.i) mesys(ime,2)=inew
73562  IF(mesys(ime,1).EQ.ir) mesys(ime,1)=irnew
73563  IF(mesys(ime,2).EQ.ir) mesys(ime,2)=irnew
73564  510 CONTINUE
73565  IF(kfq.NE.0) THEN
73566  nmesys=nmesys+1
73567  mesys(nmesys,0)=66
73568  mesys(nmesys,1)=inew
73569  mesys(nmesys,2)=ignew
73570  nmesys=nmesys+1
73571  mesys(nmesys,0)=102
73572  mesys(nmesys,1)=inew
73573  mesys(nmesys,2)=ignew
73574  ENDIF
73575 
73576 C...Global statistics.
73577  mint(353)=mint(353)+1
73578  vint(353)=vint(353)+ptcor
73579  IF (mint(353).EQ.1) vint(358)=ptcor
73580 
73581 C...Loopback for more emissions if enough space.
73582  pt2cmx=pt2
73583  IF(npart.LT.maxnur-1.AND.nevol.LT.2*maxnur-2.AND.
73584  &nmesys.LT.maxnur-2.AND.n.LT.mstu(4)-mstu(32)-5) THEN
73585  goto 300
73586  ELSE
73587  CALL pyerrm(11,'(PYPTFS:) no more memory left for shower')
73588  ENDIF
73589 
73590 C...Done.
73591  520 CONTINUE
73592 
73593  RETURN
73594  END
73595 
73596 C*********************************************************************
73597 
73598 C...PYMAEL
73599 C...Auxiliary to PYSHOW and PYPTFS.
73600 C...Matrix elements for gluon (or photon) emission from
73601 C...a two-body state; to be used by the parton shower routine.
73602 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
73603 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
73604 C... = (alpha-strong/2 pi) * CF * PYMAEL,
73605 C...i.e. normalization is such that one recovers the familiar
73606 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
73607 C...Coupling structure:
73608 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
73609 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
73610 C... = 16-19 : q -> q V
73611 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
73612 C... = 26-29 : q -> q S
73613 C... = 31-34 : V -> ~q ~qbar (~q = squark)
73614 C... = 36-39 : ~q -> ~q V
73615 C... = 41-44 : S -> ~q ~qbar
73616 C... = 46-49 : ~q -> ~q S
73617 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
73618 C... = 56-59 : ~q -> q chi
73619 C... = 61-64 : q -> ~q chi
73620 C... = 66-69 : ~g -> q ~qbar
73621 C... = 71-74 : ~q -> q ~g
73622 C... = 76-79 : q -> ~q ~g
73623 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
73624 C...Note that the order of the decay products is important.
73625 C...In each set of four, the variants are ordered as:
73626 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
73627 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
73628 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
73629 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
73630 
73631  FUNCTION pymael(NI,X1,X2,R1,R2,ALPHA)
73632 
73633 C...Double precision and integer declarations.
73634  IMPLICIT DOUBLE PRECISION(a-h, o-z)
73635  IMPLICIT INTEGER(i-n)
73636 
73637 C...Check input values. Return zero outside allowed phase space.
73638  pymael=0d0
73639  IF(x1.LE.2d0*r1.OR.x1.GE.1d0+r1**2-r2**2) RETURN
73640  IF(x2.LE.2d0*r2.OR.x2.GE.1d0+r2**2-r1**2) RETURN
73641  IF(x1+x2.LE.1d0+(r1+r2)**2) RETURN
73642  IF((2d0-2d0*x1-2d0*x2+x1*x2+2d0*r1**2+2d0*r2**2)**2.GE.
73643  &(x1**2-4d0*r1**2)*(x2**2-4d0*r2**2)) RETURN
73644  alpcor=max(0d0,min(1d0,alpha))
73645 
73646 C...Initial values and flags.
73647  iclass=ni/5
73648  icombi=ni-5*iclass
73649  isset1=0
73650  isset2=0
73651  isset4=0
73652 
73653 C... Phase space.
73654  ps=sqrt((1d0-(r1+r2)**2)*(1d0-(r1-r2)**2))
73655 
73656 C...Eikonal expression; also acts as default.
73657  IF(iclass.LE.1.OR.iclass.GE.17.OR.icombi.EQ.0) THEN
73658  rlo=ps
73659  IF(icombi.EQ.0.OR.icombi.EQ.1) THEN
73660  anum=0d0
73661  ELSEIF(icombi.EQ.2) THEN
73662  anum=(2d0-x1-x2)**2
73663  ELSEIF(icombi.EQ.3) THEN
73664  anum=alpcor*(2d0-x1-x2)**2
73665  ELSE
73666  anum=0.5d0*(2d0-x1-x2)**2
73667  ENDIF
73668  rfo=ps*2d0*((x1+x2-1d0+anum-r1**2-r2**2)/
73669  & ((1d0+r1**2-r2**2-x1)*(1d0+r2**2-r1**2-x2))-
73670  & r1**2/(1d0+r2**2-r1**2-x2)**2-
73671  & r2**2/(1d0+r1**2-r2**2-x1)**2)
73672  icombi=0
73673 
73674 C...V -> q qbar (V = gamma*/Z0/W+-/...).
73675  ELSEIF(iclass.EQ.2) THEN
73676  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
73677  rlo1=ps*(2-r1**2-r1**4+6*r1*r2-r2**2+2*r1**2*r2**2-r2**4)/2.d0
73678  rfo1=-1.d0*(3+6*r1**2+r1**4-6*r1*r2+6*r1**3*r2-2*r2**2
73679  & -6*r1**2*r2**2+6*r1*r2**3+r2**4-3*x1+6*r1*r2*x1
73680  & +2*r2**2*x1+x1**2-2*r1**2*x1**2+3*r1**2*(2-x1-x2)
73681  & +6*r1*r2*(2-x1-x2)-r2**2*(2-x1-x2)-2*x1*(2-x1-x2)
73682  & -5*r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)
73683  & -3*(2-x1-x2)**2-3*r1**2*(2-x1-x2)**2+r2**2*(2-x1-x2)**2
73684  & +2*x1*(2-x1-x2)**2+(2-x1-x2)**3-x2)/
73685  & (-1+r1**2-r2**2+x2)**2
73686  rfo1=rfo1-2*(-3+r1**2-6*r1*r2+6*r1**3*r2+3*r2**2-4*r1**2*r2**2
73687  & +6*r1*r2**3+2*x1+3*r1**2*x1+r2**2*x1-x1**2-r1**2*x1**2
73688  & -r2**2*x1**2+4*(2-x1-x2)+2*r1**2*(2-x1-x2)+3*r1*r2*(2-x1
73689  & -x2)-r2**2*(2-x1-x2)-3*x1*(2-x1-x2)-2*r1**2*x1*(2-x1-x2)
73690  & +x1**2*(2-x1-x2)-(2-x1-x2)**2-r1**2*(2-x1-x2)**2+r1*r2*(2
73691  & -x1-x2)**2+x1*(2-x1-x2)**2)/
73692  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73693  rfo1=rfo1-1.d0*(-1+2*r1**2+r1**4+6*r1*r2+6*r1**3*r2-2*r2**2
73694  & -6*r1**2*r2**2+6*r1*r2**3+r2**4-x1-2*r1**2*x1-6*r1*r2*x1
73695  & +8*r2**2*x1+x1**2-2*r2**2*x1**2-r1**2*(2-x1-x2)+r2**2*(2
73696  & -x1-x2)-r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*
73697  & (2-x1-x2)+x2)/(-1-r1**2+r2**2+x1)**2
73698  rfo1=rfo1/2.d0
73699  isset1=1
73700  ENDIF
73701  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
73702  rlo2=ps*(2-r1**2-r1**4-6*r1*r2-r2**2+2*r1**2*r2**2-r2**4)/2.d0
73703  rfo2=-1*(3+6*r1**2+r1**4+6*r1*r2-6*r1**3*r2-2*r2**2
73704  & -6*r1**2*r2**2-6*r1*r2**3+r2**4-3*x1-6*r1*r2*x1+2*r2**2*x1
73705  & +x1**2-2*r1**2*x1**2+3*r1**2*(2-x1-x2)-6*r1*r2*(2-x1-x2)
73706  & -r2**2*(2-x1-x2)-2*x1*(2-x1-x2)-5*r1**2*x1*(2-x1-x2)
73707  & +r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)-3*(2-x1-x2)**2
73708  & -3*r1**2*(2-x1-x2)**2+r2**2*(2-x1-x2)**2+2*x1*(2-x1-x2)**2
73709  & +(2-x1-x2)**3-x2)/(-1+r1**2-r2**2+x2)**2
73710  rfo2=rfo2-2*(-3+r1**2+6*r1*r2-6*r1**3*r2+3*r2**2-4*r1**2*r2**2
73711  & -6*r1*r2**3+2*x1+3*r1**2*x1+r2**2*x1-x1**2-r1**2*x1**2
73712  & -r2**2*x1**2+4*(2-x1-x2)+2*r1**2*(2-x1-x2)-3*r1*r2*(2-x1
73713  & -x2)-r2**2*(2-x1-x2)-3*x1*(2-x1-x2)-2*r1**2*x1*(2-x1-x2)
73714  & +x1**2*(2-x1-x2)-(2-x1-x2)**2-r1**2*(2-x1-x2)**2-r1*r2*(2
73715  & -x1-x2)**2+x1*(2-x1-x2)**2)/
73716  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73717  rfo2=rfo2-1*(-1+2*r1**2+r1**4-6*r1*r2-6*r1**3*r2-2*r2**2
73718  & -6*r1**2*r2**2-6*r1*r2**3+r2**4-x1-2*r1**2*x1+6*r1*r2*x1
73719  & +8*r2**2*x1+x1**2-2*r2**2*x1**2-r1**2*(2-x1-x2)+r2**2*(2-x1
73720  & -x2)-r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)
73721  & +x2)/(-1-r1**2+r2**2+x1)**2
73722  rfo2=rfo2/2.d0
73723  isset2=1
73724  ENDIF
73725  IF(icombi.EQ.4) THEN
73726  rlo4=ps*(2d0-r1**2-r1**4-r2**2+2d0*r1**2*r2**2-r2**4)/2d0
73727  rfo4=(1-r1**4+6*r1**2*r2**2-r2**4+x1+3*r1**2*x1-9*r2**2*x1
73728  & -3*x1**2-r1**2*x1**2+3*r2**2*x1**2+x1**3-x2-r1**2*x2
73729  & +r2**2*x2-r1**2*x1*x2+r2**2*x1*x2+x1**2*x2)/
73730  & (-1-r1**2+r2**2+x1)**2
73731  rfo4=rfo4
73732  & -2*(1+r1**2+r2**2-4*r1**2*r2**2+r1**2*x1+2*r2**2*x1-x1**2
73733  & -r2**2*x1**2+2*r1**2*x2+r2**2*x2-3*x1*x2+x1**2*x2-x2**2
73734  & -r1**2*x2**2+x1*x2**2)/
73735  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73736  rfo4=rfo4+(1-r1**4+6*r1**2*r2**2-r2**4-x1+r1**2*x1-r2**2*x1+x2
73737  & -9*r1**2*x2+3*r2**2*x2+r1**2*x1*x2-r2**2*x1*x2-3*x2**2
73738  & +3*r1**2*x2**2-r2**2*x2**2+x1*x2**2+x2**3)/
73739  & (-1+r1**2-r2**2+x2)**2
73740  rfo4=rfo4/2.d0
73741  isset4=1
73742  ENDIF
73743 
73744 C...q -> q V.
73745  ELSEIF(iclass.EQ.3) THEN
73746  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
73747  rlo1=ps*(1d0-2d0*r1**2+r1**4+r2**2-6d0*r1*r2**2
73748  & +r1**2*r2**2-2d0*r2**4)
73749  rfo1=2*(-1+r1-2*r1**2+2*r1**3-r1**4+r1**5-r2**2+r1*r2**2
73750  & -5*r1**2*r2**2+r1**3*r2**2-2*r1*r2**4+2*x1-2*r1*x1
73751  & +2*r1**2*x1-2*r1**3*x1+2*r2**2*x1+5*r1*r2**2*x1
73752  & +r1**2*r2**2*x1+2*r2**4*x1-x1**2+r1*x1**2-r2**2*x1**2+3*x2
73753  & +4*r1**2*x2+r1**4*x2+2*r2**2*x2+2*r1**2*r2**2*x2-4*x1*x2
73754  & -2*r1**2*x1*x2-r2**2*x1*x2+x1**2*x2-2*x2**2
73755  & -2*r1**2*x2**2+x1*x2**2)/(1-r1**2+r2**2-x2)/(-2+x1+x2)
73756  rfo1=rfo1+(2*r2**2+6*r1*r2**2-6*r1**2*r2**2+6*r1**3*r2**2
73757  & +2*r2**4+6*r1*r2**4-r2**2*x1+r1**2*r2**2*x1-r2**4*x1+x2
73758  & -r1**4*x2-3*r2**2*x2-6*r1*r2**2*x2+9*r1**2*r2**2*x2
73759  & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
73760  & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
73761  rfo1=rfo1+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4
73762  & +9*x1+10*r1**2*x1+r1**4*x1-3*r2**2*x1+6*r1*r2**2*x1
73763  & +r1**2*r2**2*x1-2*r2**4*x1-6*x1**2-2*r1**2*x1**2+x1**3
73764  & +7*x2+8*r1**2*x2+r1**4*x2-7*r2**2*x2+6*r1*r2**2*x2
73765  & +r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
73766  & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2
73767  & +2*r2**2*x2**2+x1*x2**2)/(-2+x1+x2)**2
73768  isset1=1
73769  ENDIF
73770  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
73771  rlo2=ps*(1d0-2d0*r1**2+r1**4+r2**2+6d0*r1*r2**2
73772  & +r1**2*r2**2-2d0*r2**4)
73773  rfo2=2*(1+r1+2*r1**2+2*r1**3+r1**4+r1**5+r2**2+r1*r2**2
73774  & +5*r1**2*r2**2+r1**3*r2**2-2*r1*r2**4-2*x1-2*r1*x1
73775  & -2*r1**2*x1-2*r1**3*x1-2*r2**2*x1+5*r1*r2**2*x1
73776  & -r1**2*r2**2*x1-2*r2**4*x1+x1**2+r1*x1**2+r2**2*x1**2-3*x2
73777  & -4*r1**2*x2-r1**4*x2-2*r2**2*x2-2*r1**2*r2**2*x2+4*x1*x2
73778  & +2*r1**2*x1*x2+r2**2*x1*x2-x1**2*x2+2*x2**2+2*r1**2*x2**2
73779  & -x1*x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
73780  rfo2=rfo2+(2*r2**2-6*r1*r2**2-6*r1**2*r2**2-6*r1**3*r2**2
73781  & +2*r2**4-6*r1*r2**4-r2**2*x1+r1**2*r2**2*x1-r2**4*x1+x2
73782  & -r1**4*x2-3*r2**2*x2+6*r1*r2**2*x2+9*r1**2*r2**2*x2
73783  & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
73784  & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
73785  rfo2=rfo2+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4+9*x1
73786  & +10*r1**2*x1+r1**4*x1-3*r2**2*x1-6*r1*r2**2*x1
73787  & +r1**2*r2**2*x1-2*r2**4*x1-6*x1**2-2*r1**2*x1**2+x1**3
73788  & +7*x2+8*r1**2*x2+r1**4*x2-7*r2**2*x2-6*r1*r2**2*x2
73789  & +r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
73790  & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2+2*r2**2*x2**2
73791  & +x1*x2**2)/(-2+x1+x2)**2
73792  isset2=1
73793  ENDIF
73794  IF(icombi.EQ.4) THEN
73795  rlo4=ps*(1.d0-2.d0*r1**2+r1**4+r2**2+r1**2*r2**2-2.d0*r2**4)
73796  rfo4=2*(1+2*r1**2+r1**4+r2**2+5*r1**2*r2**2-2*x1-2*r1**2*x1
73797  & -2*r2**2*x1-r1**2*r2**2*x1-2*r2**4*x1+x1**2+r2**2*x1**2
73798  & -3*x2-4*r1**2*x2-r1**4*x2-2*r2**2*x2-2*r1**2*r2**2*x2
73799  & +4*x1*x2+2*r1**2*x1*x2+r2**2*x1*x2-x1**2*x2+2*x2**2
73800  & +2*r1**2*x2**2-x1*x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
73801  rfo4=rfo4+(2*r2**2-6*r1**2*r2**2+2*r2**4-r2**2*x1+r1**2*r2**2*x1
73802  & -r2**4*x1+x2-r1**4*x2-3*r2**2*x2+9*r1**2*r2**2*x2
73803  & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
73804  & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
73805  rfo4=rfo4+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4+9*x1
73806  & +10*r1**2*x1+r1**4*x1-3*r2**2*x1+r1**2*r2**2*x1-2*r2**4*x1
73807  & -6*x1**2-2*r1**2*x1**2+x1**3+7*x2+8*r1**2*x2+r1**4*x2
73808  & -7*r2**2*x2+r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
73809  & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2+2*r2**2*x2**2
73810  & +x1*x2**2)/(2-x1-x2)**2
73811  isset4=1
73812  ENDIF
73813 
73814 C...S -> q qbar (S = h0/H0/A0/H+-/...).
73815  ELSEIF(iclass.EQ.4) THEN
73816  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
73817  rlo1=ps*(1d0-r1**2-r2**2-2d0*r1*r2)
73818  rfo1=-(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
73819  & +r2**4+x1-r1**2*x1+2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
73820  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
73821  & -2*(r1**2+r1**4-2*r1**3*r2+r2**2-6*r1**2*r2**2-2*r1*r2**3
73822  & +r2**4-r1**2*x1+r1*r2*x1+2*r2**2*x1+2*r1**2*x2+r1*r2*x2
73823  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73824  & -(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
73825  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
73826  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
73827  isset1=1
73828  ENDIF
73829  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
73830  rlo2=ps*(1d0-r1**2-r2**2+2d0*r1*r2)
73831  rfo2=-(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
73832  & +r2**4+x1-r1**2*x1-2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
73833  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
73834  & -(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
73835  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2
73836  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
73837  & +2*(-r1**2-r1**4-2*r1**3*r2-r2**2+6*r1**2*r2**2
73838  & -2*r1*r2**3-r2**4+r1**2*x1+r1*r2*x1-2*r2**2*x1
73839  & -2*r1**2*x2+r1*r2*x2+r2**2*x2+x1*x2)/
73840  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73841  isset2=1
73842  ENDIF
73843  IF(icombi.EQ.4) THEN
73844  rlo4=ps*(1d0-r1**2-r2**2)
73845  rfo4=-(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+3*r2**2*x1+x2
73846  & +r1**2*x2-r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
73847  & -2*(r1**2+r1**4+r2**2-6*r1**2*r2**2+r2**4-r1**2*x1
73848  & +2*r2**2*x1+2*r1**2*x2-r2**2*x2-x1*x2)/
73849  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73850  & -(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1
73851  & +x2+3*r1**2*x2-r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
73852  isset4=1
73853  ENDIF
73854 
73855 C...q -> q S.
73856  ELSEIF(iclass.EQ.5) THEN
73857  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
73858  rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
73859  rfo1=(4-4*r1**2+4*r2**2-3*x1-2*r1*x1+r1**2*x1-r2**2*x1-5*x2
73860  & -2*r1*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
73861  & +2*(3-r1-5*r1**2-r1**3+3*r2**2+r1*r2**2-2*x1-r1*x1
73862  & +r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
73863  & (1-r1**2+r2**2-x2)/(-2+x1+x2)
73864  & +(2-2*r1-6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1
73865  & -r2**2*x1-3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
73866  & (-1+r1**2-r2**2+x2)**2
73867  isset1=1
73868  ENDIF
73869  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
73870  rlo2=ps*(1d0+r1**2-r2**2-2d0*r1)
73871  rfo2=(4-4*r1**2+4*r2**2-3*x1+2*r1*x1+r1**2*x1-r2**2*x1-5*x2
73872  & +2*r1*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
73873  & +2*(3+r1-5*r1**2+r1**3+3*r2**2-r1*r2**2-2*x1+r1*x1
73874  & +r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
73875  & (1-r1**2+r2**2-x2)/(-2+x1+x2)
73876  & +(2+2*r1-6*r1**2+2*r1**3+2*r2**2+2*r1*r2**2-x1+r1**2*x1
73877  & -r2**2*x1-3*x2-2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
73878  & (-1+r1**2-r2**2+x2)**2
73879  isset2=1
73880  ENDIF
73881  IF(icombi.EQ.4) THEN
73882  rlo4=ps*(1d0+r1**2-r2**2)
73883  rfo4=(4-4*r1**2+4*r2**2-3*x1+r1**2*x1-r2**2*x1-5*x2+r1**2*x2
73884  & -r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
73885  & +2*(3-5*r1**2+3*r2**2-2*x1+r1**2*x1-4*x2+2*r1**2*x2
73886  & -r2**2*x2+x1*x2+x2**2)/(1-r1**2+r2**2-x2)/(-2+x1+x2)
73887  & +(2-6*r1**2+2*r2**2-x1+r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2
73888  & -r2**2*x2+x1*x2+x2**2)/(-1+r1**2-r2**2+x2)**2
73889  isset4=1
73890  ENDIF
73891 
73892 C...V -> ~q ~qbar (~q = squark).
73893  ELSEIF(iclass.EQ.6) THEN
73894  rlo1=ps*(1d0-2d0*r1**2+r1**4-2d0*r2**2-2d0*r1**2*r2**2+r2**4)
73895  rfo1=2d0*3d0+(1+r1**2+r2**2-x1)*(4*r1**2-x1**2)/
73896  & (-1-r1**2+r2**2+x1)**2
73897  & -2d0*(-1-3*r1**2-r2**2+x1+x1**2/2+x2-x1*x2/2)/
73898  & (-1-r1**2+r2**2+x1)
73899  & +(1+r1**2+r2**2-x2)*(4*r2**2-x2**2)
73900  & /(-1+r1**2-r2**2+x2)**2
73901  & -2d0*(-1-r1**2-3*r2**2+x1+x2-x1*x2/2+x2**2/2)/
73902  & (-1+r1**2-r2**2+x2)
73903  & -(-4*r1**2-4*r1**4-4*r2**2-8*r1**2*r2**2-4*r2**4+2*x1
73904  & +6*r1**2*x1+6*r2**2*x1-2*x1**2+2*x2+6*r1**2*x2+6*r2**2*x2
73905  & -4*x1*x2-2*r1**2*x1*x2-2*r2**2*x1*x2+x1**2*x2-2*x2**2
73906  & +x1*x2**2)/(-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73907  isset1=1
73908 
73909 C...~q -> ~q V.
73910  ELSEIF(iclass.EQ.7) THEN
73911  rlo1=ps*(1d0-2d0*r1**2+r1**4-2d0*r2**2-2d0*r1**2*r2**2+r2**4)
73912  rfo1=16*r2**2+8*(4*r2**2+2*r2**2*x1+x2+r1**2*x2+r2**2*x2-x1*x2
73913  & -2*x2**2)/(3*(-1+r1**2-r2**2+x2))+8*(1+r1**2+r2**2-x2)*
73914  & (4*r2**2-x2**2)/(3*(-1+r1**2-r2**2+x2)**2)+8*(x1+x2)*
73915  & (-1-2*r1**2-r1**4-2*r2**2+2*r1**2*r2**2-r2**4+2*x1
73916  & +2*r1**2*x1+2*r2**2*x1-x1**2+2*x2+2*r1**2*x2+2*r2**2*x2
73917  & -2*x1*x2-x2**2)/(3*(-2+x1+x2)**2)+8*(-1-r1**2+r2**2-x1)*
73918  & (2*r2**2*x1+x2+r1**2*x2+r2**2*x2-x1*x2-x2**2)/
73919  & (3*(-1+r1**2-r2**2+x2)*(-2+x1+x2))+8*(1+2*r1**2+r1**4
73920  & +2*r2**2-2*r1**2*r2**2+r2**4-2*x1-2*r1**2*x1-4*r2**2*x1
73921  & +x1**2-3*x2-3*r1**2*x2-3*r2**2*x2+3*x1*x2+2*x2**2)/
73922  & (3*(-2+x1+x2))
73923  rfo1=3d0*rfo1/8d0
73924  isset1=1
73925 
73926 C...S -> ~q ~qbar.
73927  ELSEIF(iclass.EQ.8) THEN
73928  rlo1=ps
73929  rfo1=(-1-2*r1**2-r1**4-2*r2**2+2*r1**2*r2**2-r2**4+2*x1
73930  & +2*r1**2*x1+2*r2**2*x1-x1**2-r2**2*x1**2+2*x2+2*r1**2*x2
73931  & +2*r2**2*x2-3*x1*x2-r1**2*x1*x2-r2**2*x1*x2+x1**2*x2-x2**2
73932  & -r1**2*x2**2+x1*x2**2)/
73933  & (1+r1**2-r2**2-x1)**2/(-1+r1**2-r2**2+x2)**2
73934  rfo1=2d0*rfo1
73935  isset1=1
73936 
73937 C...~q -> ~q S.
73938  ELSEIF(iclass.EQ.9) THEN
73939  rlo1=ps
73940  rfo1=(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
73941  & +(1+r1**2-r2**2+x1)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
73942  & -(x1+x2)/(-2+x1+x2)**2
73943  isset1=1
73944 
73945 C...chi -> q ~qbar (chi = neutralino/chargino).
73946  ELSEIF(iclass.EQ.10) THEN
73947  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
73948  rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
73949  rfo1=(2*r1+x1)*(-1-r1**2-r2**2+x1)/(-1-r1**2+r2**2+x1)**2
73950  & +2*(-1-r1**2-2*r1**3-r2**2-2*r1*r2**2+3*x1/2+r1*x1
73951  & -r1**2*x1/2-r2**2*x1/2+x2+r1*x2+r1**2*x2-x1*x2/2)/
73952  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73953  & +(2-2*r1-6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1
73954  & -r2**2*x1-3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
73955  & (-1+r1**2-r2**2+x2)**2
73956  isset1=1
73957  ENDIF
73958  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
73959  rlo2=ps*(1d0-2d0*r1+r1**2-r2**2)
73960  rfo2=(2*r1-x1)*(1+r1**2+r2**2-x1)/(-1-r1**2+r2**2+x1)**2
73961  & +2*(-1-r1**2+2*r1**3-r2**2+2*r1*r2**2+3*x1/2-r1*x1
73962  & -r1**2*x1/2-r2**2*x1/2+x2-r1*x2+r1**2*x2-x1*x2/2)/
73963  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73964  & +(2+2*r1-6*r1**2+2*r1**3+2*r2**2+2*r1*r2**2-x1+r1**2*x1
73965  & -r2**2*x1-3*x2-2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
73966  & (-1+r1**2-r2**2+x2)**2
73967  isset2=1
73968  ENDIF
73969  IF(icombi.EQ.4) THEN
73970  rlo4=ps*(1+r1**2-r2**2)
73971  rfo4=x1*(-1-r1**2-r2**2+x1)/(-1-r1**2+r2**2+x1)**2
73972  & +2d0*(-1-r1**2-r2**2+3*x1/2-r1**2*x1/2-r2**2*x1/2
73973  & +x2+r1**2*x2-x1*x2/2)/
73974  & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
73975  & +(2-6*r1**2+2*r2**2-x1+r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2
73976  & -r2**2*x2+x1*x2+x2**2)/(-1+r1**2-r2**2+x2)**2
73977  isset4=1
73978  ENDIF
73979 
73980 C...~q -> q chi.
73981  ELSEIF(iclass.EQ.11) THEN
73982  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
73983  rlo1=ps*(1d0-(r1+r2)**2)
73984  rfo1=(1+r1**2+2*r1*r2+r2**2-x1-x2)*(x1+x2)/(-2+x1+x2)**2
73985  & -(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
73986  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
73987  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
73988  & +(-1-2*r1**2-r1**4-2*r1*r2-2*r1**3*r2+2*r1*r2**3+r2**4
73989  & +x1+r1**2*x1-2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
73990  & +x1*x2+x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
73991  isset1=1
73992  ENDIF
73993  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
73994  rlo2=ps*(1d0-(r1-r2)**2)
73995  rfo2=(1+r1**2-2*r1*r2+r2**2-x1-x2)*(x1+x2)/
73996  & (-2+x1+x2)**2
73997  & -(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
73998  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2
73999  & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
74000  & +(-1-2*r1**2-r1**4+2*r1*r2+2*r1**3*r2-2*r1*r2**3+r2**4
74001  & +x1+r1**2*x1+2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
74002  & +x1*x2+x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
74003  isset2=1
74004  ENDIF
74005  IF(icombi.EQ.4) THEN
74006  rlo4=ps*(1d0-r1**2-r2**2)
74007  rfo4=(1+r1**2+r2**2-x1-x2)*(x1+x2)/(-2+x1+x2)**2
74008  & -(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1+x2
74009  & +3*r1**2*x2-r2**2*x2-x1*x2)/
74010  & (-1+r1**2-r2**2+x2)**2
74011  & -(-1-2*r1**2-r1**4+r2**4+x1+r1**2*x1-3*r2**2*x1
74012  & +2*r1**2*x2-2*r2**2*x2+x1*x2+x2**2)/
74013  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
74014  isset4=1
74015  ENDIF
74016 
74017 C...q -> ~q chi.
74018  ELSEIF(iclass.EQ.12) THEN
74019  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
74020  rlo1=ps*(1d0-r1**2+r2**2+2d0*r2)
74021  rfo1=(2*r2+x2)*(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
74022  & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1-2*r2*x1+r2**2*x1+x1**2
74023  & -3*x2-r1**2*x2-2*r2*x2+r2**2*x2+x1*x2)/
74024  & (-2+x1+x2)**2-2*(-1-r1**2+r2+r1**2*r2-r2**2-r2**3+x1
74025  & +r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
74026  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
74027  isset1=1
74028  END IF
74029  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
74030  rlo2=ps*(1d0-r1**2+r2**2-2d0*r2)
74031  rfo2=(2*r2-x2)*(1+r1**2+r2**2-x2)/(-1+r1**2-r2**2+x2)**2
74032  & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+2*r2*x1+r2**2*x1+x1**2
74033  & -3*x2-r1**2*x2+2*r2*x2+r2**2*x2+x1*x2)/
74034  & (-2+x1+x2)**2-2*(-1-r1**2-r2-r1**2*r2-r2**2+r2**3+x1
74035  & -r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
74036  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
74037  isset2=1
74038  END IF
74039  IF(icombi.EQ.4) THEN
74040  rlo4=ps*(1d0-r1**2+r2**2)
74041  rfo4=x2*(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
74042  & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+r2**2*x1+x1**2
74043  & -3*x2-r1**2*x2+r2**2*x2+x1*x2)/
74044  & (-2+x1+x2)**2-2*(-1-r1**2-r2**2+x1+r2**2*x1+2*x2
74045  & +r1**2*x2-x1*x2/2-x2**2/2)/
74046  & (2-x1-x2)/(-1+r1**2-r2**2+x2)
74047  isset4=1
74048  END IF
74049 
74050 C...~g -> q ~qbar.
74051  ELSEIF(iclass.EQ.13) THEN
74052  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
74053  rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
74054  rfo1=4*(2*r1+x1)*(-1-r1**2-r2**2+x1)/(3*(-1-r1**2+r2**2+x1)**2)
74055  & -(-1-r1**2-2*r1**3-r2**2-2*r1*r2**2+3*x1/2+r1*x1-r1**2*x1/2
74056  & -r2**2*x1/2+x2+r1*x2+r1**2*x2-x1*x2/2)/(3*(-1-r1**2+r2**2
74057  & +x1)*(-1+r1**2-r2**2+x2))-3*(-1+r1-r1**2-r1**3-r2**2
74058  & +r1*r2**2+2*x1+r2**2*x1-x1**2/2+x2+r1*x2+r1**2*x2-x1*x2/2)/
74059  & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+3*(4-4*r1**2+4*r2**2-3*x1
74060  & -2*r1*x1+r1**2*x1-r2**2*x1-5*x2-2*r1*x2+r1**2*x2-r2**2*x2
74061  & +x1*x2+x2**2)/(-2+x1+x2)**2+3*(3-r1-5*r1**2-r1**3+3*r2**2
74062  & +r1*r2**2-2*x1-r1*x1+r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2
74063  & +x1*x2+x2**2)/((1-r1**2+r2**2-x2)*(-2+x1+x2))+4*(2-2*r1
74064  & -6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1-r2**2*x1
74065  & -3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
74066  & (3*(-1+r1**2-r2**2+x2)**2)
74067  rfo1=3d0*rfo1/4d0
74068  isset1=1
74069  ENDIF
74070  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
74071  rlo2=ps*(1d0+r1**2-r2**2-2d0*r1)
74072  rfo2=4*(2*r1-x1)*(1+r1**2+r2**2-x1)/(3*(-1-r1**2+r2**2+x1)**2)
74073  & -3*(-1-r1-r1**2+r1**3-r2**2-r1*r2**2+2*x1+r2**2*x1-x1**2/2
74074  & +x2-r1*x2+r1**2*x2-x1*x2/2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
74075  & +(2+2*r1**2-4*r1**3+2*r2**2-4*r1*r2**2-3*x1+2*r1*x1
74076  & +r1**2*x1+r2**2*x1-2*x2+2*r1*x2-2*r1**2*x2+x1*x2)/
74077  & (6*(-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+3*(4-4*r1**2
74078  & +4*r2**2-3*x1+2*r1*x1+r1**2*x1-r2**2*x1-5*x2+2*r1*x2
74079  & +r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2+3*(3+r1
74080  & -5*r1**2+r1**3+3*r2**2-r1*r2**2-2*x1+r1*x1+r1**2*x1-4*x2
74081  & +2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
74082  & ((1-r1**2+r2**2-x2)*(-2+x1+x2))+4*(2+2*r1-6*r1**2+2*r1**3
74083  & +2*r2**2+2*r1*r2**2-x1+r1**2*x1-r2**2*x1-3*x2-2*r1*x2
74084  & +3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
74085  & (3*(-1+r1**2-r2**2+x2)**2)
74086  rfo2=3d0*rfo2/4d0
74087  isset2=1
74088  ENDIF
74089  IF(icombi.EQ.4) THEN
74090  rlo4=ps*(1d0+r1**2-r2**2)
74091  rfo4=8*x1*(-1-r1**2-r2**2+x1)/(3*(-1-r1**2+r2**2+x1)**2)-6*(-1
74092  & -r1**2-r2**2+2*x1+r2**2*x1-x1**2/2+x2+r1**2*x2-x1*x2/2)/
74093  & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+(2+2*r1**2+2*r2**2-3*x1
74094  & +r1**2*x1+r2**2*x1-2*x2-2*r1**2*x2+x1*x2)/(3*(-1-r1**2
74095  & +r2**2+x1)*(-1+r1**2-r2**2+x2))+6*(4-4*r1**2+4*r2**2-3*x1
74096  & +r1**2*x1-r2**2*x1-5*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/
74097  & (-2+x1+x2)**2+6*(3-5*r1**2+3*r2**2-2*x1+r1**2*x1-4*x2
74098  & +2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
74099  & ((1-r1**2+r2**2-x2)*(-2+x1+x2))+8*(2-6*r1**2+2*r2**2-x1
74100  & +r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
74101  & (3*(-1+r1**2-r2**2+x2)**2)
74102  rfo4=3d0*rfo4/8d0
74103  isset4=1
74104  ENDIF
74105 
74106 C...~q -> q ~g.
74107  ELSEIF(iclass.EQ.14) THEN
74108  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
74109  rlo1=ps*(1-r1**2-r2**2-2d0*r1*r2)
74110  rfo1=64*(1+r1**2+2*r1*r2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)
74111  & -16*(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
74112  & +r2**4+x1-r1**2*x1+2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
74113  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2-16*(r1**2+r1**4
74114  & -2*r1**3*r2+r2**2-6*r1**2*r2**2-2*r1*r2**3+r2**4
74115  & -r1**2*x1+r1*r2*x1+2*r2**2*x1+2*r1**2*x2+r1*r2*x2-r2**2*x2
74116  & -x1*x2)/((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))
74117  & -64*(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
74118  & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
74119  & -r2**2*x2-x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)
74120  & +8*(-1+r1**4-2*r1*r2+2*r1**3*r2-2*r2**2-2*r1*r2**3-r2**4
74121  & -2*r1**2*x1+2*r2**2*x1+x1**2+x2-3*r1**2*x2-2*r1*r2*x2
74122  & +r2**2*x2+x1*x2)/((-1-r1**2+r2**2+x1)*(-2+x1+x2))
74123  rfo1=rfo1
74124  & +8*(-1-2*r1**2-r1**4-2*r1*r2-2*r1**3*r2+2*r1*r2**3+r2**4
74125  & +x1+r1**2*x1-2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
74126  & +x1*x2+x2**2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
74127  rfo1=9d0*rfo1/64d0
74128  isset1=1
74129  ENDIF
74130  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
74131  rlo2=ps*(1-r1**2-r2**2+2d0*r1*r2)
74132  rfo2=64*(1+r1**2-2*r1*r2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)
74133  & -16*(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
74134  & +r2**4+x1-r1**2*x1-2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
74135  & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2-64*(-1+r1**4
74136  & +2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3+r2**4+x1
74137  & -r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2-r2**2*x2
74138  & -x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)+16*(-r1**2-r1**4
74139  & -2*r1**3*r2-r2**2+6*r1**2*r2**2-2*r1*r2**3-r2**4+r1**2*x1
74140  & +r1*r2*x1-2*r2**2*x1-2*r1**2*x2+r1*r2*x2+r2**2*x2+x1*x2)/
74141  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))
74142  rfo2=rfo2
74143  & +8*(-1+r1**4+2*r1*r2-2*r1**3*r2-2*r2**2+2*r1*r2**3-r2**4
74144  & -2*r1**2*x1+2*r2**2*x1+x1**2+x2-3*r1**2*x2+2*r1*r2*x2
74145  & +r2**2*x2+x1*x2)/((-1-r1**2+r2**2+x1)*(-2+x1+x2))
74146  & +8*(-1-2*r1**2-r1**4+2*r1*r2+2*r1**3*r2-2*r1*r2**3
74147  & +r2**4+x1+r1**2*x1+2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2
74148  & -2*r2**2*x2+x1*x2+x2**2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
74149  rfo2=9d0*rfo2/64d0
74150  isset2=1
74151  ENDIF
74152  IF(icombi.EQ.4) THEN
74153  rlo4=ps*(1-r1**2-r2**2)
74154  rfo4=128*(1+r1**2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)-32*(-1
74155  & +r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+3*r2**2*x1+x2
74156  & +r1**2*x2-r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
74157  & -32*(r1**2+r1**4+r2**2-6*r1**2*r2**2+r2**4-r1**2*x1
74158  & +2*r2**2*x1+2*r1**2*x2-r2**2*x2-x1*x2)/
74159  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))-128*(-1+r1**4
74160  & -6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2
74161  & -r2**2*x2-x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)
74162  & +16*(-1+r1**4-2*r2**2-r2**4-2*r1**2*x1+2*r2**2*x1+x1**2
74163  & +x2-3*r1**2*x2+r2**2*x2+x1*x2)/
74164  & ((-1-r1**2+r2**2+x1)*(-2+x1+ x2))
74165  rfo4=rfo4+16*(-1-2*r1**2-r1**4+r2**4+x1+r1**2*x1-3*r2**2*x1
74166  & +2*r1**2*x2-2*r2**2*x2+x1*x2+x2**2)/
74167  & (9*(1-r1**2+r2**2-x2)*(-2+x1+x2))
74168  rfo4=9d0*rfo4/128d0
74169  isset4=1
74170  ENDIF
74171 
74172 C...q -> ~q ~g.
74173  ELSEIF(iclass.EQ.15) THEN
74174  IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
74175  rlo1=ps*(1d0-r1**2+r2**2+2d0*r2)
74176  rfo1=32*(2*r2+x2)*(-1-r1**2-r2**2+x2)/(9*(-1+r1**2-r2**2+x2)**2)
74177  & +8*(-1-r1**2-2*r1**2*r2-r2**2-2*r2**3+x1+r2*x1+r2**2*x1
74178  & +3*x2/2-r1**2*x2/2+r2*x2-r2**2*x2/2-x1*x2/2)/
74179  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+8*(2+2*r1**2-2*r2
74180  & -2*r1**2*r2-6*r2**2-2*r2**3-3*x1-r1**2*x1+2*r2*x1
74181  & +3*r2**2*x1+x1**2-x2-r1**2*x2+r2**2*x2+x1*x2)/
74182  & (-1-r1**2+r2**2+x1)**2+32*(4+4*r1**2-4*r2**2-5*x1
74183  & -r1**2*x1-2*r2*x1+r2**2*x1+x1**2-3*x2-r1**2*x2-2*r2*x2
74184  & +r2**2*x2+x1*x2)/(9*(-2+x1+x2)**2)
74185  rfo1=rfo1+8*(3+3*r1**2-r2+r1**2*r2-5*r2**2-r2**3-4*x1-r1**2*x1
74186  & +2*r2**2*x1+x1**2-2*x2-r2*x2+r2**2*x2+x1*x2)/
74187  & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+8*(-1-r1**2+r2+r1**2*r2
74188  & -r2**2-r2**3+x1+r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2
74189  & -x2**2/2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
74190  rfo1=9d0*rfo1/32d0
74191  isset1=1
74192  END IF
74193  IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
74194  rlo2=ps*(1d0-r1**2+r2**2-2d0*r2)
74195  rfo2=32*(2*r2-x2)*(1+r1**2+r2**2-x2)/(9*(-1+r1**2-r2**2+x2)**2)
74196  & +8*(-1-r1**2+2*r1**2*r2-r2**2+2*r2**3+x1-r2*x1+r2**2*x1
74197  & +3*x2/2-r1**2*x2/2-r2*x2-r2**2*x2/2-x1*x2/2)/
74198  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+8*(2+2*r1**2+2*r2
74199  & +2*r1**2*r2-6*r2**2+2*r2**3-3*x1-r1**2*x1-2*r2*x1
74200  & +3*r2**2*x1+x1**2-x2-r1**2*x2+r2**2*x2+x1*x2)/
74201  & (-1-r1**2+r2**2+x1)**2+8*(3+3*r1**2+r2-r1**2*r2-5*r2**2
74202  & +r2**3-4*x1-r1**2*x1+2*r2**2*x1+x1**2-2*x2+r2*x2+r2**2*x2
74203  & +x1*x2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
74204  rfo2=rfo2+32*(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+2*r2*x1+r2**2*x1
74205  & +x1**2-3*x2-r1**2*x2+2*r2*x2+r2**2*x2+x1*x2)/
74206  & (9*(-2+x1+x2)**2)+8*(-1-r1**2-r2-r1**2*r2-r2**2+r2**3+x1
74207  & -r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
74208  & (9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
74209  rfo2=9d0*rfo2/32d0
74210  isset2=1
74211  END IF
74212  IF(icombi.EQ.4) THEN
74213  rlo4=ps*(1d0-r1**2+r2**2)
74214  rfo4=64*x2*(-1-r1**2-r2**2+x2)/(9*(-1+r1**2-r2**2+x2)**2)
74215  & +16*(-1-r1**2-r2**2+x1+r2**2*x1+3*x2/2-r1**2*x2/2
74216  & -r2**2*x2/2-x1*x2/2)/
74217  & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+16*(3+3*r1**2
74218  & -5*r2**2-4*x1-r1**2*x1+2*r2**2*x1+x1**2-2*x2+r2**2*x2
74219  & +x1*x2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
74220  & +64*(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+r2**2*x1+x1**2-3*x2
74221  & -r1**2*x2+r2**2*x2+x1*x2)/(9*(-2+x1+x2)**2)
74222  rfo4=rfo4+16*(2+2*r1**2-6*r2**2-3*x1-r1**2*x1+3*r2**2*x1+x1**2
74223  & -x2-r1**2*x2+r2**2*x2+x1*x2)/(-1-r1**2+r2**2+x1)**2
74224  & +16*(-1-r1**2-r2**2+x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2
74225  & -x2**2/2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
74226  rfo4=9d0*rfo4/64d0
74227  isset4=1
74228  END IF
74229 
74230 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
74231  ELSEIF(iclass.EQ.16) THEN
74232  rlo=ps
74233  IF(icombi.EQ.0.OR.icombi.EQ.1) THEN
74234  anum=0d0
74235  ELSEIF(icombi.EQ.2) THEN
74236  anum=(2d0-x1-x2)**2
74237  ELSEIF(icombi.EQ.3) THEN
74238  anum=alpcor*(2d0-x1-x2)**2
74239  ELSE
74240  anum=0.5d0*(2d0-x1-x2)**2
74241  ENDIF
74242  rfo=ps*2d0*((x1+x2-1d0+anum-r1**2-r2**2)/
74243  & ((1d0+r1**2-r2**2-x1)*(1d0+r2**2-r1**2-x2))-
74244  & r1**2/(1d0+r2**2-r1**2-x2)**2-
74245  & r2**2/(1d0+r1**2-r2**2-x1)**2)
74246  rfo=9d0*rfo/4d0
74247  icombi=0
74248  ENDIF
74249 
74250 C...Find relevant LO and FO expression.
74251  IF(icombi.EQ.0) THEN
74252  ELSEIF(icombi.EQ.1.AND.isset1.EQ.1) THEN
74253  rlo=rlo1
74254  rfo=rfo1
74255  ELSEIF(icombi.EQ.2.AND.isset2.EQ.1) THEN
74256  rlo=rlo2
74257  rfo=rfo2
74258  ELSEIF(icombi.EQ.3.AND.isset1.EQ.1.AND.isset2.EQ.1) THEN
74259  rlo=alpcor*rlo1+(1d0-alpcor)*rlo2
74260  rfo=alpcor*rfo1+(1d0-alpcor)*rfo2
74261  ELSEIF(isset4.EQ.1) THEN
74262  rlo=rlo4
74263  rfo=rfo4
74264  ELSEIF(icombi.EQ.4.AND.isset1.EQ.1.AND.isset2.EQ.1) THEN
74265  rlo=0.5d0*(rlo1+rlo2)
74266  rfo=0.5d0*(rfo1+rfo2)
74267  ELSEIF(isset1.EQ.1) THEN
74268  rlo=rlo1
74269  rfo=rfo1
74270  ELSE
74271  CALL pyerrm(16,'(PYMAEL:) not implemented ME code')
74272  rlo=1d0
74273  rfo=0d0
74274  ENDIF
74275 
74276 C...Output.
74277  pymael=rfo/rlo
74278 
74279  RETURN
74280  END
74281 
74282 C*********************************************************************
74283 
74284 C...PYBOEI
74285 C...Modifies an event so as to approximately take into account
74286 C...Bose-Einstein effects according to a simple phenomenological
74287 C...parametrization.
74288 
74289  SUBROUTINE pyboei(NSAV)
74290 
74291 C...Double precision and integer declarations.
74292  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74293  IMPLICIT INTEGER(i-n)
74294  INTEGER pyk,pychge,pycomp
74295 C...Parameter statement to help give large particle numbers.
74296  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74297  &kexcit=4000000,kdimen=5000000)
74298 C...Commonblocks.
74299  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74300  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74301  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74302  common/pyint1/mint(400),vint(400)
74303  SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/
74304 C...Local arrays and data.
74305  dimension dps(4),kfbe(9),nbe(0:10),bei(100),bei3(100),
74306  &beiw(100),bei3w(100)
74307  DATA kfbe/211,-211,111,321,-321,130,310,221,331/
74308 C...Statement function: squared invariant mass.
74309  sdip(i,j)=((p(i,4)+p(j,4))**2-(p(i,3)+p(j,3))**2-
74310  &(p(i,2)+p(j,2))**2-(p(i,1)+p(j,1))**2)
74311 
74312 C...Boost event to overall CM frame. Calculate CM energy.
74313  IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
74314  DO 100 j=1,4
74315  dps(j)=0d0
74316  100 CONTINUE
74317  DO 120 i=1,n
74318  kfa=iabs(k(i,2))
74319  IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22)
74320  & .AND.k(i,3).GT.0) THEN
74321  kfma=iabs(k(k(i,3),2))
74322  IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)
74323  ENDIF
74324  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120
74325  DO 110 j=1,4
74326  dps(j)=dps(j)+p(i,j)
74327  110 CONTINUE
74328  120 CONTINUE
74329  CALL pyrobo(0,0,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
74330  &-dps(3)/dps(4))
74331  pecm=0d0
74332  DO 130 i=1,n
74333  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
74334  130 CONTINUE
74335 
74336 C...Check if we have separated strings
74337 
74338 C...Reserve copy of particles by species at end of record.
74339  iwp=0
74340  iwn=0
74341  nbe(0)=n+mstu(3)
74342  nmax=nbe(0)
74343  smmin=pecm
74344  DO 190 ibe=1,min(10,mstj(52)+1)
74345  nbe(ibe)=nbe(ibe-1)
74346  DO 180 i=nsav+1,n
74347  IF(ibe.EQ.min(10,mstj(52)+1)) THEN
74348  DO 140 iibe=1,ibe-1
74349  IF(k(i,2).EQ.kfbe(iibe)) goto 180
74350  140 CONTINUE
74351  ELSE
74352  IF(k(i,2).NE.kfbe(ibe)) goto 180
74353  ENDIF
74354  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 180
74355  IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
74356  CALL pyerrm(11,'(PYBOEI:) no more memory left in PYJETS')
74357  RETURN
74358  ENDIF
74359  nbe(ibe)=nbe(ibe)+1
74360  nmax=nbe(ibe)
74361  k(nbe(ibe),1)=i
74362  k(nbe(ibe),2)=0
74363  k(nbe(ibe),3)=0
74364  k(nbe(ibe),4)=0
74365  k(nbe(ibe),5)=0
74366  p(nbe(ibe),1)=0.0d0
74367  p(nbe(ibe),2)=0.0d0
74368  p(nbe(ibe),3)=0.0d0
74369  p(nbe(ibe),4)=0.0d0
74370  p(nbe(ibe),5)=0.0d0
74371  smmin=min(smmin,p(i,5))
74372 C...Check if particles comes from different W's or Z's
74373  IF((mstj(53).NE.0.OR.mstj(56).GT.0).AND.mint(32).EQ.0) THEN
74374  im=i
74375  150 IF(k(im,3).GT.0) THEN
74376  im=k(im,3)
74377  IF(abs(k(im,2)).NE.24.AND.k(im,2).NE.23) goto 150
74378  k(nbe(ibe),5)=im
74379  IF(iwp.EQ.0.AND.k(im,2).EQ.24) iwp=im
74380  IF(iwn.EQ.0.AND.k(im,2).EQ.-24) iwn=im
74381  IF(iwp.EQ.0.AND.k(im,2).EQ.23) iwp=im
74382  IF(iwn.EQ.0.AND.k(im,2).EQ.23.AND.im.NE.iwp) iwn=im
74383  ENDIF
74384  ENDIF
74385 C...Check if particles comes from different strings.
74386  IF(parj(94).GT.0.0d0) THEN
74387  im=i
74388  160 IF(k(im,3).GT.0) THEN
74389  im=k(im,3)
74390  IF(k(im,2).NE.92.AND.k(im,2).NE.91) goto 160
74391  k(nbe(ibe),5)=im
74392  ENDIF
74393  ENDIF
74394  DO 170 j=1,3
74395  p(nbe(ibe),j)=0d0
74396  v(nbe(ibe),j)=0d0
74397  170 CONTINUE
74398  p(nbe(ibe),5)=-1.0d0
74399  180 CONTINUE
74400  190 CONTINUE
74401  IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) goto 510
74402 
74403 C...Calculate separation between W+ and W- or between two Z0's.
74404 C...No separation if there has been re-connections.
74405  sigw=parj(93)
74406  IF(iwp.GT.0.AND.iwn.GT.0.AND.mstj(56).GT.0.AND.mint(32).EQ.0) THEN
74407  IF(k(iwp,2).EQ.23) THEN
74408  dmw=pmas(23,1)
74409  dgw=pmas(23,2)
74410  ELSE
74411  dmw=pmas(24,1)
74412  dgw=pmas(24,2)
74413  ENDIF
74414  dmp=p(iwp,5)
74415  dmn=p(iwn,5)
74416  taupd=dmp/sqrt((dmp**2-dmw**2)**2+(dgw*(dmp**2)/dmw)**2)
74417  taund=dmn/sqrt((dmn**2-dmw**2)**2+(dgw*(dmn**2)/dmw)**2)
74418  taup=-taupd*log(pyr(idum))
74419  taun=-taund*log(pyr(idum))
74420  dxp=taup*pyp(iwp,8)/dmp
74421  dxn=taun*pyp(iwn,8)/dmn
74422  dx=dxp+dxn
74423  sigw=1.0d0/(1.0d0/parj(93)+REAL(mstj(56))*dx)
74424  IF(parj(94).LT.0.0d0) sigw=1.0d0/(1.0d0/sigw-1.0d0/parj(94))
74425  ENDIF
74426 
74427 C...Add separation between strings.
74428  IF(parj(94).GT.0.0d0) THEN
74429  sigw=1.0d0/(1.0d0/sigw+1.0d0/parj(94))
74430  iwp=-1
74431  iwn=-1
74432  ENDIF
74433 
74434  IF(mstj(57).EQ.1.AND.mstj(54).LT.0) THEN
74435  DO 220 ibe=1,min(9,mstj(52))
74436  DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)
74437  q2min=pecm**2
74438  i1=k(i1m,1)
74439  DO 200 i2m=nbe(ibe-1)+1,nbe(ibe)
74440  IF(i2m.EQ.i1m) goto 200
74441  i2=k(i2m,1)
74442  q2=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-
74443  & (p(i1,2)+p(i2,2))**2-(p(i1,3)+p(i2,3))**2-
74444  & (p(i1,5)+p(i2,5))**2
74445  IF(q2.GT.0.0d0.AND.q2.LT.q2min) THEN
74446  q2min=q2
74447  ENDIF
74448  200 CONTINUE
74449  p(i1m,5)=q2min
74450  210 CONTINUE
74451  220 CONTINUE
74452  ENDIF
74453 
74454 C...Tabulate integral for subsequent momentum shift.
74455  DO 400 ibe=1,min(9,mstj(52))
74456  IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) goto 270
74457  IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))
74458  & .LE.1) goto 270
74459  IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
74460  & nbe(7)-nbe(6)).LE.1) goto 270
74461  IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) goto 270
74462  IF(ibe.EQ.1) pmhq=2d0*pymass(211)
74463  IF(ibe.EQ.4) pmhq=2d0*pymass(321)
74464  IF(ibe.EQ.8) pmhq=2d0*pymass(221)
74465  IF(ibe.EQ.9) pmhq=2d0*pymass(331)
74466  qdel=0.1d0*min(pmhq,parj(93))
74467  qdel3=0.1d0*min(pmhq,parj(93)*3.0d0)
74468  qdelw=0.1d0*min(pmhq,sigw)
74469  qdel3w=0.1d0*min(pmhq,sigw*3.0d0)
74470  IF(mstj(51).EQ.1) THEN
74471  nbin=min(100,nint(9d0*parj(93)/qdel))
74472  nbin3=min(100,nint(27d0*parj(93)/qdel3))
74473  nbinw=min(100,nint(9d0*sigw/qdelw))
74474  nbin3w=min(100,nint(27d0*sigw/qdel3w))
74475  beex=exp(0.5d0*qdel/parj(93))
74476  beex3=exp(0.5d0*qdel3/(3.0d0*parj(93)))
74477  beexw=exp(0.5d0*qdelw/sigw)
74478  beex3w=exp(0.5d0*qdel3w/(3.0d0*sigw))
74479  bert=exp(-qdel/parj(93))
74480  bert3=exp(-qdel3/(3.0d0*parj(93)))
74481  bertw=exp(-qdelw/sigw)
74482  bert3w=exp(-qdel3w/(3.0d0*sigw))
74483  ELSE
74484  nbin=min(100,nint(3d0*parj(93)/qdel))
74485  nbin3=min(100,nint(9d0*parj(93)/qdel3))
74486  nbinw=min(100,nint(3d0*sigw/qdelw))
74487  nbin3w=min(100,nint(9d0*sigw/qdel3w))
74488  ENDIF
74489  DO 230 ibin=1,nbin
74490  qbin=qdel*(ibin-0.5d0)
74491  bei(ibin)=qdel*(qbin**2+qdel**2/12d0)/sqrt(qbin**2+pmhq**2)
74492  IF(mstj(51).EQ.1) THEN
74493  beex=beex*bert
74494  bei(ibin)=bei(ibin)*beex
74495  ELSE
74496  bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
74497  ENDIF
74498  IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
74499  230 CONTINUE
74500  DO 240 ibin=1,nbin3
74501  qbin=qdel3*(ibin-0.5d0)
74502  bei3(ibin)=qdel3*(qbin**2+qdel3**2/12d0)/sqrt(qbin**2+pmhq**2)
74503  IF(mstj(51).EQ.1) THEN
74504  beex3=beex3*bert3
74505  bei3(ibin)=bei3(ibin)*beex3
74506  ELSE
74507  bei3(ibin)=bei3(ibin)*exp(-(qbin/(3.0d0*parj(93)))**2)
74508  ENDIF
74509  IF(ibin.GE.2) bei3(ibin)=bei3(ibin)+bei3(ibin-1)
74510  240 CONTINUE
74511  DO 250 ibin=1,nbinw
74512  qbin=qdelw*(ibin-0.5d0)
74513  beiw(ibin)=qdelw*(qbin**2+qdelw**2/12d0)/sqrt(qbin**2+pmhq**2)
74514  IF(mstj(51).EQ.1) THEN
74515  beexw=beexw*bertw
74516  beiw(ibin)=beiw(ibin)*beexw
74517  ELSE
74518  beiw(ibin)=beiw(ibin)*exp(-(qbin/sigw)**2)
74519  ENDIF
74520  IF(ibin.GE.2) beiw(ibin)=beiw(ibin)+beiw(ibin-1)
74521  250 CONTINUE
74522  DO 260 ibin=1,nbin3w
74523  qbin=qdel3w*(ibin-0.5d0)
74524  bei3w(ibin)=qdel3w*(qbin**2+qdel3w**2/12d0)/
74525  & sqrt(qbin**2+pmhq**2)
74526  IF(mstj(51).EQ.1) THEN
74527  beex3w=beex3w*bert3w
74528  bei3w(ibin)=bei3w(ibin)*beex3w
74529  ELSE
74530  bei3w(ibin)=bei3w(ibin)*exp(-(qbin/(3.0d0*sigw))**2)
74531  ENDIF
74532  IF(ibin.GE.2) bei3w(ibin)=bei3w(ibin)+bei3w(ibin-1)
74533  260 CONTINUE
74534 
74535 C...Loop through particle pairs and find old relative momentum.
74536  270 DO 390 i1m=nbe(ibe-1)+1,nbe(ibe)-1
74537  i1=k(i1m,1)
74538  DO 380 i2m=i1m+1,nbe(ibe)
74539  IF(mstj(53).EQ.1.AND.k(i1m,5).NE.k(i2m,5)) goto 380
74540  IF(mstj(53).EQ.2.AND.k(i1m,5).EQ.k(i2m,5)) goto 380
74541  i2=k(i2m,1)
74542  q2old=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
74543  & p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2
74544  IF(q2old.LE.0.0d0) goto 380
74545  qold=sqrt(q2old)
74546 
74547 C...Calculate new relative momentum.
74548  qmov=0.0d0
74549  qmov3=0.0d0
74550  qmovw=0.0d0
74551  qmov3w=0.0d0
74552  IF(qold.LT.1d-3*qdel) THEN
74553  goto 280
74554  ELSEIF(qold.LE.qdel) THEN
74555  qmov=qold/3d0
74556  ELSEIF(qold.LT.(nbin-0.1d0)*qdel) THEN
74557  rbin=qold/qdel
74558  ibin=rbin
74559  rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
74560  qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
74561  & sqrt(q2old+pmhq**2)/q2old
74562  ELSE
74563  qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
74564  ENDIF
74565  280 q2new=q2old*(qold/(qold+3d0*parj(92)*qmov))**(2d0/3d0)
74566  IF(qold.LT.1d-3*qdel3) THEN
74567  goto 290
74568  ELSEIF(qold.LE.qdel3) THEN
74569  qmov3=qold/3d0
74570  ELSEIF(qold.LT.(nbin3-0.1d0)*qdel3) THEN
74571  rbin3=qold/qdel3
74572  ibin3=rbin3
74573  rinp3=(rbin3**3-ibin3**3)/(3*ibin3*(ibin3+1)+1)
74574  qmov3=(bei3(ibin3)+rinp3*(bei3(ibin3+1)-bei3(ibin3)))*
74575  & sqrt(q2old+pmhq**2)/q2old
74576  ELSE
74577  qmov3=bei3(nbin3)*sqrt(q2old+pmhq**2)/q2old
74578  ENDIF
74579  290 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3))**(2d0/3d0)
74580  rscale=1.0d0
74581  IF(mstj(54).EQ.2)
74582  & rscale=1.0d0-exp(-(qold/(2d0*parj(93)))**2)
74583  IF((iwp.NE.-1.AND.mstj(56).LE.0).OR.iwp.EQ.0.OR.iwn.EQ.0.OR.
74584  & k(i1m,5).EQ.k(i2m,5)) goto 320
74585 
74586  IF(qold.LT.1d-3*qdelw) THEN
74587  goto 300
74588  ELSEIF(qold.LE.qdelw) THEN
74589  qmovw=qold/3d0
74590  ELSEIF(qold.LT.(nbinw-0.1d0)*qdelw) THEN
74591  rbinw=qold/qdelw
74592  ibinw=rbinw
74593  rinpw=(rbinw**3-ibinw**3)/(3*ibinw*(ibinw+1)+1)
74594  qmovw=(beiw(ibinw)+rinpw*(beiw(ibinw+1)-beiw(ibinw)))*
74595  & sqrt(q2old+pmhq**2)/q2old
74596  ELSE
74597  qmovw=beiw(nbinw)*sqrt(q2old+pmhq**2)/q2old
74598  ENDIF
74599  300 q2new=q2old*(qold/(qold+3d0*parj(92)*qmovw))**(2d0/3d0)
74600  IF(qold.LT.1d-3*qdel3w) THEN
74601  goto 310
74602  ELSEIF(qold.LE.qdel3w) THEN
74603  qmov3w=qold/3d0
74604  ELSEIF(qold.LT.(nbin3w-0.1d0)*qdel3w) THEN
74605  rbin3w=qold/qdel3w
74606  ibin3w=rbin3w
74607  rinp3w=(rbin3w**3-ibin3w**3)/(3*ibin3w*(ibin3w+1)+1)
74608  qmov3w=(bei3w(ibin3w)+rinp3w*(bei3w(ibin3w+1)-
74609  & bei3w(ibin3w)))*sqrt(q2old+pmhq**2)/q2old
74610  ELSE
74611  qmov3w=bei3w(nbin3w)*sqrt(q2old+pmhq**2)/q2old
74612  ENDIF
74613  310 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3w))**(2d0/3d0)
74614  IF(mstj(54).EQ.2)
74615  & rscale=1.0d0-exp(-(qold/(2d0*sigw))**2)
74616 
74617  320 CALL pybesq(i1,i2,nmax,q2old,q2new)
74618  DO 330 j=1,3
74619  p(i1m,j)=p(i1m,j)+p(nmax+1,j)
74620  p(i2m,j)=p(i2m,j)+p(nmax+2,j)
74621  330 CONTINUE
74622  IF(mstj(54).GE.1) THEN
74623  CALL pybesq(i1,i2,nmax,q2old,q2new3)
74624  DO 340 j=1,3
74625  v(i1m,j)=v(i1m,j)+p(nmax+1,j)*rscale
74626  v(i2m,j)=v(i2m,j)+p(nmax+2,j)*rscale
74627  340 CONTINUE
74628  ELSEIF(mstj(54).LE.-1) THEN
74629  edel=p(i1,4)+p(i2,4)-
74630  & sqrt(max(q2new-q2old+(p(i1,4)+p(i2,4))**2,0.0d0))
74631  a2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
74632  & (p(i1,3)-p(i2,3))**2
74633  wmax=-1.0d20
74634  mi3=0
74635  mi4=0
74636  s12=sdip(i1,i2)
74637  sm1=(p(i1,5)+smmin)**2
74638  DO 360 i3m=nbe(0)+1,nbe(min(10,mstj(52)+1))
74639  IF(i3m.EQ.i1m.OR.i3m.EQ.i2m) goto 360
74640  IF(mstj(53).EQ.1.AND.k(i3m,5).NE.k(i1m,5)) goto 360
74641  IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
74642  & k(i3m,5).NE.k(i1m,5)) goto 360
74643  i3=k(i3m,1)
74644  IF(k(i3,2).EQ.k(i1,2)) goto 360
74645  s13=sdip(i1,i3)
74646  s23=sdip(i2,i3)
74647  sm3=(p(i3,5)+smmin)**2
74648  IF(mstj(54).EQ.-2) THEN
74649  wi=(min(s12*sm3,s13*min(sm1,sm3),
74650  & s23*min(sm1,sm3))*sm1)
74651  ELSE
74652  wi=((p(i1,4)+p(i2,4)+p(i3,4))**2-
74653  & (p(i1,3)+p(i2,3)+p(i3,3))**2-
74654  & (p(i1,2)+p(i2,2)+p(i3,2))**2-
74655  & (p(i1,1)+p(i2,1)+p(i3,1))**2)
74656  ENDIF
74657  IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0) THEN
74658  IF (wmax*wi.GE.(1.0d0-exp(-p(i3m,5)/(parj(93)**2))))
74659  & goto 360
74660  ELSE
74661  IF(wmax*wi.GE.1.0) goto 360
74662  ENDIF
74663  DO 350 i4m=i3m+1,nbe(min(10,mstj(52)+1))
74664  IF(i4m.EQ.i1m.OR.i4m.EQ.i2m) goto 350
74665  IF(mstj(53).EQ.1.AND.k(i4m,5).NE.k(i1m,5)) goto 350
74666  IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
74667  & k(i4m,5).NE.k(i1m,5)) goto 350
74668  i4=k(i4m,1)
74669  IF(k(i3,2).EQ.k(i4,2).OR.k(i4,2).EQ.k(i1,2))
74670  & goto 350
74671  IF((p(i3,4)+p(i4,4)+edel)**2.LT.
74672  & (p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
74673  & (p(i3,3)+p(i4,3))**2+(p(i3,5)+p(i4,5))**2)
74674  & goto 350
74675  IF(mstj(54).EQ.-2) THEN
74676  s14=sdip(i1,i4)
74677  s24=sdip(i2,i4)
74678  s34=sdip(i3,i4)
74679  w=s12*min(min(s23,s24),min(s13,s14))*s34
74680  w=min(w,s13*min(min(s23,s34),s12)*s24)
74681  w=min(w,s14*min(min(s24,s34),s12)*s23)
74682  w=min(w,min(s23,s24)*s13*s14)
74683  w=1.0d0/w
74684  ELSE
74685 C...weight=1-cos(theta)/mtot2
74686  s1234=(p(i1,4)+p(i2,4)+p(i3,4)+p(i4,4))**2-
74687  & (p(i1,3)+p(i2,3)+p(i3,3)+p(i4,3))**2-
74688  & (p(i1,2)+p(i2,2)+p(i3,2)+p(i4,2))**2-
74689  & (p(i1,1)+p(i2,1)+p(i3,1)+p(i4,1))**2
74690  w=1.0d0/s1234
74691  IF(w.LE.wmax) goto 350
74692  ENDIF
74693  IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0)
74694  & w=w*(1.0d0-exp(-p(i3m,5)/(parj(93)**2)))
74695  IF(mstj(57).EQ.1.AND.p(i4m,5).GT.0)
74696  & w=w*(1.0d0-exp(-p(i4m,5)/(parj(93)**2)))
74697  IF(w.LE.wmax) goto 350
74698  mi3=i3m
74699  mi4=i4m
74700  wmax=w
74701  350 CONTINUE
74702  360 CONTINUE
74703  IF(mi4.EQ.0) goto 380
74704  i3=k(mi3,1)
74705  i4=k(mi4,1)
74706  eold=p(i3,4)+p(i4,4)
74707  enew=eold+edel
74708  p2=(p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
74709  & (p(i3,3)+p(i4,3))**2
74710  q2newp=max(0.0d0,enew**2-p2-(p(i3,5)+p(i4,5))**2)
74711  q2oldp=max(0.0d0,eold**2-p2-(p(i3,5)+p(i4,5))**2)
74712  CALL pybesq(i3,i4,nmax,q2oldp,q2newp)
74713  DO 370 j=1,3
74714  v(mi3,j)=v(mi3,j)+p(nmax+1,j)
74715  v(mi4,j)=v(mi4,j)+p(nmax+2,j)
74716  370 CONTINUE
74717  ENDIF
74718  380 CONTINUE
74719  390 CONTINUE
74720  400 CONTINUE
74721 
74722 C...Shift momenta and recalculate energies.
74723  esump=0.0d0
74724  esum=0.0d0
74725  prod=0.0d0
74726  DO 430 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
74727  i=k(im,1)
74728  esump=esump+p(i,4)
74729  DO 410 j=1,3
74730  p(i,j)=p(i,j)+p(im,j)
74731  410 CONTINUE
74732  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
74733  esum=esum+p(i,4)
74734  DO 420 j=1,3
74735  prod=prod+v(im,j)*p(i,j)/p(i,4)
74736  420 CONTINUE
74737  430 CONTINUE
74738 
74739  parj(96)=0.0d0
74740  IF(mstj(54).NE.0.AND.prod.NE.0.0d0) THEN
74741  440 alpha=(esump-esum)/prod
74742  parj(96)=parj(96)+alpha
74743  prod=0.0d0
74744  esum=0.0d0
74745  DO 470 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
74746  i=k(im,1)
74747  DO 450 j=1,3
74748  p(i,j)=p(i,j)+alpha*v(im,j)
74749  450 CONTINUE
74750  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
74751  esum=esum+p(i,4)
74752  DO 460 j=1,3
74753  prod=prod+v(im,j)*p(i,j)/p(i,4)
74754  460 CONTINUE
74755  470 CONTINUE
74756  IF(prod.NE.0.0d0.AND.abs(esump-esum)/pecm.GT.0.00001d0)
74757  & goto 440
74758  ENDIF
74759 
74760 C...Rescale all momenta for energy conservation.
74761  pes=0d0
74762  pqs=0d0
74763  DO 480 i=1,n
74764  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 480
74765  pes=pes+p(i,4)
74766  pqs=pqs+p(i,5)**2/p(i,4)
74767  480 CONTINUE
74768  parj(95)=pes-pecm
74769  fac=(pecm-pqs)/(pes-pqs)
74770  DO 500 i=1,n
74771  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 500
74772  DO 490 j=1,3
74773  p(i,j)=fac*p(i,j)
74774  490 CONTINUE
74775  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
74776  500 CONTINUE
74777 
74778 C...Boost back to correct reference frame.
74779  510 CALL pyrobo(0,0,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
74780  DO 520 i=1,n
74781  IF(k(i,1).LT.0) k(i,1)=-k(i,1)
74782  520 CONTINUE
74783 
74784  RETURN
74785  END
74786 
74787 C*********************************************************************
74788 
74789 C...PYBESQ
74790 C...Calculates the momentum shift in a system of two particles assuming
74791 C...the relative momentum squared should be shifted to Q2NEW. NI is the
74792 C...last position occupied in /PYJETS/.
74793 
74794  SUBROUTINE pybesq(I1,I2,NI,Q2OLD,Q2NEW)
74795 
74796 C...Double precision and integer declarations.
74797  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74798  IMPLICIT INTEGER(i-n)
74799  INTEGER pyk,pychge,pycomp
74800 C...Parameter statement to help give large particle numbers.
74801  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74802  &kexcit=4000000,kdimen=5000000)
74803 C...Commonblocks.
74804  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74805  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74806  SAVE /pyjets/,/pydat1/
74807 C...Local arrays and data.
74808  dimension dp(5)
74809  SAVE hc1
74810 
74811  IF(mstj(55).EQ.0) THEN
74812  dq2=q2new-q2old
74813  dp2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
74814  & (p(i1,3)-p(i2,3))**2
74815  dp12=p(i1,1)**2+p(i1,2)**2+p(i1,3)**2
74816  & -p(i2,1)**2-p(i2,2)**2-p(i2,3)**2
74817  se=p(i1,4)+p(i2,4)
74818  de=p(i1,4)-p(i2,4)
74819  dq2se=dq2+se**2
74820  da=se*de*dp12-dp2*dq2se
74821  db=dp2*dq2se-dp12**2
74822  ha=(da+sqrt(max(da**2+dq2*(dq2+se**2-de**2)*db,0d0)))/(2d0*db)
74823  DO 100 j=1,3
74824  pd=ha*(p(i1,j)-p(i2,j))
74825  p(ni+1,j)=pd
74826  p(ni+2,j)=-pd
74827  100 CONTINUE
74828  RETURN
74829  ENDIF
74830 
74831  k(ni+1,1)=1
74832  k(ni+2,1)=1
74833  DO 110 j=1,5
74834  p(ni+1,j)=p(i1,j)
74835  p(ni+2,j)=p(i2,j)
74836  dp(j)=p(i1,j)+p(i2,j)
74837  110 CONTINUE
74838 
74839 C...Boost to cms and rotate first particle to z-axis
74840  CALL pyrobo(ni+1,ni+2,0.0d0,0.0d0,
74841  &-dp(1)/dp(4),-dp(2)/dp(4),-dp(3)/dp(4))
74842  phi=pyangl(p(ni+1,1),p(ni+1,2))
74843  the=pyangl(p(ni+1,3),sqrt(p(ni+1,1)**2+p(ni+1,2)**2))
74844  s=q2new+(p(i1,5)+p(i2,5))**2
74845  pz=0.5d0*sqrt(q2new*(s-(p(i1,5)-p(i2,5))**2)/s)
74846  p(ni+1,1)=0.0d0
74847  p(ni+1,2)=0.0d0
74848  p(ni+1,3)=pz
74849  p(ni+1,4)=sqrt(pz**2+p(i1,5)**2)
74850  p(ni+2,1)=0.0d0
74851  p(ni+2,2)=0.0d0
74852  p(ni+2,3)=-pz
74853  p(ni+2,4)=sqrt(pz**2+p(i2,5)**2)
74854  dp(4)=sqrt(dp(1)**2+dp(2)**2+dp(3)**2+s)
74855  CALL pyrobo(ni+1,ni+2,the,phi,
74856  &dp(1)/dp(4),dp(2)/dp(4),dp(3)/dp(4))
74857 
74858  DO 120 j=1,3
74859  p(ni+1,j)=p(ni+1,j)-p(i1,j)
74860  p(ni+2,j)=p(ni+2,j)-p(i2,j)
74861  120 CONTINUE
74862 
74863  RETURN
74864  END
74865 
74866 C*********************************************************************
74867 
74868 C...PYMASS
74869 C...Gives the mass of a particle/parton.
74870 
74871  FUNCTION pymass(KF)
74872 
74873 C...Double precision and integer declarations.
74874  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74875  IMPLICIT INTEGER(i-n)
74876  INTEGER pyk,pychge,pycomp
74877 C...Commonblocks.
74878  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74879  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74880  SAVE /pydat1/,/pydat2/
74881 
74882 C...Reset variables. Compressed code. Special case for popcorn diquarks.
74883  pymass=0d0
74884  kfa=iabs(kf)
74885  kc=pycomp(kf)
74886  IF(kc.EQ.0) THEN
74887  mstj(93)=0
74888  RETURN
74889  ENDIF
74890 
74891 C...Guarantee use of constituent masses for internal checks.
74892  IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.
74893  &(kfa.LE.10.OR.mod(kfa/10,10).EQ.0)) THEN
74894  IF(kfa.LE.5) THEN
74895  pymass=parf(100+kfa)
74896  IF(mstj(93).EQ.2) pymass=max(0d0,pymass-parf(121))
74897  ELSEIF(kfa.LE.10) THEN
74898  pymass=pmas(kfa,1)
74899  ELSEIF(mstj(93).EQ.1) THEN
74900  pymass=parf(100+mod(kfa/1000,10))+parf(100+mod(kfa/100,10))
74901  ELSE
74902  pymass=max(0d0,pmas(kc,1)-parf(122)-2d0*parf(112)/3d0)
74903  ENDIF
74904 
74905 C...Other masses can be read directly off table.
74906  ELSE
74907  pymass=pmas(kc,1)
74908  ENDIF
74909 
74910 C...Optional mass broadening according to truncated Breit-Wigner
74911 C...(either in m or in m^2).
74912  IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1d-4) THEN
74913  IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
74914  pymass=pymass+0.5d0*pmas(kc,2)*tan((2d0*pyr(0)-1d0)*
74915  & atan(2d0*pmas(kc,3)/pmas(kc,2)))
74916  ELSE
74917  pm0=pymass
74918  pmlow=atan((max(0d0,pm0-pmas(kc,3))**2-pm0**2)/
74919  & (pm0*pmas(kc,2)))
74920  pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
74921  pymass=sqrt(max(0d0,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
74922  & (pmupp-pmlow)*pyr(0))))
74923  ENDIF
74924  ENDIF
74925  mstj(93)=0
74926 
74927  RETURN
74928  END
74929 
74930 C*********************************************************************
74931 
74932 C...PYMRUN
74933 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
74934 C...for Higgs couplings. Everything else sent on to PYMASS.
74935 
74936  FUNCTION pymrun(KF,Q2)
74937 
74938 C...Double precision and integer declarations.
74939  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74940  IMPLICIT INTEGER(i-n)
74941  INTEGER pyk,pychge,pycomp
74942 C...Commonblocks.
74943  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74944  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74945  common/pypars/mstp(200),parp(200),msti(200),pari(200)
74946  SAVE /pydat1/,/pydat2/,/pypars/
74947 
74948 C...Most masses not handled here.
74949  kfa=iabs(kf)
74950  IF(kfa.EQ.0.OR.kfa.GT.6) THEN
74951  pymrun=pymass(kf)
74952 
74953 C...Current-algebra masses, but no Q2 dependence.
74954  ELSEIF(mstp(37).NE.1.OR.mstp(2).LE.0) THEN
74955  pymrun=parf(90+kfa)
74956 
74957 C...Running current-algebra masses.
74958  ELSE
74959  as=pyalps(q2)
74960  pymrun=parf(90+kfa)*
74961  & (log(max(4d0,parp(37)**2*parf(90+kfa)**2/paru(117)**2))/
74962  & log(max(4d0,q2/paru(117)**2)))**(12d0/(33d0-2d0*mstu(118)))
74963  ENDIF
74964 
74965  RETURN
74966  END
74967 
74968 C*********************************************************************
74969 
74970 C...PYNAME
74971 C...Gives the particle/parton name as a character string.
74972 
74973  SUBROUTINE pyname(KF,CHAU)
74974 
74975 C...Double precision and integer declarations.
74976  IMPLICIT DOUBLE PRECISION(a-h, o-z)
74977  IMPLICIT INTEGER(i-n)
74978  INTEGER pyk,pychge,pycomp
74979 C...Commonblocks.
74980  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74981  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74982  common/pydat4/chaf(500,2)
74983  CHARACTER chaf*16
74984  SAVE /pydat1/,/pydat2/,/pydat4/
74985 C...Local character variable.
74986  CHARACTER chau*16
74987 
74988 C...Read out code with distinction particle/antiparticle.
74989  chau=' '
74990  kc=pycomp(kf)
74991  IF(kc.NE.0) chau=chaf(kc,(3-isign(1,kf))/2)
74992 
74993 
74994  RETURN
74995  END
74996 
74997 C*********************************************************************
74998 
74999 C...PYCHGE
75000 C...Gives three times the charge for a particle/parton.
75001 
75002  FUNCTION pychge(KF)
75003 
75004 C...Double precision and integer declarations.
75005  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75006  IMPLICIT INTEGER(i-n)
75007  INTEGER pyk,pychge,pycomp
75008 C...Commonblocks.
75009  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75010  SAVE /pydat2/
75011 
75012 C...Read out charge and change sign for antiparticle.
75013  pychge=0
75014  kc=pycomp(kf)
75015  IF(kc.NE.0) pychge=kchg(kc,1)*isign(1,kf)
75016 
75017  RETURN
75018  END
75019 
75020 C*********************************************************************
75021 
75022 C...PYCOMP
75023 C...Compress the standard KF codes for use in mass and decay arrays;
75024 C...also checks whether a given code actually is defined.
75025 
75026  FUNCTION pycomp(KF)
75027 
75028 C...Double precision and integer declarations.
75029  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75030  IMPLICIT INTEGER(i-n)
75031  INTEGER pyk,pychge,pycomp
75032 C...Commonblocks.
75033  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75034  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75035  SAVE /pydat1/,/pydat2/
75036 C...Local arrays and saved data.
75037  dimension kford(100:500),kcord(101:500)
75038  SAVE kford,kcord,nford,kflast,kclast
75039 
75040 C...Whenever necessary reorder codes for faster search.
75041  IF(mstu(20).EQ.0) THEN
75042  nford=100
75043  kford(100)=0
75044  DO 120 i=101,500
75045  kfa=kchg(i,4)
75046  IF(kfa.LE.100) goto 120
75047  nford=nford+1
75048  DO 100 i1=nford-1,0,-1
75049  IF(kfa.GE.kford(i1)) goto 110
75050  kford(i1+1)=kford(i1)
75051  kcord(i1+1)=kcord(i1)
75052  100 CONTINUE
75053  110 kford(i1+1)=kfa
75054  kcord(i1+1)=i
75055  120 CONTINUE
75056  mstu(20)=1
75057  kflast=0
75058  kclast=0
75059  ENDIF
75060 
75061 C...Fast action if same code as in latest call.
75062  IF(kf.EQ.kflast) THEN
75063  pycomp=kclast
75064  RETURN
75065  ENDIF
75066 
75067 C...Starting values. Remove internal diquark flags.
75068  pycomp=0
75069  kfa=iabs(kf)
75070  IF(mod(kfa/10,10).EQ.0.AND.kfa.LT.100000
75071  & .AND.mod(kfa/1000,10).GT.0) kfa=mod(kfa,10000)
75072 
75073 C...Simple cases: direct translation.
75074  IF(kfa.GT.kford(nford)) THEN
75075  ELSEIF(kfa.LE.100) THEN
75076  pycomp=kfa
75077 
75078 C...Else binary search.
75079  ELSE
75080  imin=100
75081  imax=nford+1
75082  130 iavg=(imin+imax)/2
75083  IF(kford(iavg).GT.kfa) THEN
75084  imax=iavg
75085  IF(imax.GT.imin+1) goto 130
75086  ELSEIF(kford(iavg).LT.kfa) THEN
75087  imin=iavg
75088  IF(imax.GT.imin+1) goto 130
75089  ELSE
75090  pycomp=kcord(iavg)
75091  ENDIF
75092  ENDIF
75093 
75094 C...Check if antiparticle allowed.
75095  IF(pycomp.NE.0.AND.kf.LT.0) THEN
75096  IF(kchg(pycomp,3).EQ.0) pycomp=0
75097  ENDIF
75098 
75099 C...Save codes for possible future fast action.
75100  kflast=kf
75101  kclast=pycomp
75102 
75103  RETURN
75104  END
75105 
75106 C*********************************************************************
75107 
75108 C...PYERRM
75109 C...Informs user of errors in program execution.
75110 
75111  SUBROUTINE pyerrm(MERR,CHMESS)
75112 
75113 C...Double precision and integer declarations.
75114  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75115  IMPLICIT INTEGER(i-n)
75116  INTEGER pyk,pychge,pycomp
75117 C...Commonblocks.
75118  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75119  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75120  SAVE /pyjets/,/pydat1/
75121 C...Local character variable.
75122  CHARACTER chmess*(*)
75123 
75124 C...Write first few warnings, then be silent.
75125  IF(merr.LE.10) THEN
75126  mstu(27)=mstu(27)+1
75127  mstu(28)=merr
75128  IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
75129  & merr,mstu(31),chmess
75130 
75131 C...Write first few errors, then be silent or stop program.
75132  ELSEIF(merr.LE.20) THEN
75133  IF(mstu(29).EQ.0) mstu(23)=mstu(23)+1
75134  mstu(30)=mstu(30)+1
75135  mstu(24)=merr-10
75136  IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
75137  & merr-10,mstu(31),chmess
75138  IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
75139  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
75140  WRITE(mstu(11),5200)
75141  IF(merr.NE.17) CALL pylist(2)
75142  CALL pystop(3)
75143  ENDIF
75144 
75145 C...Stop program in case of irreparable error.
75146  ELSE
75147  WRITE(mstu(11),5300) merr-20,mstu(31),chmess
75148  CALL pystop(3)
75149  ENDIF
75150 
75151 C...Formats for output.
75152  5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i9,
75153  &' PYEXEC calls:'/5x,a)
75154  5100 FORMAT(/5x,'Error type',i2,' has occured after',i9,
75155  &' PYEXEC calls:'/5x,a)
75156  5200 FORMAT(5x,'Execution will be stopped after listing of last ',
75157  &'event!')
75158  5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i9,
75159  &' PYEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
75160 
75161  RETURN
75162  END
75163 
75164 C*********************************************************************
75165 
75166 C...PYALEM
75167 C...Calculates the running alpha_electromagnetic.
75168 
75169  FUNCTION pyalem(Q2)
75170 
75171 C...Double precision and integer declarations.
75172  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75173  IMPLICIT INTEGER(i-n)
75174  INTEGER pyk,pychge,pycomp
75175 C...Commonblocks.
75176  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75177  SAVE /pydat1/
75178 
75179 C...Calculate real part of photon vacuum polarization.
75180 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
75181 C...For hadrons use parametrization of H. Burkhardt et al.
75182 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
75183  aempi=paru(101)/(3d0*paru(1))
75184  IF(mstu(101).LE.0.OR.q2.LT.2d-6) THEN
75185  rpigg=0d0
75186  ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN
75187  rpigg=0d0
75188  ELSEIF(mstu(101).EQ.2) THEN
75189  rpigg=1d0-paru(101)/paru(103)
75190  ELSEIF(q2.LT.0.09d0) THEN
75191  rpigg=aempi*(13.4916d0+log(q2))+0.00835d0*log(1d0+q2)
75192  ELSEIF(q2.LT.9d0) THEN
75193  rpigg=aempi*(16.3200d0+2d0*log(q2))+
75194  & 0.00238d0*log(1d0+3.927d0*q2)
75195  ELSEIF(q2.LT.1d4) THEN
75196  rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00165d0+
75197  & 0.00299d0*log(1d0+q2)
75198  ELSE
75199  rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00221d0+
75200  & 0.00293d0*log(1d0+q2)
75201  ENDIF
75202 
75203 C...Calculate running alpha_em.
75204  pyalem=paru(101)/(1d0-rpigg)
75205  paru(108)=pyalem
75206 
75207  RETURN
75208  END
75209 
75210 C*********************************************************************
75211 
75212 C...PYALPS
75213 C...Gives the value of alpha_strong.
75214 
75215  FUNCTION pyalps(Q2)
75216 
75217 C...Double precision and integer declarations.
75218  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75219  IMPLICIT INTEGER(i-n)
75220  INTEGER pyk,pychge,pycomp
75221 C...Commonblocks.
75222  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75223  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75224  SAVE /pydat1/,/pydat2/
75225 C...Coefficients for second-order threshold matching.
75226 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
75227  dimension stepdn(6),stepup(6)
75228 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
75229 c &(2D0*321D0/3703D0),0D0/
75230 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
75231 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
75232  DATA stepdn/0d0,0d0,0.10568d0,0.13398d0,0.17337d0,0d0/
75233  DATA stepup/0d0,0d0,0d0,-0.11413d0,-0.14563d0,-0.18988d0/
75234 
75235 C...Constant alpha_strong trivial. Pick artificial Lambda.
75236  IF(mstu(111).LE.0) THEN
75237  pyalps=paru(111)
75238  mstu(118)=mstu(112)
75239  paru(117)=0.2d0
75240  IF(q2.GT.0.04d0) paru(117)=sqrt(q2)*exp(-6d0*paru(1)/
75241  & ((33d0-2d0*mstu(112))*paru(111)))
75242  paru(118)=paru(111)
75243  RETURN
75244  ENDIF
75245 
75246 C...Find effective Q2, number of flavours and Lambda.
75247  q2eff=q2
75248  IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
75249  nf=mstu(112)
75250  alam2=paru(112)**2
75251  100 IF(nf.GT.max(3,mstu(113))) THEN
75252  q2thr=paru(113)*pmas(nf,1)**2
75253  IF(q2eff.LT.q2thr) THEN
75254  nf=nf-1
75255  q2rat=q2thr/alam2
75256  alam2=alam2*q2rat**(2d0/(33d0-2d0*nf))
75257  IF(mstu(111).EQ.2) alam2=alam2*log(q2rat)**stepdn(nf)
75258  goto 100
75259  ENDIF
75260  ENDIF
75261  110 IF(nf.LT.min(6,mstu(114))) THEN
75262  q2thr=paru(113)*pmas(nf+1,1)**2
75263  IF(q2eff.GT.q2thr) THEN
75264  nf=nf+1
75265  q2rat=q2thr/alam2
75266  alam2=alam2*q2rat**(-2d0/(33d0-2d0*nf))
75267  IF(mstu(111).EQ.2) alam2=alam2*log(q2rat)**stepup(nf)
75268  goto 110
75269  ENDIF
75270  ENDIF
75271  IF(mstu(115).EQ.1) q2eff=q2eff+alam2
75272  paru(117)=sqrt(alam2)
75273 
75274 C...Evaluate first or second order alpha_strong.
75275  b0=(33d0-2d0*nf)/6d0
75276  algq=log(max(1.0001d0,q2eff/alam2))
75277  IF(mstu(111).EQ.1) THEN
75278  pyalps=min(paru(115),paru(2)/(b0*algq))
75279  ELSE
75280  b1=(153d0-19d0*nf)/6d0
75281  pyalps=min(paru(115),paru(2)/(b0*algq)*(1d0-b1*log(algq)/
75282  & (b0**2*algq)))
75283  ENDIF
75284  mstu(118)=nf
75285  paru(118)=pyalps
75286 
75287  RETURN
75288  END
75289 
75290 C*********************************************************************
75291 
75292 C...PYANGL
75293 C...Reconstructs an angle from given x and y coordinates.
75294 
75295  FUNCTION pyangl(X,Y)
75296 
75297 C...Double precision and integer declarations.
75298  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75299  IMPLICIT INTEGER(i-n)
75300  INTEGER pyk,pychge,pycomp
75301 C...Commonblocks.
75302  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75303  SAVE /pydat1/
75304 
75305  pyangl=0d0
75306  r=sqrt(x**2+y**2)
75307  IF(r.LT.1d-20) RETURN
75308  IF(abs(x)/r.LT.0.8d0) THEN
75309  pyangl=sign(acos(x/r),y)
75310  ELSE
75311  pyangl=asin(y/r)
75312  IF(x.LT.0d0.AND.pyangl.GE.0d0) THEN
75313  pyangl=paru(1)-pyangl
75314  ELSEIF(x.LT.0d0) THEN
75315  pyangl=-paru(1)-pyangl
75316  ENDIF
75317  ENDIF
75318 
75319  RETURN
75320  END
75321 
75322 C*********************************************************************
75323 
75324 C...PYR
75325 C...Generates random numbers uniformly distributed between
75326 C...0 and 1, excluding the endpoints.
75327 
75328  FUNCTION pyr(IDUMMY)
75329 
75330 C...Double precision and integer declarations.
75331  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75332  IMPLICIT INTEGER(i-n)
75333  INTEGER pyk,pychge,pycomp
75334 C...Commonblocks.
75335  common/pydatr/mrpy(6),rrpy(100)
75336  SAVE /pydatr/
75337 C...Equivalence between commonblock and local variables.
75338  equivalence(mrpy1,mrpy(1)),(mrpy2,mrpy(2)),(mrpy3,mrpy(3)),
75339  &(mrpy4,mrpy(4)),(mrpy5,mrpy(5)),(mrpy6,mrpy(6)),
75340  &(rrpy98,rrpy(98)),(rrpy99,rrpy(99)),(rrpy00,rrpy(100))
75341 
75342 C...Initialize generation from given seed.
75343  IF(mrpy2.EQ.0) THEN
75344  ij=mod(mrpy1/30082,31329)
75345  kl=mod(mrpy1,30082)
75346  i=mod(ij/177,177)+2
75347  j=mod(ij,177)+2
75348  k=mod(kl/169,178)+1
75349  l=mod(kl,169)
75350  DO 110 ii=1,97
75351  s=0d0
75352  t=0.5d0
75353  DO 100 jj=1,48
75354  m=mod(mod(i*j,179)*k,179)
75355  i=j
75356  j=k
75357  k=m
75358  l=mod(53*l+1,169)
75359  IF(mod(l*m,64).GE.32) s=s+t
75360  t=0.5d0*t
75361  100 CONTINUE
75362  rrpy(ii)=s
75363  110 CONTINUE
75364  twom24=1d0
75365  DO 120 i24=1,24
75366  twom24=0.5d0*twom24
75367  120 CONTINUE
75368  rrpy98=362436d0*twom24
75369  rrpy99=7654321d0*twom24
75370  rrpy00=16777213d0*twom24
75371  mrpy2=1
75372  mrpy3=0
75373  mrpy4=97
75374  mrpy5=33
75375  ENDIF
75376 
75377 C...Generate next random number.
75378  130 runi=rrpy(mrpy4)-rrpy(mrpy5)
75379  IF(runi.LT.0d0) runi=runi+1d0
75380  rrpy(mrpy4)=runi
75381  mrpy4=mrpy4-1
75382  IF(mrpy4.EQ.0) mrpy4=97
75383  mrpy5=mrpy5-1
75384  IF(mrpy5.EQ.0) mrpy5=97
75385  rrpy98=rrpy98-rrpy99
75386  IF(rrpy98.LT.0d0) rrpy98=rrpy98+rrpy00
75387  runi=runi-rrpy98
75388  IF(runi.LT.0d0) runi=runi+1d0
75389  IF(runi.LE.0d0.OR.runi.GE.1d0) goto 130
75390 
75391 C...Update counters. Random number to output.
75392  mrpy3=mrpy3+1
75393  IF(mrpy3.EQ.1000000000) THEN
75394  mrpy2=mrpy2+1
75395  mrpy3=0
75396  ENDIF
75397  pyr=runi
75398 
75399  RETURN
75400  END
75401 
75402 C*********************************************************************
75403 
75404 C...PYRGET
75405 C...Dumps the state of the random number generator on a file
75406 C...for subsequent startup from this state onwards.
75407 
75408  SUBROUTINE pyrget(LFN,MOVE)
75409 
75410 C...Double precision and integer declarations.
75411  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75412  IMPLICIT INTEGER(i-n)
75413  INTEGER pyk,pychge,pycomp
75414 C...Commonblocks.
75415  common/pydatr/mrpy(6),rrpy(100)
75416  SAVE /pydatr/
75417 C...Local character variable.
75418  CHARACTER cherr*8
75419 
75420 C...Backspace required number of records (or as many as there are).
75421  IF(move.LT.0) THEN
75422  nbck=min(mrpy(6),-move)
75423  DO 100 ibck=1,nbck
75424  backspace(lfn,err=110,iostat=ierr)
75425  100 CONTINUE
75426  mrpy(6)=mrpy(6)-nbck
75427  ENDIF
75428 
75429 C...Unformatted write on unit LFN.
75430  WRITE(lfn,err=110,iostat=ierr) (mrpy(i1),i1=1,5),
75431  &(rrpy(i2),i2=1,100)
75432  mrpy(6)=mrpy(6)+1
75433  RETURN
75434 
75435 C...Write error.
75436  110 WRITE(cherr,'(I8)') ierr
75437  CALL pyerrm(18,'(PYRGET:) error when accessing file, IOSTAT ='//
75438  &cherr)
75439 
75440  RETURN
75441  END
75442 
75443 C*********************************************************************
75444 
75445 C...PYRSET
75446 C...Reads a state of the random number generator from a file
75447 C...for subsequent generation from this state onwards.
75448 
75449  SUBROUTINE pyrset(LFN,MOVE)
75450 
75451 C...Double precision and integer declarations.
75452  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75453  IMPLICIT INTEGER(i-n)
75454  INTEGER pyk,pychge,pycomp
75455 C...Commonblocks.
75456  common/pydatr/mrpy(6),rrpy(100)
75457  SAVE /pydatr/
75458 C...Local character variable.
75459  CHARACTER cherr*8
75460 
75461 C...Backspace required number of records (or as many as there are).
75462  IF(move.LT.0) THEN
75463  nbck=min(mrpy(6),-move)
75464  DO 100 ibck=1,nbck
75465  backspace(lfn,err=120,iostat=ierr)
75466  100 CONTINUE
75467  mrpy(6)=mrpy(6)-nbck
75468  ENDIF
75469 
75470 C...Unformatted read from unit LFN.
75471  nfor=1+max(0,move)
75472  DO 110 ifor=1,nfor
75473  READ(lfn,err=120,iostat=ierr) (mrpy(i1),i1=1,5),
75474  & (rrpy(i2),i2=1,100)
75475  110 CONTINUE
75476  mrpy(6)=mrpy(6)+nfor
75477  RETURN
75478 
75479 C...Write error.
75480  120 WRITE(cherr,'(I8)') ierr
75481  CALL pyerrm(18,'(PYRSET:) error when accessing file, IOSTAT ='//
75482  &cherr)
75483 
75484  RETURN
75485  END
75486 
75487 C*********************************************************************
75488 
75489 C...PYROBO
75490 C...Performs rotations and boosts.
75491 
75492  SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
75493 
75494 C...Double precision and integer declarations.
75495  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75496  IMPLICIT INTEGER(i-n)
75497  INTEGER pyk,pychge,pycomp
75498 C...Commonblocks.
75499  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75500  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75501  SAVE /pyjets/,/pydat1/
75502 C...Local arrays.
75503  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
75504 
75505 C...Find and check range of rotation/boost.
75506  imin=imi
75507  IF(imin.LE.0) imin=1
75508  IF(mstu(1).GT.0) imin=mstu(1)
75509  imax=ima
75510  IF(imax.LE.0) imax=n
75511  IF(mstu(2).GT.0) imax=mstu(2)
75512  IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
75513  CALL pyerrm(11,'(PYROBO:) range outside PYJETS memory')
75514  RETURN
75515  ENDIF
75516 
75517 C...Optional resetting of V (when not set before.)
75518  IF(mstu(33).NE.0) THEN
75519  DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
75520  DO 100 j=1,5
75521  v(i,j)=0d0
75522  100 CONTINUE
75523  110 CONTINUE
75524  mstu(33)=0
75525  ENDIF
75526 
75527 C...Rotate, typically from z axis to direction (theta,phi).
75528  IF(the**2+phi**2.GT.1d-20) THEN
75529  rot(1,1)=cos(the)*cos(phi)
75530  rot(1,2)=-sin(phi)
75531  rot(1,3)=sin(the)*cos(phi)
75532  rot(2,1)=cos(the)*sin(phi)
75533  rot(2,2)=cos(phi)
75534  rot(2,3)=sin(the)*sin(phi)
75535  rot(3,1)=-sin(the)
75536  rot(3,2)=0d0
75537  rot(3,3)=cos(the)
75538  DO 140 i=imin,imax
75539  IF(k(i,1).LE.0) goto 140
75540  DO 120 j=1,3
75541  pr(j)=p(i,j)
75542  vr(j)=v(i,j)
75543  120 CONTINUE
75544  DO 130 j=1,3
75545  p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
75546  v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
75547  130 CONTINUE
75548  140 CONTINUE
75549  ENDIF
75550 
75551 C...Boost, typically from rest to momentum/energy=beta.
75552  IF(bex**2+bey**2+bez**2.GT.1d-20) THEN
75553  dbx=bex
75554  dby=bey
75555  dbz=bez
75556  db=sqrt(dbx**2+dby**2+dbz**2)
75557  eps1=1d0-1d-12
75558  IF(db.GT.eps1) THEN
75559 C...Rescale boost vector if too close to unity.
75560  CALL pyerrm(3,'(PYROBO:) boost vector too large')
75561  dbx=dbx*(eps1/db)
75562  dby=dby*(eps1/db)
75563  dbz=dbz*(eps1/db)
75564  db=eps1
75565  ENDIF
75566  dga=1d0/sqrt(1d0-db**2)
75567  DO 160 i=imin,imax
75568  IF(k(i,1).LE.0) goto 160
75569  DO 150 j=1,4
75570  dp(j)=p(i,j)
75571  dv(j)=v(i,j)
75572  150 CONTINUE
75573  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
75574  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
75575  p(i,1)=dp(1)+dgabp*dbx
75576  p(i,2)=dp(2)+dgabp*dby
75577  p(i,3)=dp(3)+dgabp*dbz
75578  p(i,4)=dga*(dp(4)+dbp)
75579  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
75580  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
75581  v(i,1)=dv(1)+dgabv*dbx
75582  v(i,2)=dv(2)+dgabv*dby
75583  v(i,3)=dv(3)+dgabv*dbz
75584  v(i,4)=dga*(dv(4)+dbv)
75585  160 CONTINUE
75586  ENDIF
75587 
75588  RETURN
75589  END
75590 
75591 C*********************************************************************
75592 
75593 C...PYEDIT
75594 C...Performs global manipulations on the event record, in particular
75595 C...to exclude unstable or undetectable partons/particles.
75596 
75597  SUBROUTINE pyedit(MEDIT)
75598 
75599 C...Double precision and integer declarations.
75600  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75601  IMPLICIT INTEGER(i-n)
75602  INTEGER pyk,pychge,pycomp
75603 C...Parameter statement to help give large particle numbers.
75604  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75605  &kexcit=4000000,kdimen=5000000)
75606 C...Commonblocks.
75607  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75608  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75609  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75610  common/pyctag/nct,mct(4000,2)
75611  SAVE /pyjets/,/pydat1/,/pydat2/,/pyctag/
75612 C...Local arrays.
75613  dimension ns(2),pts(2),pls(2)
75614 
75615 C...Remove unwanted partons/particles.
75616  IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
75617  imax=n
75618  IF(mstu(2).GT.0) imax=mstu(2)
75619  i1=max(1,mstu(1))-1
75620  DO 110 i=max(1,mstu(1)),imax
75621  IF(k(i,1).EQ.0.OR.(k(i,1).GE.21.AND.k(i,1).LE.40)) goto 110
75622  IF(medit.EQ.1) THEN
75623  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) goto 110
75624  ELSEIF(medit.EQ.2) THEN
75625  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) goto 110
75626  kc=pycomp(k(i,2))
75627  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75628  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75629  & k(i,2).EQ.ksusy1+39) goto 110
75630  ELSEIF(medit.EQ.3) THEN
75631  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) goto 110
75632  kc=pycomp(k(i,2))
75633  IF(kc.EQ.0) goto 110
75634  IF(kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0) goto 110
75635  ELSEIF(medit.EQ.5) THEN
75636  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.k(i,1).EQ.52) goto 110
75637  kc=pycomp(k(i,2))
75638  IF(kc.EQ.0) goto 110
75639  IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42.AND.
75640  & kchg(kc,2).EQ.0) goto 110
75641  ENDIF
75642 
75643 C...Pack remaining partons/particles. Origin no longer known.
75644  i1=i1+1
75645  DO 100 j=1,5
75646  k(i1,j)=k(i,j)
75647  p(i1,j)=p(i,j)
75648  v(i1,j)=v(i,j)
75649  100 CONTINUE
75650  k(i1,3)=0
75651  110 CONTINUE
75652  IF(i1.LT.n) mstu(3)=0
75653  IF(i1.LT.n) mstu(70)=0
75654  n=i1
75655 
75656 C...Selective removal of class of entries. New position of retained.
75657  ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
75658  i1=0
75659  DO 120 i=1,n
75660  k(i,3)=mod(k(i,3),mstu(5))
75661  IF(medit.EQ.11.AND.k(i,1).LT.0) goto 120
75662  IF(medit.EQ.12.AND.k(i,1).EQ.0) goto 120
75663  IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
75664  & k(i,1).EQ.15.OR.k(i,1).EQ.51).AND.k(i,2).NE.94) goto 120
75665  IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
75666  & k(i,1).EQ.52.OR.k(i,2).EQ.94)) goto 120
75667  IF(medit.EQ.15.AND.k(i,1).GE.21.AND.k(i,1).LE.40) goto 120
75668  i1=i1+1
75669  k(i,3)=k(i,3)+mstu(5)*i1
75670  120 CONTINUE
75671 
75672 C...Find new event history information and replace old.
75673  DO 140 i=1,n
75674  IF(k(i,1).LE.0.OR.(k(i,1).GE.21.AND.k(i,1).LE.40).OR.
75675  & k(i,3)/mstu(5).EQ.0) goto 140
75676  id=i
75677  130 im=mod(k(id,3),mstu(5))
75678  IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
75679  IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15.OR.
75680  & k(im,1).EQ.51).AND.k(im,2).NE.94) THEN
75681  id=im
75682  goto 130
75683  ENDIF
75684  ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
75685  IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,1).EQ.52.OR.
75686  & k(im,2).EQ.94) THEN
75687  id=im
75688  goto 130
75689  ENDIF
75690  ENDIF
75691  k(i,3)=mstu(5)*(k(i,3)/mstu(5))
75692  IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
75693  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14.AND.
75694  & k(i,1).NE.42.AND.k(i,1).NE.52) THEN
75695  IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
75696  & k(k(i,4),3)/mstu(5)
75697  IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
75698  & k(k(i,5),3)/mstu(5)
75699  ELSE
75700  kcm=mod(k(i,4)/mstu(5),mstu(5))
75701  IF(kcm.GT.0.AND.kcm.LE.mstu(4).AND.k(i,1).NE.42.AND.
75702  & k(i,1).NE.52) kcm=k(kcm,3)/mstu(5)
75703  kcd=mod(k(i,4),mstu(5))
75704  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
75705  k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
75706  kcm=mod(k(i,5)/mstu(5),mstu(5))
75707  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
75708  kcd=mod(k(i,5),mstu(5))
75709  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
75710  k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
75711  ENDIF
75712  140 CONTINUE
75713 
75714 C...Pack remaining entries.
75715  i1=0
75716  mstu90=mstu(90)
75717  mstu(90)=0
75718  DO 170 i=1,n
75719  IF(k(i,3)/mstu(5).EQ.0) goto 170
75720  i1=i1+1
75721  DO 150 j=1,5
75722  k(i1,j)=k(i,j)
75723  p(i1,j)=p(i,j)
75724  v(i1,j)=v(i,j)
75725  150 CONTINUE
75726 C...Also update LHA1 colour tags
75727  mct(i1,1)=mct(i,1)
75728  mct(i1,2)=mct(i,2)
75729  k(i1,3)=mod(k(i1,3),mstu(5))
75730  DO 160 iz=1,mstu90
75731  IF(i.EQ.mstu(90+iz)) THEN
75732  mstu(90)=mstu(90)+1
75733  mstu(90+mstu(90))=i1
75734  paru(90+mstu(90))=paru(90+iz)
75735  ENDIF
75736  160 CONTINUE
75737  170 CONTINUE
75738  IF(i1.LT.n) mstu(3)=0
75739  IF(i1.LT.n) mstu(70)=0
75740  n=i1
75741 
75742 C...Fill in some missing daughter pointers (lost in colour flow).
75743  ELSEIF(medit.EQ.16) THEN
75744  DO 220 i=1,n
75745  IF(k(i,1).LE.10.OR.(k(i,1).GE.21.AND.k(i,1).LE.50)) goto 220
75746  IF(k(i,4).NE.0.OR.k(i,5).NE.0) goto 220
75747 C...Find daughters who point to mother.
75748  DO 180 i1=i+1,n
75749  IF(k(i1,3).NE.i) THEN
75750  ELSEIF(k(i,4).EQ.0) THEN
75751  k(i,4)=i1
75752  ELSE
75753  k(i,5)=i1
75754  ENDIF
75755  180 CONTINUE
75756  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
75757  IF(k(i,4).NE.0) goto 220
75758 C...Find daughters who point to documentation version of mother.
75759  im=k(i,3)
75760  IF(im.LE.0.OR.im.GE.i) goto 220
75761  IF(k(im,1).LE.20.OR.k(im,1).GT.30) goto 220
75762  IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1d-2) goto 220
75763  DO 190 i1=i+1,n
75764  IF(k(i1,3).NE.im) THEN
75765  ELSEIF(k(i,4).EQ.0) THEN
75766  k(i,4)=i1
75767  ELSE
75768  k(i,5)=i1
75769  ENDIF
75770  190 CONTINUE
75771  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
75772  IF(k(i,4).NE.0) goto 220
75773 C...Find daughters who point to documentation daughters who,
75774 C...in their turn, point to documentation mother.
75775  id1=im
75776  id2=im
75777  DO 200 i1=im+1,i-1
75778  IF(k(i1,3).EQ.im.AND.k(i1,1).GE.21.AND.k(i1,1).LE.30) THEN
75779  id2=i1
75780  IF(id1.EQ.im) id1=i1
75781  ENDIF
75782  200 CONTINUE
75783  DO 210 i1=i+1,n
75784  IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN
75785  ELSEIF(k(i,4).EQ.0) THEN
75786  k(i,4)=i1
75787  ELSE
75788  k(i,5)=i1
75789  ENDIF
75790  210 CONTINUE
75791  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
75792  220 CONTINUE
75793 
75794 C...Save top entries at bottom of PYJETS commonblock.
75795  ELSEIF(medit.EQ.21) THEN
75796  IF(2*n.GE.mstu(4)) THEN
75797  CALL pyerrm(11,'(PYEDIT:) no more memory left in PYJETS')
75798  RETURN
75799  ENDIF
75800  DO 240 i=1,n
75801  DO 230 j=1,5
75802  k(mstu(4)-i,j)=k(i,j)
75803  p(mstu(4)-i,j)=p(i,j)
75804  v(mstu(4)-i,j)=v(i,j)
75805  230 CONTINUE
75806  240 CONTINUE
75807  mstu(32)=n
75808 
75809 C...Restore bottom entries of commonblock PYJETS to top.
75810  ELSEIF(medit.EQ.22) THEN
75811  DO 260 i=1,mstu(32)
75812  DO 250 j=1,5
75813  k(i,j)=k(mstu(4)-i,j)
75814  p(i,j)=p(mstu(4)-i,j)
75815  v(i,j)=v(mstu(4)-i,j)
75816  250 CONTINUE
75817  260 CONTINUE
75818  n=mstu(32)
75819 
75820 C...Mark primary entries at top of commonblock PYJETS as untreated.
75821  ELSEIF(medit.EQ.23) THEN
75822  i1=0
75823  DO 270 i=1,n
75824  kh=k(i,3)
75825  IF(kh.GE.1) THEN
75826  IF(k(kh,1).GE.21.AND.k(kh,1).LE.30) kh=0
75827  ENDIF
75828  IF(kh.NE.0) goto 280
75829  i1=i1+1
75830  IF(k(i,1).GE.11.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
75831  IF(k(i,1).GE.51.AND.k(i,1).LE.60) k(i,1)=k(i,1)-10
75832  270 CONTINUE
75833  280 n=i1
75834 
75835 C...Place largest axis along z axis and second largest in xy plane.
75836  ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
75837  CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61),1),
75838  & p(mstu(61),2)),0d0,0d0,0d0)
75839  CALL pyrobo(1,n+mstu(3),-pyangl(p(mstu(61),3),
75840  & p(mstu(61),1)),0d0,0d0,0d0,0d0)
75841  CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61)+1,1),
75842  & p(mstu(61)+1,2)),0d0,0d0,0d0)
75843  IF(medit.EQ.31) RETURN
75844 
75845 C...Rotate to put slim jet along +z axis.
75846  DO 290 is=1,2
75847  ns(is)=0
75848  pts(is)=0d0
75849  pls(is)=0d0
75850  290 CONTINUE
75851  DO 300 i=1,n
75852  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 300
75853  IF(mstu(41).GE.2) THEN
75854  kc=pycomp(k(i,2))
75855  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75856  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75857  & k(i,2).EQ.ksusy1+39) goto 300
75858  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
75859  & .EQ.0) goto 300
75860  ENDIF
75861  is=2d0-sign(0.5d0,p(i,3))
75862  ns(is)=ns(is)+1
75863  pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
75864  300 CONTINUE
75865  IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
75866  & CALL pyrobo(1,n+mstu(3),paru(1),0d0,0d0,0d0,0d0)
75867 
75868 C...Rotate to put second largest jet into -z,+x quadrant.
75869  DO 310 i=1,n
75870  IF(p(i,3).GE.0d0) goto 310
75871  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 310
75872  IF(mstu(41).GE.2) THEN
75873  kc=pycomp(k(i,2))
75874  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75875  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75876  & k(i,2).EQ.ksusy1+39) goto 310
75877  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
75878  & .EQ.0) goto 310
75879  ENDIF
75880  is=2d0-sign(0.5d0,p(i,1))
75881  pls(is)=pls(is)-p(i,3)
75882  310 CONTINUE
75883  IF(pls(2).GT.pls(1)) CALL pyrobo(1,n+mstu(3),0d0,paru(1),
75884  & 0d0,0d0,0d0)
75885  ENDIF
75886 
75887  RETURN
75888  END
75889 
75890 C*********************************************************************
75891 
75892 C...PYLIST
75893 C...Gives program heading, or lists an event, or particle
75894 C...data, or current parameter values.
75895 
75896  SUBROUTINE pylist(MLIST)
75897 
75898 C...Double precision and integer declarations.
75899  IMPLICIT DOUBLE PRECISION(a-h, o-z)
75900  IMPLICIT INTEGER(i-n)
75901  INTEGER pyk,pychge,pycomp
75902 C...Parameter statement to help give large particle numbers.
75903  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75904  &kexcit=4000000,kdimen=5000000)
75905 
75906 C...HEPEVT commonblock.
75907  parameter(nmxhep=4000)
75908  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
75909  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
75910  DOUBLE PRECISION phep,vhep
75911  SAVE /hepevt/
75912 
75913 C...User process event common block.
75914  INTEGER maxnup
75915  parameter(maxnup=500)
75916  INTEGER nup,idprup,idup,istup,mothup,icolup
75917  DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
75918  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
75919  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
75920  &vtimup(maxnup),spinup(maxnup)
75921  SAVE /hepeup/
75922 
75923 C...Commonblocks.
75924  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75925  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75926  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75927  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
75928  common/pyctag/nct,mct(4000,2)
75929  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyctag/
75930 C...Local arrays, character variables and data.
75931  CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chdl(7)*4
75932  dimension ps(6)
75933  DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
75934 
75935 C...Initialization printout: version number and date of last change.
75936  IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
75937  CALL pylogo
75938  mstu(12)=12345
75939  IF(mlist.EQ.0) RETURN
75940  ENDIF
75941 
75942 C...List event data, including additional lines after N.
75943  IF(mlist.GE.1.AND.mlist.LE.4) THEN
75944  IF(mlist.EQ.1) WRITE(mstu(11),5100)
75945  IF(mlist.EQ.2) WRITE(mstu(11),5200)
75946  IF(mlist.EQ.3) WRITE(mstu(11),5300)
75947  IF(mlist.EQ.4) WRITE(mstu(11),5400)
75948  lmx=12
75949  IF(mlist.GE.2) lmx=16
75950  istr=0
75951  imax=n
75952  IF(mstu(2).GT.0) imax=mstu(2)
75953  DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
75954  IF(i.GT.imax.AND.i.LE.n) goto 120
75955  IF(mstu(15).EQ.0.AND.k(i,1).LE.0) goto 120
75956  IF(mstu(15).EQ.1.AND.k(i,1).LT.0) goto 120
75957 
75958 C...Get particle name, pad it and check it is not too long.
75959  CALL pyname(k(i,2),chap)
75960  len=0
75961  DO 100 lem=1,16
75962  IF(chap(lem:lem).NE.' ') len=lem
75963  100 CONTINUE
75964  mdl=(k(i,1)+19)/10
75965  ldl=0
75966  IF(mdl.EQ.2.OR.mdl.GE.8) THEN
75967  chac=chap
75968  IF(len.GT.lmx) chac(lmx:lmx)='?'
75969  ELSE
75970  ldl=1
75971  IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
75972  IF(len.EQ.0) THEN
75973  chac=chdl(mdl)(1:2*ldl)//' '
75974  ELSE
75975  chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
75976  & chdl(mdl)(ldl+1:2*ldl)//' '
75977  IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
75978  ENDIF
75979  ENDIF
75980 
75981 C...Add information on string connection.
75982  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
75983  & THEN
75984  kc=pycomp(k(i,2))
75985  kcc=0
75986  IF(kc.NE.0) kcc=kchg(kc,2)
75987  IF(iabs(k(i,2)).EQ.39) THEN
75988  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
75989  ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
75990  istr=1
75991  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
75992  ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
75993  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
75994  ELSEIF(kcc.NE.0) THEN
75995  istr=0
75996  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
75997  ENDIF
75998  ENDIF
75999  IF((k(i,1).EQ.41.OR.k(i,1).EQ.51).AND.len+2*ldl+3.LE.lmx)
76000  & chac(lmx-1:lmx-1)='I'
76001 
76002 C...Write data for particle/jet.
76003  IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999d0) THEN
76004  WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
76005  & (p(i,j2),j2=1,5)
76006  ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999d0) THEN
76007  WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
76008  & (p(i,j2),j2=1,5)
76009  ELSEIF(mlist.EQ.1) THEN
76010  WRITE(mstu(11),5700) i,chac(1:12),(k(i,j1),j1=1,3),
76011  & (p(i,j2),j2=1,5)
76012  ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
76013  & k(i,1).EQ.14.OR.k(i,1).EQ.42.OR.k(i,1).EQ.52)) THEN
76014  IF(mlist.NE.4) WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,3),
76015  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
76016  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
76017  & (p(i,j2),j2=1,5)
76018  IF(mlist.EQ.4) WRITE(mstu(11),5900) i,chac,(k(i,j1),j1=1,3),
76019  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
76020  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5)
76021  & ,10000),mct(i,1),mct(i,2)
76022  ELSE
76023  IF(mlist.NE.4) WRITE(mstu(11),6000) i,chac,(k(i,j1),j1=1,5),
76024  & (p(i,j2),j2=1,5)
76025  IF(mlist.EQ.4) WRITE(mstu(11),6100) i,chac,(k(i,j1),j1=1,5)
76026  & ,mct(i,1),mct(i,2)
76027  ENDIF
76028  IF(mlist.EQ.3) WRITE(mstu(11),6200) (v(i,j),j=1,5)
76029 
76030 C...Insert extra separator lines specified by user.
76031  IF(mstu(70).GE.1) THEN
76032  isep=0
76033  DO 110 j=1,min(10,mstu(70))
76034  IF(i.EQ.mstu(70+j)) isep=1
76035  110 CONTINUE
76036  IF(isep.EQ.1) THEN
76037  IF(mlist.EQ.1) WRITE(mstu(11),6300)
76038  IF(mlist.EQ.2.OR.mlist.EQ.3) WRITE(mstu(11),6400)
76039  IF(mlist.EQ.4) WRITE(mstu(11),6500)
76040  ENDIF
76041  ENDIF
76042  120 CONTINUE
76043 
76044 C...Sum of charges and momenta.
76045  DO 130 j=1,6
76046  ps(j)=pyp(0,j)
76047  130 CONTINUE
76048  IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999d0) THEN
76049  WRITE(mstu(11),6600) ps(6),(ps(j),j=1,5)
76050  ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999d0) THEN
76051  WRITE(mstu(11),6700) ps(6),(ps(j),j=1,5)
76052  ELSEIF(mlist.EQ.1) THEN
76053  WRITE(mstu(11),6800) ps(6),(ps(j),j=1,5)
76054  ELSEIF(mlist.LE.3) THEN
76055  WRITE(mstu(11),6900) ps(6),(ps(j),j=1,5)
76056  ELSE
76057  WRITE(mstu(11),7000) ps(6)
76058  ENDIF
76059 
76060 C...Simple listing of HEPEVT entries (mainly for test purposes).
76061  ELSEIF(mlist.EQ.5) THEN
76062  WRITE(mstu(11),7100)
76063  DO 140 i=1,nhep
76064  IF(isthep(i).EQ.0) goto 140
76065  WRITE(mstu(11),7200) i,isthep(i),idhep(i),jmohep(1,i),
76066  & jmohep(2,i),jdahep(1,i),jdahep(2,i),(phep(j,i),j=1,5)
76067  140 CONTINUE
76068 
76069 
76070 C...Simple listing of user-process entries (mainly for test purposes).
76071  ELSEIF(mlist.EQ.7) THEN
76072  WRITE(mstu(11),7300)
76073  DO 150 i=1,nup
76074  WRITE(mstu(11),7400) i,istup(i),idup(i),mothup(1,i),
76075  & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5)
76076  150 CONTINUE
76077 
76078 C...Give simple list of KF codes defined in program.
76079  ELSEIF(mlist.EQ.11) THEN
76080  WRITE(mstu(11),7500)
76081  DO 160 kf=1,80
76082  CALL pyname(kf,chap)
76083  CALL pyname(-kf,chan)
76084  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),7600) kf,chap
76085  IF(chan.NE.' ') WRITE(mstu(11),7600) kf,chap,-kf,chan
76086  160 CONTINUE
76087  DO 190 kfls=1,3,2
76088  DO 180 kfla=1,5
76089  DO 170 kflb=1,kfla-(3-kfls)/2
76090  kf=1000*kfla+100*kflb+kfls
76091  CALL pyname(kf,chap)
76092  CALL pyname(-kf,chan)
76093  WRITE(mstu(11),7600) kf,chap,-kf,chan
76094  170 CONTINUE
76095  180 CONTINUE
76096  190 CONTINUE
76097  DO 220 kmul=0,5
76098  kfls=3
76099  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
76100  IF(kmul.EQ.5) kfls=5
76101  kflr=0
76102  IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
76103  IF(kmul.EQ.4) kflr=2
76104  DO 210 kflb=1,5
76105  DO 200 kflc=1,kflb-1
76106  kf=10000*kflr+100*kflb+10*kflc+kfls
76107  CALL pyname(kf,chap)
76108  CALL pyname(-kf,chan)
76109  WRITE(mstu(11),7600) kf,chap,-kf,chan
76110  IF(kf.EQ.311) THEN
76111  kfk=130
76112  CALL pyname(kfk,chap)
76113  WRITE(mstu(11),7600) kfk,chap
76114  kfk=310
76115  CALL pyname(kfk,chap)
76116  WRITE(mstu(11),7600) kfk,chap
76117  ENDIF
76118  200 CONTINUE
76119  kf=10000*kflr+110*kflb+kfls
76120  CALL pyname(kf,chap)
76121  WRITE(mstu(11),7600) kf,chap
76122  210 CONTINUE
76123  220 CONTINUE
76124  kf=100443
76125  CALL pyname(kf,chap)
76126  WRITE(mstu(11),7600) kf,chap
76127  kf=100553
76128  CALL pyname(kf,chap)
76129  WRITE(mstu(11),7600) kf,chap
76130  DO 260 kflsp=1,3
76131  kfls=2+2*(kflsp/3)
76132  DO 250 kfla=1,5
76133  DO 240 kflb=1,kfla
76134  DO 230 kflc=1,kflb
76135  IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc))
76136  & goto 230
76137  IF(kflsp.EQ.2.AND.kfla.EQ.kflc) goto 230
76138  IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
76139  IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
76140  CALL pyname(kf,chap)
76141  CALL pyname(-kf,chan)
76142  WRITE(mstu(11),7600) kf,chap,-kf,chan
76143  230 CONTINUE
76144  240 CONTINUE
76145  250 CONTINUE
76146  260 CONTINUE
76147  DO 270 kc=1,500
76148  kf=kchg(kc,4)
76149  IF(kf.LT.1000000) goto 270
76150  CALL pyname(kf,chap)
76151  CALL pyname(-kf,chan)
76152  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),7600) kf,chap
76153  IF(chan.NE.' ') WRITE(mstu(11),7600) kf,chap,-kf,chan
76154  270 CONTINUE
76155 
76156 C...List parton/particle data table. Check whether to be listed.
76157  ELSEIF(mlist.EQ.12) THEN
76158  WRITE(mstu(11),7700)
76159  DO 300 kc=1,mstu(6)
76160  kf=kchg(kc,4)
76161  IF(kf.EQ.0) goto 300
76162  IF(kf.LT.mstu(1).OR.(mstu(2).GT.0.AND.kf.GT.mstu(2)))
76163  & goto 300
76164 
76165 C...Find particle name and mass. Print information.
76166  CALL pyname(kf,chap)
76167  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 300
76168  CALL pyname(-kf,chan)
76169  WRITE(mstu(11),7800) kf,kc,chap,chan,(kchg(kc,j1),j1=1,3),
76170  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
76171 
76172 C...Particle decay: channel number, branching ratios, matrix element,
76173 C...decay products.
76174  DO 290 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
76175  DO 280 j=1,5
76176  CALL pyname(kfdp(idc,j),chad(j))
76177  280 CONTINUE
76178  WRITE(mstu(11),7900) idc,mdme(idc,1),mdme(idc,2),brat(idc),
76179  & (chad(j),j=1,5)
76180  290 CONTINUE
76181  300 CONTINUE
76182 
76183 C...List parameter value table.
76184  ELSEIF(mlist.EQ.13) THEN
76185  WRITE(mstu(11),8000)
76186  DO 310 i=1,200
76187  WRITE(mstu(11),8100) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
76188  310 CONTINUE
76189  ENDIF
76190 
76191 C...Format statements for output on unit MSTU(11) (by default 6).
76192  5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
76193  &5x,'KF orig p_x p_y p_z E m'/)
76194  5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
76195  &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
76196  &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
76197  5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
76198  &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
76199  &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
76200  &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
76201  5400 FORMAT(///28x,'Event listing (no momenta)'//4x,'I particle/jet',
76202  & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1x
76203  & ,' C tag AC tag'/)
76204  5500 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.3)
76205  5600 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.2)
76206  5700 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.1)
76207  5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),5f13.5)
76208  5900 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),1x,2i8)
76209  6000 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),5f13.5)
76210  6100 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),1x,2i8)
76211  6200 FORMAT(66x,5(1x,f12.3))
76212  6300 FORMAT(1x,78('='))
76213  6400 FORMAT(1x,130('='))
76214  6500 FORMAT(1x,65('='))
76215  6600 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
76216  6700 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
76217  6800 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
76218  6900 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
76219  &5f13.5)
76220  7000 FORMAT(19x,'sum charge:',f6.2)
76221  7100 FORMAT(/10x,'Event listing of HEPEVT common block (simplified)'
76222  &//' I IST ID Mothers Daughters p_x p_y p_z',
76223  &' E m')
76224  7200 FORMAT(1x,i4,i2,i8,4i5,5f9.3)
76225  7300 FORMAT(/10x,'Event listing of user process at input (simplified)'
76226  &//' I IST ID Mothers Colours p_x p_y p_z',
76227  &' E m')
76228  7400 FORMAT(1x,i3,i3,i8,2i4,2i5,5f9.3)
76229  7500 FORMAT(///20x,'List of KF codes in program'/)
76230  7600 FORMAT(4x,i9,4x,a16,6x,i9,4x,a16)
76231  7700 FORMAT(///30x,'Particle/parton data table'//8x,'KF',5x,'KC',4x,
76232  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
76233  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
76234  &1x,'ME',3x,'Br.rat.',4x,'decay products')
76235  7800 FORMAT(/1x,i9,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
76236  &1x,1p,e13.5,3x,i2)
76237  7900 FORMAT(10x,i4,2x,i3,2x,i3,2x,f10.6,4x,5a16)
76238  8000 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
76239  &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
76240  8100 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
76241 
76242  RETURN
76243  END
76244 
76245 C*********************************************************************
76246 
76247 C...PYLOGO
76248 C...Writes a logo for the program.
76249 
76250  SUBROUTINE pylogo
76251 
76252 C...Double precision and integer declarations.
76253  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76254  IMPLICIT INTEGER(i-n)
76255  INTEGER pyk,pychge,pycomp
76256 C...Parameter for length of information block.
76257  parameter(irefer=19)
76258 C...Commonblocks.
76259  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76260  common/pypars/mstp(200),parp(200),msti(200),pari(200)
76261  SAVE /pydat1/,/pypars/
76262 C...Local arrays and character variables.
76263  INTEGER idati(6)
76264  CHARACTER month(12)*3, logo(48)*32, refer(2*irefer)*36, line*79,
76265  &vers*1, subv*3, date*2, year*4, hour*2, minu*2, seco*2
76266 
76267 C...Data on months, logo, titles, and references.
76268  DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
76269  &'Oct','Nov','Dec'/
76270  DATA (logo(j),j=1,19)/
76271  &' *......* ',
76272  &' *:::!!:::::::::::* ',
76273  &' *::::::!!::::::::::::::* ',
76274  &' *::::::::!!::::::::::::::::* ',
76275  &' *:::::::::!!:::::::::::::::::* ',
76276  &' *:::::::::!!:::::::::::::::::* ',
76277  &' *::::::::!!::::::::::::::::*! ',
76278  &' *::::::!!::::::::::::::* !! ',
76279  &' !! *:::!!:::::::::::* !! ',
76280  &' !! !* -><- * !! ',
76281  &' !! !! !! ',
76282  &' !! !! !! ',
76283  &' !! !! ',
76284  &' !! lh !! ',
76285  &' !! !! ',
76286  &' !! hh !! ',
76287  &' !! ll !! ',
76288  &' !! !! ',
76289  &' !! '/
76290  DATA (logo(j),j=20,38)/
76291  &'Welcome to the Lund Monte Carlo!',
76292  &' ',
76293  &'PPP Y Y TTTTT H H III A ',
76294  &'P P Y Y T H H I A A ',
76295  &'PPP Y T HHHHH I AAAAA',
76296  &'P Y T H H I A A',
76297  &'P Y T H H III A A',
76298  &' ',
76299  &'This is PYTHIA version x.xxx ',
76300  &'Last date of change: xx xxx 201x',
76301  &' ',
76302  &'Now is xx xxx 201x at xx:xx:xx ',
76303  &' ',
76304  &'Disclaimer: this program comes ',
76305  &'without any guarantees. Beware ',
76306  &'of errors and use common sense ',
76307  &'when interpreting results. ',
76308  &' ',
76309  &'Copyright T. Sjostrand (2011) '/
76310  DATA (refer(j),j=1,14)/
76311  &'An archive of program versions and d',
76312  &'ocumentation is found on the web: ',
76313  &'http://www.thep.lu.se/~torbjorn/Pyth',
76314  &'ia.html ',
76315  &' ',
76316  &' ',
76317  &'When you cite this program, the offi',
76318  &'cial reference is to the 6.4 manual:',
76319  &'T. Sjostrand, S. Mrenna and P. Skand',
76320  &'s, JHEP05 (2006) 026 ',
76321  &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
76322  &'-T) [hep-ph/0603175]. ',
76323  &' ',
76324  &' '/
76325  DATA (refer(j),j=15,32)/
76326  &'Also remember that the program, to a',
76327  &' large extent, represents original ',
76328  &'physics research. Other publications',
76329  &' of special relevance to your ',
76330  &'studies may therefore deserve separa',
76331  &'te mention. ',
76332  &' ',
76333  &' ',
76334  &'Main author: Torbjorn Sjostrand; Dep',
76335  &'artment of Theoretical Physics, ',
76336  &' Lund University, Solvegatan 14A, S',
76337  &'-223 62 Lund, Sweden; ',
76338  &' phone: + 46 - 46 - 222 48 16; e-ma',
76339  &'il: torbjorn@thep.lu.se ',
76340  &'Author: Stephen Mrenna; Computing Di',
76341  &'vision, GDS Group, ',
76342  &' Fermi National Accelerator Laborat',
76343  &'ory, MS 234, Batavia, IL 60510, USA;'/
76344  DATA (refer(j),j=33,2*irefer)/
76345  &' phone: + 1 - 630 - 840 - 2556; e-m',
76346  &'ail: mrenna@fnal.gov ',
76347  &'Author: Peter Skands; CERN/PH-TH, CH',
76348  &'-1211 Geneva, Switzerland ',
76349  &' phone: + 41 - 22 - 767 24 47; e-ma',
76350  &'il: peter.skands@cern.ch '/
76351 
76352 C...Check that PYDATA linked (check we are in the year 20xx)
76353  IF(mstp(183)/100.NE.20) THEN
76354  WRITE(*,'(1X,A)')
76355  & 'Error: PYDATA has not been linked.'
76356  WRITE(*,'(1X,A)') 'Execution stopped!'
76357  CALL pystop(8)
76358 
76359 C...Write current version number and current date+time.
76360  ELSE
76361  WRITE(vers,'(I1)') mstp(181)
76362  logo(28)(24:24)=vers
76363  WRITE(subv,'(I3)') mstp(182)
76364  logo(28)(26:28)=subv
76365  IF(mstp(182).LT.100) logo(28)(26:26)='0'
76366  WRITE(date,'(I2)') mstp(185)
76367  logo(29)(22:23)=date
76368  logo(29)(25:27)=month(mstp(184))
76369  WRITE(year,'(I4)') mstp(183)
76370  logo(29)(29:32)=year
76371  CALL pytime(idati)
76372  IF(idati(1).LE.0) THEN
76373  logo(31)=' '
76374  ELSE
76375  WRITE(date,'(I2)') idati(3)
76376  logo(31)(8:9)=date
76377  logo(31)(11:13)=month(max(1,min(12,idati(2))))
76378  WRITE(year,'(I4)') idati(1)
76379  logo(31)(15:18)=year
76380  WRITE(hour,'(I2)') idati(4)
76381  logo(31)(23:24)=hour
76382  WRITE(minu,'(I2)') idati(5)
76383  logo(31)(26:27)=minu
76384  IF(idati(5).LT.10) logo(31)(26:26)='0'
76385  WRITE(seco,'(I2)') idati(6)
76386  logo(31)(29:30)=seco
76387  IF(idati(6).LT.10) logo(31)(29:29)='0'
76388  ENDIF
76389  ENDIF
76390 
76391 C...Loop over lines in header. Define page feed and side borders.
76392  DO 100 ilin=1,29+irefer
76393  line=' '
76394  IF(ilin.EQ.1) THEN
76395  line(1:1)='1'
76396  ELSE
76397  line(2:3)='**'
76398  line(78:79)='**'
76399  ENDIF
76400 
76401 C...Separator lines and logos.
76402  IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.GE.28+irefer) THEN
76403  line(4:77)='***********************************************'//
76404  & '***************************'
76405  ELSEIF(ilin.GE.6.AND.ilin.LE.24) THEN
76406  line(6:37)=logo(ilin-5)
76407  line(44:75)=logo(ilin+14)
76408  ELSEIF(ilin.GE.26.AND.ilin.LE.25+irefer) THEN
76409  line(5:40)=refer(2*ilin-51)
76410  line(41:76)=refer(2*ilin-50)
76411  ENDIF
76412 
76413 C...Write lines to appropriate unit.
76414  WRITE(mstu(11),'(A79)') line
76415  100 CONTINUE
76416 
76417  RETURN
76418  END
76419 
76420 C*********************************************************************
76421 
76422 C...PYUPDA
76423 C...Facilitates the updating of particle and decay data
76424 C...by allowing it to be done in an external file.
76425 
76426  SUBROUTINE pyupda(MUPDA,LFN)
76427 
76428 C...Double precision and integer declarations.
76429  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76430  IMPLICIT INTEGER(i-n)
76431  INTEGER pyk,pychge,pycomp
76432 C...Commonblocks.
76433  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76434  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76435  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
76436  common/pydat4/chaf(500,2)
76437  CHARACTER chaf*16
76438  common/pyint4/mwid(500),wids(500,5)
76439  SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pyint4/
76440 C...Local arrays, character variables and data.
76441  CHARACTER chinl*120,chkf*9,chvar(22)*9,chlin*72,
76442  &chblk(20)*72,chold*16,chtmp*16,chnew*16,chcom*24
76443  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
76444  &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
76445  &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
76446  &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
76447  &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
76448 
76449 C...Write header if not yet done.
76450  IF(mstu(12).NE.12345) CALL pylist(0)
76451 
76452 C...Write information on file for editing.
76453  IF(mupda.EQ.1) THEN
76454  DO 110 kc=1,500
76455  WRITE(lfn,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
76456  & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
76457  & mwid(kc),mdcy(kc,1)
76458  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
76459  WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
76460  & (kfdp(idc,j),j=1,5)
76461  100 CONTINUE
76462  110 CONTINUE
76463 
76464 C...Read complete set of information from edited file or
76465 C...read partial set of new or updated information from edited file.
76466  ELSEIF(mupda.EQ.2.OR.mupda.EQ.3) THEN
76467 
76468 C...Reset counters.
76469  kcc=100
76470  ndc=0
76471  chkf=' '
76472  IF(mupda.EQ.2) THEN
76473  DO 120 i=1,mstu(6)
76474  kchg(i,4)=0
76475  120 CONTINUE
76476  ELSE
76477  DO 130 kc=1,mstu(6)
76478  IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
76479  ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
76480  130 CONTINUE
76481  ENDIF
76482 
76483 C...Begin of loop: read new line; unknown whether particle or
76484 C...decay data.
76485  140 READ(lfn,5200,end=190) chinl
76486 
76487 C...Identify particle code and whether already defined (for MUPDA=3).
76488  IF(chinl(2:10).NE.' ') THEN
76489  chkf=chinl(2:10)
76490  READ(chkf,5300) kf
76491  IF(mupda.EQ.2) THEN
76492  IF(kf.LE.100) THEN
76493  kc=kf
76494  ELSE
76495  kcc=kcc+1
76496  kc=kcc
76497  ENDIF
76498  ELSE
76499  kcrep=0
76500  IF(kf.LE.100) THEN
76501  kcrep=kf
76502  ELSE
76503  DO 150 kcr=101,kcc
76504  IF(kchg(kcr,4).EQ.kf) kcrep=kcr
76505  150 CONTINUE
76506  ENDIF
76507 C...Remove duplicate old decay data.
76508  IF(kcrep.NE.0.AND.mdcy(kcrep,3).GT.0) THEN
76509  idcrep=mdcy(kcrep,2)
76510  ndcrep=mdcy(kcrep,3)
76511  DO 160 i=1,kcc
76512  IF(mdcy(i,2).GT.idcrep) mdcy(i,2)=mdcy(i,2)-ndcrep
76513  160 CONTINUE
76514  DO 180 i=idcrep,ndc-ndcrep
76515  mdme(i,1)=mdme(i+ndcrep,1)
76516  mdme(i,2)=mdme(i+ndcrep,2)
76517  brat(i)=brat(i+ndcrep)
76518  DO 170 j=1,5
76519  kfdp(i,j)=kfdp(i+ndcrep,j)
76520  170 CONTINUE
76521  180 CONTINUE
76522  ndc=ndc-ndcrep
76523  kc=kcrep
76524  ELSEIF(kcrep.NE.0) THEN
76525  kc=kcrep
76526  ELSE
76527  kcc=kcc+1
76528  kc=kcc
76529  ENDIF
76530  ENDIF
76531 
76532 C...Study line with particle data.
76533  IF(kc.GT.mstu(6)) CALL pyerrm(27,
76534  & '(PYUPDA:) Particle arrays full by KF ='//chkf)
76535  READ(chinl,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
76536  & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
76537  & mwid(kc),mdcy(kc,1)
76538  mdcy(kc,2)=0
76539  mdcy(kc,3)=0
76540 
76541 C...Study line with decay data.
76542  ELSE
76543  ndc=ndc+1
76544  IF(ndc.GT.mstu(7)) CALL pyerrm(27,
76545  & '(PYUPDA:) Decay data arrays full by KF ='//chkf)
76546  IF(mdcy(kc,2).EQ.0) mdcy(kc,2)=ndc
76547  mdcy(kc,3)=mdcy(kc,3)+1
76548  READ(chinl,5100) mdme(ndc,1),mdme(ndc,2),brat(ndc),
76549  & (kfdp(ndc,j),j=1,5)
76550  ENDIF
76551 
76552 C...End of loop; ensure that PYCOMP tables are updated.
76553  goto 140
76554  190 CONTINUE
76555  mstu(20)=0
76556 
76557 C...Perform possible tests that new information is consistent.
76558  DO 220 kc=1,mstu(6)
76559  kf=kchg(kc,4)
76560  IF(kf.EQ.0) goto 220
76561  WRITE(chkf,5300) kf
76562  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
76563  & pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0) CALL pyerrm(17,
76564  & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//chkf)
76565  brsum=0d0
76566  DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
76567  IF(mdme(idc,2).GT.80) goto 210
76568  kq=kchg(kc,1)
76569  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
76570  merr=0
76571  DO 200 j=1,5
76572  kp=kfdp(idc,j)
76573  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
76574  IF(kp.EQ.81) kq=0
76575  ELSEIF(pycomp(kp).EQ.0) THEN
76576  merr=3
76577  ELSE
76578  kq=kq-pychge(kp)
76579  kpc=pycomp(kp)
76580  pms=pms-pmas(kpc,1)
76581  IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
76582  & pmas(kpc,3))
76583  ENDIF
76584  200 CONTINUE
76585  IF(kq.NE.0) merr=max(2,merr)
76586  IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
76587  & merr=max(1,merr)
76588  IF(merr.EQ.3) CALL pyerrm(17,
76589  & '(PYUPDA:) Unknown particle code in decay of KF ='//chkf)
76590  IF(merr.EQ.2) CALL pyerrm(17,
76591  & '(PYUPDA:) Charge not conserved in decay of KF ='//chkf)
76592  IF(merr.EQ.1) CALL pyerrm(7,
76593  & '(PYUPDA:) Kinematically unallowed decay of KF ='//chkf)
76594  brsum=brsum+brat(idc)
76595  210 CONTINUE
76596  WRITE(chtmp,5500) brsum
76597  IF(abs(brsum).GT.0.0005d0.AND.abs(brsum-1d0).GT.0.0005d0)
76598  & CALL pyerrm(7,'(PYUPDA:) Sum of branching ratios is '//
76599  & chtmp(9:16)//' for KF ='//chkf)
76600  220 CONTINUE
76601 
76602 C...Write DATA statements for inclusion in program.
76603  ELSEIF(mupda.EQ.4) THEN
76604 
76605 C...Find out how many codes and decay channels are actually used.
76606  kcc=0
76607  ndc=0
76608  DO 230 i=1,mstu(6)
76609  IF(kchg(i,4).NE.0) THEN
76610  kcc=i
76611  ndc=max(ndc,mdcy(i,2)+mdcy(i,3)-1)
76612  ENDIF
76613  230 CONTINUE
76614 
76615 C...Initialize writing of DATA statements for inclusion in program.
76616  DO 300 ivar=1,22
76617  ndim=mstu(6)
76618  IF(ivar.GE.12.AND.ivar.LE.19) ndim=mstu(7)
76619  nlin=1
76620  chlin=' '
76621  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
76622  llin=35
76623  chold='START'
76624 
76625 C...Loop through variables for conversion to characters.
76626  DO 280 idim=1,ndim
76627  IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
76628  IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
76629  IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
76630  IF(ivar.EQ.4) WRITE(chtmp,5400) kchg(idim,4)
76631  IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,1)
76632  IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,2)
76633  IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,3)
76634  IF(ivar.EQ.8) WRITE(chtmp,5500) pmas(idim,4)
76635  IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,1)
76636  IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,2)
76637  IF(ivar.EQ.11) WRITE(chtmp,5400) mdcy(idim,3)
76638  IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,1)
76639  IF(ivar.EQ.13) WRITE(chtmp,5400) mdme(idim,2)
76640  IF(ivar.EQ.14) WRITE(chtmp,5600) brat(idim)
76641  IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,1)
76642  IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,2)
76643  IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,3)
76644  IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,4)
76645  IF(ivar.EQ.19) WRITE(chtmp,5400) kfdp(idim,5)
76646  IF(ivar.EQ.20) chtmp=chaf(idim,1)
76647  IF(ivar.EQ.21) chtmp=chaf(idim,2)
76648  IF(ivar.EQ.22) WRITE(chtmp,5400) mwid(idim)
76649 
76650 C...Replace variables beyond what is properly defined.
76651  IF(ivar.LE.4) THEN
76652  IF(idim.GT.kcc) chtmp=' 0'
76653  ELSEIF(ivar.LE.8) THEN
76654  IF(idim.GT.kcc) chtmp=' 0.0'
76655  ELSEIF(ivar.LE.11) THEN
76656  IF(idim.GT.kcc) chtmp=' 0'
76657  ELSEIF(ivar.LE.13) THEN
76658  IF(idim.GT.ndc) chtmp=' 0'
76659  ELSEIF(ivar.LE.14) THEN
76660  IF(idim.GT.ndc) chtmp=' 0.0'
76661  ELSEIF(ivar.LE.19) THEN
76662  IF(idim.GT.ndc) chtmp=' 0'
76663  ELSEIF(ivar.LE.21) THEN
76664  IF(idim.GT.kcc) chtmp=' '
76665  ELSE
76666  IF(idim.GT.kcc) chtmp=' 0'
76667  ENDIF
76668 
76669 C...Length of variable, trailing decimal zeros, quotation marks.
76670  llow=1
76671  lhig=1
76672  DO 240 ll=1,16
76673  IF(chtmp(17-ll:17-ll).NE.' ') llow=17-ll
76674  IF(chtmp(ll:ll).NE.' ') lhig=ll
76675  240 CONTINUE
76676  chnew=chtmp(llow:lhig)//' '
76677  lnew=1+lhig-llow
76678  IF((ivar.GE.5.AND.ivar.LE.8).OR.ivar.EQ.14) THEN
76679  lnew=lnew+1
76680  250 lnew=lnew-1
76681  IF(lnew.GE.2.AND.chnew(lnew:lnew).EQ.'0') goto 250
76682  IF(chnew(lnew:lnew).EQ.'.') lnew=lnew-1
76683  IF(lnew.EQ.0) THEN
76684  chnew(1:3)='0D0'
76685  lnew=3
76686  ELSE
76687  chnew(lnew+1:lnew+2)='D0'
76688  lnew=lnew+2
76689  ENDIF
76690  ELSEIF(ivar.EQ.20.OR.ivar.EQ.21) THEN
76691  DO 260 ll=lnew,1,-1
76692  IF(chnew(ll:ll).EQ.'''') THEN
76693  chtmp=chnew
76694  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
76695  lnew=lnew+1
76696  ENDIF
76697  260 CONTINUE
76698  lnew=min(14,lnew)
76699  chtmp=chnew
76700  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
76701  lnew=lnew+2
76702  ENDIF
76703 
76704 C...Form composite character string, often including repetition counter.
76705  IF(chnew.NE.chold) THEN
76706  nrpt=1
76707  chold=chnew
76708  chcom=chnew
76709  lcom=lnew
76710  ELSE
76711  lrpt=lnew+1
76712  IF(nrpt.GE.2) lrpt=lnew+3
76713  IF(nrpt.GE.10) lrpt=lnew+4
76714  IF(nrpt.GE.100) lrpt=lnew+5
76715  IF(nrpt.GE.1000) lrpt=lnew+6
76716  llin=llin-lrpt
76717  nrpt=nrpt+1
76718  WRITE(chtmp,5400) nrpt
76719  lrpt=1
76720  IF(nrpt.GE.10) lrpt=2
76721  IF(nrpt.GE.100) lrpt=3
76722  IF(nrpt.GE.1000) lrpt=4
76723  chcom(1:lrpt+1+lnew)=chtmp(17-lrpt:16)//'*'//chnew(1:lnew)
76724  lcom=lrpt+1+lnew
76725  ENDIF
76726 
76727 C...Add characters to end of line, to new line (after storing old line),
76728 C...or to new block of lines (after writing old block).
76729  IF(llin+lcom.LE.70) THEN
76730  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
76731  llin=llin+lcom+1
76732  ELSEIF(nlin.LE.19) THEN
76733  chlin(llin+1:72)=' '
76734  chblk(nlin)=chlin
76735  nlin=nlin+1
76736  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
76737  llin=6+lcom+1
76738  ELSE
76739  chlin(llin:72)='/'//' '
76740  chblk(nlin)=chlin
76741  WRITE(chtmp,5400) idim-nrpt
76742  chblk(1)(30:33)=chtmp(13:16)
76743  DO 270 ilin=1,nlin
76744  WRITE(lfn,5700) chblk(ilin)
76745  270 CONTINUE
76746  nlin=1
76747  chlin=' '
76748  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//
76749  & ',I= , )/'//chcom(1:lcom)//','
76750  WRITE(chtmp,5400) idim-nrpt+1
76751  chlin(25:28)=chtmp(13:16)
76752  llin=35+lcom+1
76753  ENDIF
76754  280 CONTINUE
76755 
76756 C...Write final block of lines.
76757  chlin(llin:72)='/'//' '
76758  chblk(nlin)=chlin
76759  WRITE(chtmp,5400) ndim
76760  chblk(1)(30:33)=chtmp(13:16)
76761  DO 290 ilin=1,nlin
76762  WRITE(lfn,5700) chblk(ilin)
76763  290 CONTINUE
76764  300 CONTINUE
76765  ENDIF
76766 
76767 C...Formats for reading and writing particle data.
76768  5000 FORMAT(1x,i9,2x,a16,2x,a16,3i3,3f12.5,1p,e13.5,2i3)
76769  5100 FORMAT(10x,2i5,f12.6,5i10)
76770  5200 FORMAT(a120)
76771  5300 FORMAT(i9)
76772  5400 FORMAT(i16)
76773  5500 FORMAT(f16.5)
76774  5600 FORMAT(f16.6)
76775  5700 FORMAT(a72)
76776 
76777  RETURN
76778  END
76779 
76780 C*********************************************************************
76781 
76782 C...PYK
76783 C...Provides various integer-valued event related data.
76784 
76785  FUNCTION pyk(I,J)
76786 
76787 C...Double precision and integer declarations.
76788  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76789  IMPLICIT INTEGER(i-n)
76790  INTEGER pyk,pychge,pycomp
76791 C...Commonblocks.
76792  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
76793  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76794  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76795  SAVE /pyjets/,/pydat1/,/pydat2/
76796 
76797 C...Default value. For I=0 number of entries, number of stable entries
76798 C...or 3 times total charge.
76799  pyk=0
76800  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
76801  ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
76802  pyk=n
76803  ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
76804  DO 100 i1=1,n
76805  IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+1
76806  IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+
76807  & pychge(k(i1,2))
76808  100 CONTINUE
76809  ELSEIF(i.EQ.0) THEN
76810 
76811 C...For I > 0 direct readout of K matrix or charge.
76812  ELSEIF(j.LE.5) THEN
76813  pyk=k(i,j)
76814  ELSEIF(j.EQ.6) THEN
76815  pyk=pychge(k(i,2))
76816 
76817 C...Status (existing/fragmented/decayed), parton/hadron separation.
76818  ELSEIF(j.LE.8) THEN
76819  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pyk=1
76820  IF(j.EQ.8) pyk=pyk*k(i,2)
76821  ELSEIF(j.LE.12) THEN
76822  kfa=iabs(k(i,2))
76823  kc=pycomp(kfa)
76824  kq=0
76825  IF(kc.NE.0) kq=kchg(kc,2)
76826  IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) pyk=k(i,2)
76827  IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) pyk=k(i,2)
76828  IF(j.EQ.11) pyk=kc
76829  IF(j.EQ.12) pyk=kq*isign(1,k(i,2))
76830 
76831 C...Heaviest flavour in hadron/diquark.
76832  ELSEIF(j.EQ.13) THEN
76833  kfa=iabs(k(i,2))
76834  pyk=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
76835  IF(kfa.LT.10) pyk=kfa
76836  IF(mod(kfa/1000,10).NE.0) pyk=mod(kfa/1000,10)
76837  pyk=pyk*isign(1,k(i,2))
76838 
76839 C...Particle history: generation, ancestor, rank.
76840  ELSEIF(j.LE.15) THEN
76841  i2=i
76842  i1=i
76843  110 pyk=pyk+1
76844  i2=i1
76845  i1=k(i1,3)
76846  IF(i1.GT.0) THEN
76847  IF(k(i1,1).GT.0.AND.k(i1,1).LE.20) goto 110
76848  ENDIF
76849  IF(j.EQ.15) pyk=i2
76850  ELSEIF(j.EQ.16) THEN
76851  kfa=iabs(k(i,2))
76852  IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.
76853  & (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN
76854  i1=i
76855  120 i2=i1
76856  i1=k(i1,3)
76857  IF(i1.GT.0) THEN
76858  kfam=iabs(k(i1,2))
76859  ilp=1
76860  IF(kfam.NE.0.AND.kfam.LE.10) ilp=0
76861  IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)
76862  & ilp=0
76863  IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0
76864  IF(ilp.EQ.1) goto 120
76865  ENDIF
76866  IF(k(i1,1).EQ.12) THEN
76867  DO 130 i3=i1+1,i2
76868  IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92
76869  & .AND.k(i3,2).NE.93) pyk=pyk+1
76870  130 CONTINUE
76871  ELSE
76872  i3=i2
76873  140 pyk=pyk+1
76874  i3=i3+1
76875  IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) goto 140
76876  ENDIF
76877  ENDIF
76878 
76879 C...Particle coming from collapsing jet system or not.
76880  ELSEIF(j.EQ.17) THEN
76881  i1=i
76882  150 pyk=pyk+1
76883  i3=i1
76884  i1=k(i1,3)
76885  i0=max(1,i1)
76886  kc=pycomp(k(i0,2))
76887  IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
76888  IF(pyk.EQ.1) pyk=-1
76889  IF(pyk.GT.1) pyk=0
76890  RETURN
76891  ENDIF
76892  IF(kchg(kc,2).EQ.0) goto 150
76893  IF(k(i1,1).NE.12) pyk=0
76894  IF(k(i1,1).NE.12) RETURN
76895  i2=i1
76896  160 i2=i2+1
76897  IF(i2.LT.n.AND.k(i2,1).NE.11) goto 160
76898  k3m=k(i3-1,3)
76899  IF(k3m.GE.i1.AND.k3m.LE.i2) pyk=0
76900  k3p=k(i3+1,3)
76901  IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) pyk=0
76902 
76903 C...Number of decay products. Colour flow.
76904  ELSEIF(j.EQ.18) THEN
76905  IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) pyk=max(0,k(i,5)-k(i,4)+1)
76906  IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) pyk=0
76907  ELSEIF(j.LE.22) THEN
76908  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
76909  IF(j.EQ.19) pyk=mod(k(i,4)/mstu(5),mstu(5))
76910  IF(j.EQ.20) pyk=mod(k(i,5)/mstu(5),mstu(5))
76911  IF(j.EQ.21) pyk=mod(k(i,4),mstu(5))
76912  IF(j.EQ.22) pyk=mod(k(i,5),mstu(5))
76913  ELSE
76914  ENDIF
76915 
76916  RETURN
76917  END
76918 
76919 C*********************************************************************
76920 
76921 C...PYP
76922 C...Provides various real-valued event related data.
76923 
76924  FUNCTION pyp(I,J)
76925 
76926 C...Double precision and integer declarations.
76927  IMPLICIT DOUBLE PRECISION(a-h, o-z)
76928  IMPLICIT INTEGER(i-n)
76929  INTEGER pyk,pychge,pycomp
76930 C...Commonblocks.
76931  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
76932  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76933  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76934  SAVE /pyjets/,/pydat1/,/pydat2/
76935 C...Local array.
76936  dimension psum(4)
76937 
76938 C...Set default value. For I = 0 sum of momenta or charges,
76939 C...or invariant mass of system.
76940  pyp=0d0
76941  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
76942  ELSEIF(i.EQ.0.AND.j.LE.4) THEN
76943  DO 100 i1=1,n
76944  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+p(i1,j)
76945  100 CONTINUE
76946  ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
76947  DO 120 j1=1,4
76948  psum(j1)=0d0
76949  DO 110 i1=1,n
76950  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+
76951  & p(i1,j1)
76952  110 CONTINUE
76953  120 CONTINUE
76954  pyp=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
76955  ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
76956  DO 130 i1=1,n
76957  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+pychge(k(i1,2))/3d0
76958  130 CONTINUE
76959  ELSEIF(i.EQ.0) THEN
76960 
76961 C...Direct readout of P matrix.
76962  ELSEIF(j.LE.5) THEN
76963  pyp=p(i,j)
76964 
76965 C...Charge, total momentum, transverse momentum, transverse mass.
76966  ELSEIF(j.LE.12) THEN
76967  IF(j.EQ.6) pyp=pychge(k(i,2))/3d0
76968  IF(j.EQ.7.OR.j.EQ.8) pyp=p(i,1)**2+p(i,2)**2+p(i,3)**2
76969  IF(j.EQ.9.OR.j.EQ.10) pyp=p(i,1)**2+p(i,2)**2
76970  IF(j.EQ.11.OR.j.EQ.12) pyp=p(i,5)**2+p(i,1)**2+p(i,2)**2
76971  IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) pyp=sqrt(pyp)
76972 
76973 C...Theta and phi angle in radians or degrees.
76974  ELSEIF(j.LE.16) THEN
76975  IF(j.LE.14) pyp=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
76976  IF(j.GE.15) pyp=pyangl(p(i,1),p(i,2))
76977  IF(j.EQ.14.OR.j.EQ.16) pyp=pyp*180d0/paru(1)
76978 
76979 C...True rapidity, rapidity with pion mass, pseudorapidity.
76980  ELSEIF(j.LE.19) THEN
76981  pmr=0d0
76982  IF(j.EQ.17) pmr=p(i,5)
76983  IF(j.EQ.18) pmr=pymass(211)
76984  pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
76985  pyp=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
76986  & 1d20)),p(i,3))
76987 
76988 C...Energy and momentum fractions (only to be used in CM frame).
76989  ELSEIF(j.LE.25) THEN
76990  IF(j.EQ.20) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
76991  IF(j.EQ.21) pyp=2d0*p(i,3)/paru(21)
76992  IF(j.EQ.22) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
76993  IF(j.EQ.23) pyp=2d0*p(i,4)/paru(21)
76994  IF(j.EQ.24) pyp=(p(i,4)+p(i,3))/paru(21)
76995  IF(j.EQ.25) pyp=(p(i,4)-p(i,3))/paru(21)
76996  ENDIF
76997 
76998  RETURN
76999  END
77000 
77001 C*********************************************************************
77002 
77003 C...PYSPHE
77004 C...Performs sphericity tensor analysis to give sphericity,
77005 C...aplanarity and the related event axes.
77006 
77007  SUBROUTINE pysphe(SPH,APL)
77008 
77009 C...Double precision and integer declarations.
77010  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77011  IMPLICIT INTEGER(i-n)
77012  INTEGER pyk,pychge,pycomp
77013 C...Parameter statement to help give large particle numbers.
77014  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
77015  &kexcit=4000000,kdimen=5000000)
77016 C...Commonblocks.
77017  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77018  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77019  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77020  SAVE /pyjets/,/pydat1/,/pydat2/
77021 C...Local arrays.
77022  dimension sm(3,3),sv(3,3)
77023 
77024 C...Calculate matrix to be diagonalized.
77025  np=0
77026  DO 110 j1=1,3
77027  DO 100 j2=j1,3
77028  sm(j1,j2)=0d0
77029  100 CONTINUE
77030  110 CONTINUE
77031  ps=0d0
77032  DO 140 i=1,n
77033  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
77034  IF(mstu(41).GE.2) THEN
77035  kc=pycomp(k(i,2))
77036  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
77037  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
77038  & k(i,2).EQ.ksusy1+39) goto 140
77039  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
77040  & goto 140
77041  ENDIF
77042  np=np+1
77043  pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
77044  pwt=1d0
77045  IF(abs(paru(41)-2d0).GT.0.001d0) pwt=
77046  & max(1d-10,pa)**(paru(41)-2d0)
77047  DO 130 j1=1,3
77048  DO 120 j2=j1,3
77049  sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
77050  120 CONTINUE
77051  130 CONTINUE
77052  ps=ps+pwt*pa**2
77053  140 CONTINUE
77054 
77055 C...Very low multiplicities (0 or 1) not considered.
77056  IF(np.LE.1) THEN
77057  CALL pyerrm(8,'(PYSPHE:) too few particles for analysis')
77058  sph=-1d0
77059  apl=-1d0
77060  RETURN
77061  ENDIF
77062  DO 160 j1=1,3
77063  DO 150 j2=j1,3
77064  sm(j1,j2)=sm(j1,j2)/ps
77065  150 CONTINUE
77066  160 CONTINUE
77067 
77068 C...Find eigenvalues to matrix (third degree equation).
77069  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
77070  &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
77071  sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
77072  &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
77073  &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
77074  sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
77075  p(n+1,4)=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
77076  p(n+3,4)=1d0/3d0+sqrt(-sq)*min(2d0*sp,-sqrt(3d0*(1d0-sp**2))-sp)
77077  p(n+2,4)=1d0-p(n+1,4)-p(n+3,4)
77078  IF(p(n+2,4).LT.1d-5) THEN
77079  CALL pyerrm(8,'(PYSPHE:) all particles back-to-back')
77080  sph=-1d0
77081  apl=-1d0
77082  RETURN
77083  ENDIF
77084 
77085 C...Find first and last eigenvector by solving equation system.
77086  DO 240 i=1,3,2
77087  DO 180 j1=1,3
77088  sv(j1,j1)=sm(j1,j1)-p(n+i,4)
77089  DO 170 j2=j1+1,3
77090  sv(j1,j2)=sm(j1,j2)
77091  sv(j2,j1)=sm(j1,j2)
77092  170 CONTINUE
77093  180 CONTINUE
77094  smax=0d0
77095  DO 200 j1=1,3
77096  DO 190 j2=1,3
77097  IF(abs(sv(j1,j2)).LE.smax) goto 190
77098  ja=j1
77099  jb=j2
77100  smax=abs(sv(j1,j2))
77101  190 CONTINUE
77102  200 CONTINUE
77103  smax=0d0
77104  DO 220 j3=ja+1,ja+2
77105  j1=j3-3*((j3-1)/3)
77106  rl=sv(j1,jb)/sv(ja,jb)
77107  DO 210 j2=1,3
77108  sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
77109  IF(abs(sv(j1,j2)).LE.smax) goto 210
77110  jc=j1
77111  smax=abs(sv(j1,j2))
77112  210 CONTINUE
77113  220 CONTINUE
77114  jb1=jb+1-3*(jb/3)
77115  jb2=jb+2-3*((jb+1)/3)
77116  p(n+i,jb1)=-sv(jc,jb2)
77117  p(n+i,jb2)=sv(jc,jb1)
77118  p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
77119  & sv(ja,jb)
77120  pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
77121  sgn=(-1d0)**int(pyr(0)+0.5d0)
77122  DO 230 j=1,3
77123  p(n+i,j)=sgn*p(n+i,j)/pa
77124  230 CONTINUE
77125  240 CONTINUE
77126 
77127 C...Middle axis orthogonal to other two. Fill other codes.
77128  sgn=(-1d0)**int(pyr(0)+0.5d0)
77129  p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
77130  p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
77131  p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
77132  DO 260 i=1,3
77133  k(n+i,1)=31
77134  k(n+i,2)=95
77135  k(n+i,3)=i
77136  k(n+i,4)=0
77137  k(n+i,5)=0
77138  p(n+i,5)=0d0
77139  DO 250 j=1,5
77140  v(i,j)=0d0
77141  250 CONTINUE
77142  260 CONTINUE
77143 
77144 C...Calculate sphericity and aplanarity. Select storing option.
77145  sph=1.5d0*(p(n+2,4)+p(n+3,4))
77146  apl=1.5d0*p(n+3,4)
77147  mstu(61)=n+1
77148  mstu(62)=np
77149  IF(mstu(43).LE.1) mstu(3)=3
77150  IF(mstu(43).GE.2) n=n+3
77151 
77152  RETURN
77153  END
77154 
77155 C*********************************************************************
77156 
77157 C...PYTHRU
77158 C...Performs thrust analysis to give thrust, oblateness
77159 C...and the related event axes.
77160 
77161  SUBROUTINE pythru(THR,OBL)
77162 
77163 C...Double precision and integer declarations.
77164  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77165  IMPLICIT INTEGER(i-n)
77166  INTEGER pyk,pychge,pycomp
77167 C...Parameter statement to help give large particle numbers.
77168  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
77169  &kexcit=4000000,kdimen=5000000)
77170 C...Commonblocks.
77171  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77172  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77173  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77174  SAVE /pyjets/,/pydat1/,/pydat2/
77175 C...Local arrays.
77176  dimension tdi(3),tpr(3)
77177 
77178 C...Take copy of particles that are to be considered in thrust analysis.
77179  np=0
77180  ps=0d0
77181  DO 100 i=1,n
77182  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
77183  IF(mstu(41).GE.2) THEN
77184  kc=pycomp(k(i,2))
77185  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
77186  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
77187  & k(i,2).EQ.ksusy1+39) goto 100
77188  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
77189  & goto 100
77190  ENDIF
77191  IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
77192  CALL pyerrm(11,'(PYTHRU:) no more memory left in PYJETS')
77193  thr=-2d0
77194  obl=-2d0
77195  RETURN
77196  ENDIF
77197  np=np+1
77198  k(n+np,1)=23
77199  p(n+np,1)=p(i,1)
77200  p(n+np,2)=p(i,2)
77201  p(n+np,3)=p(i,3)
77202  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
77203  p(n+np,5)=1d0
77204  IF(abs(paru(42)-1d0).GT.0.001d0) p(n+np,5)=
77205  & p(n+np,4)**(paru(42)-1d0)
77206  ps=ps+p(n+np,4)*p(n+np,5)
77207  100 CONTINUE
77208 
77209 C...Very low multiplicities (0 or 1) not considered.
77210  IF(np.LE.1) THEN
77211  CALL pyerrm(8,'(PYTHRU:) too few particles for analysis')
77212  thr=-1d0
77213  obl=-1d0
77214  RETURN
77215  ENDIF
77216 
77217 C...Loop over thrust and major. T axis along z direction in latter case.
77218  DO 320 ild=1,2
77219  IF(ild.EQ.2) THEN
77220  k(n+np+1,1)=31
77221  phi=pyangl(p(n+np+1,1),p(n+np+1,2))
77222  mstu(33)=1
77223  CALL pyrobo(n+1,n+np+1,0d0,-phi,0d0,0d0,0d0)
77224  the=pyangl(p(n+np+1,3),p(n+np+1,1))
77225  CALL pyrobo(n+1,n+np+1,-the,0d0,0d0,0d0,0d0)
77226  ENDIF
77227 
77228 C...Find and order particles with highest p (pT for major).
77229  DO 110 ilf=n+np+4,n+np+mstu(44)+4
77230  p(ilf,4)=0d0
77231  110 CONTINUE
77232  DO 160 i=n+1,n+np
77233  IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
77234  DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
77235  IF(p(i,4).LE.p(ilf,4)) goto 140
77236  DO 120 j=1,5
77237  p(ilf+1,j)=p(ilf,j)
77238  120 CONTINUE
77239  130 CONTINUE
77240  ilf=n+np+3
77241  140 DO 150 j=1,5
77242  p(ilf+1,j)=p(i,j)
77243  150 CONTINUE
77244  160 CONTINUE
77245 
77246 C...Find and order initial axes with highest thrust (major).
77247  DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
77248  p(ilg,4)=0d0
77249  170 CONTINUE
77250  nc=2**(min(mstu(44),np)-1)
77251  DO 250 ilc=1,nc
77252  DO 180 j=1,3
77253  tdi(j)=0d0
77254  180 CONTINUE
77255  DO 200 ilf=1,min(mstu(44),np)
77256  sgn=p(n+np+ilf+3,5)
77257  IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
77258  DO 190 j=1,4-ild
77259  tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
77260  190 CONTINUE
77261  200 CONTINUE
77262  tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
77263  DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
77264  IF(tds.LE.p(ilg,4)) goto 230
77265  DO 210 j=1,4
77266  p(ilg+1,j)=p(ilg,j)
77267  210 CONTINUE
77268  220 CONTINUE
77269  ilg=n+np+mstu(44)+4
77270  230 DO 240 j=1,3
77271  p(ilg+1,j)=tdi(j)
77272  240 CONTINUE
77273  p(ilg+1,4)=tds
77274  250 CONTINUE
77275 
77276 C...Iterate direction of axis until stable maximum.
77277  p(n+np+ild,4)=0d0
77278  ilg=0
77279  260 ilg=ilg+1
77280  thp=0d0
77281  270 thps=thp
77282  DO 280 j=1,3
77283  IF(thp.LE.1d-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
77284  IF(thp.GT.1d-10) tdi(j)=tpr(j)
77285  tpr(j)=0d0
77286  280 CONTINUE
77287  DO 300 i=n+1,n+np
77288  sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
77289  DO 290 j=1,4-ild
77290  tpr(j)=tpr(j)+sgn*p(i,j)
77291  290 CONTINUE
77292  300 CONTINUE
77293  thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
77294  IF(thp.GE.thps+paru(48)) goto 270
77295 
77296 C...Save good axis. Try new initial axis until a number of tries agree.
77297  IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) goto 260
77298  IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
77299  iagr=0
77300  sgn=(-1d0)**int(pyr(0)+0.5d0)
77301  DO 310 j=1,3
77302  p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
77303  310 CONTINUE
77304  p(n+np+ild,4)=thp
77305  p(n+np+ild,5)=0d0
77306  ENDIF
77307  iagr=iagr+1
77308  IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) goto 260
77309  320 CONTINUE
77310 
77311 C...Find minor axis and value by orthogonality.
77312  sgn=(-1d0)**int(pyr(0)+0.5d0)
77313  p(n+np+3,1)=-sgn*p(n+np+2,2)
77314  p(n+np+3,2)=sgn*p(n+np+2,1)
77315  p(n+np+3,3)=0d0
77316  thp=0d0
77317  DO 330 i=n+1,n+np
77318  thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
77319  330 CONTINUE
77320  p(n+np+3,4)=thp/ps
77321  p(n+np+3,5)=0d0
77322 
77323 C...Fill axis information. Rotate back to original coordinate system.
77324  DO 350 ild=1,3
77325  k(n+ild,1)=31
77326  k(n+ild,2)=96
77327  k(n+ild,3)=ild
77328  k(n+ild,4)=0
77329  k(n+ild,5)=0
77330  DO 340 j=1,5
77331  p(n+ild,j)=p(n+np+ild,j)
77332  v(n+ild,j)=0d0
77333  340 CONTINUE
77334  350 CONTINUE
77335  CALL pyrobo(n+1,n+3,the,phi,0d0,0d0,0d0)
77336 
77337 C...Calculate thrust and oblateness. Select storing option.
77338  thr=p(n+1,4)
77339  obl=p(n+2,4)-p(n+3,4)
77340  mstu(61)=n+1
77341  mstu(62)=np
77342  IF(mstu(43).LE.1) mstu(3)=3
77343  IF(mstu(43).GE.2) n=n+3
77344 
77345  RETURN
77346  END
77347 
77348 C*********************************************************************
77349 
77350 C...PYCLUS
77351 C...Subdivides the particle content of an event into jets/clusters.
77352 
77353  SUBROUTINE pyclus(NJET)
77354 
77355 C...Double precision and integer declarations.
77356  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77357  IMPLICIT INTEGER(i-n)
77358  INTEGER pyk,pychge,pycomp
77359 C...Parameter statement to help give large particle numbers.
77360  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
77361  &kexcit=4000000,kdimen=5000000)
77362 C...Commonblocks.
77363  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77364  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77365  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77366  SAVE /pyjets/,/pydat1/,/pydat2/
77367 C...Local arrays and saved variables.
77368  dimension ps(5)
77369  SAVE nsav,np,ps,pss,rinit,npre,nrem
77370 
77371 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
77372  r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
77373  &p(i1,3)*p(i2,3))*2d0*p(i1,5)*p(i2,5)/(0.0001d0+p(i1,5)+p(i2,5))**2
77374  r2m(i1,i2)=2d0*p(i1,4)*p(i2,4)*(1d0-(p(i1,1)*p(i2,1)+p(i1,2)*
77375  &p(i2,2)+p(i1,3)*p(i2,3))/max(1d-10,p(i1,5)*p(i2,5)))
77376  r2d(i1,i2)=2d0*min(p(i1,4),p(i2,4))**2*(1d0-(p(i1,1)*p(i2,1)+
77377  &p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/max(1d-10,p(i1,5)*p(i2,5)))
77378 
77379 C...If first time, reset. If reentering, skip preliminaries.
77380  IF(mstu(48).LE.0) THEN
77381  np=0
77382  DO 100 j=1,5
77383  ps(j)=0d0
77384  100 CONTINUE
77385  pss=0d0
77386  pimass=pmas(pycomp(211),1)
77387  ELSE
77388  njet=nsav
77389  IF(mstu(43).GE.2) n=n-njet
77390  DO 110 i=n+1,n+njet
77391  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
77392  110 CONTINUE
77393  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
77394  r2acc=paru(44)**2
77395  ELSE
77396  r2acc=paru(45)*ps(5)**2
77397  ENDIF
77398  nloop=0
77399  goto 300
77400  ENDIF
77401 
77402 C...Find which particles are to be considered in cluster search.
77403  DO 140 i=1,n
77404  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
77405  IF(mstu(41).GE.2) THEN
77406  kc=pycomp(k(i,2))
77407  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
77408  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
77409  & k(i,2).EQ.ksusy1+39) goto 140
77410  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
77411  & goto 140
77412  ENDIF
77413  IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
77414  CALL pyerrm(11,'(PYCLUS:) no more memory left in PYJETS')
77415  njet=-1
77416  RETURN
77417  ENDIF
77418 
77419 C...Take copy of these particles, with space left for jets later on.
77420  np=np+1
77421  k(n+np,3)=i
77422  DO 120 j=1,5
77423  p(n+np,j)=p(i,j)
77424  120 CONTINUE
77425  IF(mstu(42).EQ.0) p(n+np,5)=0d0
77426  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
77427  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
77428  p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
77429  DO 130 j=1,4
77430  ps(j)=ps(j)+p(n+np,j)
77431  130 CONTINUE
77432  pss=pss+p(n+np,5)
77433  140 CONTINUE
77434  DO 160 i=n+1,n+np
77435  k(i+np,3)=k(i,3)
77436  DO 150 j=1,5
77437  p(i+np,j)=p(i,j)
77438  150 CONTINUE
77439  160 CONTINUE
77440  ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
77441 
77442 C...Very low multiplicities not considered.
77443  IF(np.LT.mstu(47)) THEN
77444  CALL pyerrm(8,'(PYCLUS:) too few particles for analysis')
77445  njet=-1
77446  RETURN
77447  ENDIF
77448 
77449 C...Find precluster configuration. If too few jets, make harder cuts.
77450  nloop=0
77451  IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
77452  r2acc=paru(44)**2
77453  ELSE
77454  r2acc=paru(45)*ps(5)**2
77455  ENDIF
77456  rinit=1.25d0*paru(43)
77457  IF(np.LE.mstu(47)+2) rinit=0d0
77458  170 rinit=0.8d0*rinit
77459  npre=0
77460  nrem=np
77461  DO 180 i=n+np+1,n+2*np
77462  k(i,4)=0
77463  180 CONTINUE
77464 
77465 C...Sum up small momentum region. Jet if enough absolute momentum.
77466  IF(mstu(46).LE.2) THEN
77467  DO 190 j=1,4
77468  p(n+1,j)=0d0
77469  190 CONTINUE
77470  DO 210 i=n+np+1,n+2*np
77471  IF(p(i,5).GT.2d0*rinit) goto 210
77472  nrem=nrem-1
77473  k(i,4)=1
77474  DO 200 j=1,4
77475  p(n+1,j)=p(n+1,j)+p(i,j)
77476  200 CONTINUE
77477  210 CONTINUE
77478  p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
77479  IF(p(n+1,5).GT.2d0*rinit) npre=1
77480  IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
77481  IF(nrem.EQ.0) goto 170
77482  ENDIF
77483 
77484 C...Find fastest remaining particle.
77485  220 npre=npre+1
77486  pmax=0d0
77487  DO 230 i=n+np+1,n+2*np
77488  IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) goto 230
77489  imax=i
77490  pmax=p(i,5)
77491  230 CONTINUE
77492  DO 240 j=1,5
77493  p(n+npre,j)=p(imax,j)
77494  240 CONTINUE
77495  nrem=nrem-1
77496  k(imax,4)=npre
77497 
77498 C...Sum up precluster around it according to pT separation.
77499  IF(mstu(46).LE.2) THEN
77500  DO 260 i=n+np+1,n+2*np
77501  IF(k(i,4).NE.0) goto 260
77502  r2=r2t(i,imax)
77503  IF(r2.GT.rinit**2) goto 260
77504  nrem=nrem-1
77505  k(i,4)=npre
77506  DO 250 j=1,4
77507  p(n+npre,j)=p(n+npre,j)+p(i,j)
77508  250 CONTINUE
77509  260 CONTINUE
77510  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
77511 
77512 C...Sum up precluster around it according to mass or
77513 C...Durham pT separation.
77514  ELSE
77515  270 imin=0
77516  r2min=rinit**2
77517  DO 280 i=n+np+1,n+2*np
77518  IF(k(i,4).NE.0) goto 280
77519  IF(mstu(46).LE.4) THEN
77520  r2=r2m(i,n+npre)
77521  ELSE
77522  r2=r2d(i,n+npre)
77523  ENDIF
77524  IF(r2.GE.r2min) goto 280
77525  imin=i
77526  r2min=r2
77527  280 CONTINUE
77528  IF(imin.NE.0) THEN
77529  DO 290 j=1,4
77530  p(n+npre,j)=p(n+npre,j)+p(imin,j)
77531  290 CONTINUE
77532  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
77533  nrem=nrem-1
77534  k(imin,4)=npre
77535  goto 270
77536  ENDIF
77537  ENDIF
77538 
77539 C...Check if more preclusters to be found. Start over if too few.
77540  IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
77541  IF(nrem.GT.0) goto 220
77542  njet=npre
77543 
77544 C...Reassign all particles to nearest jet. Sum up new jet momenta.
77545  300 tsav=0d0
77546  psjt=0d0
77547  310 IF(mstu(46).LE.1) THEN
77548  DO 330 i=n+1,n+njet
77549  DO 320 j=1,4
77550  v(i,j)=0d0
77551  320 CONTINUE
77552  330 CONTINUE
77553  DO 360 i=n+np+1,n+2*np
77554  r2min=pss**2
77555  DO 340 ijet=n+1,n+njet
77556  IF(p(ijet,5).LT.rinit) goto 340
77557  r2=r2t(i,ijet)
77558  IF(r2.GE.r2min) goto 340
77559  imin=ijet
77560  r2min=r2
77561  340 CONTINUE
77562  k(i,4)=imin-n
77563  DO 350 j=1,4
77564  v(imin,j)=v(imin,j)+p(i,j)
77565  350 CONTINUE
77566  360 CONTINUE
77567  psjt=0d0
77568  DO 380 i=n+1,n+njet
77569  DO 370 j=1,4
77570  p(i,j)=v(i,j)
77571  370 CONTINUE
77572  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
77573  psjt=psjt+p(i,5)
77574  380 CONTINUE
77575  ENDIF
77576 
77577 C...Find two closest jets.
77578  r2min=2d0*max(r2acc,ps(5)**2)
77579  DO 400 itry1=n+1,n+njet-1
77580  DO 390 itry2=itry1+1,n+njet
77581  IF(mstu(46).LE.2) THEN
77582  r2=r2t(itry1,itry2)
77583  ELSEIF(mstu(46).LE.4) THEN
77584  r2=r2m(itry1,itry2)
77585  ELSE
77586  r2=r2d(itry1,itry2)
77587  ENDIF
77588  IF(r2.GE.r2min) goto 390
77589  imin1=itry1
77590  imin2=itry2
77591  r2min=r2
77592  390 CONTINUE
77593  400 CONTINUE
77594 
77595 C...If allowed, join two closest jets and start over.
77596  IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
77597  irec=min(imin1,imin2)
77598  idel=max(imin1,imin2)
77599  DO 410 j=1,4
77600  p(irec,j)=p(imin1,j)+p(imin2,j)
77601  410 CONTINUE
77602  p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
77603  DO 430 i=idel+1,n+njet
77604  DO 420 j=1,5
77605  p(i-1,j)=p(i,j)
77606  420 CONTINUE
77607  430 CONTINUE
77608  IF(mstu(46).GE.2) THEN
77609  DO 440 i=n+np+1,n+2*np
77610  iori=n+k(i,4)
77611  IF(iori.EQ.idel) k(i,4)=irec-n
77612  IF(iori.GT.idel) k(i,4)=k(i,4)-1
77613  440 CONTINUE
77614  ENDIF
77615  njet=njet-1
77616  goto 300
77617 
77618 C...Divide up broad jet if empty cluster in list of final ones.
77619  ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
77620  DO 450 i=n+1,n+njet
77621  k(i,5)=0
77622  450 CONTINUE
77623  DO 460 i=n+np+1,n+2*np
77624  k(n+k(i,4),5)=k(n+k(i,4),5)+1
77625  460 CONTINUE
77626  iemp=0
77627  DO 470 i=n+1,n+njet
77628  IF(k(i,5).EQ.0) iemp=i
77629  470 CONTINUE
77630  IF(iemp.NE.0) THEN
77631  nloop=nloop+1
77632  ispl=0
77633  r2max=0d0
77634  DO 480 i=n+np+1,n+2*np
77635  IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) goto 480
77636  ijet=n+k(i,4)
77637  r2=r2t(i,ijet)
77638  IF(r2.LE.r2max) goto 480
77639  ispl=i
77640  r2max=r2
77641  480 CONTINUE
77642  IF(ispl.NE.0) THEN
77643  ijet=n+k(ispl,4)
77644  DO 490 j=1,4
77645  p(iemp,j)=p(ispl,j)
77646  p(ijet,j)=p(ijet,j)-p(ispl,j)
77647  490 CONTINUE
77648  p(iemp,5)=p(ispl,5)
77649  p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
77650  IF(nloop.LE.2) goto 300
77651  ENDIF
77652  ENDIF
77653  ENDIF
77654 
77655 C...If generalized thrust has not yet converged, continue iteration.
77656  IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
77657  &THEN
77658  tsav=psjt/pss
77659  goto 310
77660  ENDIF
77661 
77662 C...Reorder jets according to energy.
77663  DO 510 i=n+1,n+njet
77664  DO 500 j=1,5
77665  v(i,j)=p(i,j)
77666  500 CONTINUE
77667  510 CONTINUE
77668  DO 540 inew=n+1,n+njet
77669  pemax=0d0
77670  DO 520 itry=n+1,n+njet
77671  IF(v(itry,4).LE.pemax) goto 520
77672  imax=itry
77673  pemax=v(itry,4)
77674  520 CONTINUE
77675  k(inew,1)=31
77676  k(inew,2)=97
77677  k(inew,3)=inew-n
77678  k(inew,4)=0
77679  DO 530 j=1,5
77680  p(inew,j)=v(imax,j)
77681  530 CONTINUE
77682  v(imax,4)=-1d0
77683  k(imax,5)=inew
77684  540 CONTINUE
77685 
77686 C...Clean up particle-jet assignments and jet information.
77687  DO 550 i=n+np+1,n+2*np
77688  iori=k(n+k(i,4),5)
77689  k(i,4)=iori-n
77690  IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
77691  k(iori,4)=k(iori,4)+1
77692  550 CONTINUE
77693  iemp=0
77694  psjt=0d0
77695  DO 570 i=n+1,n+njet
77696  k(i,5)=0
77697  psjt=psjt+p(i,5)
77698  p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0d0))
77699  DO 560 j=1,5
77700  v(i,j)=0d0
77701  560 CONTINUE
77702  IF(k(i,4).EQ.0) iemp=i
77703  570 CONTINUE
77704 
77705 C...Select storing option. Output variables. Check for failure.
77706  mstu(61)=n+1
77707  mstu(62)=np
77708  mstu(63)=npre
77709  paru(61)=ps(5)
77710  paru(62)=psjt/pss
77711  paru(63)=sqrt(r2min)
77712  IF(njet.LE.1) paru(63)=0d0
77713  IF(iemp.NE.0) THEN
77714  CALL pyerrm(8,'(PYCLUS:) failed to reconstruct as requested')
77715  njet=-1
77716  RETURN
77717  ENDIF
77718  IF(mstu(43).LE.1) mstu(3)=max(0,njet)
77719  IF(mstu(43).GE.2) n=n+max(0,njet)
77720  nsav=njet
77721 
77722  RETURN
77723  END
77724 
77725 C*********************************************************************
77726 
77727 C...PYCELL
77728 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
77729 C...as used for calorimeters at hadron colliders.
77730 
77731  SUBROUTINE pycell(NJET)
77732 
77733 C...Double precision and integer declarations.
77734  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77735  IMPLICIT INTEGER(i-n)
77736  INTEGER pyk,pychge,pycomp
77737 C...Parameter statement to help give large particle numbers.
77738  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
77739  &kexcit=4000000,kdimen=5000000)
77740 C...Commonblocks.
77741  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77742  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77743  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77744  SAVE /pyjets/,/pydat1/,/pydat2/
77745 
77746 C...Loop over all particles. Find cell that was hit by given particle.
77747  ptlrat=1d0/sinh(paru(51))**2
77748  np=0
77749  nc=n
77750  DO 110 i=1,n
77751  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
77752  IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) goto 110
77753  IF(mstu(41).GE.2) THEN
77754  kc=pycomp(k(i,2))
77755  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
77756  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
77757  & k(i,2).EQ.ksusy1+39) goto 110
77758  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
77759  & goto 110
77760  ENDIF
77761  np=np+1
77762  pt=sqrt(p(i,1)**2+p(i,2)**2)
77763  eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
77764  ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5d0*
77765  & (eta/paru(51)+1d0))))
77766  phi=pyangl(p(i,1),p(i,2))
77767  iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5d0*
77768  & (phi/paru(1)+1d0))))
77769  ietph=mstu(52)*ieta+iphi
77770 
77771 C...Add to cell already hit, or book new cell.
77772  DO 100 ic=n+1,nc
77773  IF(ietph.EQ.k(ic,3)) THEN
77774  k(ic,4)=k(ic,4)+1
77775  p(ic,5)=p(ic,5)+pt
77776  goto 110
77777  ENDIF
77778  100 CONTINUE
77779  IF(nc.GE.mstu(4)-mstu(32)-5) THEN
77780  CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
77781  njet=-2
77782  RETURN
77783  ENDIF
77784  nc=nc+1
77785  k(nc,3)=ietph
77786  k(nc,4)=1
77787  k(nc,5)=2
77788  p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
77789  p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
77790  p(nc,5)=pt
77791  110 CONTINUE
77792 
77793 C...Smear true bin content by calorimeter resolution.
77794  IF(mstu(53).GE.1) THEN
77795  DO 130 ic=n+1,nc
77796  pei=p(ic,5)
77797  IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))
77798  120 pef=pei+paru(55)*sqrt(-2d0*log(max(1d-10,pyr(0)))*pei)*
77799  & cos(paru(2)*pyr(0))
77800  IF(pef.LT.0d0.OR.pef.GT.paru(56)*pei) goto 120
77801  p(ic,5)=pef
77802  IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))
77803  130 CONTINUE
77804  ENDIF
77805 
77806 C...Remove cells below threshold.
77807  IF(paru(58).GT.0d0) THEN
77808  ncc=nc
77809  nc=n
77810  DO 140 ic=n+1,ncc
77811  IF(p(ic,5).GT.paru(58)) THEN
77812  nc=nc+1
77813  k(nc,3)=k(ic,3)
77814  k(nc,4)=k(ic,4)
77815  k(nc,5)=k(ic,5)
77816  p(nc,1)=p(ic,1)
77817  p(nc,2)=p(ic,2)
77818  p(nc,5)=p(ic,5)
77819  ENDIF
77820  140 CONTINUE
77821  ENDIF
77822 
77823 C...Find initiator cell: the one with highest pT of not yet used ones.
77824  nj=nc
77825  150 etmax=0d0
77826  DO 160 ic=n+1,nc
77827  IF(k(ic,5).NE.2) goto 160
77828  IF(p(ic,5).LE.etmax) goto 160
77829  icmax=ic
77830  eta=p(ic,1)
77831  phi=p(ic,2)
77832  etmax=p(ic,5)
77833  160 CONTINUE
77834  IF(etmax.LT.paru(52)) goto 220
77835  IF(nj.GE.mstu(4)-mstu(32)-5) THEN
77836  CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
77837  njet=-2
77838  RETURN
77839  ENDIF
77840  k(icmax,5)=1
77841  nj=nj+1
77842  k(nj,4)=0
77843  k(nj,5)=1
77844  p(nj,1)=eta
77845  p(nj,2)=phi
77846  p(nj,3)=0d0
77847  p(nj,4)=0d0
77848  p(nj,5)=0d0
77849 
77850 C...Sum up unused cells within required distance of initiator.
77851  DO 170 ic=n+1,nc
77852  IF(k(ic,5).EQ.0) goto 170
77853  IF(abs(p(ic,1)-eta).GT.paru(54)) goto 170
77854  dphia=abs(p(ic,2)-phi)
77855  IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) goto 170
77856  phic=p(ic,2)
77857  IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
77858  IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) goto 170
77859  k(ic,5)=-k(ic,5)
77860  k(nj,4)=k(nj,4)+k(ic,4)
77861  p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
77862  p(nj,4)=p(nj,4)+p(ic,5)*phic
77863  p(nj,5)=p(nj,5)+p(ic,5)
77864  170 CONTINUE
77865 
77866 C...Reject cluster below minimum ET, else accept.
77867  IF(p(nj,5).LT.paru(53)) THEN
77868  nj=nj-1
77869  DO 180 ic=n+1,nc
77870  IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
77871  180 CONTINUE
77872  ELSEIF(mstu(54).LE.2) THEN
77873  p(nj,3)=p(nj,3)/p(nj,5)
77874  p(nj,4)=p(nj,4)/p(nj,5)
77875  IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
77876  & p(nj,4))
77877  DO 190 ic=n+1,nc
77878  IF(k(ic,5).LT.0) k(ic,5)=0
77879  190 CONTINUE
77880  ELSE
77881  DO 200 j=1,4
77882  p(nj,j)=0d0
77883  200 CONTINUE
77884  DO 210 ic=n+1,nc
77885  IF(k(ic,5).GE.0) goto 210
77886  p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
77887  p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
77888  p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
77889  p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
77890  k(ic,5)=0
77891  210 CONTINUE
77892  ENDIF
77893  goto 150
77894 
77895 C...Arrange clusters in falling ET sequence.
77896  220 DO 250 i=1,nj-nc
77897  etmax=0d0
77898  DO 230 ij=nc+1,nj
77899  IF(k(ij,5).EQ.0) goto 230
77900  IF(p(ij,5).LT.etmax) goto 230
77901  ijmax=ij
77902  etmax=p(ij,5)
77903  230 CONTINUE
77904  k(ijmax,5)=0
77905  k(n+i,1)=31
77906  k(n+i,2)=98
77907  k(n+i,3)=i
77908  k(n+i,4)=k(ijmax,4)
77909  k(n+i,5)=0
77910  DO 240 j=1,5
77911  p(n+i,j)=p(ijmax,j)
77912  v(n+i,j)=0d0
77913  240 CONTINUE
77914  250 CONTINUE
77915  njet=nj-nc
77916 
77917 C...Convert to massless or massive four-vectors.
77918  IF(mstu(54).EQ.2) THEN
77919  DO 260 i=n+1,n+njet
77920  eta=p(i,3)
77921  p(i,1)=p(i,5)*cos(p(i,4))
77922  p(i,2)=p(i,5)*sin(p(i,4))
77923  p(i,3)=p(i,5)*sinh(eta)
77924  p(i,4)=p(i,5)*cosh(eta)
77925  p(i,5)=0d0
77926  260 CONTINUE
77927  ELSEIF(mstu(54).GE.3) THEN
77928  DO 270 i=n+1,n+njet
77929  p(i,5)=sqrt(max(0d0,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
77930  270 CONTINUE
77931  ENDIF
77932 
77933 C...Information about storage.
77934  mstu(61)=n+1
77935  mstu(62)=np
77936  mstu(63)=nc-n
77937  IF(mstu(43).LE.1) mstu(3)=max(0,njet)
77938  IF(mstu(43).GE.2) n=n+max(0,njet)
77939 
77940  RETURN
77941  END
77942 
77943 C*********************************************************************
77944 
77945 C...PYJMAS
77946 C...Determines, approximately, the two jet masses that minimize
77947 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
77948 
77949  SUBROUTINE pyjmas(PMH,PML)
77950 
77951 C...Double precision and integer declarations.
77952  IMPLICIT DOUBLE PRECISION(a-h, o-z)
77953  IMPLICIT INTEGER(i-n)
77954  INTEGER pyk,pychge,pycomp
77955 C...Parameter statement to help give large particle numbers.
77956  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
77957  &kexcit=4000000,kdimen=5000000)
77958 C...Commonblocks.
77959  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77960  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77961  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77962  SAVE /pyjets/,/pydat1/,/pydat2/
77963 C...Local arrays.
77964  dimension sm(3,3),sax(3),ps(3,5)
77965 
77966 C...Reset.
77967  np=0
77968  DO 120 j1=1,3
77969  DO 100 j2=j1,3
77970  sm(j1,j2)=0d0
77971  100 CONTINUE
77972  DO 110 j2=1,4
77973  ps(j1,j2)=0d0
77974  110 CONTINUE
77975  120 CONTINUE
77976  pss=0d0
77977  pimass=pmas(pycomp(211),1)
77978 
77979 C...Take copy of particles that are to be considered in mass analysis.
77980  DO 170 i=1,n
77981  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170
77982  IF(mstu(41).GE.2) THEN
77983  kc=pycomp(k(i,2))
77984  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
77985  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
77986  & k(i,2).EQ.ksusy1+39) goto 170
77987  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
77988  & goto 170
77989  ENDIF
77990  IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
77991  CALL pyerrm(11,'(PYJMAS:) no more memory left in PYJETS')
77992  pmh=-2d0
77993  pml=-2d0
77994  RETURN
77995  ENDIF
77996  np=np+1
77997  DO 130 j=1,5
77998  p(n+np,j)=p(i,j)
77999  130 CONTINUE
78000  IF(mstu(42).EQ.0) p(n+np,5)=0d0
78001  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
78002  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
78003 
78004 C...Fill information in sphericity tensor and total momentum vector.
78005  DO 150 j1=1,3
78006  DO 140 j2=j1,3
78007  sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
78008  140 CONTINUE
78009  150 CONTINUE
78010  pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
78011  DO 160 j=1,4
78012  ps(3,j)=ps(3,j)+p(n+np,j)
78013  160 CONTINUE
78014  170 CONTINUE
78015 
78016 C...Very low multiplicities (0 or 1) not considered.
78017  IF(np.LE.1) THEN
78018  CALL pyerrm(8,'(PYJMAS:) too few particles for analysis')
78019  pmh=-1d0
78020  pml=-1d0
78021  RETURN
78022  ENDIF
78023  paru(61)=sqrt(max(0d0,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-
78024  &ps(3,3)**2))
78025 
78026 C...Find largest eigenvalue to matrix (third degree equation).
78027  DO 190 j1=1,3
78028  DO 180 j2=j1,3
78029  sm(j1,j2)=sm(j1,j2)/pss
78030  180 CONTINUE
78031  190 CONTINUE
78032  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
78033  &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
78034  sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
78035  &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
78036  &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
78037  sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
78038  sma=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
78039 
78040 C...Find largest eigenvector by solving equation system.
78041  DO 210 j1=1,3
78042  sm(j1,j1)=sm(j1,j1)-sma
78043  DO 200 j2=j1+1,3
78044  sm(j2,j1)=sm(j1,j2)
78045  200 CONTINUE
78046  210 CONTINUE
78047  smax=0d0
78048  DO 230 j1=1,3
78049  DO 220 j2=1,3
78050  IF(abs(sm(j1,j2)).LE.smax) goto 220
78051  ja=j1
78052  jb=j2
78053  smax=abs(sm(j1,j2))
78054  220 CONTINUE
78055  230 CONTINUE
78056  smax=0d0
78057  DO 250 j3=ja+1,ja+2
78058  j1=j3-3*((j3-1)/3)
78059  rl=sm(j1,jb)/sm(ja,jb)
78060  DO 240 j2=1,3
78061  sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
78062  IF(abs(sm(j1,j2)).LE.smax) goto 240
78063  jc=j1
78064  smax=abs(sm(j1,j2))
78065  240 CONTINUE
78066  250 CONTINUE
78067  jb1=jb+1-3*(jb/3)
78068  jb2=jb+2-3*((jb+1)/3)
78069  sax(jb1)=-sm(jc,jb2)
78070  sax(jb2)=sm(jc,jb1)
78071  sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
78072 
78073 C...Divide particles into two initial clusters by hemisphere.
78074  DO 270 i=n+1,n+np
78075  psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
78076  is=1
78077  IF(psax.LT.0d0) is=2
78078  k(i,3)=is
78079  DO 260 j=1,4
78080  ps(is,j)=ps(is,j)+p(i,j)
78081  260 CONTINUE
78082  270 CONTINUE
78083  pms=max(1d-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
78084  &max(1d-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
78085 
78086 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
78087  280 pmd=0d0
78088  im=0
78089  DO 290 j=1,4
78090  ps(3,j)=ps(1,j)-ps(2,j)
78091  290 CONTINUE
78092  DO 300 i=n+1,n+np
78093  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)
78094  IF(k(i,3).EQ.1) pmdi=2d0*(p(i,5)**2-pps)
78095  IF(k(i,3).EQ.2) pmdi=2d0*(p(i,5)**2+pps)
78096  IF(pmdi.LT.pmd) THEN
78097  pmd=pmdi
78098  im=i
78099  ENDIF
78100  300 CONTINUE
78101 
78102 C...Loop back if significant reduction in sum of m^2.
78103  IF(pmd.LT.-paru(48)*pms) THEN
78104  pms=pms+pmd
78105  is=k(im,3)
78106  DO 310 j=1,4
78107  ps(is,j)=ps(is,j)-p(im,j)
78108  ps(3-is,j)=ps(3-is,j)+p(im,j)
78109  310 CONTINUE
78110  k(im,3)=3-is
78111  goto 280
78112  ENDIF
78113 
78114 C...Final masses and output.
78115  mstu(61)=n+1
78116  mstu(62)=np
78117  ps(1,5)=sqrt(max(0d0,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
78118  ps(2,5)=sqrt(max(0d0,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
78119  pmh=max(ps(1,5),ps(2,5))
78120  pml=min(ps(1,5),ps(2,5))
78121 
78122  RETURN
78123  END
78124 
78125 C*********************************************************************
78126 
78127 C...PYFOWO
78128 C...Calculates the first few Fox-Wolfram moments.
78129 
78130  SUBROUTINE pyfowo(H10,H20,H30,H40)
78131 
78132 C...Double precision and integer declarations.
78133  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78134  IMPLICIT INTEGER(i-n)
78135  INTEGER pyk,pychge,pycomp
78136 C...Parameter statement to help give large particle numbers.
78137  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
78138  &kexcit=4000000,kdimen=5000000)
78139 C...Commonblocks.
78140  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
78141  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78142  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
78143  SAVE /pyjets/,/pydat1/,/pydat2/
78144 
78145 C...Copy momenta for particles and calculate H0.
78146  np=0
78147  h0=0d0
78148  hd=0d0
78149  DO 110 i=1,n
78150  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
78151  IF(mstu(41).GE.2) THEN
78152  kc=pycomp(k(i,2))
78153  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
78154  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
78155  & k(i,2).EQ.ksusy1+39) goto 110
78156  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
78157  & goto 110
78158  ENDIF
78159  IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
78160  CALL pyerrm(11,'(PYFOWO:) no more memory left in PYJETS')
78161  h10=-1d0
78162  h20=-1d0
78163  h30=-1d0
78164  h40=-1d0
78165  RETURN
78166  ENDIF
78167  np=np+1
78168  DO 100 j=1,3
78169  p(n+np,j)=p(i,j)
78170  100 CONTINUE
78171  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
78172  h0=h0+p(n+np,4)
78173  hd=hd+p(n+np,4)**2
78174  110 CONTINUE
78175  h0=h0**2
78176 
78177 C...Very low multiplicities (0 or 1) not considered.
78178  IF(np.LE.1) THEN
78179  CALL pyerrm(8,'(PYFOWO:) too few particles for analysis')
78180  h10=-1d0
78181  h20=-1d0
78182  h30=-1d0
78183  h40=-1d0
78184  RETURN
78185  ENDIF
78186 
78187 C...Calculate H1 - H4.
78188  h10=0d0
78189  h20=0d0
78190  h30=0d0
78191  h40=0d0
78192  DO 130 i1=n+1,n+np
78193  DO 120 i2=i1+1,n+np
78194  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
78195  & (p(i1,4)*p(i2,4))
78196  h10=h10+p(i1,4)*p(i2,4)*cthe
78197  h20=h20+p(i1,4)*p(i2,4)*(1.5d0*cthe**2-0.5d0)
78198  h30=h30+p(i1,4)*p(i2,4)*(2.5d0*cthe**3-1.5d0*cthe)
78199  h40=h40+p(i1,4)*p(i2,4)*(4.375d0*cthe**4-3.75d0*cthe**2+
78200  & 0.375d0)
78201  120 CONTINUE
78202  130 CONTINUE
78203 
78204 C...Calculate H1/H0 - H4/H0. Output.
78205  mstu(61)=n+1
78206  mstu(62)=np
78207  h10=(hd+2d0*h10)/h0
78208  h20=(hd+2d0*h20)/h0
78209  h30=(hd+2d0*h30)/h0
78210  h40=(hd+2d0*h40)/h0
78211 
78212  RETURN
78213  END
78214 
78215 C*********************************************************************
78216 
78217 C...PYTABU
78218 C...Evaluates various properties of an event, with statistics
78219 C...accumulated during the course of the run and
78220 C...printed at the end.
78221 
78222  SUBROUTINE pytabu(MTABU)
78223 
78224 C...Double precision and integer declarations.
78225  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78226  IMPLICIT INTEGER(i-n)
78227  INTEGER pyk,pychge,pycomp
78228 C...Parameter statement to help give large particle numbers.
78229  parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
78230  &kexcit=4000000,kdimen=5000000)
78231 C...Commonblocks.
78232  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
78233  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78234  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
78235  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
78236  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
78237 C...Local arrays, character variables, saved variables and data.
78238  dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
78239  &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
78240  &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
78241  &kfdm(8),kfdc(200,0:8),npdc(200)
78242  SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
78243  &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
78244  &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
78245  CHARACTER chau*16,chis(2)*12,chdc(8)*12
78246  DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
78247  &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0d0/,fm2fm/120*0d0/,
78248  &nevee/0/,fe1ec/50*0d0/,fe2ec/50*0d0/,fe1ea/25*0d0/,fe2ea/25*0d0/,
78249  &nevdc/0/,nkfdc/0/,nredc/0/
78250 
78251 C...Reset statistics on initial parton state.
78252  IF(mtabu.EQ.10) THEN
78253  nevis=0
78254  nkfis=0
78255 
78256 C...Identify and order flavour content of initial state.
78257  ELSEIF(mtabu.EQ.11) THEN
78258  nevis=nevis+1
78259  kfm1=2*iabs(mstu(161))
78260  IF(mstu(161).GT.0) kfm1=kfm1-1
78261  kfm2=2*iabs(mstu(162))
78262  IF(mstu(162).GT.0) kfm2=kfm2-1
78263  kfmn=min(kfm1,kfm2)
78264  kfmx=max(kfm1,kfm2)
78265  DO 100 i=1,nkfis
78266  IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
78267  ikfis=-i
78268  goto 110
78269  ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
78270  & kfmx.LT.kfis(i,2))) THEN
78271  ikfis=i
78272  goto 110
78273  ENDIF
78274  100 CONTINUE
78275  ikfis=nkfis+1
78276  110 IF(ikfis.LT.0) THEN
78277  ikfis=-ikfis
78278  ELSE
78279  IF(nkfis.GE.100) RETURN
78280  DO 130 i=nkfis,ikfis,-1
78281  kfis(i+1,1)=kfis(i,1)
78282  kfis(i+1,2)=kfis(i,2)
78283  DO 120 j=0,10
78284  npis(i+1,j)=npis(i,j)
78285  120 CONTINUE
78286  130 CONTINUE
78287  nkfis=nkfis+1
78288  kfis(ikfis,1)=kfmn
78289  kfis(ikfis,2)=kfmx
78290  DO 140 j=0,10
78291  npis(ikfis,j)=0
78292  140 CONTINUE
78293  ENDIF
78294  npis(ikfis,0)=npis(ikfis,0)+1
78295 
78296 C...Count number of partons in initial state.
78297  np=0
78298  DO 160 i=1,n
78299  IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
78300  ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
78301  ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
78302  & THEN
78303  ELSE
78304  im=i
78305  150 im=k(im,3)
78306  IF(im.LE.0.OR.im.GT.n) THEN
78307  np=np+1
78308  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
78309  np=np+1
78310  ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
78311  ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10)
78312  & .NE.0) THEN
78313  ELSE
78314  goto 150
78315  ENDIF
78316  ENDIF
78317  160 CONTINUE
78318  npco=max(np,1)
78319  IF(np.GE.6) npco=6
78320  IF(np.GE.8) npco=7
78321  IF(np.GE.11) npco=8
78322  IF(np.GE.16) npco=9
78323  IF(np.GE.26) npco=10
78324  npis(ikfis,npco)=npis(ikfis,npco)+1
78325  mstu(62)=np
78326 
78327 C...Write statistics on initial parton state.
78328  ELSEIF(mtabu.EQ.12) THEN
78329  fac=1d0/max(1,nevis)
78330  WRITE(mstu(11),5000) nevis
78331  DO 170 i=1,nkfis
78332  kfmn=kfis(i,1)
78333  IF(kfmn.EQ.0) kfmn=kfis(i,2)
78334  kfm1=(kfmn+1)/2
78335  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
78336  CALL pyname(kfm1,chau)
78337  chis(1)=chau(1:12)
78338  IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
78339  kfmx=kfis(i,2)
78340  IF(kfis(i,1).EQ.0) kfmx=0
78341  kfm2=(kfmx+1)/2
78342  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
78343  CALL pyname(kfm2,chau)
78344  chis(2)=chau(1:12)
78345  IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
78346  WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
78347  & (npis(i,j)/dble(npis(i,0)),j=1,10)
78348  170 CONTINUE
78349 
78350 C...Copy statistics on initial parton state into /PYJETS/.
78351  ELSEIF(mtabu.EQ.13) THEN
78352  fac=1d0/max(1,nevis)
78353  DO 190 i=1,nkfis
78354  kfmn=kfis(i,1)
78355  IF(kfmn.EQ.0) kfmn=kfis(i,2)
78356  kfm1=(kfmn+1)/2
78357  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
78358  kfmx=kfis(i,2)
78359  IF(kfis(i,1).EQ.0) kfmx=0
78360  kfm2=(kfmx+1)/2
78361  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
78362  k(i,1)=32
78363  k(i,2)=99
78364  k(i,3)=kfm1
78365  k(i,4)=kfm2
78366  k(i,5)=npis(i,0)
78367  DO 180 j=1,5
78368  p(i,j)=fac*npis(i,j)
78369  v(i,j)=fac*npis(i,j+5)
78370  180 CONTINUE
78371  190 CONTINUE
78372  n=nkfis
78373  DO 200 j=1,5
78374  k(n+1,j)=0
78375  p(n+1,j)=0d0
78376  v(n+1,j)=0d0
78377  200 CONTINUE
78378  k(n+1,1)=32
78379  k(n+1,2)=99
78380  k(n+1,5)=nevis
78381  mstu(3)=1
78382 
78383 C...Reset statistics on number of particles/partons.
78384  ELSEIF(mtabu.EQ.20) THEN
78385  nevfs=0
78386  nprfs=0
78387  nfifs=0
78388  nchfs=0
78389  nkffs=0
78390 
78391 C...Identify whether particle/parton is primary or not.
78392  ELSEIF(mtabu.EQ.21) THEN
78393  nevfs=nevfs+1
78394  mstu(62)=0
78395  DO 260 i=1,n
78396  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) goto 260
78397  mstu(62)=mstu(62)+1
78398  kc=pycomp(k(i,2))
78399  mpri=0
78400  IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
78401  mpri=1
78402  ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
78403  mpri=1
78404  ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
78405  mpri=1
78406  ELSEIF(kc.EQ.0) THEN
78407  ELSEIF(k(k(i,3),1).EQ.13) THEN
78408  im=k(k(i,3),3)
78409  IF(im.LE.0.OR.im.GT.n) THEN
78410  mpri=1
78411  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
78412  mpri=1
78413  ENDIF
78414  ELSEIF(kchg(kc,2).EQ.0) THEN
78415  kcm=pycomp(k(k(i,3),2))
78416  IF(kcm.NE.0) THEN
78417  IF(kchg(kcm,2).NE.0) mpri=1
78418  ENDIF
78419  ENDIF
78420  IF(kc.NE.0.AND.mpri.EQ.1) THEN
78421  IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
78422  ENDIF
78423  IF(k(i,1).LE.10) THEN
78424  nfifs=nfifs+1
78425  IF(pychge(k(i,2)).NE.0) nchfs=nchfs+1
78426  ENDIF
78427 
78428 C...Fill statistics on number of particles/partons in event.
78429  kfa=iabs(k(i,2))
78430  kfs=3-isign(1,k(i,2))-mpri
78431  DO 210 ip=1,nkffs
78432  IF(kfa.EQ.kffs(ip)) THEN
78433  ikffs=-ip
78434  goto 220
78435  ELSEIF(kfa.LT.kffs(ip)) THEN
78436  ikffs=ip
78437  goto 220
78438  ENDIF
78439  210 CONTINUE
78440  ikffs=nkffs+1
78441  220 IF(ikffs.LT.0) THEN
78442  ikffs=-ikffs
78443  ELSE
78444  IF(nkffs.GE.400) RETURN
78445  DO 240 ip=nkffs,ikffs,-1
78446  kffs(ip+1)=kffs(ip)
78447  DO 230 j=1,4
78448  npfs(ip+1,j)=npfs(ip,j)
78449  230 CONTINUE
78450  240 CONTINUE
78451  nkffs=nkffs+1
78452  kffs(ikffs)=kfa
78453  DO 250 j=1,4
78454  npfs(ikffs,j)=0
78455  250 CONTINUE
78456  ENDIF
78457  npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
78458  260 CONTINUE
78459 
78460 C...Write statistics on particle/parton composition of events.
78461  ELSEIF(mtabu.EQ.22) THEN
78462  fac=1d0/max(1,nevfs)
78463  WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
78464  DO 270 i=1,nkffs
78465  CALL pyname(kffs(i),chau)
78466  kc=pycomp(kffs(i))
78467  mdcyf=0
78468  IF(kc.NE.0) mdcyf=mdcy(kc,1)
78469  WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
78470  & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
78471  270 CONTINUE
78472 
78473 C...Copy particle/parton composition information into /PYJETS/.
78474  ELSEIF(mtabu.EQ.23) THEN
78475  fac=1d0/max(1,nevfs)
78476  DO 290 i=1,nkffs
78477  k(i,1)=32
78478  k(i,2)=99
78479  k(i,3)=kffs(i)
78480  k(i,4)=0
78481  k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
78482  DO 280 j=1,4
78483  p(i,j)=fac*npfs(i,j)
78484  v(i,j)=0d0
78485  280 CONTINUE
78486  p(i,5)=fac*k(i,5)
78487  v(i,5)=0d0
78488  290 CONTINUE
78489  n=nkffs
78490  DO 300 j=1,5
78491  k(n+1,j)=0
78492  p(n+1,j)=0d0
78493  v(n+1,j)=0d0
78494  300 CONTINUE
78495  k(n+1,1)=32
78496  k(n+1,2)=99
78497  k(n+1,5)=nevfs
78498  p(n+1,1)=fac*nprfs
78499  p(n+1,2)=fac*nfifs
78500  p(n+1,3)=fac*nchfs
78501  mstu(3)=1
78502 
78503 C...Reset factorial moments statistics.
78504  ELSEIF(mtabu.EQ.30) THEN
78505  nevfm=0
78506  nmufm=0
78507  DO 330 im=1,3
78508  DO 320 ib=1,10
78509  DO 310 ip=1,4
78510  fm1fm(im,ib,ip)=0d0
78511  fm2fm(im,ib,ip)=0d0
78512  310 CONTINUE
78513  320 CONTINUE
78514  330 CONTINUE
78515 
78516 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
78517  ELSEIF(mtabu.EQ.31) THEN
78518  nevfm=nevfm+1
78519  nlow=n+mstu(3)
78520  nupp=nlow
78521  DO 410 i=1,n
78522  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 410
78523  IF(mstu(41).GE.2) THEN
78524  kc=pycomp(k(i,2))
78525  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
78526  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
78527  & k(i,2).EQ.ksusy1+39) goto 410
78528  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
78529  & pychge(k(i,2)).EQ.0) goto 410
78530  ENDIF
78531  pmr=0d0
78532  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
78533  IF(mstu(42).GE.2) pmr=p(i,5)
78534  pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
78535  yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
78536  & 1d20)),p(i,3))
78537  IF(abs(yeta).GT.paru(57)) goto 410
78538  phi=pyangl(p(i,1),p(i,2))
78539  iyeta=512d0*(yeta+paru(57))/(2d0*paru(57))
78540  iyeta=max(0,min(511,iyeta))
78541  iphi=512d0*(phi+paru(1))/paru(2)
78542  iphi=max(0,min(511,iphi))
78543  iyep=0
78544  DO 340 ib=0,9
78545  iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
78546  340 CONTINUE
78547 
78548 C...Order particles in (pseudo)rapidity and/or azimuth.
78549  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
78550  CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
78551  RETURN
78552  ENDIF
78553  nupp=nupp+1
78554  IF(nupp.EQ.nlow+1) THEN
78555  k(nupp,1)=iyeta
78556  k(nupp,2)=iphi
78557  k(nupp,3)=iyep
78558  ELSE
78559  DO 350 i1=nupp-1,nlow+1,-1
78560  IF(iyeta.GE.k(i1,1)) goto 360
78561  k(i1+1,1)=k(i1,1)
78562  350 CONTINUE
78563  360 k(i1+1,1)=iyeta
78564  DO 370 i1=nupp-1,nlow+1,-1
78565  IF(iphi.GE.k(i1,2)) goto 380
78566  k(i1+1,2)=k(i1,2)
78567  370 CONTINUE
78568  380 k(i1+1,2)=iphi
78569  DO 390 i1=nupp-1,nlow+1,-1
78570  IF(iyep.GE.k(i1,3)) goto 400
78571  k(i1+1,3)=k(i1,3)
78572  390 CONTINUE
78573  400 k(i1+1,3)=iyep
78574  ENDIF
78575  410 CONTINUE
78576  k(nupp+1,1)=2**10
78577  k(nupp+1,2)=2**10
78578  k(nupp+1,3)=4**10
78579 
78580 C...Calculate sum of factorial moments in event.
78581  DO 480 im=1,3
78582  DO 430 ib=1,10
78583  DO 420 ip=1,4
78584  fevfm(ib,ip)=0d0
78585  420 CONTINUE
78586  430 CONTINUE
78587  DO 450 ib=1,10
78588  IF(im.LE.2) ibin=2**(10-ib)
78589  IF(im.EQ.3) ibin=4**(10-ib)
78590  iagr=k(nlow+1,im)/ibin
78591  nagr=1
78592  DO 440 i=nlow+2,nupp+1
78593  icut=k(i,im)/ibin
78594  IF(icut.EQ.iagr) THEN
78595  nagr=nagr+1
78596  ELSE
78597  IF(nagr.EQ.1) THEN
78598  ELSEIF(nagr.EQ.2) THEN
78599  fevfm(ib,1)=fevfm(ib,1)+2d0
78600  ELSEIF(nagr.EQ.3) THEN
78601  fevfm(ib,1)=fevfm(ib,1)+6d0
78602  fevfm(ib,2)=fevfm(ib,2)+6d0
78603  ELSEIF(nagr.EQ.4) THEN
78604  fevfm(ib,1)=fevfm(ib,1)+12d0
78605  fevfm(ib,2)=fevfm(ib,2)+24d0
78606  fevfm(ib,3)=fevfm(ib,3)+24d0
78607  ELSE
78608  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1d0)
78609  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1d0)*(nagr-2d0)
78610  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1d0)*(nagr-2d0)*
78611  & (nagr-3d0)
78612  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1d0)*(nagr-2d0)*
78613  & (nagr-3d0)*(nagr-4d0)
78614  ENDIF
78615  iagr=icut
78616  nagr=1
78617  ENDIF
78618  440 CONTINUE
78619  450 CONTINUE
78620 
78621 C...Add results to total statistics.
78622  DO 470 ib=10,1,-1
78623  DO 460 ip=1,4
78624  IF(fevfm(1,ip).LT.0.5d0) THEN
78625  fevfm(ib,ip)=0d0
78626  ELSEIF(im.LE.2) THEN
78627  fevfm(ib,ip)=2d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
78628  ELSE
78629  fevfm(ib,ip)=4d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
78630  ENDIF
78631  fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
78632  fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
78633  460 CONTINUE
78634  470 CONTINUE
78635  480 CONTINUE
78636  nmufm=nmufm+(nupp-nlow)
78637  mstu(62)=nupp-nlow
78638 
78639 C...Write accumulated statistics on factorial moments.
78640  ELSEIF(mtabu.EQ.32) THEN
78641  fac=1d0/max(1,nevfm)
78642  IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
78643  IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
78644  IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
78645  DO 510 im=1,3
78646  WRITE(mstu(11),5500)
78647  DO 500 ib=1,10
78648  byeta=2d0*paru(57)
78649  IF(im.NE.2) byeta=byeta/2**(ib-1)
78650  bphi=paru(2)
78651  IF(im.NE.1) bphi=bphi/2**(ib-1)
78652  IF(im.LE.2) bnave=fac*nmufm/dble(2**(ib-1))
78653  IF(im.EQ.3) bnave=fac*nmufm/dble(4**(ib-1))
78654  DO 490 ip=1,4
78655  fmoma(ip)=fac*fm1fm(im,ib,ip)
78656  fmoms(ip)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
78657  & fmoma(ip)**2)))
78658  490 CONTINUE
78659  WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
78660  & ip=1,4)
78661  500 CONTINUE
78662  510 CONTINUE
78663 
78664 C...Copy statistics on factorial moments into /PYJETS/.
78665  ELSEIF(mtabu.EQ.33) THEN
78666  fac=1d0/max(1,nevfm)
78667  DO 540 im=1,3
78668  DO 530 ib=1,10
78669  i=10*(im-1)+ib
78670  k(i,1)=32
78671  k(i,2)=99
78672  k(i,3)=1
78673  IF(im.NE.2) k(i,3)=2**(ib-1)
78674  k(i,4)=1
78675  IF(im.NE.1) k(i,4)=2**(ib-1)
78676  k(i,5)=0
78677  p(i,1)=2d0*paru(57)/k(i,3)
78678  v(i,1)=paru(2)/k(i,4)
78679  DO 520 ip=1,4
78680  p(i,ip+1)=fac*fm1fm(im,ib,ip)
78681  v(i,ip+1)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
78682  & p(i,ip+1)**2)))
78683  520 CONTINUE
78684  530 CONTINUE
78685  540 CONTINUE
78686  n=30
78687  DO 550 j=1,5
78688  k(n+1,j)=0
78689  p(n+1,j)=0d0
78690  v(n+1,j)=0d0
78691  550 CONTINUE
78692  k(n+1,1)=32
78693  k(n+1,2)=99
78694  k(n+1,5)=nevfm
78695  mstu(3)=1
78696 
78697 C...Reset statistics on Energy-Energy Correlation.
78698  ELSEIF(mtabu.EQ.40) THEN
78699  nevee=0
78700  DO 560 j=1,25
78701  fe1ec(j)=0d0
78702  fe2ec(j)=0d0
78703  fe1ec(51-j)=0d0
78704  fe2ec(51-j)=0d0
78705  fe1ea(j)=0d0
78706  fe2ea(j)=0d0
78707  560 CONTINUE
78708 
78709 C...Find particles to include, with proper assumed mass.
78710  ELSEIF(mtabu.EQ.41) THEN
78711  nevee=nevee+1
78712  nlow=n+mstu(3)
78713  nupp=nlow
78714  ecm=0d0
78715  DO 570 i=1,n
78716  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 570
78717  IF(mstu(41).GE.2) THEN
78718  kc=pycomp(k(i,2))
78719  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
78720  & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
78721  & k(i,2).EQ.ksusy1+39) goto 570
78722  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
78723  & pychge(k(i,2)).EQ.0) goto 570
78724  ENDIF
78725  pmr=0d0
78726  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
78727  IF(mstu(42).GE.2) pmr=p(i,5)
78728  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
78729  CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
78730  RETURN
78731  ENDIF
78732  nupp=nupp+1
78733  p(nupp,1)=p(i,1)
78734  p(nupp,2)=p(i,2)
78735  p(nupp,3)=p(i,3)
78736  p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
78737  p(nupp,5)=max(1d-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
78738  ecm=ecm+p(nupp,4)
78739  570 CONTINUE
78740  IF(nupp.EQ.nlow) RETURN
78741 
78742 C...Analyze Energy-Energy Correlation in event.
78743  fac=(2d0/ecm**2)*50d0/paru(1)
78744  DO 580 j=1,50
78745  fevee(j)=0d0
78746  580 CONTINUE
78747  DO 600 i1=nlow+2,nupp
78748  DO 590 i2=nlow+1,i1-1
78749  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
78750  & (p(i1,5)*p(i2,5))
78751  the=acos(max(-1d0,min(1d0,cthe)))
78752  ithe=max(1,min(50,1+int(50d0*the/paru(1))))
78753  fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
78754  590 CONTINUE
78755  600 CONTINUE
78756  DO 610 j=1,25
78757  fe1ec(j)=fe1ec(j)+fevee(j)
78758  fe2ec(j)=fe2ec(j)+fevee(j)**2
78759  fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
78760  fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
78761  fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
78762  fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
78763  610 CONTINUE
78764  mstu(62)=nupp-nlow
78765 
78766 C...Write statistics on Energy-Energy Correlation.
78767  ELSEIF(mtabu.EQ.42) THEN
78768  fac=1d0/max(1,nevee)
78769  WRITE(mstu(11),5700) nevee
78770  DO 620 j=1,25
78771  feec1=fac*fe1ec(j)
78772  fees1=sqrt(max(0d0,fac*(fac*fe2ec(j)-feec1**2)))
78773  feec2=fac*fe1ec(51-j)
78774  fees2=sqrt(max(0d0,fac*(fac*fe2ec(51-j)-feec2**2)))
78775  feeca=fac*fe1ea(j)
78776  feesa=sqrt(max(0d0,fac*(fac*fe2ea(j)-feeca**2)))
78777  WRITE(mstu(11),5800) 3.6d0*(j-1),3.6d0*j,feec1,fees1,
78778  & feec2,fees2,feeca,feesa
78779  620 CONTINUE
78780 
78781 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
78782  ELSEIF(mtabu.EQ.43) THEN
78783  fac=1d0/max(1,nevee)
78784  DO 630 i=1,25
78785  k(i,1)=32
78786  k(i,2)=99
78787  k(i,3)=0
78788  k(i,4)=0
78789  k(i,5)=0
78790  p(i,1)=fac*fe1ec(i)
78791  v(i,1)=sqrt(max(0d0,fac*(fac*fe2ec(i)-p(i,1)**2)))
78792  p(i,2)=fac*fe1ec(51-i)
78793  v(i,2)=sqrt(max(0d0,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
78794  p(i,3)=fac*fe1ea(i)
78795  v(i,3)=sqrt(max(0d0,fac*(fac*fe2ea(i)-p(i,3)**2)))
78796  p(i,4)=paru(1)*(i-1)/50d0
78797  p(i,5)=paru(1)*i/50d0
78798  v(i,4)=3.6d0*(i-1)
78799  v(i,5)=3.6d0*i
78800  630 CONTINUE
78801  n=25
78802  DO 640 j=1,5
78803  k(n+1,j)=0
78804  p(n+1,j)=0d0
78805  v(n+1,j)=0d0
78806  640 CONTINUE
78807  k(n+1,1)=32
78808  k(n+1,2)=99
78809  k(n+1,5)=nevee
78810  mstu(3)=1
78811 
78812 C...Reset statistics on decay channels.
78813  ELSEIF(mtabu.EQ.50) THEN
78814  nevdc=0
78815  nkfdc=0
78816  nredc=0
78817 
78818 C...Identify and order flavour content of final state.
78819  ELSEIF(mtabu.EQ.51) THEN
78820  nevdc=nevdc+1
78821  nds=0
78822  DO 670 i=1,n
78823  IF(k(i,1).LE.0.OR.k(i,1).GE.6) goto 670
78824  nds=nds+1
78825  IF(nds.GT.8) THEN
78826  nredc=nredc+1
78827  RETURN
78828  ENDIF
78829  kfm=2*iabs(k(i,2))
78830  IF(k(i,2).LT.0) kfm=kfm-1
78831  DO 650 ids=nds-1,1,-1
78832  iin=ids+1
78833  IF(kfm.LT.kfdm(ids)) goto 660
78834  kfdm(ids+1)=kfdm(ids)
78835  650 CONTINUE
78836  iin=1
78837  660 kfdm(iin)=kfm
78838  670 CONTINUE
78839 
78840 C...Find whether old or new final state.
78841  DO 690 idc=1,nkfdc
78842  IF(nds.LT.kfdc(idc,0)) THEN
78843  ikfdc=idc
78844  goto 700
78845  ELSEIF(nds.EQ.kfdc(idc,0)) THEN
78846  DO 680 i=1,nds
78847  IF(kfdm(i).LT.kfdc(idc,i)) THEN
78848  ikfdc=idc
78849  goto 700
78850  ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
78851  goto 690
78852  ENDIF
78853  680 CONTINUE
78854  ikfdc=-idc
78855  goto 700
78856  ENDIF
78857  690 CONTINUE
78858  ikfdc=nkfdc+1
78859  700 IF(ikfdc.LT.0) THEN
78860  ikfdc=-ikfdc
78861  ELSEIF(nkfdc.GE.200) THEN
78862  nredc=nredc+1
78863  RETURN
78864  ELSE
78865  DO 720 idc=nkfdc,ikfdc,-1
78866  npdc(idc+1)=npdc(idc)
78867  DO 710 i=0,8
78868  kfdc(idc+1,i)=kfdc(idc,i)
78869  710 CONTINUE
78870  720 CONTINUE
78871  nkfdc=nkfdc+1
78872  kfdc(ikfdc,0)=nds
78873  DO 730 i=1,nds
78874  kfdc(ikfdc,i)=kfdm(i)
78875  730 CONTINUE
78876  npdc(ikfdc)=0
78877  ENDIF
78878  npdc(ikfdc)=npdc(ikfdc)+1
78879 
78880 C...Write statistics on decay channels.
78881  ELSEIF(mtabu.EQ.52) THEN
78882  fac=1d0/max(1,nevdc)
78883  WRITE(mstu(11),5900) nevdc
78884  DO 750 idc=1,nkfdc
78885  DO 740 i=1,kfdc(idc,0)
78886  kfm=kfdc(idc,i)
78887  kf=(kfm+1)/2
78888  IF(2*kf.NE.kfm) kf=-kf
78889  CALL pyname(kf,chau)
78890  chdc(i)=chau(1:12)
78891  IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
78892  740 CONTINUE
78893  WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
78894  750 CONTINUE
78895  IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
78896 
78897 C...Copy statistics on decay channels into /PYJETS/.
78898  ELSEIF(mtabu.EQ.53) THEN
78899  fac=1d0/max(1,nevdc)
78900  DO 780 idc=1,nkfdc
78901  k(idc,1)=32
78902  k(idc,2)=99
78903  k(idc,3)=0
78904  k(idc,4)=0
78905  k(idc,5)=kfdc(idc,0)
78906  DO 760 j=1,5
78907  p(idc,j)=0d0
78908  v(idc,j)=0d0
78909  760 CONTINUE
78910  DO 770 i=1,kfdc(idc,0)
78911  kfm=kfdc(idc,i)
78912  kf=(kfm+1)/2
78913  IF(2*kf.NE.kfm) kf=-kf
78914  IF(i.LE.5) p(idc,i)=kf
78915  IF(i.GE.6) v(idc,i-5)=kf
78916  770 CONTINUE
78917  v(idc,5)=fac*npdc(idc)
78918  780 CONTINUE
78919  n=nkfdc
78920  DO 790 j=1,5
78921  k(n+1,j)=0
78922  p(n+1,j)=0d0
78923  v(n+1,j)=0d0
78924  790 CONTINUE
78925  k(n+1,1)=32
78926  k(n+1,2)=99
78927  k(n+1,5)=nevdc
78928  v(n+1,5)=fac*nredc
78929  mstu(3)=1
78930  ENDIF
78931 
78932 C...Format statements for output on unit MSTU(11) (default 6).
78933  5000 FORMAT(///20x,'Event statistics - initial state'/
78934  &20x,'based on an analysis of ',i6,' events'//
78935  &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
78936  &'according to fragmenting system multiplicity'/
78937  &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
78938  &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
78939  5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
78940  5200 FORMAT(///20x,'Event statistics - final state'/
78941  &20x,'based on an analysis of ',i7,' events'//
78942  &5x,'Mean primary multiplicity =',f10.4/
78943  &5x,'Mean final multiplicity =',f10.4/
78944  &5x,'Mean charged multiplicity =',f10.4//
78945  &5x,'Number of particles produced per event (directly and via ',
78946  &'decays/branchings)'/
78947  &8x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
78948  &8x,'Total'/35x,'prim seco prim seco'/)
78949  5300 FORMAT(1x,i9,4x,a16,i2,5(1x,f11.6))
78950  5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
78951  &20x,'based on an analysis of ',i6,' events'//
78952  &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
78953  &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
78954  5500 FORMAT(10x)
78955  5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
78956  5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
78957  &20x,'based on an analysis of ',i6,' events'//
78958  &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
78959  &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
78960  5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
78961  5900 FORMAT(///20x,'Decay channel analysis - final state'/
78962  &20x,'based on an analysis of ',i6,' events'//
78963  &2x,'Probability',10x,'Complete final state'/)
78964  6000 FORMAT(2x,f9.5,5x,8(a12,1x))
78965  6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
78966  &'or table overflow)')
78967 
78968  RETURN
78969  END
78970 
78971 C*********************************************************************
78972 
78973 C...PYEEVT
78974 C...Handles the generation of an e+e- annihilation jet event.
78975 
78976  SUBROUTINE pyeevt(KFL,ECM)
78977 
78978 C...Double precision and integer declarations.
78979  IMPLICIT DOUBLE PRECISION(a-h, o-z)
78980  IMPLICIT INTEGER(i-n)
78981  INTEGER pyk,pychge,pycomp
78982 C...Commonblocks.
78983  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
78984  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78985  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
78986  SAVE /pyjets/,/pydat1/,/pydat2/
78987 
78988 C...Check input parameters.
78989  IF(mstu(12).NE.12345) CALL pylist(0)
78990  IF(kfl.LT.0.OR.kfl.GT.8) THEN
78991  CALL pyerrm(16,'(PYEEVT:) called with unknown flavour code')
78992  IF(mstu(21).GE.1) RETURN
78993  ENDIF
78994  IF(kfl.LE.5) ecmmin=parj(127)+2.02d0*parf(100+max(1,kfl))
78995  IF(kfl.GE.6) ecmmin=parj(127)+2.02d0*pmas(kfl,1)
78996  IF(ecm.LT.ecmmin) THEN
78997  CALL pyerrm(16,'(PYEEVT:) called with too small CM energy')
78998  IF(mstu(21).GE.1) RETURN
78999  ENDIF
79000 
79001 C...Check consistency of MSTJ options set.
79002  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
79003  CALL pyerrm(6,
79004  & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
79005  mstj(110)=1
79006  ENDIF
79007  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
79008  CALL pyerrm(6,
79009  & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
79010  mstj(111)=0
79011  ENDIF
79012 
79013 C...Initialize alpha_strong and total cross-section.
79014  mstu(111)=mstj(108)
79015  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
79016  &mstu(111)=1
79017  paru(112)=parj(121)
79018  IF(mstu(111).EQ.2) paru(112)=parj(122)
79019  IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
79020  &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL pyxtee(kfl,ecm,
79021  &xtot)
79022  IF(mstj(116).GE.3) mstj(116)=1
79023  parj(171)=0d0
79024 
79025 C...Add initial e+e- to event record (documentation only).
79026  ntry=0
79027  100 ntry=ntry+1
79028  IF(ntry.GT.100) THEN
79029  CALL pyerrm(14,'(PYEEVT:) caught in an infinite loop')
79030  RETURN
79031  ENDIF
79032  mstu(24)=0
79033  nc=0
79034  IF(mstj(115).GE.2) THEN
79035  nc=nc+2
79036  CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
79037  k(nc-1,1)=21
79038  CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
79039  k(nc,1)=21
79040  ENDIF
79041 
79042 C...Radiative photon (in initial state).
79043  mk=0
79044  ecmc=ecm
79045  IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL pyradk(ecm,mk,pak,
79046  &thek,phik,alpk)
79047  IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2d0*pak))
79048  IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
79049  nc=nc+1
79050  CALL py1ent(nc,22,pak,thek,phik)
79051  k(nc,3)=min(mstj(115)/2,1)
79052  ENDIF
79053 
79054 C...Virtual exchange boson (gamma or Z0).
79055  IF(mstj(115).GE.3) THEN
79056  nc=nc+1
79057  kf=22
79058  IF(mstj(102).EQ.2) kf=23
79059  mstu10=mstu(10)
79060  mstu(10)=1
79061  p(nc,5)=ecmc
79062  CALL py1ent(nc,kf,ecmc,0d0,0d0)
79063  k(nc,1)=21
79064  k(nc,3)=1
79065  mstu(10)=mstu10
79066  ENDIF
79067 
79068 C...Choice of flavour and jet configuration.
79069  CALL pyxkfl(kfl,ecm,ecmc,kflc)
79070  IF(kflc.EQ.0) goto 100
79071  CALL pyxjet(ecmc,njet,cut)
79072  kfln=21
79073  IF(njet.EQ.4) CALL pyx4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
79074  &x12,x14)
79075  IF(njet.EQ.3) CALL pyx3jt(njet,cut,kflc,ecmc,x1,x3)
79076  IF(njet.EQ.2) mstj(120)=1
79077 
79078 C...Fill jet configuration and origin.
79079  IF(njet.EQ.2.AND.mstj(101).NE.5) CALL py2ent(nc+1,kflc,-kflc,ecmc)
79080  IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL py2ent(-(nc+1),kflc,-kflc,
79081  &ecmc)
79082  IF(njet.EQ.3) CALL py3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
79083  IF(njet.EQ.4.AND.kfln.EQ.21) CALL py4ent(nc+1,kflc,kfln,kfln,
79084  &-kflc,ecmc,x1,x2,x4,x12,x14)
79085  IF(njet.EQ.4.AND.kfln.NE.21) CALL py4ent(nc+1,kflc,-kfln,kfln,
79086  &-kflc,ecmc,x1,x2,x4,x12,x14)
79087  IF(mstu(24).NE.0) goto 100
79088  DO 110 ip=nc+1,n
79089  k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
79090  110 CONTINUE
79091 
79092 C...Angular orientation according to matrix element.
79093  IF(mstj(106).EQ.1) THEN
79094  CALL pyxdif(nc,njet,kflc,ecmc,chi,the,phi)
79095  CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
79096  CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
79097  ENDIF
79098 
79099 C...Rotation and boost from radiative photon.
79100  IF(mk.EQ.1) THEN
79101  dbek=-pak/(ecm-pak)
79102  nmin=nc+1-mstj(115)/3
79103  CALL pyrobo(nmin,n,0d0,-phik,0d0,0d0,0d0)
79104  CALL pyrobo(nmin,n,alpk,0d0,dbek*sin(thek),0d0,dbek*cos(thek))
79105  CALL pyrobo(nmin,n,0d0,phik,0d0,0d0,0d0)
79106  ENDIF
79107 
79108 C...Generate parton shower. Rearrange along strings and check.
79109  IF(mstj(101).EQ.5) THEN
79110  CALL pyshow(n-1,n,ecmc)
79111  mstj14=mstj(14)
79112  IF(mstj(105).EQ.-1) mstj(14)=-1
79113  IF(mstj(105).GE.0) mstu(28)=0
79114  CALL pyprep(0)
79115  mstj(14)=mstj14
79116  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
79117  ENDIF
79118 
79119 C...Fragmentation/decay generation. Information for PYTABU.
79120  IF(mstj(105).EQ.1) CALL pyexec
79121  mstu(161)=kflc
79122  mstu(162)=-kflc
79123 
79124  RETURN
79125  END
79126 
79127 C*********************************************************************
79128 
79129 C...PYXTEE
79130 C...Calculates total cross-section, including initial state
79131 C...radiation effects.
79132 
79133  SUBROUTINE pyxtee(KFL,ECM,XTOT)
79134 
79135 C...Double precision and integer declarations.
79136  IMPLICIT DOUBLE PRECISION(a-h, o-z)
79137  IMPLICIT INTEGER(i-n)
79138  INTEGER pyk,pychge,pycomp
79139 C...Commonblocks.
79140  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
79141  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
79142  SAVE /pydat1/,/pydat2/
79143 
79144 C...Status, (optimized) Q^2 scale, alpha_strong.
79145  parj(151)=ecm
79146  mstj(119)=10*mstj(102)+kfl
79147  IF(mstj(111).EQ.0) THEN
79148  q2r=ecm**2
79149  ELSEIF(mstu(111).EQ.0) THEN
79150  parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
79151  & ((33d0-2d0*mstu(112))*paru(111)))))
79152  q2r=parj(168)*ecm**2
79153  ELSE
79154  parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
79155  & (2d0*paru(112)/ecm)**2))
79156  q2r=parj(168)*ecm**2
79157  ENDIF
79158  alspi=pyalps(q2r)/paru(1)
79159 
79160 C...QCD corrections factor in R.
79161  IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
79162  rqcd=1d0
79163  ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
79164  rqcd=1d0+alspi
79165  ELSEIF(mstj(109).EQ.0) THEN
79166  rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
79167  IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+(33d0-2d0*mstu(112))/12d0*
79168  & log(parj(168))*alspi**2)
79169  ELSEIF(iabs(mstj(101)).EQ.1) THEN
79170  rqcd=1d0+(3d0/4d0)*alspi
79171  ELSE
79172  rqcd=1d0+(3d0/4d0)*alspi-(3d0/32d0+0.519d0*mstu(118))*alspi**2
79173  ENDIF
79174 
79175 C...Calculate Z0 width if default value not acceptable.
79176  IF(mstj(102).GE.3) THEN
79177  rva=3d0*(3d0+(4d0*paru(102)-1d0)**2)+6d0*rqcd*(2d0+
79178  & (1d0-8d0*paru(102)/3d0)**2+(4d0*paru(102)/3d0-1d0)**2)
79179  DO 100 kflc=5,6
79180  vq=1d0
79181  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-
79182  & (2d0*pymass(kflc)/ ecm)**2))
79183  IF(kflc.EQ.5) vf=4d0*paru(102)/3d0-1d0
79184  IF(kflc.EQ.6) vf=1d0-8d0*paru(102)/3d0
79185  rva=rva+3d0*rqcd*(0.5d0*vq*(3d0-vq**2)*vf**2+vq**3)
79186  100 CONTINUE
79187  parj(124)=paru(101)*parj(123)*rva/(48d0*paru(102)*
79188  & (1d0-paru(102)))
79189  ENDIF
79190 
79191 C...Calculate propagator and related constants for QFD case.
79192  poll=1d0-parj(131)*parj(132)
79193  IF(mstj(102).GE.2) THEN
79194  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
79195  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
79196  sfi=sfw*(1d0-(parj(123)/ecm)**2)
79197  ve=4d0*paru(102)-1d0
79198  sf1i=sff*(ve*poll+parj(132)-parj(131))
79199  sf1w=sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
79200  hf1i=sfi*sf1i
79201  hf1w=sfw*sf1w
79202  ENDIF
79203 
79204 C...Loop over different flavours: charge, velocity.
79205  rtot=0d0
79206  rqq=0d0
79207  rqv=0d0
79208  rva=0d0
79209  DO 110 kflc=1,max(mstj(104),kfl)
79210  IF(kfl.GT.0.AND.kflc.NE.kfl) goto 110
79211  mstj(93)=1
79212  pmq=pymass(kflc)
79213  IF(ecm.LT.2d0*pmq+parj(127)) goto 110
79214  qf=kchg(kflc,1)/3d0
79215  vq=1d0
79216  IF(mod(mstj(103),2).EQ.1) vq=sqrt(1d0-(2d0*pmq/ecm)**2)
79217 
79218 C...Calculate R and sum of charges for QED or QFD case.
79219  rqq=rqq+3d0*qf**2*poll
79220  IF(mstj(102).LE.1) THEN
79221  rtot=rtot+3d0*0.5d0*vq*(3d0-vq**2)*qf**2*poll
79222  ELSE
79223  vf=sign(1d0,qf)-4d0*qf*paru(102)
79224  rqv=rqv-6d0*qf*vf*sf1i
79225  rva=rva+3d0*(vf**2+1d0)*sf1w
79226  rtot=rtot+3d0*(0.5d0*vq*(3d0-vq**2)*(qf**2*poll-
79227  & 2d0*qf*vf*hf1i+vf**2*hf1w)+vq**3*hf1w)
79228  ENDIF
79229  110 CONTINUE
79230  rsum=rqq
79231  IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
79232 
79233 C...Calculate cross-section, including QCD corrections.
79234  parj(141)=rqq
79235  parj(142)=rtot
79236  parj(143)=rtot*rqcd
79237  parj(144)=parj(143)
79238  parj(145)=parj(141)*86.8d0/ecm**2
79239  parj(146)=parj(142)*86.8d0/ecm**2
79240  parj(147)=parj(143)*86.8d0/ecm**2
79241  parj(148)=parj(147)
79242  parj(157)=rsum*rqcd
79243  parj(158)=0d0
79244  parj(159)=0d0
79245  xtot=parj(147)
79246  IF(mstj(107).LE.0) RETURN
79247 
79248 C...Virtual cross-section.
79249  xkl=parj(135)
79250  xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
79251  ale=2d0*log(ecm/pymass(11))-1d0
79252  sigv=ale/3d0+2d0*log(ecm**2/(pymass(13)*pymass(15)))/3d0-4d0/3d0+
79253  &1.526d0*log(ecm**2/0.932d0)
79254 
79255 C...Soft and hard radiative cross-section in QED case.
79256  IF(mstj(102).LE.1) THEN
79257  sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+2d0*sigv
79258  sigs=ale*(2d0*log(xkl)-log(1d0-xkl)-xkl)
79259  sigh=ale*(2d0*log(xku/xkl)-log((1d0-xku)/(1d0-xkl))-(xku-xkl))
79260 
79261 C...Soft and hard radiative cross-section in QFD case.
79262  ELSE
79263  szm=1d0-(parj(123)/ecm)**2
79264  szw=parj(123)*parj(124)/ecm**2
79265  parj(161)=-rqq/rsum
79266  parj(162)=-(rqq+rqv+rva)/rsum
79267  parj(163)=(rqv*(1d0-0.5d0*szm-sfi)+rva*(1.5d0-szm-sfw))/rsum
79268  parj(164)=(rqv*szw**2*(1d0-2d0*sfw)+rva*(2d0*sfi+szw**2-
79269  & 4d0+3d0*szm-szm**2))/(szw*rsum)
79270  sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+((2d0*rqq+sfi*rqv)/
79271  & rsum)*sigv+(szw*sfw*rqv/rsum)*paru(1)*20d0/9d0
79272  sigs=ale*(2d0*log(xkl)+parj(161)*log(1d0-xkl)+parj(162)*xkl+
79273  & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
79274  & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
79275  sigh=ale*(2d0*log(xku/xkl)+parj(161)*log((1d0-xku)/
79276  & (1d0-xkl))+parj(162)*(xku-xkl)+parj(163)*
79277  & log(((xku-szm)**2+szw**2)/((xkl-szm)**2+szw**2))+
79278  & parj(164)*(atan((xku-szm)/szw)-atan((xkl-szm)/szw)))
79279  ENDIF
79280 
79281 C...Total cross-section and fraction of hard photon events.
79282  parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
79283  parj(157)=rsum*(1d0+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
79284  parj(144)=parj(157)
79285  parj(148)=parj(144)*86.8d0/ecm**2
79286  xtot=parj(148)
79287 
79288  RETURN
79289  END
79290 
79291 C*********************************************************************
79292 
79293 C...PYRADK
79294 C...Generates initial state photon radiation.
79295 
79296  SUBROUTINE pyradk(ECM,MK,PAK,THEK,PHIK,ALPK)
79297 
79298 C...Double precision and integer declarations.
79299  IMPLICIT DOUBLE PRECISION(a-h, o-z)
79300  IMPLICIT INTEGER(i-n)
79301  INTEGER pyk,pychge,pycomp
79302 C...Commonblocks.
79303  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
79304  SAVE /pydat1/
79305 
79306 C...Function: cumulative hard photon spectrum in QFD case.
79307  fxk(xx)=2d0*log(xx)+parj(161)*log(1d0-xx)+parj(162)*xx+
79308  &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
79309 
79310 C...Determine whether radiative photon or not.
79311  mk=0
79312  pak=0d0
79313  IF(parj(160).LT.pyr(0)) RETURN
79314  mk=1
79315 
79316 C...Photon energy range. Find photon momentum in QED case.
79317  xkl=parj(135)
79318  xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
79319  IF(mstj(102).LE.1) THEN
79320  100 xk=1d0/(1d0+(1d0/xkl-1d0)*((1d0/xku-1d0)/(1d0/xkl-1d0))**pyr(0))
79321  IF(1d0+(1d0-xk)**2.LT.2d0*pyr(0)) goto 100
79322 
79323 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
79324  ELSE
79325  szm=1d0-(parj(123)/ecm)**2
79326  szw=parj(123)*parj(124)/ecm**2
79327  fxkl=fxk(xkl)
79328  fxku=fxk(xku)
79329  fxkd=1d-4*(fxku-fxkl)
79330  fxkr=fxkl+pyr(0)*(fxku-fxkl)
79331  nxk=0
79332  110 nxk=nxk+1
79333  xk=0.5d0*(xkl+xku)
79334  fxkv=fxk(xk)
79335  IF(fxkv.GT.fxkr) THEN
79336  xku=xk
79337  fxku=fxkv
79338  ELSE
79339  xkl=xk
79340  fxkl=fxkv
79341  ENDIF
79342  IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) goto 110
79343  xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
79344  ENDIF
79345  pak=0.5d0*ecm*xk
79346 
79347 C...Photon polar and azimuthal angle.
79348  pme=2d0*(pymass(11)/ecm)**2
79349  120 cthm=pme*(2d0/pme)**pyr(0)
79350  IF(1d0-(xk**2*cthm*(1d0-0.5d0*cthm)+2d0*(1d0-xk)*pme/max(pme,
79351  &cthm*(1d0-0.5d0*cthm)))/(1d0+(1d0-xk)**2).LT.pyr(0)) goto 120
79352  cthe=1d0-cthm
79353  IF(pyr(0).GT.0.5d0) cthe=-cthe
79354  sthe=sqrt(max(0d0,(cthm-pme)*(2d0-cthm)))
79355  thek=pyangl(cthe,sthe)
79356  phik=paru(2)*pyr(0)
79357 
79358 C...Rotation angle for hadronic system.
79359  sgn=1d0
79360  IF(0.5d0*(2d0-xk*(1d0-cthe))**2/((2d0-xk)**2+(xk*cthe)**2).GT.
79361  &pyr(0)) sgn=-1d0
79362  alpk=asin(sgn*sthe*(xk-sgn*(2d0*sqrt(1d0-xk)-2d0+xk)*cthe)/
79363  &(2d0-xk*(1d0-sgn*cthe)))
79364 
79365  RETURN
79366  END
79367 
79368 C*********************************************************************
79369 
79370 C...PYXKFL
79371 C...Selects flavour for produced qqbar pair.
79372 
79373  SUBROUTINE pyxkfl(KFL,ECM,ECMC,KFLC)
79374 
79375 C...Double precision and integer declarations.
79376  IMPLICIT DOUBLE PRECISION(a-h, o-z)
79377  IMPLICIT INTEGER(i-n)
79378  INTEGER pyk,pychge,pycomp
79379 C...Commonblocks.
79380  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
79381  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
79382  SAVE /pydat1/,/pydat2/
79383 
79384 C...Calculate maximum weight in QED or QFD case.
79385  IF(mstj(102).LE.1) THEN
79386  rfmax=4d0/9d0
79387  ELSE
79388  poll=1d0-parj(131)*parj(132)
79389  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
79390  sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
79391  sfi=sfw*(1d0-(parj(123)/ecmc)**2)
79392  ve=4d0*paru(102)-1d0
79393  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
79394  hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
79395  rfmax=max(4d0/9d0*poll-4d0/3d0*(1d0-8d0*paru(102)/3d0)*hf1i+
79396  & ((1d0-8d0*paru(102)/3d0)**2+1d0)*hf1w,1d0/9d0*poll+2d0/3d0*
79397  & (-1d0+4d0*paru(102)/3d0)*hf1i+((-1d0+4d0*paru(102)/3d0)**2+
79398  & 1d0)*hf1w)
79399  ENDIF
79400 
79401 C...Choose flavour. Gives charge and velocity.
79402  ntry=0
79403  100 ntry=ntry+1
79404  IF(ntry.GT.100) THEN
79405  CALL pyerrm(14,'(PYXKFL:) caught in an infinite loop')
79406  kflc=0
79407  RETURN
79408  ENDIF
79409  kflc=kfl
79410  IF(kfl.LE.0) kflc=1+int(mstj(104)*pyr(0))
79411  mstj(93)=1
79412  pmq=pymass(kflc)
79413  IF(ecm.LT.2d0*pmq+parj(127)) goto 100
79414  qf=kchg(kflc,1)/3d0
79415  vq=1d0
79416  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-(2d0*pmq/ecmc)**2))
79417 
79418 C...Calculate weight in QED or QFD case.
79419  IF(mstj(102).LE.1) THEN
79420  rf=qf**2
79421  rfv=0.5d0*vq*(3d0-vq**2)*qf**2
79422  ELSE
79423  vf=sign(1d0,qf)-4d0*qf*paru(102)
79424  rf=qf**2*poll-2d0*qf*vf*hf1i+(vf**2+1d0)*hf1w
79425  rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+vf**2*hf1w)+
79426  & vq**3*hf1w
79427  IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
79428  ENDIF
79429 
79430 C...Weighting or new event (radiative photon). Cross-section update.
79431  IF(kfl.LE.0.AND.rf.LT.pyr(0)*rfmax) goto 100
79432  parj(158)=parj(158)+1d0
79433  IF(ecmc.LT.2d0*pmq+parj(127).OR.rfv.LT.pyr(0)*rf) kflc=0
79434  IF(mstj(107).LE.0.AND.kflc.EQ.0) goto 100
79435  IF(kflc.NE.0) parj(159)=parj(159)+1d0
79436  parj(144)=parj(157)*parj(159)/parj(158)
79437  parj(148)=parj(144)*86.8d0/ecm**2
79438 
79439  RETURN
79440  END
79441 
79442 C*********************************************************************
79443 
79444 C...PYXJET
79445 C...Selects number of jets in matrix element approach.
79446 
79447  SUBROUTINE pyxjet(ECM,NJET,CUT)
79448 
79449 C...Double precision and integer declarations.
79450  IMPLICIT DOUBLE PRECISION(a-h, o-z)
79451  IMPLICIT INTEGER(i-n)
79452  INTEGER pyk,pychge,pycomp
79453 C...Commonblocks.
79454  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
79455  SAVE /pydat1/
79456 C...Local array and data.
79457  dimension zhut(5)
79458  DATA zhut/3.0922d0, 6.2291d0, 7.4782d0, 7.8440d0, 8.2560d0/
79459 
79460 C...Trivial result for two-jets only, including parton shower.
79461  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
79462  cut=0d0
79463 
79464 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
79465  ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
79466  cf=4d0/3d0
79467  IF(mstj(109).EQ.2) cf=1d0
79468  IF(mstj(111).EQ.0) THEN
79469  q2=ecm**2
79470  q2r=ecm**2
79471  ELSEIF(mstu(111).EQ.0) THEN
79472  parj(169)=min(1d0,parj(129))
79473  q2=parj(169)*ecm**2
79474  parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
79475  & ((33d0-2d0*mstu(112))*paru(111)))))
79476  q2r=parj(168)*ecm**2
79477  ELSE
79478  parj(169)=min(1d0,max(parj(129),(2d0*paru(112)/ecm)**2))
79479  q2=parj(169)*ecm**2
79480  parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
79481  & (2d0*paru(112)/ecm)**2))
79482  q2r=parj(168)*ecm**2
79483  ENDIF
79484 
79485 C...alpha_strong for R and R itself.
79486  alspi=(3d0/4d0)*cf*pyalps(q2r)/paru(1)
79487  IF(iabs(mstj(101)).EQ.1) THEN
79488  rqcd=1d0+alspi
79489  ELSEIF(mstj(109).EQ.0) THEN
79490  rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
79491  IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+
79492  & (33d0-2d0*mstu(112))/12d0*log(parj(168))*alspi**2)
79493  ELSE
79494  rqcd=1d0+alspi-(3d0/32d0+0.519d0*mstu(118))*(4d0*alspi/3d0)**2
79495  ENDIF
79496 
79497 C...alpha_strong for jet rate. Initial value for y cut.
79498  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
79499  cut=max(0.001d0,parj(125),(parj(126)/ecm)**2)
79500  IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
79501  & cut=max(cut,exp(-sqrt(0.75d0/alspi))/2d0)
79502  IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
79503 
79504 C...Parametrization of first order three-jet cross-section.
79505  100 IF(mstj(101).EQ.0.OR.cut.GE.0.25d0) THEN
79506  parj(152)=0d0
79507  ELSE
79508  parj(152)=(2d0*alspi/3d0)*((3d0-6d0*cut+2d0*log(cut))*
79509  & log(cut/(1d0-2d0*cut))+(2.5d0+1.5d0*cut-6.571d0)*
79510  & (1d0-3d0*cut)+5.833d0*(1d0-3d0*cut)**2-3.894d0*
79511  & (1d0-3d0*cut)**3+1.342d0*(1d0-3d0*cut)**4)/rqcd
79512  IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
79513  & parj(152)=0d0
79514  ENDIF
79515 
79516 C...Parametrization of second order three-jet cross-section.
79517  IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
79518  & cut.GE.0.25d0) THEN
79519  parj(153)=0d0
79520  ELSEIF(mstj(110).LE.1) THEN
79521  ct=log(1d0/cut-2d0)
79522  parj(153)=alspi**2*ct**2*(2.419d0+0.5989d0*ct+0.6782d0*ct**2-
79523  & 0.2661d0*ct**3+0.01159d0*ct**4)/rqcd
79524 
79525 C...Interpolation in second/first order ratio for Zhu parametrization.
79526  ELSEIF(mstj(110).EQ.2) THEN
79527  iza=0
79528  DO 110 iy=1,5
79529  IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
79530  110 CONTINUE
79531  IF(iza.NE.0) THEN
79532  zhurat=zhut(iza)
79533  ELSE
79534  iz=100d0*cut
79535  zhurat=zhut(iz)+(100d0*cut-iz)*(zhut(iz+1)-zhut(iz))
79536  ENDIF
79537  parj(153)=alspi*parj(152)*zhurat
79538  ENDIF
79539 
79540 C...Shift in second order three-jet cross-section with optimized Q^2.
79541  IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3
79542  & .AND.cut.LT.0.25d0) parj(153)=parj(153)+
79543  & (33d0-2d0*mstu(112))/12d0*log(parj(169))*alspi*parj(152)
79544 
79545 C...Parametrization of second order four-jet cross-section.
79546  IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125d0) THEN
79547  parj(154)=0d0
79548  ELSE
79549  ct=log(1d0/cut-5d0)
79550  IF(cut.LE.0.018d0) THEN
79551  xqqgg=6.349d0-4.330d0*ct+0.8304d0*ct**2
79552  IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(3.035d0-2.091d0*ct+
79553  & 0.4059d0*ct**2)
79554  xqqqq=1.25d0*(-0.1080d0+0.01486d0*ct+0.009364d0*ct**2)
79555  IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
79556  ELSE
79557  xqqgg=-0.09773d0+0.2959d0*ct-0.2764d0*ct**2+0.08832d0*ct**3
79558  IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(-0.04079d0+
79559  & 0.1340d0*ct-0.1326d0*ct**2+0.04365d0*ct**3)
79560  xqqqq=1.25d0*(0.003661d0-0.004888d0*ct-0.001081d0*ct**2+
79561  & 0.002093d0*ct**3)
79562  IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
79563  ENDIF
79564  parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
79565  parj(155)=xqqqq/(xqqgg+xqqqq)
79566  ENDIF
79567 
79568 C...If negative three-jet rate, change y' optimization parameter.
79569  IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0d0.AND.
79570  & parj(169).LT.0.99d0) THEN
79571  parj(169)=min(1d0,1.2d0*parj(169))
79572  q2=parj(169)*ecm**2
79573  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
79574  goto 100
79575  ENDIF
79576 
79577 C...If too high cross-section, use harder cuts, or fail.
79578  IF(parj(152)+parj(153)+parj(154).GE.1) THEN
79579  IF(mstj(110).EQ.2.AND.cut.GT.0.0499d0.AND.mstj(111).EQ.1.AND.
79580  & parj(169).LT.0.99d0) THEN
79581  parj(169)=min(1d0,1.2d0*parj(169))
79582  q2=parj(169)*ecm**2
79583  alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
79584  goto 100
79585  ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499d0) THEN
79586  CALL pyerrm(26,
79587  & '(PYXJET:) no allowed y cut value for Zhu parametrization')
79588  ENDIF
79589  cut=0.26d0*(4d0*cut)**(parj(152)+parj(153)+
79590  & parj(154))**(-1d0/3d0)
79591  IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
79592  goto 100
79593  ENDIF
79594 
79595 C...Scalar gluon (first order only).
79596  ELSE
79597  alspi=pyalps(ecm**2)/paru(1)
79598  cut=max(0.001d0,parj(125),(parj(126)/ecm)**2,exp(-3d0/alspi))
79599  parj(152)=0d0
79600  IF(cut.LT.0.25d0) parj(152)=(alspi/3d0)*((1d0-2d0*cut)*
79601  & log((1d0-2d0*cut)/cut)+0.5d0*(9d0*cut**2-1d0))
79602  parj(153)=0d0
79603  parj(154)=0d0
79604  ENDIF
79605 
79606 C...Select number of jets.
79607  parj(150)=cut
79608  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
79609  njet=2
79610  ELSEIF(mstj(101).LE.0) THEN
79611  njet=min(4,2-mstj(101))
79612  ELSE
79613  rnj=pyr(0)
79614  njet=2
79615  IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
79616  IF(parj(154).GT.rnj) njet=4
79617  ENDIF
79618 
79619  RETURN
79620  END
79621 
79622 C*********************************************************************
79623 
79624 C...PYX3JT
79625 C...Selects the kinematical variables of three-jet events.
79626 
79627  SUBROUTINE pyx3jt(NJET,CUT,KFL,ECM,X1,X2)
79628 
79629 C...Double precision and integer declarations.
79630  IMPLICIT DOUBLE PRECISION(a-h, o-z)
79631  IMPLICIT INTEGER(i-n)
79632  INTEGER pyk,pychge,pycomp
79633 C...Commonblocks.
79634  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
79635  SAVE /pydat1/
79636 C...Local array.
79637  dimension zhup(5,12)
79638 
79639 C...Coefficients of Zhu second order parametrization.
79640  DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
79641  &18.29d0, 89.56d0, 4.541d0, -52.09d0, -109.8d0, 24.90d0,
79642  &11.63d0, 3.683d0, 17.50d0,0.002440d0, -1.362d0,-0.3537d0,
79643  &11.42d0, 6.299d0, -22.55d0, -8.915d0, 59.25d0, -5.855d0,
79644  &-32.85d0, -1.054d0, -16.90d0,0.006489d0,-0.8156d0,0.01095d0,
79645  &7.847d0, -3.964d0, -35.83d0, 1.178d0, 29.39d0, 0.2806d0,
79646  &47.82d0, -12.36d0, -56.72d0, 0.04054d0,-0.4365d0, 0.6062d0,
79647  &5.441d0, -56.89d0, -50.27d0, 15.13d0, 114.3d0, -18.19d0,
79648  &97.05d0, -1.890d0, -139.9d0, 0.08153d0,-0.4984d0, 0.9439d0,
79649  &-17.65d0, 51.44d0, -58.32d0, 70.95d0, -255.7d0, -78.99d0,
79650  &476.9d0, 29.65d0, -239.3d0, 0.4745d0, -1.174d0, 6.081d0/
79651 
79652 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
79653  dilog(x)=x+x**2/4d0+x**3/9d0+x**4/16d0+x**5/25d0+x**6/36d0+
79654  &x**7/49d0
79655 
79656 C...Event type. Mass effect factors and other common constants.
79657  mstj(120)=2
79658  mstj(121)=0
79659  pmq=pymass(kfl)
79660  qme=(2d0*pmq/ecm)**2
79661  IF(mstj(109).NE.1) THEN
79662  cutl=log(cut)
79663  cutd=log(1d0/cut-2d0)
79664  IF(mstj(109).EQ.0) THEN
79665  cf=4d0/3d0
79666  cn=3d0
79667  tr=2d0
79668  wtmx=min(20d0,37d0-6d0*cutd)
79669  IF(mstj(110).EQ.2) wtmx=2d0*(7.5d0+80d0*cut)
79670  ELSE
79671  cf=1d0
79672  cn=0d0
79673  tr=12d0
79674  wtmx=0d0
79675  ENDIF
79676 
79677 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
79678  als2pi=paru(118)/paru(2)
79679  wtopt=0d0
79680  IF(mstj(111).EQ.1) wtopt=(33d0-2d0*mstu(112))/6d0*
79681  & log(parj(169))*als2pi
79682  wtmax=max(0d0,1d0+wtopt+als2pi*wtmx)
79683 
79684 C...Choose three-jet events in allowed region.
79685  100 njet=3
79686  110 y13l=cutl+cutd*pyr(0)
79687  y23l=cutl+cutd*pyr(0)
79688  y13=exp(y13l)
79689  y23=exp(y23l)
79690  y12=1d0-y13-y23
79691  IF(y12.LE.cut) goto 110
79692  IF(y13**2+y23**2+2d0*y12.LE.2d0*pyr(0)) goto 110
79693 
79694 C...Second order corrections.
79695  IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
79696  y12l=log(y12)
79697  y13m=log(1d0-y13)
79698  y23m=log(1d0-y23)
79699  y12m=log(1d0-y12)
79700  IF(y13.LE.0.5d0) y13i=dilog(y13)
79701  IF(y13.GE.0.5d0) y13i=1.644934d0-y13l*y13m-dilog(1d0-y13)
79702  IF(y23.LE.0.5d0) y23i=dilog(y23)
79703  IF(y23.GE.0.5d0) y23i=1.644934d0-y23l*y23m-dilog(1d0-y23)
79704  IF(y12.LE.0.5d0) y12i=dilog(y12)
79705  IF(y12.GE.0.5d0) y12i=1.644934d0-y12l*y12m-dilog(1d0-y12)
79706  wt1=(y13**2+y23**2+2d0*y12)/(y13*y23)
79707  wt2=cf*(-2d0*(cutl-y12l)**2-3d0*cutl-1d0+3.289868d0+
79708  & 2d0*(2d0*cutl-y12l)*cut/y12)+
79709  & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-
79710  & 11d0*cutl/6d0+67d0/18d0+1.644934d0-(2d0*cutl-y12l)*cut/y12+
79711  & (2d0*cutl-y13l)*cut/y13+(2d0*cutl-y23l)*cut/y23)+
79712  & tr*(2d0*cutl/3d0-10d0/9d0)+
79713  & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
79714  & y13l*(4d0*y12**2+2d0*y12*y13+4d0*y12*y23+y13*y23)/
79715  & (y12+y23)**2+y23l*(4d0*y12**2+2d0*y12*y23+4d0*y12*y13+
79716  & y13*y23)/(y12+y13)**2)/wt1+
79717  & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+(cn-2d0*cf)*
79718  & ((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
79719  & y23m+1.644934d0-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
79720  & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934d0-y12i-y13i)/
79721  & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
79722  & 2d0*y12l*y12**2/(y13+y23)**2-4d0*y12l*y12/(y13+y23))/wt1-
79723  & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934d0-y13i-y23i)
79724  IF(1d0+wtopt+als2pi*wt2.LE.0d0) mstj(121)=1
79725  IF(1d0+wtopt+als2pi*wt2.LE.wtmax*pyr(0)) goto 110
79726  parj(156)=(wtopt+als2pi*wt2)/(1d0+wtopt+als2pi*wt2)
79727 
79728  ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
79729 C...Second order corrections; Zhu parametrization of ERT.
79730  zx=(y23-y13)**2
79731  zy=1d0-y12
79732  iza=0
79733  DO 120 iy=1,5
79734  IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
79735  120 CONTINUE
79736  IF(iza.NE.0) THEN
79737  iz=iza
79738  wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
79739  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
79740  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
79741  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
79742  ELSE
79743  iz=100d0*cut
79744  wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
79745  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
79746  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
79747  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
79748  iz=iz+1
79749  wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
79750  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
79751  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
79752  & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
79753  wt2=wtl+(wtu-wtl)*(100d0*cut+1d0-iz)
79754  ENDIF
79755  IF(1d0+wtopt+2d0*als2pi*wt2.LE.0d0) mstj(121)=1
79756  IF(1d0+wtopt+2d0*als2pi*wt2.LE.wtmax*pyr(0)) goto 110
79757  parj(156)=(wtopt+2d0*als2pi*wt2)/(1d0+wtopt+2d0*als2pi*wt2)
79758  ENDIF
79759 
79760 C...Impose mass cuts (gives two jets). For fixed jet number new try.
79761  x1=1d0-y23
79762  x2=1d0-y13
79763  x3=1d0-y12
79764  IF(4d0*y23*y13*y12/x3**2.LE.qme) njet=2
79765  IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
79766  & 0.5d0*qme**2+(0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/(1d0-x1)+
79767  & (1d0-x1)/(1d0-x2)).GT.(x1**2+x2**2)*pyr(0)) njet=2
79768  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 100
79769 
79770 C...Scalar gluon model (first order only, no mass effects).
79771  ELSE
79772  130 njet=3
79773  140 x3=sqrt(4d0*cut**2+pyr(0)*((1d0-cut)**2-4d0*cut**2))
79774  IF(log((x3-cut)/cut).LE.pyr(0)*log((1d0-2d0*cut)/cut)) goto 140
79775  yd=sign(2d0*cut*((x3-cut)/cut)**pyr(0)-x3,pyr(0)-0.5d0)
79776  x1=1d0-0.5d0*(x3+yd)
79777  x2=1d0-0.5d0*(x3-yd)
79778  IF(4d0*(1d0-x1)*(1d0-x2)*(1d0-x3)/x3**2.LE.qme) njet=2
79779  IF(mstj(102).GE.2) THEN
79780  IF(x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*parj(171).LT.
79781  & x3**2*pyr(0)) njet=2
79782  ENDIF
79783  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 130
79784  ENDIF
79785 
79786  RETURN
79787  END
79788 
79789 C*********************************************************************
79790 
79791 C...PYX4JT
79792 C...Selects the kinematical variables of four-jet events.
79793 
79794  SUBROUTINE pyx4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
79795 
79796 C...Double precision and integer declarations.
79797  IMPLICIT DOUBLE PRECISION(a-h, o-z)
79798  IMPLICIT INTEGER(i-n)
79799  INTEGER pyk,pychge,pycomp
79800 C...Commonblocks.
79801  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
79802  SAVE /pydat1/
79803 C...Local arrays.
79804  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
79805 
79806 C...Common constants. Colour factors for QCD and Abelian gluon theory.
79807  pmq=pymass(kfl)
79808  qme=(2d0*pmq/ecm)**2
79809  ct=log(1d0/cut-5d0)
79810  IF(mstj(109).EQ.0) THEN
79811  cf=4d0/3d0
79812  cn=3d0
79813  tr=2.5d0
79814  ELSE
79815  cf=1d0
79816  cn=0d0
79817  tr=15d0
79818  ENDIF
79819 
79820 C...Choice of process (qqbargg or qqbarqqbar).
79821  100 njet=4
79822  it=1
79823  IF(parj(155).GT.pyr(0)) it=2
79824  IF(mstj(101).LE.-3) it=-mstj(101)-2
79825  IF(it.EQ.1) wtmx=0.7d0/cut**2
79826  IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6d0/cut**2
79827  IF(it.EQ.2) wtmx=0.1125d0*cf*tr/cut**2
79828  id=1
79829 
79830 C...Sample the five kinematical variables (for qqgg preweighted in y34).
79831  110 y134=3d0*cut+(1d0-6d0*cut)*pyr(0)
79832  y234=3d0*cut+(1d0-6d0*cut)*pyr(0)
79833  IF(it.EQ.1) y34=(1d0-5d0*cut)*exp(-ct*pyr(0))
79834  IF(it.EQ.2) y34=cut+(1d0-6d0*cut)*pyr(0)
79835  IF(y34.LE.y134+y234-1d0.OR.y34.GE.y134*y234) goto 110
79836  vt=pyr(0)
79837  cp=cos(paru(1)*pyr(0))
79838  y14=(y134-y34)*vt
79839  y13=y134-y14-y34
79840  vb=y34*(1d0-y134-y234+y34)/((y134-y34)*(y234-y34))
79841  y24=0.5d0*(y234-y34)*(1d0-4d0*sqrt(max(0d0,vt*(1d0-vt)*
79842  &vb*(1d0-vb)))*cp-(1d0-2d0*vt)*(1d0-2d0*vb))
79843  y23=y234-y34-y24
79844  y12=1d0-y134-y23-y24
79845  IF(min(y12,y13,y14,y23,y24).LE.cut) goto 110
79846  y123=y12+y13+y23
79847  y124=y12+y14+y24
79848 
79849 C...Calculate matrix elements for qqgg or qqqq process.
79850  ic=0
79851  wttot=0d0
79852  120 ic=ic+1
79853  IF(it.EQ.1) THEN
79854  wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3d0*y12*y23*y34+
79855  & 3d0*y12*y14*y34+4d0*y12**2*y34-y13*y23*y24+2d0*y12*y23*y24-
79856  & y13*y14*y24-2d0*y12*y13*y24+2d0*y12**2*y24+y14*y23**2+2d0*y12*
79857  & y23**2+y14**2*y23+4d0*y12*y14*y23+4d0*y12**2*y23+2d0*y12*y14**2+
79858  & 2d0*y12*y13*y14+4d0*y12**2*y14+2d0*y12**2*y13+2d0*y12**3)/
79859  & (2d0*y13*y134*y234*y24)+(y24*y34+y12*y34+y13*y24-
79860  & y14*y23+y12*y13)/(y13*y134**2)+2d0*y23*(1d0-y13)/
79861  & (y13*y134*y24)+y34/(2d0*y13*y24)
79862  wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2d0*y12*
79863  & y14*y24)/(y13*y134*y23*y14)+y12*(1d0+y34)*y124/(y134*y234*y14*
79864  & y24)-(2d0*y13*y24+y14**2+y13*y23+2d0*y12*y13)/(y13*y134*y14)+
79865  & y12*y123*y124/(2d0*y13*y14*y23*y24)
79866  wtc(ic)=-(5d0*y12*y34**2+2d0*y12*y24*y34+2d0*y12*y23*y34+
79867  & 2d0*y12*y14*y34+2d0*y12*y13*y34+4d0*y12**2*y34-y13*y24**2+
79868  & y14*y23*y24+y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-
79869  & 3d0*y12*y13*y24-y14*y23**2-y14**2*y23+y13*y14*y23-
79870  & 3d0*y12*y14*y23-y12*y13*y23)/(4d0*y134*y234*y34**2)+
79871  & (3d0*y12*y34**2-3d0*y13*y24*y34+3d0*y12*y24*y34+
79872  & 3d0*y14*y23*y34-y13*y24**2-y12*y23*y34+6d0*y12*y14*y34+
79873  & 2d0*y12*y13*y34-2d0*y12**2*y34+y14*y23*y24-3d0*y13*y23*y24-
79874  & 2d0*y13*y14*y24+4d0*y12*y14*y24+2d0*y12*y13*y24+
79875  & 3d0*y14*y23**2+2d0*y14**2*y23+2d0*y14**2*y12+
79876  & 2d0*y12**2*y14+6d0*y12*y14*y23-2d0*y12*y13**2-
79877  & 2d0*y12**2*y13)/(4d0*y13*y134*y234*y34)
79878  wtc(ic)=wtc(ic)+(2d0*y12*y34**2-2d0*y13*y24*y34+y12*y24*y34+
79879  & 4d0*y13*y23*y34+4d0*y12*y14*y34+2d0*y12*y13*y34+2d0*y12**2*y34-
79880  & y13*y24**2+3d0*y14*y23*y24+4d0*y13*y23*y24-2d0*y13*y14*y24+
79881  & 4d0*y12*y14*y24+2d0*y12*y13*y24+2d0*y14*y23**2+4d0*y13*y23**2+
79882  & 2d0*y13*y14*y23+2d0*y12*y14*y23+4d0*y12*y13*y23+2d0*y12*y14**2+
79883  & 4d0*y12**2*y13+4d0*y12*y13*y14+2d0*y12**2*y14)/
79884  & (4d0*y13*y134*y24*y34)-(y12*y34**2-2d0*y14*y24*y34-
79885  & 2d0*y13*y24*y34-y14*y23*y34+y13*y23*y34+y12*y14*y34+
79886  & 2d0*y12*y13*y34-2d0*y14**2*y24-4d0*y13*y14*y24-
79887  & 4d0*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-
79888  & y12*y13**2)/(2d0*y13*y34*y134**2)+(y12*y34**2-
79889  & 4d0*y14*y24*y34-2d0*y13*y24*y34-2d0*y14*y23*y34-
79890  & 4d0*y13*y23*y34-4d0*y12*y14*y34-4d0*y12*y13*y34-
79891  & 2d0*y13*y14*y24+2d0*y13**2*y24+2d0*y14**2*y23-
79892  & 2d0*y13*y14*y23-y12*y14**2-6d0*y12*y13*y14-
79893  & y12*y13**2)/(4d0*y34**2*y134**2)
79894  wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5d0*cn)*wtb(ic)+
79895  & cn*wtc(ic))/8d0
79896  ELSE
79897  wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2d0*y12*
79898  & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
79899  & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
79900  & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
79901  & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
79902  & y13*y14*y24+2d0*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
79903  & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
79904  & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
79905  & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
79906  wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
79907  & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
79908  & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
79909  & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
79910  & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
79911  & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
79912  & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
79913  & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
79914  wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5d0*cn)*wte(ic))/16d0
79915  ENDIF
79916 
79917 C...Permutations of momenta in matrix element. Weighting.
79918  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
79919  ysav=y13
79920  y13=y14
79921  y14=ysav
79922  ysav=y23
79923  y23=y24
79924  y24=ysav
79925  ysav=y123
79926  y123=y124
79927  y124=ysav
79928  ENDIF
79929  IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
79930  ysav=y13
79931  y13=y23
79932  y23=ysav
79933  ysav=y14
79934  y14=y24
79935  y24=ysav
79936  ysav=y134
79937  y134=y234
79938  y234=ysav
79939  ENDIF
79940  IF(ic.LE.3) goto 120
79941  IF(id.EQ.1.AND.wttot.LT.pyr(0)*wtmx) goto 110
79942  ic=5
79943 
79944 C...qqgg events: string configuration and event type.
79945  IF(it.EQ.1) THEN
79946  IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
79947  parj(156)=y34*(2d0*(wta(1)+wta(2)+wta(3)+wta(4))+4d0*(wtc(1)+
79948  & wtc(2)+wtc(3)+wtc(4)))/(9d0*wttot)
79949  IF(wta(2)+wta(4)+2d0*(wtc(2)+wtc(4)).GT.pyr(0)*(wta(1)+wta(2)+
79950  & wta(3)+wta(4)+2d0*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
79951  IF(id.EQ.2) goto 130
79952  ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
79953  parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8d0*wttot)
79954  IF(wta(2)+wta(4).GT.pyr(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
79955  IF(id.EQ.2) goto 130
79956  ENDIF
79957  mstj(120)=3
79958  IF(mstj(109).EQ.0.AND.0.5d0*y34*(wtc(1)+wtc(2)+wtc(3)+
79959  & wtc(4)).GT.pyr(0)*wttot) mstj(120)=4
79960  kfln=21
79961 
79962 C...Mass cuts. Kinematical variables out.
79963  IF(y12.LE.cut+qme) njet=2
79964  IF(njet.EQ.2) goto 150
79965  q12=0.5d0*(1d0-sqrt(1d0-qme/y12))
79966  x1=1d0-(1d0-q12)*y234-q12*y134
79967  x4=1d0-(1d0-q12)*y134-q12*y234
79968  x2=1d0-y124
79969  x12=(1d0-q12)*y13+q12*y23
79970  x14=y12-0.5d0*qme
79971  IF(y134*y234/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
79972 
79973 C...qqbarqqbar events: string configuration, choose new flavour.
79974  ELSE
79975  IF(id.EQ.1) THEN
79976  wtr=pyr(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
79977  IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
79978  IF(wtr.LT.wtd(3)+wtd(4)) id=3
79979  IF(wtr.LT.wtd(4)) id=4
79980  IF(id.GE.2) goto 130
79981  ENDIF
79982  mstj(120)=5
79983  parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16d0*wttot)
79984  140 kfln=1+int(5d0*pyr(0))
79985  IF(kfln.NE.kfl.AND.0.2d0*parj(156).LE.pyr(0)) goto 140
79986  IF(kfln.EQ.kfl.AND.1d0-0.8d0*parj(156).LE.pyr(0)) goto 140
79987  IF(kfln.GT.mstj(104)) njet=2
79988  pmqn=pymass(kfln)
79989  qmen=(2d0*pmqn/ecm)**2
79990 
79991 C...Mass cuts. Kinematical variables out.
79992  IF(y24.LE.cut+qme.OR.y13.LE.1.1d0*qmen) njet=2
79993  IF(njet.EQ.2) goto 150
79994  q24=0.5d0*(1d0-sqrt(1d0-qme/y24))
79995  q13=0.5d0*(1d0-sqrt(1d0-qmen/y13))
79996  x1=1d0-(1d0-q24)*y123-q24*y134
79997  x4=1d0-(1d0-q24)*y134-q24*y123
79998  x2=1d0-(1d0-q13)*y234-q13*y124
79999  x12=(1d0-q24)*((1d0-q13)*y14+q13*y34)+q24*((1d0-q13)*y12+
80000  & q13*y23)
80001  x14=y24-0.5d0*qme
80002  x34=(1d0-q24)*((1d0-q13)*y23+q13*y12)+q24*((1d0-q13)*y34+
80003  & q13*y14)
80004  IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
80005  & (parj(127)+pmq+pmqn)**2) njet=2
80006  IF(y123*y134/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
80007  ENDIF
80008  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) goto 100
80009 
80010  RETURN
80011  END
80012 
80013 C*********************************************************************
80014 
80015 C...PYXDIF
80016 C...Gives the angular orientation of events.
80017 
80018  SUBROUTINE pyxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
80019 
80020 C...Double precision and integer declarations.
80021  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80022  IMPLICIT INTEGER(i-n)
80023  INTEGER pyk,pychge,pycomp
80024 C...Commonblocks.
80025  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
80026  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
80027  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
80028  SAVE /pyjets/,/pydat1/,/pydat2/
80029 
80030 C...Charge. Factors depending on polarization for QED case.
80031  qf=kchg(kfl,1)/3d0
80032  poll=1d0-parj(131)*parj(132)
80033  pold=parj(132)-parj(131)
80034  IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
80035  hf1=poll
80036  hf2=0d0
80037  hf3=parj(133)**2
80038  hf4=0d0
80039 
80040 C...Factors depending on flavour, energy and polarization for QFD case.
80041  ELSE
80042  sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
80043  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
80044  sfi=sfw*(1d0-(parj(123)/ecm)**2)
80045  ae=-1d0
80046  ve=4d0*paru(102)-1d0
80047  af=sign(1d0,qf)
80048  vf=af-4d0*qf*paru(102)
80049  hf1=qf**2*poll-2d0*qf*vf*sfi*sff*(ve*poll-ae*pold)+
80050  & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2d0*ve*ae*pold)
80051  hf2=-2d0*qf*af*sfi*sff*(ae*poll-ve*pold)+2d0*vf*af*sfw*sff**2*
80052  & (2d0*ve*ae*poll-(ve**2+ae**2)*pold)
80053  hf3=parj(133)**2*(qf**2-2d0*qf*vf*sfi*sff*ve+(vf**2+af**2)*
80054  & sfw*sff**2*(ve**2-ae**2))
80055  hf4=-parj(133)**2*2d0*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
80056  & sff*ae
80057  ENDIF
80058 
80059 C...Mass factor. Differential cross-sections for two-jet events.
80060  sq2=sqrt(2d0)
80061  qme=0d0
80062  IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
80063  &mstj(109).NE.1) qme=(2d0*pymass(kfl)/ecm)**2
80064  IF(njet.EQ.2) THEN
80065  sigu=4d0*sqrt(1d0-qme)
80066  sigl=2d0*qme*sqrt(1d0-qme)
80067  sigt=0d0
80068  sigi=0d0
80069  siga=0d0
80070  sigp=4d0
80071 
80072 C...Kinematical variables. Reduce four-jet event to three-jet one.
80073  ELSE
80074  IF(njet.EQ.3) THEN
80075  x1=2d0*p(nc+1,4)/ecm
80076  x2=2d0*p(nc+3,4)/ecm
80077  ELSE
80078  ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
80079  & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
80080  x1=2d0*p(nc+1,4)/ecmr
80081  x2=2d0*p(nc+4,4)/ecmr
80082  ENDIF
80083 
80084 C...Differential cross-sections for three-jet (or reduced four-jet).
80085  xq=(1d0-x1)/(1d0-x2)
80086  ct12=(x1*x2-2d0*x1-2d0*x2+2d0+qme)/sqrt((x1**2-qme)*(x2**2-qme))
80087  st12=sqrt(1d0-ct12**2)
80088  IF(mstj(109).NE.1) THEN
80089  sigu=2d0*x1**2+x2**2*(1d0+ct12**2)-qme*(3d0+ct12**2-x1-x2)-
80090  & qme*x1/xq+0.5d0*qme*((x2**2-qme)*st12**2-2d0*x2)*xq
80091  sigl=(x2*st12)**2-qme*(3d0-ct12**2-2.5d0*(x1+x2)+x1*x2+qme)+
80092  & 0.5d0*qme*(x1**2-x1-qme)/xq+0.5d0*qme*((x2**2-qme)*ct12**2-
80093  & x2)*xq
80094  sigt=0.5d0*(x2**2-qme-0.5d0*qme*(x2**2-qme)/xq)*st12**2
80095  sigi=((1d0-0.5d0*qme*xq)*(x2**2-qme)*st12*ct12+
80096  & qme*(1d0-x1-x2+0.5d0*x1*x2+0.5d0*qme)*st12/ct12)/sq2
80097  siga=x2**2*st12/sq2
80098  sigp=2d0*(x1**2-x2**2*ct12)
80099 
80100 C...Differential cross-sect for scalar gluons (no mass effects).
80101  ELSE
80102  x3=2d0-x1-x2
80103  xt=x2*st12
80104  ct13=sqrt(max(0d0,1d0-(xt/x3)**2))
80105  sigu=(1d0-parj(171))*(x3**2-0.5d0*xt**2)+
80106  & parj(171)*(x3**2-0.5d0*xt**2-4d0*(1d0-x1)*(1d0-x2)**2/x1)
80107  sigl=(1d0-parj(171))*0.5d0*xt**2+
80108  & parj(171)*0.5d0*(1d0-x1)**2*xt**2
80109  sigt=(1d0-parj(171))*0.25d0*xt**2+
80110  & parj(171)*0.25d0*xt**2*(1d0-2d0*x1)
80111  sigi=-(0.5d0/sq2)*((1d0-parj(171))*xt*x3*ct13+
80112  & parj(171)*xt*((1d0-2d0*x1)*x3*ct13-x1*(x1-x2)))
80113  siga=(0.25d0/sq2)*xt*(2d0*(1d0-x1)-x1*x3)
80114  sigp=x3**2-2d0*(1d0-x1)*(1d0-x2)/x1
80115  ENDIF
80116  ENDIF
80117 
80118 C...Upper bounds for differential cross-section.
80119  hf1a=abs(hf1)
80120  hf2a=abs(hf2)
80121  hf3a=abs(hf3)
80122  hf4a=abs(hf4)
80123  sigmax=(2d0*hf1a+hf3a+hf4a)*abs(sigu)+2d0*(hf1a+hf3a+hf4a)*
80124  &abs(sigl)+2d0*(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigt)+2d0*sq2*
80125  &(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigi)+4d0*sq2*hf2a*abs(siga)+
80126  &2d0*hf2a*abs(sigp)
80127 
80128 C...Generate angular orientation according to differential cross-sect.
80129  100 chi=paru(2)*pyr(0)
80130  cthe=2d0*pyr(0)-1d0
80131  phi=paru(2)*pyr(0)
80132  cchi=cos(chi)
80133  schi=sin(chi)
80134  c2chi=cos(2d0*chi)
80135  s2chi=sin(2d0*chi)
80136  the=acos(cthe)
80137  sthe=sin(the)
80138  c2phi=cos(2d0*(phi-parj(134)))
80139  s2phi=sin(2d0*(phi-parj(134)))
80140  sig=((1d0+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
80141  &2d0*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
80142  &2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*c2chi*c2phi-2d0*cthe*s2chi*
80143  &s2phi)*hf3-((1d0+cthe**2)*c2chi*s2phi+2d0*cthe*s2chi*c2phi)*hf4)*
80144  &sigt-2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*(cthe*cchi*c2phi-
80145  &schi*s2phi)*hf3+2d0*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
80146  &4d0*sq2*sthe*cchi*hf2*siga+2d0*cthe*hf2*sigp
80147  IF(sig.LT.sigmax*pyr(0)) goto 100
80148 
80149  RETURN
80150  END
80151 
80152 C*********************************************************************
80153 
80154 C...PYONIA
80155 C...Generates Upsilon and toponium decays into three gluons
80156 C...or two gluons and a photon.
80157 
80158  SUBROUTINE pyonia(KFL,ECM)
80159 
80160 C...Double precision and integer declarations.
80161  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80162  IMPLICIT INTEGER(i-n)
80163  INTEGER pyk,pychge,pycomp
80164 C...Commonblocks.
80165  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
80166  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
80167  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
80168  SAVE /pyjets/,/pydat1/,/pydat2/
80169 
80170 C...Printout. Check input parameters.
80171  IF(mstu(12).NE.12345) CALL pylist(0)
80172  IF(kfl.LT.0.OR.kfl.GT.8) THEN
80173  CALL pyerrm(16,'(PYONIA:) called with unknown flavour code')
80174  IF(mstu(21).GE.1) RETURN
80175  ENDIF
80176  IF(ecm.LT.parj(127)+2.02d0*parf(101)) THEN
80177  CALL pyerrm(16,'(PYONIA:) called with too small CM energy')
80178  IF(mstu(21).GE.1) RETURN
80179  ENDIF
80180 
80181 C...Initial e+e- and onium state (optional).
80182  nc=0
80183  IF(mstj(115).GE.2) THEN
80184  nc=nc+2
80185  CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
80186  k(nc-1,1)=21
80187  CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
80188  k(nc,1)=21
80189  ENDIF
80190  kflc=iabs(kfl)
80191  IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
80192  nc=nc+1
80193  kf=110*kflc+3
80194  mstu10=mstu(10)
80195  mstu(10)=1
80196  p(nc,5)=ecm
80197  CALL py1ent(nc,kf,ecm,0d0,0d0)
80198  k(nc,1)=21
80199  k(nc,3)=1
80200  mstu(10)=mstu10
80201  ENDIF
80202 
80203 C...Choose x1 and x2 according to matrix element.
80204  ntry=0
80205  100 x1=pyr(0)
80206  x2=pyr(0)
80207  x3=2d0-x1-x2
80208  IF(x3.GE.1d0.OR.((1d0-x1)/(x2*x3))**2+((1d0-x2)/(x1*x3))**2+
80209  &((1d0-x3)/(x1*x2))**2.LE.2d0*pyr(0)) goto 100
80210  ntry=ntry+1
80211  njet=3
80212  IF(mstj(101).LE.4) CALL py3ent(nc+1,21,21,21,ecm,x1,x3)
80213  IF(mstj(101).GE.5) CALL py3ent(-(nc+1),21,21,21,ecm,x1,x3)
80214 
80215 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
80216  mstu(111)=mstj(108)
80217  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
80218  &mstu(111)=1
80219  paru(112)=parj(121)
80220  IF(mstu(111).EQ.2) paru(112)=parj(122)
80221  qf=0d0
80222  IF(kflc.NE.0) qf=kchg(kflc,1)/3d0
80223  rgam=7.2d0*qf**2*paru(101)/pyalps(ecm**2)
80224  mk=0
80225  ecmc=ecm
80226  IF(pyr(0).GT.rgam/(1d0+rgam)) THEN
80227  IF(1d0-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
80228  & njet=2
80229  IF(njet.EQ.2.AND.mstj(101).LE.4) CALL py2ent(nc+1,21,21,ecm)
80230  IF(njet.EQ.2.AND.mstj(101).GE.5) CALL py2ent(-(nc+1),21,21,ecm)
80231  ELSE
80232  mk=1
80233  ecmc=sqrt(1d0-x1)*ecm
80234  IF(ecmc.LT.2d0*parj(127)) goto 100
80235  k(nc+1,1)=1
80236  k(nc+1,2)=22
80237  k(nc+1,4)=0
80238  k(nc+1,5)=0
80239  IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
80240  IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
80241  IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
80242  IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
80243  njet=2
80244  IF(ecmc.LT.4d0*parj(127)) THEN
80245  mstu10=mstu(10)
80246  mstu(10)=1
80247  p(nc+2,5)=ecmc
80248  CALL py1ent(nc+2,83,0.5d0*(x2+x3)*ecm,paru(1),0d0)
80249  mstu(10)=mstu10
80250  njet=0
80251  ENDIF
80252  ENDIF
80253  DO 110 ip=nc+1,n
80254  k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
80255  110 CONTINUE
80256 
80257 C...Differential cross-sections. Upper limit for cross-section.
80258  IF(mstj(106).EQ.1) THEN
80259  sq2=sqrt(2d0)
80260  hf1=1d0-parj(131)*parj(132)
80261  hf3=parj(133)**2
80262  ct13=(x1*x3-2d0*x1-2d0*x3+2d0)/(x1*x3)
80263  st13=sqrt(1d0-ct13**2)
80264  sigl=0.5d0*x3**2*((1d0-x2)**2+(1d0-x3)**2)*st13**2
80265  sigu=(x1*(1d0-x1))**2+(x2*(1d0-x2))**2+(x3*(1d0-x3))**2-sigl
80266  sigt=0.5d0*sigl
80267  sigi=(sigl*ct13/st13+0.5d0*x1*x3*(1d0-x2)**2*st13)/sq2
80268  sigmax=(2d0*hf1+hf3)*abs(sigu)+2d0*(hf1+hf3)*abs(sigl)+2d0*(hf1+
80269  & 2d0*hf3)*abs(sigt)+2d0*sq2*(hf1+2d0*hf3)*abs(sigi)
80270 
80271 C...Angular orientation of event.
80272  120 chi=paru(2)*pyr(0)
80273  cthe=2d0*pyr(0)-1d0
80274  phi=paru(2)*pyr(0)
80275  cchi=cos(chi)
80276  schi=sin(chi)
80277  c2chi=cos(2d0*chi)
80278  s2chi=sin(2d0*chi)
80279  the=acos(cthe)
80280  sthe=sin(the)
80281  c2phi=cos(2d0*(phi-parj(134)))
80282  s2phi=sin(2d0*(phi-parj(134)))
80283  sig=((1d0+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2d0*(sthe**2*hf1-
80284  & sthe**2*c2phi*hf3)*sigl+2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*
80285  & c2chi*c2phi-2d0*cthe*s2chi*s2phi)*hf3)*sigt-
80286  & 2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*
80287  & (cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
80288  IF(sig.LT.sigmax*pyr(0)) goto 120
80289  CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
80290  CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
80291  ENDIF
80292 
80293 C...Generate parton shower. Rearrange along strings and check.
80294  IF(mstj(101).GE.5.AND.njet.GE.2) THEN
80295  CALL pyshow(nc+mk+1,-njet,ecmc)
80296  mstj14=mstj(14)
80297  IF(mstj(105).EQ.-1) mstj(14)=-1
80298  IF(mstj(105).GE.0) mstu(28)=0
80299  CALL pyprep(0)
80300  mstj(14)=mstj14
80301  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
80302  ENDIF
80303 
80304 C...Generate fragmentation. Information for PYTABU:
80305  IF(mstj(105).EQ.1) CALL pyexec
80306  mstu(161)=110*kflc+3
80307  mstu(162)=0
80308 
80309  RETURN
80310  END
80311 
80312 C*********************************************************************
80313 
80314 C...PYBOOK
80315 C...Books a histogram.
80316 
80317  SUBROUTINE pybook(ID,TITLE,NX,XL,XU)
80318 
80319 C...Double precision declaration.
80320  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80321  IMPLICIT INTEGER(i-n)
80322 C...Commonblock.
80323  common/pybins/ihist(4),indx(1000),bin(20000)
80324  SAVE /pybins/
80325 C...Local character variables.
80326  CHARACTER title*(*), titfx*60
80327 
80328 C...Check that input is sensible. Find initial address in memory.
80329  IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
80330  &'(PYBOOK:) not allowed histogram number')
80331  IF(nx.LE.0.OR.nx.GT.100) CALL pyerrm(28,
80332  &'(PYBOOK:) not allowed number of bins')
80333  IF(xl.GE.xu) CALL pyerrm(28,
80334  &'(PYBOOK:) x limits in wrong order')
80335  indx(id)=ihist(4)
80336  ihist(4)=ihist(4)+28+nx
80337  IF(ihist(4).GT.ihist(2)) CALL pyerrm(28,
80338  &'(PYBOOK:) out of histogram space')
80339  is=indx(id)
80340 
80341 C...Store histogram size and reset contents.
80342  bin(is+1)=nx
80343  bin(is+2)=xl
80344  bin(is+3)=xu
80345  bin(is+4)=(xu-xl)/nx
80346  CALL pynull(id)
80347 
80348 C...Store title by conversion to integer to double precision.
80349  titfx=title//' '
80350  DO 100 it=1,20
80351  bin(is+8+nx+it)=256**2*ichar(titfx(3*it-2:3*it-2))+
80352  & 256*ichar(titfx(3*it-1:3*it-1))+ichar(titfx(3*it:3*it))
80353  100 CONTINUE
80354 
80355  RETURN
80356  END
80357 
80358 C*********************************************************************
80359 
80360 C...PYFILL
80361 C...Fills entry in histogram.
80362 
80363  SUBROUTINE pyfill(ID,X,W)
80364 
80365 C...Double precision declaration.
80366  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80367  IMPLICIT INTEGER(i-n)
80368 C...Commonblock.
80369  common/pybins/ihist(4),indx(1000),bin(20000)
80370  SAVE /pybins/
80371 
80372 C...Find initial address in memory. Increase number of entries.
80373  IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
80374  &'(PYFILL:) not allowed histogram number')
80375  is=indx(id)
80376  IF(is.EQ.0) CALL pyerrm(28,
80377  &'(PYFILL:) filling unbooked histogram')
80378  bin(is+5)=bin(is+5)+1d0
80379 
80380 C...Find bin in x, including under/overflow, and fill.
80381  IF(x.LT.bin(is+2)) THEN
80382  bin(is+6)=bin(is+6)+w
80383  ELSEIF(x.GE.bin(is+3)) THEN
80384  bin(is+8)=bin(is+8)+w
80385  ELSE
80386  bin(is+7)=bin(is+7)+w
80387  ix=(x-bin(is+2))/bin(is+4)
80388  ix=max(0,min(nint(bin(is+1))-1,ix))
80389  bin(is+9+ix)=bin(is+9+ix)+w
80390  ENDIF
80391 
80392  RETURN
80393  END
80394 
80395 C*********************************************************************
80396 
80397 C...PYFACT
80398 C...Multiplies histogram contents by factor.
80399 
80400  SUBROUTINE pyfact(ID,F)
80401 
80402 C...Double precision declaration.
80403  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80404  IMPLICIT INTEGER(i-n)
80405 C...Commonblock.
80406  common/pybins/ihist(4),indx(1000),bin(20000)
80407  SAVE /pybins/
80408 
80409 C...Find initial address in memory. Multiply all contents bins.
80410  IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
80411  &'(PYFACT:) not allowed histogram number')
80412  is=indx(id)
80413  IF(is.EQ.0) CALL pyerrm(28,
80414  &'(PYFACT:) scaling unbooked histogram')
80415  DO 100 ix=is+6,is+8+nint(bin(is+1))
80416  bin(ix)=f*bin(ix)
80417  100 CONTINUE
80418 
80419  RETURN
80420  END
80421 
80422 C*********************************************************************
80423 
80424 C...PYOPER
80425 C...Performs operations between histograms.
80426 
80427  SUBROUTINE pyoper(ID1,OPER,ID2,ID3,F1,F2)
80428 
80429 C...Double precision declaration.
80430  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80431  IMPLICIT INTEGER(i-n)
80432 C...Commonblock.
80433  common/pybins/ihist(4),indx(1000),bin(20000)
80434  SAVE /pybins/
80435 C...Character variable.
80436  CHARACTER oper*(*)
80437 
80438 C...Find initial addresses in memory, and histogram size.
80439  IF(id1.LE.0.OR.id1.GT.ihist(1)) CALL pyerrm(28,
80440  &'(PYFACT:) not allowed histogram number')
80441  is1=indx(id1)
80442  is2=indx(min(ihist(1),max(1,id2)))
80443  is3=indx(min(ihist(1),max(1,id3)))
80444  nx=nint(bin(is3+1))
80445  IF(oper.EQ.'M'.AND.id3.EQ.0) nx=nint(bin(is2+1))
80446 
80447 C...Update info on number of histogram entries.
80448  IF(oper.EQ.'+'.OR.oper.EQ.'-'.OR.oper.EQ.'*'.OR.oper.EQ.'/') THEN
80449  bin(is3+5)=bin(is1+5)+bin(is2+5)
80450  ELSEIF(oper.EQ.'A'.OR.oper.EQ.'S'.OR.oper.EQ.'L') THEN
80451  bin(is3+5)=bin(is1+5)
80452  ENDIF
80453 
80454 C...Operations on pair of histograms: addition, subtraction,
80455 C...multiplication, division.
80456  IF(oper.EQ.'+') THEN
80457  DO 100 ix=6,8+nx
80458  bin(is3+ix)=f1*bin(is1+ix)+f2*bin(is2+ix)
80459  100 CONTINUE
80460  ELSEIF(oper.EQ.'-') THEN
80461  DO 110 ix=6,8+nx
80462  bin(is3+ix)=f1*bin(is1+ix)-f2*bin(is2+ix)
80463  110 CONTINUE
80464  ELSEIF(oper.EQ.'*') THEN
80465  DO 120 ix=6,8+nx
80466  bin(is3+ix)=f1*bin(is1+ix)*f2*bin(is2+ix)
80467  120 CONTINUE
80468  ELSEIF(oper.EQ.'/') THEN
80469  DO 130 ix=6,8+nx
80470  fa2=f2*bin(is2+ix)
80471  IF(abs(fa2).LE.1d-20) THEN
80472  bin(is3+ix)=0d0
80473  ELSE
80474  bin(is3+ix)=f1*bin(is1+ix)/fa2
80475  ENDIF
80476  130 CONTINUE
80477 
80478 C...Operations on single histogram: multiplication+addition,
80479 C...square root+addition, logarithm+addition.
80480  ELSEIF(oper.EQ.'A') THEN
80481  DO 140 ix=6,8+nx
80482  bin(is3+ix)=f1*bin(is1+ix)+f2
80483  140 CONTINUE
80484  ELSEIF(oper.EQ.'S') THEN
80485  DO 150 ix=6,8+nx
80486  bin(is3+ix)=f1*sqrt(max(0d0,bin(is1+ix)))+f2
80487  150 CONTINUE
80488  ELSEIF(oper.EQ.'L') THEN
80489  zmin=1d20
80490  DO 160 ix=9,8+nx
80491  IF(bin(is1+ix).LT.zmin.AND.bin(is1+ix).GT.1d-20)
80492  & zmin=0.8d0*bin(is1+ix)
80493  160 CONTINUE
80494  DO 170 ix=6,8+nx
80495  bin(is3+ix)=f1*log10(max(zmin,bin(is1+ix)))+f2
80496  170 CONTINUE
80497 
80498 C...Operation on two or three histograms: average and
80499 C...standard deviation.
80500  ELSEIF(oper.EQ.'M') THEN
80501  DO 180 ix=6,8+nx
80502  IF(abs(bin(is1+ix)).LE.1d-20) THEN
80503  bin(is2+ix)=0d0
80504  ELSE
80505  bin(is2+ix)=bin(is2+ix)/bin(is1+ix)
80506  ENDIF
80507  IF(id3.NE.0) THEN
80508  IF(abs(bin(is1+ix)).LE.1d-20) THEN
80509  bin(is3+ix)=0d0
80510  ELSE
80511  bin(is3+ix)=sqrt(max(0d0,bin(is3+ix)/bin(is1+ix)-
80512  & bin(is2+ix)**2))
80513  ENDIF
80514  ENDIF
80515  bin(is1+ix)=f1*bin(is1+ix)
80516  180 CONTINUE
80517  ENDIF
80518 
80519  RETURN
80520  END
80521 
80522 C*********************************************************************
80523 
80524 C...PYHIST
80525 C...Prints and resets all histograms.
80526 
80527  SUBROUTINE pyhist
80528 
80529 C...Double precision declaration.
80530  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80531  IMPLICIT INTEGER(i-n)
80532 C...Commonblock.
80533  common/pybins/ihist(4),indx(1000),bin(20000)
80534  SAVE /pybins/
80535 
80536 C...Loop over histograms, print and reset used ones.
80537  DO 100 id=1,ihist(1)
80538  is=indx(id)
80539  IF(is.NE.0.AND.nint(bin(is+5)).GT.0) THEN
80540  CALL pyplot(id)
80541  CALL pynull(id)
80542  ENDIF
80543  100 CONTINUE
80544 
80545  RETURN
80546  END
80547 
80548 C*********************************************************************
80549 
80550 C...PYPLOT
80551 C...Prints a histogram (but does not reset it).
80552 
80553  SUBROUTINE pyplot(ID)
80554 
80555 C...Double precision declaration.
80556  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80557  IMPLICIT INTEGER(i-n)
80558 C...Commonblocks.
80559  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
80560  common/pybins/ihist(4),indx(1000),bin(20000)
80561  SAVE /pydat1/,/pybins/
80562 C...Local arrays and character variables.
80563  dimension idati(6), irow(100), ifra(100), dyac(10)
80564  CHARACTER title*60, out*100, cha(0:11)*1
80565 
80566 C...Steps in histogram scale. Character sequence.
80567  DATA dyac/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
80568  DATA cha/'0','1','2','3','4','5','6','7','8','9','X','-'/
80569 
80570 C...Find initial address in memory; skip if empty histogram.
80571  IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
80572  is=indx(id)
80573  IF(is.EQ.0) RETURN
80574  IF(nint(bin(is+5)).LE.0) THEN
80575  WRITE(mstu(11),5000) id
80576  RETURN
80577  ENDIF
80578 
80579 C...Number of histogram lines and x bins.
80580  lin=ihist(3)-18
80581  nx=nint(bin(is+1))
80582 
80583 C...Extract title by conversion from double precision via integer.
80584  DO 100 it=1,20
80585  ieq=nint(bin(is+8+nx+it))
80586  title(3*it-2:3*it)=char(ieq/256**2)//char(mod(ieq,256**2)/256)
80587  & //char(mod(ieq,256))
80588  100 CONTINUE
80589 
80590 C...Find time; print title.
80591  CALL pytime(idati)
80592  IF(idati(1).GT.0) THEN
80593  WRITE(mstu(11),5100) id, title, (idati(j),j=1,5)
80594  ELSE
80595  WRITE(mstu(11),5200) id, title
80596  ENDIF
80597 
80598 C...Find minimum and maximum bin content.
80599  ymin=bin(is+9)
80600  ymax=bin(is+9)
80601  DO 110 ix=is+10,is+8+nx
80602  IF(bin(ix).LT.ymin) ymin=bin(ix)
80603  IF(bin(ix).GT.ymax) ymax=bin(ix)
80604  110 CONTINUE
80605 
80606 C...Determine scale and step size for y axis.
80607  IF(ymax-ymin.GT.lin*dyac(1)*1d-9) THEN
80608  IF(ymin.GT.0d0.AND.ymin.LT.0.1d0*ymax) ymin=0d0
80609  IF(ymax.LT.0d0.AND.ymax.GT.0.1d0*ymin) ymax=0d0
80610  ipot=int(log10(ymax-ymin)+10d0)-10
80611  IF(ymax-ymin.LT.lin*dyac(1)*10d0**ipot) ipot=ipot-1
80612  IF(ymax-ymin.GT.lin*dyac(10)*10d0**ipot) ipot=ipot+1
80613  dely=dyac(1)
80614  DO 120 idel=1,9
80615  IF(ymax-ymin.GE.lin*dyac(idel)*10d0**ipot) dely=dyac(idel+1)
80616  120 CONTINUE
80617  dy=dely*10d0**ipot
80618 
80619 C...Convert bin contents to integer form; fractional fill in top row.
80620  DO 130 ix=1,nx
80621  cta=abs(bin(is+8+ix))/dy
80622  irow(ix)=sign(cta+0.95d0,bin(is+8+ix))
80623  ifra(ix)=10d0*(cta+1.05d0-dble(int(cta+0.95d0)))
80624  130 CONTINUE
80625  irmi=sign(abs(ymin)/dy+0.95d0,ymin)
80626  irma=sign(abs(ymax)/dy+0.95d0,ymax)
80627 
80628 C...Print histogram row by row.
80629  DO 150 ir=irma,irmi,-1
80630  IF(ir.EQ.0) goto 150
80631  out=' '
80632  DO 140 ix=1,nx
80633  IF(ir.EQ.irow(ix)) out(ix:ix)=cha(ifra(ix))
80634  IF(ir*(irow(ix)-ir).GT.0) out(ix:ix)=cha(10)
80635  140 CONTINUE
80636  WRITE(mstu(11),5300) ir*dely, ipot, out
80637  150 CONTINUE
80638 
80639 C...Print sign and value of bin contents.
80640  ipot=int(log10(max(ymax,-ymin))+10.0001d0)-10
80641  out=' '
80642  DO 160 ix=1,nx
80643  IF(bin(is+8+ix).LT.-10d0**(ipot-4)) out(ix:ix)=cha(11)
80644  irow(ix)=nint(10d0**(3-ipot)*abs(bin(is+8+ix)))
80645  160 CONTINUE
80646  WRITE(mstu(11),5400) out
80647  DO 180 ir=4,1,-1
80648  DO 170 ix=1,nx
80649  out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
80650  170 CONTINUE
80651  WRITE(mstu(11),5500) ipot+ir-4, out
80652  180 CONTINUE
80653 
80654 C...Print sign and value of lower bin edge.
80655  ipot=int(log10(max(-bin(is+2),bin(is+3)-bin(is+4)))+
80656  & 10.0001d0)-10
80657  out=' '
80658  DO 190 ix=1,nx
80659  IF(bin(is+2)+(ix-1)*bin(is+4).LT.-10d0**(ipot-3))
80660  & out(ix:ix)=cha(11)
80661  irow(ix)=nint(10d0**(2-ipot)*abs(bin(is+2)+(ix-1)*bin(is+4)))
80662  190 CONTINUE
80663  WRITE(mstu(11),5600) out
80664  DO 210 ir=3,1,-1
80665  DO 200 ix=1,nx
80666  out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
80667  200 CONTINUE
80668  WRITE(mstu(11),5500) ipot+ir-3, out
80669  210 CONTINUE
80670  ENDIF
80671 
80672 C...Calculate and print statistics.
80673  csum=0d0
80674  cxsum=0d0
80675  cxxsum=0d0
80676  DO 220 ix=1,nx
80677  cta=abs(bin(is+8+ix))
80678  x=bin(is+2)+(ix-0.5d0)*bin(is+4)
80679  csum=csum+cta
80680  cxsum=cxsum+cta*x
80681  cxxsum=cxxsum+cta*x**2
80682  220 CONTINUE
80683  xmean=cxsum/max(csum,1d-20)
80684  xrms=sqrt(max(0d0,cxxsum/max(csum,1d-20)-xmean**2))
80685  WRITE(mstu(11),5700) nint(bin(is+5)),xmean,bin(is+6),
80686  &bin(is+2),bin(is+7),xrms,bin(is+8),bin(is+3)
80687 
80688 C...Formats for output.
80689  5000 FORMAT(/5x,'Histogram no',i5,' : no entries')
80690  5100 FORMAT('1'/5x,'Histogram no',i5,6x,a60,5x,i4,'-',i2,'-',i2,1x,
80691  &i2,':',i2/)
80692  5200 FORMAT('1'/5x,'Histogram no',i5,6x,a60/)
80693  5300 FORMAT(2x,f7.2,'*10**',i2,3x,a100)
80694  5400 FORMAT(/8x,'Contents',3x,a100)
80695  5500 FORMAT(9x,'*10**',i2,3x,a100)
80696  5600 FORMAT(/8x,'Low edge',3x,a100)
80697  5700 FORMAT(/5x,'Entries =',i12,1p,6x,'Mean =',d12.4,6x,'Underflow ='
80698  &,d12.4,6x,'Low edge =',d12.4/5x,'All chan =',d12.4,6x,
80699  &'Rms =',d12.4,6x,'Overflow =',d12.4,6x,'High edge =',d12.4)
80700 
80701  RETURN
80702  END
80703 
80704 C*********************************************************************
80705 
80706 C...PYNULL
80707 C...Resets bin contents of a histogram.
80708 
80709  SUBROUTINE pynull(ID)
80710 
80711 C...Double precision declaration.
80712  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80713  IMPLICIT INTEGER(i-n)
80714 C...Commonblock.
80715  common/pybins/ihist(4),indx(1000),bin(20000)
80716  SAVE /pybins/
80717 
80718  IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
80719  is=indx(id)
80720  IF(is.EQ.0) RETURN
80721  DO 100 ix=is+5,is+8+nint(bin(is+1))
80722  bin(ix)=0d0
80723  100 CONTINUE
80724 
80725  RETURN
80726  END
80727 
80728 C*********************************************************************
80729 
80730 C...PYDUMP
80731 C...Dumps histogram contents on file for reading by other program.
80732 C...Can also read back own dump.
80733 
80734  SUBROUTINE pydump(MDUMP,LFN,NHI,IHI)
80735 
80736 C...Double precision declaration.
80737  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80738  IMPLICIT INTEGER(i-n)
80739 C...Commonblock.
80740  common/pybins/ihist(4),indx(1000),bin(20000)
80741  SAVE /pybins/
80742 C...Local arrays and character variables.
80743  dimension ihi(*),iss(100),val(5)
80744  CHARACTER title*60,format*13
80745 
80746 C...Dump all histograms that have been booked,
80747 C...including titles and ranges, one after the other.
80748  IF(mdump.EQ.1) THEN
80749 
80750 C...Loop over histograms and find which are wanted and booked.
80751  IF(nhi.LE.0) THEN
80752  nw=ihist(1)
80753  ELSE
80754  nw=nhi
80755  ENDIF
80756  DO 130 iw=1,nw
80757  IF(nhi.EQ.0) THEN
80758  id=iw
80759  ELSE
80760  id=ihi(iw)
80761  ENDIF
80762  is=indx(id)
80763  IF(is.NE.0) THEN
80764 
80765 C...Write title, histogram size, filling statistics.
80766  nx=nint(bin(is+1))
80767  DO 100 it=1,20
80768  ieq=nint(bin(is+8+nx+it))
80769  title(3*it-2:3*it)=char(ieq/256**2)//
80770  & char(mod(ieq,256**2)/256)//char(mod(ieq,256))
80771  100 CONTINUE
80772  WRITE(lfn,5100) id,title
80773  WRITE(lfn,5200) nx,bin(is+2),bin(is+3)
80774  WRITE(lfn,5300) nint(bin(is+5)),bin(is+6),bin(is+7),
80775  & bin(is+8)
80776 
80777 
80778 C...Write histogram contents, in groups of five.
80779  DO 120 ixg=1,(nx+4)/5
80780  DO 110 ixv=1,5
80781  ix=5*ixg+ixv-5
80782  IF(ix.LE.nx) THEN
80783  val(ixv)=bin(is+8+ix)
80784  ELSE
80785  val(ixv)=0d0
80786  ENDIF
80787  110 CONTINUE
80788  WRITE(lfn,5400) (val(ixv),ixv=1,5)
80789  120 CONTINUE
80790 
80791 C...Go to next histogram; finish.
80792  ELSEIF(nhi.GT.0) THEN
80793  CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
80794  ENDIF
80795  130 CONTINUE
80796 
80797 C...Read back in histograms dumped MDUMP=1.
80798  ELSEIF(mdump.EQ.2) THEN
80799 
80800 C...Read histogram number, title and range, and book.
80801  140 READ(lfn,5100,end=170) id,title
80802  READ(lfn,5200) nx,xl,xu
80803  CALL pybook(id,title,nx,xl,xu)
80804  is=indx(id)
80805 
80806 C...Read filling statistics.
80807  READ(lfn,5300) nentry,bin(is+6),bin(is+7),bin(is+8)
80808  bin(is+5)=dble(nentry)
80809 
80810 C...Read histogram contents, in groups of five.
80811  DO 160 ixg=1,(nx+4)/5
80812  READ(lfn,5400) (val(ixv),ixv=1,5)
80813  DO 150 ixv=1,5
80814  ix=5*ixg+ixv-5
80815  IF(ix.LE.nx) bin(is+8+ix)=val(ixv)
80816  150 CONTINUE
80817  160 CONTINUE
80818 
80819 C...Go to next histogram; finish.
80820  goto 140
80821  170 CONTINUE
80822 
80823 C...Write histogram contents in column format,
80824 C...convenient e.g. for GNUPLOT input.
80825  ELSEIF(mdump.EQ.3) THEN
80826 
80827 C...Find addresses to wanted histograms.
80828  nss=0
80829  IF(nhi.LE.0) THEN
80830  nw=ihist(1)
80831  ELSE
80832  nw=nhi
80833  ENDIF
80834  DO 180 iw=1,nw
80835  IF(nhi.EQ.0) THEN
80836  id=iw
80837  ELSE
80838  id=ihi(iw)
80839  ENDIF
80840  is=indx(id)
80841  IF(is.NE.0.AND.nss.LT.100) THEN
80842  nss=nss+1
80843  iss(nss)=is
80844  ELSEIF(nss.GE.100) THEN
80845  CALL pyerrm(8,'(PYDUMP:) too many histograms requested')
80846  ELSEIF(nhi.GT.0) THEN
80847  CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
80848  ENDIF
80849  180 CONTINUE
80850 
80851 C...Check that they have common number of x bins. Fix format.
80852  nx=nint(bin(iss(1)+1))
80853  DO 190 iw=2,nss
80854  IF(nint(bin(iss(iw)+1)).NE.nx) THEN
80855  CALL pyerrm(8,'(PYDUMP:) different number of bins')
80856  RETURN
80857  ENDIF
80858  190 CONTINUE
80859  format='(1P,000E12.4)'
80860  WRITE(FORMAT(5:7),'(I3)') nss+1
80861 
80862 C...Write histogram contents; first column x values.
80863  DO 200 ix=1,nx
80864  x=bin(iss(1)+2)+(ix-0.5d0)*bin(iss(1)+4)
80865  WRITE(lfn,format) x, (bin(iss(iw)+8+ix),iw=1,nss)
80866  200 CONTINUE
80867 
80868  ENDIF
80869 
80870 C...Formats for output.
80871  5100 FORMAT(i5,5x,a60)
80872  5200 FORMAT(i5,1p,2d12.4)
80873  5300 FORMAT(i12,1p,3d12.4)
80874  5400 FORMAT(1p,5d12.4)
80875 
80876  RETURN
80877  END
80878 
80879 C*********************************************************************
80880 
80881 C...PYSTOP
80882 C...Allows users to handle STOP statemens
80883 
80884  SUBROUTINE pystop(MCOD)
80885 
80886 C...Double precision and integer declarations.
80887  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80888  IMPLICIT INTEGER(i-n)
80889  INTEGER pyk,pychge,pycomp
80890 C...Commonblocks.
80891  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
80892  SAVE /pydat1/
80893 
80894 
80895 C...Write message, then stop
80896  WRITE(mstu(11),5000) mcod
80897  stop
80898 
80899 
80900 C...Formats for output.
80901  5000 FORMAT(/5x,'PYSTOP called with code: ',i4)
80902  END
80903 
80904 C*********************************************************************
80905 
80906 C...PYKCUT
80907 C...Dummy routine, which the user can replace in order to make cuts on
80908 C...the kinematics on the parton level before the matrix elements are
80909 C...evaluated and the event is generated. The cross-section estimates
80910 C...will automatically take these cuts into account, so the given
80911 C...values are for the allowed phase space region only. MCUT=0 means
80912 C...that the event has passed the cuts, MCUT=1 that it has failed.
80913 
80914  SUBROUTINE pykcut(MCUT)
80915 
80916 C...Double precision and integer declarations.
80917  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80918  IMPLICIT INTEGER(i-n)
80919  INTEGER pyk,pychge,pycomp
80920 C...Commonblocks.
80921  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
80922  common/pyint1/mint(400),vint(400)
80923  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
80924  SAVE /pydat1/,/pyint1/,/pyint2/
80925 
80926 C...Set default value (accepting event) for MCUT.
80927  mcut=0
80928 
80929 C...Read out subprocess number.
80930  isub=mint(1)
80931  istsb=iset(isub)
80932 
80933 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
80934  tau=vint(21)
80935  yst=vint(22)
80936  cth=0d0
80937  IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
80938  taup=0d0
80939  IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
80940 
80941 C...Calculate x_1, x_2, x_F.
80942  IF(istsb.LE.2.OR.istsb.GE.5) THEN
80943  x1=sqrt(tau)*exp(yst)
80944  x2=sqrt(tau)*exp(-yst)
80945  ELSE
80946  x1=sqrt(taup)*exp(yst)
80947  x2=sqrt(taup)*exp(-yst)
80948  ENDIF
80949  xf=x1-x2
80950 
80951 C...Calculate shat, that, uhat, p_T^2.
80952  shat=tau*vint(2)
80953  sqm3=vint(63)
80954  sqm4=vint(64)
80955  rm3=sqm3/shat
80956  rm4=sqm4/shat
80957  be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
80958  rpts=4d0*vint(71)**2/shat
80959  be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
80960  rm34=2d0*rm3*rm4
80961  rsqm=1d0+rm34
80962  rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
80963  that=-0.5d0*shat*max(rthm,1d0-rm3-rm4-be34*cth)
80964  uhat=-0.5d0*shat*max(rthm,1d0-rm3-rm4+be34*cth)
80965  pt2=max(vint(71)**2,0.25d0*shat*be34**2*(1d0-cth**2))
80966 
80967 C...Decisions by user to be put here.
80968 
80969 C...Stop program if this routine is ever called.
80970 C...You should not copy these lines to your own routine.
80971  WRITE(mstu(11),5000)
80972  CALL pystop(6)
80973 
80974 C...Format for error printout.
80975  5000 FORMAT(1x,'Error: you did not link your PYKCUT routine ',
80976  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
80977  &1x,'Execution stopped!')
80978 
80979  RETURN
80980  END
80981 
80982 C*********************************************************************
80983 
80984 C...PYEVWT
80985 C...Dummy routine, which the user can replace in order to multiply the
80986 C...standard PYTHIA differential cross-section by a process- and
80987 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
80988 C...to generation of weighted events, with weight 1/WTXS, while for
80989 C...MSTP(142)=2 it corresponds to a modification of the underlying
80990 C...physics.
80991 
80992  SUBROUTINE pyevwt(WTXS)
80993 
80994 C...Double precision and integer declarations.
80995  IMPLICIT DOUBLE PRECISION(a-h, o-z)
80996  IMPLICIT INTEGER(i-n)
80997  INTEGER pyk,pychge,pycomp
80998 C...Commonblocks.
80999  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81000  common/pyint1/mint(400),vint(400)
81001  common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
81002  SAVE /pydat1/,/pyint1/,/pyint2/
81003 
81004 C...Set default weight for WTXS.
81005  wtxs=1d0
81006 
81007 C...Read out subprocess number.
81008  isub=mint(1)
81009  istsb=iset(isub)
81010 
81011 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
81012  tau=vint(21)
81013  yst=vint(22)
81014  cth=0d0
81015  IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
81016  taup=0d0
81017  IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
81018 
81019 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
81020  x1=vint(41)
81021  x2=vint(42)
81022  xf=x1-x2
81023  shat=vint(44)
81024  that=vint(45)
81025  uhat=vint(46)
81026  pt2=vint(48)
81027 
81028 C...Modifications by user to be put here.
81029 
81030 C...Stop program if this routine is ever called.
81031 C...You should not copy these lines to your own routine.
81032  WRITE(mstu(11),5000)
81033  CALL pystop(4)
81034 
81035 C...Format for error printout.
81036  5000 FORMAT(1x,'Error: you did not link your PYEVWT routine ',
81037  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
81038  &1x,'Execution stopped!')
81039 
81040  RETURN
81041  END
81042 
81043 C*********************************************************************
81044 
81045 C...UPINIT
81046 C...Dummy routine, to be replaced by a user implementing external
81047 C...processes. Is supposed to fill the HEPRUP commonblock with info
81048 C...on incoming beams and allowed processes.
81049 
81050 C...New example: handles a standard Les Houches Events File.
81051 
81052  SUBROUTINE upinit
81053 
81054 C...Double precision and integer declarations.
81055  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81056  IMPLICIT INTEGER(i-n)
81057 
81058 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
81059  common/pypars/mstp(200),parp(200),msti(200),pari(200)
81060  SAVE /pypars/
81061 
81062 C...User process initialization commonblock.
81063  INTEGER maxpup
81064  parameter(maxpup=100)
81065  INTEGER idbmup,pdfgup,pdfsup,idwtup,nprup,lprup
81066  DOUBLE PRECISION ebmup,xsecup,xerrup,xmaxup
81067  common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
81068  &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
81069  &lprup(maxpup)
81070  SAVE /heprup/
81071 
81072 C...Lines to read in assumed never longer than 200 characters.
81073  parameter(maxlen=200)
81074  CHARACTER*(MAXLEN) string
81075 
81076 C...Format for reading lines.
81077  CHARACTER*6 strfmt
81078  strfmt='(A000)'
81079  WRITE(strfmt(3:5),'(I3)') maxlen
81080 
81081 C...Loop until finds line beginning with "<init>" or "<init ".
81082  100 READ(mstp(161),strfmt,end=130,err=130) string
81083  ibeg=0
81084  110 ibeg=ibeg+1
81085 C...Allow indentation.
81086  IF(string(ibeg:ibeg).EQ.' '.AND.ibeg.LT.maxlen-5) goto 110
81087  IF(string(ibeg:ibeg+5).NE.'<init>'.AND.
81088  &string(ibeg:ibeg+5).NE.'<init ') goto 100
81089 
81090 C...Read first line of initialization info.
81091  READ(mstp(161),*,end=130,err=130) idbmup(1),idbmup(2),ebmup(1),
81092  &ebmup(2),pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
81093 
81094 C...Read NPRUP subsequent lines with information on each process.
81095  DO 120 ipr=1,nprup
81096  READ(mstp(161),*,end=130,err=130) xsecup(ipr),xerrup(ipr),
81097  & xmaxup(ipr),lprup(ipr)
81098  120 CONTINUE
81099  RETURN
81100 
81101 C...Error exit: give up if initalization does not work.
81102  130 WRITE(*,*) ' Failed to read LHEF initialization information.'
81103  WRITE(*,*) ' Event generation will be stopped.'
81104  CALL pystop(12)
81105 
81106  RETURN
81107  END
81108 
81109 C...Old example: handles a simple Pythia 6.4 initialization file.
81110 
81111 c SUBROUTINE UPINIT
81112 
81113 C...Double precision and integer declarations.
81114 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81115 c IMPLICIT INTEGER(I-N)
81116 
81117 C...Commonblocks.
81118 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81119 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
81120 c SAVE /PYDAT1/,/PYPARS/
81121 
81122 C...User process initialization commonblock.
81123 c INTEGER MAXPUP
81124 c PARAMETER (MAXPUP=100)
81125 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
81126 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
81127 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
81128 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
81129 c &LPRUP(MAXPUP)
81130 c SAVE /HEPRUP/
81131 
81132 C...Read info from file.
81133 c IF(MSTP(161).GT.0) THEN
81134 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
81135 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
81136 c DO 100 IPR=1,NPRUP
81137 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
81138 c & XMAXUP(IPR),LPRUP(IPR)
81139 c 100 CONTINUE
81140 c RETURN
81141 C...Error or prematurely reached end of file.
81142 c 110 WRITE(MSTU(11),5000)
81143 c STOP
81144 
81145 C...Else not implemented.
81146 c ELSE
81147 c WRITE(MSTU(11),5100)
81148 c STOP
81149 c ENDIF
81150 
81151 C...Format for error printout.
81152 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
81153 c &1X,'Execution stopped!')
81154 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
81155 c &1X,'Dummy routine in PYTHIA file called instead.'/
81156 c &1X,'Execution stopped!')
81157 
81158 c RETURN
81159 c END
81160 
81161 C*********************************************************************
81162 
81163 C...UPEVNT
81164 C...Dummy routine, to be replaced by a user implementing external
81165 C...processes. Depending on cross section model chosen, it either has
81166 C...to generate a process of the type IDPRUP requested, or pick a type
81167 C...itself and generate this event. The event is to be stored in the
81168 C...HEPEUP commonblock, including (often) an event weight.
81169 
81170 C...New example: handles a standard Les Houches Events File.
81171 
81172  SUBROUTINE upevnt
81173 
81174 C...Double precision and integer declarations.
81175  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81176  IMPLICIT INTEGER(i-n)
81177 
81178 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
81179  common/pypars/mstp(200),parp(200),msti(200),pari(200)
81180  SAVE /pypars/
81181 
81182 C...User process event common block.
81183  INTEGER maxnup
81184  parameter(maxnup=500)
81185  INTEGER nup,idprup,idup,istup,mothup,icolup
81186  DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
81187  common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
81188  &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
81189  &vtimup(maxnup),spinup(maxnup)
81190  SAVE /hepeup/
81191 
81192 C...Lines to read in assumed never longer than 200 characters.
81193  parameter(maxlen=200)
81194  CHARACTER*(MAXLEN) string
81195 
81196 C...Format for reading lines.
81197  CHARACTER*6 strfmt
81198  strfmt='(A000)'
81199  WRITE(strfmt(3:5),'(I3)') maxlen
81200 
81201 C...Loop until finds line beginning with "<event>" or "<event ".
81202  100 READ(mstp(162),strfmt,end=130,err=130) string
81203  ibeg=0
81204  110 ibeg=ibeg+1
81205 C...Allow indentation.
81206  IF(string(ibeg:ibeg).EQ.' '.AND.ibeg.LT.maxlen-6) goto 110
81207  IF(string(ibeg:ibeg+6).NE.'<event>'.AND.
81208  &string(ibeg:ibeg+6).NE.'<event ') goto 100
81209 
81210 C...Read first line of event info.
81211  READ(mstp(162),*,end=130,err=130) nup,idprup,xwgtup,scalup,
81212  &aqedup,aqcdup
81213 
81214 C...Read NUP subsequent lines with information on each particle.
81215  DO 120 i=1,nup
81216  READ(mstp(162),*,end=130,err=130) idup(i),istup(i),
81217  & mothup(1,i),mothup(2,i),icolup(1,i),icolup(2,i),
81218  & (pup(j,i),j=1,5),vtimup(i),spinup(i)
81219  120 CONTINUE
81220  RETURN
81221 
81222 C...Error exit, typically when no more events.
81223  130 WRITE(*,*) ' Failed to read LHEF event information.'
81224  WRITE(*,*) ' Will assume end of file has been reached.'
81225  nup=0
81226  msti(51)=1
81227 
81228  RETURN
81229  END
81230 
81231 C...Old example: handles a simple Pythia 6.4 event file.
81232 
81233 c SUBROUTINE UPEVNT
81234 
81235 C...Double precision and integer declarations.
81236 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
81237 c IMPLICIT INTEGER(I-N)
81238 
81239 C...Commonblocks.
81240 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
81241 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
81242 c SAVE /PYDAT1/,/PYPARS/
81243 
81244 C...User process event common block.
81245 c INTEGER MAXNUP
81246 c PARAMETER (MAXNUP=500)
81247 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
81248 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
81249 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
81250 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
81251 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
81252 c SAVE /HEPEUP/
81253 
81254 C...Read info from file.
81255 c IF(MSTP(162).GT.0) THEN
81256 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
81257 c & AQEDUP,AQCDUP
81258 c DO 100 I=1,NUP
81259 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
81260 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
81261 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
81262 c 100 CONTINUE
81263 c RETURN
81264 C...Special when reached end of file or other error.
81265 c 110 NUP=0
81266 
81267 C...Else not implemented.
81268 c ELSE
81269 c WRITE(MSTU(11),5000)
81270 c STOP
81271 c ENDIF
81272 
81273 C...Format for error printout.
81274 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
81275 c &1X,'Dummy routine in PYTHIA file called instead.'/
81276 c &1X,'Execution stopped!')
81277 
81278 c RETURN
81279 c END
81280 
81281 C*********************************************************************
81282 
81283 C...UPVETO
81284 C...Dummy routine, to be replaced by user, to veto event generation
81285 C...on the parton level, after parton showers but before multiple
81286 C...interactions, beam remnants and hadronization is added.
81287 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
81288 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
81289 C...be undecayed at this stage; if decayed their decay products will
81290 C...have been allowed to shower.
81291 
81292 C...All partons at the end of the shower phase are stored in the
81293 C...HEPEVT commonblock. The interesting information is
81294 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
81295 C...IDHEP(I) = the particle ID code according to PDG conventions,
81296 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
81297 C...All ISTHEP entries are 1, while the rest is zeroed.
81298 
81299 C...The user decision is to be conveyed by the IVETO value.
81300 C...IVETO = 0 : retain current event and generate in full;
81301 C... = 1 : abort generation of current event and move to next.
81302 
81303  SUBROUTINE upveto(IVETO)
81304 
81305 C...HEPEVT commonblock.
81306  parameter(nmxhep=4000)
81307  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
81308  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
81309  DOUBLE PRECISION phep,vhep
81310  SAVE /hepevt/
81311 
81312 C...Next few lines allow you to see what info PYVETO extracted from
81313 C...the full event record for the first two events.
81314 C...Delete if you don't want it.
81315  DATA nlist/0/
81316  SAVE nlist
81317  IF(nlist.LE.2) THEN
81318  WRITE(*,*) ' Full event record at time of UPVETO call:'
81319  CALL pylist(1)
81320  WRITE(*,*) ' Part of event record made available to UPVETO:'
81321  CALL pylist(5)
81322  nlist=nlist+1
81323  ENDIF
81324 
81325 C...Make decision here.
81326  iveto = 0
81327 
81328  RETURN
81329  END
81330 
81331 C*********************************************************************
81332 
81333 C...PDFSET
81334 C...Dummy routine, to be removed when PDFLIB is to be linked.
81335 
81336  SUBROUTINE pdfset(PARM,VALUE)
81337 
81338 C...Double precision and integer declarations.
81339  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81340  IMPLICIT INTEGER(i-n)
81341  INTEGER pyk,pychge,pycomp
81342 C...Commonblocks.
81343  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81344  SAVE /pydat1/
81345 C...Local arrays and character variables.
81346  CHARACTER*20 parm(20)
81347  DOUBLE PRECISION value(20)
81348 
81349 C...Stop program if this routine is ever called.
81350  WRITE(mstu(11),5000)
81351  CALL pystop(5)
81352  parm(20)=parm(1)
81353  value(20)=value(1)
81354 
81355 C...Format for error printout.
81356  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
81357  &1x,'Dummy routine PDFSET in PYTHIA file called instead.'/
81358  &1x,'Execution stopped!')
81359 
81360  RETURN
81361  END
81362 
81363 C*********************************************************************
81364 
81365 C...STRUCTM
81366 C...Dummy routine, to be removed when PDFLIB is to be linked.
81367 
81368  SUBROUTINE structm(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
81369 
81370 C...Double precision and integer declarations.
81371  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81372  IMPLICIT INTEGER(i-n)
81373  INTEGER pyk,pychge,pycomp
81374 C...Commonblocks.
81375  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81376  SAVE /pydat1/
81377 C...Local variables
81378  DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu
81379 
81380 C...Stop program if this routine is ever called.
81381  WRITE(mstu(11),5000)
81382  CALL pystop(5)
81383  upv=xx+qq
81384  dnv=xx+2d0*qq
81385  usea=xx+3d0*qq
81386  dsea=xx+4d0*qq
81387  str=xx+5d0*qq
81388  chm=xx+6d0*qq
81389  bot=xx+7d0*qq
81390  top=xx+8d0*qq
81391  glu=xx+9d0*qq
81392 
81393 C...Format for error printout.
81394  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
81395  &1x,'Dummy routine STRUCTM in PYTHIA file called instead.'/
81396  &1x,'Execution stopped!')
81397 
81398  RETURN
81399  END
81400 
81401 C*********************************************************************
81402 
81403 C...STRUCTP
81404 C...Dummy routine, to be removed when PDFLIB is to be linked.
81405 
81406  SUBROUTINE structp(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
81407  &bot,top,glu)
81408 
81409 C...Double precision and integer declarations.
81410  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81411  IMPLICIT INTEGER(i-n)
81412  INTEGER pyk,pychge,pycomp
81413 C...Commonblocks.
81414  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81415  SAVE /pydat1/
81416 C...Local variables
81417  DOUBLE PRECISION xx,qq2,p2,upv,dnv,usea,dsea,str,chm,bot,
81418  &top,glu
81419 
81420 C...Stop program if this routine is ever called.
81421  WRITE(mstu(11),5000)
81422  CALL pystop(5)
81423  upv=xx+qq2
81424  dnv=xx+2d0*qq2
81425  usea=xx+3d0*qq2
81426  dsea=xx+4d0*qq2
81427  str=xx+5d0*qq2
81428  chm=xx+6d0*qq2
81429  bot=xx+7d0*qq2
81430  top=xx+8d0*qq2
81431  glu=xx+9d0*qq2
81432 
81433 C...Format for error printout.
81434  5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
81435  &1x,'Dummy routine STRUCTP in PYTHIA file called instead.'/
81436  &1x,'Execution stopped!')
81437 
81438  RETURN
81439  END
81440 
81441 C*********************************************************************
81442 
81443 C...SUGRA
81444 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
81445 
81446  SUBROUTINE sugra(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
81447  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81448  IMPLICIT INTEGER(i-n)
81449  REAL mzero,mhlf,azero,tanb,sgnmu,mtop
81450  INTEGER imodl
81451 C...Commonblocks.
81452  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81453  SAVE /pydat1/
81454 
81455 C...Stop program if this routine is ever called.
81456  WRITE(mstu(11),5000)
81457  CALL pystop(110)
81458 
81459 C...Format for error printout.
81460  5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
81461  &1x,'Dummy routine SUGRA in PYTHIA file called instead.'/
81462  &1x,'Execution stopped!')
81463 
81464  RETURN
81465  END
81466 
81467 C*********************************************************************
81468 
81469 C...VISAJE
81470 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
81471 
81472  FUNCTION visaje()
81473  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81474  IMPLICIT INTEGER(i-n)
81475  CHARACTER*40 visaje
81476 
81477 C...Commonblocks.
81478  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81479  SAVE /pydat1/
81480 
81481 C...Assign default value.
81482  visaje='Undefined'
81483 
81484 C...Stop program if this routine is ever called.
81485  WRITE(mstu(11),5000)
81486  CALL pystop(110)
81487 
81488 C...Format for error printout.
81489  5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
81490  &1x,'Dummy function VISAJE in PYTHIA file called instead.'/
81491  &1x,'Execution stopped!')
81492 
81493  RETURN
81494  END
81495 
81496 C*********************************************************************
81497 
81498 C...SSMSSM
81499 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
81500 
81501  SUBROUTINE ssmssm(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
81502  &rdum8,rdum9,rdum10,rdum11,rdum12,rdum13,rdum14,rdum15,rdum16,
81503  &rdum17,rdum18,rdum19,rdum20,rdum21,rdum22,rdum23,rdum24,rdum25,
81504  &idum1,idum2)
81505  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81506  IMPLICIT INTEGER(i-n)
81507  REAL rdum1,rdum2,rdum3,rdum4,rdum5,rdum6,rdum7,rdum8,rdum9,
81508  &rdum10,rdum11,rdum12,rdum13,rdum14,rdum15,rdum16,rdum17,rdum18,
81509  &rdum19,rdum20,rdum21,rdum22,rdum23,rdum24,rdum25
81510 C...Commonblocks.
81511  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81512  SAVE /pydat1/
81513 
81514 C...Stop program if this routine is ever called.
81515  WRITE(mstu(11),5000)
81516  CALL pystop(110)
81517 
81518 C...Format for error printout.
81519  5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
81520  &1x,'Dummy routine SSMSSM in PYTHIA file called instead.'/
81521  &1x,'Execution stopped!')
81522  RETURN
81523  END
81524 
81525 C*********************************************************************
81526 
81527 C...FHSETFLAGS
81528 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
81529 
81530  SUBROUTINE fhsetflags(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
81531  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81532  IMPLICIT INTEGER(i-n)
81533 Cmssmpart = 4 # full MSSM [recommended]
81534 Cfieldren = 0 # MSbar field ren. [strongly recommended]
81535 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
81536 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
81537 Cp2approx = 0 # no approximation [recommended]
81538 Clooplevel= 2 # include 2-loop corrections
81539 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
81540 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
81541 
81542 C...Commonblocks.
81543  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81544  SAVE /pydat1/
81545 
81546 C...Stop program if this routine is ever called.
81547  WRITE(mstu(11),5000)
81548  CALL pystop(103)
81549 
81550 C...Format for error printout.
81551  5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
81552  &1x,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
81553  &1x,'Execution stopped!')
81554  RETURN
81555  END
81556 
81557 C*********************************************************************
81558 
81559 C...FHSETPARA
81560 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
81561 
81562  SUBROUTINE fhsetpara(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
81563  & dm3e,dm3q,dm3u,dm3d,dm2l,dm2e,dm2q,dm2u, dm2d,dm1l,dm1e,dm1q,
81564  & dm1u,dm1d,dmu,ae33,au33,ad33,ae22,au22,ad22,ae11,au11,ad11,
81565  & dm1,dm2,dm3,rlt,rlb,qtau,qt,qb)
81566  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81567  IMPLICIT INTEGER(i-n)
81568 
81569  DOUBLE COMPLEX saeff, uhiggs(3,3)
81570  DOUBLE COMPLEX dmu,
81571  & ae33, au33, ad33, ae22, au22, ad22, ae11, au11, ad11,
81572  & dm1, dm2, dm3
81573 
81574 C...Commonblocks.
81575  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81576  SAVE /pydat1/
81577 
81578 C...Stop program if this routine is ever called.
81579  WRITE(mstu(11),5000)
81580  CALL pystop(103)
81581 
81582 C...Format for error printout.
81583  5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
81584  &1x,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
81585  &1x,'Execution stopped!')
81586  RETURN
81587  END
81588 
81589 C*********************************************************************
81590 
81591 C...FHHIGGSCORR
81592 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
81593 
81594  SUBROUTINE fhhiggscorr(IERR, RMHIGG, SAEFF, UHIGGS)
81595  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81596  IMPLICIT INTEGER(i-n)
81597 
81598 C...FeynHiggs variables
81599  DOUBLE PRECISION rmhigg(4)
81600  DOUBLE COMPLEX saeff, uhiggs(3,3)
81601  DOUBLE COMPLEX dmu,
81602  & ae33, au33, ad33, ae22, au22, ad22, ae11, au11, ad11,
81603  & dm1, dm2, dm3
81604 
81605 C...Commonblocks.
81606  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81607  SAVE /pydat1/
81608 
81609 C...Stop program if this routine is ever called.
81610  WRITE(mstu(11),5000)
81611  CALL pystop(103)
81612 
81613 C...Format for error printout.
81614  5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
81615  &1x,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
81616  &1x,'Execution stopped!')
81617  RETURN
81618  END
81619 
81620 C*********************************************************************
81621 
81622 C...PYTAUD
81623 C...Dummy routine, to be replaced by user, to handle the decay of a
81624 C...polarized tau lepton.
81625 C...Input:
81626 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
81627 C...IORIG is the position where the mother of the tau is stored;
81628 C... is 0 when the mother is not stored.
81629 C...KFORIG is the flavour of the mother of the tau;
81630 C... is 0 when the mother is not known.
81631 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
81632 C... e.g. in B hadron semileptonic decays the W propagator
81633 C... is not explicitly stored but the W code is still unambiguous.
81634 C...Output:
81635 C...NDECAY is the number of decay products in the current tau decay.
81636 C...These decay products should be added to the /PYJETS/ common block,
81637 C...in positions N+1 through N+NDECAY. For each product I you must
81638 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
81639 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
81640 
81641  SUBROUTINE pytaud(ITAU,IORIG,KFORIG,NDECAY)
81642 
81643 C...Double precision and integer declarations.
81644  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81645  IMPLICIT INTEGER(i-n)
81646  INTEGER pyk,pychge,pycomp
81647 C...Commonblocks.
81648  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
81649  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
81650  SAVE /pyjets/,/pydat1/
81651 
81652 C...Stop program if this routine is ever called.
81653 C...You should not copy these lines to your own routine.
81654  ndecay=itau+iorig+kforig
81655  WRITE(mstu(11),5000)
81656  CALL pystop(10)
81657 
81658 C...Format for error printout.
81659  5000 FORMAT(1x,'Error: you did not link your PYTAUD routine ',
81660  &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
81661  &1x,'Execution stopped!')
81662 
81663  RETURN
81664  END
81665 
81666 C*********************************************************************
81667 
81668 C...PYTIME
81669 C...Finds current date and time.
81670 C...Since this task is not standardized in Fortran 77, the routine
81671 C...is dummy, to be replaced by the user. Examples are given for
81672 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
81673 C...you do not have access to suitable routines.
81674 
81675  SUBROUTINE pytime(IDATI)
81676 
81677 C...Double precision and integer declarations.
81678  IMPLICIT DOUBLE PRECISION(a-h, o-z)
81679  IMPLICIT INTEGER(i-n)
81680  INTEGER pyk,pychge,pycomp
81681  CHARACTER*8 atime
81682 C...Local array.
81683  INTEGER idati(6),idtemp(3),ival(8)
81684 
81685 C...Example 0: if you do not have suitable routines.
81686  DO 100 j=1,6
81687  idati(j)=0
81688  100 CONTINUE
81689 
81690 C...Example 1: Fortran 90 routine.
81691 C CALL DATE_AND_TIME(VALUES=IVAL)
81692 C IDATI(1)=IVAL(1)
81693 C IDATI(2)=IVAL(2)
81694 C IDATI(3)=IVAL(3)
81695 C IDATI(4)=IVAL(5)
81696 C IDATI(5)=IVAL(6)
81697 C IDATI(6)=IVAL(7)
81698 
81699 C...Example 2: DEC Fortran 77. AIX.
81700 C CALL IDATE(IMON,IDAY,IYEAR)
81701 C IDATI(1)=IYEAR
81702 C IDATI(2)=IMON
81703 C IDATI(3)=IDAY
81704 C CALL ITIME(IHOUR,IMIN,ISEC)
81705 C IDATI(4)=IHOUR
81706 C IDATI(5)=IMIN
81707 C IDATI(6)=ISEC
81708 
81709 C...Example 3: DEC Fortran, IRIX, IRIX64.
81710 C CALL IDATE(IMON,IDAY,IYEAR)
81711 C IDATI(1)=IYEAR
81712 C IDATI(2)=IMON
81713 C IDATI(3)=IDAY
81714 C CALL TIME(ATIME)
81715 C IHOUR=0
81716 C IMIN=0
81717 C ISEC=0
81718 C READ(ATIME(1:2),'(I2)') IHOUR
81719 C READ(ATIME(4:5),'(I2)') IMIN
81720 C READ(ATIME(7:8),'(I2)') ISEC
81721 C IDATI(4)=IHOUR
81722 C IDATI(5)=IMIN
81723 C IDATI(6)=ISEC
81724 
81725 C...Example 4: GNU LINUX libU77, SunOS.
81726 C CALL IDATE(IDTEMP)
81727 C IDATI(1)=IDTEMP(3)
81728 C IDATI(2)=IDTEMP(2)
81729 C IDATI(3)=IDTEMP(1)
81730 C CALL ITIME(IDTEMP)
81731 C IDATI(4)=IDTEMP(1)
81732 C IDATI(5)=IDTEMP(2)
81733 C IDATI(6)=IDTEMP(3)
81734 
81735 C...Common code to ensure right century.
81736  idati(1)=2000+mod(idati(1),100)
81737 
81738  RETURN
81739  END