]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/pythia6115dpm3.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Small fix Sarah
[u/mrichter/AliRoot.git] / DPMJET / pythia6115dpm3.f
CommitLineData
9aaba0d6 1C*********************************************************************
2C*********************************************************************
3C* **
4C* March 1997 **
5C* **
6C* The Lund Monte Carlo for Hadronic Processes **
7C* **
8C* PYTHIA version 6.1 **
9C* **
10C* Torbjorn Sjostrand **
11C* Department of Theoretical Physics 2 **
12C* Lund University **
13C* Solvegatan 14A, S-223 62 Lund, Sweden **
14C* phone +46 - 46 - 222 48 16 **
15C* E-mail torbjorn@thep.lu.se **
16C* **
17C* SUSY parts by **
18C* Stephen Mrenna **
19C* Argonne National Laboratory **
20C* 9700 South Cass Avenue, Argonne, IL 60439, USA **
21C* phone + 1 - 630 - 252 - 7615 **
22C* E-mail mrenna@hep.anl.gov **
23C* **
24C* Several parts are written by Hans-Uno Bengtsson **
25C* PYSHOW is written together with Mats Bengtsson **
26C* advanced popcorn baryon production written by Patrik Eden **
27C* CTEQ 3 parton distributions are by the CTEQ collaboration **
28C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
29C* SaS photon parton distributions together with Gerhard Schuler **
30C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
31C* MSSM Higgs mass calculation code by M. Carena, **
32C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
33C* PYGAUS adapted from CERN library (K.S. Kolbig) **
34C* **
35C* The latest program version and documentation is found on WWW **
36C* http://www.thep.lu.se/tf2/staff/torbjorn/Pythia.html **
37C* **
38C* Copyright Torbjorn Sjostrand, Lund 1997 **
39C* **
40C*********************************************************************
41C*********************************************************************
42C *
43C List of subprograms in order of appearance, with main purpose *
44C (S = subroutine, F = function, B = block data) *
45C *
46C B PYDATA to contain all default values *
47C S PYTEST to test the proper functioning of the package *
48C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
49C *
50C S PYINIT to administer the initialization procedure *
51C S PYEVNT to administer the generation of an event *
52C S PYSTAT to print cross-section and other information *
53C S PYINRE to initialize treatment of resonances *
54C S PYINBM to read in beam, target and frame choices *
55C S PYINKI to initialize kinematics of incoming particles *
56C S PYINPR to set up the selection of included processes *
57C S PYXTOT to give total, elastic and diffractive cross-sect. *
58C S PYMAXI to find differential cross-section maxima *
59C S PYPILE to select multiplicity of pileup events *
60C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
61C S PYRAND to select subprocess and kinematics for event *
62C S PYSCAT to set up kinematics and colour flow of event *
63C S PYSSPA to simulate initial state spacelike showers *
64C S PYRESD to perform resonance decays *
65C S PYMULT to generate multiple interactions *
66C S PYREMN to add on target remnants *
67C S PYDIFF to set up kinematics for diffractive events *
68C S PYDOCU to compute cross-sections and handle documentation *
69C S PYFRAM to perform boosts between different frames *
70C S PYWIDT to calculate full and partial widths of resonances *
71C S PYOFSH to calculate partial width into off-shell channels *
72C S PYRECO to handle colour reconnection in W+W- events *
73C S PYKLIM to calculate borders of allowed kinematical region *
74C S PYKMAP to construct value of kinematical variable *
75C S PYSIGH to calculate differential cross-sections *
76C S PYPDFU to evaluate parton distributions *
77C S PYPDFL to evaluate parton distributions at low x and Q^2 *
78C S PYPDEL to evaluate electron parton distributions *
79C S PYPDGA to evaluate photon parton distributions (generic) *
80C S PYGGAM to evaluate photon parton distributions (SaS sets) *
81C S PYGVMD to evaluate VMD part of photon parton distributions *
82C S PYGANO to evaluate anomalous part of photon pdf's *
83C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
84C S PYGDIR to evaluate direct contribution to photon pdf's *
85C S PYPDPI to evaluate pion parton distributions *
86C S PYPDPR to evaluate proton parton distributions *
87C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
88C S PYGRVL to evaluate the GRV 94L pronton parton distributions *
89C S PYGRVM to evaluate the GRV 94M pronton parton distributions *
90C S PYGRVD to evaluate the GRV 94D pronton parton distributions *
91C F PYGRVV auxiliary to the PYGRV* routines *
92C F PYGRVW auxiliary to the PYGRV* routines *
93C F PYGRVS auxiliary to the PYGRV* routines *
94C F PYHFTH to evaluate threshold factor for heavy flavour *
95C S PYSPLI to find flavours left in hadron when one removed *
96C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
97C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
98C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
99C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
100C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
101C *
102C S PYMSIN to initialize the supersymmetry simulation *
103C S PYAPPS to determine MSSM parameters from SUGRA input *
104C F PYRNMQ to determine running quark masses *
105C F PYRNMT to determine running top mass *
106C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
107C S PYINOM to calculate neutralino/chargino mass eigenstates *
108C F PYRNM3 to determine running M3, gluino mass *
109C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
110C S PYHGGM to determine Higgs mass spectrum *
111C S PYSUBH to determine Higgs masses in the MSSM *
112C S PYPOLE to determine Higgs masses in the MSSM *
113C S PYVACU to determine Higgs masses in the MSSM *
114C S PYRGHM auxiliary to PYVACU *
115C S PYGFXX auxiliary to PYRGHM *
116C F PYFINT auxiliary to PYVACU *
117C F PYFISB auxiliary to PYFINT *
118C S PYSFDC to calculate sfermion decay partial widths *
119C S PYGLUI to calculate gluino decay partial widths *
120C S PYTBBN to calculate 3-body decay of gluino to neutralino *
121C S PYTBBC to calculate 3-body decay of gluino to chargino *
122C S PYNJDC to calculate neutralino decay partial widths *
123C S PYCJDC to calculate chargino decay partial widths *
124C F PYXXZ5 auxiliary for neutralino 3-body decay *
125C F PYXXW5 auxiliary for ino charge change 3-body decay *
126C F PYXXGA auxiliary for ino -> ino + gamma decay *
127C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
128C F PYX2XH auxiliary for ino -> ino + Higgs decay *
129C F PYXXZ2 auxiliary for chargino 3-body decay *
130C S PYHEXT to calculate non-SM Higgs decay partial widths *
131C F PYH2XX auxiliary for H -> ino + ino decay *
132C F PYGAUS to perform Gaussian integration *
133C F PYSIMP to perform Simpson integration *
134C F PYLAMF to evaluate the lambda kinematics function *
135C S PYTBDY to perform 3-body decay of gauginos *
136C *
137C S PY1ENT to fill one entry (= parton or particle) *
138C S PY2ENT to fill two entries *
139C S PY3ENT to fill three entries *
140C S PY4ENT to fill four entries *
141C S PYJOIN to connect entries with colour flow information *
142C S PYGIVE to fill (or query) commonblock variables *
143C S PYEXEC to administrate fragmentation and decay chain *
144C S PYPREP to rearrange showered partons along strings *
145C S PYSTRF to do string fragmentation of jet system *
146C S PYINDF to do independent fragmentation of one or many jets *
147C S PYDECY to do the decay of a particle *
148C S PYDCYK to select parton and hadron flavours in decays *
149C S PYKFDI to select parton and hadron flavours in fragm *
150C S PYNMES to select number of popcorn mesons *
151C S PYKFIN to calculate falvour prod. ratios from input params. *
152C S PYPTDI to select transverse momenta in fragm *
153C S PYZDIS to select longitudinal scaling variable in fragm *
154C S PYSHOW to do timelike parton shower evolution *
155C S PYBOEI to include Bose-Einstein effects (crudely) *
156C F PYMASS to give the mass of a particle or parton *
157C S PYNAME to give the name of a particle or parton *
158C F PYCHGE to give three times the electric charge *
159C F PYCOMP to compress standard KF flavour code to internal KC *
160C S PYERRM to write error messages and abort faulty run *
161C F PYALEM to give the alpha_electromagnetic value *
162C F PYALPS to give the alpha_strong value *
163C F PYANGL to give the angle from known x and y components *
164C F PYR to provide a random number generator *
165C S PYRGET to save the state of the random number generator *
166C S PYRSET to set the state of the random number generator *
167C S PYROBO to rotate and/or boost an event *
168C S PYEDIT to remove unwanted entries from record *
169C S PYLIST to list event record or particle data *
170C S PYLOGO to write a logo *
171C S PYUPDA to update particle data *
172C F PYK to provide integer-valued event information *
173C F PYP to provide real-valued event information *
174C S PYSPHE to perform sphericity analysis *
175C S PYTHRU to perform thrust analysis *
176C S PYCLUS to perform three-dimensional cluster analysis *
177C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
178C S PYJMAS to give high and low jet mass of event *
179C S PYFOWO to give Fox-Wolfram moments *
180C S PYTABU to analyze events, with tabular output *
181C *
182C S PYEEVT to administrate the generation of an e+e- event *
183C S PYXTEE to give the total cross-section at given CM energy *
184C S PYRADK to generate initial state photon radiation *
185C S PYXKFL to select flavour of primary qqbar pair *
186C S PYXJET to select (matrix element) jet multiplicity *
187C S PYX3JT to select kinematics of three-jet event *
188C S PYX4JT to select kinematics of four-jet event *
189C S PYXDIF to select angular orientation of event *
190C S PYONIA to perform generation of onium decay to gluons *
191C *
192C S PYBOOK to book a histogram *
193C S PYFILL to fill an entry in a histogram *
194C S PYFACT to multiply histogram contents by a factor *
195C S PYOPER to perform operations between histograms *
196C S PYHIST to print and reset all histograms *
197C S PYPLOT to print a single histogram *
198C S PYNULL to reset contents of a single histogram *
199C S PYDUMP to dump histogram contents onto a file *
200C *
201C S PYKCUT dummy routine for user kinematical cuts *
202C S PYEVWT dummy routine for weighting events *
203C S PYUPIN dummy routine to initialize a user process *
204C S PYUPEV dummy routine to generate a user process event *
205C S PDFSET dummy routine to be removed when using PDFLIB *
206C S STRUCTM dummy routine to be removed when using PDFLIB *
207C S PYTAUD dummy routine for interface to tau decay libraries *
208C S PYTIME dummy routine for giving date and time *
209C *
210C*********************************************************************
211
212*$ CREATE PYDATA.FOR
213*COPY PYDATA
214C...PYDATA
215C...Default values for switches and parameters,
216C...and particle, decay and process data.
217
218 BLOCK DATA PYDATA
219
220C...Double precision and integer declarations.
221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
222 INTEGER PYK,PYCHGE,PYCOMP
223C...Commonblocks.
224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
225 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
226 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
227 COMMON/PYDAT4/CHAF(500,2)
228 CHARACTER CHAF*16
229 COMMON/PYDATR/MRPY(6),RRPY(100)
230 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
231 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
232 COMMON/PYINT1/MINT(400),VINT(400)
233 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
234 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
235 COMMON/PYINT4/MWID(500),WIDS(500,5)
236 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
237 COMMON/PYINT6/PROC(0:500)
238 CHARACTER PROC*28
239 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
240 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
241 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
242 &SFMIX(16,4)
243 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
244 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
245 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
246 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
247
248C...PYDAT1, containing status codes and most parameters.
249 DATA MSTU/
250 & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2,
251 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
252 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
253 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
254 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
255 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
256 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
257 7 30*0,
258 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
259 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
260 & 80*0/
261 DATA PARU/
262 & 3.141592653589793D0, 6.283185307179586D0,
263 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
264 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
265 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
266 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
267 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
268 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
269 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
270 6 40*0D0,
271 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
272 & 0D0, 0D0, 0D0, 0D0, 0D0,
273 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
274 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
275 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
276 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
277 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
278 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
279 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
280 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
281 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
282 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
283 DATA MSTJ/
284 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
285 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
286 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
287 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
288 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
289 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
290 6 40*0,
291 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
292 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
293 2 80*0/
294 DATA PARJ/
295 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
296 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
297 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
298 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
299 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0,2.5D0,0.6D0,0D0,
300 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
301 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
302 5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
303 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
304 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
305 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0, 0D0,
306 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
307 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
308 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
309 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
310 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
311 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
312 4 60*0D0/
313
314C...PYDAT2, with particle data and flavour treatment parameters.
315 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
316 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3,
317 &8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,3*0,4,3*3,
318 &6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,
319 &3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,
320 &3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,
321 &-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,
322 &3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,
323 &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
324 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
325 &3*0,-1,4*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
326 &-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,
327 &6*1,6*0,2*1,165*0/
328 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
329 &11*0,1,2*0,1,26*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,12*1,3*0,
330 &102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,
331 &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
332 DATA (KCHG(I,4),I= 1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
333 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
334 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
335 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
336 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
337 &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
338 &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
339 &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
340 &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
341 &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
342 &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
343 &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
344 &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
345 &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
346 &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
347 &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
348 &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
349 &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
350 &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
351 &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
352 DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
353 &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
354 &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
355 &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
356 &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
357 &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
358 DATA (PMAS(I,1),I= 1, 214)/0.0099D0,0.0056D0,0.199D0,1.35D0,
359 &5D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,
360 &400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
361 &3*300D0,350D0,200D0,5000D0,10*0D0,3*100D0,3*200D0,26*0D0,1D0,2D0,
362 &5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,0.49767D0,0D0,0.13957D0,
363 &0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,1.275D0,2*0.49767D0,
364 &0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,0D0,0.95777D0,
365 &1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,2.0067D0,2.46D0,
366 &1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,3.09688D0,3.5562D0,
367 &5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,5.3693D0,
368 &5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,9.9132D0,
369 &0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,0.93957D0,1.233D0,
370 &0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
371 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
372 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
373 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
374 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
375 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
376 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
377 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0/
378 DATA (PMAS(I,1),I= 215, 500)/5.641D0,5.84D0,7.00575D0,5.38897D0,
379 &5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,5.84D0,7.00575D0,5.56725D0,
380 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
381 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
382 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
383 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
384 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
385 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
386 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
387 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
388 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
389 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
390 &4*400D0,163*0D0/
391 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.4D0,16*0D0,2.47833D0,
392 &2.069D0,0.00295D0,6*0D0,14.67788D0,0D0,16.79392D0,8.45231D0,
393 &4.93534D0,5.80468D0,19.1898D0,0.39162D0,417.35283D0,62*0D0,
394 &0.151D0,0.107D0,3*0D0,0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,
395 &2*0D0,0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0D0,0.0002D0,
396 &0.00443D0,0.076D0,2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,
397 &0.0013D0,0D0,0.002D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,
398 &2*0D0,0.02D0,4*0D0,0.12D0,4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,
399 &0.0394D0,4*0D0,0.036D0,0D0,0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,
400 &74*0D0,0.06D0,0.142D0,0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,
401 &0.287D0,0.09D0,0.25D0,0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,
402 &0D0,0.014D0,0.01D0,8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,
403 &0.053D0,3*0.05D0,0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,
404 &1D0,0D0,1D0,0D0,2.60511D0,2.60839D0,0.42904D0,0.41921D0,163*0D0/
405 DATA (PMAS(I,3),I= 1, 500)/5*0D0,14D0,16*0D0,24.78326D0,
406 &20.69D0,0.02954D0,6*0D0,146.77876D0,0D0,167.93924D0,84.52308D0,
407 &49.35344D0,58.04675D0,191.89803D0,3.91624D0,4173.5283D0,62*0D0,
408 &0.4D0,0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,
409 &0.12D0,0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
410 &2*0D0,0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,
411 &2*0D0,0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,
412 &3*0D0,2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,
413 &0.05D0,0D0,0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,
414 &0.4D0,0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,
415 &0.08D0,0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,
416 &2*0.3D0,0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,
417 &3*0D0,19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,
418 &0.00001D0,26.05109D0,26.08388D0,4.29043D0,4.19206D0,163*0D0/
419 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
420 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
421 &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
422 &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
423 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
424 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
425 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
426 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
427 DATA PARF/
428 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
429 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
430 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
431 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
432 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
433 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
434 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
435 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
436 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
437 9 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
438 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
439 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
440 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
441 3 60*0D0,
442 4 0.2D0, 0.5D0, 8*0D0,
443 5 1800*0D0/
444 DATA ((VCKM(I,J),J=1,4),I=1,4)/
445 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
446 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
447 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
448 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
449
450C...PYDAT3, with particle decay parameters and data.
451 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
452 &7*1,10*0,2*1,0,3*1,26*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,12*1,
453 &0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,
454 &2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,
455 &1,0,4*1,163*0/
456 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,
457 &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,
458 &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,
459 &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,
460 &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,
461 &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,
462 &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,
463 &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,
464 &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,
465 &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,
466 &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,
467 &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,
468 &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,
469 &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,
470 &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,
471 &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,
472 &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,
473 &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,
474 &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,
475 &2493,2496,163*0/
476 DATA (MDCY(I,3),I= 1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,
477 &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,2*5,0,20,24,18,
478 &26*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,11,0,6,11,6,
479 &63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,0,
480 &1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,
481 &4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,
482 &1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,
483 &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,
484 &15,0,2*4,3,2,163*0/
485 DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
486 &7*1,-1,1,-1,12*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
487 &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,2*-1,
488 &6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,197*1,2*-1,2*1,-1,20*1,
489 &2*-1,6*1,2*-1,7*1,-1,3*1,-1,3*1,5*-1,3*1,-1,1,-1,6*1,2*-1,6*1,
490 &2*-1,1892*1,1503*0/
491 DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,
492 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
493 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,
494 &16*32,27*0,62*53,18*0,62*53,9*0,18*53,3*32,0,6*32,3*0,2*32,3*0,
495 &2*32,7*0,8*32,12*0,16*32,6*0,8*32,8*0,12,2*42,2*11,9*42,0,2,3,
496 &15*0,4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,
497 &3*0,1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,
498 &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,
499 &3*13,2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,
500 &4*32,2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,
501 &2*42,2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
502 &2*42,2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,
503 &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,
504 &4*32,2*4,5*0,828*53,1515*0/
505 DATA (BRAT(I) ,I= 1, 418)/43*0D0,0.00003D0,0.00177D0,0.9982D0,
506 &33*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,0.003D0,
507 &0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,0.0071D0,
508 &0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,0.0034D0,0.08D0,
509 &0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,0.0067D0,0.0005D0,
510 &0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,0.00075D0,0.0001D0,
511 &0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,0.0004D0,0.0001D0,
512 &2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,0.00025D0,35*0D0,
513 &0.15403D0,0.11945D0,0.15402D0,0.11931D0,0.15215D0,3*0D0,
514 &0.03357D0,0.0668D0,0.03357D0,0.0668D0,0.0335D0,0.0668D0,2*0D0,
515 &0.32139D0,0.0165D0,2*0D0,0.0165D0,0.32067D0,2*0D0,0.00001D0,
516 &0.00059D0,6*0D0,2*0.10814D0,0.10806D0,3*0D0,0.00031D0,0.04438D0,
517 &0.88031D0,4*0D0,0.0002D0,0.05531D0,0D0,0.01838D0,0.00071D0,0D0,
518 &0.00009D0,0.00032D0,62*0D0,0.14449D0,0.11223D0,0.14449D0,
519 &0.11223D0,0.14443D0,0.05782D0,2*0D0,0.03172D0,0.06305D0,
520 &0.03172D0,0.06305D0,0.03172D0,0.06305D0,8*0D0,0.24928D0,0.0128D0,
521 &0.00001D0,0D0,0.0128D0,0.24882D0,0.00039D0,0D0,0.00001D0,
522 &0.00046D0,0.22153D0,5*0D0,2*0.08464D0,0.08463D0,7*0D0,0.00005D0,
523 &0.00097D0,5*0D0,0.00007D0,0D0,0.00049D0,0.00001D0,0.00006D0,
524 &0.30591D0,0.68863D0,0D0,0.0038D0,66*0D0,0.00008D0,0.00167D0/
525 DATA (BRAT(I) ,I= 419, 722)/5*0D0,0.00013D0,0D0,0.00294D0,
526 &0.00001D0,3*0D0,0.99517D0,63*0D0,0.00002D0,0.07231D0,2*0D0,
527 &0.00001D0,0.00269D0,0D0,0.92497D0,18*0D0,0.0024D0,0.99483D0,
528 &0.00278D0,1D0,3*0.21511D0,0.21478D0,2*0D0,2*0.06995D0,2*0D0,1D0,
529 &3*0D0,0.95D0,0.05D0,3*0D0,4*0.25D0,16*0D0,4*0.25D0,20*0D0,1D0,
530 &17*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,
531 &0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,0.998739D0,
532 &0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,0.144D0,
533 &0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,
534 &2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,
535 &0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,
536 &0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,
537 &0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,
538 &0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,
539 &2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,
540 &0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,
541 &0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,
542 &0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,
543 &0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,
544 &0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0,0.48947D0/
545 DATA (BRAT(I) ,I= 723, 897)/0.34D0,3*0.043D0,0.027D0,0.0126D0,
546 &0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,
547 &2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,
548 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,
549 &0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,
550 &0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,
551 &0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,
552 &0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,
553 &0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,
554 &0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
555 &0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,
556 &2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,
557 &3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,
558 &0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,
559 &0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,
560 &0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,
561 &0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,
562 &0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,
563 &0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
564 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
565 DATA (BRAT(I) ,I= 898,1063)/0.079D0,0.095D0,0.052D0,0.0078D0,
566 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
567 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
568 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
569 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
570 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
571 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
572 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
573 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
574 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
575 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
576 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
577 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
578 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
579 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
580 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
581 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
582 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
583 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
584 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
585 DATA (BRAT(I) ,I=1064,1254)/0.122D0,0.006D0,0.012D0,0.035D0,
586 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
587 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
588 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
589 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
590 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
591 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
592 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
593 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
594 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
595 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
596 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
597 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
598 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
599 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
600 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
601 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
602 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
603 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
604 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
605 DATA (BRAT(I) ,I=1255,1447)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
606 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
607 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
608 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
609 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
610 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
611 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
612 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
613 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
614 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
615 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
616 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
617 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
618 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
619 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
620 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
621 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
622 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
623 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
624 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
625 DATA (BRAT(I) ,I=1448,1648)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
626 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
627 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
628 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
629 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
630 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
631 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
632 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
633 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
634 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
635 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
636 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
637 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
638 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
639 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
640 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
641 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
642 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
643 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
644 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
645 DATA (BRAT(I) ,I=1649,4000)/0.008D0,0.024D0,0.425D0,0.02D0,
646 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,827*0D0,0.8516D0,
647 &0.00539D0,0.04483D0,0.09819D0,0.85053D0,0.02152D0,0.02989D0,
648 &0.09806D0,0.29439D0,0.10943D0,0.59618D0,0.38983D0,0.61017D0,
649 &1503*0D0/
650 DATA (KFDP(I,1),I= 1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,
651 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
652 &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,
653 &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,
654 &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,
655 &1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,
656 &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,
657 &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,
658 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
659 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,
660 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
661 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
662 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
663 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
664 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
665 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
666 &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,
667 &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,
668 &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
669 &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/
670 DATA (KFDP(I,1),I= 376, 606)/1000003,-1000003,1000004,2000004,
671 &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
672 &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
673 &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
674 &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
675 &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,
676 &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,
677 &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,
678 &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,
679 &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
680 &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
681 &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
682 &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
683 &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
684 &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,
685 &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,
686 &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,
687 &2,3,4,5,6,11,13,15,4,5,11,13,15,2*4,-11,-13,-15,2*24,2*52,1,2,3,
688 &4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,2*52,4*-1,4*-3,4*-5,4*-7,
689 &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/
690 DATA (KFDP(I,1),I= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,
691 &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,
692 &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,
693 &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,
694 &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,
695 &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,
696 &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,
697 &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,
698 &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,
699 &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,
700 &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,
701 &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
702 &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
703 &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
704 &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,
705 &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,
706 &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,
707 &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,
708 &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,
709 &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/
710 DATA (KFDP(I,1),I=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,
711 &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,
712 &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,
713 &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,
714 &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,
715 &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,
716 &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,
717 &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,
718 &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,
719 &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,
720 &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,
721 &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,
722 &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,
723 &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,
724 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,
725 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,
726 &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,
727 &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
728 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
729 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/
730 DATA (KFDP(I,1),I=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
731 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
732 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
733 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
734 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
735 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
736 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
737 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
738 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
739 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
740 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
741 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
742 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
743 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
744 &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
745 &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
746 &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
747 &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,
748 &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,
749 &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/
750 DATA (KFDP(I,1),I=1711,1900)/1000025,1000035,1000006,2000006,
751 &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,
752 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
753 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
754 &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,
755 &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,
756 &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,
757 &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,
758 &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,
759 &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,
760 &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
761 &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,
762 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
763 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
764 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
765 &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,
766 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
767 &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,
768 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
769 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/
770 DATA (KFDP(I,1),I=1901,2095)/-1000037,1000037,-1000037,1000037,
771 &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,
772 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
773 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
774 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
775 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
776 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
777 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
778 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
779 &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,
780 &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,
781 &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,
782 &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,
783 &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,
784 &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
785 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
786 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
787 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
788 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
789 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/
790 DATA (KFDP(I,1),I=2096,2323)/2000003,-2000003,1000004,-1000004,
791 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
792 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
793 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
794 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
795 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
796 &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
797 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
798 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
799 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
800 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
801 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
802 &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
803 &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
804 &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
805 &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
806 &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
807 &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
808 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
809 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/
810 DATA (KFDP(I,1),I=2324,4000)/-1000003,-2000003,1000006,2000006,
811 &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,
812 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
813 &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
814 &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,
815 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
816 &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,
817 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
818 &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,
819 &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,
820 &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,
821 &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,
822 &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
823 &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,
824 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
825 &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,
826 &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,
827 &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,
828 &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,
829 &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/
830 DATA (KFDP(I,2),I= 1, 337)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
831 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,4*1000006,3*7,
832 &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,
833 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
834 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
835 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
836 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
837 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
838 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
839 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
840 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
841 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
842 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
843 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
844 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
845 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
846 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
847 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
848 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
849 &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/
850 DATA (KFDP(I,2),I= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,
851 &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
852 &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
853 &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
854 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
855 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
856 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
857 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
858 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
859 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
860 &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
861 &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
862 &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
863 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
864 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
865 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
866 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
867 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
868 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
869 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
870 DATA (KFDP(I,2),I= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,
871 &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,
872 &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,
873 &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
874 &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,
875 &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,
876 &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,
877 &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,
878 &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,
879 &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,
880 &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,
881 &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,
882 &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,
883 &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,
884 &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,
885 &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,
886 &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,
887 &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,
888 &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,
889 &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/
890 DATA (KFDP(I,2),I= 941,1318)/2*-15,211,213,20213,211,213,20213,
891 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
892 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
893 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,
894 &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,
895 &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,
896 &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,
897 &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,
898 &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,
899 &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,
900 &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,
901 &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,
902 &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,
903 &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,
904 &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,
905 &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,
906 &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,
907 &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,
908 &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,
909 &-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1/
910 DATA (KFDP(I,2),I=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,
911 &11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,
912 &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,
913 &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,
914 &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,
915 &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,
916 &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,
917 &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,
918 &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,
919 &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,
920 &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,
921 &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,
922 &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,
923 &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,
924 &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,
925 &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
926 &2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,2*1,4*2,2*24,2*37,2,
927 &3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37,4,5,2*6,4*5,2*-24,
928 &2*-37,5,6,2*5,4*6,2*24,2*37,6,4,11,2*12,4*11,2*-24,2*-37,12,2*11,
929 &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/
930 DATA (KFDP(I,2),I=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,
931 &4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,
932 &-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,
933 &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,
934 &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
935 &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
936 &1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
937 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
938 &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,
939 &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,
940 &2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,22,
941 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
942 &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
943 &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
944 &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
945 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
946 &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,
947 &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,
948 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,
949 &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/
950 DATA (KFDP(I,2),I=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
951 &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
952 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
953 &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,
954 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
955 &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,
956 &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,
957 &2*24,2*37,2,3,2*4,4*3,23,25,35,36,2*-24,2*-37,3,4,2*3,4*4,23,25,
958 &35,36,2*24,2*37,4,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,6,2*5,4*6,
959 &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,
960 &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,
961 &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/
962 DATA (KFDP(I,3),I= 1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,
963 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
964 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
965 &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
966 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
967 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
968 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
969 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
970 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
971 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
972 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
973 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
974 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
975 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
976 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
977 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
978 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
979 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
980 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
981 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
982 DATA (KFDP(I,3),I=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,
983 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
984 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
985 &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,
986 &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,
987 &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,
988 &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,
989 &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,
990 &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,
991 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
992 &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,
993 &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,
994 &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
995 &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
996 &-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
997 &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
998 &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,
999 &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,
1000 &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,
1001 &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/
1002 DATA (KFDP(I,3),I=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,
1003 &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,
1004 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,
1005 &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/
1006 DATA (KFDP(I,4),I= 1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,
1007 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1008 &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1009 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1010 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1011 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1012 &-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,
1013 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1014 &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,
1015 &162*81,31*0,-211,111,2450*0/
1016 DATA (KFDP(I,5),I= 1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,
1017 &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1018 &3*111,-211,111,3127*0/
1019
1020C...PYDAT4, with particle names (character strings).
1021 DATA (CHAF(I,1),I= 1, 190)/'d','u','s','c','b','t','b''','t''',
1022 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1023 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1024 &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1025 &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1026 &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',
1027 &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',
1028 &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
1029 &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',
1030 &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',
1031 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',
1032 &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',
1033 &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',
1034 &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',
1035 &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',
1036 &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',
1037 &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',
1038 &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',
1039 &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',
1040 &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/
1041 DATA (CHAF(I,1),I= 191, 317)/'Sigma*_c+','Sigma_c++',
1042 &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',
1043 &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',
1044 &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',
1045 &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',
1046 &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1047 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1048 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1049 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1050 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1051 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1052 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1053 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1054 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1055 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1056 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1057 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1058 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1059 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1060 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/
1061 DATA (CHAF(I,1),I= 318, 500)/'~chi_30','~chi_40','~chi_2+',
1062 &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',
1063 &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',
1064 &'nu*_e0',163*' '/
1065 DATA (CHAF(I,2),I= 1, 206)/'dbar','ubar','sbar','cbar','bbar',
1066 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1067 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1068 &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1069 &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',
1070 &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',
1071 &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',
1072 &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',
1073 &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',
1074 &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',
1075 &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',
1076 &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',
1077 &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',
1078 &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',
1079 &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',
1080 &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',
1081 &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',
1082 &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',
1083 &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1084 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/
1085 DATA (CHAF(I,2),I= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',
1086 &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',
1087 &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',
1088 &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',
1089 &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',
1090 &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',
1091 &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',
1092 &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',
1093 &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',
1094 &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',
1095 &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1096 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1097 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1098 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1099 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1100 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1101 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1102 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1103 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1104 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/
1105 DATA (CHAF(I,2),I= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',
1106 &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1107 &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1108
1109C...PYDATR, with initial values for the random number generator.
1110 DATA MRPY/19780503,0,0,97,33,0/
1111
1112C...Default values for allowed processes and kinematics constraints.
1113 DATA MSEL/1/
1114 DATA MSUB/500*0/
1115 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1116 &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,
1117 &6*1,4*0,4*1,16*0/
1118 DATA CKIN/
1119 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1120 & 1.0D0, -10D0, 10D0, -10D0, 10D0,
1121 1 -10D0, 10D0, -10D0, 10D0, -10D0,
1122 1 10D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1123 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1124 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1125 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1126 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1127 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1128 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1129 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1130 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1131 6 140*0D0/
1132
1133C...Default values for main switches and parameters. Reset information.
1134 DATA (MSTP(I),I=1,100)/
1135 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1136 1 1, 0, 1, 0, 5, 0, 0, 0, 0, 0,
1137 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1138 3 1, 2, 0, 1, 0, 2, 1, 5, 2, 0,
1139 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1140 5 4, 1, 3, 1, 5, 1, 1, 6, 1, 7,
1141 6 1, 3, 2, 2, 1, 1, 2, 0, 0, 0,
1142 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1143 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
1144 9 1, 4, 1, 2, 0, 0, 0, 0, 0, 0/
1145 DATA (MSTP(I),I=101,200)/
1146 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1147 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1148 2 0, 1, 2, 1, 1, 50, 0, 0, 10, 0,
1149 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1150 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1151 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1152 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1153 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1154 8 6, 115, 1998, 01, 27, 0, 0, 0, 0, 0,
1155 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1156 DATA (PARP(I),I=1,100)/
1157 & 0.25D0, 10D0, 8*0D0,
1158 1 0D0, 0D0, 1.0D0, 0.01D0, 0.6D0, 1.0D0, 1.0D0, 3*0D0,
1159 2 10*0D0,
1160 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1161 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
1162 5 1.0D0, 9*0D0,
1163 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1164 7 4.0D0, 0.25D0, 8*0D0,
1165 8 1.40D0,1.55D0,0.5D0, 0.2D0,0.33D0,0.66D0, 0.7D0, 0.5D0,2*0D0,
1166 9 0.44D0,0.20D0,2.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,0.44D0,2.0D0/
1167 DATA (PARP(I),I=101,200)/
1168 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0,
1169 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1170 2 1.0D0, 0.4D0, 8*0D0,
1171 3 0.01D0, 9*0D0,
1172 4 0.33333D0, 82D0, 1D0, 4D0, 200D0, 5*0D0,
1173 5 0D0, 0D0, 0D0, 0D0, 6*0D0,
1174 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 6*0D0,
1175 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1176 8 20*0D0/
1177 DATA MSTI/200*0/
1178 DATA PARI/200*0D0/
1179 DATA MINT/400*0/
1180 DATA VINT/400*0D0/
1181
1182C...Constants for the generation of the various processes.
1183 DATA (ISET(I),I=1,100)/
1184 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1185 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1186 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1187 3 2, -1, 2, 2, 2, 2, -1, -1, -1, -1,
1188 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1189 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1190 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1191 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1192 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1193 9 0, 0, 0, 0, 0, 9, -2, -2, -2, -2/
1194 DATA (ISET(I),I=101,200)/
1195 & -1, 1, 1, -2, -2, 2, 2, 2, -2, 2,
1196 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1197 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1198 3 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1199 4 1, 1, 1, 1, 1, -2, 1, 1, 1, -2,
1200 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1201 6 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1202 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1203 8 5, 5, -2, -2, -2, 5, 5, -2, -2, -2,
1204 9 1, 1, 1, 2, -2, -2, -2, -2, -2, -2/
1205 DATA (ISET(I),I=201,300)/
1206 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1207 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1208 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1209 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1210 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1211 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1212 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1213 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1214 8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
1215 9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
1216 DATA (ISET(I),I=301,500)/200*-2/
1217 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1218 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1219 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1220 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1221 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1222 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1223 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1224 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1225 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1226 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1227 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1228 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1229 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1230 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1231 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1232 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1233 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1234 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1235 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1236 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1237 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1238 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1239 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1240 & 23, 0, 25, 0, 25, 0, 0, 0, 0, 0,
1241 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1242 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1243 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1244 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1245 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1246 3 23, 5, 0, 0, 0, 0, 0, 0, 0, 0,
1247 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1248 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0,
1249 4 0, 0, 4000001, 0, 4000002, 0, 38, 0, 0, 0/
1250 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1251 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1252 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1253 6 6, 37, 39, 0, 39, 39, 39, 39, 11, 0,
1254 6 11, 0, 0, 4000001, 0, 4000002, 0, 0, 0, 0,
1255 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1256 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1257 8 35, 6, 35, 6, 0, 0, 0, 0, 0, 0,
1258 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0,
1259 9 54, 0, 55, 0, 56, 0, 11, 0, 0, 0,
1260 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1261 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1262 & 1000011, 1000011, 2000011, 2000011, 1000011,
1263 & 2000011, 1000013, 1000013, 2000013, 2000013,
1264 & 1000013, 2000013, 1000015, 1000015, 2000015,
1265 & 2000015, 1000015, 2000015, 1000011, 1000012,
1266 1 1000015, 1000016, 2000015, 1000016, 1000012,
1267 1 1000012, 1000016, 1000016, 0, 0,
1268 1 1000022, 1000022, 1000023, 1000023, 1000025,
1269 1 1000025, 1000035, 1000035, 1000022, 1000023,
1270 2 1000022, 1000025, 1000022, 1000035, 1000023,
1271 2 1000025, 1000023, 1000035, 1000025, 1000035,
1272 2 1000024, 1000024, 1000037, 1000037, 1000024,
1273 2 1000037, 1000022, 1000024, 1000023, 1000024,
1274 3 1000025, 1000024, 1000035, 1000024, 1000022,
1275 3 1000037, 1000023, 1000037, 1000025, 1000037,
1276 3 1000035, 1000037, 1000021, 1000022, 1000021,
1277 3 1000023, 1000021, 1000025, 1000021, 1000035/
1278 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1279 4 1000021, 1000024, 1000021, 1000037, 1000021,
1280 4 1000021, 1000021, 1000021, 0, 0,
1281 4 1000002, 1000022, 2000002, 1000022, 1000002,
1282 4 1000023, 2000002, 1000023, 1000002, 1000025,
1283 5 2000002, 1000025, 1000002, 1000035, 2000002,
1284 5 1000035, 1000001, 1000024, 2000005, 1000024,
1285 5 1000001, 1000037, 2000005, 1000037, 1000002,
1286 5 1000021, 2000002, 1000021, 0, 0,
1287 6 1000006, 1000006, 2000006, 2000006, 1000006,
1288 6 2000006, 1000006, 1000006, 2000006, 2000006,
1289 6 0, 0, 0, 0, 0,
1290 6 0, 0, 0, 0, 0,
1291 7 1000002, 1000002, 2000002, 2000002, 1000002,
1292 7 2000002, 1000002, 1000002, 2000002, 2000002,
1293 7 1000002, 2000002, 1000002, 1000002, 2000002,
1294 7 2000002, 1000002, 1000002, 2000002, 2000002/
1295 DATA ((KFPR(I,J),J=1,2),I=281,500)/440*0/
1296 DATA COEF/10000*0D0/
1297 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1298 &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,
1299 &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,
1300 &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,
1301 &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,
1302 &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,
1303 &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,
1304 &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,
1305 &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,
1306 &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,
1307 &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/
1308
1309C...Treatment of resonances.
1310 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1311 &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1312
1313C...Character constants: name of processes.
1314 DATA PROC(0)/ 'All included subprocesses '/
1315 DATA (PROC(I),I=1,20)/
1316 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1317 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1318 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1319 &' ', 'W+ + W- -> h0 ',
1320 &' ', 'f + f'' -> f + f'' (QFD) ',
1321 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1322 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1323 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1324 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1325 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1326 DATA (PROC(I),I=21,40)/
1327 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1328 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1329 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1330 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1331 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1332 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1333 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1334 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1335 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1336 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1337 DATA (PROC(I),I=41,60)/
1338 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1339 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1340 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1341 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1342 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1343 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1344 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1345 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1346 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1347 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1348 DATA (PROC(I),I=61,80)/
1349 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1350 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1351 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1352 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1353 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1354 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1355 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1356 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1357 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1358 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1359 DATA (PROC(I),I=81,100)/
1360 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1361 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1362 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1363 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1364 8'g + g -> chi_2c + g ', ' ',
1365 9'Elastic scattering ', 'Single diffractive (XB) ',
1366 9'Single diffractive (AX) ', 'Double diffractive ',
1367 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1368 9' ', ' ',
1369 9' ', ' '/
1370 DATA (PROC(I),I=101,120)/
1371 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1372 &'gamma + gamma -> h0 ', ' ',
1373 &' ', 'g + g -> J/Psi + gamma ',
1374 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1375 &' ', 'f + fbar -> gamma + h0 ',
1376 1'f + fbar -> g + h0 ', 'q + g -> q + h0 ',
1377 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1378 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1379 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1380 1' ', ' '/
1381 DATA (PROC(I),I=121,140)/
1382 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1383 2'f + f'' -> f + f'' + h0 ',
1384 2'f + f'' -> f" + f"'' + h0 ',
1385 2' ', ' ',
1386 2' ', ' ',
1387 2' ', ' ',
1388 3'g + g -> Z0 + q + qbar ', ' ',
1389 3' ', ' ',
1390 3' ', ' ',
1391 3' ', ' ',
1392 3' ', ' '/
1393 DATA (PROC(I),I=141,160)/
1394 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1395 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1396 4'q + l -> LQ ', ' ',
1397 4'd + g -> d* ', 'u + g -> u* ',
1398 4'g + g -> eta_techni ', ' ',
1399 5'f + fbar -> H0 ', 'g + g -> H0 ',
1400 5'gamma + gamma -> H0 ', ' ',
1401 5' ', 'f + fbar -> A0 ',
1402 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1403 5' ', ' '/
1404 DATA (PROC(I),I=161,180)/
1405 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1406 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1407 6'f + fbar -> f'' + fbar'' (g/Z)',
1408 6'f +fbar'' -> f" + fbar"'' (W) ',
1409 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1410 6' ', ' ',
1411 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1412 7'f + f'' -> f + f'' + H0 ',
1413 7'f + f'' -> f" + f"'' + H0 ',
1414 7' ', 'f + fbar -> Z0 + A0 ',
1415 7'f + fbar'' -> W+/- + A0 ',
1416 7'f + f'' -> f + f'' + A0 ',
1417 7'f + f'' -> f" + f"'' + A0 ',
1418 7' '/
1419 DATA (PROC(I),I=181,200)/
1420 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1421 8' ', ' ',
1422 8' ', 'g + g -> Q + Qbar + A0 ',
1423 8'q + qbar -> Q + Qbar + A0 ', ' ',
1424 8' ', ' ',
1425 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ',
1426 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (technic)',
1427 9' ', ' ',
1428 9' ', ' ',
1429 9' ', ' '/
1430 DATA (PROC(I),I=201,220)/
1431 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1432 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1433 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1434 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1435 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1436 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1437 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1438 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1439 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1440 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1441 DATA (PROC(I),I=221,240)/
1442 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1443 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1444 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1445 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1446 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1447 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1448 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1449 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1450 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1451 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1452 DATA (PROC(I),I=241,260)/
1453 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1454 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1455 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1456 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1457 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1458 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1459 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1460 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1461 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1462 5'qj + g -> ~qj_R + ~g ', ' '/
1463 DATA (PROC(I),I=261,280)/
1464 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1465 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1466 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1467 6' ', ' ',
1468 6' ', ' ',
1469 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1470 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1471 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1472 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1473 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar '/
1474 DATA (PROC(I),I=281,500)/220*' '/
1475
1476C...Cross sections and slope offsets.
1477 DATA SIGT/294*0D0/
1478
1479C...Supersymmetry switches and parameters.
1480 DATA IMSS/0,
1481 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1482 1 89*0/
1483 DATA RMSS/0D0,
1484 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1485 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1486 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,24D17,2*0D0,
1487 3 69*0D0/
1488
1489C...Data for histogramming routines.
1490 DATA IHIST/1000,20000,55,1/
1491 DATA INDX/1000*0/
1492
1493 END
1494
1495C*********************************************************************
1496
1497*$ CREATE PYTEST.FOR
1498*COPY PYTEST
1499C...PYTEST
1500C...A simple program (disguised as subroutine) to run at installation
1501C...as a check that the program works as intended.
1502
1503 SUBROUTINE PYTEST(MTEST)
1504
1505C...Double precision and integer declarations.
1506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1507 INTEGER PYK,PYCHGE,PYCOMP
1508C...Commonblocks.
1509 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1510 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1511 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1512 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
1513 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1514 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1515 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1516C...Local arrays.
1517 DIMENSION PSUM(5),PINI(6),PFIN(6)
1518
1519C...Save defaults for values that are changed.
1520 MSTJ1=MSTJ(1)
1521 MSTJ3=MSTJ(3)
1522 MSTJ11=MSTJ(11)
1523 MSTJ42=MSTJ(42)
1524 MSTJ43=MSTJ(43)
1525 MSTJ44=MSTJ(44)
1526 PARJ17=PARJ(17)
1527 PARJ22=PARJ(22)
1528 PARJ43=PARJ(43)
1529 PARJ54=PARJ(54)
1530 MST101=MSTJ(101)
1531 MST104=MSTJ(104)
1532 MST105=MSTJ(105)
1533 MST107=MSTJ(107)
1534 MST116=MSTJ(116)
1535
1536C...First part: loop over simple events to be generated.
1537 IF(MTEST.GE.1) CALL PYTABU(20)
1538 NERR=0
1539 DO 180 IEV=1,500
1540
1541C...Reset parameter values. Switch on some nonstandard features.
1542 MSTJ(1)=1
1543 MSTJ(3)=0
1544 MSTJ(11)=1
1545 MSTJ(42)=2
1546 MSTJ(43)=4
1547 MSTJ(44)=2
1548 PARJ(17)=0.1D0
1549 PARJ(22)=1.5D0
1550 PARJ(43)=1D0
1551 PARJ(54)=-0.05D0
1552 MSTJ(101)=5
1553 MSTJ(104)=5
1554 MSTJ(105)=0
1555 MSTJ(107)=1
1556 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1557
1558C...Ten events each for some single jets configurations.
1559 IF(IEV.LE.50) THEN
1560 ITY=(IEV+9)/10
1561 MSTJ(3)=-1
1562 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1563 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1564 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1565 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1566 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1567 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1568
1569C...Ten events each for some simple jet systems; string fragmentation.
1570 ELSEIF(IEV.LE.130) THEN
1571 ITY=(IEV-41)/10
1572 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1573 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1574 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1575 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1576 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1577 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1578 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1579 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1580 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1581
1582C...Seventy events with independent fragmentation and momentum cons.
1583 ELSEIF(IEV.LE.200) THEN
1584 ITY=1+(IEV-131)/16
1585 MSTJ(2)=1+MOD(IEV-131,4)
1586 MSTJ(3)=1+MOD((IEV-131)/4,4)
1587 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1588 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1589 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1590 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1591 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1592 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1593
1594C...A hundred events with random jets (check invariant mass).
1595 ELSEIF(IEV.LE.300) THEN
1596 100 DO 110 J=1,5
1597 PSUM(J)=0D0
1598 110 CONTINUE
1599 NJET=2D0+6D0*PYR(0)
1600 DO 130 I=1,NJET
1601 KFL=21
1602 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1603 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1604 EJET=5D0+20D0*PYR(0)
1605 THETA=ACOS(2D0*PYR(0)-1D0)
1606 PHI=6.2832D0*PYR(0)
1607 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1608 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1609 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1610 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1611 DO 120 J=1,4
1612 PSUM(J)=PSUM(J)+P(I,J)
1613 120 CONTINUE
1614 130 CONTINUE
1615 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
1616 & (PSUM(5)+PARJ(32))**2) GOTO 100
1617
1618C...Fifty e+e- continuum events with matrix elements.
1619 ELSEIF(IEV.LE.350) THEN
1620 MSTJ(101)=2
1621 CALL PYEEVT(0,40D0)
1622
1623C...Fifty e+e- continuum event with varying shower options.
1624 ELSEIF(IEV.LE.400) THEN
1625 MSTJ(42)=1+MOD(IEV,2)
1626 MSTJ(43)=1+MOD(IEV/2,4)
1627 MSTJ(44)=MOD(IEV/8,3)
1628 CALL PYEEVT(0,90D0)
1629
1630C...Fifty e+e- continuum events with coherent shower.
1631 ELSEIF(IEV.LE.450) THEN
1632 CALL PYEEVT(0,500D0)
1633
1634C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1635 ELSE
1636 CALL PYONIA(5,9.46D0)
1637 ENDIF
1638
1639C...Generate event. Find total momentum, energy and charge.
1640 DO 140 J=1,4
1641 PINI(J)=PYP(0,J)
1642 140 CONTINUE
1643 PINI(6)=PYP(0,6)
1644 CALL PYEXEC
1645 DO 150 J=1,4
1646 PFIN(J)=PYP(0,J)
1647 150 CONTINUE
1648 PFIN(6)=PYP(0,6)
1649
1650C...Check conservation of energy, momentum and charge;
1651C...usually exact, but only approximate for single jets.
1652 MERR=0
1653 IF(IEV.LE.50) THEN
1654 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4D0)
1655 & MERR=MERR+1
1656 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
1657 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
1658 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
1659 ELSE
1660 DO 160 J=1,4
1661 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
1662 160 CONTINUE
1663 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
1664 ENDIF
1665 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1666 & (PFIN(J),J=1,4),PFIN(6)
1667
1668C...Check that all KF codes are known ones, and that partons/particles
1669C...satisfy energy-momentum-mass relation. Store particle statistics.
1670 DO 170 I=1,N
1671 IF(K(I,1).GT.20) GOTO 170
1672 IF(PYCOMP(K(I,2)).EQ.0) THEN
1673 WRITE(MSTU(11),5100) I
1674 MERR=MERR+1
1675 ENDIF
1676 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
1677 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
1678 & THEN
1679 WRITE(MSTU(11),5200) I
1680 MERR=MERR+1
1681 ENDIF
1682 170 CONTINUE
1683 IF(MTEST.GE.1) CALL PYTABU(21)
1684
1685C...List all erroneous events and some normal ones.
1686 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
1687 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1688 CALL PYLIST(2)
1689 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
1690 CALL PYLIST(1)
1691 ENDIF
1692
1693C...Stop execution if too many errors.
1694 IF(MERR.NE.0) NERR=NERR+1
1695 IF(NERR.GE.10) THEN
1696 WRITE(MSTU(11),6300)
1697 CALL PYLIST(1)
1698 STOP
1699 ENDIF
1700 180 CONTINUE
1701
1702C...Summarize result of run.
1703 IF(MTEST.GE.1) CALL PYTABU(22)
1704
1705C...Reset commonblock variables changed during run.
1706 MSTJ(1)=MSTJ1
1707 MSTJ(3)=MSTJ3
1708 MSTJ(11)=MSTJ11
1709 MSTJ(42)=MSTJ42
1710 MSTJ(43)=MSTJ43
1711 MSTJ(44)=MSTJ44
1712 PARJ(17)=PARJ17
1713 PARJ(22)=PARJ22
1714 PARJ(43)=PARJ43
1715 PARJ(54)=PARJ54
1716 MSTJ(101)=MST101
1717 MSTJ(104)=MST104
1718 MSTJ(105)=MST105
1719 MSTJ(107)=MST107
1720 MSTJ(116)=MST116
1721
1722C...Second part: complete events of various kinds.
1723C...Common initial values. Loop over initiating conditions.
1724 MSTP(122)=MAX(0,MIN(2,MTEST))
1725 MDCY(PYCOMP(111),1)=0
1726 DO 230 IPROC=1,8
1727
1728C...Reset process type, kinematics cuts, and the flags used.
1729 MSEL=0
1730 DO 190 ISUB=1,500
1731 MSUB(ISUB)=0
1732 190 CONTINUE
1733 CKIN(1)=2D0
1734 CKIN(3)=0D0
1735 MSTP(2)=1
1736 MSTP(11)=0
1737 MSTP(33)=0
1738 MSTP(81)=1
1739 MSTP(82)=1
1740 MSTP(111)=1
1741 MSTP(131)=0
1742 MSTP(133)=0
1743 PARP(131)=0.01D0
1744
1745C...Prompt photon production at fixed target.
1746 IF(IPROC.EQ.1) THEN
1747 PZSUM=300D0
1748 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
1749 PQSUM=2D0
1750 MSEL=10
1751 CKIN(3)=5D0
1752 CALL PYINIT('FIXT','pi+','p',PZSUM)
1753
1754C...QCD processes at ISR energies.
1755 ELSEIF(IPROC.EQ.2) THEN
1756 PESUM=63D0
1757 PZSUM=0D0
1758 PQSUM=2D0
1759 MSEL=1
1760 CKIN(3)=5D0
1761 CALL PYINIT('CMS','p','p',PESUM)
1762
1763C...W production + multiple interactions at CERN Collider.
1764 ELSEIF(IPROC.EQ.3) THEN
1765 PESUM=630D0
1766 PZSUM=0D0
1767 PQSUM=0D0
1768 MSEL=12
1769 CKIN(1)=20D0
1770 MSTP(82)=4
1771 MSTP(2)=2
1772 MSTP(33)=3
1773 CALL PYINIT('CMS','p','pbar',PESUM)
1774
1775C...W/Z gauge boson pairs + pileup events at the Tevatron.
1776 ELSEIF(IPROC.EQ.4) THEN
1777 PESUM=1800D0
1778 PZSUM=0D0
1779 PQSUM=0D0
1780 MSUB(22)=1
1781 MSUB(23)=1
1782 MSUB(25)=1
1783 CKIN(1)=200D0
1784 MSTP(111)=0
1785 MSTP(131)=1
1786 MSTP(133)=2
1787 PARP(131)=0.04D0
1788 CALL PYINIT('CMS','p','pbar',PESUM)
1789
1790C...Higgs production at LHC.
1791 ELSEIF(IPROC.EQ.5) THEN
1792 PESUM=15400D0
1793 PZSUM=0D0
1794 PQSUM=2D0
1795 MSUB(3)=1
1796 MSUB(102)=1
1797 MSUB(123)=1
1798 MSUB(124)=1
1799 PMAS(25,1)=300D0
1800 CKIN(1)=200D0
1801 MSTP(81)=0
1802 MSTP(111)=0
1803 CALL PYINIT('CMS','p','p',PESUM)
1804
1805C...Z' production at SSC.
1806 ELSEIF(IPROC.EQ.6) THEN
1807 PESUM=40000D0
1808 PZSUM=0D0
1809 PQSUM=2D0
1810 MSEL=21
1811 PMAS(32,1)=600D0
1812 CKIN(1)=400D0
1813 MSTP(81)=0
1814 MSTP(111)=0
1815 CALL PYINIT('CMS','p','p',PESUM)
1816
1817C...W pair production at 1 TeV e+e- collider.
1818 ELSEIF(IPROC.EQ.7) THEN
1819 PESUM=1000D0
1820 PZSUM=0D0
1821 PQSUM=0D0
1822 MSUB(25)=1
1823 MSUB(69)=1
1824 MSTP(11)=1
1825 CALL PYINIT('CMS','e+','e-',PESUM)
1826
1827C...Deep inelastic scattering at a LEP+LHC ep collider.
1828 ELSEIF(IPROC.EQ.8) THEN
1829 P(1,1)=0D0
1830 P(1,2)=0D0
1831 P(1,3)=8000D0
1832 P(2,1)=0D0
1833 P(2,2)=0D0
1834 P(2,3)=-80D0
1835 PESUM=8080D0
1836 PZSUM=7920D0
1837 PQSUM=0D0
1838 MSUB(10)=1
1839 CKIN(3)=50D0
1840 MSTP(111)=0
1841 CALL PYINIT('USER','p','e-',PESUM)
1842 ENDIF
1843
1844C...Generate 20 events of each required type.
1845 DO 220 IEV=1,20
1846 CALL PYEVNT
1847 PESUMM=PESUM
1848 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
1849
1850C...Check conservation of energy/momentum/flavour.
1851 PINI(1)=0D0
1852 PINI(2)=0D0
1853 PINI(3)=PZSUM
1854 PINI(4)=PESUMM
1855 PINI(6)=PQSUM
1856 DO 200 J=1,4
1857 PFIN(J)=PYP(0,J)
1858 200 CONTINUE
1859 PFIN(6)=PYP(0,6)
1860 MERR=0
1861 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
1862 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
1863 DEVQ=ABS(PFIN(6)-PINI(6))
1864 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
1865 & DEVQ.GT.0.1D0) MERR=1
1866 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1867 & (PFIN(J),J=1,4),PFIN(6)
1868
1869C...Check that all KF codes are known ones, and that partons/particles
1870C...satisfy energy-momentum-mass relation.
1871 DO 210 I=1,N
1872 IF(K(I,1).GT.20) GOTO 210
1873 IF(PYCOMP(K(I,2)).EQ.0) THEN
1874 WRITE(MSTU(11),5100) I
1875 MERR=MERR+1
1876 ENDIF
1877 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
1878 & SIGN(1D0,P(I,5))
1879 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
1880 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
1881 WRITE(MSTU(11),5200) I
1882 MERR=MERR+1
1883 ENDIF
1884 210 CONTINUE
1885
1886C...Listing of erroneous events, and first event of each type.
1887 IF(MERR.GE.1) NERR=NERR+1
1888 IF(NERR.GE.10) THEN
1889 WRITE(MSTU(11),6300)
1890 CALL PYLIST(1)
1891 STOP
1892 ENDIF
1893 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
1894 IF(MERR.GE.1) WRITE(MSTU(11),6400)
1895 CALL PYLIST(1)
1896 ENDIF
1897 220 CONTINUE
1898
1899C...List statistics for each process type.
1900 IF(MTEST.GE.1) CALL PYSTAT(1)
1901 230 CONTINUE
1902
1903C...Summarize result of run.
1904 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
1905 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
1906
1907C...Format statements for output.
1908 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
1909 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
1910 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
1911 &4(1X,F12.5),1X,F8.2)
1912 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
1913 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
1914 &'kinematics')
1915 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
1916 &'wrong.'/5X,'Execution will be stopped after listing of event.')
1917 6400 FORMAT(5X,'Faulty event follows:')
1918 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
1919 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
1920 &5X,'This should not have happened!')
1921
1922 RETURN
1923 END
1924
1925C*********************************************************************
1926
1927*$ CREATE PYHEPC.FOR
1928*COPY PYHEPC
1929C...PYHEPC
1930C...Converts PYTHIA event record contents to or from
1931C...the standard event record commonblock.
1932
1933 SUBROUTINE PYHEPC(MCONV)
1934
1935C...Double precision and integer declarations.
1936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1937 INTEGER PYK,PYCHGE,PYCOMP
1938C...Commonblocks.
1939 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1941 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1942 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
1943C...HEPEVT commonblock.
1944 PARAMETER (NMXHEP=4000)
1945 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
1946 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
1947 DOUBLE PRECISION PHEP,VHEP
1948 SAVE /HEPEVT/
1949
1950C...Conversion from PYTHIA to standard, the easy part.
1951 IF(MCONV.EQ.1) THEN
1952 NEVHEP=0
1953 IF(N.GT.NMXHEP) CALL PYERRM(8,
1954 & '(PYHEPC:) no more space in /HEPEVT/')
1955 NHEP=MIN(N,NMXHEP)
1956 DO 140 I=1,NHEP
1957 ISTHEP(I)=0
1958 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
1959 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
1960 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
1961 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
1962 IDHEP(I)=K(I,2)
1963 JMOHEP(1,I)=K(I,3)
1964 JMOHEP(2,I)=0
1965 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
1966 JDAHEP(1,I)=K(I,4)
1967 JDAHEP(2,I)=K(I,5)
1968 ELSE
1969 JDAHEP(1,I)=0
1970 JDAHEP(2,I)=0
1971 ENDIF
1972 DO 100 J=1,5
1973 PHEP(J,I)=P(I,J)
1974 100 CONTINUE
1975 DO 110 J=1,4
1976 VHEP(J,I)=V(I,J)
1977 110 CONTINUE
1978
1979C...Check if new event (from pileup).
1980 IF(I.EQ.1) THEN
1981 INEW=1
1982 ELSE
1983 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
1984 ENDIF
1985
1986C...Fill in missing mother information.
1987 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
1988 IMO1=I-2
1989 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
1990 & IMO1=IMO1-1
1991 JMOHEP(1,I)=IMO1
1992 JMOHEP(2,I)=IMO1+1
1993 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
1994 I1=K(I,3)-1
1995 120 I1=I1+1
1996 IF(I1.GE.I) CALL PYERRM(8,
1997 & '(PYHEPC:) translation of inconsistent event history')
1998 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
1999 KC=PYCOMP(K(I1,2))
2000 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2001 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2002 JMOHEP(2,I)=I1
2003 ELSEIF(K(I,2).EQ.94) THEN
2004 NJET=2
2005 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2006 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2007 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2008 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2009 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2010 ENDIF
2011
2012C...Fill in missing daughter information.
2013 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2014 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2015 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2016 JDAHEP(1,I2)=I
2017 130 CONTINUE
2018 ENDIF
2019 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2020 I1=JMOHEP(1,I)
2021 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2022 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2023 IF(JDAHEP(1,I1).EQ.0) THEN
2024 JDAHEP(1,I1)=I
2025 ELSE
2026 JDAHEP(2,I1)=I
2027 ENDIF
2028 140 CONTINUE
2029 DO 150 I=1,NHEP
2030 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2031 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2032 150 CONTINUE
2033
2034C...Conversion from standard to PYTHIA, the easy part.
2035 ELSE
2036 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2037 & '(PYHEPC:) no more space in /PYJETS/')
2038 N=MIN(NHEP,MSTU(4))
2039 NKQ=0
2040 KQSUM=0
2041 DO 180 I=1,N
2042 K(I,1)=0
2043 IF(ISTHEP(I).EQ.1) K(I,1)=1
2044 IF(ISTHEP(I).EQ.2) K(I,1)=11
2045 IF(ISTHEP(I).EQ.3) K(I,1)=21
2046 K(I,2)=IDHEP(I)
2047 K(I,3)=JMOHEP(1,I)
2048 K(I,4)=JDAHEP(1,I)
2049 K(I,5)=JDAHEP(2,I)
2050 DO 160 J=1,5
2051 P(I,J)=PHEP(J,I)
2052 160 CONTINUE
2053 DO 170 J=1,4
2054 V(I,J)=VHEP(J,I)
2055 170 CONTINUE
2056 V(I,5)=0D0
2057 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2058 I1=JDAHEP(1,I)
2059 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2060 & PHEP(5,I)/PHEP(4,I)
2061 ENDIF
2062
2063C...Fill in missing information on colour connection in jet systems.
2064 IF(ISTHEP(I).EQ.1) THEN
2065 KC=PYCOMP(K(I,2))
2066 KQ=0
2067 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2068 IF(KQ.NE.0) NKQ=NKQ+1
2069 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2070 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2071 K(I,1)=2
2072 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2073 IF(K(I+1,2).EQ.21) K(I,1)=2
2074 ENDIF
2075 ENDIF
2076 180 CONTINUE
2077 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2078 & '(PYHEPC:) input parton configuration not colour singlet')
2079 ENDIF
2080
2081 END
2082
2083C*********************************************************************
2084
2085*$ CREATE PYINIT.FOR
2086*COPY PYINIT
2087C...PYINIT
2088C...Initializes the generation procedure; finds maxima of the
2089C...differential cross-sections to be used for weighting.
2090
2091 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2092
2093C...Double precision and integer declarations.
2094 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2095 INTEGER PYK,PYCHGE,PYCOMP
2096C...Commonblocks.
2097 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2098 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2099 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2100 COMMON/PYDAT4/CHAF(500,2)
2101 CHARACTER CHAF*16
2102 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2103 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2104 COMMON/PYINT1/MINT(400),VINT(400)
2105 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2106 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2107 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2108 &/PYINT1/,/PYINT2/,/PYINT5/
2109C...Local arrays and character variables.
2110 DIMENSION ALAMIN(20),NFIN(20)
2111 CHARACTER*(*) FRAME,BEAM,TARGET
2112 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHLH(2)*6
2113
2114C...Interface to PDFLIB.
2115 COMMON/W50512/QCDL4,QCDL5
2116 SAVE /W50512/
2117 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2118 CHARACTER*20 PARM(20)
2119 DATA VALUE/20*0D0/,PARM/20*' '/
2120
2121C...Data:Lambda and n_f values for parton distributions; months.
2122 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2123 &14*0.2D0/,NFIN/20*4/
2124 DATA CHLH/'lepton','hadron'/
2125
2126C...Reset MINT and VINT arrays. Write headers.
2127 DO 100 J=1,400
2128 MINT(J)=0
2129 VINT(J)=0D0
2130 100 CONTINUE
2131 IF(MSTU(12).GE.1) CALL PYLIST(0)
2132 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2133
2134C...Maximum 4 generations; set maximum number of allowed flavours.
2135 MSTP(1)=MIN(4,MSTP(1))
2136 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2137 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2138
2139C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2140 DO 120 I=-20,20
2141 VINT(180+I)=0D0
2142 IA=IABS(I)
2143 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2144 DO 110 J=1,MSTP(1)
2145 IB=2*J-1+MOD(IA,2)
2146 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2147 IPM=(5-ISIGN(1,I))/2
2148 IDC=J+MDCY(IA,2)+2
2149 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2150 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2151 110 CONTINUE
2152 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2153 VINT(180+I)=1D0
2154 ENDIF
2155 120 CONTINUE
2156
2157C...Initialize parton distributions: PDFLIB.
2158 IF(MSTP(52).EQ.2) THEN
2159 PARM(1)='NPTYPE'
2160 VALUE(1)=1
2161 PARM(2)='NGROUP'
2162 VALUE(2)=MSTP(51)/1000
2163 PARM(3)='NSET'
2164 VALUE(3)=MOD(MSTP(51),1000)
2165 PARM(4)='TMAS'
2166 VALUE(4)=PMAS(6,1)
2167 CALL PDFSET(PARM,VALUE)
2168 MINT(93)=1000000+MSTP(51)
2169 ENDIF
2170
2171C...Choose Lambda value to use in alpha-strong.
2172 MSTU(111)=MSTP(2)
2173 IF(MSTP(3).GE.2) THEN
2174 ALAM=0.2D0
2175 NF=4
2176 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.10) THEN
2177 ALAM=ALAMIN(MSTP(51))
2178 NF=NFIN(MSTP(51))
2179 ELSEIF(MSTP(52).EQ.2) THEN
2180 ALAM=QCDL4
2181 NF=4
2182 ENDIF
2183 PARP(1)=ALAM
2184 PARP(61)=ALAM
2185 PARP(72)=ALAM
2186 PARU(112)=ALAM
2187 MSTU(112)=NF
2188 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2189 ENDIF
2190
2191C...Initialize the SUSY generation: couplings, masses,
2192C...decay modes, branching ratios, and so on.
2193 CALL PYMSIN
2194
2195C...Initialize widths and partial widths for resonances.
2196 CALL PYINRE
2197C...Set Z0 mass and width for e+e- routines.
2198 PARJ(123)=PMAS(23,1)
2199 PARJ(124)=PMAS(23,2)
2200
2201C...Identify beam and target particles and frame of process.
2202 CHFRAM=FRAME//' '
2203 CHBEAM=BEAM//' '
2204 CHTARG=TARGET//' '
2205 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2206 IF(MINT(65).EQ.1) GOTO 170
2207
2208C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2209C...For e-gamma allow 2 alternatives.
2210 MINT(121)=1
2211 MINT(123)=MSTP(14)
2212 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2213 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2214 & (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2215 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2216 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2217 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2218 ENDIF
2219
2220C...Set up kinematics of process.
2221 CALL PYINKI(0)
2222
2223C...Precalculate flavour selection weights
2224 CALL PYKFIN
2225
2226C...Loop over gamma-p or gamma-gamma alternatives.
2227 DO 160 IGA=1,MINT(121)
2228 MINT(122)=IGA
2229
2230C...Select partonic subprocesses to be included in the simulation.
2231 CALL PYINPR
2232
2233C...Count number of subprocesses on.
2234 MINT(48)=0
2235 DO 130 ISUB=1,500
2236 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2237 & MSUB(ISUB).EQ.1) THEN
2238 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2239 STOP
2240 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2241 WRITE(MSTU(11),5300) ISUB
2242 STOP
2243 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2244 WRITE(MSTU(11),5400) ISUB
2245 STOP
2246 ELSEIF(MSUB(ISUB).EQ.1) THEN
2247 MINT(48)=MINT(48)+1
2248 ENDIF
2249 130 CONTINUE
2250 IF(MINT(48).EQ.0) THEN
2251 WRITE(MSTU(11),5500)
2252 STOP
2253 ENDIF
2254 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2255
2256C...Reset variables for cross-section calculation.
2257 DO 150 I=0,500
2258 DO 140 J=1,3
2259 NGEN(I,J)=0
2260 XSEC(I,J)=0D0
2261 140 CONTINUE
2262 150 CONTINUE
2263
2264C...Find parametrized total cross-sections.
2265 CALL PYXTOT
2266
2267C...Maxima of differential cross-sections.
2268 IF(MSTP(121).LE.1) CALL PYMAXI
2269
2270C...Initialize possibility of pileup events.
2271 IF(MINT(121).GT.1) MSTP(131)=0
2272 IF(MSTP(131).NE.0) CALL PYPILE(1)
2273
2274C...Initialize multiple interactions with variable impact parameter.
2275 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2276 & MSTP(82).GE.2) CALL PYMULT(1)
2277
2278C...Save results for gamma-p and gamma-gamma alternatives.
2279 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2280 160 CONTINUE
2281
2282C...Initialization finished.
2283 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2284
2285C...Formats for initialization information.
2286 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2287 &'routines',1X,17('*'))
2288 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2289 &'-',A6,' interactions.'/1X,'Execution stopped!')
2290 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2291 &1X,'Execution stopped!')
2292 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2293 &1X,'Execution stopped!')
2294 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2295 &1X,'Execution stopped.')
2296 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2297 &22('*'))
2298
2299 RETURN
2300 END
2301
2302C*********************************************************************
2303
2304*$ CREATE PYEVNT.FOR
2305*COPY PYEVNT
2306C...PYEVNT
2307C...Administers the generation of a high-pT event via calls to
2308C...a number of subroutines.
2309
2310 SUBROUTINE PYEVNT
2311
2312C...Double precision and integer declarations.
2313 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2314 INTEGER PYK,PYCHGE,PYCOMP
2315C...Commonblocks.
2316 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2317 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2318 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2319 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2320 COMMON/PYINT1/MINT(400),VINT(400)
2321 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2322 COMMON/PYINT4/MWID(500),WIDS(500,5)
2323 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2324 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
2325 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
2326 &/PYINT4/,/PYINT5/,/PYUPPR/
2327C...Local array.
2328 DIMENSION VTX(4)
2329
2330C...Initial values for some counters.
2331 N=0
2332 MINT(5)=MINT(5)+1
2333 MINT(7)=0
2334 MINT(8)=0
2335 MINT(83)=0
2336 MINT(84)=MSTP(126)
2337 MSTU(24)=0
2338 MSTU70=0
2339 MSTJ14=MSTJ(14)
2340
2341C...If variable energies: redo incoming kinematics and cross-section.
2342 MSTI(61)=0
2343 IF(MSTP(171).EQ.1) THEN
2344 CALL PYINKI(1)
2345 IF(MSTI(61).EQ.1) THEN
2346 MINT(5)=MINT(5)-1
2347 RETURN
2348 ENDIF
2349 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2350 CALL PYXTOT
2351 ENDIF
2352
2353C...Loop over number of pileup events; check space left.
2354 IF(MSTP(131).LE.0) THEN
2355 NPILE=1
2356 ELSE
2357 CALL PYPILE(2)
2358 NPILE=MINT(81)
2359 ENDIF
2360 DO 260 IPILE=1,NPILE
2361 IF(MINT(84)+100.GE.MSTU(4)) THEN
2362 CALL PYERRM(11,
2363 & '(PYEVNT:) no more space in PYJETS for pileup events')
2364 IF(MSTU(21).GE.1) GOTO 270
2365 ENDIF
2366 MINT(82)=IPILE
2367
2368C...Generate variables of hard scattering.
2369 MINT(51)=0
2370 MSTI(52)=0
2371 100 CONTINUE
2372 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2373 MINT(31)=0
2374 MINT(51)=0
2375 MINT(57)=0
2376 CALL PYRAND
2377 IF(MSTI(61).EQ.1) THEN
2378 MINT(5)=MINT(5)-1
2379 RETURN
2380 ENDIF
2381 IF(MINT(51).EQ.2) RETURN
2382 ISUB=MINT(1)
2383 IF(MSTP(111).EQ.-1) GOTO 250
2384
2385 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
2386C...Hard scattering (including low-pT):
2387C...reconstruct kinematics and colour flow of hard scattering.
2388 110 MINT(51)=0
2389 CALL PYSCAT
2390 IF(MINT(51).EQ.1) GOTO 100
2391 IPU1=MINT(84)+1
2392 IPU2=MINT(84)+2
2393 IF(ISUB.EQ.95) GOTO 130
2394
2395C...Showering of initial state partons (optional).
2396 ALAMSV=PARJ(81)
2397 PARJ(81)=PARP(72)
2398 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2399 PARJ(81)=ALAMSV
2400 IF(MINT(51).EQ.1) GOTO 100
2401
2402C...Showering of final state partons (optional).
2403 ALAMSV=PARJ(81)
2404 PARJ(81)=PARP(72)
2405 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2406 & THEN
2407 IPU3=MINT(84)+3
2408 IPU4=MINT(84)+4
2409 IF(ISET(ISUB).EQ.5) IPU4=-3
2410 QMAX=VINT(55)
2411 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2412 CALL PYSHOW(IPU3,IPU4,QMAX)
2413 ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
2414 DO 120 IUP=1,NFUP
2415 IPU3=IFUP(IUP,1)+MINT(84)
2416 IPU4=IFUP(IUP,2)+MINT(84)
2417 QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
2418 CALL PYSHOW(IPU3,IPU4,QMAX)
2419 120 CONTINUE
2420 ENDIF
2421 PARJ(81)=ALAMSV
2422
2423C...Decay of final state resonances.
2424 MINT(32)=0
2425 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2426 IF(MINT(51).EQ.1) GOTO 100
2427 MINT(52)=N
2428
2429C...Multiple interactions.
2430 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2431 MINT(53)=N
2432
2433C...Hadron remnants and primordial kT.
2434 130 CALL PYREMN(IPU1,IPU2)
2435 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2436 IF(MINT(51).EQ.1) GOTO 100
2437
2438 ELSE
2439C...Diffractive and elastic scattering.
2440 CALL PYDIFF
2441 ENDIF
2442
2443C...Check that no odd resonance left undecayed.
2444 IF(MSTP(111).GE.1) THEN
2445 NFIX=N
2446 DO 140 I=MINT(84)+1,NFIX
2447 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2448 & K(I,2).NE.22) THEN
2449 IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
2450 CALL PYRESD(I)
2451 IF(MINT(51).EQ.1) GOTO 100
2452 ENDIF
2453 ENDIF
2454 140 CONTINUE
2455 ENDIF
2456
2457C...Recalculate energies from momenta and masses (if desired).
2458 IF(MSTP(113).GE.1) THEN
2459 DO 150 I=MINT(83)+1,N
2460 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2461 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2462 150 CONTINUE
2463 NRECAL=N
2464 ENDIF
2465
2466C...Rearrange partons along strings, check invariant mass cuts.
2467 MSTU(28)=0
2468 IF(MSTP(111).LE.0) MSTJ(14)=-1
2469 CALL PYPREP(MINT(84)+1)
2470 MSTJ(14)=MSTJ14
2471 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2472 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2473 DO 180 I=MINT(84)+1,N
2474 IF(K(I,2).EQ.94) THEN
2475 DO 170 I1=I+1,MIN(N,I+3)
2476 IF(K(I1,3).EQ.I) THEN
2477 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2478 IF(K(I1,3).EQ.0) THEN
2479 DO 160 II=MINT(84)+1,I-1
2480 IF(K(II,2).EQ.K(I1,2)) THEN
2481 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2482 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2483 ENDIF
2484 160 CONTINUE
2485 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2486 ENDIF
2487 ENDIF
2488 170 CONTINUE
2489 ENDIF
2490 180 CONTINUE
2491 CALL PYEDIT(12)
2492 CALL PYEDIT(14)
2493 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2494 IF(MSTP(125).EQ.0) MINT(4)=0
2495 DO 200 I=MINT(83)+1,N
2496 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2497 DO 190 I1=I+1,N
2498 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2499 IF(K(I1,3).EQ.I) K(I,5)=I1
2500 190 CONTINUE
2501 ENDIF
2502 200 CONTINUE
2503 ENDIF
2504
2505C...Introduce separators between sections in PYLIST event listing.
2506 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2507 MSTU70=1
2508 MSTU(71)=N
2509 ELSEIF(IPILE.EQ.1) THEN
2510 MSTU70=3
2511 MSTU(71)=2
2512 MSTU(72)=MINT(4)
2513 MSTU(73)=N
2514 ENDIF
2515
2516C...Go back to lab frame (needed for vertices, also in fragmentation).
2517 CALL PYFRAM(1)
2518
2519C...Set nonvanishing production vertex (optional).
2520 IF(MSTP(151).EQ.1) THEN
2521 DO 210 J=1,4
2522 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2523 & SIN(PARU(2)*PYR(0))
2524 210 CONTINUE
2525 DO 230 I=MINT(83)+1,N
2526 DO 220 J=1,4
2527 V(I,J)=V(I,J)+VTX(J)
2528 220 CONTINUE
2529 230 CONTINUE
2530 ENDIF
2531
2532C...Perform hadronization (if desired).
2533 IF(MSTP(111).GE.1) THEN
2534 CALL PYEXEC
2535 IF(MSTU(24).NE.0) GOTO 100
2536 ENDIF
2537 IF(MSTP(113).GE.1) THEN
2538 DO 240 I=NRECAL,N
2539 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
2540 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2541 240 CONTINUE
2542 ENDIF
2543 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
2544
2545C...Store event information and calculate Monte Carlo estimates of
2546C...subprocess cross-sections.
2547 250 IF(IPILE.EQ.1) CALL PYDOCU
2548
2549C...Set counters for current pileup event and loop to next one.
2550 MSTI(41)=IPILE
2551 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
2552 IF(MSTU70.LT.10) THEN
2553 MSTU70=MSTU70+1
2554 MSTU(70+MSTU70)=N
2555 ENDIF
2556 MINT(83)=N
2557 MINT(84)=N+MSTP(126)
2558 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
2559 260 CONTINUE
2560
2561C...Generic information on pileup events. Reconstruct missing history.
2562 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
2563 PARI(91)=VINT(132)
2564 PARI(92)=VINT(133)
2565 PARI(93)=VINT(134)
2566 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
2567 ENDIF
2568 CALL PYEDIT(16)
2569
2570C...Transform to the desired coordinate frame.
2571 270 CALL PYFRAM(MSTP(124))
2572 MSTU(70)=MSTU70
2573 PARU(21)=VINT(1)
2574
2575 RETURN
2576 END
2577
2578C***********************************************************************
2579
2580*$ CREATE PYSTAT.FOR
2581*COPY PYSTAT
2582C...PYSTAT
2583C...Prints out information about cross-sections, decay widths, branching
2584C...ratios, kinematical limits, status codes and parameter values.
2585
2586 SUBROUTINE PYSTAT(MSTAT)
2587
2588C...Double precision and integer declarations.
2589 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2590 INTEGER PYK,PYCHGE,PYCOMP
2591C...Parameter statement to help give large particle numbers.
2592 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2593C...Commonblocks.
2594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2596 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2597 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2598 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2599 COMMON/PYINT1/MINT(400),VINT(400)
2600 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2601 COMMON/PYINT4/MWID(500),WIDS(500,5)
2602 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2603 COMMON/PYINT6/PROC(0:500)
2604 CHARACTER PROC*28
2605 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2606 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
2607 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
2608C...Local arrays, character variables and data.
2609 DIMENSION WDTP(0:200),WDTE(0:200,0:5)
2610 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2611 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28
2612 DATA PROGA/
2613 &'VMD/hadron * VMD ','VMD/hadron * direct ',
2614 &'VMD/hadron * anomalous ','direct * direct ',
2615 &'direct * anomalous ','anomalous * anomalous '/
2616 DATA DISGA/'e * VMD','e * anomalous'/
2617 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
2618 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2619 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
2620 &' y*_small ',' eta*_large ',' eta*_small ',
2621 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
2622 &' x_2 ',' x_F ',' cos(theta_hard) ',
2623 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
2624 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
2625 &' tau'' '/
2626
2627C...Cross-sections.
2628 IF(MSTAT.LE.1) THEN
2629 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
2630 WRITE(MSTU(11),5000)
2631 WRITE(MSTU(11),5100)
2632 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
2633 DO 100 I=1,500
2634 IF(MSUB(I).NE.1) GOTO 100
2635 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
2636 100 CONTINUE
2637 IF(MINT(121).GT.1) THEN
2638 WRITE(MSTU(11),5300)
2639 DO 110 IGA=1,MINT(121)
2640 CALL PYSAVE(3,IGA)
2641 IF(MINT(121).EQ.2) THEN
2642 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
2643 & XSEC(0,3)
2644 ELSE
2645 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
2646 & XSEC(0,3)
2647 ENDIF
2648 110 CONTINUE
2649 CALL PYSAVE(5,0)
2650 ENDIF
2651 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
2652 & MAX(1D0,DBLE(NGEN(0,2)))
2653
2654C...Decay widths and branching ratios.
2655 ELSEIF(MSTAT.EQ.2) THEN
2656 WRITE(MSTU(11),5500)
2657 WRITE(MSTU(11),5600)
2658 DO 140 KC=1,500
2659 KF=KCHG(KC,4)
2660 CALL PYNAME(KF,CHKF)
2661 IOFF=0
2662 IF(KC.LE.22) THEN
2663 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
2664 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
2665 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
2666 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
2667 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
2668 ELSE
2669 IF(MWID(KC).LE.0) GOTO 140
2670 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
2671 & KF/KSUSY1.EQ.2)) GOTO 140
2672 ENDIF
2673C...Off-shell branchings.
2674 IF(IOFF.EQ.1) THEN
2675 NGP=0
2676 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
2677 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
2678 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
2679 DO 120 J=1,MDCY(KC,3)
2680 IDC=J+MDCY(KC,2)-1
2681 NGP1=0
2682 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2683 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2684 NGP2=0
2685 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2686 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2687 CALL PYNAME(KFDP(IDC,1),CHD1)
2688 CALL PYNAME(KFDP(IDC,2),CHD2)
2689 IF(KFDP(IDC,3).EQ.0) THEN
2690 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2691 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2692 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2693 ELSE
2694 CALL PYNAME(KFDP(IDC,3),CHD3)
2695 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2696 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2697 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2698 ENDIF
2699 120 CONTINUE
2700C...On-shell decays.
2701 ELSE
2702 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
2703 BRFIN=1D0
2704 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
2705 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
2706 & STATE(MDCY(KC,1)),BRFIN
2707 DO 130 J=1,MDCY(KC,3)
2708 IDC=J+MDCY(KC,2)-1
2709 NGP1=0
2710 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2711 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2712 NGP2=0
2713 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2714 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2715 BRFIN=0D0
2716 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
2717 CALL PYNAME(KFDP(IDC,1),CHD1)
2718 CALL PYNAME(KFDP(IDC,2),CHD2)
2719 IF(KFDP(IDC,3).EQ.0) THEN
2720 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2721 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2722 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
2723 & STATE(MDME(IDC,1)),BRFIN
2724 ELSE
2725 CALL PYNAME(KFDP(IDC,3),CHD3)
2726 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2727 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2728 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
2729 & STATE(MDME(IDC,1)),BRFIN
2730 ENDIF
2731 130 CONTINUE
2732 ENDIF
2733 140 CONTINUE
2734 WRITE(MSTU(11),6000)
2735
2736C...Allowed incoming partons/particles at hard interaction.
2737 ELSEIF(MSTAT.EQ.3) THEN
2738 WRITE(MSTU(11),6100)
2739 CALL PYNAME(MINT(11),CHAU)
2740 CHIN(1)=CHAU(1:12)
2741 CALL PYNAME(MINT(12),CHAU)
2742 CHIN(2)=CHAU(1:12)
2743 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
2744 DO 150 I=-20,22
2745 IF(I.EQ.0) GOTO 150
2746 IA=IABS(I)
2747 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
2748 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
2749 CALL PYNAME(I,CHAU)
2750 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
2751 & STATE(KFIN(2,I))
2752 150 CONTINUE
2753 WRITE(MSTU(11),6400)
2754
2755C...User-defined limits on kinematical variables.
2756 ELSEIF(MSTAT.EQ.4) THEN
2757 WRITE(MSTU(11),6500)
2758 WRITE(MSTU(11),6600)
2759 SHRMAX=CKIN(2)
2760 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
2761 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
2762 PTHMIN=MAX(CKIN(3),CKIN(5))
2763 PTHMAX=CKIN(4)
2764 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
2765 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
2766 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
2767 DO 160 I=4,14
2768 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
2769 160 CONTINUE
2770 SPRMAX=CKIN(32)
2771 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
2772 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
2773 WRITE(MSTU(11),7000)
2774
2775C...Status codes and parameter values.
2776 ELSEIF(MSTAT.EQ.5) THEN
2777 WRITE(MSTU(11),7100)
2778 WRITE(MSTU(11),7200)
2779 DO 170 I=1,100
2780 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
2781 & PARP(100+I)
2782 170 CONTINUE
2783
2784C...List of all processes implemented in the program.
2785 ELSEIF(MSTAT.EQ.6) THEN
2786 WRITE(MSTU(11),7400)
2787 WRITE(MSTU(11),7500)
2788 DO 180 I=1,500
2789 IF(ISET(I).LT.0) GOTO 180
2790 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
2791 180 CONTINUE
2792 WRITE(MSTU(11),7700)
2793 ENDIF
2794
2795C...Formats for printouts.
2796 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
2797 &'Events and Cross-sections',1X,9('*'))
2798 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
2799 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
2800 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
2801 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
2802 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
2803 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
2804 &'I',12X,'I')
2805 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
2806 &D10.3,1X,'I')
2807 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
2808 &1X,'I',34X,'I',28X,'I',12X,'I')
2809 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
2810 &1X,'********* Fraction of events that fail fragmentation ',
2811 &'cuts =',1X,F8.5,' *********'/)
2812 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
2813 &'Ratios',1X,27('*'))
2814 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2815 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
2816 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
2817 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2818 &1X,98('='))
2819 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
2820 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
2821 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
2822 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
2823 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2824 &1P,D10.3,0P,1X,'I')
2825 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
2826 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2827 &1P,D10.3,0P,1X,'I')
2828 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
2829 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
2830 &'Particles at Hard Interaction',1X,7('*'))
2831 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
2832 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
2833 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
2834 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
2835 &78('=')/1X,'I',38X,'I',37X,'I')
2836 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
2837 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
2838 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
2839 &'Kinematical Variables',1X,12('*'))
2840 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
2841 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
2842 &16X,'I')
2843 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
2844 &1X,'<',1X,1P,D10.3,0P,16X,'I')
2845 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
2846 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
2847 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
2848 &'Parameter Values',1X,12('*'))
2849 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
2850 &'PARP(I)'/)
2851 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
2852 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
2853 &1X,13('*'))
2854 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
2855 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
2856 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
2857 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
2858 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
2859
2860 RETURN
2861 END
2862
2863C*********************************************************************
2864
2865*$ CREATE PYINRE.FOR
2866*COPY PYINRE
2867C...PYINRE
2868C...Calculates full and effective widths of gauge bosons, stores
2869C...masses and widths, rescales coefficients to be used for
2870C...resonance production generation.
2871
2872 SUBROUTINE PYINRE
2873
2874C...Double precision and integer declarations.
2875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2876 INTEGER PYK,PYCHGE,PYCOMP
2877C...Parameter statement to help give large particle numbers.
2878 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2879C...Commonblocks.
2880 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2882 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2883 COMMON/PYDAT4/CHAF(500,2)
2884 CHARACTER CHAF*16
2885 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2886 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2887 COMMON/PYINT1/MINT(400),VINT(400)
2888 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2889 COMMON/PYINT4/MWID(500),WIDS(500,5)
2890 COMMON/PYINT6/PROC(0:500)
2891 CHARACTER PROC*28
2892 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2893 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2894 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
2895C...Local arrays and data.
2896 DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
2897 &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
2898
2899C...Born level couplings in MSSM Higgs doublet sector.
2900 XW=PARU(102)
2901 XWV=XW
2902 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
2903 XW1=1D0-XW
2904 IF(MSTP(4).EQ.2) THEN
2905 TANBE=PARU(141)
2906 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
2907 SQMZ=PMAS(23,1)**2
2908 SQMW=PMAS(24,1)**2
2909 SQMH=PMAS(25,1)**2
2910 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
2911 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
2912 SQMHC=SQMA+SQMW
2913 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
2914 WRITE(MSTU(11),5000)
2915 STOP
2916 ENDIF
2917 PMAS(35,1)=SQRT(SQMHP)
2918 PMAS(36,1)=SQRT(SQMA)
2919 PMAS(37,1)=SQRT(SQMHC)
2920 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
2921 & (SQMA-SQMZ)))
2922 BESU=ATAN(TANBE)
2923 PARU(142)=1D0
2924 PARU(143)=1D0
2925 PARU(161)=-SIN(ALSU)/COS(BESU)
2926 PARU(162)=COS(ALSU)/SIN(BESU)
2927 PARU(163)=PARU(161)
2928 PARU(164)=SIN(BESU-ALSU)
2929 PARU(165)=PARU(164)
2930 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
2931 PARU(171)=COS(ALSU)/COS(BESU)
2932 PARU(172)=SIN(ALSU)/SIN(BESU)
2933 PARU(173)=PARU(171)
2934 PARU(174)=COS(BESU-ALSU)
2935 PARU(175)=PARU(174)
2936 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
2937 & SIN(BESU+ALSU)
2938 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
2939 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
2940 PARU(181)=TANBE
2941 PARU(182)=1D0/TANBE
2942 PARU(183)=PARU(181)
2943 PARU(184)=0D0
2944 PARU(185)=PARU(184)
2945 PARU(186)=COS(BESU-ALSU)
2946 PARU(187)=SIN(BESU-ALSU)
2947 PARU(188)=PARU(186)
2948 PARU(189)=PARU(187)
2949 PARU(190)=0D0
2950 PARU(195)=COS(BESU-ALSU)
2951 ENDIF
2952
2953C...Reset effective widths of gauge bosons.
2954 DO 110 I=1,500
2955 DO 100 J=1,5
2956 WIDS(I,J)=1D0
2957 100 CONTINUE
2958 110 CONTINUE
2959
2960C...Order resonances by increasing mass (except Z0 and W+/-).
2961 NRES=0
2962 DO 140 KC=1,500
2963 KF=KCHG(KC,4)
2964 IF(KF.EQ.0) GOTO 140
2965 IF(MWID(KC).EQ.0) GOTO 140
2966 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
2967 IF(MSTP(1).LE.3) GOTO 140
2968 ENDIF
2969 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
2970 IF(IMSS(1).LE.0) GOTO 140
2971 ENDIF
2972 NRES=NRES+1
2973 PMRES=PMAS(KC,1)
2974 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
2975 DO 120 I1=NRES-1,1,-1
2976 IF(PMRES.GE.PMORD(I1)) GOTO 130
2977 KCORD(I1+1)=KCORD(I1)
2978 PMORD(I1+1)=PMORD(I1)
2979 120 CONTINUE
2980 130 KCORD(I1+1)=KC
2981 PMORD(I1+1)=PMRES
2982 140 CONTINUE
2983
2984C...Loop over possible resonances.
2985 DO 180 I=1,NRES
2986 KC=KCORD(I)
2987 KF=KCHG(KC,4)
2988
2989C...Check that no fourth generation channels on by mistake.
2990 IF(MSTP(1).LE.3) THEN
2991 DO 150 J=1,MDCY(KC,3)
2992 IDC=J+MDCY(KC,2)-1
2993 KFA1=IABS(KFDP(IDC,1))
2994 KFA2=IABS(KFDP(IDC,2))
2995 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
2996 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
2997 & MDME(IDC,1)=-1
2998 150 CONTINUE
2999 ENDIF
3000
3001C...Check that no supersymmetric channels on by mistake.
3002 IF(IMSS(1).LE.0) THEN
3003 DO 160 J=1,MDCY(KC,3)
3004 IDC=J+MDCY(KC,2)-1
3005 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3006 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3007 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3008 & MDME(IDC,1)=-1
3009 160 CONTINUE
3010 ENDIF
3011
3012C...Find mass and evaluate width.
3013 PMR=PMAS(KC,1)
3014 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3015 IF(MWID(KC).EQ.3) MINT(63)=1
3016 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3017 MINT(51)=0
3018
3019C...Evaluate suppression factors due to non-simulated channels.
3020 IF(KCHG(KC,3).EQ.0) THEN
3021 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3022 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3023 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3024 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3025 WIDS(KC,3)=0D0
3026 WIDS(KC,4)=0D0
3027 WIDS(KC,5)=0D0
3028 ELSE
3029 IF(MWID(KC).EQ.3) MINT(63)=1
3030 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3031 MINT(51)=0
3032 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3033 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3034 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3035 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3036 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3037 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3038 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3039 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3040 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3041 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3042 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3043 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3044 ENDIF
3045
3046C...Set resonance widths and branching ratios;
3047C...also on/off switch for decays.
3048 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3049 PMAS(KC,2)=WDTP(0)
3050 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3051 MDCY(KC,1)=MSTP(41)
3052 DO 170 J=1,MDCY(KC,3)
3053 IDC=J+MDCY(KC,2)-1
3054 BRAT(IDC)=0D0
3055 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3056 170 CONTINUE
3057 ENDIF
3058 180 CONTINUE
3059
3060C...Flavours of leptoquark: redefine charge and name.
3061 KFLQQ=KFDP(MDCY(39,2),1)
3062 KFLQL=KFDP(MDCY(39,2),2)
3063 KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3064 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3065 LL=1
3066 IF(IABS(KFLQL).EQ.13) LL=2
3067 IF(IABS(KFLQL).EQ.15) LL=3
3068 CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3069 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3070 CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
3071
3072C...Special cases in treatment of gamma*/Z0: redefine process name.
3073 IF(MSTP(43).EQ.1) THEN
3074 PROC(1)='f + fbar -> gamma*'
3075 PROC(15)='f + fbar -> g + gamma*'
3076 PROC(19)='f + fbar -> gamma + gamma*'
3077 PROC(30)='f + g -> f + gamma*'
3078 PROC(35)='f + gamma -> f + gamma*'
3079 ELSEIF(MSTP(43).EQ.2) THEN
3080 PROC(1)='f + fbar -> Z0'
3081 PROC(15)='f + fbar -> g + Z0'
3082 PROC(19)='f + fbar -> gamma + Z0'
3083 PROC(30)='f + g -> f + Z0'
3084 PROC(35)='f + gamma -> f + Z0'
3085 ELSEIF(MSTP(43).EQ.3) THEN
3086 PROC(1)='f + fbar -> gamma*/Z0'
3087 PROC(15)='f + fbar -> g + gamma*/Z0'
3088 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3089 PROC(30)='f + g -> f + gamma*/Z0'
3090 PROC(35)='f + gamma -> f + gamma*/Z0'
3091 ENDIF
3092
3093C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3094 IF(MSTP(44).EQ.1) THEN
3095 PROC(141)='f + fbar -> gamma*'
3096 ELSEIF(MSTP(44).EQ.2) THEN
3097 PROC(141)='f + fbar -> Z0'
3098 ELSEIF(MSTP(44).EQ.3) THEN
3099 PROC(141)='f + fbar -> Z''0'
3100 ELSEIF(MSTP(44).EQ.4) THEN
3101 PROC(141)='f + fbar -> gamma*/Z0'
3102 ELSEIF(MSTP(44).EQ.5) THEN
3103 PROC(141)='f + fbar -> gamma*/Z''0'
3104 ELSEIF(MSTP(44).EQ.6) THEN
3105 PROC(141)='f + fbar -> Z0/Z''0'
3106 ELSEIF(MSTP(44).EQ.7) THEN
3107 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3108 ENDIF
3109
3110C...Special cases in treatment of WW -> WW: redefine process name.
3111 IF(MSTP(45).EQ.1) THEN
3112 PROC(77)='W+ + W+ -> W+ + W+'
3113 ELSEIF(MSTP(45).EQ.2) THEN
3114 PROC(77)='W+ + W- -> W+ + W-'
3115 ELSEIF(MSTP(45).EQ.3) THEN
3116 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3117 ENDIF
3118
3119C...Format for error information.
3120 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3121 &'combination'/1X,'Execution stopped!')
3122
3123 RETURN
3124 END
3125
3126C*********************************************************************
3127
3128*$ CREATE PYINBM.FOR
3129*COPY PYINBM
3130C...PYINBM
3131C...Identifies the two incoming particles and the choice of frame.
3132
3133 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3134
3135C...Double precision and integer declarations.
3136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3137 INTEGER PYK,PYCHGE,PYCOMP
3138C...Commonblocks.
3139 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3142 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3143 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3144 COMMON/PYINT1/MINT(400),VINT(400)
3145 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3146C...Local arrays, character variables and data.
3147 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
3148 &CHIDNT(3)*8,CHTEMP*8,CHCDE(29)*8,CHINIT*76
3149 DIMENSION LEN(3),KCDE(29),PM(2)
3150 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3151 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3152 DATA CHCDE/'e- ','e+ ','nu_e ','nu_ebar ',
3153 &'mu- ','mu+ ','nu_mu ','nu_mubar','tau- ',
3154 &'tau+ ','nu_tau ','nu_tauba','pi+ ','pi- ',
3155 &'n0 ','nbar0 ','p+ ','pbar- ','gamma ',
3156 &'lambda0 ','sigma- ','sigma0 ','sigma+ ','xi- ',
3157 &'xi0 ','omega- ','pi0 ','reggeon ','pomeron '/
3158 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3159 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3160 &3312,3322,3334,111,28,29/
3161
3162C...Store initial energy. Default frame.
3163 VINT(290)=WIN
3164 MINT(111)=0
3165
3166C...Convert character variables to lowercase and find their length.
3167 CHCOM(1)=CHFRAM
3168 CHCOM(2)=CHBEAM
3169 CHCOM(3)=CHTARG
3170 DO 130 I=1,3
3171 LEN(I)=8
3172 DO 110 LL=8,1,-1
3173 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
3174 DO 100 LA=1,26
3175 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
3176 & CHALP(1)(LA:LA)
3177 100 CONTINUE
3178 110 CONTINUE
3179 CHIDNT(I)=CHCOM(I)
3180
3181C...Fix up bar, underscore and charge in particle name (if needed).
3182 DO 120 LL=1,6
3183 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
3184 CHTEMP=CHIDNT(I)
3185 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:6)//' '
3186 ENDIF
3187 120 CONTINUE
3188 IF(CHIDNT(I)(7:7).EQ.'~') CHIDNT(I)(7:8)='ba'
3189 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
3190 CHTEMP=CHIDNT(I)
3191 CHIDNT(I)='nu_'//CHTEMP(3:7)
3192 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
3193 CHIDNT(I)(1:3)='n0 '
3194 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
3195 CHIDNT(I)(1:5)='nbar0'
3196 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
3197 CHIDNT(I)(1:3)='p+ '
3198 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
3199 & CHIDNT(I)(1:2).EQ.'p-') THEN
3200 CHIDNT(I)(1:5)='pbar-'
3201 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
3202 CHIDNT(I)(7:7)='0'
3203 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
3204 CHIDNT(I)(1:7)='reggeon'
3205 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
3206 CHIDNT(I)(1:7)='pomeron'
3207 ENDIF
3208 130 CONTINUE
3209
3210C...Identify free initialization.
3211 IF(CHCOM(1)(1:2).EQ.'no') THEN
3212 MINT(65)=1
3213 RETURN
3214 ENDIF
3215
3216C...Identify incoming beam and target particles.
3217 DO 150 I=1,2
3218 DO 140 J=1,29
3219 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
3220 140 CONTINUE
3221 PM(I)=PYMASS(MINT(10+I))
3222 VINT(2+I)=PM(I)
3223 150 CONTINUE
3224 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
3225 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
3226 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
3227
3228C...Identify choice of frame and input energies.
3229 CHINIT=' '
3230
3231C...Events defined in the CM frame.
3232 IF(CHCOM(1)(1:2).EQ.'cm') THEN
3233 MINT(111)=1
3234 S=WIN**2
3235 IF(MSTP(122).GE.1) THEN
3236 IF(CHCOM(2)(1:1).NE.'e') THEN
3237 LOFFS=(31-(LEN(2)+LEN(3)))/2
3238 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
3239 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3240 & ' collider'//' '
3241 ELSE
3242 LOFFS=(30-(LEN(2)+LEN(3)))/2
3243 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
3244 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3245 & ' collider'//' '
3246 ENDIF
3247 WRITE(MSTU(11),5200) CHINIT
3248 WRITE(MSTU(11),5300) WIN
3249 ENDIF
3250
3251C...Events defined in fixed target frame.
3252 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
3253 MINT(111)=2
3254 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
3255 IF(MSTP(122).GE.1) THEN
3256 LOFFS=(29-(LEN(2)+LEN(3)))/2
3257 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3258 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3259 & ' fixed target'//' '
3260 WRITE(MSTU(11),5200) CHINIT
3261 WRITE(MSTU(11),5400) WIN
3262 WRITE(MSTU(11),5500) SQRT(S)
3263 ENDIF
3264
3265C...Frame defined by user three-vectors.
3266 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
3267 MINT(111)=3
3268 P(1,5)=PM(1)
3269 P(2,5)=PM(2)
3270 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3271 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3272 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3273 & (P(1,3)+P(2,3))**2
3274 IF(MSTP(122).GE.1) THEN
3275 LOFFS=(12-(LEN(2)+LEN(3)))/2
3276 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3277 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3278 & ' user-specified configuration'//' '
3279 WRITE(MSTU(11),5200) CHINIT
3280 WRITE(MSTU(11),5600)
3281 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3282 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3283 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3284 ENDIF
3285
3286C...Frame defined by user four-vectors.
3287 ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
3288 MINT(111)=4
3289 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3290 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3291 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3292 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3293 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3294 & (P(1,3)+P(2,3))**2
3295 IF(MSTP(122).GE.1) THEN
3296 LOFFS=(12-(LEN(2)+LEN(3)))/2
3297 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3298 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3299 & ' user-specified configuration'//' '
3300 WRITE(MSTU(11),5200) CHINIT
3301 WRITE(MSTU(11),5600)
3302 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3303 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3304 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3305 ENDIF
3306
3307C...Frame defined by user five-vectors.
3308 ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
3309 MINT(111)=5
3310 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3311 & (P(1,3)+P(2,3))**2
3312 IF(MSTP(122).GE.1) THEN
3313 LOFFS=(12-(LEN(2)+LEN(3)))/2
3314 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3315 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3316 & ' user-specified configuration'//' '
3317 WRITE(MSTU(11),5200) CHINIT
3318 WRITE(MSTU(11),5600)
3319 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3320 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3321 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3322 ENDIF
3323
3324C...Unknown frame. Error for too low CM energy.
3325 ELSE
3326 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
3327 STOP
3328 ENDIF
3329 IF(S.LT.PARP(2)**2) THEN
3330 WRITE(MSTU(11),5900) SQRT(S)
3331 STOP
3332 ENDIF
3333
3334C...Formats for initialization and error information.
3335 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
3336 &1X,'Execution stopped!')
3337 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
3338 &1X,'Execution stopped!')
3339 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
3340 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
3341 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
3342 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
3343 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
3344 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
3345 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
3346 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
3347 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
3348 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
3349 &1X,'Execution stopped!')
3350 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
3351 &'generation.'/1X,'Execution stopped!')
3352
3353 RETURN
3354 END
3355
3356C*********************************************************************
3357
3358*$ CREATE PYINKI.FOR
3359*COPY PYINKI
3360C...PYINKI
3361C...Sets up kinematics, including rotations and boosts to/from CM frame.
3362
3363 SUBROUTINE PYINKI(MODKI)
3364
3365C...Double precision and integer declarations.
3366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3367 INTEGER PYK,PYCHGE,PYCOMP
3368C...Commonblocks.
3369 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3372 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3373 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3374 COMMON/PYINT1/MINT(400),VINT(400)
3375 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3376
3377C...Set initial flavour state.
3378 N=2
3379 DO 100 I=1,2
3380 K(I,1)=1
3381 K(I,2)=MINT(10+I)
3382 100 CONTINUE
3383
3384C...Reset boost. Do kinematics for various cases.
3385 DO 110 J=6,10
3386 VINT(J)=0D0
3387 110 CONTINUE
3388
3389C...Set up kinematics for events defined in CM frame.
3390 IF(MINT(111).EQ.1) THEN
3391 WIN=VINT(290)
3392 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3393 S=WIN**2
3394 P(1,5)=VINT(3)
3395 P(2,5)=VINT(4)
3396 P(1,1)=0D0
3397 P(1,2)=0D0
3398 P(2,1)=0D0
3399 P(2,2)=0D0
3400 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
3401 & (4D0*S))
3402 P(2,3)=-P(1,3)
3403 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3404 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
3405
3406C...Set up kinematics for fixed target events.
3407 ELSEIF(MINT(111).EQ.2) THEN
3408 WIN=VINT(290)
3409 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3410 P(1,5)=VINT(3)
3411 P(2,5)=VINT(4)
3412 P(1,1)=0D0
3413 P(1,2)=0D0
3414 P(2,1)=0D0
3415 P(2,2)=0D0
3416 P(1,3)=WIN
3417 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3418 P(2,3)=0D0
3419 P(2,4)=P(2,5)
3420 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
3421 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
3422 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
3423
3424C...Set up kinematics for events in user-defined frame.
3425 ELSEIF(MINT(111).EQ.3) THEN
3426 P(1,5)=VINT(3)
3427 P(2,5)=VINT(4)
3428 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3429 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3430 DO 120 J=1,3
3431 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3432 120 CONTINUE
3433 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3434 VINT(7)=PYANGL(P(1,1),P(1,2))
3435 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3436 VINT(6)=PYANGL(P(1,3),P(1,1))
3437 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3438 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
3439
3440C...Set up kinematics for events with user-defined four-vectors.
3441 ELSEIF(MINT(111).EQ.4) THEN
3442 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3443 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3444 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3445 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3446 DO 130 J=1,3
3447 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3448 130 CONTINUE
3449 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3450 VINT(7)=PYANGL(P(1,1),P(1,2))
3451 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3452 VINT(6)=PYANGL(P(1,3),P(1,1))
3453 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3454 S=(P(1,4)+P(2,4))**2
3455
3456C...Set up kinematics for events with user-defined five-vectors.
3457 ELSEIF(MINT(111).EQ.5) THEN
3458 DO 140 J=1,3
3459 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3460 140 CONTINUE
3461 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3462 VINT(7)=PYANGL(P(1,1),P(1,2))
3463 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3464 VINT(6)=PYANGL(P(1,3),P(1,1))
3465 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3466 S=(P(1,4)+P(2,4))**2
3467 ENDIF
3468
3469C...Return or error for too low CM energy.
3470 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
3471 IF(MSTP(172).LE.1) THEN
3472 CALL PYERRM(23,
3473 & '(PYINKI:) too low invariant mass in this event')
3474 ELSE
3475 MSTI(61)=1
3476 RETURN
3477 ENDIF
3478 ENDIF
3479
3480C...Save information on incoming particles.
3481 VINT(1)=SQRT(S)
3482 VINT(2)=S
3483 IF(MINT(111).GE.4) VINT(3)=P(1,5)
3484 IF(MINT(111).GE.4) VINT(4)=P(2,5)
3485 VINT(5)=P(1,3)
3486 IF(MODKI.EQ.0) VINT(289)=S
3487 DO 150 J=1,5
3488 V(1,J)=0D0
3489 V(2,J)=0D0
3490 VINT(290+J)=P(1,J)
3491 VINT(295+J)=P(2,J)
3492 150 CONTINUE
3493
3494C...Store pT cut-off and related constants to be used in generation.
3495 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
3496 IF(MSTP(82).LE.1) THEN
3497 IF(MINT(121).GT.1) PARP(81)=1.30D0+0.15D0*LOG(VINT(1)/200D0)/
3498 & LOG(900D0/200D0)
3499 PTMN=PARP(81)
3500 ELSE
3501 IF(MINT(121).GT.1) PARP(82)=1.25D0+0.15D0*LOG(VINT(1)/200D0)/
3502 & LOG(900D0/200D0)
3503 PTMN=PARP(82)
3504 ENDIF
3505 VINT(149)=4D0*PTMN**2/S
3506
3507 RETURN
3508 END
3509
3510C*********************************************************************
3511
3512*$ CREATE PYINPR.FOR
3513*COPY PYINPR
3514C...PYINPR
3515C...Selects partonic subprocesses to be included in the simulation.
3516
3517 SUBROUTINE PYINPR
3518
3519C...Double precision and integer declarations.
3520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3521 INTEGER PYK,PYCHGE,PYCOMP
3522C...Commonblocks.
3523 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3524 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3525 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3526 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3527 COMMON/PYINT1/MINT(400),VINT(400)
3528 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3529 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
3530
3531C...Reset processes to be included.
3532 IF(MSEL.NE.0) THEN
3533 DO 100 I=1,500
3534 MSUB(I)=0
3535 100 CONTINUE
3536 ENDIF
3537
3538C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.
3539 IF(MINT(121).EQ.2) THEN
3540 MSUB(10)=1
3541 MINT(123)=MINT(122)+1
3542
3543C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.
3544C...Here also set a few parameters otherwise normally not touched.
3545 ELSEIF(MINT(121).GT.1) THEN
3546
3547C...Parton distributions dampened at small Q2; go to low energies,
3548C...alpha_s <1; no minimum pT cut-off a priori.
3549 MSTP(57)=3
3550 MSTP(85)=0
3551 PARP(2)=2D0
3552 PARU(115)=1D0
3553 CKIN(5)=0.2D0
3554 CKIN(6)=0.2D0
3555
3556C...Define pT cut-off parameters and whether run involves low-pT.
3557 IF(MSTP(82).LE.1) THEN
3558 PTMVMD=1.30D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3559 ELSE
3560 PTMVMD=1.25D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3561 ENDIF
3562 PTMDIR=PARP(15)
3563 PTMANO=PTMVMD
3564 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
3565 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
3566 IPTL=1
3567 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
3568 IF(MSEL.EQ.2) IPTL=1
3569
3570C...Set up for p/VMD * VMD.
3571 IF(MINT(122).EQ.1) THEN
3572 MINT(123)=2
3573 MSUB(11)=1
3574 MSUB(12)=1
3575 MSUB(13)=1
3576 MSUB(28)=1
3577 MSUB(53)=1
3578 MSUB(68)=1
3579 IF(IPTL.EQ.1) MSUB(95)=1
3580 IF(MSEL.EQ.2) THEN
3581 MSUB(91)=1
3582 MSUB(92)=1
3583 MSUB(93)=1
3584 MSUB(94)=1
3585 ENDIF
3586 PARP(81)=PTMVMD
3587 PARP(82)=PTMVMD
3588 IF(IPTL.EQ.1) CKIN(3)=0D0
3589
3590C...Set up for p/VMD * direct gamma.
3591 ELSEIF(MINT(122).EQ.2) THEN
3592 MINT(123)=0
3593 IF(MINT(121).EQ.6) MINT(123)=5
3594 MSUB(33)=1
3595 MSUB(54)=1
3596 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3597
3598C...Set up for p/VMD * anomalous gamma.
3599 ELSEIF(MINT(122).EQ.3) THEN
3600 MINT(123)=3
3601 IF(MINT(121).EQ.6) MINT(123)=7
3602 MSUB(11)=1
3603 MSUB(12)=1
3604 MSUB(13)=1
3605 MSUB(28)=1
3606 MSUB(53)=1
3607 MSUB(68)=1
3608 IF(MSTP(82).GE.2) MSTP(85)=1
3609 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3610
3611C...Set up for direct * direct gamma (switch off leptons).
3612 ELSEIF(MINT(122).EQ.4) THEN
3613 MINT(123)=0
3614 MSUB(58)=1
3615 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3616 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3617 110 CONTINUE
3618 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3619
3620C...Set up for direct * anomalous gamma.
3621 ELSEIF(MINT(122).EQ.5) THEN
3622 MINT(123)=6
3623 MSUB(33)=1
3624 MSUB(54)=1
3625 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3626
3627C...Set up for anomalous * anomalous gamma.
3628 ELSEIF(MINT(122).EQ.6) THEN
3629 MINT(123)=3
3630 MSUB(11)=1
3631 MSUB(12)=1
3632 MSUB(13)=1
3633 MSUB(28)=1
3634 MSUB(53)=1
3635 MSUB(68)=1
3636 IF(MSTP(82).GE.2) MSTP(85)=1
3637 IF(IPTL.EQ.1) CKIN(3)=PTMANO
3638 ENDIF
3639
3640C...End of special set up for gamma-p and gamma-gamma.
3641 CKIN(1)=2D0*CKIN(3)
3642 ENDIF
3643
3644C...Flavour information for individual beams.
3645 DO 120 I=1,2
3646 MINT(40+I)=1
3647 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
3648 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
3649 IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
3650 MINT(44+I)=MINT(40+I)
3651 IF(MSTP(11).GE.1.AND.IABS(MINT(10+I)).EQ.11) MINT(44+I)=3
3652 120 CONTINUE
3653
3654C...If two gammas, whereof one direct, pick the first.
3655 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3656 IF(MINT(123).GE.4.AND.MINT(123).LE.6) THEN
3657 MINT(41)=1
3658 MINT(45)=1
3659 ENDIF
3660 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
3661 IF(MINT(123).GE.4) CALL PYERRM(26,
3662 & '(PYINPR:) unallowed MSTP(14) code for single photon')
3663 ENDIF
3664
3665C...Flavour information on combination of incoming particles.
3666 MINT(43)=2*MINT(41)+MINT(42)-2
3667 MINT(44)=MINT(43)
3668 IF(MINT(123).LE.0) THEN
3669 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
3670 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
3671 ELSEIF(MINT(123).LE.3) THEN
3672 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
3673 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
3674 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3675 MINT(43)=4
3676 MINT(44)=1
3677 ENDIF
3678 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
3679 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
3680 MINT(50)=0
3681 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
3682 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.MINT(123).GE.3)
3683 &MINT(50)=0
3684 MINT(107)=0
3685 IF(MINT(11).EQ.22) THEN
3686 MINT(107)=MINT(123)
3687 IF(MINT(123).GE.4) MINT(107)=0
3688 IF(MINT(123).EQ.7) MINT(107)=2
3689 ENDIF
3690 MINT(108)=0
3691 IF(MINT(12).EQ.22) THEN
3692 MINT(108)=MINT(123)
3693 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
3694 IF(MINT(123).EQ.7) MINT(108)=3
3695 ENDIF
3696
3697C...Select default processes according to incoming beams
3698C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).
3699 IF(MINT(121).GT.1) THEN
3700 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
3701
3702 IF(MINT(43).EQ.1) THEN
3703C...Lepton + lepton -> gamma/Z0 or W.
3704 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
3705 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
3706
3707 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
3708 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
3709C...Unresolved photon + lepton: Compton scattering.
3710 MSUB(34)=1
3711
3712 ELSEIF(MINT(43).LE.3) THEN
3713C...Lepton + hadron: deep inelastic scattering.
3714 MSUB(10)=1
3715
3716 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
3717 & MINT(12).EQ.22) THEN
3718C...Two unresolved photons: fermion pair production.
3719 MSUB(58)=1
3720
3721 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
3722 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
3723 & MINT(12).EQ.22)) THEN
3724C...Unresolved photon + hadron: photon-parton scattering.
3725 MSUB(33)=1
3726 MSUB(34)=1
3727 MSUB(54)=1
3728
3729 ELSEIF(MSEL.EQ.1) THEN
3730C...High-pT QCD processes:
3731 MSUB(11)=1
3732 MSUB(12)=1
3733 MSUB(13)=1
3734 MSUB(28)=1
3735 MSUB(53)=1
3736 MSUB(68)=1
3737 IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
3738 IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
3739 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
3740
3741 ELSE
3742C...All QCD processes:
3743 MSUB(11)=1
3744 MSUB(12)=1
3745 MSUB(13)=1
3746 MSUB(28)=1
3747 MSUB(53)=1
3748 MSUB(68)=1
3749 MSUB(91)=1
3750 MSUB(92)=1
3751 MSUB(93)=1
3752 MSUB(94)=1
3753 MSUB(95)=1
3754 ENDIF
3755
3756 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
3757C...Heavy quark production.
3758 MSUB(81)=1
3759 MSUB(82)=1
3760 MSUB(84)=1
3761 DO 130 J=1,MIN(8,MDCY(21,3))
3762 MDME(MDCY(21,2)+J-1,1)=0
3763 130 CONTINUE
3764 MDME(MDCY(21,2)+MSEL-1,1)=1
3765 MSUB(85)=1
3766 DO 140 J=1,MIN(12,MDCY(22,3))
3767 MDME(MDCY(22,2)+J-1,1)=0
3768 140 CONTINUE
3769 MDME(MDCY(22,2)+MSEL-1,1)=1
3770
3771 ELSEIF(MSEL.EQ.10) THEN
3772C...Prompt photon production:
3773 MSUB(14)=1
3774 MSUB(18)=1
3775 MSUB(29)=1
3776
3777 ELSEIF(MSEL.EQ.11) THEN
3778C...Z0/gamma* production:
3779 MSUB(1)=1
3780
3781 ELSEIF(MSEL.EQ.12) THEN
3782C...W+/- production:
3783 MSUB(2)=1
3784
3785 ELSEIF(MSEL.EQ.13) THEN
3786C...Z0 + jet:
3787 MSUB(15)=1
3788 MSUB(30)=1
3789
3790 ELSEIF(MSEL.EQ.14) THEN
3791C...W+/- + jet:
3792 MSUB(16)=1
3793 MSUB(31)=1
3794
3795 ELSEIF(MSEL.EQ.15) THEN
3796C...Z0 & W+/- pair production:
3797 MSUB(19)=1
3798 MSUB(20)=1
3799 MSUB(22)=1
3800 MSUB(23)=1
3801 MSUB(25)=1
3802
3803 ELSEIF(MSEL.EQ.16) THEN
3804C...h0 production:
3805 MSUB(3)=1
3806 MSUB(102)=1
3807 MSUB(103)=1
3808 MSUB(123)=1
3809 MSUB(124)=1
3810
3811 ELSEIF(MSEL.EQ.17) THEN
3812C...h0 & Z0 or W+/- pair production:
3813 MSUB(24)=1
3814 MSUB(26)=1
3815
3816 ELSEIF(MSEL.EQ.18) THEN
3817C...h0 production; interesting processes in e+e-.
3818 MSUB(24)=1
3819 MSUB(103)=1
3820 MSUB(123)=1
3821 MSUB(124)=1
3822
3823 ELSEIF(MSEL.EQ.19) THEN
3824C...h0, H0 and A0 production; interesting processes in e+e-.
3825 MSUB(24)=1
3826 MSUB(103)=1
3827 MSUB(123)=1
3828 MSUB(124)=1
3829 MSUB(153)=1
3830 MSUB(171)=1
3831 MSUB(173)=1
3832 MSUB(174)=1
3833 MSUB(158)=1
3834 MSUB(176)=1
3835 MSUB(178)=1
3836 MSUB(179)=1
3837
3838 ELSEIF(MSEL.EQ.21) THEN
3839C...Z'0 production:
3840 MSUB(141)=1
3841
3842 ELSEIF(MSEL.EQ.22) THEN
3843C...W'+/- production:
3844 MSUB(142)=1
3845
3846 ELSEIF(MSEL.EQ.23) THEN
3847C...H+/- production:
3848 MSUB(143)=1
3849
3850 ELSEIF(MSEL.EQ.24) THEN
3851C...R production:
3852 MSUB(144)=1
3853
3854 ELSEIF(MSEL.EQ.25) THEN
3855C...LQ (leptoquark) production.
3856 MSUB(145)=1
3857 MSUB(162)=1
3858 MSUB(163)=1
3859 MSUB(164)=1
3860
3861 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
3862C...Production of one heavy quark (W exchange):
3863 MSUB(83)=1
3864 DO 150 J=1,MIN(8,MDCY(21,3))
3865 MDME(MDCY(21,2)+J-1,1)=0
3866 150 CONTINUE
3867 MDME(MDCY(21,2)+MSEL-31,1)=1
3868
3869CMRENNA++Define SUSY alternatives.
3870 ELSEIF(MSEL.EQ.39) THEN
3871C...Turn on all SUSY processes.
3872 IF(MINT(43).EQ.4) THEN
3873C...Hadron-hadron processes.
3874 DO 160 I=201,280
3875 IF(ISET(I).GE.0) MSUB(I)=1
3876 160 CONTINUE
3877 ELSEIF(MINT(43).EQ.1) THEN
3878C...Lepton-lepton processes: QED production of squarks.
3879 DO 170 I=201,214
3880 MSUB(I)=1
3881 170 CONTINUE
3882 MSUB(210)=0
3883 MSUB(211)=0
3884 MSUB(212)=0
3885 DO 180 I=216,228
3886 MSUB(I)=1
3887 180 CONTINUE
3888 DO 190 I=261,263
3889 MSUB(I)=1
3890 190 CONTINUE
3891 MSUB(277)=1
3892 MSUB(278)=1
3893 ENDIF
3894
3895 ELSEIF(MSEL.EQ.40) THEN
3896C...Gluinos and squarks.
3897 IF(MINT(43).EQ.4) THEN
3898 MSUB(243)=1
3899 MSUB(244)=1
3900 MSUB(258)=1
3901 MSUB(259)=1
3902 MSUB(261)=1
3903 MSUB(262)=1
3904 MSUB(264)=1
3905 MSUB(265)=1
3906 DO 200 I=271,280
3907 MSUB(I)=1
3908 200 CONTINUE
3909 ELSEIF(MINT(43).EQ.1) THEN
3910 MSUB(277)=1
3911 MSUB(278)=1
3912 ENDIF
3913
3914 ELSEIF(MSEL.EQ.41) THEN
3915C...Stop production.
3916 MSUB(261)=1
3917 MSUB(262)=1
3918 MSUB(263)=1
3919 IF(MINT(43).EQ.4) THEN
3920 MSUB(264)=1
3921 MSUB(265)=1
3922 ENDIF
3923
3924 ELSEIF(MSEL.EQ.42) THEN
3925C...Slepton production.
3926 DO 210 I=201,214
3927 MSUB(I)=1
3928 210 CONTINUE
3929 IF(MINT(43).NE.4) THEN
3930 MSUB(210)=0
3931 MSUB(211)=0
3932 MSUB(212)=0
3933 ENDIF
3934
3935 ELSEIF(MSEL.EQ.43) THEN
3936C...Neutralino/Chargino + Gluino/Squark.
3937 IF(MINT(43).EQ.4) THEN
3938 DO 220 I=237,242
3939 MSUB(I)=1
3940 220 CONTINUE
3941 DO 230 I=246,257
3942 MSUB(I)=1
3943 230 CONTINUE
3944 ENDIF
3945
3946 ELSEIF(MSEL.EQ.44) THEN
3947C...Neutralino/Chargino pair production.
3948 IF(MINT(43).EQ.4) THEN
3949 DO 240 I=216,236
3950 MSUB(I)=1
3951 240 CONTINUE
3952 ELSEIF(MINT(43).EQ.1) THEN
3953 DO 250 I=216,228
3954 MSUB(I)=1
3955 250 CONTINUE
3956 ENDIF
3957 ENDIF
3958
3959C...Find heaviest new quark flavour allowed in processes 81-84.
3960 KFLQM=1
3961 DO 260 I=1,MIN(8,MDCY(21,3))
3962 IDC=I+MDCY(21,2)-1
3963 IF(MDME(IDC,1).LE.0) GOTO 260
3964 KFLQM=I
3965 260 CONTINUE
3966 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
3967 &KFLQM=MSTP(7)
3968 MINT(55)=KFLQM
3969 KFPR(81,1)=KFLQM
3970 KFPR(81,2)=KFLQM
3971 KFPR(82,1)=KFLQM
3972 KFPR(82,2)=KFLQM
3973 KFPR(83,1)=KFLQM
3974 KFPR(84,1)=KFLQM
3975 KFPR(84,2)=KFLQM
3976
3977C...Find heaviest new fermion flavour allowed in process 85.
3978 KFLFM=1
3979 DO 270 I=1,MIN(12,MDCY(22,3))
3980 IDC=I+MDCY(22,2)-1
3981 IF(MDME(IDC,1).LE.0) GOTO 270
3982 KFLFM=KFDP(IDC,1)
3983 270 CONTINUE
3984 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
3985 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
3986 MINT(56)=KFLFM
3987 KFPR(85,1)=KFLFM
3988 KFPR(85,2)=KFLFM
3989
3990 RETURN
3991 END
3992
3993C*********************************************************************
3994
3995*$ CREATE PYXTOT.FOR
3996*COPY PYXTOT
3997C...PYXTOT
3998C...Parametrizes total, elastic and diffractive cross-sections
3999C...for different energies and beams. Donnachie-Landshoff for
4000C...total and Schuler-Sjostrand for elastic and diffractive.
4001C...Process code IPROC:
4002C...= 1 : p + p;
4003C...= 2 : pbar + p;
4004C...= 3 : pi+ + p;
4005C...= 4 : pi- + p;
4006C...= 5 : pi0 + p;
4007C...= 6 : phi + p;
4008C...= 7 : J/psi + p;
4009C...= 11 : rho + rho;
4010C...= 12 : rho + phi;
4011C...= 13 : rho + J/psi;
4012C...= 14 : phi + phi;
4013C...= 15 : phi + J/psi;
4014C...= 16 : J/psi + J/psi;
4015C...= 21 : gamma + p (DL);
4016C...= 22 : gamma + p (VDM).
4017C...= 23 : gamma + pi (DL);
4018C...= 24 : gamma + pi (VDM);
4019C...= 25 : gamma + gamma (DL);
4020C...= 26 : gamma + gamma (VDM).
4021
4022 SUBROUTINE PYXTOT
4023
4024C...Double precision and integer declarations.
4025 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4026 INTEGER PYK,PYCHGE,PYCOMP
4027C...Commonblocks.
4028 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4029 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4030 COMMON/PYINT1/MINT(400),VINT(400)
4031 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4032 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4033 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
4034C...Local arrays.
4035 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
4036 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
4037 &CEFFD(10,9),SIGTMP(6,0:5)
4038
4039C...Common constants.
4040 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
4041 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
4042 &FACDD/0.0084D0/
4043
4044C...Number of multiple processes to be evaluated (= 0 : undefined).
4045 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4046C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4047 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
4048 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
4049 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
4050 DATA YPAR/
4051 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
4052 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
4053 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
4054
4055C...Beam and target hadron class:
4056C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4057 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4058 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
4059C...Characteristic class masses, slope parameters, beta = sqrt(X).
4060 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
4061 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
4062 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
4063
4064C...Fitting constants used in parametrizations of diffractive results.
4065 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4066 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4067 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
4068 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
4069 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
4070 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
4071 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
4072 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
4073 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
4074 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
4075 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
4076 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
4077 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
4078 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
4079 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
4080 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
4081 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
4082 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
4083 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
4084 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
4085 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
4086 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
4087 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
4088 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
4089 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
4090 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
4091 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
4092 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
4093 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
4094
4095C...Parameters. Combinations of the energy.
4096 AEM=PARU(101)
4097 PMTH=PARP(102)
4098 S=VINT(2)
4099 SRT=VINT(1)
4100 SEPS=S**EPS
4101 SETA=S**ETA
4102 SLOG=LOG(S)
4103
4104C...Ratio of gamma/pi (for rescaling in parton distributions).
4105 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
4106 &(XPAR(5)*SEPS+YPAR(5)*SETA)
4107 IF(MINT(50).NE.1) RETURN
4108
4109C...Order flavours of incoming particles: KF1 < KF2.
4110 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
4111 KF1=IABS(MINT(11))
4112 KF2=IABS(MINT(12))
4113 IORD=1
4114 ELSE
4115 KF1=IABS(MINT(12))
4116 KF2=IABS(MINT(11))
4117 IORD=2
4118 ENDIF
4119 ISGN12=ISIGN(1,MINT(11)*MINT(12))
4120
4121C...Find process number (for lookup tables).
4122 IF(KF1.GT.1000) THEN
4123 IPROC=1
4124 IF(ISGN12.LT.0) IPROC=2
4125 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
4126 IPROC=3
4127 IF(ISGN12.LT.0) IPROC=4
4128 IF(KF1.EQ.111) IPROC=5
4129 ELSEIF(KF1.GT.100) THEN
4130 IPROC=11
4131 ELSEIF(KF2.GT.1000) THEN
4132 IPROC=21
4133 IF(MINT(123).EQ.2) IPROC=22
4134 ELSEIF(KF2.GT.100) THEN
4135 IPROC=23
4136 IF(MINT(123).EQ.2) IPROC=24
4137 ELSE
4138 IPROC=25
4139 IF(MINT(123).EQ.2) IPROC=26
4140 ENDIF
4141
4142C... Number of multiple processes to be stored; beam/target side.
4143 NPR=NPROC(IPROC)
4144 MINT(101)=1
4145 MINT(102)=1
4146 IF(NPR.EQ.3) THEN
4147 MINT(100+IORD)=4
4148 ELSEIF(NPR.EQ.6) THEN
4149 MINT(101)=4
4150 MINT(102)=4
4151 ENDIF
4152 N1=0
4153 IF(MINT(101).EQ.4) N1=4
4154 N2=0
4155 IF(MINT(102).EQ.4) N2=4
4156
4157C...Do not do any more for user-set or undefined cross-sections.
4158 IF(MSTP(31).LE.0) RETURN
4159 IF(NPR.EQ.0) CALL PYERRM(26,
4160 &'(PYXTOT:) cross section for this process not yet implemented')
4161
4162C...Parameters. Combinations of the energy.
4163 AEM=PARU(101)
4164 PMTH=PARP(102)
4165 S=VINT(2)
4166 SRT=VINT(1)
4167 SEPS=S**EPS
4168 SETA=S**ETA
4169 SLOG=LOG(S)
4170
4171C...Loop over multiple processes (for VDM).
4172 DO 110 I=1,NPR
4173 IF(NPR.EQ.1) THEN
4174 IPR=IPROC
4175 ELSEIF(NPR.EQ.3) THEN
4176 IPR=I+4
4177 IF(KF2.LT.1000) IPR=I+10
4178 ELSEIF(NPR.EQ.6) THEN
4179 IPR=I+10
4180 ENDIF
4181
4182C...Evaluate hadron species, mass, slope contribution and fit number.
4183 IHA=IHADA(IPR)
4184 IHB=IHADB(IPR)
4185 PMA=PMHAD(IHA)
4186 PMB=PMHAD(IHB)
4187 BHA=BHAD(IHA)
4188 BHB=BHAD(IHB)
4189 ISD=IFITSD(IPR)
4190 IDD=IFITDD(IPR)
4191
4192C...Skip if energy too low relative to masses.
4193 DO 100 J=0,5
4194 SIGTMP(I,J)=0D0
4195 100 CONTINUE
4196 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
4197
4198C...Total cross-section. Elastic slope parameter and cross-section.
4199 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
4200 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
4201 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
4202
4203C...Diffractive scattering A + B -> X + B.
4204 BSD=2D0*BHB
4205 SQML=(PMA+PMTH)**2
4206 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
4207 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4208 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4209 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
4210 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
4211 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
4212 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
4213
4214C...Diffractive scattering A + B -> A + X.
4215 BSD=2D0*BHA
4216 SQML=(PMB+PMTH)**2
4217 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
4218 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4219 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4220 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
4221 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
4222 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
4223 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
4224
4225C...Order single diffractive correctly.
4226 IF(IORD.EQ.2) THEN
4227 SIGSAV=SIGTMP(I,2)
4228 SIGTMP(I,2)=SIGTMP(I,3)
4229 SIGTMP(I,3)=SIGSAV
4230 ENDIF
4231
4232C...Double diffractive scattering A + B -> X1 + X2.
4233 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
4234 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
4235 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
4236 IF(YEFF.LE.0) SUM1=0D0
4237 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
4238 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
4239 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
4240 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
4241 & (2D0*ALP)
4242 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
4243 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
4244 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
4245 & (2D0*ALP)
4246 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
4247 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
4248 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
4249 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
4250 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
4251
4252C...Non-diffractive by unitarity.
4253 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
4254 & SIGTMP(I,4)
4255 110 CONTINUE
4256
4257C...Put temporary results in output array: only one process.
4258 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
4259 DO 120 J=0,5
4260 SIGT(0,0,J)=SIGTMP(1,J)
4261 120 CONTINUE
4262
4263C...Beam multiple processes.
4264 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
4265 DO 140 I=1,4
4266 CONV=AEM/PARP(160+I)
4267 I1=MAX(1,I-1)
4268 DO 130 J=0,5
4269 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
4270 130 CONTINUE
4271 140 CONTINUE
4272 DO 150 J=0,5
4273 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4274 150 CONTINUE
4275
4276C...Target multiple processes.
4277 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
4278 DO 170 I=1,4
4279 CONV=AEM/PARP(160+I)
4280 IV=MAX(1,I-1)
4281 DO 160 J=0,5
4282 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
4283 160 CONTINUE
4284 170 CONTINUE
4285 DO 180 J=0,5
4286 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
4287 180 CONTINUE
4288
4289C...Both beam and target multiple processes.
4290 ELSE
4291 DO 210 I1=1,4
4292 DO 200 I2=1,4
4293 CONV=AEM**2/(PARP(160+I1)*PARP(160+I2))
4294 IF(I1.LE.2) THEN
4295 IV=MAX(1,I2-1)
4296 ELSEIF(I2.LE.2) THEN
4297 IV=MAX(1,I1-1)
4298 ELSEIF(I1.EQ.I2) THEN
4299 IV=2*I1-2
4300 ELSE
4301 IV=5
4302 ENDIF
4303 DO 190 J=0,5
4304 JV=J
4305 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
4306 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
4307 190 CONTINUE
4308 200 CONTINUE
4309 210 CONTINUE
4310 DO 230 J=0,5
4311 DO 220 I=1,4
4312 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
4313 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
4314 220 CONTINUE
4315 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4316 230 CONTINUE
4317 ENDIF
4318
4319C...Scale up uniformly for Donnachie-Landshoff parametrization.
4320 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
4321 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
4322 DO 260 I1=0,N1
4323 DO 250 I2=0,N2
4324 DO 240 J=0,5
4325 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
4326 240 CONTINUE
4327 250 CONTINUE
4328 260 CONTINUE
4329 ENDIF
4330
4331 RETURN
4332 END
4333
4334C*********************************************************************
4335
4336*$ CREATE PYMAXI.FOR
4337*COPY PYMAXI
4338C...PYMAXI
4339C...Finds optimal set of coefficients for kinematical variable selection
4340C...and the maximum of the part of the differential cross-section used
4341C...in the event weighting.
4342
4343 SUBROUTINE PYMAXI
4344
4345C...Double precision and integer declarations.
4346 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4347 INTEGER PYK,PYCHGE,PYCOMP
4348C...Parameter statement to help give large particle numbers.
4349 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
4350C...Commonblocks.
4351 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4352 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4353 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
4354 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4355 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4356 COMMON/PYINT1/MINT(400),VINT(400)
4357 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4358 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
4359 COMMON/PYINT4/MWID(500),WIDS(500,5)
4360 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4361 COMMON/PYINT6/PROC(0:500)
4362 CHARACTER PROC*28
4363 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4364 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4365 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
4366C...Local arrays, character variables and data.
4367 CHARACTER CVAR(4)*4
4368 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
4369 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
4370 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
4371 DATA CVAR/'tau ','tau''','y* ','cth '/
4372 DATA SIGSSM/3*0D0/
4373
4374C...Select subprocess to study: skip cases not applicable.
4375 NPOSI=0
4376 VINT(143)=1D0
4377 VINT(144)=1D0
4378 XSEC(0,1)=0D0
4379 DO 460 ISUB=1,500
4380 MINT(51)=0
4381 IF(ISET(ISUB).EQ.11) THEN
4382 XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
4383 NPOSI=NPOSI+1
4384 GOTO 450
4385 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
4386 XSEC(ISUB,1)=SIGT(0,0,ISUB-90)
4387 IF(MSUB(ISUB).NE.1) GOTO 460
4388 NPOSI=NPOSI+1
4389 GOTO 450
4390 ELSEIF(ISUB.EQ.96) THEN
4391 IF(MINT(50).EQ.0) GOTO 460
4392 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
4393 & GOTO 460
4394 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
4395 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
4396 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
4397 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
4398 ELSE
4399 IF(MSUB(ISUB).NE.1) GOTO 460
4400 ENDIF
4401 MINT(1)=ISUB
4402 ISTSB=ISET(ISUB)
4403 IF(ISUB.EQ.96) ISTSB=2
4404 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
4405 MWTXS=0
4406 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
4407 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
4408
4409C...Find resonances (explicit or implicit in cross-section).
4410 MINT(72)=0
4411 KFR1=0
4412 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
4413 KFR1=KFPR(ISUB,1)
4414 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
4415 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
4416 KFR1=23
4417 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
4418 & .OR.ISUB.EQ.177) THEN
4419 KFR1=24
4420 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
4421 KFR1=25
4422 IF(MSTP(46).EQ.5) THEN
4423 KFR1=30
4424 PMAS(30,1)=PARP(45)
4425 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
4426 ENDIF
4427 ELSEIF(ISUB.EQ.194) THEN
4428 KFR1=54
4429 ENDIF
4430 CKMX=CKIN(2)
4431 IF(CKMX.LE.0D0) CKMX=VINT(1)
4432 KCR1=PYCOMP(KFR1)
4433 IF(KFR1.NE.0) THEN
4434 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
4435 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
4436 ENDIF
4437 IF(KFR1.NE.0) THEN
4438 TAUR1=PMAS(KCR1,1)**2/VINT(2)
4439 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
4440 MINT(72)=1
4441 MINT(73)=KFR1
4442 VINT(73)=TAUR1
4443 VINT(74)=GAMR1
4444 ENDIF
4445 KFR2=0
4446 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
4447 KFR2=23
4448 IF(ISUB.EQ.194) KFR2=56
4449 KCR2=PYCOMP(KFR2)
4450 TAUR2=PMAS(KCR2,1)**2/VINT(2)
4451 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
4452 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
4453 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
4454 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
4455 MINT(72)=2
4456 MINT(74)=KFR2
4457 VINT(75)=TAUR2
4458 VINT(76)=GAMR2
4459 ELSEIF(KFR2.NE.0) THEN
4460 KFR1=KFR2
4461 TAUR1=TAUR2
4462 GAMR1=GAMR2
4463 MINT(72)=1
4464 MINT(73)=KFR1
4465 VINT(73)=TAUR1
4466 VINT(74)=GAMR1
4467 KFR2=0
4468 ENDIF
4469 ENDIF
4470
4471C...Find product masses and minimum pT of process.
4472 SQM3=0D0
4473 SQM4=0D0
4474 MINT(71)=0
4475 VINT(71)=CKIN(3)
4476 VINT(80)=1D0
4477 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4478 NBW=0
4479 DO 110 I=1,2
4480 PMMN(I)=0D0
4481 IF(KFPR(ISUB,I).EQ.0) THEN
4482 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
4483 & PARP(41)) THEN
4484 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4485 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4486 ELSE
4487 NBW=NBW+1
4488C...This prevents SUSY/t particles from becoming too light.
4489 KFLW=KFPR(ISUB,I)
4490 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
4491 KCW=PYCOMP(KFLW)
4492 PMMN(I)=PMAS(KCW,1)
4493 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
4494 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
4495 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
4496 & PMAS(PYCOMP(KFDP(IDC,2)),1)
4497 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
4498 & PMAS(PYCOMP(KFDP(IDC,3)),1)
4499 PMMN(I)=MIN(PMMN(I),PMSUM)
4500 ENDIF
4501 100 CONTINUE
4502 ELSEIF(KFLW.EQ.6) THEN
4503 PMMN(I)=PMAS(24,1)+PMAS(5,1)
4504 ENDIF
4505 ENDIF
4506 110 CONTINUE
4507 IF(NBW.GE.1) THEN
4508 CKIN41=CKIN(41)
4509 CKIN43=CKIN(43)
4510 CKIN(41)=MAX(PMMN(1),CKIN(41))
4511 CKIN(43)=MAX(PMMN(2),CKIN(43))
4512 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
4513 CKIN(41)=CKIN41
4514 CKIN(43)=CKIN43
4515 IF(MINT(51).EQ.1) THEN
4516 WRITE(MSTU(11),5100) ISUB
4517 MSUB(ISUB)=0
4518 GOTO 460
4519 ENDIF
4520 SQM3=PQM3**2
4521 SQM4=PQM4**2
4522 ENDIF
4523 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
4524 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
4525 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
4526 IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08D0*PARP(82)
4527 ENDIF
4528 VINT(63)=SQM3
4529 VINT(64)=SQM4
4530
4531C...Prepare for additional variable choices in 2 -> 3.
4532 IF(ISTSB.EQ.5) THEN
4533 VINT(201)=0D0
4534 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
4535 VINT(206)=VINT(201)
4536 VINT(204)=PMAS(23,1)
4537 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
4538 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
4539 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
4540 VINT(209)=VINT(204)
4541 ENDIF
4542
4543C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
4544 NPTS(1)=2+2*MINT(72)
4545 IF(MINT(47).EQ.1) THEN
4546 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
4547 ELSEIF(MINT(47).EQ.5) THEN
4548 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
4549 ENDIF
4550 NPTS(2)=1
4551 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
4552 IF(MINT(47).GE.2) NPTS(2)=2
4553 IF(MINT(47).EQ.5) NPTS(2)=3
4554 ENDIF
4555 NPTS(3)=1
4556 IF(MINT(47).GE.4) NPTS(3)=3
4557 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
4558 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
4559 NPTS(4)=1
4560 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
4561 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
4562
4563C...Reset coefficients of cross-section weighting.
4564 DO 120 J=1,20
4565 COEF(ISUB,J)=0D0
4566 120 CONTINUE
4567 COEF(ISUB,1)=1D0
4568 COEF(ISUB,8)=0.5D0
4569 COEF(ISUB,9)=0.5D0
4570 COEF(ISUB,13)=1D0
4571 COEF(ISUB,18)=1D0
4572 MCTH=0
4573 MTAUP=0
4574 METAUP=0
4575 VINT(23)=0D0
4576 VINT(26)=0D0
4577 SIGSAM=0D0
4578
4579C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
4580C...in grid of phase space points.
4581 CALL PYKLIM(1)
4582 METAU=MINT(51)
4583 NACC=0
4584 DO 150 ITRY=1,NTRY
4585 MINT(51)=0
4586 IF(METAU.EQ.1) GOTO 150
4587 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
4588 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
4589 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
4590 RTAU=0.5D0
4591C...Special case when both resonances have same mass,
4592C...as is often the case in process 194.
4593 IF(MINT(72).EQ.2) THEN
4594 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
4595 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
4596 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
4597 RTAU=0.4D0
4598 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
4599 RTAU=0.6D0
4600 ENDIF
4601 ENDIF
4602 ENDIF
4603 CALL PYKMAP(1,MTAU,RTAU)
4604 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
4605 METAUP=MINT(51)
4606 ENDIF
4607 IF(METAUP.EQ.1) GOTO 150
4608 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
4609 & .EQ.0) THEN
4610 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
4611 CALL PYKMAP(4,MTAUP,0.5D0)
4612 ENDIF
4613 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
4614 CALL PYKLIM(2)
4615 MEYST=MINT(51)
4616 ENDIF
4617 IF(MEYST.EQ.1) GOTO 150
4618 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
4619 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
4620 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
4621 CALL PYKMAP(2,MYST,0.5D0)
4622 CALL PYKLIM(3)
4623 MECTH=MINT(51)
4624 ENDIF
4625 IF(MECTH.EQ.1) GOTO 150
4626 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4627 MCTH=1+MOD(ITRY-1,NPTS(4))
4628 CALL PYKMAP(3,MCTH,0.5D0)
4629 ENDIF
4630 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
4631
4632C...Store position and limits.
4633 MINT(51)=0
4634 CALL PYKLIM(0)
4635 IF(MINT(51).EQ.1) GOTO 150
4636 NACC=NACC+1
4637 MVARPT(NACC,1)=MTAU
4638 MVARPT(NACC,2)=MTAUP
4639 MVARPT(NACC,3)=MYST
4640 MVARPT(NACC,4)=MCTH
4641 DO 130 J=1,30
4642 VINTPT(NACC,J)=VINT(10+J)
4643 130 CONTINUE
4644
4645C...Normal case: calculate cross-section.
4646 IF(ISTSB.NE.5) THEN
4647 CALL PYSIGH(NCHN,SIGS)
4648 IF(MWTXS.EQ.1) THEN
4649 CALL PYEVWT(WTXS)
4650 SIGS=WTXS*SIGS
4651 ENDIF
4652
4653C..2 -> 3: find highest value out of a number of tries.
4654 ELSE
4655 SIGS=0D0
4656 DO 140 IKIN3=1,MSTP(129)
4657 CALL PYKMAP(5,0,0D0)
4658 IF(MINT(51).EQ.1) GOTO 140
4659 CALL PYSIGH(NCHN,SIGTMP)
4660 IF(MWTXS.EQ.1) THEN
4661 CALL PYEVWT(WTXS)
4662 SIGTMP=WTXS*SIGTMP
4663 ENDIF
4664 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4665 140 CONTINUE
4666 ENDIF
4667
4668C...Store cross-section.
4669 SIGSPT(NACC)=SIGS
4670 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
4671 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
4672 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
4673 150 CONTINUE
4674 IF(NACC.EQ.0) THEN
4675 WRITE(MSTU(11),5100) ISUB
4676 MSUB(ISUB)=0
4677 GOTO 460
4678 ELSEIF(SIGSAM.EQ.0D0) THEN
4679 WRITE(MSTU(11),5300) ISUB
4680 MSUB(ISUB)=0
4681 GOTO 460
4682 ENDIF
4683 IF(ISUB.NE.96) NPOSI=NPOSI+1
4684
4685C...Calculate integrals in tau over maximal phase space limits.
4686 TAUMIN=VINT(11)
4687 TAUMAX=VINT(31)
4688 ATAU1=LOG(TAUMAX/TAUMIN)
4689 IF(NPTS(1).GE.2) THEN
4690 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
4691 ENDIF
4692 IF(NPTS(1).GE.4) THEN
4693 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
4694 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
4695 & GAMR1
4696 ENDIF
4697 IF(NPTS(1).GE.6) THEN
4698 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
4699 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
4700 & GAMR2
4701 ENDIF
4702 IF(NPTS(1).GT.2+2*MINT(72)) THEN
4703 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
4704 ENDIF
4705
4706C...Reset. Sum up cross-sections in points calculated.
4707 DO 320 IVAR=1,4
4708 IF(NPTS(IVAR).EQ.1) GOTO 320
4709 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
4710 NBIN=NPTS(IVAR)
4711 DO 170 J1=1,NBIN
4712 NAREL(J1)=0
4713 WTREL(J1)=0D0
4714 COEFU(J1)=0D0
4715 DO 160 J2=1,NBIN
4716 WTMAT(J1,J2)=0D0
4717 160 CONTINUE
4718 170 CONTINUE
4719 DO 180 IACC=1,NACC
4720 IBIN=MVARPT(IACC,IVAR)
4721 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
4722 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
4723 NAREL(IBIN)=NAREL(IBIN)+1
4724 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
4725
4726C...Sum up tau cross-section pieces in points used.
4727 IF(IVAR.EQ.1) THEN
4728 TAU=VINTPT(IACC,11)
4729 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4730 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
4731 IF(NBIN.GE.4) THEN
4732 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
4733 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
4734 & ((TAU-TAUR1)**2+GAMR1**2)
4735 ENDIF
4736 IF(NBIN.GE.6) THEN
4737 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
4738 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
4739 & ((TAU-TAUR2)**2+GAMR2**2)
4740 ENDIF
4741 IF(NBIN.GT.2+2*MINT(72)) THEN
4742 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
4743 & TAU/MAX(2D-6,1D0-TAU)
4744 ENDIF
4745
4746C...Sum up tau' cross-section pieces in points used.
4747 ELSEIF(IVAR.EQ.2) THEN
4748 TAU=VINTPT(IACC,11)
4749 TAUP=VINTPT(IACC,16)
4750 TAUPMN=VINTPT(IACC,6)
4751 TAUPMX=VINTPT(IACC,26)
4752 ATAUP1=LOG(TAUPMX/TAUPMN)
4753 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
4754 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4755 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
4756 & (1D0-TAU/TAUP)**3/TAUP
4757 IF(NBIN.GE.3) THEN
4758 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
4759 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
4760 & TAUP/MAX(2D-6,1D0-TAUP)
4761 ENDIF
4762
4763C...Sum up y* cross-section pieces in points used.
4764 ELSEIF(IVAR.EQ.3) THEN
4765 YST=VINTPT(IACC,12)
4766 YSTMIN=VINTPT(IACC,2)
4767 YSTMAX=VINTPT(IACC,22)
4768 AYST0=YSTMAX-YSTMIN
4769 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
4770 AYST2=AYST1
4771 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
4772 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
4773 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
4774 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
4775 IF(MINT(45).EQ.3) THEN
4776 TAUE=VINTPT(IACC,11)
4777 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4778 YST0=-0.5D0*LOG(TAUE)
4779 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
4780 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
4781 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
4782 & MAX(1D-6,1D0-EXP(YST-YST0))
4783 ENDIF
4784 IF(MINT(46).EQ.3) THEN
4785 TAUE=VINTPT(IACC,11)
4786 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4787 YST0=-0.5D0*LOG(TAUE)
4788 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
4789 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
4790 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
4791 & MAX(1D-6,1D0-EXP(-YST-YST0))
4792 ENDIF
4793
4794C...Sum up cos(theta-hat) cross-section pieces in points used.
4795 ELSE
4796 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
4797 RSQM=1D0+RM34
4798 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
4799 CTHMIN=-CTHMAX
4800 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
4801 & (TAUMAX*VINT(2)))
4802 ACTH1=CTHMAX-CTHMIN
4803 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
4804 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
4805 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
4806 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
4807 CTH=VINTPT(IACC,13)
4808 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4809 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
4810 & MAX(RM34,RSQM-CTH)
4811 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
4812 & MAX(RM34,RSQM+CTH)
4813 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
4814 & MAX(RM34,RSQM-CTH)**2
4815 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
4816 & MAX(RM34,RSQM+CTH)**2
4817 ENDIF
4818 180 CONTINUE
4819
4820C...Check that equation system solvable.
4821 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
4822 MSOLV=1
4823 WTRELS=0D0
4824 DO 190 IBIN=1,NBIN
4825 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
4826 & IRED=1,NBIN),WTREL(IBIN)
4827 IF(NAREL(IBIN).EQ.0) MSOLV=0
4828 WTRELS=WTRELS+WTREL(IBIN)
4829 190 CONTINUE
4830 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
4831
4832C...Solve to find relative importance of cross-section pieces.
4833 IF(MSOLV.EQ.1) THEN
4834 DO 200 IBIN=1,NBIN
4835 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
4836 200 CONTINUE
4837 DO 230 IRED=1,NBIN-1
4838 DO 220 IBIN=IRED+1,NBIN
4839 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
4840 MSOLV=0
4841 GOTO 260
4842 ENDIF
4843 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
4844 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
4845 DO 210 ICOE=IRED,NBIN
4846 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
4847 210 CONTINUE
4848 220 CONTINUE
4849 230 CONTINUE
4850 DO 250 IRED=NBIN,1,-1
4851 DO 240 ICOE=IRED+1,NBIN
4852 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
4853 240 CONTINUE
4854 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
4855 250 CONTINUE
4856 ENDIF
4857
4858C...Share evenly if failure.
4859 260 IF(MSOLV.EQ.0) THEN
4860 DO 270 IBIN=1,NBIN
4861 COEFU(IBIN)=1D0
4862 WTRELN(IBIN)=0.1D0
4863 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
4864 & WTREL(IBIN)/WTRELS)
4865 270 CONTINUE
4866 ENDIF
4867
4868C...Normalize coefficients, with piece shared democratically.
4869 COEFSU=0D0
4870 WTRELS=0D0
4871 DO 280 IBIN=1,NBIN
4872 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
4873 COEFSU=COEFSU+COEFU(IBIN)
4874 WTRELS=WTRELS+WTRELN(IBIN)
4875 280 CONTINUE
4876 IF(COEFSU.GT.0D0) THEN
4877 DO 290 IBIN=1,NBIN
4878 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
4879 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
4880 290 CONTINUE
4881 ELSE
4882 DO 300 IBIN=1,NBIN
4883 COEFO(IBIN)=1D0/NBIN
4884 300 CONTINUE
4885 ENDIF
4886 IF(IVAR.EQ.1) IOFF=0
4887 IF(IVAR.EQ.2) IOFF=17
4888 IF(IVAR.EQ.3) IOFF=7
4889 IF(IVAR.EQ.4) IOFF=12
4890 DO 310 IBIN=1,NBIN
4891 ICOF=IOFF+IBIN
4892 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
4893 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
4894 COEF(ISUB,ICOF)=COEFO(IBIN)
4895 310 CONTINUE
4896 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
4897 & (COEFO(IBIN),IBIN=1,NBIN)
4898 320 CONTINUE
4899
4900C...Find two most promising maxima among points previously determined.
4901 DO 330 J=1,4
4902 IACCMX(J)=0
4903 SIGSMX(J)=0D0
4904 330 CONTINUE
4905 NMAX=0
4906 DO 390 IACC=1,NACC
4907 DO 340 J=1,30
4908 VINT(10+J)=VINTPT(IACC,J)
4909 340 CONTINUE
4910 IF(ISTSB.NE.5) THEN
4911 CALL PYSIGH(NCHN,SIGS)
4912 IF(MWTXS.EQ.1) THEN
4913 CALL PYEVWT(WTXS)
4914 SIGS=WTXS*SIGS
4915 ENDIF
4916 ELSE
4917 SIGS=0D0
4918 DO 350 IKIN3=1,MSTP(129)
4919 CALL PYKMAP(5,0,0D0)
4920 IF(MINT(51).EQ.1) GOTO 350
4921 CALL PYSIGH(NCHN,SIGTMP)
4922 IF(MWTXS.EQ.1) THEN
4923 CALL PYEVWT(WTXS)
4924 SIGTMP=WTXS*SIGTMP
4925 ENDIF
4926 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4927 350 CONTINUE
4928 ENDIF
4929 IEQ=0
4930 DO 360 IMV=1,NMAX
4931 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
4932 360 CONTINUE
4933 IF(IEQ.EQ.0) THEN
4934 DO 370 IMV=NMAX,1,-1
4935 IIN=IMV+1
4936 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
4937 IACCMX(IMV+1)=IACCMX(IMV)
4938 SIGSMX(IMV+1)=SIGSMX(IMV)
4939 370 CONTINUE
4940 IIN=1
4941 380 IACCMX(IIN)=IACC
4942 SIGSMX(IIN)=SIGS
4943 IF(NMAX.LE.1) NMAX=NMAX+1
4944 ENDIF
4945 390 CONTINUE
4946
4947C...Read out starting position for search.
4948 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
4949 SIGSAM=SIGSMX(1)
4950 DO 440 IMAX=1,NMAX
4951 IACC=IACCMX(IMAX)
4952 MTAU=MVARPT(IACC,1)
4953 MTAUP=MVARPT(IACC,2)
4954 MYST=MVARPT(IACC,3)
4955 MCTH=MVARPT(IACC,4)
4956 VTAU=0.5D0
4957 VYST=0.5D0
4958 VCTH=0.5D0
4959 VTAUP=0.5D0
4960
4961C...Starting point and step size in parameter space.
4962 DO 430 IRPT=1,2
4963 DO 420 IVAR=1,4
4964 IF(NPTS(IVAR).EQ.1) GOTO 420
4965 IF(IVAR.EQ.1) VVAR=VTAU
4966 IF(IVAR.EQ.2) VVAR=VTAUP
4967 IF(IVAR.EQ.3) VVAR=VYST
4968 IF(IVAR.EQ.4) VVAR=VCTH
4969 IF(IVAR.EQ.1) MVAR=MTAU
4970 IF(IVAR.EQ.2) MVAR=MTAUP
4971 IF(IVAR.EQ.3) MVAR=MYST
4972 IF(IVAR.EQ.4) MVAR=MCTH
4973 IF(IRPT.EQ.1) VDEL=0.1D0
4974 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
4975 & 0.98D0-VVAR))
4976 IF(IRPT.EQ.1) VMAR=0.02D0
4977 IF(IRPT.EQ.2) VMAR=0.002D0
4978 IMOV0=1
4979 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
4980 DO 410 IMOV=IMOV0,8
4981
4982C...Define new point in parameter space.
4983 IF(IMOV.EQ.0) THEN
4984 INEW=2
4985 VNEW=VVAR
4986 ELSEIF(IMOV.EQ.1) THEN
4987 INEW=3
4988 VNEW=VVAR+VDEL
4989 ELSEIF(IMOV.EQ.2) THEN
4990 INEW=1
4991 VNEW=VVAR-VDEL
4992 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
4993 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
4994 VVAR=VVAR+VDEL
4995 SIGSSM(1)=SIGSSM(2)
4996 SIGSSM(2)=SIGSSM(3)
4997 INEW=3
4998 VNEW=VVAR+VDEL
4999 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
5000 & VVAR-2D0*VDEL.GT.VMAR) THEN
5001 VVAR=VVAR-VDEL
5002 SIGSSM(3)=SIGSSM(2)
5003 SIGSSM(2)=SIGSSM(1)
5004 INEW=1
5005 VNEW=VVAR-VDEL
5006 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
5007 VDEL=0.5D0*VDEL
5008 VVAR=VVAR+VDEL
5009 SIGSSM(1)=SIGSSM(2)
5010 INEW=2
5011 VNEW=VVAR
5012 ELSE
5013 VDEL=0.5D0*VDEL
5014 VVAR=VVAR-VDEL
5015 SIGSSM(3)=SIGSSM(2)
5016 INEW=2
5017 VNEW=VVAR
5018 ENDIF
5019
5020C...Convert to relevant variables and find derived new limits.
5021 ILERR=0
5022 IF(IVAR.EQ.1) THEN
5023 VTAU=VNEW
5024 CALL PYKMAP(1,MTAU,VTAU)
5025 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5026 CALL PYKLIM(4)
5027 IF(MINT(51).EQ.1) ILERR=1
5028 ENDIF
5029 ENDIF
5030 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
5031 & ILERR.EQ.0) THEN
5032 IF(IVAR.EQ.2) VTAUP=VNEW
5033 CALL PYKMAP(4,MTAUP,VTAUP)
5034 ENDIF
5035 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
5036 CALL PYKLIM(2)
5037 IF(MINT(51).EQ.1) ILERR=1
5038 ENDIF
5039 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
5040 IF(IVAR.EQ.3) VYST=VNEW
5041 CALL PYKMAP(2,MYST,VYST)
5042 CALL PYKLIM(3)
5043 IF(MINT(51).EQ.1) ILERR=1
5044 ENDIF
5045 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
5046 & ILERR.EQ.0) THEN
5047 IF(IVAR.EQ.4) VCTH=VNEW
5048 CALL PYKMAP(3,MCTH,VCTH)
5049 ENDIF
5050 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
5051
5052C...Evaluate cross-section. Save new maximum. Final maximum.
5053 IF(ILERR.NE.0) THEN
5054 SIGS=0.
5055 ELSEIF(ISTSB.NE.5) THEN
5056 CALL PYSIGH(NCHN,SIGS)
5057 IF(MWTXS.EQ.1) THEN
5058 CALL PYEVWT(WTXS)
5059 SIGS=WTXS*SIGS
5060 ENDIF
5061 ELSE
5062 SIGS=0D0
5063 DO 400 IKIN3=1,MSTP(129)
5064 CALL PYKMAP(5,0,0D0)
5065 IF(MINT(51).EQ.1) GOTO 400
5066 CALL PYSIGH(NCHN,SIGTMP)
5067 IF(MWTXS.EQ.1) THEN
5068 CALL PYEVWT(WTXS)
5069 SIGTMP=WTXS*SIGTMP
5070 ENDIF
5071 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5072 400 CONTINUE
5073 ENDIF
5074 SIGSSM(INEW)=SIGS
5075 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5076 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
5077 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5078 410 CONTINUE
5079 420 CONTINUE
5080 430 CONTINUE
5081 440 CONTINUE
5082 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
5083 XSEC(ISUB,1)=1.05D0*SIGSAM
5084 450 CONTINUE
5085 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
5086 & PARP(174)*XSEC(ISUB,1)
5087 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
5088 460 CONTINUE
5089 MINT(51)=0
5090
5091C...Print summary table.
5092 IF(NPOSI.EQ.0) THEN
5093 WRITE(MSTU(11),5900)
5094 STOP
5095 ENDIF
5096 IF(MSTP(122).GE.1) THEN
5097 WRITE(MSTU(11),6000)
5098 WRITE(MSTU(11),6100)
5099 DO 470 ISUB=1,500
5100 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
5101 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
5102 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
5103 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
5104 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
5105 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
5106 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
5107 470 CONTINUE
5108 WRITE(MSTU(11),6300)
5109 ENDIF
5110
5111C...Format statements for maximization results.
5112 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
5113 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
5114 &'cth',9X,'tau''',7X,'sigma')
5115 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
5116 &'phase space.'/1X,'Process switched off!')
5117 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5118 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
5119 &'cross-section.'/1X,'Process switched off!')
5120 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5121 5500 FORMAT(1X,1P,8D11.3)
5122 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
5123 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
5124 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5125 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5126 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
5127 &'cross-section.'/1X,'Execution stopped!')
5128 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
5129 &'cross-section maximum search',1X,8('*'))
5130 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
5131 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
5132 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
5133 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
5134 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
5135
5136 RETURN
5137 END
5138
5139C*********************************************************************
5140
5141*$ CREATE PYPILE.FOR
5142*COPY PYPILE
5143C...PYPILE
5144C...Initializes multiplicity distribution and selects mutliplicity
5145C...of pileup events, i.e. several events occuring at the same
5146C...beam crossing.
5147
5148 SUBROUTINE PYPILE(MPILE)
5149
5150C...Double precision and integer declarations.
5151 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5152 INTEGER PYK,PYCHGE,PYCOMP
5153C...Commonblocks.
5154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5155 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5156 COMMON/PYINT1/MINT(400),VINT(400)
5157 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5158 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
5159C...Local arrays and saved variables.
5160 DIMENSION WTI(0:200)
5161 SAVE IMIN,IMAX,WTI,WTS
5162
5163C...Sum of allowed cross-sections for pileup events.
5164 IF(MPILE.EQ.1) THEN
5165 VINT(131)=SIGT(0,0,5)
5166 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
5167 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
5168 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
5169 IF(MSTP(133).LE.0) RETURN
5170
5171C...Initialize multiplicity distribution at maximum.
5172 XNAVE=VINT(131)*PARP(131)
5173 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
5174 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
5175 WTI(INAVE)=1D0
5176 WTS=WTI(INAVE)
5177 WTN=WTI(INAVE)*INAVE
5178
5179C...Find shape of multiplicity distribution below maximum.
5180 IMIN=INAVE
5181 DO 100 I=INAVE-1,1,-1
5182 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
5183 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
5184 IF(WTI(I).LT.1D-6) GOTO 110
5185 WTS=WTS+WTI(I)
5186 WTN=WTN+WTI(I)*I
5187 IMIN=I
5188 100 CONTINUE
5189
5190C...Find shape of multiplicity distribution above maximum.
5191 110 IMAX=INAVE
5192 DO 120 I=INAVE+1,200
5193 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
5194 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
5195 IF(WTI(I).LT.1D-6) GOTO 130
5196 WTS=WTS+WTI(I)
5197 WTN=WTN+WTI(I)*I
5198 IMAX=I
5199 120 CONTINUE
5200 130 VINT(132)=XNAVE
5201 VINT(133)=WTN/WTS
5202 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
5203 & WTS/(WTS+WTI(1)/XNAVE)
5204 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
5205 IF(MSTP(133).GE.2) VINT(134)=XNAVE
5206
5207C...Pick multiplicity of pileup events.
5208 ELSE
5209 IF(MSTP(133).LE.0) THEN
5210 MINT(81)=MAX(1,MSTP(134))
5211 ELSE
5212 WTR=WTS*PYR(0)
5213 DO 140 I=IMIN,IMAX
5214 MINT(81)=I
5215 WTR=WTR-WTI(I)
5216 IF(WTR.LE.0D0) GOTO 150
5217 140 CONTINUE
5218 150 CONTINUE
5219 ENDIF
5220 ENDIF
5221
5222C...Format statement for error message.
5223 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
5224 &'crossing too large, ',1P,D12.4)
5225
5226 RETURN
5227 END
5228
5229C*********************************************************************
5230
5231*$ CREATE PYSAVE.FOR
5232*COPY PYSAVE
5233C...PYSAVE
5234C...Saves and restores parameter and cross section values for the
5235C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random
5236C...choice between alternatives.
5237
5238 SUBROUTINE PYSAVE(ISAVE,IGA)
5239
5240C...Double precision and integer declarations.
5241 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5242 INTEGER PYK,PYCHGE,PYCOMP
5243C...Commonblocks.
5244 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5245 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5246 COMMON/PYINT1/MINT(400),VINT(400)
5247 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5248 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5249 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/
5250C...Local arrays and saved variables.
5251 DIMENSION NCP(10),NSUBCP(10,20),MSUBCP(10,20),COEFCP(10,20,20),
5252 &NGENCP(10,0:20,3),XSECCP(10,0:20,3),INTCP(10,20),RECP(10,20)
5253 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,INTCP,RECP
5254
5255C...Save list of subprocesses and cross-section information.
5256 IF(ISAVE.EQ.1) THEN
5257 ICP=0
5258 DO 120 I=1,500
5259 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
5260 ICP=ICP+1
5261 NSUBCP(IGA,ICP)=I
5262 MSUBCP(IGA,ICP)=MSUB(I)
5263 DO 100 J=1,20
5264 COEFCP(IGA,ICP,J)=COEF(I,J)
5265 100 CONTINUE
5266 DO 110 J=1,3
5267 NGENCP(IGA,ICP,J)=NGEN(I,J)
5268 XSECCP(IGA,ICP,J)=XSEC(I,J)
5269 110 CONTINUE
5270 120 CONTINUE
5271 NCP(IGA)=ICP
5272 DO 130 J=1,3
5273 NGENCP(IGA,0,J)=NGEN(0,J)
5274 XSECCP(IGA,0,J)=XSEC(0,J)
5275 130 CONTINUE
5276C...Save various common process variables.
5277 DO 140 J=1,10
5278 INTCP(IGA,J)=MINT(40+J)
5279 140 CONTINUE
5280 INTCP(IGA,11)=MINT(101)
5281 INTCP(IGA,12)=MINT(102)
5282 INTCP(IGA,13)=MINT(107)
5283 INTCP(IGA,14)=MINT(108)
5284 INTCP(IGA,15)=MINT(123)
5285 RECP(IGA,1)=CKIN(3)
5286
5287C...Save cross-section information only.
5288 ELSEIF(ISAVE.EQ.2) THEN
5289 DO 160 ICP=1,NCP(IGA)
5290 I=NSUBCP(IGA,ICP)
5291 DO 150 J=1,3
5292 NGENCP(IGA,ICP,J)=NGEN(I,J)
5293 XSECCP(IGA,ICP,J)=XSEC(I,J)
5294 150 CONTINUE
5295 160 CONTINUE
5296 DO 170 J=1,3
5297 NGENCP(IGA,0,J)=NGEN(0,J)
5298 XSECCP(IGA,0,J)=XSEC(0,J)
5299 170 CONTINUE
5300
5301C...Choose between allowed alternatives.
5302 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
5303 IF(ISAVE.EQ.4) THEN
5304 XSUMCP=0D0
5305 DO 180 IG=1,MINT(121)
5306 XSUMCP=XSUMCP+XSECCP(IG,0,1)
5307 180 CONTINUE
5308 XSUMCP=XSUMCP*PYR(0)
5309 DO 190 IG=1,MINT(121)
5310 IGA=IG
5311 XSUMCP=XSUMCP-XSECCP(IG,0,1)
5312 IF(XSUMCP.LE.0D0) GOTO 200
5313 190 CONTINUE
5314 200 CONTINUE
5315 ENDIF
5316
5317C...Restore cross-section information.
5318 DO 210 I=1,500
5319 MSUB(I)=0
5320 210 CONTINUE
5321 DO 240 ICP=1,NCP(IGA)
5322 I=NSUBCP(IGA,ICP)
5323 MSUB(I)=MSUBCP(IGA,ICP)
5324 DO 220 J=1,20
5325 COEF(I,J)=COEFCP(IGA,ICP,J)
5326 220 CONTINUE
5327 DO 230 J=1,3
5328 NGEN(I,J)=NGENCP(IGA,ICP,J)
5329 XSEC(I,J)=XSECCP(IGA,ICP,J)
5330 230 CONTINUE
5331 240 CONTINUE
5332 DO 250 J=1,3
5333 NGEN(0,J)=NGENCP(IGA,0,J)
5334 XSEC(0,J)=XSECCP(IGA,0,J)
5335 250 CONTINUE
5336
5337C...Restore various common process variables.
5338 DO 260 J=1,10
5339 MINT(40+J)=INTCP(IGA,J)
5340 260 CONTINUE
5341 MINT(101)=INTCP(IGA,11)
5342 MINT(102)=INTCP(IGA,12)
5343 MINT(107)=INTCP(IGA,13)
5344 MINT(108)=INTCP(IGA,14)
5345 MINT(123)=INTCP(IGA,15)
5346 CKIN(3)=RECP(IGA,1)
5347 CKIN(1)=2D0*CKIN(3)
5348
5349C...Sum up cross-section info (for PYSTAT).
5350 ELSEIF(ISAVE.EQ.5) THEN
5351 DO 270 I=1,500
5352 MSUB(I)=0
5353 NGEN(I,1)=0
5354 NGEN(I,3)=0
5355 XSEC(I,3)=0D0
5356 270 CONTINUE
5357 NGEN(0,1)=0
5358 NGEN(0,2)=0
5359 NGEN(0,3)=0
5360 XSEC(0,3)=0
5361 DO 290 IG=1,MINT(121)
5362 DO 280 ICP=1,NCP(IG)
5363 I=NSUBCP(IG,ICP)
5364 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
5365 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
5366 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
5367 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
5368 280 CONTINUE
5369 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
5370 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
5371 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
5372 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
5373 290 CONTINUE
5374 ENDIF
5375
5376 RETURN
5377 END
5378
5379C*********************************************************************
5380
5381*$ CREATE PYRAND.FOR
5382*COPY PYRAND
5383C...PYRAND
5384C...Generates quantities characterizing the high-pT scattering at the
5385C...parton level according to the matrix elements. Chooses incoming,
5386C...reacting partons, their momentum fractions and one of the possible
5387C...subprocesses.
5388
5389 SUBROUTINE PYRAND
5390
5391C...Double precision and integer declarations.
5392 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5393 INTEGER PYK,PYCHGE,PYCOMP
5394C...Parameter statement to help give large particle numbers.
5395 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
5396C...Commonblocks.
5397 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5398 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5399 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
5400 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5401 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5402 COMMON/PYINT1/MINT(400),VINT(400)
5403 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5404 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5405 COMMON/PYINT4/MWID(500),WIDS(500,5)
5406 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5407 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5408 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
5409 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5410 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5411 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
5412C...Local arrays.
5413 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
5414
5415C...Parameters and data used in elastic/diffractive treatment.
5416 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
5417 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5418
5419C...Initial values, specifically for (first) semihard interaction.
5420 MINT(10)=0
5421 MINT(17)=0
5422 MINT(18)=0
5423 VINT(143)=1D0
5424 VINT(144)=1D0
5425 MFAIL=0
5426 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
5427 ISUB=0
5428 LOOP=0
5429 100 LOOP=LOOP+1
5430 MINT(51)=0
5431
5432C...Choice of process type - first event of pileup.
5433 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
5434
5435C...For gamma-p or gamma-gamma first pick between alternatives.
5436 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
5437 MINT(122)=IGA
5438
5439C...For gamma + gamma with different nature, flip at random.
5440 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
5441 & PYR(0).GT.0.5D0) THEN
5442 MINTSV=MINT(41)
5443 MINT(41)=MINT(42)
5444 MINT(42)=MINTSV
5445 MINTSV=MINT(45)
5446 MINT(45)=MINT(46)
5447 MINT(46)=MINTSV
5448 MINTSV=MINT(107)
5449 MINT(107)=MINT(108)
5450 MINT(108)=MINTSV
5451 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
5452 ENDIF
5453
5454C...Pick process type.
5455 RSUB=XSEC(0,1)*PYR(0)
5456 DO 110 I=1,500
5457 IF(MSUB(I).NE.1) GOTO 110
5458 ISUB=I
5459 RSUB=RSUB-XSEC(I,1)
5460 IF(RSUB.LE.0D0) GOTO 120
5461 110 CONTINUE
5462 120 IF(ISUB.EQ.95) ISUB=96
5463 IF(ISUB.EQ.96) CALL PYMULT(2)
5464
5465C...Choice of inclusive process type - pileup events.
5466 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
5467 RSUB=VINT(131)*PYR(0)
5468 ISUB=96
5469 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
5470 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
5471 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
5472 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
5473 & ISUB=91
5474 IF(ISUB.EQ.96) CALL PYMULT(2)
5475 ENDIF
5476 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
5477 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
5478 IF(ISUB.EQ.96.AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
5479 &NGEN(97,1)=NGEN(97,1)+1
5480 MINT(1)=ISUB
5481 ISTSB=ISET(ISUB)
5482
5483C...Random choice of flavour for some SUSY processes.
5484 IF(ISUB.GE.201.AND.ISUB.LE.280) THEN
5485C...~e_L ~nu_e or ~mu_L ~nu_mu.
5486 IF(ISUB.EQ.210) THEN
5487 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
5488 KFPR(ISUB,2)=KFPR(ISUB,1)+1
5489C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
5490 ELSEIF(ISUB.EQ.213) THEN
5491 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
5492 KFPR(ISUB,2)=KFPR(ISUB,1)
5493C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
5494 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
5495 IF(MOD(ISUB,2).EQ.0) THEN
5496 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5497 ELSE
5498 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5499 ENDIF
5500C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.
5501 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
5502 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
5503 KSU1=KSUSY1
5504 KSU2=KSUSY1
5505 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
5506 KSU1=KSUSY2
5507 KSU2=KSUSY2
5508 ELSEIF(PYR(0).LT.0.5D0) THEN
5509 KSU1=KSUSY1
5510 KSU2=KSUSY2
5511 ELSE
5512 KSU1=KSUSY2
5513 KSU2=KSUSY1
5514 ENDIF
5515 KFPR(ISUB,1)=KSU1+1+INT(5D0*PYR(0))
5516 KFPR(ISUB,2)=KSU2+1+INT(5D0*PYR(0))
5517C...~q ~q(bar); ~q = ~d, ~u, ~s, ~c or ~b.
5518 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
5519 KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5520 KFPR(ISUB,2)=KFPR(ISUB,1)
5521 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
5522 KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5523 KFPR(ISUB,2)=KFPR(ISUB,1)
5524 ENDIF
5525 ENDIF
5526
5527C...Find resonances (explicit or implicit in cross-section).
5528 MINT(72)=0
5529 KFR1=0
5530 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5531 KFR1=KFPR(ISUB,1)
5532 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
5533 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5534 KFR1=23
5535 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
5536 & ISUB.EQ.177) THEN
5537 KFR1=24
5538 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5539 KFR1=25
5540 IF(MSTP(46).EQ.5) THEN
5541 KFR1=30
5542 PMAS(30,1)=PARP(45)
5543 PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5544 ENDIF
5545 ELSEIF(ISUB.EQ.194) THEN
5546 KFR1=54
5547 ENDIF
5548 CKMX=CKIN(2)
5549 IF(CKMX.LE.0D0) CKMX=VINT(1)
5550 KCR1=PYCOMP(KFR1)
5551 IF(KFR1.NE.0) THEN
5552 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5553 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5554 ENDIF
5555 IF(KFR1.NE.0) THEN
5556 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5557 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5558 MINT(72)=1
5559 MINT(73)=KFR1
5560 VINT(73)=TAUR1
5561 VINT(74)=GAMR1
5562 ENDIF
5563 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
5564 KFR2=23
5565 IF(ISUB.EQ.194) KFR2=56
5566 KCR2=PYCOMP(KFR2)
5567 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5568 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5569 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5570 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5571 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5572 MINT(72)=2
5573 MINT(74)=KFR2
5574 VINT(75)=TAUR2
5575 VINT(76)=GAMR2
5576 ELSEIF(KFR2.NE.0) THEN
5577 KFR1=KFR2
5578 TAUR1=TAUR2
5579 GAMR1=GAMR2
5580 MINT(72)=1
5581 MINT(73)=KFR1
5582 VINT(73)=TAUR1
5583 VINT(74)=GAMR1
5584 ENDIF
5585 ENDIF
5586
5587C...Find product masses and minimum pT of process,
5588C...optionally with broadening according to a truncated Breit-Wigner.
5589 VINT(63)=0D0
5590 VINT(64)=0D0
5591 MINT(71)=0
5592 VINT(71)=CKIN(3)
5593 IF(MINT(82).GE.2) VINT(71)=0D0
5594 VINT(80)=1D0
5595 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5596 NBW=0
5597 DO 140 I=1,2
5598 PMMN(I)=0D0
5599 IF(KFPR(ISUB,I).EQ.0) THEN
5600 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5601 & PARP(41)) THEN
5602 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5603 ELSE
5604 NBW=NBW+1
5605C...This prevents SUSY/t particles from becoming too light.
5606 KFLW=KFPR(ISUB,I)
5607 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5608 KCW=PYCOMP(KFLW)
5609 PMMN(I)=PMAS(KCW,1)
5610 DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5611 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5612 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5613 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5614 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5615 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5616 PMMN(I)=MIN(PMMN(I),PMSUM)
5617 ENDIF
5618 130 CONTINUE
5619 ELSEIF(KFLW.EQ.6) THEN
5620 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5621 ENDIF
5622 ENDIF
5623 140 CONTINUE
5624 IF(NBW.GE.1) THEN
5625 CKIN41=CKIN(41)
5626 CKIN43=CKIN(43)
5627 CKIN(41)=MAX(PMMN(1),CKIN(41))
5628 CKIN(43)=MAX(PMMN(2),CKIN(43))
5629 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5630 CKIN(41)=CKIN41
5631 CKIN(43)=CKIN43
5632 IF(MINT(51).EQ.1) THEN
5633 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5634 IF(MFAIL.EQ.1) THEN
5635 MSTI(61)=1
5636 RETURN
5637 ENDIF
5638 GOTO 100
5639 ENDIF
5640 VINT(63)=PQM3**2
5641 VINT(64)=PQM4**2
5642 ENDIF
5643 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
5644 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5645 ENDIF
5646
5647C...Prepare for additional variable choices in 2 -> 3.
5648 IF(ISTSB.EQ.5) THEN
5649 VINT(201)=0D0
5650 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5651 VINT(206)=VINT(201)
5652 VINT(204)=PMAS(23,1)
5653 IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
5654 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
5655 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5656 VINT(209)=VINT(204)
5657 ENDIF
5658
5659C...Select incoming VDM particle (rho/omega/phi/J/psi).
5660 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
5661 &(MINT(123).EQ.2.OR.MINT(123).EQ.5.OR.MINT(123).EQ.7)) THEN
5662 VRN=PYR(0)*SIGT(0,0,5)
5663 IF(MINT(101).LE.1) THEN
5664 I1MN=0
5665 I1MX=0
5666 ELSE
5667 I1MN=1
5668 I1MX=MINT(101)
5669 ENDIF
5670 IF(MINT(102).LE.1) THEN
5671 I2MN=0
5672 I2MX=0
5673 ELSE
5674 I2MN=1
5675 I2MX=MINT(102)
5676 ENDIF
5677 DO 160 I1=I1MN,I1MX
5678 KFV1=110*I1+3
5679 DO 150 I2=I2MN,I2MX
5680 KFV2=110*I2+3
5681 VRN=VRN-SIGT(I1,I2,5)
5682 IF(VRN.LE.0D0) GOTO 170
5683 150 CONTINUE
5684 160 CONTINUE
5685 170 IF(MINT(101).GE.2) MINT(103)=KFV1
5686 IF(MINT(102).GE.2) MINT(104)=KFV2
5687 ENDIF
5688
5689 IF(ISTSB.EQ.0) THEN
5690C...Elastic scattering or single or double diffractive scattering.
5691
5692C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
5693 MINT(103)=MINT(11)
5694 MINT(104)=MINT(12)
5695 PMM(1)=VINT(3)
5696 PMM(2)=VINT(4)
5697 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
5698 JJ=ISUB-90
5699 VRN=PYR(0)*SIGT(0,0,JJ)
5700 IF(MINT(101).LE.1) THEN
5701 I1MN=0
5702 I1MX=0
5703 ELSE
5704 I1MN=1
5705 I1MX=MINT(101)
5706 ENDIF
5707 IF(MINT(102).LE.1) THEN
5708 I2MN=0
5709 I2MX=0
5710 ELSE
5711 I2MN=1
5712 I2MX=MINT(102)
5713 ENDIF
5714 DO 190 I1=I1MN,I1MX
5715 KFV1=110*I1+3
5716 DO 180 I2=I2MN,I2MX
5717 KFV2=110*I2+3
5718 VRN=VRN-SIGT(I1,I2,JJ)
5719 IF(VRN.LE.0D0) GOTO 200
5720 180 CONTINUE
5721 190 CONTINUE
5722 200 IF(MINT(101).GE.2) THEN
5723 MINT(103)=KFV1
5724 PMM(1)=PYMASS(KFV1)
5725 ENDIF
5726 IF(MINT(102).GE.2) THEN
5727 MINT(104)=KFV2
5728 PMM(2)=PYMASS(KFV2)
5729 ENDIF
5730 ENDIF
5731
5732C...Side/sides of diffractive system.
5733 MINT(17)=0
5734 MINT(18)=0
5735 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
5736 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
5737
5738C...Find masses of particles and minimal masses of diffractive states.
5739 DO 210 JT=1,2
5740 PDIF(JT)=PMM(JT)
5741 VINT(66+JT)=PDIF(JT)
5742 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
5743 210 CONTINUE
5744 SH=VINT(2)
5745 SQM1=PMM(1)**2
5746 SQM2=PMM(2)**2
5747 SQM3=PDIF(1)**2
5748 SQM4=PDIF(2)**2
5749 SMRES1=(PMM(1)+PMRC)**2
5750 SMRES2=(PMM(2)+PMRC)**2
5751
5752C...Find elastic slope and lower limit diffractive slope.
5753 IHA=MAX(2,IABS(MINT(103))/110)
5754 IF(IHA.GE.5) IHA=1
5755 IHB=MAX(2,IABS(MINT(104))/110)
5756 IF(IHB.GE.5) IHB=1
5757 IF(ISUB.EQ.91) THEN
5758 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
5759 ELSEIF(ISUB.EQ.92) THEN
5760 BMN=MAX(2D0,2D0*BHAD(IHB))
5761 ELSEIF(ISUB.EQ.93) THEN
5762 BMN=MAX(2D0,2D0*BHAD(IHA))
5763 ELSEIF(ISUB.EQ.94) THEN
5764 BMN=2D0*ALP*4D0
5765 ENDIF
5766
5767C...Determine maximum possible t range and coefficient of generation.
5768 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
5769 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5770 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5771 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5772 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5773 & (SQM1*SQM4-SQM2*SQM3)/SH
5774 THL=-0.5D0*(THA+THB)
5775 THU=THC/THL
5776 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
5777
5778C...Select diffractive mass/masses according to dm^2/m^2.
5779 220 DO 230 JT=1,2
5780 IF(MINT(16+JT).EQ.0) THEN
5781 PDIF(2+JT)=PDIF(JT)
5782 ELSE
5783 PMMIN=PDIF(JT)
5784 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
5785 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
5786 ENDIF
5787 230 CONTINUE
5788 SQM3=PDIF(3)**2
5789 SQM4=PDIF(4)**2
5790
5791C..Additional mass factors, including resonance enhancement.
5792 IF(PDIF(3)+PDIF(4).GE.VINT(1)) GOTO 220
5793 IF(ISUB.EQ.92) THEN
5794 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
5795 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5796 ELSEIF(ISUB.EQ.93) THEN
5797 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
5798 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5799 ELSEIF(ISUB.EQ.94) THEN
5800 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
5801 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
5802 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
5803 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
5804 ENDIF
5805
5806C...Select t according to exp(Bmn*t) and correct to right slope.
5807 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
5808 IF(ISUB.GE.92) THEN
5809 IF(ISUB.EQ.92) THEN
5810 BADD=2D0*ALP*LOG(SH/SQM3)
5811 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
5812 ELSEIF(ISUB.EQ.93) THEN
5813 BADD=2D0*ALP*LOG(SH/SQM4)
5814 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
5815 ELSEIF(ISUB.EQ.94) THEN
5816 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
5817 ENDIF
5818 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
5819 ENDIF
5820
5821C...Check whether m^2 and t choices are consistent.
5822 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5823 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5824 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5825 IF(THB.LE.1D-8) GOTO 220
5826 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5827 & (SQM1*SQM4-SQM2*SQM3)/SH
5828 THLM=-0.5D0*(THA+THB)
5829 THUM=THC/THLM
5830 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
5831
5832C...Information to output.
5833 VINT(21)=1D0
5834 VINT(22)=0D0
5835 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
5836 VINT(45)=TH
5837 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
5838 VINT(63)=PDIF(3)**2
5839 VINT(64)=PDIF(4)**2
5840
5841C...Note: in the following, by In is meant the integral over the
5842C...quantity multiplying coefficient cn.
5843C...Choose tau according to h1(tau)/tau, where
5844C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
5845C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
5846C...I1/I5*c5*1/(tau+tau_R') +
5847C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
5848C...I1/I7*c7*tau/(1.-tau), and
5849C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
5850 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
5851 CALL PYKLIM(1)
5852 IF(MINT(51).NE.0) THEN
5853 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5854 IF(MFAIL.EQ.1) THEN
5855 MSTI(61)=1
5856 RETURN
5857 ENDIF
5858 GOTO 100
5859 ENDIF
5860 RTAU=PYR(0)
5861 MTAU=1
5862 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
5863 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
5864 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
5865 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
5866 & MTAU=5
5867 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5868 & COEF(ISUB,5)) MTAU=6
5869 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5870 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
5871 CALL PYKMAP(1,MTAU,PYR(0))
5872
5873C...2 -> 3, 4 processes:
5874C...Choose tau' according to h4(tau,tau')/tau', where
5875C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
5876C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
5877 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5878 CALL PYKLIM(4)
5879 IF(MINT(51).NE.0) THEN
5880 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5881 IF(MFAIL.EQ.1) THEN
5882 MSTI(61)=1
5883 RETURN
5884 ENDIF
5885 GOTO 100
5886 ENDIF
5887 RTAUP=PYR(0)
5888 MTAUP=1
5889 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
5890 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
5891 CALL PYKMAP(4,MTAUP,PYR(0))
5892 ENDIF
5893
5894C...Choose y* according to h2(y*), where
5895C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
5896C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
5897C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
5898C...and c1 + c2 + c3 + c4 + c5 = 1.
5899 CALL PYKLIM(2)
5900 IF(MINT(51).NE.0) THEN
5901 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5902 IF(MFAIL.EQ.1) THEN
5903 MSTI(61)=1
5904 RETURN
5905 ENDIF
5906 GOTO 100
5907 ENDIF
5908 RYST=PYR(0)
5909 MYST=1
5910 IF(RYST.GT.COEF(ISUB,8)) MYST=2
5911 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
5912 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
5913 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
5914 & COEF(ISUB,11)) MYST=5
5915 CALL PYKMAP(2,MYST,PYR(0))
5916
5917C...2 -> 2 processes:
5918C...Choose cos(theta-hat) (cth) according to h3(cth), where
5919C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
5920C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
5921C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
5922C...and c0 + c1 + c2 + c3 + c4 = 1.
5923 CALL PYKLIM(3)
5924 IF(MINT(51).NE.0) THEN
5925 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5926 IF(MFAIL.EQ.1) THEN
5927 MSTI(61)=1
5928 RETURN
5929 ENDIF
5930 GOTO 100
5931 ENDIF
5932 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5933 RCTH=PYR(0)
5934 MCTH=1
5935 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
5936 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
5937 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
5938 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
5939 & COEF(ISUB,16)) MCTH=5
5940 CALL PYKMAP(3,MCTH,PYR(0))
5941 ENDIF
5942
5943C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
5944 IF(ISTSB.EQ.5) THEN
5945 CALL PYKMAP(5,0,0D0)
5946 IF(MINT(51).NE.0) THEN
5947 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5948 IF(MFAIL.EQ.1) THEN
5949 MSTI(61)=1
5950 RETURN
5951 ENDIF
5952 GOTO 100
5953 ENDIF
5954 ENDIF
5955
5956C...Low-pT or multiple interactions (first semihard interaction).
5957 ELSEIF(ISTSB.EQ.9) THEN
5958 CALL PYMULT(3)
5959 ISUB=MINT(1)
5960
5961C...Generate user-defined process: kinematics plus weight.
5962 ELSEIF(ISTSB.EQ.11) THEN
5963 MSTI(51)=0
5964 CALL PYUPEV(ISUB,SIGS)
5965 IF(NUP.LE.0) THEN
5966 MINT(51)=2
5967 MSTI(51)=1
5968 IF(MINT(82).EQ.1) THEN
5969 NGEN(0,1)=NGEN(0,1)-1
5970 NGEN(0,2)=NGEN(0,2)-1
5971 NGEN(ISUB,1)=NGEN(ISUB,1)-1
5972 ENDIF
5973 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5974 RETURN
5975 ENDIF
5976
5977C...Construct 'trivial' kinematical variables needed.
5978 KFL1=KUP(1,2)
5979 KFL2=KUP(2,2)
5980 VINT(41)=2D0*PUP(1,4)/VINT(1)
5981 VINT(42)=2D0*PUP(2,4)/VINT(1)
5982 VINT(21)=VINT(41)*VINT(42)
5983 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
5984 VINT(44)=VINT(21)*VINT(2)
5985 VINT(43)=SQRT(MAX(0D0,VINT(44)))
5986 VINT(56)=Q2UP(0)
5987 VINT(55)=SQRT(MAX(0D0,VINT(56)))
5988
5989C...Construct other kinematical variables needed (approximately).
5990 VINT(23)=0D0
5991 VINT(26)=VINT(21)
5992 VINT(45)=-0.5D0*VINT(44)
5993 VINT(46)=-0.5D0*VINT(44)
5994 VINT(49)=VINT(43)
5995 VINT(50)=VINT(44)
5996 VINT(51)=VINT(55)
5997 VINT(52)=VINT(56)
5998 VINT(53)=VINT(55)
5999 VINT(54)=VINT(56)
6000 VINT(25)=0D0
6001 VINT(48)=0D0
6002 DO 240 IUP=3,NUP
6003 IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
6004 & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(1)
6005 IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
6006 & PUP(IUP,2)**2)
6007 240 CONTINUE
6008 VINT(47)=SQRT(VINT(48))
6009
6010C...Calculate parton distribution weights.
6011 IF(MINT(47).GE.2) THEN
6012 DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
6013 MINT(105)=MINT(102+I)
6014 MINT(109)=MINT(106+I)
6015 IF(MSTP(57).LE.1) THEN
6016 CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
6017 ELSE
6018 CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
6019 ENDIF
6020 DO 250 KFL=-25,25
6021 XSFX(I,KFL)=XPQ(KFL)
6022 250 CONTINUE
6023 260 CONTINUE
6024 ENDIF
6025 ENDIF
6026
6027C...Choose azimuthal angle.
6028 VINT(24)=PARU(2)*PYR(0)
6029
6030C...Check against user cuts on kinematics at parton level.
6031 MINT(51)=0
6032 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
6033 IF(MINT(51).NE.0) THEN
6034 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6035 IF(MFAIL.EQ.1) THEN
6036 MSTI(61)=1
6037 RETURN
6038 ENDIF
6039 GOTO 100
6040 ENDIF
6041 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
6042 MCUT=0
6043 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
6044 & CALL PYKCUT(MCUT)
6045 IF(MCUT.NE.0) THEN
6046 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6047 IF(MFAIL.EQ.1) THEN
6048 MSTI(61)=1
6049 RETURN
6050 ENDIF
6051 GOTO 100
6052 ENDIF
6053 ENDIF
6054
6055C...Calculate differential cross-section for different subprocesses.
6056 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
6057 SIGSOR=SIGS
6058 SIGLPT=SIGT(0,0,5)
6059
6060C...Multiply cross-section by user-defined weights.
6061 IF(MSTP(173).EQ.1) THEN
6062 SIGS=PARP(173)*SIGS
6063 DO 270 ICHN=1,NCHN
6064 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
6065 270 CONTINUE
6066 SIGLPT=PARP(173)*SIGLPT
6067 ENDIF
6068 WTXS=1D0
6069 SIGSWT=SIGS
6070 VINT(99)=1D0
6071 VINT(100)=1D0
6072 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
6073 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
6074 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
6075 SIGSWT=WTXS*SIGS
6076 VINT(99)=WTXS
6077 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
6078 ENDIF
6079
6080C...Calculations for Monte Carlo estimate of all cross-sections.
6081 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
6082 IF(MSTP(142).LE.1) THEN
6083 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6084 ELSE
6085 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
6086 ENDIF
6087 ELSEIF(MINT(82).EQ.1) THEN
6088 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6089 ENDIF
6090 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
6091 &XSEC(97,2)=XSEC(97,2)+SIGLPT
6092
6093C...Multiple interactions: store results of cross-section calculation.
6094 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
6095 VINT(153)=SIGSOR
6096 CALL PYMULT(4)
6097 ENDIF
6098
6099C...Check that weight not negative.
6100 VIOL=SIGSWT/XSEC(ISUB,1)
6101 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
6102 IF(MSTP(123).LE.0) THEN
6103 IF(VIOL.LT.-1D-3) THEN
6104 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
6105 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6106 & VINT(22),VINT(23),VINT(26)
6107 STOP
6108 ENDIF
6109 ELSE
6110 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
6111 VINT(109)=VIOL
6112 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
6113 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6114 & VINT(22),VINT(23),VINT(26)
6115 ENDIF
6116 ENDIF
6117
6118C...Weighting using estimate of maximum of differential cross-section.
6119 IF(MFAIL.EQ.0) THEN
6120 IF(VIOL.LT.PYR(0)) THEN
6121 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6122 GOTO 100
6123 ENDIF
6124 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
6125 IF(VIOL.LT.PYR(0)) THEN
6126 MSTI(61)=1
6127 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6128 RETURN
6129 ENDIF
6130 ELSE
6131 RATND=SIGLPT/XSEC(95,1)
6132 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
6133 MSTI(61)=1
6134 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6135 RETURN
6136 ENDIF
6137 VIOL=VIOL/RATND
6138 IF(VIOL.LT.PYR(0)) THEN
6139 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6140 GOTO 100
6141 ENDIF
6142 ENDIF
6143
6144C...Check for possible violation of estimated maximum of differential
6145C...cross-section used in weighting.
6146 IF(MSTP(123).LE.0) THEN
6147 IF(VIOL.GT.1D0) THEN
6148 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
6149 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6150 & VINT(22),VINT(23),VINT(26)
6151 STOP
6152 ENDIF
6153 ELSEIF(MSTP(123).EQ.1) THEN
6154 IF(VIOL.GT.VINT(108)) THEN
6155 VINT(108)=VIOL
6156 IF(VIOL.GT.1D0) THEN
6157 MINT(10)=1
6158 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6159 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6160 & VINT(22),VINT(23),VINT(26)
6161 ENDIF
6162 ENDIF
6163 ELSEIF(VIOL.GT.VINT(108)) THEN
6164 VINT(108)=VIOL
6165 IF(VIOL.GT.1D0) THEN
6166 MINT(10)=1
6167 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
6168 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
6169 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
6170 & XSEC(0,1)=XSEC(0,1)+XDIF
6171 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6172 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6173 & VINT(22),VINT(23),VINT(26)
6174 IF(ISUB.LE.9) THEN
6175 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
6176 ELSEIF(ISUB.LE.99) THEN
6177 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
6178 ELSE
6179 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
6180 ENDIF
6181 VINT(108)=1D0
6182 ENDIF
6183 ENDIF
6184
6185C...Multiple interactions: choose impact parameter.
6186 VINT(148)=1D0
6187 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
6188 &MSTP(82).GE.3) THEN
6189 CALL PYMULT(5)
6190 IF(VINT(150).LT.PYR(0)) THEN
6191 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6192 IF(MFAIL.EQ.1) THEN
6193 MSTI(61)=1
6194 RETURN
6195 ENDIF
6196 GOTO 100
6197 ENDIF
6198 ENDIF
6199 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
6200 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
6201 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
6202 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
6203 ENDIF
6204 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
6205
6206C...Choose flavour of reacting partons (and subprocess).
6207 IF(ISTSB.GE.11) GOTO 290
6208 RSIGS=SIGS*PYR(0)
6209 QT2=VINT(48)
6210 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
6211 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
6212 &PYR(0).GT.RQQBAR)) THEN
6213 DO 280 ICHN=1,NCHN
6214 KFL1=ISIG(ICHN,1)
6215 KFL2=ISIG(ICHN,2)
6216 MINT(2)=ISIG(ICHN,3)
6217 RSIGS=RSIGS-SIGH(ICHN)
6218 IF(RSIGS.LE.0D0) GOTO 290
6219 280 CONTINUE
6220
6221C...Multiple interactions: choose qqbar preferentially at small pT.
6222 ELSEIF(ISUB.EQ.96) THEN
6223 MINT(105)=MINT(103)
6224 MINT(109)=MINT(107)
6225 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
6226 MINT(105)=MINT(104)
6227 MINT(109)=MINT(108)
6228 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
6229 MINT(1)=11
6230 MINT(2)=1
6231 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
6232
6233C...Low-pT: choose string drawing configuration.
6234 ELSE
6235 KFL1=21
6236 KFL2=21
6237 RSIGS=6D0*PYR(0)
6238 MINT(2)=1
6239 IF(RSIGS.GT.1D0) MINT(2)=2
6240 IF(RSIGS.GT.2D0) MINT(2)=3
6241 ENDIF
6242
6243C...Reassign QCD process. Partons before initial state radiation.
6244 290 IF(MINT(2).GT.10) THEN
6245 MINT(1)=MINT(2)/10
6246 MINT(2)=MOD(MINT(2),10)
6247 ENDIF
6248 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
6249 &NGEN(MINT(1),2)+1
6250 MINT(15)=KFL1
6251 MINT(16)=KFL2
6252 MINT(13)=MINT(15)
6253 MINT(14)=MINT(16)
6254 VINT(141)=VINT(41)
6255 VINT(142)=VINT(42)
6256 VINT(151)=0D0
6257 VINT(152)=0D0
6258
6259C...Calculate x value of photon for parton inside photon inside e.
6260 DO 320 JT=1,2
6261 MINT(18+JT)=0
6262 VINT(154+JT)=0D0
6263 MSPLI=0
6264 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
6265 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
6266 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
6267 IF(MSPLI.EQ.2) THEN
6268 KFLH=MINT(14+JT)
6269 XHRD=VINT(140+JT)
6270 Q2HRD=VINT(54)
6271 MINT(105)=MINT(102+JT)
6272 MINT(109)=MINT(106+JT)
6273 IF(MSTP(57).LE.1) THEN
6274 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
6275 ELSE
6276 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
6277 ENDIF
6278 WTMX=4D0*XPQ(KFLH)
6279 IF(MSTP(13).EQ.2) THEN
6280 Q2PMS=Q2HRD/PMAS(11,1)**2
6281 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
6282 ENDIF
6283 300 XE=XHRD**PYR(0)
6284 XG=MIN(0.999999D0,XHRD/XE)
6285 IF(MSTP(57).LE.1) THEN
6286 CALL PYPDFU(22,XG,Q2HRD,XPQ)
6287 ELSE
6288 CALL PYPDFL(22,XG,Q2HRD,XPQ)
6289 ENDIF
6290 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
6291 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
6292 IF(WT.LT.PYR(0)*WTMX) GOTO 300
6293 MINT(18+JT)=1
6294 VINT(154+JT)=XE
6295 DO 310 KFLS=-25,25
6296 XSFX(JT,KFLS)=XPQ(KFLS)
6297 310 CONTINUE
6298 ENDIF
6299 320 CONTINUE
6300
6301C...Pick scale where photon is resolved.
6302 IF(MINT(107).EQ.3) VINT(283)=PARP(15)**2*
6303 &(VINT(54)/PARP(15)**2)**PYR(0)
6304 IF(MINT(108).EQ.3) VINT(284)=PARP(15)**2*
6305 &(VINT(54)/PARP(15)**2)**PYR(0)
6306 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6307
6308C...Format statements for differential cross-section maximum violations.
6309 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
6310 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6311 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
6312 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
6313 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
6314 &'in event',1X,I7)
6315 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
6316 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6317 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
6318 &'in event',1X,I7)
6319 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
6320 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
6321 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
6322
6323 RETURN
6324 END
6325
6326C*********************************************************************
6327
6328*$ CREATE PYSCAT.FOR
6329*COPY PYSCAT
6330C...PYSCAT
6331C...Finds outgoing flavours and event type; sets up the kinematics
6332C...and colour flow of the hard scattering
6333
6334 SUBROUTINE PYSCAT
6335
6336C...Double precision and integer declarations
6337 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6338 INTEGER PYK,PYCHGE,PYCOMP
6339C...Parameter statement to help give large particle numbers.
6340 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
6341C...Commonblocks
6342 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6343 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6344 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6345 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
6346 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6347 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6348 COMMON/PYINT1/MINT(400),VINT(400)
6349 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6350 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6351 COMMON/PYINT4/MWID(500),WIDS(500,5)
6352 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6353 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
6354 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
6355 &SFMIX(16,4)
6356 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
6357 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
6358C...Local arrays and saved variables
6359 DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
6360 &PHI(2),KUPPO(20),VINTSV(41:66)
6361 SAVE VINTSV
6362
6363C...Read out process
6364 ISUB=MINT(1)
6365 ISUBSV=ISUB
6366
6367C...Restore information for low-pT processes
6368 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
6369 DO 100 J=41,66
6370 100 VINT(J)=VINTSV(J)
6371 ENDIF
6372
6373C...Convert H' or A process into equivalent H one
6374 IHIGG=1
6375 KFHIGG=25
6376 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
6377 &ISUB.LE.190)) THEN
6378 IHIGG=2
6379 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
6380 KFHIGG=33+IHIGG
6381 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
6382 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
6383 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
6384 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
6385 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
6386 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
6387 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
6388 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
6389 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
6390 ENDIF
6391
6392C...Choice of subprocess, number of documentation lines
6393 IDOC=6+ISET(ISUB)
6394 IF(ISUB.EQ.95) IDOC=8
6395 IF(ISET(ISUB).EQ.5) IDOC=9
6396 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
6397 MINT(3)=IDOC-6
6398 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
6399 MINT(4)=IDOC
6400 IPU1=MINT(84)+1
6401 IPU2=MINT(84)+2
6402 IPU3=MINT(84)+3
6403 IPU4=MINT(84)+4
6404 IPU5=MINT(84)+5
6405 IPU6=MINT(84)+6
6406
6407C...Reset K, P and V vectors. Store incoming particles
6408 DO 120 JT=1,MSTP(126)+20
6409 I=MINT(83)+JT
6410 DO 110 J=1,5
6411 K(I,J)=0
6412 P(I,J)=0D0
6413 V(I,J)=0D0
6414 110 CONTINUE
6415 120 CONTINUE
6416 DO 140 JT=1,2
6417 I=MINT(83)+JT
6418 K(I,1)=21
6419 K(I,2)=MINT(10+JT)
6420 DO 130 J=1,5
6421 P(I,J)=VINT(285+5*JT+J)
6422 130 CONTINUE
6423 140 CONTINUE
6424 MINT(6)=2
6425 KFRES=0
6426
6427C...Store incoming partons in their CM-frame
6428 SH=VINT(44)
6429 SHR=SQRT(SH)
6430 SHP=VINT(26)*VINT(2)
6431 SHPR=SQRT(SHP)
6432 SHUSER=SHR
6433 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
6434 DO 150 JT=1,2
6435 I=MINT(84)+JT
6436 K(I,1)=14
6437 K(I,2)=MINT(14+JT)
6438 K(I,3)=MINT(83)+2+JT
6439 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
6440 P(I,4)=0.5D0*SHUSER
6441 150 CONTINUE
6442
6443C...Copy incoming partons to documentation lines
6444 DO 170 JT=1,2
6445 I1=MINT(83)+4+JT
6446 I2=MINT(84)+JT
6447 K(I1,1)=21
6448 K(I1,2)=K(I2,2)
6449 K(I1,3)=I1-2
6450 DO 160 J=1,5
6451 P(I1,J)=P(I2,J)
6452 160 CONTINUE
6453 170 CONTINUE
6454
6455C...Choose new quark/lepton flavour for relevant annihilation graphs
6456 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58) THEN
6457 IGLGA=21
6458 IF(ISUB.EQ.58) IGLGA=22
6459 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
6460 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
6461 DO 190 I=1,MDCY(IGLGA,3)
6462 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
6463 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
6464 IF(RKFL.LE.0D0) GOTO 200
6465 190 CONTINUE
6466 200 CONTINUE
6467 IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
6468 & IABS(KFLF).GE.3) THEN
6469 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
6470 & VINT(44)**2
6471 FACCIB=VINT(46)**2/PARU(155)**4
6472 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
6473 ELSEIF(ISUB.EQ.54) THEN
6474 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
6475 ELSEIF(ISUB.EQ.58) THEN
6476 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
6477 ENDIF
6478 ENDIF
6479
6480C...Final state flavours and colour flow: default values
6481 JS=1
6482 MINT(21)=MINT(15)
6483 MINT(22)=MINT(16)
6484 MINT(23)=0
6485 MINT(24)=0
6486 KCC=20
6487 KCS=ISIGN(1,MINT(15))
6488
6489 IF(ISET(ISUB).EQ.11) THEN
6490C...User-defined processes: find products
6491 IRUP=0
6492 DO 210 IUP=3,NUP
6493 IF(KUP(IUP,1).NE.1) THEN
6494 ELSEIF(IRUP.LE.5) THEN
6495 IRUP=IRUP+1
6496 MINT(20+IRUP)=KUP(IUP,2)
6497 ENDIF
6498 210 CONTINUE
6499
6500 ELSEIF(ISUB.LE.10) THEN
6501 IF(ISUB.EQ.1) THEN
6502C...f + fbar -> gamma*/Z0
6503 KFRES=23
6504
6505 ELSEIF(ISUB.EQ.2) THEN
6506C...f + fbar' -> W+/-
6507 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6508 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6509 KFRES=ISIGN(24,KCH1+KCH2)
6510
6511 ELSEIF(ISUB.EQ.3) THEN
6512C...f + fbar -> h0 (or H0, or A0)
6513 KFRES=KFHIGG
6514
6515 ELSEIF(ISUB.EQ.4) THEN
6516C...gamma + W+/- -> W+/-
6517
6518 ELSEIF(ISUB.EQ.5) THEN
6519C...Z0 + Z0 -> h0
6520 XH=SH/SHP
6521 MINT(21)=MINT(15)
6522 MINT(22)=MINT(16)
6523 PMQ(1)=PYMASS(MINT(21))
6524 PMQ(2)=PYMASS(MINT(22))
6525 220 JT=INT(1.5D0+PYR(0))
6526 ZMIN=2D0*PMQ(JT)/SHPR
6527 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6528 & (SHPR*(SHPR-PMQ(3-JT)))
6529 ZMAX=MIN(1D0-XH,ZMAX)
6530 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6531 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6532 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
6533 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6534 IF(SQC1.LT.1.D-8) GOTO 220
6535 C1=SQRT(SQC1)
6536 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6537 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6538 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6539 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6540 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6541 IF(SQC1.LT.1.D-8) GOTO 220
6542 C1=SQRT(SQC1)
6543 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6544 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6545 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6546 PHIR=PARU(2)*PYR(0)
6547 CPHI=COS(PHIR)
6548 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6549 & SQRT(1D0-CTHE(2)**2)*CPHI
6550 Z1=2D0-Z(JT)
6551 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6552 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6553 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6554 & PMQ(3-JT)**2/SHP))
6555 ZMIN=2D0*PMQ(3-JT)/SHPR
6556 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6557 ZMAX=MIN(1D0-XH,ZMAX)
6558 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
6559 KCC=22
6560 KFRES=25
6561
6562 ELSEIF(ISUB.EQ.6) THEN
6563C...Z0 + W+/- -> W+/-
6564
6565 ELSEIF(ISUB.EQ.7) THEN
6566C...W+ + W- -> Z0
6567
6568 ELSEIF(ISUB.EQ.8) THEN
6569C...W+ + W- -> h0
6570 XH=SH/SHP
6571 230 DO 260 JT=1,2
6572 I=MINT(14+JT)
6573 IA=IABS(I)
6574 IF(IA.LE.10) THEN
6575 RVCKM=VINT(180+I)*PYR(0)
6576 DO 240 J=1,MSTP(1)
6577 IB=2*J-1+MOD(IA,2)
6578 IPM=(5-ISIGN(1,I))/2
6579 IDC=J+MDCY(IA,2)+2
6580 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
6581 MINT(20+JT)=ISIGN(IB,I)
6582 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6583 IF(RVCKM.LE.0D0) GOTO 250
6584 240 CONTINUE
6585 ELSE
6586 IB=2*((IA+1)/2)-1+MOD(IA,2)
6587 MINT(20+JT)=ISIGN(IB,I)
6588 ENDIF
6589 250 PMQ(JT)=PYMASS(MINT(20+JT))
6590 260 CONTINUE
6591 JT=INT(1.5D0+PYR(0))
6592 ZMIN=2D0*PMQ(JT)/SHPR
6593 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6594 & (SHPR*(SHPR-PMQ(3-JT)))
6595 ZMAX=MIN(1D0-XH,ZMAX)
6596 IF(ZMIN.GE.ZMAX) GOTO 230
6597 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6598 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6599 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
6600 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6601 IF(SQC1.LT.1.D-8) GOTO 230
6602 C1=SQRT(SQC1)
6603 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6604 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6605 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6606 Z(3-JT)=1D0-XH/(1D0-Z(JT))
6607 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6608 IF(SQC1.LT.1.D-8) GOTO 230
6609 C1=SQRT(SQC1)
6610 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6611 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6612 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6613 PHIR=PARU(2)*PYR(0)
6614 CPHI=COS(PHIR)
6615 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6616 & SQRT(1D0-CTHE(2)**2)*CPHI
6617 Z1=2D0-Z(JT)
6618 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6619 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6620 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6621 & PMQ(3-JT)**2/SHP))
6622 ZMIN=2D0*PMQ(3-JT)/SHPR
6623 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6624 ZMAX=MIN(1D0-XH,ZMAX)
6625 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
6626 KCC=22
6627 KFRES=25
6628
6629 ELSEIF(ISUB.EQ.10) THEN
6630C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
6631 IF(MINT(2).EQ.1) THEN
6632 KCC=22
6633 ELSE
6634C...W exchange: need to mix flavours according to CKM matrix
6635 DO 280 JT=1,2
6636 I=MINT(14+JT)
6637 IA=IABS(I)
6638 IF(IA.LE.10) THEN
6639 RVCKM=VINT(180+I)*PYR(0)
6640 DO 270 J=1,MSTP(1)
6641 IB=2*J-1+MOD(IA,2)
6642 IPM=(5-ISIGN(1,I))/2
6643 IDC=J+MDCY(IA,2)+2
6644 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
6645 MINT(20+JT)=ISIGN(IB,I)
6646 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6647 IF(RVCKM.LE.0D0) GOTO 280
6648 270 CONTINUE
6649 ELSE
6650 IB=2*((IA+1)/2)-1+MOD(IA,2)
6651 MINT(20+JT)=ISIGN(IB,I)
6652 ENDIF
6653 280 CONTINUE
6654 KCC=22
6655 ENDIF
6656 ENDIF
6657
6658 ELSEIF(ISUB.LE.20) THEN
6659 IF(ISUB.EQ.11) THEN
6660C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
6661 KCC=MINT(2)
6662 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
6663
6664 ELSEIF(ISUB.EQ.12) THEN
6665C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
6666 MINT(21)=ISIGN(KFLF,MINT(15))
6667 MINT(22)=-MINT(21)
6668 KCC=4
6669
6670 ELSEIF(ISUB.EQ.13) THEN
6671C...f + fbar -> g + g; th arbitrary
6672 MINT(21)=21
6673 MINT(22)=21
6674 KCC=MINT(2)+4
6675
6676 ELSEIF(ISUB.EQ.14) THEN
6677C...f + fbar -> g + gamma; th arbitrary
6678 IF(PYR(0).GT.0.5D0) JS=2
6679 MINT(20+JS)=21
6680 MINT(23-JS)=22
6681 KCC=17+JS
6682
6683 ELSEIF(ISUB.EQ.15) THEN
6684C...f + fbar -> g + Z0; th arbitrary
6685 IF(PYR(0).GT.0.5D0) JS=2
6686 MINT(20+JS)=21
6687 MINT(23-JS)=23
6688 KCC=17+JS
6689
6690 ELSEIF(ISUB.EQ.16) THEN
6691C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6692 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6693 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6694 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6695 MINT(20+JS)=21
6696 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6697 KCC=17+JS
6698
6699 ELSEIF(ISUB.EQ.17) THEN
6700C...f + fbar -> g + h0; th arbitrary
6701 IF(PYR(0).GT.0.5D0) JS=2
6702 MINT(20+JS)=21
6703 MINT(23-JS)=25
6704 KCC=17+JS
6705
6706 ELSEIF(ISUB.EQ.18) THEN
6707C...f + fbar -> gamma + gamma; th arbitrary
6708 MINT(21)=22
6709 MINT(22)=22
6710
6711 ELSEIF(ISUB.EQ.19) THEN
6712C...f + fbar -> gamma + Z0; th arbitrary
6713 IF(PYR(0).GT.0.5D0) JS=2
6714 MINT(20+JS)=22
6715 MINT(23-JS)=23
6716
6717 ELSEIF(ISUB.EQ.20) THEN
6718C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
6719C...(p(fbar')-p(W+))**2
6720 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6721 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6722 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6723 MINT(20+JS)=22
6724 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6725 ENDIF
6726
6727 ELSEIF(ISUB.LE.30) THEN
6728 IF(ISUB.EQ.21) THEN
6729C...f + fbar -> gamma + h0; th arbitrary
6730 IF(PYR(0).GT.0.5D0) JS=2
6731 MINT(20+JS)=22
6732 MINT(23-JS)=25
6733
6734 ELSEIF(ISUB.EQ.22) THEN
6735C...f + fbar -> Z0 + Z0; th arbitrary
6736 MINT(21)=23
6737 MINT(22)=23
6738
6739 ELSEIF(ISUB.EQ.23) THEN
6740C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6741 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6742 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6743 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6744 MINT(20+JS)=23
6745 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6746
6747 ELSEIF(ISUB.EQ.24) THEN
6748C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
6749 IF(PYR(0).GT.0.5D0) JS=2
6750 MINT(20+JS)=23
6751 MINT(23-JS)=KFHIGG
6752
6753 ELSEIF(ISUB.EQ.25) THEN
6754C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
6755 MINT(21)=-ISIGN(24,MINT(15))
6756 MINT(22)=-MINT(21)
6757
6758 ELSEIF(ISUB.EQ.26) THEN
6759C...f + fbar' -> W+/- + h0 (or H0, or A0);
6760C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6761 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6762 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6763 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
6764 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
6765 MINT(23-JS)=KFHIGG
6766
6767 ELSEIF(ISUB.EQ.27) THEN
6768C...f + fbar -> h0 + h0
6769
6770 ELSEIF(ISUB.EQ.28) THEN
6771C...f + g -> f + g; th = (p(f)-p(f))**2
6772 KCC=MINT(2)+6
6773 IF(MINT(15).EQ.21) KCC=KCC+2
6774 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
6775 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
6776
6777 ELSEIF(ISUB.EQ.29) THEN
6778C...f + g -> f + gamma; th = (p(f)-p(f))**2
6779 IF(MINT(15).EQ.21) JS=2
6780 MINT(23-JS)=22
6781 KCC=15+JS
6782 KCS=ISIGN(1,MINT(14+JS))
6783
6784 ELSEIF(ISUB.EQ.30) THEN
6785C...f + g -> f + Z0; th = (p(f)-p(f))**2
6786 IF(MINT(15).EQ.21) JS=2
6787 MINT(23-JS)=23
6788 KCC=15+JS
6789 KCS=ISIGN(1,MINT(14+JS))
6790 ENDIF
6791
6792 ELSEIF(ISUB.LE.40) THEN
6793 IF(ISUB.EQ.31) THEN
6794C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
6795 IF(MINT(15).EQ.21) JS=2
6796 I=MINT(14+JS)
6797 IA=IABS(I)
6798 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6799 RVCKM=VINT(180+I)*PYR(0)
6800 DO 290 J=1,MSTP(1)
6801 IB=2*J-1+MOD(IA,2)
6802 IPM=(5-ISIGN(1,I))/2
6803 IDC=J+MDCY(IA,2)+2
6804 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
6805 MINT(20+JS)=ISIGN(IB,I)
6806 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6807 IF(RVCKM.LE.0D0) GOTO 300
6808 290 CONTINUE
6809 300 KCC=15+JS
6810 KCS=ISIGN(1,MINT(14+JS))
6811
6812 ELSEIF(ISUB.EQ.32) THEN
6813C...f + g -> f + h0; th = (p(f)-p(f))**2
6814 IF(MINT(15).EQ.21) JS=2
6815 MINT(23-JS)=25
6816 KCC=15+JS
6817 KCS=ISIGN(1,MINT(14+JS))
6818
6819 ELSEIF(ISUB.EQ.33) THEN
6820C...f + gamma -> f + g; th=(p(f)-p(f))**2
6821 IF(MINT(15).EQ.22) JS=2
6822 MINT(23-JS)=21
6823 KCC=24+JS
6824 KCS=ISIGN(1,MINT(14+JS))
6825
6826 ELSEIF(ISUB.EQ.34) THEN
6827C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
6828 IF(MINT(15).EQ.22) JS=2
6829 KCC=22
6830 KCS=ISIGN(1,MINT(14+JS))
6831
6832 ELSEIF(ISUB.EQ.35) THEN
6833C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
6834 IF(MINT(15).EQ.22) JS=2
6835 MINT(23-JS)=23
6836 KCC=22
6837
6838 ELSEIF(ISUB.EQ.36) THEN
6839C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
6840 IF(MINT(15).EQ.22) JS=2
6841 I=MINT(14+JS)
6842 IA=IABS(I)
6843 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6844 IF(IA.LE.10) THEN
6845 RVCKM=VINT(180+I)*PYR(0)
6846 DO 310 J=1,MSTP(1)
6847 IB=2*J-1+MOD(IA,2)
6848 IPM=(5-ISIGN(1,I))/2
6849 IDC=J+MDCY(IA,2)+2
6850 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
6851 MINT(20+JS)=ISIGN(IB,I)
6852 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6853 IF(RVCKM.LE.0D0) GOTO 320
6854 310 CONTINUE
6855 ELSE
6856 IB=2*((IA+1)/2)-1+MOD(IA,2)
6857 MINT(20+JS)=ISIGN(IB,I)
6858 ENDIF
6859 320 KCC=22
6860
6861 ELSEIF(ISUB.EQ.37) THEN
6862C...f + gamma -> f + h0
6863
6864 ELSEIF(ISUB.EQ.38) THEN
6865C...f + Z0 -> f + g
6866
6867 ELSEIF(ISUB.EQ.39) THEN
6868C...f + Z0 -> f + gamma
6869
6870 ELSEIF(ISUB.EQ.40) THEN
6871C...f + Z0 -> f + Z0
6872 ENDIF
6873
6874 ELSEIF(ISUB.LE.50) THEN
6875 IF(ISUB.EQ.41) THEN
6876C...f + Z0 -> f' + W+/-
6877
6878 ELSEIF(ISUB.EQ.42) THEN
6879C...f + Z0 -> f + h0
6880
6881 ELSEIF(ISUB.EQ.43) THEN
6882C...f + W+/- -> f' + g
6883
6884 ELSEIF(ISUB.EQ.44) THEN
6885C...f + W+/- -> f' + gamma
6886
6887 ELSEIF(ISUB.EQ.45) THEN
6888C...f + W+/- -> f' + Z0
6889
6890 ELSEIF(ISUB.EQ.46) THEN
6891C...f + W+/- -> f' + W+/-
6892
6893 ELSEIF(ISUB.EQ.47) THEN
6894C...f + W+/- -> f' + h0
6895
6896 ELSEIF(ISUB.EQ.48) THEN
6897C...f + h0 -> f + g
6898
6899 ELSEIF(ISUB.EQ.49) THEN
6900C...f + h0 -> f + gamma
6901
6902 ELSEIF(ISUB.EQ.50) THEN
6903C...f + h0 -> f + Z0
6904 ENDIF
6905
6906 ELSEIF(ISUB.LE.60) THEN
6907 IF(ISUB.EQ.51) THEN
6908C...f + h0 -> f' + W+/-
6909
6910 ELSEIF(ISUB.EQ.52) THEN
6911C...f + h0 -> f + h0
6912
6913 ELSEIF(ISUB.EQ.53) THEN
6914C...g + g -> f + fbar; th arbitrary
6915 KCS=(-1)**INT(1.5D0+PYR(0))
6916 MINT(21)=ISIGN(KFLF,KCS)
6917 MINT(22)=-MINT(21)
6918 KCC=MINT(2)+10
6919
6920 ELSEIF(ISUB.EQ.54) THEN
6921C...g + gamma -> f + fbar; th arbitrary
6922 KCS=(-1)**INT(1.5D0+PYR(0))
6923 MINT(21)=ISIGN(KFLF,KCS)
6924 MINT(22)=-MINT(21)
6925 KCC=27
6926 IF(MINT(16).EQ.21) KCC=28
6927
6928 ELSEIF(ISUB.EQ.55) THEN
6929C...g + Z0 -> f + fbar
6930
6931 ELSEIF(ISUB.EQ.56) THEN
6932C...g + W+/- -> f + fbar'
6933
6934 ELSEIF(ISUB.EQ.57) THEN
6935C...g + h0 -> f + fbar
6936
6937 ELSEIF(ISUB.EQ.58) THEN
6938C...gamma + gamma -> f + fbar; th arbitrary
6939 KCS=(-1)**INT(1.5D0+PYR(0))
6940 MINT(21)=ISIGN(KFLF,KCS)
6941 MINT(22)=-MINT(21)
6942 KCC=21
6943
6944 ELSEIF(ISUB.EQ.59) THEN
6945C...gamma + Z0 -> f + fbar
6946
6947 ELSEIF(ISUB.EQ.60) THEN
6948C...gamma + W+/- -> f + fbar'
6949 ENDIF
6950
6951 ELSEIF(ISUB.LE.70) THEN
6952 IF(ISUB.EQ.61) THEN
6953C...gamma + h0 -> f + fbar
6954
6955 ELSEIF(ISUB.EQ.62) THEN
6956C...Z0 + Z0 -> f + fbar
6957
6958 ELSEIF(ISUB.EQ.63) THEN
6959C...Z0 + W+/- -> f + fbar'
6960
6961 ELSEIF(ISUB.EQ.64) THEN
6962C...Z0 + h0 -> f + fbar
6963
6964 ELSEIF(ISUB.EQ.65) THEN
6965C...W+ + W- -> f + fbar
6966
6967 ELSEIF(ISUB.EQ.66) THEN
6968C...W+/- + h0 -> f + fbar'
6969
6970 ELSEIF(ISUB.EQ.67) THEN
6971C...h0 + h0 -> f + fbar
6972
6973 ELSEIF(ISUB.EQ.68) THEN
6974C...g + g -> g + g; th arbitrary
6975 KCC=MINT(2)+12
6976 KCS=(-1)**INT(1.5D0+PYR(0))
6977
6978 ELSEIF(ISUB.EQ.69) THEN
6979C...gamma + gamma -> W+ + W-; th arbitrary
6980 MINT(21)=24
6981 MINT(22)=-24
6982 KCC=21
6983
6984 ELSEIF(ISUB.EQ.70) THEN
6985C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
6986 IF(MINT(15).EQ.22) MINT(21)=23
6987 IF(MINT(16).EQ.22) MINT(22)=23
6988 KCC=21
6989 ENDIF
6990
6991 ELSEIF(ISUB.LE.80) THEN
6992 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
6993C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
6994 XH=SH/SHP
6995 MINT(21)=MINT(15)
6996 MINT(22)=MINT(16)
6997 PMQ(1)=PYMASS(MINT(21))
6998 PMQ(2)=PYMASS(MINT(22))
6999 330 JT=INT(1.5D0+PYR(0))
7000 ZMIN=2D0*PMQ(JT)/SHPR
7001 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7002 & (SHPR*(SHPR-PMQ(3-JT)))
7003 ZMAX=MIN(1D0-XH,ZMAX)
7004 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7005 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7006 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
7007 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7008 IF(SQC1.LT.1.D-8) GOTO 330
7009 C1=SQRT(SQC1)
7010 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7011 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7012 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7013 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7014 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7015 IF(SQC1.LT.1.D-8) GOTO 330
7016 C1=SQRT(SQC1)
7017 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7018 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7019 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7020 PHIR=PARU(2)*PYR(0)
7021 CPHI=COS(PHIR)
7022 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7023 & SQRT(1D0-CTHE(2)**2)*CPHI
7024 Z1=2D0-Z(JT)
7025 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7026 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7027 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7028 & PMQ(3-JT)**2/SHP))
7029 ZMIN=2D0*PMQ(3-JT)/SHPR
7030 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7031 ZMAX=MIN(1D0-XH,ZMAX)
7032 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
7033 KCC=22
7034
7035 ELSEIF(ISUB.EQ.73) THEN
7036C...Z0 + W+/- -> Z0 + W+/-
7037 JS=MINT(2)
7038 XH=SH/SHP
7039 340 JT=3-MINT(2)
7040 I=MINT(14+JT)
7041 IA=IABS(I)
7042 IF(IA.LE.10) THEN
7043 RVCKM=VINT(180+I)*PYR(0)
7044 DO 350 J=1,MSTP(1)
7045 IB=2*J-1+MOD(IA,2)
7046 IPM=(5-ISIGN(1,I))/2
7047 IDC=J+MDCY(IA,2)+2
7048 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
7049 MINT(20+JT)=ISIGN(IB,I)
7050 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7051 IF(RVCKM.LE.0D0) GOTO 360
7052 350 CONTINUE
7053 ELSE
7054 IB=2*((IA+1)/2)-1+MOD(IA,2)
7055 MINT(20+JT)=ISIGN(IB,I)
7056 ENDIF
7057 360 PMQ(JT)=PYMASS(MINT(20+JT))
7058 MINT(23-JT)=MINT(17-JT)
7059 PMQ(3-JT)=PYMASS(MINT(23-JT))
7060 JT=INT(1.5D0+PYR(0))
7061 ZMIN=2D0*PMQ(JT)/SHPR
7062 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7063 & (SHPR*(SHPR-PMQ(3-JT)))
7064 ZMAX=MIN(1D0-XH,ZMAX)
7065 IF(ZMIN.GE.ZMAX) GOTO 340
7066 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7067 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7068 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
7069 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7070 IF(SQC1.LT.1.D-8) GOTO 340
7071 C1=SQRT(SQC1)
7072 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7073 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7074 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7075 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7076 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7077 IF(SQC1.LT.1.D-8) GOTO 340
7078 C1=SQRT(SQC1)
7079 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7080 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7081 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7082 PHIR=PARU(2)*PYR(0)
7083 CPHI=COS(PHIR)
7084 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7085 & SQRT(1D0-CTHE(2)**2)*CPHI
7086 Z1=2D0-Z(JT)
7087 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7088 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7089 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7090 & PMQ(3-JT)**2/SHP))
7091 ZMIN=2D0*PMQ(3-JT)/SHPR
7092 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7093 ZMAX=MIN(1D0-XH,ZMAX)
7094 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
7095 KCC=22
7096
7097 ELSEIF(ISUB.EQ.74) THEN
7098C...Z0 + h0 -> Z0 + h0
7099
7100 ELSEIF(ISUB.EQ.75) THEN
7101C...W+ + W- -> gamma + gamma
7102
7103 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
7104C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
7105 XH=SH/SHP
7106 370 DO 400 JT=1,2
7107 I=MINT(14+JT)
7108 IA=IABS(I)
7109 IF(IA.LE.10) THEN
7110 RVCKM=VINT(180+I)*PYR(0)
7111 DO 380 J=1,MSTP(1)
7112 IB=2*J-1+MOD(IA,2)
7113 IPM=(5-ISIGN(1,I))/2
7114 IDC=J+MDCY(IA,2)+2
7115 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
7116 MINT(20+JT)=ISIGN(IB,I)
7117 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7118 IF(RVCKM.LE.0D0) GOTO 390
7119 380 CONTINUE
7120 ELSE
7121 IB=2*((IA+1)/2)-1+MOD(IA,2)
7122 MINT(20+JT)=ISIGN(IB,I)
7123 ENDIF
7124 390 PMQ(JT)=PYMASS(MINT(20+JT))
7125 400 CONTINUE
7126 JT=INT(1.5D0+PYR(0))
7127 ZMIN=2D0*PMQ(JT)/SHPR
7128 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7129 & (SHPR*(SHPR-PMQ(3-JT)))
7130 ZMAX=MIN(1D0-XH,ZMAX)
7131 IF(ZMIN.GE.ZMAX) GOTO 370
7132 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7133 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7134 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
7135 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7136 IF(SQC1.LT.1.D-8) GOTO 370
7137 C1=SQRT(SQC1)
7138 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7139 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7140 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7141 Z(3-JT)=1D0-XH/(1D0-Z(JT))
7142 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7143 IF(SQC1.LT.1.D-8) GOTO 370
7144 C1=SQRT(SQC1)
7145 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7146 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7147 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7148 PHIR=PARU(2)*PYR(0)
7149 CPHI=COS(PHIR)
7150 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7151 & SQRT(1D0-CTHE(2)**2)*CPHI
7152 Z1=2D0-Z(JT)
7153 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7154 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7155 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7156 & PMQ(3-JT)**2/SHP))
7157 ZMIN=2D0*PMQ(3-JT)/SHPR
7158 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7159 ZMAX=MIN(1D0-XH,ZMAX)
7160 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
7161 KCC=22
7162
7163 ELSEIF(ISUB.EQ.78) THEN
7164C...W+/- + h0 -> W+/- + h0
7165
7166 ELSEIF(ISUB.EQ.79) THEN
7167C...h0 + h0 -> h0 + h0
7168
7169 ELSEIF(ISUB.EQ.80) THEN
7170C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
7171 IF(MINT(15).EQ.22) JS=2
7172 I=MINT(14+JS)
7173 IA=IABS(I)
7174 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
7175 IB=3-IA
7176 MINT(20+JS)=ISIGN(IB,I)
7177 KCC=22
7178 ENDIF
7179
7180 ELSEIF(ISUB.LE.90) THEN
7181 IF(ISUB.EQ.81) THEN
7182C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
7183 MINT(21)=ISIGN(MINT(55),MINT(15))
7184 MINT(22)=-MINT(21)
7185 KCC=4
7186
7187 ELSEIF(ISUB.EQ.82) THEN
7188C...g + g -> Q + Qbar; th arbitrary
7189 KCS=(-1)**INT(1.5D0+PYR(0))
7190 MINT(21)=ISIGN(MINT(55),KCS)
7191 MINT(22)=-MINT(21)
7192 KCC=MINT(2)+10
7193
7194 ELSEIF(ISUB.EQ.83) THEN
7195C...f + q -> f' + Q; th = (p(f) - p(f'))**2
7196 KFOLD=MINT(16)
7197 IF(MINT(2).EQ.2) KFOLD=MINT(15)
7198 KFAOLD=IABS(KFOLD)
7199 IF(KFAOLD.GT.10) THEN
7200 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
7201 ELSE
7202 RCKM=VINT(180+KFOLD)*PYR(0)
7203 IPM=(5-ISIGN(1,KFOLD))/2
7204 KFANEW=-MOD(KFAOLD+1,2)
7205 410 KFANEW=KFANEW+2
7206 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
7207 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
7208 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
7209 & VCKM(KFAOLD/2,(KFANEW+1)/2)
7210 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
7211 & VCKM(KFANEW/2,(KFAOLD+1)/2)
7212 ENDIF
7213 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
7214 ENDIF
7215 IF(MINT(2).EQ.1) THEN
7216 MINT(21)=ISIGN(MINT(55),MINT(15))
7217 MINT(22)=ISIGN(KFANEW,MINT(16))
7218 ELSE
7219 MINT(21)=ISIGN(KFANEW,MINT(15))
7220 MINT(22)=ISIGN(MINT(55),MINT(16))
7221 JS=2
7222 ENDIF
7223 KCC=22
7224
7225 ELSEIF(ISUB.EQ.84) THEN
7226C...g + gamma -> Q + Qbar; th arbitary
7227 KCS=(-1)**INT(1.5D0+PYR(0))
7228 MINT(21)=ISIGN(MINT(55),KCS)
7229 MINT(22)=-MINT(21)
7230 KCC=27
7231 IF(MINT(16).EQ.21) KCC=28
7232
7233 ELSEIF(ISUB.EQ.85) THEN
7234C...gamma + gamma -> F + Fbar; th arbitary
7235 KCS=(-1)**INT(1.5D0+PYR(0))
7236 MINT(21)=ISIGN(MINT(56),KCS)
7237 MINT(22)=-MINT(21)
7238 KCC=21
7239
7240 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
7241C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
7242 MINT(21)=KFPR(ISUB,1)
7243 MINT(22)=KFPR(ISUB,2)
7244 KCC=24
7245 KCS=(-1)**INT(1.5D0+PYR(0))
7246 ENDIF
7247
7248 ELSEIF(ISUB.LE.100) THEN
7249 IF(ISUB.EQ.95) THEN
7250C...Low-pT ( = energyless g + g -> g + g)
7251 KCC=MINT(2)+12
7252 KCS=(-1)**INT(1.5D0+PYR(0))
7253
7254 ELSEIF(ISUB.EQ.96) THEN
7255C...Multiple interactions (should be reassigned to QCD process)
7256 ENDIF
7257
7258 ELSEIF(ISUB.LE.110) THEN
7259 IF(ISUB.EQ.101) THEN
7260C...g + g -> gamma*/Z0
7261 KCC=21
7262 KFRES=22
7263
7264 ELSEIF(ISUB.EQ.102) THEN
7265C...g + g -> h0 (or H0, or A0)
7266 KCC=21
7267 KFRES=KFHIGG
7268
7269 ELSEIF(ISUB.EQ.103) THEN
7270C...gamma + gamma -> h0 (or H0, or A0)
7271 KCC=21
7272 KFRES=KFHIGG
7273
7274 ELSEIF(ISUB.EQ.106) THEN
7275C...g + g -> J/Psi + gamma
7276 MINT(21)=KFPR(ISUB,1)
7277 MINT(22)=KFPR(ISUB,2)
7278 KCC=21
7279
7280 ELSEIF(ISUB.EQ.107) THEN
7281C...g + gamma -> J/Psi + g
7282 MINT(21)=KFPR(ISUB,1)
7283 MINT(22)=KFPR(ISUB,2)
7284 KCC=22
7285 IF(MINT(16).EQ.22) KCC=33
7286
7287 ELSEIF(ISUB.EQ.108) THEN
7288C...gamma + gamma -> J/Psi + gamma
7289 MINT(21)=KFPR(ISUB,1)
7290 MINT(22)=KFPR(ISUB,2)
7291
7292 ELSEIF(ISUB.EQ.110) THEN
7293C...f + fbar -> gamma + h0; th arbitrary
7294 IF(PYR(0).GT.0.5D0) JS=2
7295 MINT(20+JS)=22
7296 MINT(23-JS)=KFHIGG
7297 ENDIF
7298
7299 ELSEIF(ISUB.LE.120) THEN
7300 IF(ISUB.EQ.111) THEN
7301C...f + fbar -> g + h0; th arbitrary
7302 IF(PYR(0).GT.0.5D0) JS=2
7303 MINT(20+JS)=21
7304 MINT(23-JS)=25
7305 KCC=17+JS
7306
7307 ELSEIF(ISUB.EQ.112) THEN
7308C...f + g -> f + h0; th = (p(f) - p(f))**2
7309 IF(MINT(15).EQ.21) JS=2
7310 MINT(23-JS)=25
7311 KCC=15+JS
7312 KCS=ISIGN(1,MINT(14+JS))
7313
7314 ELSEIF(ISUB.EQ.113) THEN
7315C...g + g -> g + h0; th arbitrary
7316 IF(PYR(0).GT.0.5D0) JS=2
7317 MINT(23-JS)=25
7318 KCC=22+JS
7319 KCS=(-1)**INT(1.5D0+PYR(0))
7320
7321 ELSEIF(ISUB.EQ.114) THEN
7322C...g + g -> gamma + gamma; th arbitrary
7323 IF(PYR(0).GT.0.5D0) JS=2
7324 MINT(21)=22
7325 MINT(22)=22
7326 KCC=21
7327
7328 ELSEIF(ISUB.EQ.115) THEN
7329C...g + g -> g + gamma; th arbitrary
7330 IF(PYR(0).GT.0.5D0) JS=2
7331 MINT(23-JS)=22
7332 KCC=22+JS
7333 KCS=(-1)**INT(1.5D0+PYR(0))
7334
7335 ELSEIF(ISUB.EQ.116) THEN
7336C...g + g -> gamma + Z0
7337
7338 ELSEIF(ISUB.EQ.117) THEN
7339C...g + g -> Z0 + Z0
7340
7341 ELSEIF(ISUB.EQ.118) THEN
7342C...g + g -> W+ + W-
7343 ENDIF
7344
7345 ELSEIF(ISUB.LE.140) THEN
7346 IF(ISUB.EQ.121) THEN
7347C...g + g -> Q + Qbar + h0
7348 KCS=(-1)**INT(1.5D0+PYR(0))
7349 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
7350 MINT(22)=-MINT(21)
7351 KCC=11+INT(0.5D0+PYR(0))
7352 KFRES=KFHIGG
7353
7354 ELSEIF(ISUB.EQ.122) THEN
7355C...q + qbar -> Q + Qbar + h0
7356 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
7357 MINT(22)=-MINT(21)
7358 KCC=4
7359 KFRES=KFHIGG
7360
7361 ELSEIF(ISUB.EQ.123) THEN
7362C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
7363C...inner process)
7364 KCC=22
7365 KFRES=KFHIGG
7366
7367 ELSEIF(ISUB.EQ.124) THEN
7368C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
7369C...inner process)
7370 DO 430 JT=1,2
7371 I=MINT(14+JT)
7372 IA=IABS(I)
7373 IF(IA.LE.10) THEN
7374 RVCKM=VINT(180+I)*PYR(0)
7375 DO 420 J=1,MSTP(1)
7376 IB=2*J-1+MOD(IA,2)
7377 IPM=(5-ISIGN(1,I))/2
7378 IDC=J+MDCY(IA,2)+2
7379 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
7380 MINT(20+JT)=ISIGN(IB,I)
7381 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7382 IF(RVCKM.LE.0D0) GOTO 430
7383 420 CONTINUE
7384 ELSE
7385 IB=2*((IA+1)/2)-1+MOD(IA,2)
7386 MINT(20+JT)=ISIGN(IB,I)
7387 ENDIF
7388 430 CONTINUE
7389 KCC=22
7390 KFRES=KFHIGG
7391
7392 ELSEIF(ISUB.EQ.131) THEN
7393C...g + g -> Z0 + q + qbar
7394 ENDIF
7395
7396 ELSEIF(ISUB.LE.160) THEN
7397 IF(ISUB.EQ.141) THEN
7398C...f + fbar -> gamma*/Z0/Z'0
7399 KFRES=32
7400
7401 ELSEIF(ISUB.EQ.142) THEN
7402C...f + fbar' -> W'+/-
7403 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7404 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7405 KFRES=ISIGN(34,KCH1+KCH2)
7406
7407 ELSEIF(ISUB.EQ.143) THEN
7408C...f + fbar' -> H+/-
7409 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7410 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7411 KFRES=ISIGN(37,KCH1+KCH2)
7412
7413 ELSEIF(ISUB.EQ.144) THEN
7414C...f + fbar' -> R
7415 KFRES=ISIGN(40,MINT(15)+MINT(16))
7416
7417 ELSEIF(ISUB.EQ.145) THEN
7418C...q + l -> LQ (leptoquark)
7419 IF(IABS(MINT(16)).LE.8) JS=2
7420 KFRES=ISIGN(39,MINT(14+JS))
7421 KCC=28+JS
7422 KCS=ISIGN(1,MINT(14+JS))
7423
7424 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
7425C...q + g -> q* (excited quark)
7426 IF(MINT(15).EQ.21) JS=2
7427 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
7428 KCC=30+JS
7429 KCS=ISIGN(1,MINT(14+JS))
7430
7431 ELSEIF(ISUB.EQ.149) THEN
7432C...g + g -> eta_techni
7433 KFRES=38
7434 KCC=23
7435 KCS=(-1)**INT(1.5D0+PYR(0))
7436 ENDIF
7437
7438 ELSEIF(ISUB.LE.200) THEN
7439 IF(ISUB.EQ.161) THEN
7440C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
7441 IF(MINT(15).EQ.21) JS=2
7442 I=MINT(14+JS)
7443 IA=IABS(I)
7444 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
7445 IB=IA+MOD(IA,2)-MOD(IA+1,2)
7446 MINT(20+JS)=ISIGN(IB,I)
7447 KCC=15+JS
7448 KCS=ISIGN(1,MINT(14+JS))
7449
7450 ELSEIF(ISUB.EQ.162) THEN
7451C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
7452 IF(MINT(15).EQ.21) JS=2
7453 MINT(20+JS)=ISIGN(39,MINT(14+JS))
7454 KFLQL=KFDP(MDCY(39,2),2)
7455 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
7456 KCC=15+JS
7457 KCS=ISIGN(1,MINT(14+JS))
7458
7459 ELSEIF(ISUB.EQ.163) THEN
7460C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
7461 KCS=(-1)**INT(1.5D0+PYR(0))
7462 MINT(21)=ISIGN(39,KCS)
7463 MINT(22)=-MINT(21)
7464 KCC=MINT(2)+10
7465
7466 ELSEIF(ISUB.EQ.164) THEN
7467C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
7468 MINT(21)=ISIGN(39,MINT(15))
7469 MINT(22)=-MINT(21)
7470 KCC=4
7471
7472 ELSEIF(ISUB.EQ.165) THEN
7473C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
7474 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7475 MINT(22)=-MINT(21)
7476
7477 ELSEIF(ISUB.EQ.166) THEN
7478C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
7479 IF(MOD(MINT(15),2).EQ.0) THEN
7480 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
7481 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
7482 ELSE
7483 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7484 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
7485 ENDIF
7486
7487 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
7488C...q + q' -> q" + q* (excited quark)
7489 KFQSTR=KFPR(ISUB,2)
7490 KFQEXC=MOD(KFQSTR,KEXCIT)
7491 JS=MINT(2)
7492 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
7493 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
7494 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
7495 KCC=22
7496
7497 ELSEIF(ISUB.EQ.191) THEN
7498C...f + fbar -> rho_tech0.
7499 KFRES=54
7500
7501 ELSEIF(ISUB.EQ.192) THEN
7502C...f + fbar' -> rho_tech+/-
7503 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7504 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7505 KFRES=ISIGN(55,KCH1+KCH2)
7506
7507 ELSEIF(ISUB.EQ.193) THEN
7508C...f + fbar -> omega_tech0.
7509 KFRES=56
7510
7511 ELSEIF(ISUB.EQ.194) THEN
7512C...f + fbar -> f' + fbar' via mixture of s-channel
7513C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
7514 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7515 MINT(22)=-MINT(21)
7516 ENDIF
7517
7518CMRENNA++
7519 ELSEIF(ISUB.LE.215) THEN
7520 IF(ISUB.EQ.201) THEN
7521C...f + fbar -> ~e_L + ~e_Lbar
7522 MINT(21)=ISIGN(KSUSY1+11,KCS)
7523 MINT(22)=-MINT(21)
7524
7525 ELSEIF(ISUB.EQ.202) THEN
7526C...f + fbar -> ~e_R + ~e_Rbar
7527 MINT(21)=ISIGN(KSUSY2+11,KCS)
7528 MINT(22)=-MINT(21)
7529
7530 ELSEIF(ISUB.EQ.203) THEN
7531C...f + fbar -> ~e_R + ~e_Lbar
7532 KCS=1
7533 IF(MINT(2).EQ.2) KCS=-1
7534 MINT(21)=ISIGN(KSUSY1+11,KCS)
7535 MINT(22)=-ISIGN(KSUSY2+11,KCS)
7536
7537 ELSEIF(ISUB.EQ.204) THEN
7538C...f + fbar -> ~mu_L + ~mu_Lbar
7539 MINT(21)=ISIGN(KSUSY1+13,KCS)
7540 MINT(22)=-MINT(21)
7541
7542 ELSEIF(ISUB.EQ.205) THEN
7543C...f + fbar -> ~mu_R + ~mu_Rbar
7544 MINT(21)=ISIGN(KSUSY2+13,KCS)
7545 MINT(22)=-MINT(21)
7546
7547 ELSEIF(ISUB.EQ.206) THEN
7548C...f + fbar -> ~mu_L + ~mu_Rbar
7549 KCS=1
7550 IF(MINT(2).EQ.2) KCS=-1
7551 MINT(21)=ISIGN(KSUSY1+13,KCS)
7552 MINT(22)=-ISIGN(KSUSY2+13,KCS)
7553
7554 ELSEIF(ISUB.EQ.207) THEN
7555C...f + fbar -> ~tau_1 + ~tau_1bar
7556 MINT(21)=ISIGN(KSUSY1+15,KCS)
7557 MINT(22)=-MINT(21)
7558
7559 ELSEIF(ISUB.EQ.208) THEN
7560C...f + fbar -> ~tau_2 + ~tau_2bar
7561 MINT(21)=ISIGN(KSUSY2+15,KCS)
7562 MINT(22)=-MINT(21)
7563
7564 ELSEIF(ISUB.EQ.209) THEN
7565C...f + fbar -> ~tau_1 + ~tau_2bar
7566 KCS=1
7567 IF(MINT(2).EQ.2) KCS=-1
7568 MINT(21)=ISIGN(KSUSY1+15,KCS)
7569 MINT(22)=-ISIGN(KSUSY2+15,KCS)
7570
7571 ELSEIF(ISUB.EQ.210) THEN
7572C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
7573 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7574 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7575 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
7576 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
7577
7578 ELSEIF(ISUB.EQ.211) THEN
7579C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
7580 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7581 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7582 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
7583 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7584
7585 ELSEIF(ISUB.EQ.212) THEN
7586C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
7587 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7588 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7589 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
7590 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7591
7592 ELSEIF(ISUB.EQ.213) THEN
7593C...f + fbar -> ~nul + ~nulbar
7594 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7595 MINT(22)=-MINT(21)
7596
7597 ELSEIF(ISUB.EQ.214) THEN
7598C...f + fbar -> ~nutau + ~nutaubar
7599 MINT(21)=ISIGN(KSUSY1+16,KCS)
7600 MINT(22)=-MINT(21)
7601 ENDIF
7602
7603 ELSEIF(ISUB.LE.225) THEN
7604 IF(ISUB.EQ.216) THEN
7605C...f + fbar -> ~chi01 + ~chi01
7606 MINT(21)=KSUSY1+22
7607 MINT(22)=KSUSY1+22
7608
7609 ELSEIF(ISUB.EQ.217) THEN
7610C...f + fbar -> ~chi02 + ~chi02
7611 MINT(21)=KSUSY1+23
7612 MINT(22)=KSUSY1+23
7613
7614 ELSEIF(ISUB.EQ.218 ) THEN
7615C...f + fbar -> ~chi03 + ~chi03
7616 MINT(21)=KSUSY1+25
7617 MINT(22)=KSUSY1+25
7618
7619 ELSEIF(ISUB.EQ.219 ) THEN
7620C...f + fbar -> ~chi04 + ~chi04
7621 MINT(21)=KSUSY1+35
7622 MINT(22)=KSUSY1+35
7623
7624 ELSEIF(ISUB.EQ.220 ) THEN
7625C...f + fbar -> ~chi01 + ~chi02
7626 IF(PYR(0).GT.0.5D0) JS=2
7627 MINT(20+JS)=KSUSY1+22
7628 MINT(23-JS)=KSUSY1+23
7629
7630 ELSEIF(ISUB.EQ.221 ) THEN
7631C...f + fbar -> ~chi01 + ~chi03
7632 IF(PYR(0).GT.0.5D0) JS=2
7633 MINT(20+JS)=KSUSY1+22
7634 MINT(23-JS)=KSUSY1+25
7635
7636 ELSEIF(ISUB.EQ.222) THEN
7637C...f + fbar -> ~chi01 + ~chi04
7638 IF(PYR(0).GT.0.5D0) JS=2
7639 MINT(20+JS)=KSUSY1+22
7640 MINT(23-JS)=KSUSY1+35
7641
7642 ELSEIF(ISUB.EQ.223) THEN
7643C...f + fbar -> ~chi02 + ~chi03
7644 IF(PYR(0).GT.0.5D0) JS=2
7645 MINT(20+JS)=KSUSY1+23
7646 MINT(23-JS)=KSUSY1+25
7647
7648 ELSEIF(ISUB.EQ.224) THEN
7649C...f + fbar -> ~chi02 + ~chi04
7650 IF(PYR(0).GT.0.5D0) JS=2
7651 MINT(20+JS)=KSUSY1+23
7652 MINT(23-JS)=KSUSY1+35
7653
7654 ELSEIF(ISUB.EQ.225) THEN
7655C...f + fbar -> ~chi03 + ~chi04
7656 IF(PYR(0).GT.0.5D0) JS=2
7657 MINT(20+JS)=KSUSY1+25
7658 MINT(23-JS)=KSUSY1+35
7659 ENDIF
7660
7661 ELSEIF(ISUB.LE.236) THEN
7662 IF(ISUB.EQ.226) THEN
7663C...f + fbar -> ~chi+-1 + ~chi-+1
7664C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
7665 MINT(21)=ISIGN(KSUSY1+24,MINT(15))
7666 MINT(22)=-MINT(21)
7667
7668 ELSEIF(ISUB.EQ.227) THEN
7669C...f + fbar -> ~chi+-2 + ~chi-+2
7670 MINT(21)=ISIGN(KSUSY1+37,MINT(15))
7671 MINT(22)=-MINT(21)
7672
7673 ELSEIF(ISUB.EQ.228) THEN
7674C...f + fbar -> ~chi+-1 + ~chi-+2
7675C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
7676C...js=1 if pyr<.5, js=2 if pyr>.5
7677C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
7678C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
7679C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
7680C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
7681 KCH1=ISIGN(1,MINT(15))
7682 KCH2=INT(1-KCH1)/2
7683 IF(MINT(2).EQ.1) THEN
7684 MINT(22-KCH2)= -(KSUSY1+24)
7685 MINT(21+KCH2)= KSUSY1+37
7686 IF(KCH2.EQ.0) JS=2
7687 ELSE
7688 MINT(21+KCH2)= KSUSY1+24
7689 MINT(22-KCH2)= -(KSUSY1+37)
7690 IF(KCH2.EQ.1) JS=2
7691 ENDIF
7692
7693 ELSEIF(ISUB.EQ.229) THEN
7694C...q + qbar' -> ~chi01 + ~chi+-1
7695C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
7696 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7697 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7698C...CHECK THIS
7699 IF(MOD(MINT(15),2).NE.0) JS=2
7700 MINT(20+JS)=KSUSY1+22
7701 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7702
7703 ELSEIF(ISUB.EQ.230) THEN
7704C...q + qbar' -> ~chi02 + ~chi+-1
7705 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7706 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7707 IF(MOD(MINT(15),2).NE.0) JS=2
7708 MINT(20+JS)=KSUSY1+23
7709 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7710
7711 ELSEIF(ISUB.EQ.231) THEN
7712C...q + qbar' -> ~chi03 + ~chi+-1
7713 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7714 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7715 IF(MOD(MINT(15),2).NE.0) JS=2
7716 MINT(20+JS)=KSUSY1+25
7717 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7718
7719 ELSEIF(ISUB.EQ.232) THEN
7720C...q + qbar' -> ~chi04 + ~chi+-1
7721 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7722 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7723 IF(MOD(MINT(15),2).NE.0) JS=2
7724 MINT(20+JS)=KSUSY1+35
7725 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7726
7727 ELSEIF(ISUB.EQ.233) THEN
7728C...q + qbar' -> ~chi01 + ~chi+-2
7729 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7730 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7731 IF(MOD(MINT(15),2).NE.0) JS=2
7732 MINT(20+JS)=KSUSY1+22
7733 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7734
7735 ELSEIF(ISUB.EQ.234) THEN
7736C...q + qbar' -> ~chi02 + ~chi+-2
7737 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7738 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7739 IF(MOD(MINT(15),2).NE.0) JS=2
7740 MINT(20+JS)=KSUSY1+23
7741 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7742
7743 ELSEIF(ISUB.EQ.235) THEN
7744C...q + qbar' -> ~chi03 + ~chi+-2
7745 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7746 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7747 IF(MOD(MINT(15),2).NE.0) JS=2
7748 MINT(20+JS)=KSUSY1+25
7749 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7750
7751 ELSEIF(ISUB.EQ.236) THEN
7752C...q + qbar' -> ~chi04 + ~chi+-2
7753 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7754 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7755 IF(MOD(MINT(15),2).NE.0) JS=2
7756 MINT(20+JS)=KSUSY1+35
7757 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7758 ENDIF
7759
7760 ELSEIF(ISUB.LE.245) THEN
7761 IF(ISUB.EQ.237) THEN
7762C...q + qbar -> ~chi01 + ~g
7763C...th arbitrary
7764 IF(PYR(0).GT.0.5D0) JS=2
7765 MINT(20+JS)=KSUSY1+21
7766 MINT(23-JS)=KSUSY1+22
7767 KCC=17+JS
7768
7769 ELSEIF(ISUB.EQ.238) THEN
7770C...q + qbar -> ~chi02 + ~g
7771C...th arbitrary
7772 IF(PYR(0).GT.0.5D0) JS=2
7773 MINT(20+JS)=KSUSY1+21
7774 MINT(23-JS)=KSUSY1+23
7775 KCC=17+JS
7776
7777 ELSEIF(ISUB.EQ.239) THEN
7778C...q + qbar -> ~chi03 + ~g
7779C...th arbitrary
7780 IF(PYR(0).GT.0.5D0) JS=2
7781 MINT(20+JS)=KSUSY1+21
7782 MINT(23-JS)=KSUSY1+25
7783 KCC=17+JS
7784
7785 ELSEIF(ISUB.EQ.240) THEN
7786C...q + qbar -> ~chi04 + ~g
7787C...th arbitrary
7788 IF(PYR(0).GT.0.5D0) JS=2
7789 MINT(20+JS)=KSUSY1+21
7790 MINT(23-JS)=KSUSY1+35
7791 KCC=17+JS
7792
7793 ELSEIF(ISUB.EQ.241) THEN
7794C...q + qbar' -> ~chi+-1 + ~g
7795C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7796C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7797C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7798C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7799C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7800 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7801 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7802 JS=1
7803 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7804 MINT(20+JS)=KSUSY1+21
7805 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7806 KCC=17+JS
7807
7808 ELSEIF(ISUB.EQ.242) THEN
7809C...q + qbar' -> ~chi+-2 + ~g
7810C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7811C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7812C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7813C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7814C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7815 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7816 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7817 JS=1
7818 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7819 MINT(20+JS)=KSUSY1+21
7820 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7821 KCC=17+JS
7822
7823 ELSEIF(ISUB.EQ.243) THEN
7824C...q + qbar -> ~g + ~g ; th arbitrary
7825 MINT(21)=KSUSY1+21
7826 MINT(22)=KSUSY1+21
7827 KCC=MINT(2)+4
7828
7829 ELSEIF(ISUB.EQ.244) THEN
7830C...g + g -> ~g + ~g ; th arbitrary
7831 KCC=MINT(2)+12
7832 KCS=(-1)**INT(1.5D0+PYR(0))
7833 MINT(21)=KSUSY1+21
7834 MINT(22)=KSUSY1+21
7835 ENDIF
7836
7837 ELSEIF(ISUB.LE.260) THEN
7838 IF(ISUB.EQ.246) THEN
7839C...qj + g -> ~qj_L + ~chi01
7840 IF(MINT(15).EQ.21) JS=2
7841 I=MINT(14+JS)
7842 IA=IABS(I)
7843 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7844 MINT(23-JS)=KSUSY1+22
7845 KCC=15+JS
7846 KCS=ISIGN(1,MINT(14+JS))
7847
7848 ELSEIF(ISUB.EQ.247) THEN
7849C...qj + g -> ~qj_R + ~chi01
7850 IF(MINT(15).EQ.21) JS=2
7851 I=MINT(14+JS)
7852 IA=IABS(I)
7853 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7854 MINT(23-JS)=KSUSY1+22
7855 KCC=15+JS
7856 KCS=ISIGN(1,MINT(14+JS))
7857
7858 ELSEIF(ISUB.EQ.248) THEN
7859C...qj + g -> ~qj_L + ~chi02
7860 IF(MINT(15).EQ.21) JS=2
7861 I=MINT(14+JS)
7862 IA=IABS(I)
7863 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7864 MINT(23-JS)=KSUSY1+23
7865 KCC=15+JS
7866 KCS=ISIGN(1,MINT(14+JS))
7867
7868 ELSEIF(ISUB.EQ.249) THEN
7869C...qj + g -> ~qj_R + ~chi02
7870 IF(MINT(15).EQ.21) JS=2
7871 I=MINT(14+JS)
7872 IA=IABS(I)
7873 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7874 MINT(23-JS)=KSUSY1+23
7875 KCC=15+JS
7876 KCS=ISIGN(1,MINT(14+JS))
7877
7878 ELSEIF(ISUB.EQ.250) THEN
7879C...qj + g -> ~qj_L + ~chi03
7880 IF(MINT(15).EQ.21) JS=2
7881 I=MINT(14+JS)
7882 IA=IABS(I)
7883 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7884 MINT(23-JS)=KSUSY1+25
7885 KCC=15+JS
7886 KCS=ISIGN(1,MINT(14+JS))
7887
7888 ELSEIF(ISUB.EQ.251) THEN
7889C...qj + g -> ~qj_R + ~chi03
7890 IF(MINT(15).EQ.21) JS=2
7891 I=MINT(14+JS)
7892 IA=IABS(I)
7893 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7894 MINT(23-JS)=KSUSY1+25
7895 KCC=15+JS
7896 KCS=ISIGN(1,MINT(14+JS))
7897
7898 ELSEIF(ISUB.EQ.252) THEN
7899C...qj + g -> ~qj_L + ~chi04
7900 IF(MINT(15).EQ.21) JS=2
7901 I=MINT(14+JS)
7902 IA=IABS(I)
7903 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7904 MINT(23-JS)=KSUSY1+35
7905 KCC=15+JS
7906 KCS=ISIGN(1,MINT(14+JS))
7907
7908 ELSEIF(ISUB.EQ.253) THEN
7909C...qj + g -> ~qj_R + ~chi04
7910 IF(MINT(15).EQ.21) JS=2
7911 I=MINT(14+JS)
7912 IA=IABS(I)
7913 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7914 MINT(23-JS)=KSUSY1+35
7915 KCC=15+JS
7916 KCS=ISIGN(1,MINT(14+JS))
7917
7918 ELSEIF(ISUB.EQ.254) THEN
7919C...qj + g -> ~qk_L + ~chi+-1
7920 IF(MINT(15).EQ.21) JS=2
7921 I=MINT(14+JS)
7922 IA=IABS(I)
7923 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7924 IB=-IA+INT((IA+1)/2)*4-1
7925 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7926 KCC=15+JS
7927 KCS=ISIGN(1,MINT(14+JS))
7928
7929 ELSEIF(ISUB.EQ.255) THEN
7930C...qj + g -> ~qk_L + ~chi+-1
7931 IF(MINT(15).EQ.21) JS=2
7932 I=MINT(14+JS)
7933 IA=IABS(I)
7934 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7935 IB=-IA+INT((IA+1)/2)*4-1
7936 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7937 KCC=15+JS
7938 KCS=ISIGN(1,MINT(14+JS))
7939
7940 ELSEIF(ISUB.EQ.256) THEN
7941C...qj + g -> ~qk_L + ~chi+-2
7942 IF(MINT(15).EQ.21) JS=2
7943 I=MINT(14+JS)
7944 IA=IABS(I)
7945 IB=-IA+INT((IA+1)/2)*4-1
7946 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7947 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7948 KCC=15+JS
7949 KCS=ISIGN(1,MINT(14+JS))
7950
7951 ELSEIF(ISUB.EQ.257) THEN
7952C...qj + g -> ~qk_R + ~chi+-2
7953 IF(MINT(15).EQ.21) JS=2
7954 I=MINT(14+JS)
7955 IA=IABS(I)
7956 IB=-IA+INT((IA+1)/2)*4-1
7957 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7958 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7959 KCC=15+JS
7960 KCS=ISIGN(1,MINT(14+JS))
7961
7962 ELSEIF(ISUB.EQ.258) THEN
7963C...qj + g -> ~qj_L + ~g
7964 IF(MINT(15).EQ.21) JS=2
7965 I=MINT(14+JS)
7966 IA=IABS(I)
7967 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7968 MINT(23-JS)=KSUSY1+21
7969 KCC=MINT(2)+6
7970 IF(JS.EQ.2) KCC=KCC+2
7971 KCS=ISIGN(1,I)
7972
7973 ELSEIF(ISUB.EQ.259) THEN
7974C...qj + g -> ~qj_R + ~g
7975 IF(MINT(15).EQ.21) JS=2
7976 I=MINT(14+JS)
7977 IA=IABS(I)
7978 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7979 MINT(23-JS)=KSUSY1+21
7980 KCC=MINT(2)+6
7981 IF(JS.EQ.2) KCC=KCC+2
7982 KCS=ISIGN(1,I)
7983 ENDIF
7984
7985 ELSEIF(ISUB.LE.270) THEN
7986 IF(ISUB.EQ.261) THEN
7987C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
7988 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7989 MINT(22)=-MINT(21)
7990C...Correct color combination
7991 IF(MINT(43).EQ.4) KCC=4
7992
7993 ELSEIF(ISUB.EQ.262) THEN
7994C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
7995 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7996 MINT(22)=-MINT(21)
7997C...Correct color combination
7998 IF(MINT(43).EQ.4) KCC=4
7999
8000 ELSEIF(ISUB.EQ.263) THEN
8001C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
8002 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
8003 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
8004 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8005 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
8006 ELSE
8007 JS=2
8008 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
8009 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
8010 ENDIF
8011C...Correct color combination
8012 IF(MINT(43).EQ.4) KCC=4
8013
8014 ELSEIF(ISUB.EQ.264) THEN
8015C...g + g -> ~t_1 + ~t_1bar; th arbitrary
8016 KCS=(-1)**INT(1.5D0+PYR(0))
8017 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8018 MINT(22)=-MINT(21)
8019 KCC=MINT(2)+10
8020
8021 ELSEIF(ISUB.EQ.265) THEN
8022C...g + g -> ~t_2 + ~t_2bar; th arbitrary
8023 KCS=(-1)**INT(1.5D0+PYR(0))
8024 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8025 MINT(22)=-MINT(21)
8026 KCC=MINT(2)+10
8027 ENDIF
8028
8029 ELSEIF(ISUB.LE.280) THEN
8030 IF(ISUB.EQ.271) THEN
8031C...qi + qj -> ~qi_L + ~qj_L
8032 KCC=MINT(2)
8033 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8034 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8035 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8036
8037 ELSEIF(ISUB.EQ.272) THEN
8038C...qi + qj -> ~qi_R + ~qj_R
8039 KCC=MINT(2)
8040 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8041 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8042 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8043
8044 ELSEIF(ISUB.EQ.273) THEN
8045C...qi + qj -> ~qi_L + ~qj_R
8046 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8047 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8048 KCC=MINT(2)
8049 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8050
8051 ELSEIF(ISUB.EQ.274) THEN
8052C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
8053 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8054 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8055 KCC=MINT(2)
8056 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8057
8058 ELSEIF(ISUB.EQ.275) THEN
8059C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8060 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8061 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8062 KCC=MINT(2)
8063 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8064
8065 ELSEIF(ISUB.EQ.276) THEN
8066C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8067 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8068 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8069 KCC=MINT(2)
8070 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8071
8072 ELSEIF(ISUB.EQ.277) THEN
8073C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
8074 ISGN=1
8075 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8076 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8077 MINT(22)=-MINT(21)
8078 IF(MINT(43).EQ.4) KCC=4
8079
8080 ELSEIF(ISUB.EQ.278) THEN
8081C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
8082 ISGN=1
8083 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8084 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8085 MINT(22)=-MINT(21)
8086 IF(MINT(43).EQ.4) KCC=4
8087
8088 ELSEIF(ISUB.EQ.279) THEN
8089C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
8090C...pure LL + RR
8091 KCS=(-1)**INT(1.5D0+PYR(0))
8092 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8093 MINT(22)=-MINT(21)
8094 KCC=MINT(2)+10
8095
8096 ELSEIF(ISUB.EQ.280) THEN
8097C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
8098 KCS=(-1)**INT(1.5D0+PYR(0))
8099 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8100 MINT(22)=-MINT(21)
8101 KCC=MINT(2)+10
8102 ENDIF
8103
8104CMRENNA--
8105 ENDIF
8106
8107 IF(ISET(ISUB).EQ.11) THEN
8108C...Store documentation for user-defined processes
8109 BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
8110 KUPPO(1)=MINT(83)+5
8111 KUPPO(2)=MINT(83)+6
8112 I=MINT(83)+6
8113 DO 450 IUP=3,NUP
8114 KUPPO(IUP)=0
8115 IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
8116 IDOC=IDOC-1
8117 MINT(4)=MINT(4)-1
8118 GOTO 450
8119 ENDIF
8120 I=I+1
8121 KUPPO(IUP)=I
8122 K(I,1)=21
8123 K(I,2)=KUP(IUP,2)
8124 K(I,3)=0
8125 IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
8126 K(I,4)=0
8127 K(I,5)=0
8128 DO 440 J=1,5
8129 P(I,J)=PUP(IUP,J)
8130 440 CONTINUE
8131 450 CONTINUE
8132 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
8133 & -BEZUP)
8134
8135C...Store final state partons for user-defined processes
8136 N=IPU2
8137 DO 470 IUP=3,NUP
8138 N=N+1
8139 K(N,1)=1
8140 IF(KUP(IUP,1).NE.1) K(N,1)=11
8141 K(N,2)=KUP(IUP,2)
8142 IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
8143 K(N,3)=KUPPO(IUP)
8144 ELSE
8145 K(N,3)=MINT(84)+KUP(IUP,3)
8146 ENDIF
8147 K(N,4)=0
8148 K(N,5)=0
8149 DO 460 J=1,5
8150 P(N,J)=PUP(IUP,J)
8151 460 CONTINUE
8152 470 CONTINUE
8153 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
8154
8155C...Arrange colour flow for user-defined processes
8156 N=MINT(84)
8157 DO 480 IUP=1,NUP
8158 N=N+1
8159 IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
8160 IF(K(N,1).EQ.1) K(N,1)=3
8161 IF(K(N,1).EQ.11) K(N,1)=14
8162 IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
8163 & MINT(84))
8164 IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
8165 & MINT(84))
8166 IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
8167 IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
8168 480 CONTINUE
8169
8170 ELSEIF(IDOC.EQ.7) THEN
8171C...Resonance not decaying; store kinematics
8172 I=MINT(83)+7
8173 K(IPU3,1)=1
8174 K(IPU3,2)=KFRES
8175 K(IPU3,3)=I
8176 P(IPU3,4)=SHUSER
8177 P(IPU3,5)=SHUSER
8178 K(I,1)=21
8179 K(I,2)=KFRES
8180 P(I,4)=SHUSER
8181 P(I,5)=SHUSER
8182 N=IPU3
8183 MINT(21)=KFRES
8184 MINT(22)=0
8185
8186C...Special cases: colour flow in coloured resonances
8187 KCRES=PYCOMP(KFRES)
8188 IF(KCHG(KCRES,2).NE.0) THEN
8189 K(IPU3,1)=3
8190 DO 490 J=1,2
8191 JC=J
8192 IF(KCS.EQ.-1) JC=3-J
8193 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8194 & MINT(84)+ICOL(KCC,1,JC)
8195 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8196 & MINT(84)+ICOL(KCC,2,JC)
8197 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8198 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8199 490 CONTINUE
8200 ELSE
8201 K(IPU1,4)=IPU2
8202 K(IPU1,5)=IPU2
8203 K(IPU2,4)=IPU1
8204 K(IPU2,5)=IPU1
8205 ENDIF
8206
8207 ELSEIF(IDOC.EQ.8) THEN
8208C...2 -> 2 processes: store outgoing partons in their CM-frame
8209 DO 500 JT=1,2
8210 I=MINT(84)+2+JT
8211 KCA=PYCOMP(MINT(20+JT))
8212 K(I,1)=1
8213 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8214 K(I,2)=MINT(20+JT)
8215 K(I,3)=MINT(83)+IDOC+JT-2
8216 KFAA=IABS(K(I,2))
8217 IF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,1).NE.0) THEN
8218 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8219 ELSEIF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,2).NE.0) THEN
8220 P(I,5)=SQRT(VINT(64))
8221 ELSE
8222 P(I,5)=PYMASS(K(I,2))
8223 ENDIF
8224 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
8225 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
8226 500 CONTINUE
8227 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
8228 KFA1=IABS(MINT(21))
8229 KFA2=IABS(MINT(22))
8230 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
8231 & THEN
8232 MINT(51)=1
8233 RETURN
8234 ENDIF
8235 P(IPU3,5)=0D0
8236 P(IPU4,5)=0D0
8237 ENDIF
8238 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
8239 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
8240 P(IPU4,4)=SHR-P(IPU3,4)
8241 P(IPU4,3)=-P(IPU3,3)
8242 N=IPU4
8243 MINT(7)=MINT(83)+7
8244 MINT(8)=MINT(83)+8
8245
8246C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
8247 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
8248
8249 ELSEIF(IDOC.EQ.9) THEN
8250C...2 -> 3 processes: store outgoing partons in their CM frame
8251 DO 510 JT=1,2
8252 I=MINT(84)+2+JT
8253 KCA=PYCOMP(MINT(20+JT))
8254 K(I,1)=1
8255 IF(KCHG(KCA,2).NE.0) K(I,1)=3
8256 K(I,2)=MINT(20+JT)
8257 K(I,3)=MINT(83)+IDOC+JT-3
8258 IF(IABS(K(I,2)).LE.22) THEN
8259 P(I,5)=PYMASS(K(I,2))
8260 ELSE
8261 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8262 ENDIF
8263 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
8264 P(I,1)=PT*COS(VINT(198+5*JT))
8265 P(I,2)=PT*SIN(VINT(198+5*JT))
8266 510 CONTINUE
8267 K(IPU5,1)=1
8268 K(IPU5,2)=KFRES
8269 K(IPU5,3)=MINT(83)+IDOC
8270 P(IPU5,5)=SHR
8271 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8272 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8273 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
8274 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
8275 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
8276 PMT3=SQRT(PMS3)
8277 P(IPU5,3)=PMT3*SINH(VINT(211))
8278 P(IPU5,4)=PMT3*COSH(VINT(211))
8279 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
8280 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
8281 IF(SQL12.LE.0D0) THEN
8282 MINT(51)=1
8283 RETURN
8284 ENDIF
8285 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
8286 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
8287 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
8288 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
8289 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
8290 MINT(23)=KFRES
8291 N=IPU5
8292 MINT(7)=MINT(83)+7
8293 MINT(8)=MINT(83)+8
8294
8295 ELSEIF(IDOC.EQ.11) THEN
8296C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
8297 PHI(1)=PARU(2)*PYR(0)
8298 PHI(2)=PHI(1)-PHIR
8299 DO 520 JT=1,2
8300 I=MINT(84)+2+JT
8301 K(I,1)=1
8302 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8303 K(I,2)=MINT(20+JT)
8304 K(I,3)=MINT(83)+IDOC+JT-2
8305 P(I,5)=PYMASS(K(I,2))
8306 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
8307 MINT(51)=1
8308 RETURN
8309 ENDIF
8310 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8311 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8312 P(I,1)=PTABS*COS(PHI(JT))
8313 P(I,2)=PTABS*SIN(PHI(JT))
8314 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8315 P(I,4)=0.5D0*SHPR*Z(JT)
8316 IZW=MINT(83)+6+JT
8317 K(IZW,1)=21
8318 K(IZW,2)=23
8319 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
8320 K(IZW,3)=IZW-2
8321 P(IZW,1)=-P(I,1)
8322 P(IZW,2)=-P(I,2)
8323 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8324 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8325 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8326 520 CONTINUE
8327 I=MINT(83)+9
8328 K(IPU5,1)=1
8329 K(IPU5,2)=KFRES
8330 K(IPU5,3)=I
8331 P(IPU5,5)=SHR
8332 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8333 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8334 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
8335 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
8336 K(I,1)=21
8337 K(I,2)=KFRES
8338 DO 530 J=1,5
8339 P(I,J)=P(IPU5,J)
8340 530 CONTINUE
8341 N=IPU5
8342 MINT(23)=KFRES
8343
8344 ELSEIF(IDOC.EQ.12) THEN
8345C...Z0 and W+/- scattering: store bosons and outgoing partons
8346 PHI(1)=PARU(2)*PYR(0)
8347 PHI(2)=PHI(1)-PHIR
8348 JTRAN=INT(1.5D0+PYR(0))
8349 DO 540 JT=1,2
8350 I=MINT(84)+2+JT
8351 K(I,1)=1
8352 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8353 K(I,2)=MINT(20+JT)
8354 K(I,3)=MINT(83)+IDOC+JT-2
8355 P(I,5)=PYMASS(K(I,2))
8356 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
8357 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8358 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8359 P(I,1)=PTABS*COS(PHI(JT))
8360 P(I,2)=PTABS*SIN(PHI(JT))
8361 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8362 P(I,4)=0.5D0*SHPR*Z(JT)
8363 IZW=MINT(83)+6+JT
8364 K(IZW,1)=21
8365 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
8366 K(IZW,2)=23
8367 ELSE
8368 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
8369 ENDIF
8370 K(IZW,3)=IZW-2
8371 P(IZW,1)=-P(I,1)
8372 P(IZW,2)=-P(I,2)
8373 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8374 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8375 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8376 IPU=MINT(84)+4+JT
8377 K(IPU,1)=3
8378 K(IPU,2)=KFPR(ISUB,JT)
8379 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
8380 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
8381 K(IPU,3)=MINT(83)+8+JT
8382 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
8383 P(IPU,5)=PYMASS(K(IPU,2))
8384 ELSE
8385 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8386 ENDIF
8387 MINT(22+JT)=K(IPU,2)
8388 540 CONTINUE
8389C...Find rotation and boost for hard scattering subsystem
8390 I1=MINT(83)+7
8391 I2=MINT(83)+8
8392 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
8393 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
8394 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
8395 GAMCM=(P(I1,4)+P(I2,4))/SHR
8396 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
8397 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
8398 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
8399 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
8400 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
8401 PHICM=PYANGL(PX,PY)
8402C...Store hard scattering subsystem. Rotate and boost it
8403 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
8404 & P(IPU6,5)**2
8405 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
8406 CTHWZ=VINT(23)
8407 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
8408 PHIWZ=VINT(24)-PHICM
8409 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
8410 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
8411 P(IPU5,3)=PABS*CTHWZ
8412 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
8413 P(IPU6,1)=-P(IPU5,1)
8414 P(IPU6,2)=-P(IPU5,2)
8415 P(IPU6,3)=-P(IPU5,3)
8416 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
8417 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
8418 DO 560 JT=1,2
8419 I1=MINT(83)+8+JT
8420 I2=MINT(84)+4+JT
8421 K(I1,1)=21
8422 K(I1,2)=K(I2,2)
8423 DO 550 J=1,5
8424 P(I1,J)=P(I2,J)
8425 550 CONTINUE
8426 560 CONTINUE
8427 N=IPU6
8428 MINT(7)=MINT(83)+9
8429 MINT(8)=MINT(83)+10
8430 ENDIF
8431
8432 IF(ISET(ISUB).EQ.11) THEN
8433 ELSEIF(IDOC.GE.8) THEN
8434C...Store colour connection indices
8435 DO 570 J=1,2
8436 JC=J
8437 IF(KCS.EQ.-1) JC=3-J
8438 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8439 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
8440 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8441 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
8442 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8443 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8444 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8445 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8446 570 CONTINUE
8447
8448C...Copy outgoing partons to documentation lines
8449 IMAX=2
8450 IF(IDOC.EQ.9) IMAX=3
8451 DO 590 I=1,IMAX
8452 I1=MINT(83)+IDOC-IMAX+I
8453 I2=MINT(84)+2+I
8454 K(I1,1)=21
8455 K(I1,2)=K(I2,2)
8456 IF(IDOC.LE.9) K(I1,3)=0
8457 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
8458 DO 580 J=1,5
8459 P(I1,J)=P(I2,J)
8460 580 CONTINUE
8461 590 CONTINUE
8462
8463 ELSEIF(IDOC.EQ.9) THEN
8464C...Store colour connection indices
8465 DO 600 J=1,2
8466 JC=J
8467 IF(KCS.EQ.-1) JC=3-J
8468 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8469 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
8470 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
8471 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8472 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
8473 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
8474 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8475 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8476 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
8477 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8478 600 CONTINUE
8479
8480C...Copy outgoing partons to documentation lines
8481 DO 620 I=1,3
8482 I1=MINT(83)+IDOC-3+I
8483 I2=MINT(84)+2+I
8484 K(I1,1)=21
8485 K(I1,2)=K(I2,2)
8486 K(I1,3)=0
8487 DO 610 J=1,5
8488 P(I1,J)=P(I2,J)
8489 610 CONTINUE
8490 620 CONTINUE
8491 ENDIF
8492
8493C...Low-pT events: remove gluons used for string drawing purposes
8494 IF(ISUB.EQ.95) THEN
8495 K(IPU3,1)=K(IPU3,1)+10
8496 K(IPU4,1)=K(IPU4,1)+10
8497 DO 630 J=41,66
8498 VINTSV(J)=VINT(J)
8499 VINT(J)=0D0
8500 630 CONTINUE
8501 DO 650 I=MINT(83)+5,MINT(83)+8
8502 DO 640 J=1,5
8503 P(I,J)=0D0
8504 640 CONTINUE
8505 650 CONTINUE
8506 ENDIF
8507
8508 RETURN
8509 END
8510
8511C*********************************************************************
8512
8513*$ CREATE PYSSPA.FOR
8514*COPY PYSSPA
8515C...PYSSPA
8516C...Generates spacelike parton showers.
8517
8518 SUBROUTINE PYSSPA(IPU1,IPU2)
8519
8520C...Double precision and integer declarations.
8521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8522 INTEGER PYK,PYCHGE,PYCOMP
8523C...Commonblocks.
8524 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8526 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8527 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8528 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8529 COMMON/PYINT1/MINT(400),VINT(400)
8530 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8531 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8532 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8533 &/PYINT2/,/PYINT3/
8534C...Local arrays and data.
8535 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
8536 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
8537 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
8538 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
8539 &THEFIS(2,2),ISFI(2)
8540 DATA IS/2*0/
8541
8542C...Read out basic information; set global Q^2 scale.
8543 IPUS1=IPU1
8544 IPUS2=IPU2
8545 ISUB=MINT(1)
8546 Q2MX=VINT(56)
8547 IF(ISET(ISUB).EQ.2) Q2MX=PARP(67)*VINT(56)
8548
8549C...Initialize QCD evolution and check phase space.
8550 Q2MNC=PARP(62)**2
8551 Q2MNCS(1)=Q2MNC
8552 IF(MSTP(66).EQ.1.AND.MINT(107).EQ.3)
8553 &Q2MNCS(1)=MAX(Q2MNC,VINT(283))
8554 Q2MNCS(2)=Q2MNC
8555 IF(MSTP(66).EQ.1.AND.MINT(108).EQ.3)
8556 &Q2MNCS(2)=MAX(Q2MNC,VINT(284))
8557 MCEV=0
8558 XEC0=2D0*PARP(65)/VINT(1)
8559 ALAMS=PARU(112)
8560 PARU(112)=PARP(61)
8561 FQ2C=1D0
8562 TCMX=0D0
8563 IF(MINT(47).GE.2.AND.(MINT(47).NE.5.OR.MSTP(12).GE.1)) THEN
8564 MCEV=1
8565 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
8566 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
8567 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
8568 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
8569 & MCEV=0
8570 ENDIF
8571
8572C...Initialize QED evolution and check phase space.
8573 Q2MNE=PARP(68)**2
8574 MEEV=0
8575 XEE=1D-6
8576 SPME=PMAS(11,1)**2
8577 TEMX=0D0
8578 FWTE=10D0
8579 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
8580 MEEV=1
8581 TEMX=LOG(Q2MX/SPME)
8582 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
8583 ENDIF
8584 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
8585
8586C...Initial values: flavours, momenta, virtualities.
8587 NS=N
8588 100 N=NS
8589 DO 120 JT=1,2
8590 MORE(JT)=1
8591 KFBEAM(JT)=MINT(10+JT)
8592 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
8593 KFLS(JT)=MINT(14+JT)
8594 KFLS(JT+2)=KFLS(JT)
8595 XS(JT)=VINT(40+JT)
8596 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
8597 ZS(JT)=1D0
8598 Q2S(JT)=Q2MX
8599 TEVCSV(JT)=TCMX
8600 ALAM(JT)=PARP(61)
8601 THE2(JT)=100D0
8602 TEVESV(JT)=TEMX
8603 DO 110 KFL=-25,25
8604 XFS(JT,KFL)=XSFX(JT,KFL)
8605 110 CONTINUE
8606 120 CONTINUE
8607 DSH=VINT(44)
8608 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
8609
8610C...Find if interference with final state partons.
8611 MFIS=0
8612 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
8613 IF(MFIS.NE.0) THEN
8614 DO 140 I=1,2
8615 KCFI(I)=0
8616 KCA=PYCOMP(IABS(KFLS(I)))
8617 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
8618 NFIS(I)=0
8619 IF(KCFI(I).NE.0) THEN
8620 IF(I.EQ.1) IPFS=IPUS1
8621 IF(I.EQ.2) IPFS=IPUS2
8622 DO 130 J=1,2
8623 ICSI=MOD(K(IPFS,3+J),MSTU(5))
8624 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
8625 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
8626 NFIS(I)=NFIS(I)+1
8627 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
8628 & P(ICSI,2)**2))
8629 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
8630 ENDIF
8631 130 CONTINUE
8632 ENDIF
8633 140 CONTINUE
8634 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
8635 ENDIF
8636
8637C...Pick up leg with highest virtuality.
8638 150 N=N+1
8639 JT=1
8640 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
8641 IF(MORE(JT).EQ.0) JT=3-JT
8642 KFLB=KFLS(JT)
8643 XB=XS(JT)
8644 DO 160 KFL=-25,25
8645 XFB(KFL)=XFS(JT,KFL)
8646 160 CONTINUE
8647 DSHR=2D0*SQRT(DSH)
8648 DSHZ=DSH/ZS(JT)
8649
8650C...Check if allowed to branch.
8651 MCEV=0
8652 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
8653 MCEV=1
8654 XEC=MAX(XEC0,XB*(1D0/(1D0-PARP(66))-1D0))
8655 IF(XB.GE.1D0-2D0*XEC) MCEV=0
8656 ENDIF
8657 MEEV=0
8658 IF(MINT(44+JT).EQ.3) THEN
8659 MEEV=1
8660 IF(XB.GE.1D0-2D0*XEE) MEEV=0
8661 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
8662 & MEEV=0
8663C***Currently kill QED shower for resolved photoproduction.
8664 IF(MINT(18+JT).EQ.1) MEEV=0
8665C***Currently kill shower for W inside electron.
8666 IF(IABS(KFLB).EQ.24) THEN
8667 MCEV=0
8668 MEEV=0
8669 ENDIF
8670 ENDIF
8671 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8672 Q2B=0D0
8673 GOTO 250
8674 ENDIF
8675
8676C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
8677 Q2B=Q2S(JT)
8678 TEVCB=TEVCSV(JT)
8679 TEVEB=TEVESV(JT)
8680 IF(MSTP(62).LE.1) THEN
8681 IF(ZS(JT).GT.0.99999D0) THEN
8682 Q2B=Q2S(JT)
8683 ELSE
8684 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
8685 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
8686 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
8687 ENDIF
8688 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8689 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8690 ENDIF
8691 IF(MCEV.EQ.1) THEN
8692 ALSDUM=PYALPS(FQ2C*Q2B)
8693 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
8694 ALAM(JT)=PARU(117)
8695 B0=(33D0-2D0*MSTU(118))/6D0
8696 ENDIF
8697 TEVCBS=TEVCB
8698 TEVEBS=TEVEB
8699
8700C...Select side for interference with final state partons.
8701 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
8702 IFI=N-NS
8703 ISFI(IFI)=0
8704 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
8705 ISFI(IFI)=1
8706 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
8707 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
8708 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
8709 ISFI(IFI)=1
8710 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
8711 ENDIF
8712 ENDIF
8713
8714C...Calculate Altarelli-Parisi weights.
8715 DO 170 KFL=-25,25
8716 WTAPC(KFL)=0D0
8717 WTAPE(KFL)=0D0
8718 WTSF(KFL)=0D0
8719 170 CONTINUE
8720C...q -> q, g -> q.
8721 IF(IABS(KFLB).LE.10) THEN
8722 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
8723 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
8724C...f -> f, gamma -> f.
8725 ELSEIF(IABS(KFLB).LE.20) THEN
8726 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
8727 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
8728 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
8729 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
8730C...f -> g, g -> g.
8731 ELSEIF(KFLB.EQ.21) THEN
8732 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
8733 DO 180 KFL=1,MSTP(58)
8734 WTAPC(KFL)=WTAPQ
8735 WTAPC(-KFL)=WTAPQ
8736 180 CONTINUE
8737 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
8738C...f -> gamma, W+, W-.
8739 ELSEIF(KFLB.EQ.22) THEN
8740 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
8741 WTAPE(11)=WTAPF
8742 WTAPE(-11)=WTAPF
8743 ELSEIF(KFLB.EQ.24) THEN
8744 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8745 & (XEE*(XB+XEE)))/XB
8746 ELSEIF(KFLB.EQ.-24) THEN
8747 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8748 & (XEE*(XB+XEE)))/XB
8749 ENDIF
8750
8751C...Calculate parton distribution weights and sum.
8752 NTRY=0
8753 190 NTRY=NTRY+1
8754 IF(NTRY.GT.500) THEN
8755 MINT(51)=1
8756 RETURN
8757 ENDIF
8758 WTSUMC=0D0
8759 WTSUME=0D0
8760 XFBO=MAX(1D-10,XFB(KFLB))
8761 DO 200 KFL=-25,25
8762 WTSF(KFL)=XFB(KFL)/XFBO
8763 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
8764 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
8765 200 CONTINUE
8766 WTSUMC=MAX(0.0001D0,WTSUMC)
8767 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
8768
8769C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
8770 NTRY2=0
8771 210 NTRY2=NTRY2+1
8772 IF(NTRY2.GT.500) THEN
8773 MINT(51)=1
8774 RETURN
8775 ENDIF
8776 IF(MCEV.EQ.1) THEN
8777 IF(MSTP(64).LE.0) THEN
8778 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
8779 ELSEIF(MSTP(64).EQ.1) THEN
8780 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
8781 ELSE
8782 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
8783 ENDIF
8784 ENDIF
8785 IF(MEEV.EQ.1) THEN
8786 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
8787 & (PARU(101)*FWTE*WTSUME*TEMX)))
8788 ENDIF
8789
8790C...Translate t into Q2 scale; choose between QCD and QED evolution.
8791 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
8792 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
8793 MCE=0
8794 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8795 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
8796 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
8797 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
8798 IF(Q2EB.GT.Q2MNE) MCE=2
8799 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
8800 MCE=1
8801 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
8802 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
8803 ELSE
8804 MCE=2
8805 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
8806 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
8807 ENDIF
8808
8809C...Evolution possibly ended. Update t values.
8810 IF(MCE.EQ.0) THEN
8811 Q2B=0D0
8812 GOTO 250
8813 ELSEIF(MCE.EQ.1) THEN
8814 Q2B=Q2CB
8815 Q2REF=FQ2C*Q2B
8816 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8817 ELSE
8818 Q2B=Q2EB
8819 Q2REF=Q2B
8820 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8821 ENDIF
8822
8823C...Select flavour for branching parton.
8824 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
8825 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
8826 KFLA=-25
8827 230 KFLA=KFLA+1
8828 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
8829 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
8830 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
8831 IF(KFLA.EQ.25) THEN
8832 Q2B=0D0
8833 GOTO 250
8834 ENDIF
8835
8836C...Choose z value and corrective weight.
8837 WTZ=0D0
8838C...q -> q + g.
8839 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
8840 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
8841 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
8842 WTZ=0.5D0*(1D0+Z**2)
8843C...q -> g + q.
8844 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
8845 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
8846 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
8847C...f -> f + gamma.
8848 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
8849 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
8850 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
8851 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
8852 ELSE
8853 Z=XB+XB*(XEE/(1D0-XEE))*
8854 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8855 ENDIF
8856 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
8857C...f -> gamma + f.
8858 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
8859 Z=XB+XB*(XEE/(1D0-XEE))*
8860 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8861 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
8862C...f -> W+- + f'.
8863 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
8864 Z=XB+XB*(XEE/(1D0-XEE))*
8865 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8866 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
8867 & (Q2B/(Q2B+PMAS(24,1)**2))
8868C...g -> q + qbar.
8869 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
8870 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
8871 WTZ=1D0-2D0*Z*(1D0-Z)
8872C...g -> g + g.
8873 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
8874 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
8875 WTZ=(1D0-Z*(1D0-Z))**2
8876C...gamma -> f + fbar.
8877 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
8878 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
8879 WTZ=1D0-2D0*Z*(1D0-Z)
8880 ENDIF
8881 IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
8882
8883C...Option with resummation of soft gluon emission as effective z shift.
8884 IF(MCE.EQ.1) THEN
8885 IF(MSTP(65).GE.1) THEN
8886 RSOFT=6D0
8887 IF(KFLB.NE.21) RSOFT=8D0/3D0
8888 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
8889 IF(Z.LE.XB) GOTO 210
8890 ENDIF
8891
8892C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
8893 IF(MSTP(64).GE.2) THEN
8894 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
8895 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
8896 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
8897 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
8898 ENDIF
8899
8900C...Impose angular constraint in first branching from interference
8901C...with final state partons.
8902 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
8903 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
8904 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
8905 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
8906 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
8907 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
8908 ENDIF
8909 ENDIF
8910
8911C...Option with angular ordering requirement.
8912 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
8913 THE2T=(4D0*Z**2*Q2B)/(VINT(2)*(1D0-Z)*XB**2)
8914 IF(THE2T.GT.THE2(JT)) GOTO 210
8915 ENDIF
8916 ENDIF
8917
8918C...Weighting with new parton distributions.
8919 MINT(105)=MINT(102+JT)
8920 MINT(109)=MINT(106+JT)
8921 IF(MSTP(57).LE.1) THEN
8922 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
8923 ELSE
8924 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
8925 ENDIF
8926 XFBN=XFN(KFLB)
8927 IF(XFBN.LT.1D-20) THEN
8928 IF(KFLA.EQ.KFLB) THEN
8929 TEVCB=TEVCBS
8930 TEVEB=TEVEBS
8931 WTAPC(KFLB)=0D0
8932 WTAPE(KFLB)=0D0
8933 GOTO 190
8934 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
8935 TEVCB=0.5D0*(TEVCBS+TEVCB)
8936 GOTO 220
8937 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
8938 TEVEB=0.5D0*(TEVEBS+TEVEB)
8939 GOTO 220
8940 ELSE
8941 XFBN=1D-10
8942 XFN(KFLB)=XFBN
8943 ENDIF
8944 ENDIF
8945 DO 240 KFL=-25,25
8946 XFB(KFL)=XFN(KFL)
8947 240 CONTINUE
8948 XA=XB/Z
8949 IF(MSTP(57).LE.1) THEN
8950 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
8951 ELSE
8952 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
8953 ENDIF
8954 XFAN=XFA(KFLA)
8955 IF(XFAN.LT.1D-20) GOTO 190
8956 WTSFA=WTSF(KFLA)
8957 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
8958
8959C...Define two hard scatterers in their CM-frame.
8960 250 IF(N.EQ.NS+2) THEN
8961 DQ2(JT)=Q2B
8962 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
8963 DO 270 JR=1,2
8964 I=NS+JR
8965 IF(JR.EQ.1) IPO=IPUS1
8966 IF(JR.EQ.2) IPO=IPUS2
8967 DO 260 J=1,5
8968 K(I,J)=0
8969 P(I,J)=0D0
8970 V(I,J)=0D0
8971 260 CONTINUE
8972 K(I,1)=14
8973 K(I,2)=KFLS(JR+2)
8974 K(I,4)=IPO
8975 K(I,5)=IPO
8976 P(I,3)=DPLCM*(-1)**(JR+1)
8977 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
8978 P(I,5)=-SQRT(DQ2(JR))
8979 K(IPO,1)=14
8980 K(IPO,3)=I
8981 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
8982 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
8983 270 CONTINUE
8984
8985C...Find maximum allowed mass of timelike parton.
8986 ELSEIF(N.GT.NS+2) THEN
8987 JR=3-JT
8988 DQ2(3)=Q2B
8989 DPC(1)=P(IS(1),4)
8990 DPC(2)=P(IS(2),4)
8991 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
8992 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
8993 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
8994 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
8995 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
8996 IKIN=0
8997 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
8998 & 1D-10*DPD(1)) IKIN=1
8999 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
9000 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
9001 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
9002 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
9003
9004C...Generate timelike parton shower (if required).
9005 IT=N
9006 DO 280 J=1,5
9007 K(IT,J)=0
9008 P(IT,J)=0D0
9009 V(IT,J)=0D0
9010 280 CONTINUE
9011 K(IT,1)=3
9012C...f -> f + g (gamma).
9013 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
9014 K(IT,2)=21
9015 IF(IABS(KFLB).GE.11) K(IT,2)=22
9016C...f -> g (gamma, W+-) + f.
9017 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
9018 K(IT,2)=KFLB
9019 IF(KFLS(JT+2).EQ.24) THEN
9020 K(IT,2)=-12
9021 ELSEIF(KFLS(JT+2).EQ.-24) THEN
9022 K(IT,2)=12
9023 ENDIF
9024C...g (gamma) -> f + fbar, g + g.
9025 ELSE
9026 K(IT,2)=-KFLS(JT+2)
9027 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
9028 ENDIF
9029 P(IT,5)=PYMASS(K(IT,2))
9030 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
9031 IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
9032 MSTJ48=MSTJ(48)
9033 PARJ85=PARJ(85)
9034 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
9035 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
9036 IF(MSTP(63).EQ.1) THEN
9037 Q2TIM=DMSMA
9038 ELSEIF(MSTP(63).EQ.2) THEN
9039 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
9040 ELSE
9041 Q2TIM=DMSMA
9042 MSTJ(48)=1
9043 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9044 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
9045 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
9046 PARJ(85)=SQRT(MAX(0D0,DPT2))*
9047 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
9048 ENDIF
9049 CALL PYSHOW(IT,0,SQRT(Q2TIM))
9050 MSTJ(48)=MSTJ48
9051 PARJ(85)=PARJ85
9052 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
9053 ENDIF
9054
9055C...Reconstruct kinematics of branching: timelike parton shower.
9056 DMS=P(IT,5)**2
9057 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9058 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
9059 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
9060 & (4D0*DSH*DPC(3)**2)
9061 IF(DPT2.LT.0D0) GOTO 100
9062 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
9063 & DSHR)/DPC(3)-DPC(3)
9064 P(IT,1)=SQRT(DPT2)
9065 P(IT,3)=DPB(1)*(-1)**(JT+1)
9066 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
9067 IF(N.GE.IT+1) THEN
9068 DPB(1)=SQRT(DPB(1)**2+DPT2)
9069 DPB(2)=SQRT(DPB(1)**2+DMS)
9070 DPB(3)=P(IT+1,3)
9071 DPB(4)=SQRT(DPB(3)**2+DMS)
9072 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
9073 & DPB(1))
9074 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
9075 THE=PYANGL(P(IT,3),P(IT,1))
9076 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
9077 ENDIF
9078
9079C...Reconstruct kinematics of branching: spacelike parton.
9080 DO 290 J=1,5
9081 K(N+1,J)=0
9082 P(N+1,J)=0D0
9083 V(N+1,J)=0D0
9084 290 CONTINUE
9085 K(N+1,1)=14
9086 K(N+1,2)=KFLB
9087 P(N+1,1)=P(IT,1)
9088 P(N+1,3)=P(IT,3)+P(IS(JT),3)
9089 P(N+1,4)=P(IT,4)+P(IS(JT),4)
9090 P(N+1,5)=-SQRT(DQ2(3))
9091
9092C...Define colour flow of branching.
9093 K(IS(JT),3)=N+1
9094 K(IT,3)=N+1
9095 IM1=N+1
9096 IM2=N+1
9097C...f -> f + gamma (Z, W).
9098 IF(IABS(K(IT,2)).GE.22) THEN
9099 K(IT,1)=1
9100 ID1=IS(JT)
9101 ID2=IS(JT)
9102C...f -> gamma (Z, W) + f.
9103 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
9104 ID1=IT
9105 ID2=IT
9106C...gamma -> q + qbar, g + g.
9107 ELSEIF(K(N+1,2).EQ.22) THEN
9108 ID1=IS(JT)
9109 ID2=IT
9110 IM1=ID2
9111 IM2=ID1
9112C...q -> q + g.
9113 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
9114 ID1=IT
9115 ID2=IS(JT)
9116C...q -> g + q.
9117 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
9118 ID1=IS(JT)
9119 ID2=IT
9120C...qbar -> qbar + g.
9121 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
9122 ID1=IS(JT)
9123 ID2=IT
9124C...qbar -> g + qbar.
9125 ELSEIF(K(N+1,2).LT.0) THEN
9126 ID1=IT
9127 ID2=IS(JT)
9128C...g -> g + g; g -> q + qbar.
9129 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
9130 ID1=IS(JT)
9131 ID2=IT
9132 ELSE
9133 ID1=IT
9134 ID2=IS(JT)
9135 ENDIF
9136 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
9137 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
9138 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
9139 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
9140 IF(ID1.NE.ID2) THEN
9141 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
9142 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
9143 ENDIF
9144 N=N+1
9145
9146C...Boost to new CM-frame.
9147 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
9148 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
9149 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
9150 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
9151 IR=N+(JT-1)*(IS(1)-N)
9152 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
9153 & 0D0,0D0,0D0)
9154 ENDIF
9155
9156C...Update kinematics variables.
9157 IS(JT)=N
9158 DQ2(JT)=Q2B
9159 IF(MSTP(62).GE.3) THE2(JT)=THE2T
9160 DSH=DSHZ
9161
9162C...Save quantities; loop back.
9163 Q2S(JT)=Q2B
9164 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
9165 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
9166 KFLS(JT+2)=KFLS(JT)
9167 KFLS(JT)=KFLA
9168 XS(JT)=XA
9169 ZS(JT)=Z
9170 DO 300 KFL=-25,25
9171 XFS(JT,KFL)=XFA(KFL)
9172 300 CONTINUE
9173 TEVCSV(JT)=TEVCB
9174 TEVESV(JT)=TEVEB
9175 ELSE
9176 MORE(JT)=0
9177 IF(JT.EQ.1) IPU1=N
9178 IF(JT.EQ.2) IPU2=N
9179 ENDIF
9180 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
9181 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
9182 IF(MSTU(21).GE.1) N=NS
9183 IF(MSTU(21).GE.1) RETURN
9184 ENDIF
9185 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
9186
9187C...Boost hard scattering partons to frame of shower initiators.
9188 DO 310 J=1,3
9189 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
9190 310 CONTINUE
9191 K(N+2,1)=1
9192 DO 320 J=1,5
9193 P(N+2,J)=P(NS+1,J)
9194 320 CONTINUE
9195 ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
9196 IF(ROBOT.GE.0.999999D0) THEN
9197 ROBOT=1.00001D0*SQRT(ROBOT)
9198 ROBO(3)=ROBO(3)/ROBOT
9199 ROBO(4)=ROBO(4)/ROBOT
9200 ROBO(5)=ROBO(5)/ROBOT
9201 ENDIF
9202 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
9203 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
9204 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
9205 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
9206 &ROBO(5))
9207
9208C...Store user information. Reset Lambda value.
9209 K(IPU1,3)=MINT(83)+3
9210 K(IPU2,3)=MINT(83)+4
9211 DO 330 JT=1,2
9212 MINT(12+JT)=KFLS(JT)
9213 VINT(140+JT)=XS(JT)
9214 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
9215 330 CONTINUE
9216 PARU(112)=ALAMS
9217
9218 RETURN
9219 END
9220
9221C*********************************************************************
9222
9223*$ CREATE PYRESD.FOR
9224*COPY PYRESD
9225C...PYRESD
9226C...Allows resonances to decay (including parton showers for hadronic
9227C...channels).
9228
9229 SUBROUTINE PYRESD(IRES)
9230
9231C...Double precision and integer declarations.
9232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9233 INTEGER PYK,PYCHGE,PYCOMP
9234C...Parameter statement to help give large particle numbers.
9235 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
9236C...Commonblocks.
9237 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
9238 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9239 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9240 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
9241 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9242 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9243 COMMON/PYINT1/MINT(400),VINT(400)
9244 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9245 COMMON/PYINT4/MWID(500),WIDS(500,5)
9246 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
9247 &/PYINT1/,/PYINT2/,/PYINT4/
9248C...Local arrays and complex and character variables.
9249 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
9250 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
9251 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
9252 &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5)
9253 COMPLEX FGK,HA(6,6),HC(6,6)
9254 REAL TIR,UIR
9255 CHARACTER CODE*9,MASS*9
9256
9257C...The F, Xi and Xj functions of Gunion and Kunszt
9258C...(Phys. Rev. D33, 665, plus errata from the authors).
9259 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
9260 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
9261 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
9262 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
9263 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
9264 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
9265 &2D0*(D34/D56+D56/D34))
9266
9267C...Some general constants.
9268 XW=PARU(102)
9269 XWV=XW
9270 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
9271 XW1=1D0-XW
9272 SQMZ=PMAS(23,1)**2
9273 GMMZ=PMAS(23,1)*PMAS(23,2)
9274 SQMW=PMAS(24,1)**2
9275 GMMW=PMAS(24,1)*PMAS(24,2)
9276 SH=VINT(44)
9277
9278C...Reset original resonance configuration.
9279 DO 100 JT=1,8
9280 IREF(1,JT)=0
9281 100 CONTINUE
9282
9283C...Define initial one, two or three objects for subprocess.
9284 IF(IRES.EQ.0) THEN
9285 ISUB=MINT(1)
9286 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
9287 IREF(1,1)=MINT(84)+2+ISET(ISUB)
9288 IREF(1,4)=MINT(83)+6+ISET(ISUB)
9289 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
9290 IREF(1,1)=MINT(84)+1+ISET(ISUB)
9291 IREF(1,2)=MINT(84)+2+ISET(ISUB)
9292 IREF(1,4)=MINT(83)+5+ISET(ISUB)
9293 IREF(1,5)=MINT(83)+6+ISET(ISUB)
9294 ELSEIF(ISET(ISUB).EQ.5) THEN
9295 IREF(1,1)=MINT(84)+3
9296 IREF(1,2)=MINT(84)+4
9297 IREF(1,3)=MINT(84)+5
9298 IREF(1,4)=MINT(83)+7
9299 IREF(1,5)=MINT(83)+8
9300 IREF(1,6)=MINT(83)+9
9301 ENDIF
9302
9303C...Define original resonance for odd cases.
9304 ELSE
9305 ISUB=0
9306 IREF(1,1)=IRES
9307 ENDIF
9308
9309C...Check if initial resonance has been moved (in resonance + jet).
9310 DO 120 JT=1,3
9311 IF(IREF(1,JT).GT.0) THEN
9312 IF(K(IREF(1,JT),1).GT.10) THEN
9313 KFA=IABS(K(IREF(1,JT),2))
9314 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
9315 DO 110 I=IREF(1,JT)+1,N
9316 IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
9317 & IREF(1,JT)=I
9318 110 CONTINUE
9319 ELSE
9320 KDA=MOD(K(IREF(1,JT),4),MSTU(4))
9321 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
9322 ENDIF
9323 ENDIF
9324 ENDIF
9325 120 CONTINUE
9326
9327C...Loop over decay history.
9328 NP=1
9329 IP=0
9330 130 IP=IP+1
9331 NINH=0
9332 JTMAX=2
9333 IF(IREF(IP,2).EQ.0) JTMAX=1
9334 IF(IREF(IP,3).NE.0) JTMAX=3
9335 IT4=0
9336 NSAV=N
9337
9338C...Start treatment of one, two or three resonances in parallel.
9339 140 N=NSAV
9340 DO 220 JT=1,JTMAX
9341 ID=IREF(IP,JT)
9342 KDCY(JT)=0
9343 KFL1(JT)=0
9344 KFL2(JT)=0
9345 KFL3(JT)=0
9346 KEQL(JT)=0
9347 NSD(JT)=ID
9348
9349C...Check whether particle can/is allowed to decay.
9350 IF(ID.EQ.0) GOTO 210
9351 KFA=IABS(K(ID,2))
9352 KCA=PYCOMP(KFA)
9353 IF(MWID(KCA).EQ.0) GOTO 210
9354 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 210
9355 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
9356 & KFA.EQ.18) IT4=IT4+1
9357 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
9358 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
9359
9360C...Info for selection of decay channel: sign, pairings.
9361 IF(KCHG(KCA,3).EQ.0) THEN
9362 IPM=2
9363 ELSE
9364 IPM=(5-ISIGN(1,K(ID,2)))/2
9365 ENDIF
9366 KFB=0
9367 IF(JTMAX.EQ.2) THEN
9368 KFB=IABS(K(IREF(IP,3-JT),2))
9369 ELSEIF(JTMAX.EQ.3) THEN
9370 JT2=JT+1-3*(JT/3)
9371 KFB=IABS(K(IREF(IP,JT2),2))
9372 IF(KFB.NE.KFA) THEN
9373 JT2=JT+2-3*((JT+1)/3)
9374 KFB=IABS(K(IREF(IP,JT2),2))
9375 ENDIF
9376 ENDIF
9377
9378C...Select decay channel.
9379 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
9380 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
9381 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
9382 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
9383 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
9384 IF(WDTE0S.LE.0D0) GOTO 210
9385 RKFL=WDTE0S*PYR(0)
9386 IDL=0
9387 150 IDL=IDL+1
9388 IDC=IDL+MDCY(KCA,2)-1
9389 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
9390 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
9391 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 150
9392
9393C...Read out flavours and colour charges of decay channel chosen.
9394 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
9395 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
9396 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
9397 KFC1A=PYCOMP(IABS(KFL1(JT)))
9398 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
9399 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
9400 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
9401 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
9402 KFC2A=PYCOMP(IABS(KFL2(JT)))
9403 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
9404 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
9405 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
9406 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
9407 IF(KFL3(JT).NE.0) THEN
9408 KFC3A=PYCOMP(IABS(KFL3(JT)))
9409 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
9410 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
9411 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
9412 ENDIF
9413
9414C...Set/save further info on channel.
9415 KDCY(JT)=1
9416 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
9417 NSD(JT)=N
9418 HGZ(JT,1)=VINT(111)
9419 HGZ(JT,2)=VINT(112)
9420 HGZ(JT,3)=VINT(114)
9421
9422C...Select masses; to begin with assume resonances narrow.
9423 DO 170 I=1,3
9424 P(N+I,5)=0D0
9425 PMMN(I)=0D0
9426 IF(I.EQ.1) THEN
9427 KFLW=IABS(KFL1(JT))
9428 KCW=KFC1A
9429 ELSEIF(I.EQ.2) THEN
9430 KFLW=IABS(KFL2(JT))
9431 KCW=KFC2A
9432 ELSEIF(I.EQ.3) THEN
9433 IF(KFL3(JT).EQ.0) GOTO 170
9434 KFLW=IABS(KFL3(JT))
9435 KCW=KFC3A
9436 ENDIF
9437 P(N+I,5)=PMAS(KCW,1)
9438CMRENNA++
9439C...This prevents SUSY/t particles from becoming too light.
9440 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9441 PMMN(I)=PMAS(KCW,1)
9442 DO 160 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9443 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9444 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9445 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9446 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9447 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9448 PMMN(I)=MIN(PMMN(I),PMSUM)
9449 ENDIF
9450 160 CONTINUE
9451CMRENNA--
9452 ELSEIF(KFLW.EQ.6) THEN
9453 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9454 ENDIF
9455 170 CONTINUE
9456
9457C...Check which two out of three are widest.
9458 IWID1=1
9459 IWID2=2
9460 PWID1=PMAS(KFC1A,2)
9461 PWID2=PMAS(KFC2A,2)
9462 KFLW1=IABS(KFL1(JT))
9463 KFLW2=IABS(KFL2(JT))
9464 IF(KFL3(JT).NE.0) THEN
9465 PWID3=PMAS(KFC3A,2)
9466 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
9467 IWID1=3
9468 PWID1=PWID3
9469 KFLW1=IABS(KFL3(JT))
9470 ELSEIF(PWID3.GT.PWID2) THEN
9471 IWID2=3
9472 PWID2=PWID3
9473 KFLW2=IABS(KFL3(JT))
9474 ENDIF
9475 ENDIF
9476
9477C...If all narrow then only check that masses consistent.
9478 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
9479 & PWID2.LT.PARP(41))) THEN
9480CMRENNA++
9481C....Handle near degeneracy cases.
9482 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
9483 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
9484 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
9485 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
9486 ENDIF
9487 ENDIF
9488CMRENNA--
9489 IF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
9490 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
9491 MINT(51)=1
9492 RETURN
9493 ENDIF
9494
9495C...For three wide resonances select narrower of three
9496C...according to BW decoupled from rest.
9497 ELSE
9498 PMTOT=P(ID,5)
9499 IF(KFL3(JT).NE.0) THEN
9500 IWID3=6-IWID1-IWID2
9501 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
9502 & KFLW1-KFLW2
9503 LOOP=0
9504 180 LOOP=LOOP+1
9505 P(N+IWID3,5)=PYMASS(KFLW3)
9506 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 180
9507 PMTOT=PMTOT-P(N+IWID3,5)
9508 ENDIF
9509C...Select other two correlated within remaining phase space.
9510 IF(IP.EQ.1) THEN
9511 CKIN45=CKIN(45)
9512 CKIN47=CKIN(47)
9513 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
9514 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
9515 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9516 & P(N+IWID2,5))
9517 CKIN(45)=CKIN45
9518 CKIN(47)=CKIN47
9519 ELSE
9520 CKIN(49)=PMMN(IWID1)
9521 CKIN(50)=PMMN(IWID2)
9522 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9523 & P(N+IWID2,5))
9524 CKIN(49)=0D0
9525 CKIN(50)=0D0
9526 ENDIF
9527 IF(MINT(51).EQ.1) RETURN
9528 ENDIF
9529
9530C...Begin fill decay products, with colour flow for coloured objects.
9531 MSTU10=MSTU(10)
9532 MSTU(10)=1
9533 MSTU(19)=1
9534
9535CMRENNA++
9536C...1) Three-body decays of SUSY particles (plus special case top).
9537 IF(KFL3(JT).NE.0) THEN
9538 DO 200 I=N+1,N+3
9539 DO 190 J=1,5
9540 K(I,J)=0
9541 V(I,J)=0D0
9542 190 CONTINUE
9543 200 CONTINUE
9544 XM(1)=P(N+1,5)
9545 XM(2)=P(N+2,5)
9546 XM(3)=P(N+3,5)
9547 XM(5)=P(ID,5)
9548 CALL PYTBDY(XM)
9549 K(N+1,1)=1
9550 K(N+1,2)=KFL1(JT)
9551 K(N+2,1)=1
9552 K(N+2,2)=KFL2(JT)
9553 K(N+3,1)=1
9554 K(N+3,2)=KFL3(JT)
9555
9556C...Set colour flow for t -> W + b + Z.
9557 IF(KFA.EQ.6) THEN
9558 K(N+2,1)=3
9559 ISID=4
9560 IF(KCQM(JT).EQ.-1) ISID=5
9561 IDAU=N+2
9562 K(ID,ISID)=K(ID,ISID)+IDAU
9563 K(IDAU,ISID)=MSTU(5)*ID
9564
9565C...Set colour flow in three-body decays - programmed as special cases.
9566 ELSEIF(KFC2A.LE.6) THEN
9567 K(N+2,1)=3
9568 K(N+3,1)=3
9569 ISID=4
9570 IF(KFL2(JT).LT.0) ISID=5
9571 K(N+2,ISID)=MSTU(5)*(N+3)
9572 K(N+3,9-ISID)=MSTU(5)*(N+2)
9573 ENDIF
9574 IF(KFL1(JT).EQ.KSUSY1+21) THEN
9575 K(N+1,1)=3
9576 K(N+2,1)=3
9577 K(N+3,1)=3
9578 ISID=4
9579 IF(KFL2(JT).LT.0) ISID=5
9580 K(N+1,ISID)=MSTU(5)*(N+2)
9581 K(N+1,9-ISID)=MSTU(5)*(N+3)
9582 K(N+2,ISID)=MSTU(5)*(N+1)
9583 K(N+3,9-ISID)=MSTU(5)*(N+1)
9584 ENDIF
9585 IF(KFA.EQ.KSUSY1+21) THEN
9586 K(N+2,1)=3
9587 K(N+3,1)=3
9588 ISID=4
9589 IF(KFL2(JT).LT.0) ISID=5
9590 K(ID,ISID)=K(ID,ISID)+(N+2)
9591 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
9592 K(N+2,ISID)=MSTU(5)*ID
9593 K(N+3,9-ISID)=MSTU(5)*ID
9594 ENDIF
9595 N=N+3
9596CMRENNA--
9597
9598C...2) Everything else two-body decay.
9599 ELSE
9600 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
9601C...First set colour flow as if mother colour singlet.
9602 IF(KCQ1(JT).NE.0) THEN
9603 K(N-1,1)=3
9604 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
9605 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
9606 ENDIF
9607 IF(KCQ2(JT).NE.0) THEN
9608 K(N,1)=3
9609 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
9610 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
9611 ENDIF
9612C...Then redirect colour flow if mother (anti)triplet.
9613 IF(KCQM(JT).EQ.0) THEN
9614 ELSEIF(KCQM(JT).NE.2) THEN
9615 ISID=4
9616 IF(KCQM(JT).EQ.-1) ISID=5
9617 IDAU=N-1
9618 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
9619 K(ID,ISID)=K(ID,ISID)+IDAU
9620 K(IDAU,ISID)=MSTU(5)*ID
9621C...Then redirect colour flow if mother octet.
9622 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
9623 IDAU=N-1
9624 IF(KCQ1(JT).EQ.0) IDAU=N
9625 K(ID,4)=K(ID,4)+IDAU
9626 K(ID,5)=K(ID,5)+IDAU
9627 K(IDAU,4)=MSTU(5)*ID
9628 K(IDAU,5)=MSTU(5)*ID
9629 ELSE
9630 ISID=4
9631 IF(KCQ1(JT).EQ.-1) ISID=5
9632 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
9633 K(ID,ISID)=K(ID,ISID)+(N-1)
9634 K(ID,9-ISID)=K(ID,9-ISID)+N
9635 K(N-1,ISID)=MSTU(5)*ID
9636 K(N,9-ISID)=MSTU(5)*ID
9637 ENDIF
9638 ENDIF
9639
9640C...End loop over resonances for daughter flavour and mass selection.
9641 MSTU(10)=MSTU10
9642 210 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
9643 & NINH=NINH+1
9644 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
9645 WRITE(CODE,'(I9)') K(ID,2)
9646 WRITE(MASS,'(F9.3)') P(ID,5)
9647 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
9648 & CODE//' with mass'//MASS)
9649 MINT(51)=1
9650 RETURN
9651 ENDIF
9652 220 CONTINUE
9653
9654C...Check for allowed combinations. Skip if no decays.
9655 IF(JTMAX.EQ.1) THEN
9656 IF(KDCY(1).EQ.0) GOTO 560
9657 ELSEIF(JTMAX.EQ.2) THEN
9658 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 560
9659 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9660 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9661 ELSEIF(JTMAX.EQ.3) THEN
9662 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 560
9663 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9664 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9665 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9666 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9667 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9668 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9669 ENDIF
9670
9671C...Special case: matrix element option for Z0 decay to quarks.
9672 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
9673 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
9674
9675C...Check consistency of MSTJ options set.
9676 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9677 CALL PYERRM(6,
9678 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
9679 MSTJ(110)=1
9680 ENDIF
9681 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9682 CALL PYERRM(6,
9683 & '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
9684 MSTJ(111)=0
9685 ENDIF
9686
9687C...Select alpha_strong behaviour.
9688 MST111=MSTU(111)
9689 PAR112=PARU(112)
9690 MSTU(111)=MSTJ(108)
9691 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9692 & MSTU(111)=1
9693 PARU(112)=PARJ(121)
9694 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9695
9696C...Find axial fraction in total cross section for scalar gluon model.
9697 PARJ(171)=0D0
9698 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
9699 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
9700 POLL=1D0-PARJ(131)*PARJ(132)
9701 SFF=1D0/(16D0*XW*XW1)
9702 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
9703 & (PARJ(123)*PARJ(124))**2)
9704 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
9705 VE=4D0*XW-1D0
9706 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
9707 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
9708 & (PARJ(132)-PARJ(131)))
9709 KFLC=IABS(KFL1(1))
9710 PMQ=PYMASS(KFLC)
9711 QF=KCHG(KFLC,1)/3D0
9712 VQ=1D0
9713 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
9714 & 1D0-(2D0*PMQ/P(ID,5))**2))
9715 VF=SIGN(1D0,QF)-4D0*QF*XW
9716 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
9717 & VF**2*HF1W)+VQ**3*HF1W
9718 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
9719 ENDIF
9720
9721C...Choice of jet configuration.
9722 CALL PYXJET(P(ID,5),NJET,CUT)
9723 KFLC=IABS(KFL1(1))
9724 KFLN=21
9725 IF(NJET.EQ.4) THEN
9726 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
9727 ELSEIF(NJET.EQ.3) THEN
9728 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
9729 ELSE
9730 MSTJ(120)=1
9731 ENDIF
9732
9733C...Fill jet configuration; return if incorrect kinematics.
9734 NC=N-2
9735 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
9736 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
9737 ELSEIF(NJET.EQ.2) THEN
9738 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
9739 ELSEIF(NJET.EQ.3) THEN
9740 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
9741 ELSEIF(KFLN.EQ.21) THEN
9742 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9743 & X12,X14)
9744 ELSE
9745 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9746 & X12,X14)
9747 ENDIF
9748 IF(MSTU(24).NE.0) THEN
9749 MINT(51)=1
9750 MSTU(111)=MST111
9751 PARU(112)=PAR112
9752 RETURN
9753 ENDIF
9754
9755C...Angular orientation according to matrix element.
9756 IF(MSTJ(106).EQ.1) THEN
9757 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHI,THE,PHI)
9758 IF(MINT(11).LT.0) THE=PARU(1)-THE
9759 CTHE(1)=COS(THE)
9760 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
9761 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
9762 ENDIF
9763
9764C...Boost partons to Z0 rest frame.
9765 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
9766 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9767
9768C...Mark decayed resonance and add documentation lines,
9769 K(ID,1)=K(ID,1)+10
9770 IDOC=MINT(83)+MINT(4)
9771 DO 240 I=NC+1,N
9772 I1=MINT(83)+MINT(4)+1
9773 K(I,3)=I1
9774 IF(MSTP(128).GE.1) K(I,3)=ID
9775 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
9776 MINT(4)=MINT(4)+1
9777 K(I1,1)=21
9778 K(I1,2)=K(I,2)
9779 K(I1,3)=IREF(IP,4)
9780 DO 230 J=1,5
9781 P(I1,J)=P(I,J)
9782 230 CONTINUE
9783 ENDIF
9784 240 CONTINUE
9785
9786C...Generate parton shower.
9787 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
9788
9789C... End special case for Z0: skip ahead.
9790 MSTU(111)=MST111
9791 PARU(112)=PAR112
9792 GOTO 550
9793 ENDIF
9794
9795C...Order incoming partons and outgoing resonances.
9796 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9797 ILIN(1)=MINT(84)+1
9798 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
9799 IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
9800 ILIN(2)=2*MINT(84)+3-ILIN(1)
9801 IMIN=1
9802 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
9803 & .EQ.36) IMIN=3
9804 IMAX=2
9805 IORD=1
9806 IF(K(IREF(IP,1),2).EQ.23) IORD=2
9807 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
9808 IAKIPD=IABS(K(IREF(IP,IORD),2))
9809 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
9810 IF(KDCY(IORD).EQ.0) IORD=3-IORD
9811
9812C...Order decay products of resonances.
9813 DO 250 JT=IORD,3-IORD,3-2*IORD
9814 IF(KDCY(JT).EQ.0) THEN
9815 ILIN(IMAX+1)=NSD(JT)
9816 IMAX=IMAX+1
9817 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
9818 ILIN(IMAX+1)=N+2*JT-1
9819 ILIN(IMAX+2)=N+2*JT
9820 IMAX=IMAX+2
9821 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9822 K(N+2*JT,2)=K(NSD(JT)+2,2)
9823 ELSE
9824 ILIN(IMAX+1)=N+2*JT
9825 ILIN(IMAX+2)=N+2*JT-1
9826 IMAX=IMAX+2
9827 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9828 K(N+2*JT,2)=K(NSD(JT)+2,2)
9829 ENDIF
9830 250 CONTINUE
9831
9832C...Find charge, isospin, left- and righthanded couplings.
9833 DO 270 I=IMIN,IMAX
9834 DO 260 J=1,4
9835 COUP(I,J)=0D0
9836 260 CONTINUE
9837 KFA=IABS(K(ILIN(I),2))
9838 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 270
9839 COUP(I,1)=KCHG(KFA,1)/3D0
9840 COUP(I,2)=(-1)**MOD(KFA,2)
9841 COUP(I,4)=-2D0*COUP(I,1)*XWV
9842 COUP(I,3)=COUP(I,2)+COUP(I,4)
9843 270 CONTINUE
9844
9845C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
9846 IF(ISUB.EQ.22) THEN
9847 DO 300 I=3,5,2
9848 I1=IORD
9849 IF(I.EQ.5) I1=3-IORD
9850 DO 290 J1=1,2
9851 DO 280 J2=1,2
9852 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
9853 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
9854 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
9855 & COUP(I,J2+2)**2
9856 280 CONTINUE
9857 290 CONTINUE
9858 300 CONTINUE
9859 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
9860 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
9861 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
9862 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
9863 IF(COWT12.LT.PYR(0)*COMX12) GOTO 140
9864 ENDIF
9865 ENDIF
9866
9867C...Select angular orientation type - Z'/W' only.
9868 MZPWP=0
9869 IF(ISUB.EQ.141) THEN
9870 IF(PYR(0).LT.PARU(130)) MZPWP=1
9871 IF(IP.EQ.2) THEN
9872 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
9873 IAKIR=IABS(K(IREF(2,2),2))
9874 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9875 ENDIF
9876 IF(IP.GE.3) MZPWP=2
9877 ELSEIF(ISUB.EQ.142) THEN
9878 IF(PYR(0).LT.PARU(136)) MZPWP=1
9879 IF(IP.EQ.2) THEN
9880 IAKIR=IABS(K(IREF(2,2),2))
9881 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9882 ENDIF
9883 IF(IP.GE.3) MZPWP=2
9884 ENDIF
9885
9886C...Select random angles (begin of weighting procedure).
9887 310 DO 320 JT=1,JTMAX
9888 IF(KDCY(JT).EQ.0) GOTO 320
9889 IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
9890 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
9891 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
9892 PHI(JT)=VINT(24)
9893 ELSE
9894 CTHE(JT)=2D0*PYR(0)-1D0
9895 PHI(JT)=PARU(2)*PYR(0)
9896 ENDIF
9897 320 CONTINUE
9898
9899 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9900C...Construct massless four-vectors.
9901 DO 340 I=N+1,N+4
9902 K(I,1)=1
9903 DO 330 J=1,5
9904 P(I,J)=0D0
9905 V(I,J)=0D0
9906 330 CONTINUE
9907 340 CONTINUE
9908 DO 350 JT=1,JTMAX
9909 IF(KDCY(JT).EQ.0) GOTO 350
9910 ID=IREF(IP,JT)
9911 P(N+2*JT-1,3)=0.5D0*P(ID,5)
9912 P(N+2*JT-1,4)=0.5D0*P(ID,5)
9913 P(N+2*JT,3)=-0.5D0*P(ID,5)
9914 P(N+2*JT,4)=0.5D0*P(ID,5)
9915 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
9916 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9917 350 CONTINUE
9918
9919C...Store incoming and outgoing momenta, with random rotation to
9920C...avoid accidental zeroes in HA expressions.
9921 DO 370 I=1,IMAX
9922 K(N+4+I,1)=1
9923 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
9924 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
9925 P(N+4+I,5)=P(ILIN(I),5)
9926 DO 360 J=1,3
9927 P(N+4+I,J)=P(ILIN(I),J)
9928 360 CONTINUE
9929 370 CONTINUE
9930 380 THERR=ACOS(2D0*PYR(0)-1D0)
9931 PHIRR=PARU(2)*PYR(0)
9932 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
9933 DO 400 I=1,IMAX
9934 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2) GOTO 380
9935 DO 390 J=1,4
9936 PK(I,J)=P(N+4+I,J)
9937 390 CONTINUE
9938 400 CONTINUE
9939
9940C...Calculate internal products.
9941 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
9942 & ISUB.EQ.142) THEN
9943 DO 420 I1=IMIN,IMAX-1
9944 DO 410 I2=I1+1,IMAX
9945 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
9946 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
9947 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
9948 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
9949 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
9950 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
9951 HC(I1,I2)=CONJG(HA(I1,I2))
9952 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
9953 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
9954 HA(I2,I1)=-HA(I1,I2)
9955 HC(I2,I1)=-HC(I1,I2)
9956 410 CONTINUE
9957 420 CONTINUE
9958 ENDIF
9959 DO 440 I=1,2
9960 DO 430 J=1,4
9961 PK(I,J)=-PK(I,J)
9962 430 CONTINUE
9963 440 CONTINUE
9964 DO 460 I1=IMIN,IMAX-1
9965 DO 450 I2=I1+1,IMAX
9966 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
9967 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
9968 PKK(I2,I1)=PKK(I1,I2)
9969 450 CONTINUE
9970 460 CONTINUE
9971 ENDIF
9972
9973 KFAGM=IABS(IREF(IP,7))
9974 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
9975C...Isotropic decay selected by user.
9976 WT=1D0
9977 WTMAX=1D0
9978
9979 ELSEIF(JTMAX.EQ.3) THEN
9980C...Isotropic decay when three mother particles.
9981 WT=1D0
9982 WTMAX=1D0
9983
9984 ELSEIF(IT4.GE.1) THEN
9985C... Isotropic decay t -> b + W etc for 4th generation q and l.
9986 WT=1D0
9987 WTMAX=1D0
9988
9989 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
9990 & IREF(IP,7).EQ.36) THEN
9991C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
9992 IF(IP.EQ.1) WTMAX=SH**2
9993 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
9994 KFA=IABS(K(IREF(IP,1),2))
9995 IF(KFA.EQ.23) THEN
9996 KFLF1A=IABS(KFL1(1))
9997 EF1=KCHG(KFLF1A,1)/3D0
9998 AF1=SIGN(1D0,EF1+0.1D0)
9999 VF1=AF1-4D0*EF1*XWV
10000 KFLF2A=IABS(KFL1(2))
10001 EF2=KCHG(KFLF2A,1)/3D0
10002 AF2=SIGN(1D0,EF2+0.1D0)
10003 VF2=AF2-4D0*EF2*XWV
10004 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
10005 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
10006 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
10007 ELSEIF(KFA.EQ.24) THEN
10008 WT=16D0*PKK(3,5)*PKK(4,6)
10009 ELSE
10010 WT=WTMAX
10011 ENDIF
10012
10013 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
10014 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
10015 & THEN
10016C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
10017 I1=IREF(IP,8)
10018 IF(MOD(KFAGM,2).EQ.0) THEN
10019 I2=N+1
10020 I3=N+2
10021 ELSE
10022 I2=N+2
10023 I3=N+1
10024 ENDIF
10025 I4=IREF(IP,2)
10026 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
10027 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
10028 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
10029 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
10030
10031 ELSEIF(ISUB.EQ.1) THEN
10032C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
10033 EI=KCHG(IABS(MINT(15)),1)/3D0
10034 AI=SIGN(1D0,EI+0.1D0)
10035 VI=AI-4D0*EI*XWV
10036 EF=KCHG(IABS(KFL1(1)),1)/3D0
10037 AF=SIGN(1D0,EF+0.1D0)
10038 VF=AF-4D0*EF*XWV
10039 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
10040 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10041 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
10042 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10043 & (VI**2+AI**2)*VINT(114)*VF**2)
10044 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
10045 & 4D0*VI*AI*VINT(114)*VF*AF)
10046 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
10047 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
10048 WTMAX=2D0*(WT1+ABS(WT3))
10049
10050 ELSEIF(ISUB.EQ.2) THEN
10051C...Angular weight for W+/- -> 2 quarks/leptons.
10052 WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
10053 WTMAX=4D0
10054
10055 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
10056C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
10057C...-> gluon/gamma + 2 quarks/leptons.
10058 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10059 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10060 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10061 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10062 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10063 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10064 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10065 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10066 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10067 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10068 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10069 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10070 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
10071 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
10072 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10073 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
10074
10075 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
10076C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
10077C...-> gluon/gamma + 2 quarks/leptons.
10078 WT=PKK(1,3)**2+PKK(2,4)**2
10079 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
10080
10081 ELSEIF(ISUB.EQ.22) THEN
10082C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
10083 S34=P(IREF(IP,IORD),5)**2
10084 S56=P(IREF(IP,3-IORD),5)**2
10085 TI=PKK(1,3)+PKK(1,4)+S34
10086 UI=PKK(1,5)+PKK(1,6)+S56
10087 TIR=REAL(TI)
10088 UIR=REAL(UI)
10089 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
10090 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
10091 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
10092 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
10093 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
10094 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
10095 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
10096 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
10097 WT=
10098 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
10099 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
10100 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
10101 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
10102 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
10103 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
10104 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
10105 & 1D0/UI**2))
10106
10107 ELSEIF(ISUB.EQ.23) THEN
10108C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
10109 D34=P(IREF(IP,IORD),5)**2
10110 D56=P(IREF(IP,3-IORD),5)**2
10111 DT=PKK(1,3)+PKK(1,4)+D34
10112 DU=PKK(1,5)+PKK(1,6)+D56
10113 FACBW=1D0/((SH-SQMW)**2+SQMW*PMAS(24,2)**2)
10114 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10115 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10116 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
10117 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
10118 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
10119 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
10120 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10121 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
10122 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
10123
10124 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
10125C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
10126C...(or H0, or A0).
10127 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10128 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
10129 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
10130 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10131 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10132
10133 ELSEIF(ISUB.EQ.25) THEN
10134C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
10135 D34=P(IREF(IP,IORD),5)**2
10136 D56=P(IREF(IP,3-IORD),5)**2
10137 DT=PKK(1,3)+PKK(1,4)+D34
10138 DU=PKK(1,5)+PKK(1,6)+D56
10139 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
10140 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
10141 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
10142 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
10143 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
10144 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
10145 & REAL(CBWW)*FGK(1,2,5,6,3,4))
10146 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10147 WT=FGK135**2+(CCWW*FGK253)**2
10148 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
10149 & CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10150
10151 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
10152C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
10153C...(or H0, or A0).
10154 WT=PKK(1,3)*PKK(2,4)
10155 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10156
10157 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
10158C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
10159C...-> f + 2 quarks/leptons.
10160 CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10161 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10162 & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10163 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10164 & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10165 & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10166 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10167 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10168 & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10169 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10170 & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10171 & COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10172 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
10173 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
10174 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
10175 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
10176 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10177 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
10178
10179 ELSEIF(ISUB.EQ.31) THEN
10180C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.
10181 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
10182 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
10183 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
10184
10185 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
10186 & ISUB.EQ.77) THEN
10187C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
10188 WT=16D0*PKK(3,5)*PKK(4,6)
10189 WTMAX=SH**2
10190
10191 ELSEIF(ISUB.EQ.110) THEN
10192C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
10193 WT=1D0
10194 WTMAX=1D0
10195
10196 ELSEIF(ISUB.EQ.141) THEN
10197 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10198C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
10199C...Couplings of incoming flavour.
10200 KFAI=IABS(MINT(15))
10201 EI=KCHG(KFAI,1)/3D0
10202 AI=SIGN(1D0,EI+0.1D0)
10203 VI=AI-4D0*EI*XWV
10204 KFAIC=1
10205 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
10206 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
10207 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
10208 VPI=PARU(119+2*KFAIC)
10209 API=PARU(120+2*KFAIC)
10210C...Couplings of final flavour.
10211 KFAF=IABS(KFL1(1))
10212 EF=KCHG(KFAF,1)/3D0
10213 AF=SIGN(1D0,EF+0.1D0)
10214 VF=AF-4D0*EF*XWV
10215 KFAFC=1
10216 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
10217 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
10218 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
10219 VPF=PARU(119+2*KFAFC)
10220 APF=PARU(120+2*KFAFC)
10221C...Asymmetry and weight.
10222 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
10223 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
10224 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
10225 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10226 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
10227 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
10228 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
10229 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10230 WTMAX=2D0+ABS(ASYM)
10231 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
10232C...Angular weight for f + fbar -> Z' -> W+ + W-.
10233 RM1=P(NSD(1)+1,5)**2/SH
10234 RM2=P(NSD(1)+2,5)**2/SH
10235 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10236 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10237 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10238 & (RM2-RM1)**2)
10239 WT=CFLAT+CCOS2*CTHE(1)**2
10240 WTMAX=CFLAT+MAX(0D0,CCOS2)
10241 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
10242 & IABS(KFL1(1)).EQ.37)) THEN
10243C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
10244 WT=1D0-CTHE(1)**2
10245 WTMAX=1D0
10246 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10247C...Angular weight for f + fbar -> Z' -> Z0 + h0.
10248 RM1=P(NSD(1)+1,5)**2/SH
10249 RM2=P(NSD(1)+2,5)**2/SH
10250 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10251 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10252 WTMAX=1D0+FLAM2/(8D0*RM1)
10253 ELSEIF(MZPWP.EQ.0) THEN
10254C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10255C...(W:s like if intermediate Z).
10256 D34=P(IREF(IP,IORD),5)**2
10257 D56=P(IREF(IP,3-IORD),5)**2
10258 DT=PKK(1,3)+PKK(1,4)+D34
10259 DU=PKK(1,5)+PKK(1,6)+D56
10260 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10261 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10262 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
10263 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
10264 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10265 ELSEIF(MZPWP.EQ.1) THEN
10266C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10267C...(W:s approximately longitudinal, like if intermediate H).
10268 WT=16D0*PKK(3,5)*PKK(4,6)
10269 WTMAX=SH**2
10270 ELSE
10271C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
10272C...H0 + A0 -> 4 quarks/leptons.
10273 WT=1D0
10274 WTMAX=1D0
10275 ENDIF
10276
10277 ELSEIF(ISUB.EQ.142) THEN
10278 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10279C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
10280 KFAI=IABS(MINT(15))
10281 KFAIC=1
10282 IF(KFAI.GT.10) KFAIC=2
10283 VI=PARU(129+2*KFAIC)
10284 AI=PARU(130+2*KFAIC)
10285 KFAF=IABS(KFL1(1))
10286 KFAFC=1
10287 IF(KFAF.GT.10) KFAFC=2
10288 VF=PARU(129+2*KFAFC)
10289 AF=PARU(130+2*KFAFC)
10290 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
10291 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10292 WTMAX=2D0+ABS(ASYM)
10293 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
10294C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
10295 RM1=P(NSD(1)+1,5)**2/SH
10296 RM2=P(NSD(1)+2,5)**2/SH
10297 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10298 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10299 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10300 & (RM2-RM1)**2)
10301 WT=CFLAT+CCOS2*CTHE(1)**2
10302 WTMAX=CFLAT+MAX(0D0,CCOS2)
10303 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10304C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
10305 RM1=P(NSD(1)+1,5)**2/SH
10306 RM2=P(NSD(1)+2,5)**2/SH
10307 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10308 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10309 WTMAX=1D0+FLAM2/(8D0*RM1)
10310 ELSEIF(MZPWP.EQ.0) THEN
10311C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10312C...(W/Z like if intermediate W).
10313 D34=P(IREF(IP,IORD),5)**2
10314 D56=P(IREF(IP,3-IORD),5)**2
10315 DT=PKK(1,3)+PKK(1,4)+D34
10316 DU=PKK(1,5)+PKK(1,6)+D56
10317 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10318 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
10319 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10320 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
10321 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10322 ELSEIF(MZPWP.EQ.1) THEN
10323C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10324C...(W/Z approximately longitudinal, like if intermediate H).
10325 WT=16D0*PKK(3,5)*PKK(4,6)
10326 WTMAX=SH**2
10327 ELSE
10328C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.
10329 WT=1D0
10330 WTMAX=1D0
10331 ENDIF
10332
10333 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
10334 & THEN
10335C...Isotropic decay of leptoquarks (assumed spin 0).
10336 WT=1D0
10337 WTMAX=1D0
10338
10339 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
10340C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).
10341 SIDE=1D0
10342 IF(MINT(16).EQ.21) SIDE=-1D0
10343 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
10344 WT=1D0+SIDE*CTHE(1)
10345 WTMAX=2D0
10346 ELSEIF(IP.EQ.1) THEN
10347 RM1=P(NSD(1)+1,5)**2/SH
10348 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10349 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10350 ELSE
10351C...W/Z decay assumed isotropic, since not known.
10352 WT=1D0
10353 WTMAX=1D0
10354 ENDIF
10355
10356 ELSEIF(ISUB.EQ.149) THEN
10357C...Isotropic decay of techni-eta.
10358 WT=1D0
10359 WTMAX=1D0
10360
10361 ELSEIF(ISUB.EQ.191) THEN
10362 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10363C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
10364C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
10365 WT=1D0-CTHE(1)**2
10366 WTMAX=1D0
10367 ELSEIF(IP.EQ.1) THEN
10368C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
10369 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10370 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
10371 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10372 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10373 KFAI=IABS(MINT(15))
10374 EI=KCHG(KFAI,1)/3D0
10375 AI=SIGN(1D0,EI+0.1D0)
10376 VI=AI-4D0*EI*XWV
10377 VALI=0.5D0*(VI+AI)
10378 VARI=0.5D0*(VI-AI)
10379 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
10380 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
10381 KFAF=IABS(KFL1(1))
10382 EF=KCHG(KFAF,1)/3D0
10383 AF=SIGN(1D0,EF+0.1D0)
10384 VF=AF-4D0*EF*XWV
10385 VALF=0.5D0*(VF+AF)
10386 VARF=0.5D0*(VF-AF)
10387 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
10388 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
10389 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
10390 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
10391 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
10392 WTMAX=4D0*MAX(ASAME,AFLIP)
10393 ELSE
10394C...Isotropic decay of W/pi_tech produced in rho_tech decay.
10395 WT=1D0
10396 WTMAX=1D0
10397 ENDIF
10398
10399 ELSEIF(ISUB.EQ.192) THEN
10400 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10401C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
10402C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
10403 WT=1D0-CTHE(1)**2
10404 WTMAX=1D0
10405 ELSEIF(IP.EQ.1) THEN
10406C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
10407 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10408 WT=(1D0+CTHESG)**2
10409 WTMAX=4D0
10410 ELSE
10411C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
10412 WT=1D0
10413 WTMAX=1D0
10414 ENDIF
10415
10416 ELSEIF(ISUB.EQ.193) THEN
10417 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10418C...Angular weight for f + fbar -> omega_tech0 ->
10419C...gamma pi_tech0 or Z0 pi_tech0.
10420 WT=1D0+CTHE(1)**2
10421 WTMAX=2D0
10422 ELSEIF(IP.EQ.1) THEN
10423C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
10424 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10425 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10426 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10427 KFAI=IABS(MINT(15))
10428 EI=KCHG(KFAI,1)/3D0
10429 AI=SIGN(1D0,EI+0.1D0)
10430 VI=AI-4D0*EI*XWV
10431 VALI=0.5D0*(VI+AI)
10432 VARI=0.5D0*(VI-AI)
10433 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
10434 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
10435 KFAF=IABS(KFL1(1))
10436 EF=KCHG(KFAF,1)/3D0
10437 AF=SIGN(1D0,EF+0.1D0)
10438 VF=AF-4D0*EF*XWV
10439 VALF=0.5D0*(VF+AF)
10440 VARF=0.5D0*(VF-AF)
10441 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
10442 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
10443 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
10444 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
10445 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
10446 WTMAX=4D0*MAX(BSAME,BFLIP)
10447 ELSE
10448C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
10449 WT=1D0
10450 WTMAX=1D0
10451 ENDIF
10452
10453C...Obtain correct angular distribution by rejection techniques.
10454 ELSE
10455 WT=1D0
10456 WTMAX=1D0
10457 ENDIF
10458 IF(WT.LT.PYR(0)*WTMAX) GOTO 310
10459
10460C...Construct massive four-vectors using angles chosen.
10461 470 DO 540 JT=1,JTMAX
10462 IF(KDCY(JT).EQ.0) GOTO 540
10463 ID=IREF(IP,JT)
10464 DO 480 J=1,5
10465 DPMO(J)=P(ID,J)
10466 480 CONTINUE
10467 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
10468CMRENNA++
10469 IF(KFL3(JT).EQ.0) THEN
10470 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
10471 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10472 ELSE
10473 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
10474 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10475 ENDIF
10476CMRENNA--
10477
10478C...Mark decayed resonances; trace history.
10479 K(ID,1)=K(ID,1)+10
10480 KFA=IABS(K(ID,2))
10481 KCA=PYCOMP(KFA)
10482 IF(KCQM(JT).NE.0) THEN
10483C...Do not kill colour flow through coloured resonance!
10484 ELSE
10485 K(ID,4)=NSD(JT)+1
10486 K(ID,5)=NSD(JT)+2
10487 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
10488 ENDIF
10489
10490C...Add documentation lines.
10491 IF(ISUB.NE.0) THEN
10492 IDOC=MINT(83)+MINT(4)
10493CMRENNA+++
10494 IHI=NSD(JT)+2
10495 IF(KFL3(JT).NE.0) IHI=IHI+1
10496 DO 500 I=NSD(JT)+1,IHI
10497CMRENNA---
10498 I1=MINT(83)+MINT(4)+1
10499 K(I,3)=I1
10500 IF(MSTP(128).GE.1) K(I,3)=ID
10501 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
10502 MINT(4)=MINT(4)+1
10503 K(I1,1)=21
10504 K(I1,2)=K(I,2)
10505 K(I1,3)=IREF(IP,JT+3)
10506 DO 490 J=1,5
10507 P(I1,J)=P(I,J)
10508 490 CONTINUE
10509 ENDIF
10510 500 CONTINUE
10511 ELSE
10512 K(NSD(JT)+1,3)=ID
10513 K(NSD(JT)+2,3)=ID
10514 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
10515 ENDIF
10516
10517C...Do showering if any of the two/three products can shower.
10518 NSHBEF=N
10519 IF(MSTP(71).GE.1) THEN
10520 ISHOW1=0
10521 KFL1A=IABS(KFL1(JT))
10522 IF(KFL1A.LE.22) ISHOW1=1
10523 ISHOW2=0
10524 KFL2A=IABS(KFL2(JT))
10525 IF(KFL2A.LE.22) ISHOW2=1
10526 ISHOW3=0
10527 IF(KFL3(JT).NE.0) THEN
10528 KFL3A=IABS(KFL3(JT))
10529 IF(KFL3A.LE.22) ISHOW3=1
10530 ENDIF
10531 IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
10532 ELSEIF(KFL3(JT).EQ.0) THEN
10533 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
10534 ELSE
10535 NSD1=NSD(JT)+1
10536 NSD2=NSD(JT)+2
10537 IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
10538 NSD1=NSD(JT)+3
10539 ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
10540 NSD2=NSD(JT)+3
10541 ENDIF
10542 PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
10543 & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
10544 & (P(NSD1,3)+P(NSD2,3))**2))
10545 CALL PYSHOW(NSD1,NSD2,PMSHOW)
10546 ENDIF
10547 ENDIF
10548 NSHAFT=N
10549 IF(JT.EQ.1) NAFT1=N
10550
10551C...Check if decay products moved by shower.
10552 NSD1=NSD(JT)+1
10553 NSD2=NSD(JT)+2
10554 NSD3=NSD(JT)+3
10555 IF(NSHAFT.GT.NSHBEF) THEN
10556 IF(K(NSD1,1).GT.10) THEN
10557 DO 510 I=NSHBEF+1,NSHAFT
10558 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
10559 510 CONTINUE
10560 ENDIF
10561 IF(K(NSD2,1).GT.10) THEN
10562 DO 520 I=NSHBEF+1,NSHAFT
10563 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
10564 & I.NE.NSD1) NSD2=I
10565 520 CONTINUE
10566 ENDIF
10567 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
10568 DO 530 I=NSHBEF+1,NSHAFT
10569 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
10570 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
10571 530 CONTINUE
10572 ENDIF
10573 ENDIF
10574
10575C...Store decay products for further treatment.
10576 NP=NP+1
10577 IREF(NP,1)=NSD1
10578 IREF(NP,2)=NSD2
10579 IREF(NP,3)=0
10580 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
10581 IREF(NP,4)=IDOC+1
10582 IREF(NP,5)=IDOC+2
10583 IREF(NP,6)=0
10584 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
10585 IREF(NP,7)=K(IREF(IP,JT),2)
10586 IREF(NP,8)=IREF(IP,JT)
10587 540 CONTINUE
10588
10589C...Fill information for 2 -> 1 -> 2.
10590 550 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
10591 MINT(7)=MINT(83)+6+2*ISET(ISUB)
10592 MINT(8)=MINT(83)+7+2*ISET(ISUB)
10593 MINT(25)=KFL1(1)
10594 MINT(26)=KFL2(1)
10595 VINT(23)=CTHE(1)
10596 RM3=P(N-1,5)**2/SH
10597 RM4=P(N,5)**2/SH
10598 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
10599 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
10600 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
10601 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
10602 VINT(47)=SQRT(VINT(48))
10603 ENDIF
10604
10605C...Possibility of colour rearrangement in W+W- events.
10606 IF(ISUB.EQ.25.AND.MSTP(115).GE.1) THEN
10607 IAKF1=IABS(KFL1(1))
10608 IAKF2=IABS(KFL1(2))
10609 IAKF3=IABS(KFL2(1))
10610 IAKF4=IABS(KFL2(2))
10611 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
10612 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
10613 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
10614 ENDIF
10615
10616C...Loop back if needed.
10617 560 IF(IP.LT.NP) GOTO 130
10618
10619 RETURN
10620 END
10621
10622C*********************************************************************
10623
10624*$ CREATE PYMULT.FOR
10625*COPY PYMULT
10626C...PYMULT
10627C...Initializes treatment of multiple interactions, selects kinematics
10628C...of hardest interaction if low-pT physics included in run, and
10629C...generates all non-hardest interactions.
10630
10631 SUBROUTINE PYMULT(MMUL)
10632
10633C...Double precision and integer declarations.
10634 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10635 INTEGER PYK,PYCHGE,PYCOMP
10636C...Commonblocks.
10637 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10638 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10639 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10640 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10641 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10642 COMMON/PYINT1/MINT(400),VINT(400)
10643 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10644 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10645 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10646 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
10647 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10648 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
10649C...Local arrays and saved variables.
10650 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
10651 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
10652
10653C...Initialization of multiple interaction treatment.
10654 IF(MMUL.EQ.1) THEN
10655 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
10656 ISUB=96
10657 MINT(1)=96
10658 VINT(63)=0D0
10659 VINT(64)=0D0
10660 VINT(143)=1D0
10661 VINT(144)=1D0
10662
10663C...Loop over phase space points: xT2 choice in 20 bins.
10664 100 SIGSUM=0D0
10665 DO 120 IXT2=1,20
10666 NMUL(IXT2)=MSTP(83)
10667 SIGM(IXT2)=0D0
10668 DO 110 ITRY=1,MSTP(83)
10669 RSCA=0.05D0*((21-IXT2)-PYR(0))
10670 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
10671 XT2=MAX(0.01D0*VINT(149),XT2)
10672 VINT(25)=XT2
10673
10674C...Choose tau and y*. Calculate cos(theta-hat).
10675 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10676 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10677 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10678 ELSE
10679 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10680 ENDIF
10681 VINT(21)=TAU
10682 CALL PYKLIM(2)
10683 RYST=PYR(0)
10684 MYST=1
10685 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10686 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10687 CALL PYKMAP(2,MYST,PYR(0))
10688 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10689
10690C...Calculate differential cross-section.
10691 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10692 CALL PYSIGH(NCHN,SIGS)
10693 SIGM(IXT2)=SIGM(IXT2)+SIGS
10694 110 CONTINUE
10695 SIGSUM=SIGSUM+SIGM(IXT2)
10696 120 CONTINUE
10697 SIGSUM=SIGSUM/(20D0*MSTP(83))
10698
10699C...Reject result if sigma(parton-parton) is smaller than hadronic one.
10700 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
10701 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) PARP(82),SIGSUM
10702 PARP(82)=0.9D0*PARP(82)
10703 VINT(149)=4D0*PARP(82)**2/VINT(2)
10704 GOTO 100
10705 ENDIF
10706 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) PARP(82), SIGSUM
10707
10708C...Start iteration to find k factor.
10709 YKE=SIGSUM/SIGT(0,0,5)
10710 SO=0.5D0
10711 XI=0D0
10712 YI=0D0
10713 XF=0D0
10714 YF=0D0
10715 XK=0.5D0
10716 IIT=0
10717 130 IF(IIT.EQ.0) THEN
10718 XK=2D0*XK
10719 ELSEIF(IIT.EQ.1) THEN
10720 XK=0.5D0*XK
10721 ELSE
10722 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
10723 ENDIF
10724
10725C...Evaluate overlap integrals.
10726 IF(MSTP(82).EQ.2) THEN
10727 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
10728 SOP=SP/PARU(1)
10729 ELSE
10730 IF(MSTP(82).EQ.3) DELTAB=0.02D0
10731 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
10732 SP=0D0
10733 SOP=0D0
10734 B=-0.5D0*DELTAB
10735 140 B=B+DELTAB
10736 IF(MSTP(82).EQ.3) THEN
10737 OV=EXP(-B**2)/PARU(2)
10738 ELSE
10739 CQ2=PARP(84)**2
10740 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
10741 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
10742 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
10743 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
10744 ENDIF
10745 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
10746 SP=SP+PARU(2)*B*DELTAB*PACC
10747 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
10748 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
10749 ENDIF
10750 YK=PARU(1)*XK*SO/SP
10751
10752C...Continue iteration until convergence.
10753 IF(YK.LT.YKE) THEN
10754 XI=XK
10755 YI=YK
10756 IF(IIT.EQ.1) IIT=2
10757 ELSE
10758 XF=XK
10759 YF=YK
10760 IF(IIT.EQ.0) IIT=1
10761 ENDIF
10762 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
10763
10764C...Store some results for subsequent use.
10765 VINT(145)=SIGSUM
10766 VINT(146)=SOP/SO
10767 VINT(147)=SOP/SP
10768
10769C...Initialize iteration in xT2 for hardest interaction.
10770 ELSEIF(MMUL.EQ.2) THEN
10771 IF(MSTP(82).LE.0) THEN
10772 ELSEIF(MSTP(82).EQ.1) THEN
10773 XT2=1D0
10774 XT2FAC=XSEC(96,1)/SIGT(0,0,5)*VINT(149)/(1D0-VINT(149))
10775 ELSEIF(MSTP(82).EQ.2) THEN
10776 XT2=1D0
10777 XT2FAC=VINT(146)*XSEC(96,1)/SIGT(0,0,5)*VINT(149)*
10778 & (1D0+VINT(149))
10779 ELSE
10780 XC2=4D0*CKIN(3)**2/VINT(2)
10781 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
10782 ENDIF
10783
10784 ELSEIF(MMUL.EQ.3) THEN
10785C...Low-pT or multiple interactions (first semihard interaction):
10786C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
10787C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
10788 ISUB=MINT(1)
10789 IF(MSTP(82).LE.0) THEN
10790 XT2=0D0
10791 ELSEIF(MSTP(82).EQ.1) THEN
10792 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10793 ELSEIF(MSTP(82).EQ.2) THEN
10794 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
10795 & VINT(149)))).GT.PYR(0)) XT2=1D0
10796 IF(XT2.GE.1D0) THEN
10797 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
10798 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
10799 & VINT(149)
10800 ELSE
10801 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
10802 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
10803 & VINT(149)
10804 ENDIF
10805 XT2=MAX(0.01D0*VINT(149),XT2)
10806 ELSE
10807 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
10808 & PYR(0)*(1D0-XC2))-VINT(149)
10809 XT2=MAX(0.01D0*VINT(149),XT2)
10810 ENDIF
10811 VINT(25)=XT2
10812
10813C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
10814 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
10815 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
10816 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
10817 ISUB=95
10818 MINT(1)=ISUB
10819 VINT(21)=0.01D0*VINT(149)
10820 VINT(22)=0D0
10821 VINT(23)=0D0
10822 VINT(25)=0.01D0*VINT(149)
10823
10824 ELSE
10825C...Multiple interactions (first semihard interaction).
10826C...Choose tau and y*. Calculate cos(theta-hat).
10827 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10828 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10829 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10830 ELSE
10831 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10832 ENDIF
10833 VINT(21)=TAU
10834 CALL PYKLIM(2)
10835 RYST=PYR(0)
10836 MYST=1
10837 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10838 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10839 CALL PYKMAP(2,MYST,PYR(0))
10840 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10841 ENDIF
10842 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
10843
10844C...Store results of cross-section calculation.
10845 ELSEIF(MMUL.EQ.4) THEN
10846 ISUB=MINT(1)
10847 XTS=VINT(25)
10848 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
10849 IF(ISET(ISUB).EQ.2)
10850 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10851 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
10852 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
10853 & (XTS+VINT(149))))
10854 IRBIN=INT(1D0+20D0*RBIN)
10855 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
10856 NMUL(IRBIN)=NMUL(IRBIN)+1
10857 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
10858 ENDIF
10859
10860C...Choose impact parameter.
10861 ELSEIF(MMUL.EQ.5) THEN
10862 IF(MSTP(82).EQ.3) THEN
10863 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
10864 ELSE
10865 RTYPE=PYR(0)
10866 CQ2=PARP(84)**2
10867 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
10868 B2=-LOG(PYR(0))
10869 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
10870 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
10871 ELSE
10872 B2=-CQ2*LOG(PYR(0))
10873 ENDIF
10874 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
10875 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
10876 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
10877 ENDIF
10878
10879C...Multiple interactions (variable impact parameter) : reject with
10880C...probability exp(-overlap*cross-section above pT/normalization).
10881 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
10882 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
10883 DO 150 IBIN=IRBIN+1,20
10884 RNCOR=RNCOR+NMUL(IBIN)
10885 SIGCOR=SIGCOR+SIGM(IBIN)
10886 150 CONTINUE
10887 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
10888 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
10889 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
10890 & SIGABV/SIGT(0,0,5)))
10891
10892C...Generate additional multiple semihard interactions.
10893 ELSEIF(MMUL.EQ.6) THEN
10894 ISUBSV=MINT(1)
10895 DO 160 J=11,80
10896 VINTSV(J)=VINT(J)
10897 160 CONTINUE
10898 ISUB=96
10899 MINT(1)=96
10900
10901C...Reconstruct strings in hard scattering.
10902 NMAX=MINT(84)+4
10903 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
10904 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
10905 NSTR=0
10906 DO 180 I=MINT(84)+1,NMAX
10907 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
10908 IF(KCS.EQ.0) GOTO 180
10909
10910 DO 170 J=1,4
10911 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
10912 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
10913 IF(J.LE.2) THEN
10914 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
10915 ELSE
10916 IST=MOD(K(I,J+1),MSTU(5))
10917 ENDIF
10918 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
10919 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
10920 NSTR=NSTR+1
10921 IF(J.EQ.1.OR.J.EQ.4) THEN
10922 KSTR(NSTR,1)=I
10923 KSTR(NSTR,2)=IST
10924 ELSE
10925 KSTR(NSTR,1)=IST
10926 KSTR(NSTR,2)=I
10927 ENDIF
10928 170 CONTINUE
10929 180 CONTINUE
10930
10931C...Set up starting values for iteration in xT2.
10932 XT2=VINT(25)
10933 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
10934 IF(ISET(ISUBSV).EQ.2)
10935 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10936 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
10937 IF(MSTP(82).LE.1) THEN
10938 XT2FAC=XSEC(ISUB,1)*VINT(149)/((1D0-VINT(149))*SIGT(0,0,5))
10939 ELSE
10940 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/SIGT(0,0,5)*
10941 & VINT(149)*(1D0+VINT(149))
10942 ENDIF
10943 VINT(63)=0D0
10944 VINT(64)=0D0
10945 VINT(143)=1D0-VINT(141)
10946 VINT(144)=1D0-VINT(142)
10947
10948C...Iterate downwards in xT2.
10949 190 IF(MSTP(82).LE.1) THEN
10950 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10951 IF(XT2.LT.VINT(149)) GOTO 240
10952 ELSE
10953 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
10954 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
10955 & LOG(PYR(0)))-VINT(149)
10956 IF(XT2.LE.0D0) GOTO 240
10957 XT2=MAX(0.01D0*VINT(149),XT2)
10958 ENDIF
10959 VINT(25)=XT2
10960
10961C...Choose tau and y*. Calculate cos(theta-hat).
10962 IF(PYR(0).LE.COEF(ISUB,1)) THEN
10963 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10964 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10965 ELSE
10966 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10967 ENDIF
10968 VINT(21)=TAU
10969 CALL PYKLIM(2)
10970 RYST=PYR(0)
10971 MYST=1
10972 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10973 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10974 CALL PYKMAP(2,MYST,PYR(0))
10975 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10976
10977C...Check that x not used up. Accept or reject kinematical variables.
10978 X1M=SQRT(TAU)*EXP(VINT(22))
10979 X2M=SQRT(TAU)*EXP(-VINT(22))
10980 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
10981 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10982 CALL PYSIGH(NCHN,SIGS)
10983 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
10984
10985C...Reset K, P and V vectors. Select some variables.
10986 DO 210 I=N+1,N+2
10987 DO 200 J=1,5
10988 K(I,J)=0
10989 P(I,J)=0D0
10990 V(I,J)=0D0
10991 200 CONTINUE
10992 210 CONTINUE
10993 RFLAV=PYR(0)
10994 PT=0.5D0*VINT(1)*SQRT(XT2)
10995 PHI=PARU(2)*PYR(0)
10996 CTH=VINT(23)
10997
10998C...Add first parton to event record.
10999 K(N+1,1)=3
11000 K(N+1,2)=21
11001 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
11002 & 1+INT((2D0+PARJ(2))*PYR(0))
11003 P(N+1,1)=PT*COS(PHI)
11004 P(N+1,2)=PT*SIN(PHI)
11005 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
11006 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
11007 P(N+1,5)=0D0
11008
11009C...Add second parton to event record.
11010 K(N+2,1)=3
11011 K(N+2,2)=21
11012 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
11013 P(N+2,1)=-P(N+1,1)
11014 P(N+2,2)=-P(N+1,2)
11015 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
11016 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
11017 P(N+2,5)=0D0
11018
11019 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
11020C....Choose relevant string pieces to place gluons on.
11021 DO 230 I=N+1,N+2
11022 DMIN=1D8
11023 DO 220 ISTR=1,NSTR
11024 I1=KSTR(ISTR,1)
11025 I2=KSTR(ISTR,2)
11026 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
11027 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
11028 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
11029 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
11030 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
11031 DMIN=DIST
11032 IST1=I1
11033 IST2=I2
11034 ISTM=ISTR
11035 ENDIF
11036 220 CONTINUE
11037
11038C....Colour flow adjustments, new string pieces.
11039 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
11040 & MOD(K(IST1,4),MSTU(5))
11041 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
11042 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
11043 K(I,5)=MSTU(5)*IST1
11044 K(I,4)=MSTU(5)*IST2
11045 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
11046 & MOD(K(IST2,5),MSTU(5))
11047 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
11048 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
11049 KSTR(ISTM,2)=I
11050 KSTR(NSTR+1,1)=I
11051 KSTR(NSTR+1,2)=IST2
11052 NSTR=NSTR+1
11053 230 CONTINUE
11054
11055C...String drawing and colour flow for gluon loop.
11056 ELSEIF(K(N+1,2).EQ.21) THEN
11057 K(N+1,4)=MSTU(5)*(N+2)
11058 K(N+1,5)=MSTU(5)*(N+2)
11059 K(N+2,4)=MSTU(5)*(N+1)
11060 K(N+2,5)=MSTU(5)*(N+1)
11061 KSTR(NSTR+1,1)=N+1
11062 KSTR(NSTR+1,2)=N+2
11063 KSTR(NSTR+2,1)=N+2
11064 KSTR(NSTR+2,2)=N+1
11065 NSTR=NSTR+2
11066
11067C...String drawing and colour flow for qqbar pair.
11068 ELSE
11069 K(N+1,4)=MSTU(5)*(N+2)
11070 K(N+2,5)=MSTU(5)*(N+1)
11071 KSTR(NSTR+1,1)=N+1
11072 KSTR(NSTR+1,2)=N+2
11073 NSTR=NSTR+1
11074 ENDIF
11075
11076C...Update remaining energy; iterate.
11077 N=N+2
11078 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11079 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
11080 IF(MSTU(21).GE.1) RETURN
11081 ENDIF
11082 MINT(31)=MINT(31)+1
11083 VINT(151)=VINT(151)+VINT(41)
11084 VINT(152)=VINT(152)+VINT(42)
11085 VINT(143)=VINT(143)-VINT(41)
11086 VINT(144)=VINT(144)-VINT(42)
11087 IF(MINT(31).LT.240) GOTO 190
11088 240 CONTINUE
11089 MINT(1)=ISUBSV
11090 DO 250 J=11,80
11091 VINT(J)=VINTSV(J)
11092 250 CONTINUE
11093 ENDIF
11094
11095C...Format statements for printout.
11096 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
11097 &'actions for MSTP(82) =',I2,' ******')
11098 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11099 &D9.2,' mb: rejected')
11100 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11101 &D9.2,' mb: accepted')
11102
11103 RETURN
11104 END
11105
11106C*********************************************************************
11107
11108*$ CREATE PYREMN.FOR
11109*COPY PYREMN
11110C...PYREMN
11111C...Adds on target remnants (one or two from each side) and
11112C...includes primordial kT for hadron beams.
11113
11114 SUBROUTINE PYREMN(IPU1,IPU2)
11115
11116C...Double precision and integer declarations.
11117 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11118 INTEGER PYK,PYCHGE,PYCOMP
11119C...Commonblocks.
11120 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11121 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11122 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11123 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11124 COMMON/PYINT1/MINT(400),VINT(400)
11125 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
11126C...Local arrays.
11127 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
11128 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
11129
11130C...Find event type and remaining energy.
11131 ISUB=MINT(1)
11132 NS=N
11133 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
11134 VINT(143)=1D0-VINT(141)
11135 VINT(144)=1D0-VINT(142)
11136 ENDIF
11137
11138C...Define initial partons.
11139 NTRY=0
11140 100 NTRY=NTRY+1
11141 DO 130 JT=1,2
11142 I=MINT(83)+JT+2
11143 IF(JT.EQ.1) IPU=IPU1
11144 IF(JT.EQ.2) IPU=IPU2
11145 K(I,1)=21
11146 K(I,2)=K(IPU,2)
11147 K(I,3)=I-2
11148 PMS(JT)=0D0
11149 VINT(156+JT)=0D0
11150 VINT(158+JT)=0D0
11151 IF(MINT(47).EQ.1) THEN
11152 DO 110 J=1,5
11153 P(I,J)=P(I-2,J)
11154 110 CONTINUE
11155 ELSEIF(ISUB.EQ.95) THEN
11156 K(I,2)=21
11157 ELSE
11158 P(I,5)=P(IPU,5)
11159
11160C...No primordial kT, or chosen according to truncated Gaussian or
11161C...exponential, or (for photon) predetermined or power law.
11162 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
11163 IF(MSTP(91).LE.0) THEN
11164 PT=0D0
11165 ELSEIF(MSTP(91).EQ.1) THEN
11166 PT=PARP(91)*SQRT(-LOG(PYR(0)))
11167 ELSE
11168 RPT1=PYR(0)
11169 RPT2=PYR(0)
11170 PT=-PARP(92)*LOG(RPT1*RPT2)
11171 ENDIF
11172 IF(PT.GT.PARP(93)) GOTO 120
11173 ELSEIF(MINT(106+JT).EQ.3) THEN
11174 PT=SQRT(VINT(282+JT))
11175 PT=PT*0.8D0**MINT(57)
11176 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
11177 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
11178 IF(MSTP(93).LE.0) THEN
11179 PT=0D0
11180 ELSEIF(MSTP(93).EQ.1) THEN
11181 PT=PARP(99)*SQRT(-LOG(PYR(0)))
11182 ELSEIF(MSTP(93).EQ.2) THEN
11183 RPT1=PYR(0)
11184 RPT2=PYR(0)
11185 PT=-PARP(99)*LOG(RPT1*RPT2)
11186 ELSEIF(MSTP(93).EQ.3) THEN
11187 HA=PARP(99)**2
11188 HB=PARP(100)**2
11189 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
11190 ELSE
11191 HA=PARP(99)**2
11192 HB=PARP(100)**2
11193 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
11194 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
11195 ENDIF
11196 IF(PT.GT.PARP(100)) GOTO 120
11197 ELSE
11198 PT=0D0
11199 ENDIF
11200 VINT(156+JT)=PT
11201 PHI=PARU(2)*PYR(0)
11202 P(I,1)=PT*COS(PHI)
11203 P(I,2)=PT*SIN(PHI)
11204 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11205 ENDIF
11206 130 CONTINUE
11207 IF(MINT(47).EQ.1) RETURN
11208
11209C...Kinematics construction for initial partons.
11210 I1=MINT(83)+3
11211 I2=MINT(83)+4
11212 IF(ISUB.EQ.95) THEN
11213 SHS=0D0
11214 SHR=0D0
11215 ELSE
11216 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
11217 & (P(I1,2)+P(I2,2))**2
11218 SHR=SQRT(MAX(0D0,SHS))
11219 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
11220 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
11221 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
11222 P(I2,4)=SHR-P(I1,4)
11223 P(I2,3)=-P(I1,3)
11224
11225C...Transform partons to overall CM-frame.
11226 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
11227 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
11228 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
11229 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
11230 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
11231 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
11232 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
11233 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
11234 ROBO(5)=MAX(-0.999999D0,MIN(0.999999D0,(VINT(141)-VINT(142))/
11235 & (VINT(141)+VINT(142))))
11236 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
11237 ENDIF
11238
11239C...Optionally fix up x and Q2 definitions for leptoproduction.
11240 IDISXQ=0
11241 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
11242 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
11243 IF(IDISXQ.EQ.1) THEN
11244
11245C...Find where incoming and outgoing leptons/partons are sitting.
11246 LESD=1
11247 IF(MINT(42).EQ.1) LESD=2
11248 LPIN=MINT(83)+3-LESD
11249 LEIN=MINT(84)+LESD
11250 LQIN=MINT(84)+3-LESD
11251 LEOUT=MINT(84)+2+LESD
11252 LQOUT=MINT(84)+5-LESD
11253 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
11254 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
11255 LSCMS=0
11256 DO 140 I=MINT(84)+5,N
11257 IF(K(I,2).EQ.94) THEN
11258 LSCMS=I
11259 LEOUT=I+LESD
11260 LQOUT=I+3-LESD
11261 ENDIF
11262 140 CONTINUE
11263 LQBG=IPU1
11264 IF(LESD.EQ.1) LQBG=IPU2
11265
11266C...Calculate actual and wanted momentum transfer.
11267 XNOM=VINT(43-LESD)
11268 Q2NOM=-VINT(45)
11269 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
11270 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
11271 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
11272 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
11273 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
11274 P(N+1,1)=FAC*P(LEOUT,1)
11275 P(N+1,2)=FAC*P(LEOUT,2)
11276 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
11277 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
11278 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
11279 & P(N+1,3)**2)
11280 DO 150 J=1,4
11281 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
11282 QNEW(J)=P(LEIN,J)-P(N+1,J)
11283 150 CONTINUE
11284
11285C...Boost outgoing electron and daughters.
11286 IF(LSCMS.EQ.0) THEN
11287 DO 160 J=1,4
11288 P(LEOUT,J)=P(N+1,J)
11289 160 CONTINUE
11290 ELSE
11291 DO 170 J=1,3
11292 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
11293 170 CONTINUE
11294 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
11295 DO 180 J=1,3
11296 DBE(J)=PINV*P(N+2,J)
11297 180 CONTINUE
11298 DO 200 I=LSCMS+1,N
11299 IORIG=I
11300 190 IORIG=K(IORIG,3)
11301 IF(IORIG.GT.LEOUT) GOTO 190
11302 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
11303 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
11304 200 CONTINUE
11305 ENDIF
11306
11307C...Copy shower initiator and all outgoing partons.
11308 NCOP=N+1
11309 K(NCOP,3)=LQBG
11310 DO 210 J=1,5
11311 P(NCOP,J)=P(LQBG,J)
11312 210 CONTINUE
11313 DO 240 I=MINT(84)+1,N
11314 ICOP=0
11315 IF(K(I,1).GT.10) GOTO 240
11316 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
11317 ICOP=I
11318 ELSE
11319 IORIG=I
11320 220 IORIG=K(IORIG,3)
11321 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
11322 ICOP=IORIG
11323 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
11324 GOTO 220
11325 ENDIF
11326 ENDIF
11327 IF(ICOP.NE.0) THEN
11328 NCOP=NCOP+1
11329 K(NCOP,3)=I
11330 DO 230 J=1,5
11331 P(NCOP,J)=P(I,J)
11332 230 CONTINUE
11333 ENDIF
11334 240 CONTINUE
11335
11336C...Calculate relative rescaling factors.
11337 SLC=3-2*LESD
11338 PLCSUM=0D0
11339 DO 250 I=N+2,NCOP
11340 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
11341 250 CONTINUE
11342 DO 260 I=N+2,NCOP
11343 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
11344 260 CONTINUE
11345
11346C...Transfer extra three-momentum of current.
11347 DO 280 I=N+2,NCOP
11348 DO 270 J=1,3
11349 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
11350 270 CONTINUE
11351 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11352 280 CONTINUE
11353
11354C...Iterate change of initiator momentum to get energy right.
11355 ITER=0
11356 290 ITER=ITER+1
11357 PEEX=-P(N+1,4)-QNEW(4)
11358 PEMV=-P(N+1,3)/P(N+1,4)
11359 DO 300 I=N+2,NCOP
11360 PEEX=PEEX+P(I,4)
11361 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
11362 300 CONTINUE
11363 IF(ABS(PEMV).LT.1D-10) THEN
11364 MINT(51)=1
11365 MINT(57)=MINT(57)+1
11366 RETURN
11367 ENDIF
11368 PZCH=-PEEX/PEMV
11369 P(N+1,3)=P(N+1,3)+PZCH
11370 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)
11371 DO 310 I=N+2,NCOP
11372 P(I,3)=P(I,3)+V(I,1)*PZCH
11373 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11374 310 CONTINUE
11375 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
11376
11377C...Modify momenta in event record.
11378 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
11379 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
11380 IF(ABS(HBE).GT.0.999999D0) THEN
11381 MINT(51)=1
11382 MINT(57)=MINT(57)+1
11383 RETURN
11384 ENDIF
11385 I=MINT(83)+5-LESD
11386 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
11387 DO 330 I=N+1,NCOP
11388 ICOP=K(I,3)
11389 DO 320 J=1,4
11390 P(ICOP,J)=P(I,J)
11391 320 CONTINUE
11392 330 CONTINUE
11393 ENDIF
11394
11395C...Check minimum invariant mass of remnant system(s).
11396 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
11397 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
11398 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11399 PMIN(0)=SQRT(PMS(0))
11400 DO 340 JT=1,2
11401 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
11402 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
11403 PMIN(JT)=0D0
11404 IF(MINT(44+JT).EQ.1) GOTO 340
11405 MINT(105)=MINT(102+JT)
11406 MINT(109)=MINT(106+JT)
11407 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
11408 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
11409 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
11410 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
11411 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
11412 & P(MINT(83)+JT+2,2)**2)
11413 340 CONTINUE
11414 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
11415 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
11416 &PSYS(2,4))) THEN
11417 MINT(51)=1
11418 MINT(57)=MINT(57)+1
11419 RETURN
11420 ENDIF
11421
11422C...Loop over two remnants; skip if none there.
11423 I=NS
11424 DO 410 JT=1,2
11425 ISN(JT)=0
11426 IF(MINT(44+JT).EQ.1) GOTO 410
11427 IF(JT.EQ.1) IPU=IPU1
11428 IF(JT.EQ.2) IPU=IPU2
11429
11430C...Store first remnant parton.
11431 I=I+1
11432 IS(JT)=I
11433 ISN(JT)=1
11434 DO 350 J=1,5
11435 K(I,J)=0
11436 P(I,J)=0D0
11437 V(I,J)=0D0
11438 350 CONTINUE
11439 K(I,1)=1
11440 K(I,2)=KFLSP(JT)
11441 K(I,3)=MINT(83)+JT
11442 P(I,5)=PYMASS(K(I,2))
11443
11444C...First parton colour connections and kinematics.
11445 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
11446 IF(KCOL.EQ.2) THEN
11447 K(I,1)=3
11448 K(I,4)=MSTU(5)*IPU+IPU
11449 K(I,5)=MSTU(5)*IPU+IPU
11450 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11451 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11452 ELSEIF(KCOL.NE.0) THEN
11453 K(I,1)=3
11454 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
11455 K(I,KFLS+3)=IPU
11456 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11457 ENDIF
11458 IF(KFLCH(JT).EQ.0) THEN
11459 P(I,1)=-P(MINT(83)+JT+2,1)
11460 P(I,2)=-P(MINT(83)+JT+2,2)
11461 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11462 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11463 P(I,3)=PSYS(JT,3)
11464 P(I,4)=PSYS(JT,4)
11465
11466C...When extra remnant parton or hadron: store extra remnant.
11467 ELSE
11468 I=I+1
11469 ISN(JT)=2
11470 DO 360 J=1,5
11471 K(I,J)=0
11472 P(I,J)=0D0
11473 V(I,J)=0D0
11474 360 CONTINUE
11475 K(I,1)=1
11476 K(I,2)=KFLCH(JT)
11477 K(I,3)=MINT(83)+JT
11478 P(I,5)=PYMASS(K(I,2))
11479
11480C...Find parton colour connections of extra remnant.
11481 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
11482 IF(KCOL.EQ.2) THEN
11483 K(I,1)=3
11484 K(I,4)=MSTU(5)*IPU+IPU
11485 K(I,5)=MSTU(5)*IPU+IPU
11486 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11487 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11488 ELSEIF(KCOL.NE.0) THEN
11489 K(I,1)=3
11490 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
11491 K(I,KFLS+3)=IPU
11492 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11493 ENDIF
11494
11495C...Relative transverse momentum when two remnants.
11496 LOOP=0
11497 370 LOOP=LOOP+1
11498 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
11499 IF(IABS(MINT(10+JT)).LT.20) THEN
11500 P(I-1,1)=0D0
11501 P(I-1,2)=0D0
11502 ENDIF
11503 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
11504 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
11505 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
11506 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11507
11508C...Meson or baryon; photon as meson. For splitup below.
11509 IMB=1
11510 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
11511
11512C***Relative distribution for electron into two electrons. Temporary!
11513 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
11514 & THEN
11515 CHI(JT)=PYR(0)
11516
11517C...Relative distribution of electron energy into electron plus parton.
11518 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
11519 XHRD=VINT(140+JT)
11520 XE=VINT(154+JT)
11521 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
11522
11523C...Relative distribution of energy for particle into two jets.
11524 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
11525 CHIK=PARP(92+2*IMB)
11526 IF(MSTP(92).LE.1) THEN
11527 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11528 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11529 ELSEIF(MSTP(92).EQ.2) THEN
11530 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
11531 ELSEIF(MSTP(92).EQ.3) THEN
11532 CUT=2D0*0.3D0/VINT(1)
11533 380 CHI(JT)=PYR(0)**2
11534 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
11535 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
11536 ELSEIF(MSTP(92).EQ.4) THEN
11537 CUT=2D0*0.3D0/VINT(1)
11538 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11539 390 CHIR=CUT*CUTR**PYR(0)
11540 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
11541 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
11542 ELSE
11543 CUT=2D0*0.3D0/VINT(1)
11544 CUTA=CUT**(1D0-PARP(98))
11545 CUTB=(1D0+CUT)**(1D0-PARP(98))
11546 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11547 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
11548 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
11549 ENDIF
11550
11551C...Relative distribution of energy for particle into jet plus particle.
11552 ELSE
11553 IF(MSTP(94).LE.1) THEN
11554 IF(IMB.EQ.1) CHI(JT)=PYR(0)
11555 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11556 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11557 ELSEIF(MSTP(94).EQ.2) THEN
11558 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
11559 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11560 ELSEIF(MSTP(94).EQ.3) THEN
11561 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
11562 CHI(JT)=ZZ
11563 ELSE
11564 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
11565 CHI(JT)=ZZ
11566 ENDIF
11567 ENDIF
11568
11569C...Construct total transverse mass; reject if too large.
11570 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
11571 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
11572 IF(LOOP.LT.10) THEN
11573 GOTO 370
11574 ELSE
11575 MINT(51)=1
11576 MINT(57)=MINT(57)+1
11577 RETURN
11578 ENDIF
11579 ENDIF
11580 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11581 VINT(158+JT)=CHI(JT)
11582
11583C...Subdivide longitudinal momentum according to value selected above.
11584 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
11585 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
11586 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
11587 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
11588 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
11589 ENDIF
11590 410 CONTINUE
11591 N=I
11592
11593C...Check if longitudinal boosts needed - if so pick two systems.
11594 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
11595 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
11596 IF(PDEV.LE.1D-6*VINT(1)) RETURN
11597 IF(ISN(1).EQ.0) THEN
11598 IR=0
11599 IL=2
11600 ELSEIF(ISN(2).EQ.0) THEN
11601 IR=1
11602 IL=0
11603 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
11604 IR=1
11605 IL=2
11606 ELSEIF(VINT(143).GT.0.2D0) THEN
11607 IR=1
11608 IL=0
11609 ELSEIF(VINT(144).GT.0.2D0) THEN
11610 IR=0
11611 IL=2
11612 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
11613 IR=1
11614 IL=0
11615 ELSE
11616 IR=0
11617 IL=2
11618 ENDIF
11619 IG=3-IR-IL
11620
11621C...E+-pL wanted for system to be modified.
11622 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
11623 PPB=VINT(1)
11624 PNB=VINT(1)
11625 ELSE
11626 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
11627 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
11628 ENDIF
11629
11630C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
11631 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
11632 PMTB=PPB*PNB
11633 PMTR=PMS(IR)
11634 PMTL=PMS(IL)
11635 SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
11636 SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11637 RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
11638 & *PNB)
11639 RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
11640 & *PPB)
11641 BER=(RKR**2-1D0)/(RKR**2+1D0)
11642 BEL=-(RKL**2-1D0)/(RKL**2+1D0)
11643 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
11644 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
11645 DO 420 J=1,4
11646 PSYS(0,J)=0D0
11647 420 CONTINUE
11648 DO 450 I=MINT(84)+1,NS
11649 IF(K(I,1).GT.10) GOTO 450
11650 INCL=0
11651 IORIG=I
11652 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11653 IORIG=K(IORIG,3)
11654 IF(IORIG.GT.LPIN) GOTO 430
11655 IF(INCL.EQ.0) GOTO 450
11656 DO 440 J=1,4
11657 PSYS(0,J)=PSYS(0,J)+P(I,J)
11658 440 CONTINUE
11659 450 CONTINUE
11660 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11661 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
11662 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
11663 ENDIF
11664
11665C...Construct longitudinal boosts.
11666 DPMTB=PPB*PNB
11667 DPMTR=PMS(IR)
11668 DPMTL=PMS(IL)
11669 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
11670 IF(DSQLAM.LE.1D-6*DPMTB) THEN
11671 MINT(51)=1
11672 MINT(57)=MINT(57)+1
11673 RETURN
11674 ENDIF
11675 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11676 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
11677 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
11678 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
11679 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
11680 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
11681 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
11682
11683C...Perform longitudinal boosts.
11684 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
11685 P(IS(1),3)=0D0
11686 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
11687 ELSEIF(IR.EQ.1) THEN
11688 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
11689 ELSEIF(IDISXQ.EQ.1) THEN
11690 DO 470 I=I1,NS
11691 INCL=0
11692 IORIG=I
11693 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11694 IORIG=K(IORIG,3)
11695 IF(IORIG.GT.LPIN) GOTO 460
11696 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
11697 470 CONTINUE
11698 ELSE
11699 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
11700 ENDIF
11701 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
11702 P(IS(2),3)=0D0
11703 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
11704 ELSEIF(IL.EQ.2) THEN
11705 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
11706 ELSEIF(IDISXQ.EQ.1) THEN
11707 DO 490 I=I1,NS
11708 INCL=0
11709 IORIG=I
11710 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11711 IORIG=K(IORIG,3)
11712 IF(IORIG.GT.LPIN) GOTO 480
11713 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
11714 490 CONTINUE
11715 ELSE
11716 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
11717 ENDIF
11718
11719C...Final check that energy-momentum conservation worked.
11720 PESUM=0D0
11721 PZSUM=0D0
11722 DO 500 I=MINT(84)+1,N
11723 IF(K(I,1).GT.10) GOTO 500
11724 PESUM=PESUM+P(I,4)
11725 PZSUM=PZSUM+P(I,3)
11726 500 CONTINUE
11727 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
11728 IF(PDEV.GT.1D-4*VINT(1)) THEN
11729 MINT(51)=1
11730 MINT(57)=MINT(57)+1
11731 RETURN
11732 ENDIF
11733
11734C...Calculate rotation and boost from overall CM frame to
11735C...hadronic CM frame in leptoproduction.
11736 MINT(91)=0
11737 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
11738 MINT(91)=1
11739 LESD=1
11740 IF(MINT(42).EQ.1) LESD=2
11741 LPIN=MINT(83)+3-LESD
11742
11743C...Sum upp momenta of everything not lepton or photon to define boost.
11744 DO 510 J=1,4
11745 PSUM(J)=0D0
11746 510 CONTINUE
11747 DO 530 I=1,N
11748 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
11749 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
11750 IF(K(I,2).EQ.22) GOTO 530
11751 DO 520 J=1,4
11752 PSUM(J)=PSUM(J)+P(I,J)
11753 520 CONTINUE
11754 530 CONTINUE
11755 VINT(223)=-PSUM(1)/PSUM(4)
11756 VINT(224)=-PSUM(2)/PSUM(4)
11757 VINT(225)=-PSUM(3)/PSUM(4)
11758
11759C...Boost incoming hadron to hadronic CM frame to determine rotations.
11760 K(N+1,1)=1
11761 DO 540 J=1,5
11762 P(N+1,J)=P(LPIN,J)
11763 V(N+1,J)=V(LPIN,J)
11764 540 CONTINUE
11765 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
11766 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
11767 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
11768 IF(LESD.EQ.2) THEN
11769 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
11770 ELSE
11771 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
11772 ENDIF
11773 ENDIF
11774
11775 RETURN
11776 END
11777
11778C*********************************************************************
11779
11780*$ CREATE PYDIFF.FOR
11781*COPY PYDIFF
11782C...PYDIFF
11783C...Handles diffractive and elastic scattering.
11784
11785 SUBROUTINE PYDIFF
11786
11787C...Double precision and integer declarations.
11788 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11789 INTEGER PYK,PYCHGE,PYCOMP
11790C...Commonblocks.
11791 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11792 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11793 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11794 COMMON/PYINT1/MINT(400),VINT(400)
11795 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11796
11797C...Reset K, P and V vectors. Store incoming particles.
11798 DO 110 JT=1,MSTP(126)+10
11799 I=MINT(83)+JT
11800 DO 100 J=1,5
11801 K(I,J)=0
11802 P(I,J)=0D0
11803 V(I,J)=0D0
11804 100 CONTINUE
11805 110 CONTINUE
11806 N=MINT(84)
11807 MINT(3)=0
11808 MINT(21)=0
11809 MINT(22)=0
11810 MINT(23)=0
11811 MINT(24)=0
11812 MINT(4)=4
11813 DO 130 JT=1,2
11814 I=MINT(83)+JT
11815 K(I,1)=21
11816 K(I,2)=MINT(10+JT)
11817 DO 120 J=1,5
11818 P(I,J)=VINT(285+5*JT+J)
11819 120 CONTINUE
11820 130 CONTINUE
11821 MINT(6)=2
11822
11823C...Subprocess; kinematics.
11824 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
11825 PZ=SQRT(SQLAM)/(2D0*VINT(1))
11826 DO 200 JT=1,2
11827 I=MINT(83)+JT
11828 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
11829 KFH=MINT(102+JT)
11830
11831C...Elastically scattered particle.
11832 IF(MINT(16+JT).LE.0) THEN
11833 N=N+1
11834 K(N,1)=1
11835 K(N,2)=KFH
11836 K(N,3)=I+2
11837 P(N,3)=PZ*(-1)**(JT+1)
11838 P(N,4)=PE
11839 P(N,5)=SQRT(VINT(62+JT))
11840
11841C...Decay rho from elastic scattering of gamma with sin**2(theta)
11842C...distribution of decay products (in rho rest frame).
11843 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
11844 NSAV=N
11845 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
11846 P(N,3)=0D0
11847 P(N,4)=P(N,5)
11848 CALL PYDECY(NSAV)
11849 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
11850 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
11851 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
11852 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
11853 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
11854 140 CTHE=2D0*PYR(0)-1D0
11855 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
11856 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
11857 ENDIF
11858 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
11859 ENDIF
11860
11861C...Diffracted particle: low-mass system to two particles.
11862 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
11863 N=N+2
11864 K(N-1,1)=1
11865 K(N,1)=1
11866 K(N-1,3)=I+2
11867 K(N,3)=I+2
11868 PMMAS=SQRT(VINT(62+JT))
11869 NTRY=0
11870 150 NTRY=NTRY+1
11871 IF(NTRY.LT.20) THEN
11872 MINT(105)=MINT(102+JT)
11873 MINT(109)=MINT(106+JT)
11874 CALL PYSPLI(KFH,21,KFL1,KFL2)
11875 CALL PYKFDI(KFL1,0,KFL3,KF1)
11876 IF(KF1.EQ.0) GOTO 150
11877 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
11878 IF(KF2.EQ.0) GOTO 150
11879 ELSE
11880 KF1=KFH
11881 KF2=111
11882 ENDIF
11883 PM1=PYMASS(KF1)
11884 PM2=PYMASS(KF2)
11885 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
11886 K(N-1,2)=KF1
11887 K(N,2)=KF2
11888 P(N-1,5)=PM1
11889 P(N,5)=PM2
11890 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
11891 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
11892 P(N-1,3)=PZP
11893 P(N,3)=-PZP
11894 P(N-1,4)=SQRT(PM1**2+PZP**2)
11895 P(N,4)=SQRT(PM2**2+PZP**2)
11896 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
11897 & 0D0,0D0,0D0)
11898 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
11899 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
11900
11901C...Diffracted particle: valence quark kicked out.
11902 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
11903 & PARP(101))) THEN
11904 N=N+2
11905 K(N-1,1)=2
11906 K(N,1)=1
11907 K(N-1,3)=I+2
11908 K(N,3)=I+2
11909 MINT(105)=MINT(102+JT)
11910 MINT(109)=MINT(106+JT)
11911 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
11912 P(N-1,5)=PYMASS(K(N-1,2))
11913 P(N,5)=PYMASS(K(N,2))
11914 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
11915 & 4D0*P(N-1,5)**2*P(N,5)**2
11916 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
11917 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
11918 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
11919 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
11920 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11921
11922C...Diffracted particle: gluon kicked out.
11923 ELSE
11924 N=N+3
11925 K(N-2,1)=2
11926 K(N-1,1)=2
11927 K(N,1)=1
11928 K(N-2,3)=I+2
11929 K(N-1,3)=I+2
11930 K(N,3)=I+2
11931 MINT(105)=MINT(102+JT)
11932 MINT(109)=MINT(106+JT)
11933 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
11934 K(N-1,2)=21
11935 P(N-2,5)=PYMASS(K(N-2,2))
11936 P(N-1,5)=0D0
11937 P(N,5)=PYMASS(K(N,2))
11938C...Energy distribution for particle into two jets.
11939 160 IMB=1
11940 IF(MOD(KFH/1000,10).NE.0) IMB=2
11941 CHIK=PARP(92+2*IMB)
11942 IF(MSTP(92).LE.1) THEN
11943 IF(IMB.EQ.1) CHI=PYR(0)
11944 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
11945 ELSEIF(MSTP(92).EQ.2) THEN
11946 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
11947 ELSEIF(MSTP(92).EQ.3) THEN
11948 CUT=2D0*0.3D0/VINT(1)
11949 170 CHI=PYR(0)**2
11950 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
11951 & PYR(0)) GOTO 170
11952 ELSEIF(MSTP(92).EQ.4) THEN
11953 CUT=2D0*0.3D0/VINT(1)
11954 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11955 180 CHIR=CUT*CUTR**PYR(0)
11956 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
11957 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
11958 ELSE
11959 CUT=2D0*0.3D0/VINT(1)
11960 CUTA=CUT**(1D0-PARP(98))
11961 CUTB=(1D0+CUT)**(1D0-PARP(98))
11962 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11963 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
11964 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
11965 ENDIF
11966 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
11967 & VINT(62+JT)) GOTO 160
11968 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
11969 IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 160
11970 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
11971 & (2D0*VINT(62+JT))
11972 PEI=SQRT(PZI**2+SQM)
11973 PQQP=(1D0-CHI)*(PEI+PZI)
11974 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
11975 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
11976 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
11977 P(N-1,3)=P(N-1,4)*(-1)**JT
11978 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
11979 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11980 ENDIF
11981
11982C...Documentation lines.
11983 K(I+2,1)=21
11984 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
11985 IF(MINT(16+JT).NE.0) K(I+2,2)=10*(KFH/10)
11986 K(I+2,3)=I
11987 P(I+2,3)=PZ*(-1)**(JT+1)
11988 P(I+2,4)=PE
11989 P(I+2,5)=SQRT(VINT(62+JT))
11990 200 CONTINUE
11991
11992C...Rotate outgoing partons/particles using cos(theta).
11993 IF(VINT(23).LT.0.9D0) THEN
11994 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
11995 ELSE
11996 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
11997 ENDIF
11998
11999 RETURN
12000 END
12001
12002C*********************************************************************
12003
12004*$ CREATE PYDOCU.FOR
12005*COPY PYDOCU
12006C...PYDOCU
12007C...Handles the documentation of the process in MSTI and PARI,
12008C...and also computes cross-sections based on accumulated statistics.
12009
12010 SUBROUTINE PYDOCU
12011
12012C...Double precision and integer declarations.
12013 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12014 INTEGER PYK,PYCHGE,PYCOMP
12015C...Commonblocks.
12016 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12017 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12018 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12019 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12020 COMMON/PYINT1/MINT(400),VINT(400)
12021 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12022 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
12023 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
12024 &/PYINT5/
12025
12026C...Calculate Monte Carlo estimates of cross-sections.
12027 ISUB=MINT(1)
12028 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
12029 NGEN(0,3)=NGEN(0,3)+1
12030 XSEC(0,3)=0D0
12031 DO 100 I=1,500
12032 IF(I.EQ.96.OR.I.EQ.97) THEN
12033 XSEC(I,3)=0D0
12034 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
12035 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
12036 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
12037 & DBLE(NGEN(96,2)))
12038 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
12039 XSEC(I,3)=0D0
12040 ELSEIF(NGEN(I,2).EQ.0) THEN
12041 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
12042 & DBLE(NGEN(0,2)))
12043 ELSE
12044 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
12045 & DBLE(NGEN(I,2)))
12046 ENDIF
12047 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
12048 100 CONTINUE
12049
12050C...Rescale to known low-pT cross-section for standard QCD processes.
12051 IF(MSUB(95).EQ.1) THEN
12052 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
12053 & XSEC(68,3)+XSEC(95,3)
12054 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
12055 IF(XSECH.GT.1D-10.AND.XSECW.GT.1D-10) THEN
12056 FAC=XSECW/XSECH
12057 XSEC(11,3)=FAC*XSEC(11,3)
12058 XSEC(12,3)=FAC*XSEC(12,3)
12059 XSEC(13,3)=FAC*XSEC(13,3)
12060 XSEC(28,3)=FAC*XSEC(28,3)
12061 XSEC(53,3)=FAC*XSEC(53,3)
12062 XSEC(68,3)=FAC*XSEC(68,3)
12063 XSEC(95,3)=FAC*XSEC(95,3)
12064 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
12065 ENDIF
12066 ENDIF
12067
12068C...Save information for gamma-p and gamma-gamma.
12069 IF(MINT(121).GT.1) THEN
12070 IGA=MINT(122)
12071 CALL PYSAVE(2,IGA)
12072 CALL PYSAVE(5,0)
12073 ENDIF
12074
12075C...Reset information on hard interaction.
12076 DO 110 J=1,200
12077 MSTI(J)=0
12078 PARI(J)=0D0
12079 110 CONTINUE
12080
12081C...Copy integer valued information from MINT into MSTI.
12082 DO 120 J=1,32
12083 MSTI(J)=MINT(J)
12084 120 CONTINUE
12085 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
12086
12087C...Store cross-section variables in PARI.
12088 PARI(1)=XSEC(0,3)
12089 PARI(2)=XSEC(0,3)/MINT(5)
12090 PARI(9)=VINT(99)
12091 PARI(10)=VINT(100)
12092 VINT(98)=VINT(98)+VINT(100)
12093 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
12094
12095C...Store kinematics variables in PARI.
12096 PARI(11)=VINT(1)
12097 PARI(12)=VINT(2)
12098 IF(ISUB.NE.95) THEN
12099 DO 130 J=13,26
12100 PARI(J)=VINT(30+J)
12101 130 CONTINUE
12102 PARI(31)=VINT(141)
12103 PARI(32)=VINT(142)
12104 PARI(33)=VINT(41)
12105 PARI(34)=VINT(42)
12106 PARI(35)=PARI(33)-PARI(34)
12107 PARI(36)=VINT(21)
12108 PARI(37)=VINT(22)
12109 PARI(38)=VINT(26)
12110 PARI(39)=VINT(157)
12111 PARI(40)=VINT(158)
12112 PARI(41)=VINT(23)
12113 PARI(42)=2D0*VINT(47)/VINT(1)
12114 ENDIF
12115
12116C...Store information on scattered partons in PARI.
12117 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
12118 DO 140 IS=7,8
12119 I=MINT(IS)
12120 PARI(36+IS)=P(I,3)/VINT(1)
12121 PARI(38+IS)=P(I,4)/VINT(1)
12122 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
12123 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12124 & SQRT(PR),1D20)),P(I,3))
12125 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
12126 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12127 & SQRT(PR),1D20)),P(I,3))
12128 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
12129 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
12130 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
12131 140 CONTINUE
12132 ENDIF
12133
12134C...Store sum up transverse and longitudinal momenta.
12135 PARI(65)=2D0*PARI(17)
12136 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
12137 DO 150 I=MSTP(126)+1,N
12138 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
12139 PT=SQRT(P(I,1)**2+P(I,2)**2)
12140 PARI(69)=PARI(69)+PT
12141 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
12142 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
12143 150 CONTINUE
12144 PARI(67)=PARI(68)
12145 PARI(71)=VINT(151)
12146 PARI(72)=VINT(152)
12147 PARI(73)=VINT(151)
12148 PARI(74)=VINT(152)
12149 ELSE
12150 PARI(66)=PARI(65)
12151 PARI(69)=PARI(65)
12152 ENDIF
12153
12154C...Store various other pieces of information into PARI.
12155 PARI(61)=VINT(148)
12156 PARI(75)=VINT(155)
12157 PARI(76)=VINT(156)
12158 PARI(77)=VINT(159)
12159 PARI(78)=VINT(160)
12160 PARI(81)=VINT(138)
12161
12162C...Set information for PYTABU.
12163 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12164 MSTU(161)=MINT(21)
12165 MSTU(162)=0
12166 ELSEIF(ISET(ISUB).EQ.5) THEN
12167 MSTU(161)=MINT(23)
12168 MSTU(162)=0
12169 ELSE
12170 MSTU(161)=MINT(21)
12171 MSTU(162)=MINT(22)
12172 ENDIF
12173
12174 RETURN
12175 END
12176
12177C*********************************************************************
12178
12179*$ CREATE PYFRAM.FOR
12180*COPY PYFRAM
12181C...PYFRAM
12182C...Performs transformations between different coordinate frames.
12183
12184 SUBROUTINE PYFRAM(IFRAME)
12185
12186C...Double precision and integer declarations.
12187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12188 INTEGER PYK,PYCHGE,PYCOMP
12189C...Commonblocks.
12190 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12191 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12192 COMMON/PYINT1/MINT(400),VINT(400)
12193 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
12194
12195C...Check that transformation can and should be done.
12196 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
12197 &MINT(91).EQ.1)) THEN
12198 IF(IFRAME.EQ.MINT(6)) RETURN
12199 ELSE
12200 WRITE(MSTU(11),5000) IFRAME,MINT(6)
12201 RETURN
12202 ENDIF
12203
12204 IF(MINT(6).EQ.1) THEN
12205C...Transform from fixed target or user specified frame to
12206C...overall CM frame.
12207 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
12208 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
12209 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
12210 ELSEIF(MINT(6).EQ.3) THEN
12211C...Transform from hadronic CM frame in DIS to overall CM frame.
12212 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
12213 & -VINT(225))
12214 ENDIF
12215
12216 IF(IFRAME.EQ.1) THEN
12217C...Transform from overall CM frame to fixed target or user specified
12218C...frame.
12219 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
12220 ELSEIF(IFRAME.EQ.3) THEN
12221C...Transform from overall CM frame to hadronic CM frame in DIS.
12222 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
12223 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
12224 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
12225 ENDIF
12226
12227C...Set information about new frame.
12228 MINT(6)=IFRAME
12229 MSTI(6)=IFRAME
12230
12231 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
12232 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
12233 &1X,I5)
12234
12235 RETURN
12236 END
12237
12238C*********************************************************************
12239
12240*$ CREATE PYWIDT.FOR
12241*COPY PYWIDT
12242C...PYWIDT
12243C...Calculates full and partial widths of resonances.
12244
12245 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
12246
12247C...Double precision and integer declarations.
12248 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12249 INTEGER PYK,PYCHGE,PYCOMP
12250C...Parameter statement to help give large particle numbers.
12251 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
12252C...Commonblocks.
12253 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12254 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12255 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
12256 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12257 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12258 COMMON/PYINT1/MINT(400),VINT(400)
12259 COMMON/PYINT4/MWID(500),WIDS(500,5)
12260 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
12261 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
12262 &SFMIX(16,4)
12263 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
12264 &/PYINT4/,/PYMSSM/,/PYSSMT/
12265C...Local arrays and saved variables.
12266 DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
12267 &WID2SV(3,2)
12268 SAVE MOFSV,WIDWSV,WID2SV
12269 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
12270
12271C...Compressed code and sign; mass.
12272 KFLA=IABS(KFLR)
12273 KFLS=ISIGN(1,KFLR)
12274 KC=PYCOMP(KFLA)
12275 SHR=SQRT(SH)
12276 PMR=PMAS(KC,1)
12277
12278C...Reset width information.
12279 DO 110 I=0,200
12280 WDTP(I)=0D0
12281 DO 100 J=0,5
12282 WDTE(I,J)=0D0
12283 100 CONTINUE
12284 110 CONTINUE
12285
12286C...Not to be treated as a resonance: return.
12287 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
12288 &KFLA.NE.22) THEN
12289 WDTP(0)=1D0
12290 WDTE(0,0)=1D0
12291 MINT(61)=0
12292 MINT(62)=0
12293 MINT(63)=0
12294 RETURN
12295
12296C...Treatment as a resonance based on tabulated branching ratios.
12297 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
12298C...Loop over possible decay channels; skip irrelevant ones.
12299 DO 120 I=1,MDCY(KC,3)
12300 IDC=I+MDCY(KC,2)-1
12301 IF(MDME(IDC,1).LT.0) GOTO 120
12302
12303C...Read out decay products and nominal masses.
12304 KFD1=KFDP(IDC,1)
12305 KFC1=PYCOMP(KFD1)
12306 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
12307 PM1=PMAS(KFC1,1)
12308 KFD2=KFDP(IDC,2)
12309 KFC2=PYCOMP(KFD2)
12310 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
12311 PM2=PMAS(KFC2,1)
12312 KFD3=KFDP(IDC,3)
12313 PM3=0D0
12314 IF(KFD3.NE.0) THEN
12315 KFC3=PYCOMP(KFD3)
12316 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
12317 PM3=PMAS(KFC3,1)
12318 ENDIF
12319
12320C...Naive partial width and alternative threshold factors.
12321 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
12322 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
12323 & PM1+PM2+PM3.GE.SHR) THEN
12324 WDTP(I)=0D0
12325 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
12326 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
12327 & 4D0*PM1**2*PM2**2))/SH
12328 ELSEIF(MDME(IDC,2).EQ.52) THEN
12329 PMA=MAX(PM1,PM2,PM3)
12330 PMC=MIN(PM1,PM2,PM3)
12331 PMB=PM1+PM2+PM3-PMA-PMC
12332 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
12333 PMAN=PMA**2/SH
12334 PMBN=PMB**2/SH
12335 PMCN=PMC**2/SH
12336 PMBCN=PMBC**2/SH
12337 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
12338 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12339 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12340 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12341 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12342 & ((1D0-PMBCN)*PMBCN*SH)
12343 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
12344 WDTP(I)=WDTP(I)*SQRT(
12345 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
12346 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
12347 ELSEIF(MDME(IDC,2).EQ.53) THEN
12348 PMA=MAX(PM1,PM2,PM3)
12349 PMC=MIN(PM1,PM2,PM3)
12350 PMB=PM1+PM2+PM3-PMA-PMC
12351 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
12352 PMAN=PMA**2/SH
12353 PMBN=PMB**2/SH
12354 PMCN=PMC**2/SH
12355 PMBCN=PMBC**2/SH
12356 FACACT=SQRT(MAX(0D0,
12357 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12358 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12359 & ((SHR-PMA)**2-(PMB+PMC)**2)*
12360 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12361 & ((1D0-PMBCN)*PMBCN*SH)
12362 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
12363 PMAN=PMA**2/PMR**2
12364 PMBN=PMB**2/PMR**2
12365 PMCN=PMC**2/PMR**2
12366 PMBCN=PMBC**2/PMR**2
12367 FACNOM=SQRT(MAX(0D0,
12368 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12369 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12370 & ((PMR-PMA)**2-(PMB+PMC)**2)*
12371 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
12372 & ((1D0-PMBCN)*PMBCN*PMR**2)
12373 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
12374 ENDIF
12375 WDTP(0)=WDTP(0)+WDTP(I)
12376
12377C...Calculate secondary width (at most two identical/opposite).
12378 IF(MDME(IDC,1).GT.0) THEN
12379 IF(KFD2.EQ.KFD1) THEN
12380 IF(KCHG(KFC1,3).EQ.0) THEN
12381 WID2=WIDS(KFC1,1)
12382 ELSEIF(KFD1.GT.0) THEN
12383 WID2=WIDS(KFC1,4)
12384 ELSE
12385 WID2=WIDS(KFC1,5)
12386 ENDIF
12387 IF(KFD3.GT.0) THEN
12388 WID2=WID2*WIDS(KFC3,2)
12389 ELSEIF(KFD3.LT.0) THEN
12390 WID2=WID2*WIDS(KFC3,3)
12391 ENDIF
12392 ELSEIF(KFD2.EQ.-KFD1) THEN
12393 WID2=WIDS(KFC1,1)
12394 IF(KFD3.GT.0) THEN
12395 WID2=WID2*WIDS(KFC3,2)
12396 ELSEIF(KFD3.LT.0) THEN
12397 WID2=WID2*WIDS(KFC3,3)
12398 ENDIF
12399 ELSEIF(KFD3.EQ.KFD1) THEN
12400 IF(KCHG(KFC1,3).EQ.0) THEN
12401 WID2=WIDS(KFC1,1)
12402 ELSEIF(KFD1.GT.0) THEN
12403 WID2=WIDS(KFC1,4)
12404 ELSE
12405 WID2=WIDS(KFC1,5)
12406 ENDIF
12407 IF(KFD2.GT.0) THEN
12408 WID2=WID2*WIDS(KFC2,2)
12409 ELSEIF(KFD2.LT.0) THEN
12410 WID2=WID2*WIDS(KFC2,3)
12411 ENDIF
12412 ELSEIF(KFD3.EQ.-KFD1) THEN
12413 WID2=WIDS(KFC1,1)
12414 IF(KFD2.GT.0) THEN
12415 WID2=WID2*WIDS(KFC2,2)
12416 ELSEIF(KFD2.LT.0) THEN
12417 WID2=WID2*WIDS(KFC2,3)
12418 ENDIF
12419 ELSEIF(KFD3.EQ.KFD2) THEN
12420 IF(KCHG(KFC2,3).EQ.0) THEN
12421 WID2=WIDS(KFC2,1)
12422 ELSEIF(KFD2.GT.0) THEN
12423 WID2=WIDS(KFC2,4)
12424 ELSE
12425 WID2=WIDS(KFC2,5)
12426 ENDIF
12427 IF(KFD1.GT.0) THEN
12428 WID2=WID2*WIDS(KFC1,2)
12429 ELSEIF(KFD1.LT.0) THEN
12430 WID2=WID2*WIDS(KFC1,3)
12431 ENDIF
12432 ELSEIF(KFD3.EQ.-KFD2) THEN
12433 WID2=WIDS(KFC2,1)
12434 IF(KFD1.GT.0) THEN
12435 WID2=WID2*WIDS(KFC1,2)
12436 ELSEIF(KFD1.LT.0) THEN
12437 WID2=WID2*WIDS(KFC1,3)
12438 ENDIF
12439 ELSE
12440 IF(KFD1.GT.0) THEN
12441 WID2=WIDS(KFC1,2)
12442 ELSE
12443 WID2=WIDS(KFC1,3)
12444 ENDIF
12445 IF(KFD2.GT.0) THEN
12446 WID2=WID2*WIDS(KFC2,2)
12447 ELSE
12448 WID2=WID2*WIDS(KFC2,3)
12449 ENDIF
12450 IF(KFD3.GT.0) THEN
12451 WID2=WID2*WIDS(KFC3,2)
12452 ELSEIF(KFD3.LT.0) THEN
12453 WID2=WID2*WIDS(KFC3,3)
12454 ENDIF
12455 ENDIF
12456
12457C...Store effective widths according to case.
12458 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12459 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12460 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12461 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12462 ENDIF
12463 120 CONTINUE
12464C...Return.
12465 MINT(61)=0
12466 MINT(62)=0
12467 MINT(63)=0
12468 RETURN
12469 ENDIF
12470
12471C...Here begins detailed dynamical calculation of resonance widths.
12472C...Shared treatment of Higgs states.
12473 KFHIGG=25
12474 IHIGG=1
12475 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12476 KFHIGG=KFLA
12477 IHIGG=KFLA-33
12478 ENDIF
12479
12480C...Common electroweak and strong constants.
12481 XW=PARU(102)
12482 XWV=XW
12483 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12484 XW1=1D0-XW
12485 AEM=PYALEM(SH)
12486 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
12487 AS=PYALPS(SH)
12488 RADC=1D0+AS/PARU(1)
12489
12490 IF(KFLA.EQ.6) THEN
12491C...t quark.
12492 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12493 RADCT=1D0-2.5D0*AS/PARU(1)
12494 DO 130 I=1,MDCY(KC,3)
12495 IDC=I+MDCY(KC,2)-1
12496 IF(MDME(IDC,1).LT.0) GOTO 130
12497 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12498 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12499 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
12500 IF(I.GE.4.AND.I.LE.7) THEN
12501C...t -> W + q; including approximate QCD correction factor.
12502 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
12503 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12504 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12505 IF(KFLR.GT.0) THEN
12506 WID2=WIDS(24,2)
12507 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12508 ELSE
12509 WID2=WIDS(24,3)
12510 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12511 ENDIF
12512 ELSEIF(I.EQ.9) THEN
12513C...t -> H + b.
12514 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12515 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12516 WID2=WIDS(37,2)
12517 IF(KFLR.LT.0) WID2=WIDS(37,3)
12518CMRENNA++
12519 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
12520C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
12521 BETA=ATAN(RMSS(5))
12522 SINB=SIN(BETA)
12523 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
12524 ET=KCHG(6,1)/3D0
12525 T3L=SIGN(0.5D0,ET)
12526 KFC1=PYCOMP(KFDP(IDC,1))
12527 KFC2=PYCOMP(KFDP(IDC,2))
12528 PMNCHI=PMAS(KFC1,1)
12529 PMSTOP=PMAS(KFC2,1)
12530 IF(SHR.GT.PMNCHI+PMSTOP) THEN
12531 IZ=I-9
12532 AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
12533 AR=-ET*ZMIX(IZ,1)*TANW
12534 BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
12535 BR=AL
12536 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
12537 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
12538 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
12539 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
12540 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
12541 & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
12542 IF(KFLR.GT.0) THEN
12543 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
12544 ELSE
12545 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
12546 ENDIF
12547 ENDIF
12548CMRENNA--
12549 ENDIF
12550 WDTP(0)=WDTP(0)+WDTP(I)
12551 IF(MDME(IDC,1).GT.0) THEN
12552 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12553 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12554 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12555 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12556 ENDIF
12557 130 CONTINUE
12558
12559 ELSEIF(KFLA.EQ.7) THEN
12560C...b' quark.
12561 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12562 DO 140 I=1,MDCY(KC,3)
12563 IDC=I+MDCY(KC,2)-1
12564 IF(MDME(IDC,1).LT.0) GOTO 140
12565 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12566 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12567 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
12568 IF(I.GE.4.AND.I.LE.7) THEN
12569C...b' -> W + q.
12570 WDTP(I)=FAC*VCKM(I-3,4)*
12571 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12572 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12573 IF(KFLR.GT.0) THEN
12574 WID2=WIDS(24,3)
12575 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
12576 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
12577 ELSE
12578 WID2=WIDS(24,2)
12579 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
12580 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
12581 ENDIF
12582 WID2=WIDS(24,3)
12583 IF(KFLR.LT.0) WID2=WIDS(24,2)
12584 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12585C...b' -> H + q.
12586 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12587 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12588 IF(KFLR.GT.0) THEN
12589 WID2=WIDS(37,3)
12590 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
12591 ELSE
12592 WID2=WIDS(37,2)
12593 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
12594 ENDIF
12595 ENDIF
12596 WDTP(0)=WDTP(0)+WDTP(I)
12597 IF(MDME(IDC,1).GT.0) THEN
12598 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12599 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12600 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12601 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12602 ENDIF
12603 140 CONTINUE
12604
12605 ELSEIF(KFLA.EQ.8) THEN
12606C...t' quark.
12607 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12608 DO 150 I=1,MDCY(KC,3)
12609 IDC=I+MDCY(KC,2)-1
12610 IF(MDME(IDC,1).LT.0) GOTO 150
12611 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12612 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12613 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
12614 IF(I.GE.4.AND.I.LE.7) THEN
12615C...t' -> W + q.
12616 WDTP(I)=FAC*VCKM(4,I-3)*
12617 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12618 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12619 IF(KFLR.GT.0) THEN
12620 WID2=WIDS(24,2)
12621 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12622 ELSE
12623 WID2=WIDS(24,3)
12624 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12625 ENDIF
12626 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12627C...t' -> H + q.
12628 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12629 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12630 IF(KFLR.GT.0) THEN
12631 WID2=WIDS(37,2)
12632 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
12633 ELSE
12634 WID2=WIDS(37,3)
12635 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
12636 ENDIF
12637 ENDIF
12638 WDTP(0)=WDTP(0)+WDTP(I)
12639 IF(MDME(IDC,1).GT.0) THEN
12640 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12641 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12642 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12643 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12644 ENDIF
12645 150 CONTINUE
12646
12647 ELSEIF(KFLA.EQ.17) THEN
12648C...tau' lepton.
12649 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12650 DO 160 I=1,MDCY(KC,3)
12651 IDC=I+MDCY(KC,2)-1
12652 IF(MDME(IDC,1).LT.0) GOTO 160
12653 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12654 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12655 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
12656 IF(I.EQ.3) THEN
12657C...tau' -> W + nu'_tau.
12658 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12659 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12660 IF(KFLR.GT.0) THEN
12661 WID2=WIDS(24,3)
12662 WID2=WID2*WIDS(18,2)
12663 ELSE
12664 WID2=WIDS(24,2)
12665 WID2=WID2*WIDS(18,3)
12666 ENDIF
12667 ELSEIF(I.EQ.5) THEN
12668C...tau' -> H + nu'_tau.
12669 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12670 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12671 IF(KFLR.GT.0) THEN
12672 WID2=WIDS(37,3)
12673 WID2=WID2*WIDS(18,2)
12674 ELSE
12675 WID2=WIDS(37,2)
12676 WID2=WID2*WIDS(18,3)
12677 ENDIF
12678 ENDIF
12679 WDTP(0)=WDTP(0)+WDTP(I)
12680 IF(MDME(IDC,1).GT.0) THEN
12681 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12682 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12683 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12684 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12685 ENDIF
12686 160 CONTINUE
12687
12688 ELSEIF(KFLA.EQ.18) THEN
12689C...nu'_tau neutrino.
12690 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12691 DO 170 I=1,MDCY(KC,3)
12692 IDC=I+MDCY(KC,2)-1
12693 IF(MDME(IDC,1).LT.0) GOTO 170
12694 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12695 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12696 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
12697 IF(I.EQ.2) THEN
12698C...nu'_tau -> W + tau'.
12699 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12700 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12701 IF(KFLR.GT.0) THEN
12702 WID2=WIDS(24,2)
12703 WID2=WID2*WIDS(17,2)
12704 ELSE
12705 WID2=WIDS(24,3)
12706 WID2=WID2*WIDS(17,3)
12707 ENDIF
12708 ELSEIF(I.EQ.3) THEN
12709C...nu'_tau -> H + tau'.
12710 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12711 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12712 IF(KFLR.GT.0) THEN
12713 WID2=WIDS(37,2)
12714 WID2=WID2*WIDS(17,2)
12715 ELSE
12716 WID2=WIDS(37,3)
12717 WID2=WID2*WIDS(17,3)
12718 ENDIF
12719 ENDIF
12720 WDTP(0)=WDTP(0)+WDTP(I)
12721 IF(MDME(IDC,1).GT.0) THEN
12722 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12723 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12724 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12725 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12726 ENDIF
12727 170 CONTINUE
12728
12729 ELSEIF(KFLA.EQ.21) THEN
12730C...QCD:
12731C***Note that widths are not given in dimensional quantities here.
12732 DO 180 I=1,MDCY(KC,3)
12733 IDC=I+MDCY(KC,2)-1
12734 IF(MDME(IDC,1).LT.0) GOTO 180
12735 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12736 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12737 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
12738 WID2=1D0
12739 IF(I.LE.8) THEN
12740C...QCD -> q + qbar
12741 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12742 IF(I.EQ.6) WID2=WIDS(6,1)
12743 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12744 ENDIF
12745 WDTP(0)=WDTP(0)+WDTP(I)
12746 IF(MDME(IDC,1).GT.0) THEN
12747 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12748 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12749 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12750 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12751 ENDIF
12752 180 CONTINUE
12753
12754 ELSEIF(KFLA.EQ.22) THEN
12755C...QED photon.
12756C***Note that widths are not given in dimensional quantities here.
12757 DO 190 I=1,MDCY(KC,3)
12758 IDC=I+MDCY(KC,2)-1
12759 IF(MDME(IDC,1).LT.0) GOTO 190
12760 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12761 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12762 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
12763 WID2=1D0
12764 IF(I.LE.8) THEN
12765C...QED -> q + qbar.
12766 EF=KCHG(I,1)/3D0
12767 FCOF=3D0*RADC
12768 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12769 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12770 IF(I.EQ.6) WID2=WIDS(6,1)
12771 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12772 ELSEIF(I.LE.12) THEN
12773C...QED -> l+ + l-.
12774 EF=KCHG(9+2*(I-8),1)/3D0
12775 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12776 IF(I.EQ.12) WID2=WIDS(17,1)
12777 ENDIF
12778 WDTP(0)=WDTP(0)+WDTP(I)
12779 IF(MDME(IDC,1).GT.0) THEN
12780 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12781 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12782 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12783 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12784 ENDIF
12785 190 CONTINUE
12786
12787 ELSEIF(KFLA.EQ.23) THEN
12788C...Z0:
12789 ICASE=1
12790 XWC=1D0/(16D0*XW*XW1)
12791 FAC=(AEM*XWC/3D0)*SHR
12792 200 CONTINUE
12793 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
12794 VINT(111)=0D0
12795 VINT(112)=0D0
12796 VINT(114)=0D0
12797 ENDIF
12798 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12799 KFI=IABS(MINT(15))
12800 IF(KFI.GT.20) KFI=IABS(MINT(16))
12801 EI=KCHG(KFI,1)/3D0
12802 AI=SIGN(1D0,EI)
12803 VI=AI-4D0*EI*XWV
12804 SQMZ=PMAS(23,1)**2
12805 HZ=SHR*WDTP(0)
12806 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
12807 IF(MSTP(43).EQ.3) VINT(112)=
12808 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
12809 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12810 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
12811 ENDIF
12812 DO 210 I=1,MDCY(KC,3)
12813 IDC=I+MDCY(KC,2)-1
12814 IF(MDME(IDC,1).LT.0) GOTO 210
12815 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12816 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12817 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
12818 WID2=1D0
12819 IF(I.LE.8) THEN
12820C...Z0 -> q + qbar
12821 EF=KCHG(I,1)/3D0
12822 AF=SIGN(1D0,EF+0.1D0)
12823 VF=AF-4D0*EF*XWV
12824 FCOF=3D0*RADC
12825 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12826 IF(I.EQ.6) WID2=WIDS(6,1)
12827 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12828 ELSEIF(I.LE.16) THEN
12829C...Z0 -> l+ + l-, nu + nubar
12830 EF=KCHG(I+2,1)/3D0
12831 AF=SIGN(1D0,EF+0.1D0)
12832 VF=AF-4D0*EF*XWV
12833 FCOF=1D0
12834 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
12835 ENDIF
12836 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
12837 IF(ICASE.EQ.1) THEN
12838 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
12839 & BE34
12840 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12841 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
12842 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
12843 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
12844 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12845 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
12846 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
12847 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
12848 ENDIF
12849 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
12850 IF(MDME(IDC,1).GT.0) THEN
12851 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
12852 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
12853 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12854 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
12855 & WDTE(I,MDME(IDC,1))
12856 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12857 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12858 ENDIF
12859 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12860 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
12861 & VINT(111)+FGGF*WID2
12862 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
12863 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12864 & VINT(114)+FZZF*WID2
12865 ENDIF
12866 ENDIF
12867 210 CONTINUE
12868 IF(MINT(61).GE.1) ICASE=3-ICASE
12869 IF(ICASE.EQ.2) GOTO 200
12870
12871 ELSEIF(KFLA.EQ.24) THEN
12872C...W+/-:
12873 FAC=(AEM/(24D0*XW))*SHR
12874 DO 220 I=1,MDCY(KC,3)
12875 IDC=I+MDCY(KC,2)-1
12876 IF(MDME(IDC,1).LT.0) GOTO 220
12877 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12878 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12879 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
12880 WID2=1D0
12881 IF(I.LE.16) THEN
12882C...W+/- -> q + qbar'
12883 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
12884 IF(KFLR.GT.0) THEN
12885 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
12886 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
12887 IF(I.GE.13) WID2=WID2*WIDS(7,3)
12888 ELSE
12889 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
12890 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
12891 IF(I.GE.13) WID2=WID2*WIDS(7,2)
12892 ENDIF
12893 ELSEIF(I.LE.20) THEN
12894C...W+/- -> l+/- + nu
12895 FCOF=1D0
12896 IF(KFLR.GT.0) THEN
12897 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
12898 ELSE
12899 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
12900 ENDIF
12901 ENDIF
12902 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
12903 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
12904 WDTP(0)=WDTP(0)+WDTP(I)
12905 IF(MDME(IDC,1).GT.0) THEN
12906 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12907 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12908 WDTE(I,0)=WDTE(I,MDME(IDC,1))
12909 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12910 ENDIF
12911 220 CONTINUE
12912
12913 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12914C...h0 (or H0, or A0):
12915 IF(MSTP(49).EQ.0) THEN
12916 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
12917 ELSE
12918 FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
12919 ENDIF
12920 DO 260 I=1,MDCY(KFHIGG,3)
12921 IDC=I+MDCY(KFHIGG,2)-1
12922 IF(MDME(IDC,1).LT.0) GOTO 260
12923 KFC1=PYCOMP(KFDP(IDC,1))
12924 KFC2=PYCOMP(KFDP(IDC,2))
12925 RM1=PMAS(KFC1,1)**2/SH
12926 RM2=PMAS(KFC2,1)**2/SH
12927 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
12928 & GOTO 260
12929 WID2=1D0
12930
12931 IF(I.LE.8) THEN
12932C...h0 -> q + qbar
12933 WDTP(I)=FAC*3D0*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,
12934 & 1D0-4D0*RM1))*RADC
12935 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) WDTP(I)=WDTP(I)*
12936 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
12937 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
12938 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12939 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
12940 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
12941 ENDIF
12942 IF(I.EQ.6) WID2=WIDS(6,1)
12943 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12944
12945 ELSEIF(I.LE.12) THEN
12946C...h0 -> l+ + l-
12947 WDTP(I)=FAC*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12948 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
12949 & PARU(153+10*IHIGG)**2
12950 IF(I.EQ.12) WID2=WIDS(17,1)
12951
12952 ELSEIF(I.EQ.13) THEN
12953C...h0 -> g + g; quark loop contribution only
12954 ETARE=0D0
12955 ETAIM=0D0
12956 DO 230 J=1,2*MSTP(1)
12957 EPS=(2D0*PMAS(J,1))**2/SH
12958C...Loop integral; function of eps=4m^2/shat; different for A0.
12959 IF(EPS.LE.1D0) THEN
12960 IF(EPS.GT.1.D-4) THEN
12961 ROOT=SQRT(1D0-EPS)
12962 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
12963 ELSE
12964 RLN=LOG(4D0/EPS-2D0)
12965 ENDIF
12966 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
12967 PHIIM=0.5D0*PARU(1)*RLN
12968 ELSE
12969 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
12970 PHIIM=0D0
12971 ENDIF
12972 IF(IHIGG.LE.2) THEN
12973 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
12974 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
12975 ELSE
12976 ETAREJ=-0.5D0*EPS*PHIRE
12977 ETAIMJ=-0.5D0*EPS*PHIIM
12978 ENDIF
12979C...Couplings (=1 for standard model Higgs).
12980 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12981 IF(MOD(J,2).EQ.1) THEN
12982 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
12983 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
12984 ELSE
12985 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
12986 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
12987 ENDIF
12988 ENDIF
12989 ETARE=ETARE+ETAREJ
12990 ETAIM=ETAIM+ETAIMJ
12991 230 CONTINUE
12992 ETA2=ETARE**2+ETAIM**2
12993 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
12994
12995 ELSEIF(I.EQ.14) THEN
12996C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
12997 ETARE=0D0
12998 ETAIM=0D0
12999 JMAX=3*MSTP(1)+1
13000 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13001 DO 240 J=1,JMAX
13002 IF(J.LE.2*MSTP(1)) THEN
13003 EJ=KCHG(J,1)/3D0
13004 EPS=(2D0*PMAS(J,1))**2/SH
13005 ELSEIF(J.LE.3*MSTP(1)) THEN
13006 JL=2*(J-2*MSTP(1))-1
13007 EJ=KCHG(10+JL,1)/3D0
13008 EPS=(2D0*PMAS(10+JL,1))**2/SH
13009 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13010 EPS=(2D0*PMAS(24,1))**2/SH
13011 ELSE
13012 EPS=(2D0*PMAS(37,1))**2/SH
13013 ENDIF
13014C...Loop integral; function of eps=4m^2/shat.
13015 IF(EPS.LE.1D0) THEN
13016 IF(EPS.GT.1.D-4) THEN
13017 ROOT=SQRT(1D0-EPS)
13018 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13019 ELSE
13020 RLN=LOG(4D0/EPS-2D0)
13021 ENDIF
13022 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13023 PHIIM=0.5D0*PARU(1)*RLN
13024 ELSE
13025 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13026 PHIIM=0D0
13027 ENDIF
13028 IF(J.LE.3*MSTP(1)) THEN
13029C...Fermion loops: loop integral different for A0; charges.
13030 IF(IHIGG.LE.2) THEN
13031 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
13032 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
13033 ELSE
13034 PHIPRE=-0.5D0*EPS*PHIRE
13035 PHIPIM=-0.5D0*EPS*PHIIM
13036 ENDIF
13037 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13038 EJC=3D0*EJ**2
13039 EJH=PARU(151+10*IHIGG)
13040 ELSEIF(J.LE.2*MSTP(1)) THEN
13041 EJC=3D0*EJ**2
13042 EJH=PARU(152+10*IHIGG)
13043 ELSE
13044 EJC=EJ**2
13045 EJH=PARU(153+10*IHIGG)
13046 ENDIF
13047 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13048 ETAREJ=EJC*EJH*PHIPRE
13049 ETAIMJ=EJC*EJH*PHIPIM
13050 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13051C...W loops: loop integral and charges.
13052 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
13053 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
13054 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13055 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13056 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13057 ENDIF
13058 ELSE
13059C...Charged H loops: loop integral and charges.
13060 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
13061 & PARU(158+10*IHIGG+2*(IHIGG/3))
13062 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
13063 ETAIMJ=-EPS**2*PHIIM*FACHHH
13064 ENDIF
13065 ETARE=ETARE+ETAREJ
13066 ETAIM=ETAIM+ETAIMJ
13067 240 CONTINUE
13068 ETA2=ETARE**2+ETAIM**2
13069 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
13070
13071 ELSEIF(I.EQ.15) THEN
13072C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
13073 ETARE=0D0
13074 ETAIM=0D0
13075 JMAX=3*MSTP(1)+1
13076 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13077 DO 250 J=1,JMAX
13078 IF(J.LE.2*MSTP(1)) THEN
13079 EJ=KCHG(J,1)/3D0
13080 AJ=SIGN(1D0,EJ+0.1D0)
13081 VJ=AJ-4D0*EJ*XWV
13082 EPS=(2D0*PMAS(J,1))**2/SH
13083 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
13084 ELSEIF(J.LE.3*MSTP(1)) THEN
13085 JL=2*(J-2*MSTP(1))-1
13086 EJ=KCHG(10+JL,1)/3D0
13087 AJ=SIGN(1D0,EJ+0.1D0)
13088 VJ=AJ-4D0*EJ*XWV
13089 EPS=(2D0*PMAS(10+JL,1))**2/SH
13090 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
13091 ELSE
13092 EPS=(2D0*PMAS(24,1))**2/SH
13093 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
13094 ENDIF
13095C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
13096 IF(EPS.LE.1D0) THEN
13097 ROOT=SQRT(1D0-EPS)
13098 IF(EPS.GT.1.D-4) THEN
13099 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13100 ELSE
13101 RLN=LOG(4D0/EPS-2D0)
13102 ENDIF
13103 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13104 PHIIM=0.5D0*PARU(1)*RLN
13105 PSIRE=0.5D0*ROOT*RLN
13106 PSIIM=-0.5D0*ROOT*PARU(1)
13107 ELSE
13108 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13109 PHIIM=0D0
13110 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
13111 PSIIM=0D0
13112 ENDIF
13113 IF(EPSP.LE.1D0) THEN
13114 ROOT=SQRT(1D0-EPSP)
13115 IF(EPSP.GT.1.D-4) THEN
13116 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13117 ELSE
13118 RLN=LOG(4D0/EPSP-2D0)
13119 ENDIF
13120 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
13121 PHIIMP=0.5D0*PARU(1)*RLN
13122 PSIREP=0.5D0*ROOT*RLN
13123 PSIIMP=-0.5D0*ROOT*PARU(1)
13124 ELSE
13125 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
13126 PHIIMP=0D0
13127 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
13128 PSIIMP=0D0
13129 ENDIF
13130 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
13131 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
13132 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
13133 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
13134 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
13135 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
13136 IF(J.LE.3*MSTP(1)) THEN
13137C...Fermion loops: loop integral different for A0; charges.
13138 IF(IHIGG.EQ.3) FXYRE=0D0
13139 IF(IHIGG.EQ.3) FXYIM=0D0
13140 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13141 EJC=-3D0*EJ*VJ
13142 EJH=PARU(151+10*IHIGG)
13143 ELSEIF(J.LE.2*MSTP(1)) THEN
13144 EJC=-3D0*EJ*VJ
13145 EJH=PARU(152+10*IHIGG)
13146 ELSE
13147 EJC=-EJ*VJ
13148 EJH=PARU(153+10*IHIGG)
13149 ENDIF
13150 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13151 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
13152 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
13153 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13154C...W loops: loop integral and charges.
13155 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
13156 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
13157 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
13158 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13159 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13160 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13161 ENDIF
13162 ELSE
13163C...Charged H loops: loop integral and charges.
13164 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
13165 & PARU(158+10*IHIGG+2*(IHIGG/3))
13166 ETAREJ=FACHHH*FXYRE
13167 ETAIMJ=FACHHH*FXYIM
13168 ENDIF
13169 ETARE=ETARE+ETAREJ
13170 ETAIM=ETAIM+ETAIMJ
13171 250 CONTINUE
13172 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
13173 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
13174 WID2=WIDS(23,2)
13175
13176 ELSEIF(I.LE.17) THEN
13177C...h0 -> Z0 + Z0, W+ + W-
13178 PM1=PMAS(IABS(KFDP(IDC,1)),1)
13179 PG1=PMAS(IABS(KFDP(IDC,1)),2)
13180 IF(MINT(62).GE.1) THEN
13181 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
13182 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
13183 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
13184 MOFSV(IHIGG,I-15)=0
13185 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13186 & 1D0-4D0*RM1))
13187 WID2=1D0
13188 ELSE
13189 MOFSV(IHIGG,I-15)=1
13190 RMAS=SQRT(MAX(0D0,SH))
13191 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
13192 & WID2)
13193 WIDWSV(IHIGG,I-15)=WIDW
13194 WID2SV(IHIGG,I-15)=WID2
13195 ENDIF
13196 ELSE
13197 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
13198 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13199 & 1D0-4D0*RM1))
13200 WID2=1D0
13201 ELSE
13202 WIDW=WIDWSV(IHIGG,I-15)
13203 WID2=WID2SV(IHIGG,I-15)
13204 ENDIF
13205 ENDIF
13206 WDTP(I)=FAC*WIDW/(2D0*(18-I))
13207 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
13208 & PARU(138+I+10*IHIGG)**2
13209 WID2=WID2*WIDS(7+I,1)
13210
13211 ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
13212C***H0 -> Z0 + h0 (not yet implemented).
13213
13214 ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
13215C...H0 -> h0 + h0.
13216 WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
13217 & SQRT(MAX(0D0,1D0-4D0*RM1))
13218 WID2=WIDS(25,2)**2
13219
13220 ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
13221C...H0 -> A0 + A0.
13222 WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
13223 & SQRT(MAX(0D0,1D0-4D0*RM1))
13224 WID2=WIDS(36,2)**2
13225
13226 ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
13227C...A0 -> Z0 + h0.
13228 WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
13229 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13230 WID2=WIDS(23,2)*WIDS(25,2)
13231
13232CMRENNA++
13233 ELSE
13234C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13235 RM10=RM1*SH/PMR**2
13236 RM20=RM2*SH/PMR**2
13237 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13238 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13239 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13240 WFAC=0D0
13241 ELSE
13242 WFAC=WFAC/WFAC0
13243 ENDIF
13244 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13245CMRENNA--
13246 IF(KFC2.EQ.KFC1) THEN
13247 WID2=WIDS(KFC1,1)
13248 ELSE
13249 KSGN1=2
13250 IF(KFDP(IDC,1).LT.0) KSGN1=3
13251 KSGN2=2
13252 IF(KFDP(IDC,2).LT.0) KSGN2=3
13253 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13254 ENDIF
13255 ENDIF
13256 WDTP(0)=WDTP(0)+WDTP(I)
13257 IF(MDME(IDC,1).GT.0) THEN
13258 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13259 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13260 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13261 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13262 ENDIF
13263 260 CONTINUE
13264
13265 ELSEIF(KFLA.EQ.32) THEN
13266C...Z'0:
13267 ICASE=1
13268 XWC=1D0/(16D0*XW*XW1)
13269 FAC=(AEM*XWC/3D0)*SHR
13270 VINT(117)=0D0
13271 270 CONTINUE
13272 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
13273 VINT(111)=0D0
13274 VINT(112)=0D0
13275 VINT(113)=0D0
13276 VINT(114)=0D0
13277 VINT(115)=0D0
13278 VINT(116)=0D0
13279 ENDIF
13280 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13281 KFAI=IABS(MINT(15))
13282 EI=KCHG(KFAI,1)/3D0
13283 AI=SIGN(1D0,EI+0.1D0)
13284 VI=AI-4D0*EI*XWV
13285 KFAIC=1
13286 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13287 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13288 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13289 VPI=PARU(119+2*KFAIC)
13290 API=PARU(120+2*KFAIC)
13291 SQMZ=PMAS(23,1)**2
13292 HZ=SHR*FAC*VINT(117)
13293 SQMZP=PMAS(32,1)**2
13294 HZP=SHR*FAC*WDTP(0)
13295 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13296 & MSTP(44).EQ.7) VINT(111)=1D0
13297 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
13298 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
13299 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
13300 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
13301 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13302 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
13303 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
13304 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
13305 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
13306 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13307 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
13308 ENDIF
13309 DO 280 I=1,MDCY(KC,3)
13310 IDC=I+MDCY(KC,2)-1
13311 IF(MDME(IDC,1).LT.0) GOTO 280
13312 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13313 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13314 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
13315 WID2=1D0
13316 IF(I.LE.16) THEN
13317 IF(I.LE.8) THEN
13318C...Z'0 -> q + qbar
13319 EF=KCHG(I,1)/3D0
13320 AF=SIGN(1D0,EF+0.1D0)
13321 VF=AF-4D0*EF*XWV
13322 VPF=PARU(123-2*MOD(I,2))
13323 APF=PARU(124-2*MOD(I,2))
13324 FCOF=3D0*RADC
13325 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
13326 & PYHFTH(SH,SH*RM1,1D0)
13327 IF(I.EQ.6) WID2=WIDS(6,1)
13328 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
13329 ELSEIF(I.LE.16) THEN
13330C...Z'0 -> l+ + l-, nu + nubar
13331 EF=KCHG(I+2,1)/3D0
13332 AF=SIGN(1D0,EF+0.1D0)
13333 VF=AF-4D0*EF*XWV
13334 VPF=PARU(127-2*MOD(I,2))
13335 APF=PARU(128-2*MOD(I,2))
13336 FCOF=1D0
13337 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
13338 ENDIF
13339 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
13340 IF(ICASE.EQ.1) THEN
13341 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13342 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
13343 & APF**2*(1D0-4D0*RM1))*BE34
13344 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13345 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
13346 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13347 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
13348 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
13349 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
13350 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
13351 ELSEIF(MINT(61).EQ.2) THEN
13352 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
13353 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
13354 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
13355 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13356 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
13357 & BE34
13358 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
13359 & BE34
13360 ENDIF
13361 ELSEIF(I.EQ.17) THEN
13362C...Z'0 -> W+ + W-
13363 WDTPZP=PARU(129)**2*XW1**2*
13364 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13365 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13366 IF(ICASE.EQ.1) THEN
13367 WDTPZ=0D0
13368 WDTP(I)=FAC*WDTPZP
13369 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13370 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13371 ELSEIF(MINT(61).EQ.2) THEN
13372 FGGF=0D0
13373 FGZF=0D0
13374 FGZPF=0D0
13375 FZZF=0D0
13376 FZZPF=0D0
13377 FZPZPF=WDTPZP
13378 ENDIF
13379 WID2=WIDS(24,1)
13380 ELSEIF(I.EQ.18) THEN
13381C...Z'0 -> H+ + H-
13382 CZC=2D0*(1D0-2D0*XW)
13383 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
13384 IF(ICASE.EQ.1) THEN
13385 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
13386 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
13387 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13388 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
13389 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
13390 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
13391 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
13392 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
13393 ELSEIF(MINT(61).EQ.2) THEN
13394 FGGF=0.25D0*BE34C
13395 FGZF=0.25D0*PARU(142)*CZC*BE34C
13396 FGZPF=0.25D0*PARU(143)*CZC*BE34C
13397 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
13398 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
13399 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
13400 ENDIF
13401 WID2=WIDS(37,1)
13402 ELSEIF(I.EQ.19) THEN
13403C...Z'0 -> Z0 + gamma.
13404 ELSEIF(I.EQ.20) THEN
13405C...Z'0 -> Z0 + h0
13406 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13407 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
13408 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
13409 IF(ICASE.EQ.1) THEN
13410 WDTPZ=0D0
13411 WDTP(I)=FAC*WDTPZP
13412 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13413 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13414 ELSEIF(MINT(61).EQ.2) THEN
13415 FGGF=0D0
13416 FGZF=0D0
13417 FGZPF=0D0
13418 FZZF=0D0
13419 FZZPF=0D0
13420 FZPZPF=WDTPZP
13421 ENDIF
13422 WID2=WIDS(23,2)*WIDS(25,2)
13423 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
13424C...Z' -> h0 + A0 or H0 + A0.
13425 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13426 IF(I.EQ.21) THEN
13427 CZAH=PARU(186)
13428 CZPAH=PARU(188)
13429 ELSE
13430 CZAH=PARU(187)
13431 CZPAH=PARU(189)
13432 ENDIF
13433 IF(ICASE.EQ.1) THEN
13434 WDTPZ=CZAH**2*BE34C
13435 WDTP(I)=FAC*CZPAH**2*BE34C
13436 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13437 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
13438 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
13439 & VINT(116))*BE34C
13440 ELSEIF(MINT(61).EQ.2) THEN
13441 FGGF=0D0
13442 FGZF=0D0
13443 FGZPF=0D0
13444 FZZF=CZAH**2*BE34C
13445 FZZPF=CZAH*CZPAH*BE34C
13446 FZPZPF=CZPAH**2*BE34C
13447 ENDIF
13448 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
13449 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
13450 ENDIF
13451 IF(ICASE.EQ.1) THEN
13452 VINT(117)=VINT(117)+WDTPZ
13453 WDTP(0)=WDTP(0)+WDTP(I)
13454 ENDIF
13455 IF(MDME(IDC,1).GT.0) THEN
13456 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
13457 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
13458 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13459 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
13460 & WDTE(I,MDME(IDC,1))
13461 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13462 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13463 ENDIF
13464 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
13465 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13466 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
13467 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
13468 & FGZF*WID2
13469 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
13470 & FGZPF*WID2
13471 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13472 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
13473 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
13474 & FZZPF*WID2
13475 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13476 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
13477 ENDIF
13478 ENDIF
13479 280 CONTINUE
13480 IF(MINT(61).GE.1) ICASE=3-ICASE
13481 IF(ICASE.EQ.2) GOTO 270
13482
13483 ELSEIF(KFLA.EQ.34) THEN
13484C...W'+/-:
13485 FAC=(AEM/(24D0*XW))*SHR
13486 DO 290 I=1,MDCY(KC,3)
13487 IDC=I+MDCY(KC,2)-1
13488 IF(MDME(IDC,1).LT.0) GOTO 290
13489 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13490 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13491 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
13492 WID2=1D0
13493 IF(I.LE.20) THEN
13494 IF(I.LE.16) THEN
13495C...W'+/- -> q + qbar'
13496 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
13497 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
13498 IF(KFLR.GT.0) THEN
13499 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
13500 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
13501 IF(I.GE.13) WID2=WID2*WIDS(7,3)
13502 ELSE
13503 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
13504 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
13505 IF(I.GE.13) WID2=WID2*WIDS(7,2)
13506 ENDIF
13507 ELSEIF(I.LE.20) THEN
13508C...W'+/- -> l+/- + nu
13509 FCOF=PARU(133)**2+PARU(134)**2
13510 IF(KFLR.GT.0) THEN
13511 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13512 ELSE
13513 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13514 ENDIF
13515 ENDIF
13516 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13517 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13518 ELSEIF(I.EQ.21) THEN
13519C...W'+/- -> W+/- + Z0
13520 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
13521 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13522 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13523 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
13524 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
13525 ELSEIF(I.EQ.23) THEN
13526C...W'+/- -> W+/- + h0
13527 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13528 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
13529 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13530 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13531 ENDIF
13532 WDTP(0)=WDTP(0)+WDTP(I)
13533 IF(MDME(IDC,1).GT.0) THEN
13534 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13535 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13536 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13537 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13538 ENDIF
13539 290 CONTINUE
13540
13541 ELSEIF(KFLA.EQ.37) THEN
13542C...H+/-:
13543 FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
13544 DO 300 I=1,MDCY(KC,3)
13545 IDC=I+MDCY(KC,2)-1
13546 IF(MDME(IDC,1).LT.0) GOTO 300
13547 KFC1=PYCOMP(KFDP(IDC,1))
13548 KFC2=PYCOMP(KFDP(IDC,2))
13549 RM1=PMAS(KFC1,1)**2/SH
13550 RM2=PMAS(KFC2,1)**2/SH
13551 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
13552 WID2=1D0
13553 IF(I.LE.4) THEN
13554C...H+/- -> q + qbar'
13555 RM1R=RM1
13556 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) RM1R=RM1*
13557 & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
13558 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
13559 WDTP(I)=FAC*3D0*RADC*((RM1R*PARU(141)**2+RM2/PARU(141)**2)*
13560 & (1D0-RM1R-RM2)-4D0*RM1R*RM2)*
13561 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13562 IF(KFLR.GT.0) THEN
13563 IF(I.EQ.3) WID2=WIDS(6,2)
13564 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
13565 ELSE
13566 IF(I.EQ.3) WID2=WIDS(6,3)
13567 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
13568 ENDIF
13569 ELSEIF(I.LE.8) THEN
13570C...H+/- -> l+/- + nu
13571 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
13572 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-
13573 & 4D0*RM1*RM2))
13574 IF(KFLR.GT.0) THEN
13575 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
13576 ELSE
13577 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
13578 ENDIF
13579 ELSEIF(I.EQ.9) THEN
13580C...H+/- -> W+/- + h0.
13581 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
13582 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13583 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13584 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13585
13586CMRENNA++
13587 ELSE
13588C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13589 RM10=RM1*SH/PMR**2
13590 RM20=RM2*SH/PMR**2
13591 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13592 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13593 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13594 WFAC=0D0
13595 ELSE
13596 WFAC=WFAC/WFAC0
13597 ENDIF
13598 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13599CMRENNA--
13600 KSGN1=2
13601 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
13602 KSGN2=2
13603 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
13604 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13605 ENDIF
13606 WDTP(0)=WDTP(0)+WDTP(I)
13607 IF(MDME(IDC,1).GT.0) THEN
13608 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13609 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13610 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13611 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13612 ENDIF
13613 300 CONTINUE
13614
13615 ELSEIF(KFLA.EQ.38) THEN
13616C...Techni-eta.
13617 FAC=(SH/PARP(46)**2)*SHR
13618 DO 310 I=1,MDCY(KC,3)
13619 IDC=I+MDCY(KC,2)-1
13620 IF(MDME(IDC,1).LT.0) GOTO 310
13621 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13622 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13623 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
13624 WID2=1D0
13625 IF(I.LE.2) THEN
13626 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
13627 IF(I.EQ.2) WID2=WIDS(6,1)
13628 ELSE
13629 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
13630 ENDIF
13631 WDTP(0)=WDTP(0)+WDTP(I)
13632 IF(MDME(IDC,1).GT.0) THEN
13633 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13634 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13635 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13636 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13637 ENDIF
13638 310 CONTINUE
13639
13640 ELSEIF(KFLA.EQ.39) THEN
13641C...LQ (leptoquark).
13642 FAC=(AEM/4D0)*PARU(151)*SHR
13643 DO 320 I=1,MDCY(KC,3)
13644 IDC=I+MDCY(KC,2)-1
13645 IF(MDME(IDC,1).LT.0) GOTO 320
13646 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13647 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13648 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
13649 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13650 WID2=1D0
13651 WDTP(0)=WDTP(0)+WDTP(I)
13652 IF(MDME(IDC,1).GT.0) THEN
13653 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13654 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13655 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13656 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13657 ENDIF
13658 320 CONTINUE
13659
13660 ELSEIF(KFLA.EQ.40) THEN
13661C...R:
13662 FAC=(AEM/(12D0*XW))*SHR
13663 DO 330 I=1,MDCY(KC,3)
13664 IDC=I+MDCY(KC,2)-1
13665 IF(MDME(IDC,1).LT.0) GOTO 330
13666 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13667 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13668 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
13669 WID2=1D0
13670 IF(I.LE.6) THEN
13671C...R -> q + qbar'
13672 FCOF=3D0*RADC
13673 ELSEIF(I.LE.9) THEN
13674C...R -> l+ + l'-
13675 FCOF=1D0
13676 ENDIF
13677 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
13678 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13679 IF(KFLR.GT.0) THEN
13680 IF(I.EQ.4) WID2=WIDS(6,3)
13681 IF(I.EQ.5) WID2=WIDS(7,3)
13682 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
13683 IF(I.EQ.9) WID2=WIDS(17,3)
13684 ELSE
13685 IF(I.EQ.4) WID2=WIDS(6,2)
13686 IF(I.EQ.5) WID2=WIDS(7,2)
13687 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
13688 IF(I.EQ.9) WID2=WIDS(17,2)
13689 ENDIF
13690 WDTP(0)=WDTP(0)+WDTP(I)
13691 IF(MDME(IDC,1).GT.0) THEN
13692 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13693 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13694 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13695 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13696 ENDIF
13697 330 CONTINUE
13698
13699 ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.52) THEN
13700C...Techni-pi0 and techni-pi+-:
13701 FAC=(3D0/(32D0*PARU(1)*PARP(142)**2))*SHR
13702 DO 340 I=1,MDCY(KC,3)
13703 IDC=I+MDCY(KC,2)-1
13704 IF(MDME(IDC,1).LT.0) GOTO 340
13705 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
13706 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
13707 RM1=PM1**2/SH
13708 RM2=PM2**2/SH
13709 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
13710 WID2=1D0
13711C...pi_tech -> f + f'.
13712 FCOF=1D0
13713 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
13714 WDTP(I)=FAC*FCOF*(PM1+PM2)**2*
13715 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13716 WDTP(0)=WDTP(0)+WDTP(I)
13717 IF(MDME(IDC,1).GT.0) THEN
13718 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13719 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13720 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13721 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13722 ENDIF
13723 340 CONTINUE
13724
13725 ELSEIF(KFLA.EQ.53) THEN
13726C...Techni-pi'0 not yet implemented.
13727
13728 ELSEIF(KFLA.EQ.54) THEN
13729C...Techni-rho0:
13730 ALPRHT=2.91D0*(3D0/PARP(144))
13731 FAC=(ALPRHT/12D0)*SHR
13732 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)
13733 SQMZ=PMAS(23,1)**2
13734 GMMZ=PMAS(23,1)*PMAS(23,2)
13735 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13736 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13737 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13738 DO 350 I=1,MDCY(KC,3)
13739 IDC=I+MDCY(KC,2)-1
13740 IF(MDME(IDC,1).LT.0) GOTO 350
13741 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13742 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13743 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 350
13744 IF(I.EQ.1) THEN
13745C...rho_tech0 -> W+ + W-.
13746 WDTP(I)=FAC*PARP(141)**4*
13747 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13748 WID2=WIDS(24,1)
13749 ELSEIF(I.EQ.2) THEN
13750C...rho_tech0 -> W+ + pi_tech-.
13751 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13752 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13753 WID2=WIDS(24,2)*WIDS(52,3)
13754 ELSEIF(I.EQ.3) THEN
13755C...rho_tech0 -> pi_tech+ + W-.
13756 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13757 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13758 WID2=WIDS(52,2)*WIDS(24,3)
13759 ELSEIF(I.EQ.4) THEN
13760C...rho_tech0 -> pi_tech+ + pi_tech-.
13761 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13762 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13763 WID2=WIDS(52,1)
13764 ELSE
13765C...rho_tech0 -> f + fbar.
13766 WID2=1D0
13767 IF(I.LE.12) THEN
13768 IA=I-4
13769 FCOF=3D0*RADC
13770 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13771 ELSE
13772 IA=I-2
13773 FCOF=1D0
13774 IF(IA.GE.17) WID2=WIDS(IA,1)
13775 ENDIF
13776 EI=KCHG(IA,1)/3D0
13777 AI=SIGN(1D0,EI+0.1D0)
13778 VI=AI-4D0*EI*XWV
13779 VALI=0.5D0*(VI+AI)
13780 VARI=0.5D0*(VI-AI)
13781 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13782 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
13783 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
13784 ENDIF
13785 WDTP(0)=WDTP(0)+WDTP(I)
13786 IF(MDME(IDC,1).GT.0) THEN
13787 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13788 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13789 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13790 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13791 ENDIF
13792 350 CONTINUE
13793
13794 ELSEIF(KFLA.EQ.55) THEN
13795C...Techni-rho+/-:
13796 ALPRHT=2.91D0*(3D0/PARP(144))
13797 FAC=(ALPRHT/12D0)*SHR
13798 SQMW=PMAS(24,1)**2
13799 GMMW=PMAS(24,1)*PMAS(24,2)
13800 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13801 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
13802 DO 360 I=1,MDCY(KC,3)
13803 IDC=I+MDCY(KC,2)-1
13804 IF(MDME(IDC,1).LT.0) GOTO 360
13805 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13806 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13807 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
13808 IF(I.EQ.1) THEN
13809C...rho_tech+ -> W+ + Z0.
13810 WDTP(I)=FAC*PARP(141)**4*
13811 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13812 IF(KFLR.GT.0) THEN
13813 WID2=WIDS(24,2)*WIDS(23,2)
13814 ELSE
13815 WID2=WIDS(24,3)*WIDS(23,2)
13816 ENDIF
13817 ELSEIF(I.EQ.2) THEN
13818C...rho_tech+ -> W+ + pi_tech0.
13819 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13820 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13821 IF(KFLR.GT.0) THEN
13822 WID2=WIDS(24,2)*WIDS(51,2)
13823 ELSE
13824 WID2=WIDS(24,3)*WIDS(51,2)
13825 ENDIF
13826 ELSEIF(I.EQ.3) THEN
13827C...rho_tech+ -> pi_tech+ + Z0.
13828 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13829 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13830 IF(KFLR.GT.0) THEN
13831 WID2=WIDS(52,2)*WIDS(23,2)
13832 ELSE
13833 WID2=WIDS(52,3)*WIDS(23,2)
13834 ENDIF
13835 ELSEIF(I.EQ.4) THEN
13836C...rho_tech+ -> pi_tech+ + pi_tech0.
13837 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13838 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13839 IF(KFLR.GT.0) THEN
13840 WID2=WIDS(52,2)*WIDS(51,2)
13841 ELSE
13842 WID2=WIDS(52,3)*WIDS(51,2)
13843 ENDIF
13844 ELSE
13845C...rho_tech+ -> f + fbar'.
13846 IA=I-4
13847 WID2=1D0
13848 IF(IA.LE.16) THEN
13849 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
13850 IF(KFLR.GT.0) THEN
13851 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
13852 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
13853 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
13854 ELSE
13855 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
13856 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
13857 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
13858 ENDIF
13859 ELSE
13860 FCOF=1D0
13861 IF(KFLR.GT.0) THEN
13862 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13863 ELSE
13864 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13865 ENDIF
13866 ENDIF
13867 WDTP(I)=FACF*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13868 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13869 ENDIF
13870 WDTP(0)=WDTP(0)+WDTP(I)
13871 IF(MDME(IDC,1).GT.0) THEN
13872 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13873 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13874 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13875 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13876 ENDIF
13877 360 CONTINUE
13878
13879 ELSEIF(KFLA.EQ.56) THEN
13880C...Techni-omega:
13881 ALPRHT=2.91D0*(3D0/PARP(144))
13882 FAC=(AEM/24D0)*(SHR**3/PARP(145)**2)
13883 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13884 & (2D0*PARP(143)-1D0)**2
13885 SQMZ=PMAS(23,1)**2
13886 GMMZ=PMAS(23,1)*PMAS(23,2)
13887 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13888 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13889 DO 370 I=1,MDCY(KC,3)
13890 IDC=I+MDCY(KC,2)-1
13891 IF(MDME(IDC,1).LT.0) GOTO 370
13892 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13893 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13894 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
13895 IF(I.EQ.1) THEN
13896C...omega_tech0 -> gamma + pi_tech0.
13897 WDTP(I)=FAC*
13898 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13899 WID2=WIDS(51,2)
13900 ELSEIF(I.EQ.2) THEN
13901C...omega_tech0 -> Z0 + pi_tech0 not known.
13902 WDTP(I)=0D0
13903 WID2=WIDS(23,2)*WIDS(51,2)
13904 ELSE
13905C...omega_tech0 -> f + fbar.
13906 WID2=1D0
13907 IF(I.LE.10) THEN
13908 IA=I-2
13909 FCOF=3D0*RADC
13910 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13911 ELSE
13912 IA=I
13913 FCOF=1D0
13914 IF(IA.GE.17) WID2=WIDS(IA,1)
13915 ENDIF
13916 EI=KCHG(IA,1)/3D0
13917 AI=SIGN(1D0,EI+0.1D0)
13918 VI=AI-4D0*EI*XWV
13919 VALI=0.5D0*(VI+AI)
13920 VARI=0.5D0*(VI-AI)
13921 WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13922 & ((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
13923 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
13924 ENDIF
13925 WDTP(0)=WDTP(0)+WDTP(I)
13926 IF(MDME(IDC,1).GT.0) THEN
13927 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13928 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13929 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13930 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13931 ENDIF
13932 370 CONTINUE
13933
13934 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
13935C...d* excited quark.
13936 FAC=(SH/PARU(155)**2)*SHR
13937 DO 380 I=1,MDCY(KC,3)
13938 IDC=I+MDCY(KC,2)-1
13939 IF(MDME(IDC,1).LT.0) GOTO 380
13940 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13941 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13942 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
13943 IF(I.EQ.1) THEN
13944C...d* -> g + d.
13945 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13946 WID2=1D0
13947 ELSEIF(I.EQ.2) THEN
13948C...d* -> gamma + d.
13949 QF=-PARU(157)/2D0+PARU(158)/6D0
13950 WDTP(I)=FAC*AEM*QF**2/4D0
13951 WID2=1D0
13952 ELSEIF(I.EQ.3) THEN
13953C...d* -> Z0 + d.
13954 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13955 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13956 & (1D0-RM1)**2*(2D0+RM1)
13957 WID2=WIDS(23,2)
13958 ELSEIF(I.EQ.4) THEN
13959C...d* -> W- + u.
13960 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13961 & (1D0-RM1)**2*(2D0+RM1)
13962 IF(KFLR.GT.0) WID2=WIDS(24,3)
13963 IF(KFLR.LT.0) WID2=WIDS(24,2)
13964 ENDIF
13965 WDTP(0)=WDTP(0)+WDTP(I)
13966 IF(MDME(IDC,1).GT.0) THEN
13967 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13968 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13969 WDTE(I,0)=WDTE(I,MDME(IDC,1))
13970 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13971 ENDIF
13972 380 CONTINUE
13973
13974 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
13975C...u* excited quark.
13976 FAC=(SH/PARU(155)**2)*SHR
13977 DO 390 I=1,MDCY(KC,3)
13978 IDC=I+MDCY(KC,2)-1
13979 IF(MDME(IDC,1).LT.0) GOTO 390
13980 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13981 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13982 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
13983 IF(I.EQ.1) THEN
13984C...u* -> g + u.
13985 WDTP(I)=FAC*AS*PARU(159)**2/3D0
13986 WID2=1D0
13987 ELSEIF(I.EQ.2) THEN
13988C...u* -> gamma + u.
13989 QF=PARU(157)/2D0+PARU(158)/6D0
13990 WDTP(I)=FAC*AEM*QF**2/4D0
13991 WID2=1D0
13992 ELSEIF(I.EQ.3) THEN
13993C...u* -> Z0 + u.
13994 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13995 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13996 & (1D0-RM1)**2*(2D0+RM1)
13997 WID2=WIDS(23,2)
13998 ELSEIF(I.EQ.4) THEN
13999C...u* -> W+ + d.
14000 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14001 & (1D0-RM1)**2*(2D0+RM1)
14002 IF(KFLR.GT.0) WID2=WIDS(24,2)
14003 IF(KFLR.LT.0) WID2=WIDS(24,3)
14004 ENDIF
14005 WDTP(0)=WDTP(0)+WDTP(I)
14006 IF(MDME(IDC,1).GT.0) THEN
14007 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14008 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14009 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14010 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14011 ENDIF
14012 390 CONTINUE
14013
14014 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
14015C...e* excited lepton.
14016 FAC=(SH/PARU(155)**2)*SHR
14017 DO 400 I=1,MDCY(KC,3)
14018 IDC=I+MDCY(KC,2)-1
14019 IF(MDME(IDC,1).LT.0) GOTO 400
14020 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14021 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14022 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
14023 IF(I.EQ.1) THEN
14024C...e* -> gamma + e.
14025 QF=-PARU(157)/2D0-PARU(158)/2D0
14026 WDTP(I)=FAC*AEM*QF**2/4D0
14027 WID2=1D0
14028 ELSEIF(I.EQ.2) THEN
14029C...e* -> Z0 + e.
14030 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14031 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14032 & (1D0-RM1)**2*(2D0+RM1)
14033 WID2=WIDS(23,2)
14034 ELSEIF(I.EQ.3) THEN
14035C...e* -> W- + nu.
14036 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14037 & (1D0-RM1)**2*(2D0+RM1)
14038 IF(KFLR.GT.0) WID2=WIDS(24,3)
14039 IF(KFLR.LT.0) WID2=WIDS(24,2)
14040 ENDIF
14041 WDTP(0)=WDTP(0)+WDTP(I)
14042 IF(MDME(IDC,1).GT.0) THEN
14043 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14044 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14045 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14046 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14047 ENDIF
14048 400 CONTINUE
14049
14050 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
14051C...nu*_e excited neutrino.
14052 FAC=(SH/PARU(155)**2)*SHR
14053 DO 410 I=1,MDCY(KC,3)
14054 IDC=I+MDCY(KC,2)-1
14055 IF(MDME(IDC,1).LT.0) GOTO 410
14056 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14057 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14058 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
14059 IF(I.EQ.1) THEN
14060C...nu*_e -> Z0 + nu*_e.
14061 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14062 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14063 & (1D0-RM1)**2*(2D0+RM1)
14064 WID2=WIDS(23,2)
14065 ELSEIF(I.EQ.2) THEN
14066C...nu*_e -> W+ + e.
14067 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14068 & (1D0-RM1)**2*(2D0+RM1)
14069 IF(KFLR.GT.0) WID2=WIDS(24,2)
14070 IF(KFLR.LT.0) WID2=WIDS(24,3)
14071 ENDIF
14072 WDTP(0)=WDTP(0)+WDTP(I)
14073 IF(MDME(IDC,1).GT.0) THEN
14074 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14075 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14076 WDTE(I,0)=WDTE(I,MDME(IDC,1))
14077 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14078 ENDIF
14079 410 CONTINUE
14080
14081 ENDIF
14082 MINT(61)=0
14083 MINT(62)=0
14084 MINT(63)=0
14085
14086 RETURN
14087 END
14088
14089C***********************************************************************
14090
14091*$ CREATE PYOFSH.FOR
14092*COPY PYOFSH
14093C...PYOFSH
14094C...Calculates partial width and differential cross-section maxima
14095C...of channels/processes not allowed on mass-shell, and selects
14096C...masses in such channels/processes.
14097
14098 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
14099
14100C...Double precision and integer declarations.
14101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14102 INTEGER PYK,PYCHGE,PYCOMP
14103C...Commonblocks.
14104 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14105 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14106 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
14107 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14108 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14109 COMMON/PYINT1/MINT(400),VINT(400)
14110 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14111 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14112 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
14113 &/PYINT2/,/PYINT5/
14114C...Local arrays.
14115 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
14116 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
14117 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
14118 &WDTE(0:200,0:5)
14119
14120C...Find if particles equal, maximum mass, matrix elements, etc.
14121 MINT(51)=0
14122 ISUB=MINT(1)
14123 KFD(1)=IABS(KFD1)
14124 KFD(2)=IABS(KFD2)
14125 MEQL=0
14126 IF(KFD(1).EQ.KFD(2)) MEQL=1
14127 MLM=0
14128 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
14129 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
14130 NOFF=44
14131 PMMX=PMMO
14132 ELSE
14133 NOFF=40
14134 PMMX=VINT(1)
14135 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
14136 ENDIF
14137 MMED=0
14138 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
14139 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
14140 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
14141 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
14142 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
14143 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
14144 LOOP=1
14145
14146C...Find where Breit-Wigners are required, else select discrete masses.
14147 100 DO 110 I=1,2
14148 KFCA=PYCOMP(KFD(I))
14149 IF(KFCA.GT.0) THEN
14150 PMD(I)=PMAS(KFCA,1)
14151 PGD(I)=PMAS(KFCA,2)
14152 ELSE
14153 PMD(I)=0D0
14154 PGD(I)=0D0
14155 ENDIF
14156 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
14157 MBW(I)=0
14158 PMG(I)=PMD(I)
14159 RMG(I)=(PMG(I)/PMMX)**2
14160 ELSE
14161 MBW(I)=1
14162 ENDIF
14163 110 CONTINUE
14164
14165C...Find allowed mass range and Breit-Wigner parameters.
14166 DO 120 I=1,2
14167 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
14168 PML(I)=PARP(42)
14169 PMU(I)=PMMX-PARP(42)
14170 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14171 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14172 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
14173 ILM=I
14174 IF(MLM.EQ.2) ILM=3-I
14175 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
14176 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
14177 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=MIN(PMU(I),
14178 & CKIN(NOFF+2*ILM))
14179 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14180 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14181 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14182 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14183 IF(MBW(I).EQ.1) THEN
14184 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14185 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14186 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14187 & PGD(I)))
14188 ENDIF
14189 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
14190 ILM=I
14191 IF(MLM.EQ.2) ILM=3-I
14192 PML(I)=MAX(CKIN(48+I),PARP(42))
14193 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
14194 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14195 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14196 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14197 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14198 IF(MBW(I).EQ.1) THEN
14199 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14200 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14201 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14202 & PGD(I)))
14203 ENDIF
14204 ENDIF
14205 120 CONTINUE
14206 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
14207 &THEN
14208 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
14209 MINT(51)=1
14210 RETURN
14211 ENDIF
14212
14213C...Calculation of partial width of resonance.
14214 IF(MOFSH.EQ.1) THEN
14215
14216C..If only one integration, pick that to be the inner.
14217 IF(MBW(1).EQ.0) THEN
14218 PM2=PMD(1)
14219 PMD(1)=PMD(2)
14220 PGD(1)=PGD(2)
14221 PML(1)=PML(2)
14222 PMU(1)=PMU(2)
14223 ELSEIF(MBW(2).EQ.0) THEN
14224 PM2=PMD(2)
14225 ENDIF
14226
14227C...Start outer loop of integration.
14228 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14229 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14230 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14231 NPT2=1
14232 XPT2(1)=1D0
14233 INX2(1)=0
14234 FMAX2=0D0
14235 ENDIF
14236 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14237 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
14238 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
14239 ENDIF
14240 RM2=(PM2/PMMX)**2
14241
14242C...Start inner loop of integration.
14243 PML1=PML(1)
14244 PMU1=MIN(PMU(1),PMMX-PM2)
14245 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
14246 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14247 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14248 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
14249 FUNC2=0D0
14250 GOTO 180
14251 ENDIF
14252 NPT1=1
14253 XPT1(1)=1D0
14254 INX1(1)=0
14255 FMAX1=0D0
14256 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
14257 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
14258 RM1=(PM1/PMMX)**2
14259
14260C...Evaluate function value - inner loop.
14261 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
14262 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
14263 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
14264 & RM2**2+10D0*RM1*RM2)
14265 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
14266 FPT1(NPT1)=FUNC1
14267
14268C...Go to next position in inner loop.
14269 IF(NPT1.EQ.1) THEN
14270 NPT1=NPT1+1
14271 XPT1(NPT1)=0D0
14272 INX1(NPT1)=1
14273 GOTO 140
14274 ELSEIF(NPT1.LE.8) THEN
14275 NPT1=NPT1+1
14276 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
14277 ISH1=ISH1+1
14278 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14279 INX1(NPT1)=INX1(ISH1)
14280 INX1(ISH1)=NPT1
14281 GOTO 140
14282 ELSEIF(NPT1.LT.100) THEN
14283 ISN1=ISH1
14284 150 ISH1=ISH1+1
14285 IF(ISH1.GT.NPT1) ISH1=2
14286 IF(ISH1.EQ.ISN1) GOTO 160
14287 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
14288 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
14289 NPT1=NPT1+1
14290 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14291 INX1(NPT1)=INX1(ISH1)
14292 INX1(ISH1)=NPT1
14293 GOTO 140
14294 ENDIF
14295
14296C...Calculate integral over inner loop.
14297 160 FSUM1=0D0
14298 DO 170 IPT1=2,NPT1
14299 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
14300 & (XPT1(INX1(IPT1))-XPT1(IPT1))
14301 170 CONTINUE
14302 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
14303 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14304 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
14305 FPT2(NPT2)=FUNC2
14306
14307C...Go to next position in outer loop.
14308 IF(NPT2.EQ.1) THEN
14309 NPT2=NPT2+1
14310 XPT2(NPT2)=0D0
14311 INX2(NPT2)=1
14312 GOTO 130
14313 ELSEIF(NPT2.LE.8) THEN
14314 NPT2=NPT2+1
14315 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
14316 ISH2=ISH2+1
14317 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14318 INX2(NPT2)=INX2(ISH2)
14319 INX2(ISH2)=NPT2
14320 GOTO 130
14321 ELSEIF(NPT2.LT.100) THEN
14322 ISN2=ISH2
14323 190 ISH2=ISH2+1
14324 IF(ISH2.GT.NPT2) ISH2=2
14325 IF(ISH2.EQ.ISN2) GOTO 200
14326 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
14327 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
14328 NPT2=NPT2+1
14329 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14330 INX2(NPT2)=INX2(ISH2)
14331 INX2(ISH2)=NPT2
14332 GOTO 130
14333 ENDIF
14334
14335C...Calculate integral over outer loop.
14336 200 FSUM2=0D0
14337 DO 210 IPT2=2,NPT2
14338 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
14339 & (XPT2(INX2(IPT2))-XPT2(IPT2))
14340 210 CONTINUE
14341 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
14342 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
14343 ELSE
14344 FSUM2=FUNC2
14345 ENDIF
14346
14347C...Save result; second integration for user-selected mass range.
14348 IF(LOOP.EQ.1) WIDW=FSUM2
14349 WID2=FSUM2
14350 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
14351 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
14352 LOOP=2
14353 GOTO 100
14354 ENDIF
14355 RET1=WIDW
14356 RET2=WID2/WIDW
14357
14358C...Select two decay product masses of a resonance.
14359 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
14360 220 DO 230 I=1,2
14361 IF(MBW(I).EQ.0) GOTO 230
14362 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
14363 & (ATU(I)-ATL(I)))
14364 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
14365 RMG(I)=(PMG(I)/PMMX)**2
14366 230 CONTINUE
14367 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14368 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
14369
14370C...Weight with matrix element (if none known, use beta factor).
14371 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
14372 IF(MMED.EQ.1) THEN
14373 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
14374 ELSEIF(MMED.EQ.2) THEN
14375 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
14376 & RMG(2)**2+10D0*RMG(1)*RMG(2))
14377 ELSEIF(MMED.EQ.3) THEN
14378 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
14379 ELSE
14380 WTBE=FLAM
14381 ENDIF
14382 IF(WTBE.LT.PYR(0)) GOTO 220
14383 RET1=PMG(1)
14384 RET2=PMG(2)
14385
14386C...Find suitable set of masses for initialization of 2 -> 2 processes.
14387 ELSEIF(MOFSH.EQ.3) THEN
14388 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
14389 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
14390 PMG(2)=PMD(2)
14391 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
14392 PMG(1)=PMD(1)
14393 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
14394 ELSE
14395 IDIV=-1
14396 240 IDIV=IDIV+1
14397 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
14398 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
14399 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
14400 ENDIF
14401 RET1=PMG(1)
14402 RET2=PMG(2)
14403
14404C...Evaluate importance of excluded tails of Breit-Wigners.
14405 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14406 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14407 IF(MEQL.LE.1) THEN
14408 VINT(80)=1D0
14409 DO 250 I=1,2
14410 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
14411 & PARU(1)
14412 250 CONTINUE
14413 ELSE
14414 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
14415 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
14416 ENDIF
14417 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
14418 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
14419 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
14420 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14421
14422C...Pick one particle to be the lighter (if improves efficiency).
14423 ELSEIF(MOFSH.EQ.4) THEN
14424 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14425 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14426 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
14427
14428C...Select two masses according to Breit-Wigner + flat in s + 1/s.
14429 DO 270 I=1,2
14430 IF(MBW(I).EQ.0) GOTO 270
14431 PMV=PMU(I)
14432 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14433 ATV=ATU(I)
14434 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14435 RBR=PYR(0)
14436 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14437 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
14438 IF(RBR.LT.0.8D0) THEN
14439 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
14440 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
14441 ELSEIF(RBR.LT.0.9D0) THEN
14442 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
14443 ELSEIF(RBR.LT.1.5D0) THEN
14444 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
14445 ELSE
14446 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
14447 & (PMV**2-PML(I)**2))))
14448 ENDIF
14449 270 CONTINUE
14450 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14451 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
14452 IF(MINT(48).EQ.1) THEN
14453 NGEN(0,1)=NGEN(0,1)+1
14454 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
14455 GOTO 260
14456 ELSE
14457 MINT(51)=1
14458 RETURN
14459 ENDIF
14460 ENDIF
14461 RET1=PMG(1)
14462 RET2=PMG(2)
14463
14464C...Give weight for selected mass distribution.
14465 VINT(80)=1D0
14466 DO 280 I=1,2
14467 IF(MBW(I).EQ.0) GOTO 280
14468 PMV=PMU(I)
14469 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14470 ATV=ATU(I)
14471 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14472 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
14473 & (PMD(I)*PGD(I))**2)/PARU(1)
14474 F1=1D0
14475 F2=1D0/PMG(I)**2
14476 F3=1D0/PMG(I)**4
14477 FI0=(ATV-ATL(I))/PARU(1)
14478 FI1=PMV**2-PML(I)**2
14479 FI2=2D0*LOG(PMV/PML(I))
14480 FI3=1D0/PML(I)**2-1D0/PMV**2
14481 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14482 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
14483 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
14484 & 5D0*F3/FI3))
14485 ELSE
14486 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
14487 ENDIF
14488 VINT(80)=VINT(80)*FI0
14489 280 CONTINUE
14490 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14491 ENDIF
14492
14493 RETURN
14494 END
14495
14496C***********************************************************************
14497
14498*$ CREATE PYRECO.FOR
14499*COPY PYRECO
14500C...PYRECO
14501C...Handles the possibility of colour reconnection in W+W- events,
14502C...Based on the main scenarios of the Sjostrand and Khoze study:
14503C...I, II, II', intermediate and instantaneous; plus one model
14504C...along the lines of the Gustafson and Hakkinen: GH.
14505
14506 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
14507
14508C...Double precision and integer declarations.
14509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14510 INTEGER PYK,PYCHGE,PYCOMP
14511C...Parameter value; number of points in MC integration.
14512 PARAMETER (NPT=100)
14513C...Commonblocks.
14514 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14515 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14516 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14517 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14518 COMMON/PYINT1/MINT(400),VINT(400)
14519 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14520C...Local arrays.
14521 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
14522 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
14523 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
14524 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
14525 &TMC(20),IJOIN(100)
14526
14527C...Functions to give four-product and to do determinants.
14528 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)
14529 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
14530 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
14531 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
14532
14533C...Only allow fraction of recoupling for GH, intermediate and
14534C...instantaneous.
14535 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14536 IF(PYR(0).GT.PARP(120)) RETURN
14537 ENDIF
14538
14539C...Common part for scenarios I, II, II', and GH.
14540 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
14541 &MSTP(115).EQ.5) THEN
14542
14543C...Read out frequently-used parameters.
14544 PI=PARU(1)
14545 HBAR=PARU(3)
14546 PMW=PMAS(24,1)
14547 PGW=PMAS(24,2)
14548 TFRAG=PARP(115)
14549 RHAD=PARP(116)
14550 FACT=PARP(117)
14551 BLOWR=PARP(118)
14552 BLOWT=PARP(119)
14553
14554C...Find range of decay products of the W's.
14555C...Background: the W's are stored in IW1 and IW2.
14556C...Their direct decay products in NSD1+1 through NSD1+4.
14557C...Products after shower (if any) in NSD1+5 through NAFT1
14558C...for first W and in NAFT1+1 through N for the second.
14559 IF(K(IW1,2).GT.0) THEN
14560 JT=1
14561 ELSE
14562 JT=2
14563 ENDIF
14564 JR=3-JT
14565 IF(NAFT1.GT.NSD1+4) THEN
14566 NBEG(JT)=NSD1+5
14567 NEND(JT)=NAFT1
14568 ELSE
14569 NBEG(JT)=NSD1+1
14570 NEND(JT)=NSD1+2
14571 ENDIF
14572 IF(N.GT.NAFT1) THEN
14573 NBEG(JR)=NAFT1+1
14574 NEND(JR)=N
14575 ELSE
14576 NBEG(JR)=NSD1+3
14577 NEND(JR)=NSD1+4
14578 ENDIF
14579
14580C...Rearrange parton shower products along strings.
14581 NOLD=N
14582 CALL PYPREP(NSD1+1)
14583
14584C...Find partons pointing back to W+ and W-; store them with quark
14585C...end of string first.
14586 NNP=0
14587 NNM=0
14588 ISGP=0
14589 ISGM=0
14590 DO 120 I=NOLD+1,N
14591 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
14592 IF(IABS(K(I,2)).GE.22) GOTO 120
14593 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
14594 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
14595 NNP=NNP+1
14596 IF(ISGP.EQ.1) THEN
14597 INP(NNP)=I
14598 ELSE
14599 DO 100 I1=NNP,2,-1
14600 INP(I1)=INP(I1-1)
14601 100 CONTINUE
14602 INP(1)=I
14603 ENDIF
14604 IF(K(I,1).EQ.1) ISGP=0
14605 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
14606 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
14607 NNM=NNM+1
14608 IF(ISGM.EQ.1) THEN
14609 INM(NNM)=I
14610 ELSE
14611 DO 110 I1=NNM,2,-1
14612 INM(I1)=INM(I1-1)
14613 110 CONTINUE
14614 INM(1)=I
14615 ENDIF
14616 IF(K(I,1).EQ.1) ISGM=0
14617 ENDIF
14618 120 CONTINUE
14619
14620C...Boost to W+W- rest frame (not strictly needed).
14621 DO 130 J=1,3
14622 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
14623 130 CONTINUE
14624 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14625 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14626 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14627
14628C...Select decay vertices of W+ and W-.
14629 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
14630 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
14631 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
14632 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
14633 GTMAX=MAX(TP,TM)
14634 DO 140 J=1,3
14635 XP(J)=TP*P(IW1,J)/P(IW1,4)
14636 XM(J)=TM*P(IW2,J)/P(IW2,4)
14637 140 CONTINUE
14638
14639C...Begin scenario I specifics.
14640 IF(MSTP(115).EQ.1) THEN
14641
14642C...Reconstruct velocity and direction of W+ string pieces.
14643 DO 170 IIP=1,NNP-1
14644 IF(K(INP(IIP),2).LT.0) GOTO 170
14645 I1=INP(IIP)
14646 I2=INP(IIP+1)
14647 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14648 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14649 DO 150 J=1,3
14650 V1(J)=P(I1,J)/P1A
14651 V2(J)=P(I2,J)/P2A
14652 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
14653 DIRP(IIP,J)=V1(J)-V2(J)
14654 150 CONTINUE
14655 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
14656 & BETP(IIP,3)**2)
14657 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
14658 DO 160 J=1,3
14659 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
14660 160 CONTINUE
14661 170 CONTINUE
14662
14663C...Reconstruct velocity and direction of W- string pieces.
14664 DO 200 IIM=1,NNM-1
14665 IF(K(INM(IIM),2).LT.0) GOTO 200
14666 I1=INM(IIM)
14667 I2=INM(IIM+1)
14668 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14669 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14670 DO 180 J=1,3
14671 V1(J)=P(I1,J)/P1A
14672 V2(J)=P(I2,J)/P2A
14673 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
14674 DIRM(IIM,J)=V1(J)-V2(J)
14675 180 CONTINUE
14676 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
14677 & BETM(IIM,3)**2)
14678 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
14679 DO 190 J=1,3
14680 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
14681 190 CONTINUE
14682 200 CONTINUE
14683
14684C...Loop over number of space-time points.
14685 NACC=0
14686 SUM=0D0
14687 DO 250 IPT=1,NPT
14688
14689C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
14690 R=SQRT(-LOG(PYR(0)))
14691 PHI=2D0*PI*PYR(0)
14692 X=BLOWR*RHAD*R*COS(PHI)
14693 Y=BLOWR*RHAD*R*SIN(PHI)
14694 R=SQRT(-LOG(PYR(0)))
14695 PHI=2D0*PI*PYR(0)
14696 Z=BLOWR*RHAD*R*COS(PHI)
14697 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
14698
14699C...Weight for sample distribution.
14700 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
14701 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
14702
14703C...Loop over W+ string pieces and find one with largest weight.
14704 IMAXP=0
14705 WTMAXP=1D-10
14706 XD(1)=X-XP(1)
14707 XD(2)=Y-XP(2)
14708 XD(3)=Z-XP(3)
14709 XD(4)=T-TP
14710 DO 220 IIP=1,NNP-1
14711 IF(K(INP(IIP),2).LT.0) GOTO 220
14712 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
14713 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
14714 DO 210 J=1,3
14715 XB(J)=XD(J)+BEDG*BETP(IIP,J)
14716 210 CONTINUE
14717 XB(4)=BETP(IIP,4)*(XD(4)-BED)
14718 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14719 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
14720 & DIRP(IIP,3)*XB(3))**2
14721 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14722 & TFRAG**2)
14723 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
14724 IF(WTP.GT.WTMAXP) THEN
14725 IMAXP=IIP
14726 WTMAXP=WTP
14727 ENDIF
14728 220 CONTINUE
14729
14730C...Loop over W- string pieces and find one with largest weight.
14731 IMAXM=0
14732 WTMAXM=1D-10
14733 XD(1)=X-XM(1)
14734 XD(2)=Y-XM(2)
14735 XD(3)=Z-XM(3)
14736 XD(4)=T-TM
14737 DO 240 IIM=1,NNM-1
14738 IF(K(INM(IIM),2).LT.0) GOTO 240
14739 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
14740 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
14741 DO 230 J=1,3
14742 XB(J)=XD(J)+BEDG*BETM(IIM,J)
14743 230 CONTINUE
14744 XB(4)=BETM(IIM,4)*(XD(4)-BED)
14745 SR2=XB(1)**2+XB(2)**2+XB(3)**2
14746 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
14747 & DIRM(IIM,3)*XB(3))**2
14748 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14749 & TFRAG**2)
14750 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
14751 IF(WTM.GT.WTMAXM) THEN
14752 IMAXM=IIM
14753 WTMAXM=WTM
14754 ENDIF
14755 240 CONTINUE
14756
14757C...Result of integration.
14758 WT=0D0
14759 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
14760 WT=WTMAXP*WTMAXM/WTSMP
14761 SUM=SUM+WT
14762 NACC=NACC+1
14763 IAP(NACC)=IMAXP
14764 IAM(NACC)=IMAXM
14765 WTA(NACC)=WT
14766 ENDIF
14767 250 CONTINUE
14768 RES=BLOWR**3*BLOWT*SUM/NPT
14769
14770C...Decide whether to reconnect and, if so, where.
14771 IACC=0
14772 PREC=1D0-EXP(-FACT*RES)
14773 IF(PREC.GT.PYR(0)) THEN
14774 RSUM=PYR(0)*SUM
14775 DO 260 IA=1,NACC
14776 IACC=IA
14777 RSUM=RSUM-WTA(IA)
14778 IF(RSUM.LE.0D0) GOTO 270
14779 260 CONTINUE
14780 270 IIP=IAP(IACC)
14781 IIM=IAM(IACC)
14782 ENDIF
14783
14784C...Begin scenario II and II' specifics.
14785 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
14786
14787C...Loop through all string pieces, one from W+ and one from W-.
14788 NCROSS=0
14789 TC(0)=0D0
14790 DO 340 IIP=1,NNP-1
14791 IF(K(INP(IIP),2).LT.0) GOTO 340
14792 I1P=INP(IIP)
14793 I2P=INP(IIP+1)
14794 DO 330 IIM=1,NNM-1
14795 IF(K(INM(IIM),2).LT.0) GOTO 330
14796 I1M=INM(IIM)
14797 I2M=INM(IIM+1)
14798
14799C...Find endpoint velocity vectors.
14800 DO 280 J=1,3
14801 V1P(J)=P(I1P,J)/P(I1P,4)
14802 V2P(J)=P(I2P,J)/P(I2P,4)
14803 V1M(J)=P(I1M,J)/P(I1M,4)
14804 V2M(J)=P(I2M,J)/P(I2M,4)
14805 280 CONTINUE
14806
14807C...Define q matrix and find t.
14808 DO 290 J=1,3
14809 Q(1,J)=V2P(J)-V1P(J)
14810 Q(2,J)=-(V2M(J)-V1M(J))
14811 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
14812 Q(4,J)=V1P(J)-V1M(J)
14813 290 CONTINUE
14814 T=-DETER(1,2,3)/DETER(1,2,4)
14815
14816C...Find alpha and beta; i.e. coordinates of crossing point.
14817 S11=Q(1,1)*(T-TP)
14818 S12=Q(2,1)*(T-TM)
14819 S13=Q(3,1)+Q(4,1)*T
14820 S21=Q(1,2)*(T-TP)
14821 S22=Q(2,2)*(T-TM)
14822 S23=Q(3,2)+Q(4,2)*T
14823 DEN=S11*S22-S12*S21
14824 ALP=(S12*S23-S22*S13)/DEN
14825 BET=(S21*S13-S11*S23)/DEN
14826
14827C...Check if solution acceptable.
14828 IANSW=1
14829 IF(T.LT.GTMAX) IANSW=0
14830 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
14831 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
14832
14833C...Find point of crossing and check that not inconsistent.
14834 DO 300 J=1,3
14835 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
14836 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
14837 300 CONTINUE
14838 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
14839 & (XPP(3)-XMM(3))**2
14840 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
14841 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
14842 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
14843
14844C...Find string eigentimes at crossing.
14845 IF(IANSW.EQ.1) THEN
14846 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
14847 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
14848 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
14849 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
14850 ELSE
14851 TAUP=0D0
14852 TAUM=0D0
14853 ENDIF
14854
14855C...Order crossings by time. End loop over crossings.
14856 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
14857 NCROSS=NCROSS+1
14858 DO 310 I1=NCROSS,1,-1
14859 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
14860 IPC(I1)=IIP
14861 IMC(I1)=IIM
14862 TC(I1)=T
14863 TPC(I1)=TAUP
14864 TMC(I1)=TAUM
14865 GOTO 320
14866 ELSE
14867 IPC(I1)=IPC(I1-1)
14868 IMC(I1)=IMC(I1-1)
14869 TC(I1)=TC(I1-1)
14870 TPC(I1)=TPC(I1-1)
14871 TMC(I1)=TMC(I1-1)
14872 ENDIF
14873 310 CONTINUE
14874 320 CONTINUE
14875 ENDIF
14876 330 CONTINUE
14877 340 CONTINUE
14878
14879C...Loop over crossings; find first (if any) acceptable one.
14880 IACC=0
14881 IF(NCROSS.GE.1) THEN
14882 DO 350 IC=1,NCROSS
14883 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
14884 IF(PNFRAG.GT.PYR(0)) THEN
14885C...Scenario II: only compare with fragmentation time.
14886 IF(MSTP(115).EQ.2) THEN
14887 IACC=IC
14888 IIP=IPC(IACC)
14889 IIM=IMC(IACC)
14890 GOTO 360
14891C...Scenario II': also require that string length decreases.
14892 ELSE
14893 IIP=IPC(IC)
14894 IIM=IMC(IC)
14895 I1P=INP(IIP)
14896 I2P=INP(IIP+1)
14897 I1M=INM(IIM)
14898 I2M=INM(IIM+1)
14899 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14900 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14901 IF(ELNEW.LT.ELOLD) THEN
14902 IACC=IC
14903 IIP=IPC(IACC)
14904 IIM=IMC(IACC)
14905 GOTO 360
14906 ENDIF
14907 ENDIF
14908 ENDIF
14909 350 CONTINUE
14910 360 CONTINUE
14911 ENDIF
14912
14913C...Begin scenario GH specifics.
14914 ELSEIF(MSTP(115).EQ.5) THEN
14915
14916C...Loop through all string pieces, one from W+ and one from W-.
14917 IACC=0
14918 ELMIN=1D0
14919 DO 380 IIP=1,NNP-1
14920 IF(K(INP(IIP),2).LT.0) GOTO 380
14921 I1P=INP(IIP)
14922 I2P=INP(IIP+1)
14923 DO 370 IIM=1,NNM-1
14924 IF(K(INM(IIM),2).LT.0) GOTO 370
14925 I1M=INM(IIM)
14926 I2M=INM(IIM+1)
14927
14928C...Look for largest decrease of (exponent of) Lambda measure.
14929 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14930 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14931 ELDIF=ELNEW/MAX(1D-10,ELOLD)
14932 IF(ELDIF.LT.ELMIN) THEN
14933 IACC=IIP+IIM
14934 ELMIN=ELDIF
14935 IPC(1)=IIP
14936 IMC(1)=IIM
14937 ENDIF
14938 370 CONTINUE
14939 380 CONTINUE
14940 IIP=IPC(1)
14941 IIM=IMC(1)
14942 ENDIF
14943
14944C...Common for scenarios I, II, II' and GH: reconnect strings.
14945 IF(IACC.NE.0) THEN
14946 MINT(32)=1
14947 NJOIN=0
14948 DO 390 IS=1,NNP+NNM
14949 NJOIN=NJOIN+1
14950 IF(IS.LE.IIP) THEN
14951 I=INP(IS)
14952 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
14953 I=INM(IS-IIP+IIM)
14954 ELSEIF(IS.LE.IIP+NNM) THEN
14955 I=INM(IS-IIP-NNM+IIM)
14956 ELSE
14957 I=INP(IS-NNM)
14958 ENDIF
14959 IJOIN(NJOIN)=I
14960 IF(K(I,2).LT.0) THEN
14961 CALL PYJOIN(NJOIN,IJOIN)
14962 NJOIN=0
14963 ENDIF
14964 390 CONTINUE
14965
14966C...Restore original event record if no reconnection.
14967 ELSE
14968 DO 400 I=NSD1+1,NOLD
14969 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
14970 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14971 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14972 ENDIF
14973 400 CONTINUE
14974 DO 410 I=NOLD+1,N
14975 K(K(I,3),1)=3
14976 410 CONTINUE
14977 N=NOLD
14978 ENDIF
14979
14980C...Boost back system.
14981 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14982 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14983 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
14984 & BEWW(1),BEWW(2),BEWW(3))
14985
14986C...Common part for intermediate and instantaneous scenarios.
14987 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14988 MINT(32)=1
14989
14990C...Remove old shower products and reset showering ones.
14991 N=NSD1+4
14992 DO 420 I=NSD1+1,NSD1+4
14993 K(I,1)=3
14994 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14995 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14996 420 CONTINUE
14997
14998C...Identify quark-antiquark pairs.
14999 IQ1=NSD1+1
15000 IQ2=NSD1+2
15001 IQ3=NSD1+3
15002 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
15003 IQ4=2*NSD1+7-IQ3
15004
15005C...Reconnect strings.
15006 IJOIN(1)=IQ1
15007 IJOIN(2)=IQ4
15008 CALL PYJOIN(2,IJOIN)
15009 IJOIN(1)=IQ3
15010 IJOIN(2)=IQ2
15011 CALL PYJOIN(2,IJOIN)
15012
15013C...Do new parton showers in intermediate scenario.
15014 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
15015 MSTJ50=MSTJ(50)
15016 MSTJ(50)=0
15017 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
15018 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
15019 MSTJ(50)=MSTJ50
15020
15021C...Do new parton showers in instantaneous scenario.
15022 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
15023 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
15024 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
15025 PPM=SQRT(MAX(0D0,PPM2))
15026 CALL PYSHOW(IQ1,IQ4,PPM)
15027 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
15028 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
15029 PPM=SQRT(MAX(0D0,PPM2))
15030 CALL PYSHOW(IQ3,IQ2,PPM)
15031 ENDIF
15032 ENDIF
15033
15034 RETURN
15035 END
15036
15037C***********************************************************************
15038
15039*$ CREATE PYKLIM.FOR
15040*COPY PYKLIM
15041C...PYKLIM
15042C...Checks generated variables against pre-set kinematical limits;
15043C...also calculates limits on variables used in generation.
15044
15045 SUBROUTINE PYKLIM(ILIM)
15046
15047C...Double precision and integer declarations.
15048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15049 INTEGER PYK,PYCHGE,PYCOMP
15050C...Commonblocks.
15051 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15052 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15053 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15054 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15055 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15056 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15057 COMMON/PYINT1/MINT(400),VINT(400)
15058 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15059 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15060 &/PYINT1/,/PYINT2/
15061
15062C...Common kinematical expressions.
15063 MINT(51)=0
15064 ISUB=MINT(1)
15065 ISTSB=ISET(ISUB)
15066 IF(ISUB.EQ.96) GOTO 100
15067 SQM3=VINT(63)
15068 SQM4=VINT(64)
15069 IF(ILIM.NE.0) THEN
15070 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
15071 CKIN09=MAX(CKIN(9),CKIN(13))
15072 CKIN10=MIN(CKIN(10),CKIN(14))
15073 CKIN11=MAX(CKIN(11),CKIN(15))
15074 CKIN12=MIN(CKIN(12),CKIN(16))
15075 ELSE
15076 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
15077 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
15078 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
15079 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
15080 ENDIF
15081 ENDIF
15082 IF(ILIM.NE.1) THEN
15083 TAU=VINT(21)
15084 RM3=SQM3/(TAU*VINT(2))
15085 RM4=SQM4/(TAU*VINT(2))
15086 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
15087 ENDIF
15088 PTHMIN=CKIN(3)
15089 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
15090 &PTHMIN=MAX(CKIN(3),CKIN(5))
15091
15092 IF(ILIM.EQ.0) THEN
15093C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15094C...pre-set kinematical limits.
15095 YST=VINT(22)
15096 CTH=VINT(23)
15097 TAUP=VINT(26)
15098 TAUE=TAU
15099 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
15100 X1=SQRT(TAUE)*EXP(YST)
15101 X2=SQRT(TAUE)*EXP(-YST)
15102 XF=X1-X2
15103 IF(MINT(47).NE.1) THEN
15104 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
15105 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
15106 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
15107 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
15108 ENDIF
15109 IF(MINT(45).NE.1) THEN
15110 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
15111 ENDIF
15112 IF(MINT(46).NE.1) THEN
15113 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
15114 ENDIF
15115 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
15116 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
15117 EXPY3=MAX(1.D-10,(1D0+RM3-RM4+BE34*CTH)/
15118 & MAX(1.D-10,(1D0+RM3-RM4-BE34*CTH)))
15119 EXPY4=MAX(1.D-10,(1D0-RM3+RM4-BE34*CTH)/
15120 & MAX(1.D-10,(1D0-RM3+RM4+BE34*CTH)))
15121 Y3=YST+0.5D0*LOG(EXPY3)
15122 Y4=YST+0.5D0*LOG(EXPY4)
15123 YLARGE=MAX(Y3,Y4)
15124 YSMALL=MIN(Y3,Y4)
15125 ETALAR=10D0
15126 ETASMA=-10D0
15127 STH=SQRT(MAX(0D0,1D0-CTH**2))
15128 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
15129 & CTH)**2-4D0*RM3))
15130 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
15131 & CTH)**2-4D0*RM4))
15132 IF(STH.GE.1.D-6) THEN
15133 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
15134 & (BE34*STH)
15135 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
15136 & (BE34*STH)
15137 ETA3=LOG(MIN(1.D10,MAX(1.D-10,EXPET3)))
15138 ETA4=LOG(MIN(1.D10,MAX(1.D-10,EXPET4)))
15139 ETALAR=MAX(ETA3,ETA4)
15140 ETASMA=MIN(ETA3,ETA4)
15141 ENDIF
15142 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
15143 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
15144 CTSLAR=MIN(1D0,MAX(CTS3,CTS4))
15145 CTSSMA=MAX(-1D0,MIN(CTS3,CTS4))
15146 SH=TAU*VINT(2)
15147 RPTS=4D0*VINT(71)**2/SH
15148 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
15149 RM34=MAX(1D-20,2D0*RM3*RM4)
15150 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15151 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15152 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
15153 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
15154 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
15155 IF(PTH.LT.PTHMIN) MINT(51)=1
15156 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
15157 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
15158 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
15159 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
15160 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
15161 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
15162 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
15163 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
15164 IF(THA.LT.CKIN(35)) MINT(51)=1
15165 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
15166 IF(UHA.LT.CKIN(37)) MINT(51)=1
15167 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
15168 ENDIF
15169 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
15170 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
15171 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
15172 ENDIF
15173
15174C...Additional cuts on W2 (approximately) in DIS.
15175 IF(ISUB.EQ.10) THEN
15176 XBJ=X2
15177 IF(IABS(MINT(12)).LT.20) XBJ=X1
15178 Q2BJ=THA
15179 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
15180 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
15181 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
15182 ENDIF
15183
15184 ELSEIF(ILIM.EQ.1) THEN
15185C...Calculate limits on tau
15186C...0) due to definition
15187 TAUMN0=0D0
15188 TAUMX0=1D0
15189C...1) due to limits on subsystem mass
15190 TAUMN1=CKIN(1)**2/VINT(2)
15191 TAUMX1=1D0
15192 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
15193C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15194 TM3=SQRT(SQM3+PTHMIN**2)
15195 TM4=SQRT(SQM4+PTHMIN**2)
15196 YDCOSH=1D0
15197 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
15198 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
15199 TAUMX2=1D0
15200C...3) due to limits on pT-hat and cos(theta-hat)
15201 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
15202 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
15203 TAUMN3=0D0
15204 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
15205 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
15206 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
15207 TAUMX3=1D0
15208 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
15209 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
15210 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
15211C...4) due to limits on x1 and x2
15212 TAUMN4=CKIN(21)*CKIN(23)
15213 TAUMX4=CKIN(22)*CKIN(24)
15214C...5) due to limits on xF
15215 TAUMN5=0D0
15216 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
15217C...6) due to limits on that and uhat
15218 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
15219 TAUMX6=1D0
15220 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
15221 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
15222
15223C...Net effect of all separate limits.
15224 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
15225 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
15226 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15227 VINT(11)=0.99999D0
15228 VINT(31)=1.00001D0
15229 ELSEIF(MINT(47).EQ.5) THEN
15230 VINT(31)=MIN(VINT(31),0.999998D0)
15231 ENDIF
15232 IF(VINT(31).LE.VINT(11)) MINT(51)=1
15233
15234 ELSEIF(ILIM.EQ.2) THEN
15235C...Calculate limits on y*
15236 TAUE=TAU
15237 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15238 TAURT=SQRT(TAUE)
15239C...0) due to kinematics
15240 YSTMN0=LOG(TAURT)
15241 YSTMX0=-YSTMN0
15242C...1) due to explicit limits
15243 YSTMN1=CKIN(7)
15244 YSTMX1=CKIN(8)
15245C...2) due to limits on x1
15246 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
15247 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
15248C...3) due to limits on x2
15249 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
15250 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
15251C...4) due to limits on xF
15252 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
15253 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
15254 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
15255 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
15256C...5) due to simultaneous limits on y-large and y-small
15257 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
15258 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
15259 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
15260 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
15261 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
15262 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
15263C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15264C... y-small
15265 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
15266 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
15267 RZMX=BE34*MIN(CKIN(28),CTHLIM)
15268 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
15269 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
15270 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
15271 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
15272 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
15273 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
15274
15275C...Net effect of all separate limits.
15276 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
15277 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
15278 IF(MINT(47).EQ.1) THEN
15279 VINT(12)=-0.00001D0
15280 VINT(32)=0.00001D0
15281 ELSEIF(MINT(47).EQ.2) THEN
15282 VINT(12)=0.99999D0*YSTMX0
15283 VINT(32)=1.00001D0*YSTMX0
15284 ELSEIF(MINT(47).EQ.3) THEN
15285 VINT(12)=-1.00001D0*YSTMX0
15286 VINT(32)=-0.99999D0*YSTMX0
15287 ELSEIF(MINT(47).EQ.5) THEN
15288 YSTEE=LOG(0.999999D0/TAURT)
15289 VINT(12)=MAX(VINT(12),-YSTEE)
15290 VINT(32)=MIN(VINT(32),YSTEE)
15291 ENDIF
15292 IF(VINT(32).LE.VINT(12)) MINT(51)=1
15293
15294 ELSEIF(ILIM.EQ.3) THEN
15295C...Calculate limits on cos(theta-hat)
15296 YST=VINT(22)
15297C...0) due to definition
15298 CTNMN0=-1D0
15299 CTNMX0=0D0
15300 CTPMN0=0D0
15301 CTPMX0=1D0
15302C...1) due to explicit limits
15303 CTNMN1=MIN(0D0,CKIN(27))
15304 CTNMX1=MIN(0D0,CKIN(28))
15305 CTPMN1=MAX(0D0,CKIN(27))
15306 CTPMX1=MAX(0D0,CKIN(28))
15307C...2) due to limits on pT-hat
15308 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
15309 CTPMX2=-CTNMN2
15310 CTNMX2=0D0
15311 CTPMN2=0D0
15312 IF(CKIN(4).GE.0D0) THEN
15313 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
15314 & (BE34**2*TAU*VINT(2))))
15315 CTPMN2=-CTNMX2
15316 ENDIF
15317C...3) due to limits on y-large and y-small
15318 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
15319 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
15320 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
15321 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
15322 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
15323 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
15324 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
15325 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
15326C...4) due to limits on that
15327 CTNMN4=-1D0
15328 CTNMX4=0D0
15329 CTPMN4=0D0
15330 CTPMX4=1D0
15331 SH=TAU*VINT(2)
15332 IF(CKIN(35).GT.0D0) THEN
15333 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
15334 IF(CTLIM.GT.0D0) THEN
15335 CTPMX4=CTLIM
15336 ELSE
15337 CTPMX4=0D0
15338 CTNMX4=CTLIM
15339 ENDIF
15340 ENDIF
15341 IF(CKIN(36).GT.0D0) THEN
15342 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
15343 IF(CTLIM.LT.0D0) THEN
15344 CTNMN4=CTLIM
15345 ELSE
15346 CTNMN4=0D0
15347 CTPMN4=CTLIM
15348 ENDIF
15349 ENDIF
15350C...5) due to limits on uhat
15351 CTNMN5=-1D0
15352 CTNMX5=0D0
15353 CTPMN5=0D0
15354 CTPMX5=1D0
15355 IF(CKIN(37).GT.0D0) THEN
15356 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
15357 IF(CTLIM.LT.0D0) THEN
15358 CTNMN5=CTLIM
15359 ELSE
15360 CTNMN5=0D0
15361 CTPMN5=CTLIM
15362 ENDIF
15363 ENDIF
15364 IF(CKIN(38).GT.0D0) THEN
15365 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
15366 IF(CTLIM.GT.0D0) THEN
15367 CTPMX5=CTLIM
15368 ELSE
15369 CTPMX5=0D0
15370 CTNMX5=CTLIM
15371 ENDIF
15372 ENDIF
15373
15374C...Net effect of all separate limits.
15375 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
15376 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
15377 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
15378 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
15379 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
15380
15381 ELSEIF(ILIM.EQ.4) THEN
15382C...Calculate limits on tau'
15383C...0) due to kinematics
15384 TAPMN0=TAU
15385 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
15386 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
15387 TAPMN0=(SQRT(TAU)+PQRAT)**2
15388 ENDIF
15389 TAPMX0=1D0
15390C...1) due to explicit limits
15391 TAPMN1=CKIN(31)**2/VINT(2)
15392 TAPMX1=1D0
15393 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
15394
15395C...Net effect of all separate limits.
15396 VINT(16)=MAX(TAPMN0,TAPMN1)
15397 VINT(36)=MIN(TAPMX0,TAPMX1)
15398 IF(MINT(47).EQ.1) THEN
15399 VINT(16)=0.99999D0
15400 VINT(36)=1.00001D0
15401 ENDIF
15402 IF(VINT(36).LE.VINT(16)) MINT(51)=1
15403
15404 ENDIF
15405 RETURN
15406
15407C...Special case for low-pT and multiple interactions:
15408C...effective kinematical limits for tau, y*, cos(theta-hat).
15409 100 IF(ILIM.EQ.0) THEN
15410 ELSEIF(ILIM.EQ.1) THEN
15411 IF(MSTP(82).LE.1) VINT(11)=4D0*PARP(81)**2/VINT(2)
15412 IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
15413 VINT(31)=1D0
15414 ELSEIF(ILIM.EQ.2) THEN
15415 VINT(12)=0.5D0*LOG(VINT(21))
15416 VINT(32)=-VINT(12)
15417 ELSEIF(ILIM.EQ.3) THEN
15418 IF(MSTP(82).LE.1) ST2EFF=4D0*PARP(81)**2/(VINT(21)*VINT(2))
15419 IF(MSTP(82).GE.2) ST2EFF=0.01D0*PARP(82)**2/(VINT(21)*VINT(2))
15420 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
15421 VINT(33)=0D0
15422 VINT(14)=0D0
15423 VINT(34)=-VINT(13)
15424 ENDIF
15425
15426 RETURN
15427 END
15428
15429C*********************************************************************
15430
15431*$ CREATE PYKMAP.FOR
15432*COPY PYKMAP
15433C...PYKMAP
15434C...Maps a uniform distribution into a distribution of a kinematical
15435C...variable according to one of the possibilities allowed. It is
15436C...assumed that kinematical limits have been set by a PYKLIM call.
15437
15438 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
15439
15440C...Double precision and integer declarations.
15441 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15442 INTEGER PYK,PYCHGE,PYCOMP
15443C...Commonblocks.
15444 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15445 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15446 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15447 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15448 COMMON/PYINT1/MINT(400),VINT(400)
15449 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15450 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
15451
15452C...Convert VVAR to tau variable.
15453 ISUB=MINT(1)
15454 ISTSB=ISET(ISUB)
15455 IF(IVAR.EQ.1) THEN
15456 TAUMIN=VINT(11)
15457 TAUMAX=VINT(31)
15458 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
15459 TAURE=VINT(73)
15460 GAMRE=VINT(74)
15461 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
15462 TAURE=VINT(75)
15463 GAMRE=VINT(76)
15464 ENDIF
15465 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15466 TAU=1D0
15467 ELSEIF(MVAR.EQ.1) THEN
15468 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
15469 ELSEIF(MVAR.EQ.2) THEN
15470 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
15471 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
15472 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
15473 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
15474 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
15475 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
15476 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
15477 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
15478 ELSE
15479 AUPP=LOG(MAX(2D-6,1D0-TAUMAX))
15480 ALOW=LOG(MAX(2D-6,1D0-TAUMIN))
15481 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15482 ENDIF
15483 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
15484
15485C...Convert VVAR to y* variable.
15486 ELSEIF(IVAR.EQ.2) THEN
15487 YSTMIN=VINT(12)
15488 YSTMAX=VINT(32)
15489 TAUE=VINT(21)
15490 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15491 IF(MINT(47).EQ.1) THEN
15492 YST=0D0
15493 ELSEIF(MINT(47).EQ.2) THEN
15494 YST=-0.5D0*LOG(TAUE)
15495 ELSEIF(MINT(47).EQ.3) THEN
15496 YST=0.5D0*LOG(TAUE)
15497 ELSEIF(MVAR.EQ.1) THEN
15498 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
15499 ELSEIF(MVAR.EQ.2) THEN
15500 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
15501 ELSEIF(MVAR.EQ.3) THEN
15502 AUPP=ATAN(EXP(YSTMAX))
15503 ALOW=ATAN(EXP(YSTMIN))
15504 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
15505 ELSEIF(MVAR.EQ.4) THEN
15506 YST0=-0.5D0*LOG(TAUE)
15507 AUPP=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0))
15508 ALOW=LOG(MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
15509 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
15510 ELSE
15511 YST0=-0.5D0*LOG(TAUE)
15512 AUPP=LOG(MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
15513 ALOW=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0))
15514 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
15515 ENDIF
15516 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
15517
15518C...Convert VVAR to cos(theta-hat) variable.
15519 ELSEIF(IVAR.EQ.3) THEN
15520 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
15521 RSQM=1D0+RM34
15522 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15523 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15524 CTNMIN=VINT(13)
15525 CTNMAX=VINT(33)
15526 CTPMIN=VINT(14)
15527 CTPMAX=VINT(34)
15528 IF(MVAR.EQ.1) THEN
15529 ANEG=CTNMAX-CTNMIN
15530 APOS=CTPMAX-CTPMIN
15531 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15532 VCTN=VVAR*(ANEG+APOS)/ANEG
15533 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
15534 ELSE
15535 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15536 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
15537 ENDIF
15538 ELSEIF(MVAR.EQ.2) THEN
15539 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15540 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15541 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15542 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15543 ANEG=LOG(RMNMIN/RMNMAX)
15544 APOS=LOG(RMPMIN/RMPMAX)
15545 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15546 VCTN=VVAR*(ANEG+APOS)/ANEG
15547 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
15548 ELSE
15549 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15550 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
15551 ENDIF
15552 ELSEIF(MVAR.EQ.3) THEN
15553 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15554 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15555 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15556 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15557 ANEG=LOG(RMNMAX/RMNMIN)
15558 APOS=LOG(RMPMAX/RMPMIN)
15559 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15560 VCTN=VVAR*(ANEG+APOS)/ANEG
15561 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
15562 ELSE
15563 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15564 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
15565 ENDIF
15566 ELSEIF(MVAR.EQ.4) THEN
15567 RMNMIN=MAX(RM34,RSQM-CTNMIN)
15568 RMNMAX=MAX(RM34,RSQM-CTNMAX)
15569 RMPMIN=MAX(RM34,RSQM-CTPMIN)
15570 RMPMAX=MAX(RM34,RSQM-CTPMAX)
15571 ANEG=1D0/RMNMAX-1D0/RMNMIN
15572 APOS=1D0/RMPMAX-1D0/RMPMIN
15573 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15574 VCTN=VVAR*(ANEG+APOS)/ANEG
15575 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
15576 ELSE
15577 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15578 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
15579 ENDIF
15580 ELSEIF(MVAR.EQ.5) THEN
15581 RMNMIN=MAX(RM34,RSQM+CTNMIN)
15582 RMNMAX=MAX(RM34,RSQM+CTNMAX)
15583 RMPMIN=MAX(RM34,RSQM+CTPMIN)
15584 RMPMAX=MAX(RM34,RSQM+CTPMAX)
15585 ANEG=1D0/RMNMIN-1D0/RMNMAX
15586 APOS=1D0/RMPMIN-1D0/RMPMAX
15587 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15588 VCTN=VVAR*(ANEG+APOS)/ANEG
15589 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
15590 ELSE
15591 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15592 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
15593 ENDIF
15594 ENDIF
15595 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
15596 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
15597 VINT(23)=CTH
15598
15599C...Convert VVAR to tau' variable.
15600 ELSEIF(IVAR.EQ.4) THEN
15601 TAU=VINT(21)
15602 TAUPMN=VINT(16)
15603 TAUPMX=VINT(36)
15604 IF(MINT(47).EQ.1) THEN
15605 TAUP=1D0
15606 ELSEIF(MVAR.EQ.1) THEN
15607 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
15608 ELSEIF(MVAR.EQ.2) THEN
15609 AUPP=(1D0-TAU/TAUPMX)**4
15610 ALOW=(1D0-TAU/TAUPMN)**4
15611 TAUP=TAU/MAX(1D-7,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
15612 ELSE
15613 AUPP=LOG(MAX(2D-6,1D0-TAUPMX))
15614 ALOW=LOG(MAX(2D-6,1D0-TAUPMN))
15615 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15616 ENDIF
15617 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
15618
15619C...Selection of extra variables needed in 2 -> 3 process:
15620C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
15621C...Since no options are available, the functions of PYKLIM
15622C...and PYKMAP are joint for these choices.
15623 ELSEIF(IVAR.EQ.5) THEN
15624
15625C...Read out total energy and particle masses.
15626 MINT(51)=0
15627 MPTPK=1
15628 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
15629 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179) MPTPK=2
15630 SHP=VINT(26)*VINT(2)
15631 SHPR=SQRT(SHP)
15632 PM1=VINT(201)
15633 PM2=VINT(206)
15634 PM3=SQRT(VINT(21))*VINT(1)
15635 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
15636 MINT(51)=1
15637 RETURN
15638 ENDIF
15639 PMRS1=VINT(204)**2
15640 PMRS2=VINT(209)**2
15641
15642C...Specify coefficients of pT choice; upper and lower limits.
15643 IF(MPTPK.EQ.1) THEN
15644 HWT1=0.4D0
15645 HWT2=0.4D0
15646 ELSE
15647 HWT1=0.05D0
15648 HWT2=0.05D0
15649 ENDIF
15650 HWT3=1D0-HWT1-HWT2
15651 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
15652 & (4D0*SHP)
15653 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
15654 PTSMN1=CKIN(51)**2
15655 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
15656 & (4D0*SHP)
15657 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
15658 PTSMN2=CKIN(53)**2
15659
15660C...Select transverse momenta according to
15661C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
15662 HMX=PMRS1+PTSMX1
15663 HMN=PMRS1+PTSMN1
15664 IF(HMX.LT.1.0001D0*HMN) THEN
15665 MINT(51)=1
15666 RETURN
15667 ENDIF
15668 HDE=PTSMX1-PTSMN1
15669 RPT=PYR(0)
15670 IF(RPT.LT.HWT1) THEN
15671 PTS1=PTSMN1+PYR(0)*HDE
15672 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15673 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
15674 ELSE
15675 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
15676 ENDIF
15677 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
15678 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
15679 HMX=PMRS2+PTSMX2
15680 HMN=PMRS2+PTSMN2
15681 IF(HMX.LT.1.0001D0*HMN) THEN
15682 MINT(51)=1
15683 RETURN
15684 ENDIF
15685 HDE=PTSMX2-PTSMN2
15686 RPT=PYR(0)
15687 IF(RPT.LT.HWT1) THEN
15688 PTS2=PTSMN2+PYR(0)*HDE
15689 ELSEIF(RPT.LT.HWT1+HWT2) THEN
15690 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
15691 ELSE
15692 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
15693 ENDIF
15694 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
15695 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
15696
15697C...Select azimuthal angles and check pT choice.
15698 PHI1=PARU(2)*PYR(0)
15699 PHI2=PARU(2)*PYR(0)
15700 PHIR=PHI2-PHI1
15701 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
15702 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
15703 & CKIN(56)**2)) THEN
15704 MINT(51)=1
15705 RETURN
15706 ENDIF
15707
15708C...Calculate transverse masses and check phase space not closed.
15709 PMS1=PM1**2+PTS1
15710 PMS2=PM2**2+PTS2
15711 PMS3=PM3**2+PTS3
15712 PMT1=SQRT(PMS1)
15713 PMT2=SQRT(PMS2)
15714 PMT3=SQRT(PMS3)
15715 PM12=(PMT1+PMT2)**2
15716 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
15717 MINT(51)=1
15718 RETURN
15719 ENDIF
15720
15721C...Select rapidity for particle 3 and check phase space not closed.
15722 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
15723 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
15724 IF(Y3MAX.LT.1D-6) THEN
15725 MINT(51)=1
15726 RETURN
15727 ENDIF
15728 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
15729 PZ3=PMT3*SINH(Y3)
15730 PE3=PMT3*COSH(Y3)
15731
15732C...Find momentum transfers in two mirror solutions (in 1-2 frame).
15733 PZ12=-PZ3
15734 PE12=SHPR-PE3
15735 PMS12=PE12**2-PZ12**2
15736 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
15737 IF(SQL12.LT.1D-6*SHP) THEN
15738 MINT(51)=1
15739 RETURN
15740 ENDIF
15741 PMM1=PMS12+PMS1-PMS2
15742 PMM2=PMS12+PMS2-PMS1
15743 TFAC=-SHPR/(2D0*PMS12)
15744 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
15745 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
15746 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
15747 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
15748
15749C...Construct relative mirror weights and make choice.
15750 IF(MPTPK.EQ.1) THEN
15751 WTPU=1D0
15752 WTNU=1D0
15753 ELSE
15754 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
15755 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
15756 ENDIF
15757 WTP=WTPU/(WTPU+WTNU)
15758 WTN=WTNU/(WTPU+WTNU)
15759 EPS=1D0
15760 IF(WTN.GT.PYR(0)) EPS=-1D0
15761
15762C...Store result of variable choice and associated weights.
15763 VINT(202)=PTS1
15764 VINT(207)=PTS2
15765 VINT(203)=PHI1
15766 VINT(208)=PHI2
15767 VINT(205)=WTPTS1
15768 VINT(210)=WTPTS2
15769 VINT(211)=Y3
15770 VINT(212)=Y3MAX
15771 VINT(213)=EPS
15772 IF(EPS.GT.0D0) THEN
15773 VINT(214)=1D0/WTP
15774 VINT(215)=T1P
15775 VINT(216)=T2P
15776 ELSE
15777 VINT(214)=1D0/WTN
15778 VINT(215)=T1N
15779 VINT(216)=T2N
15780 ENDIF
15781 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
15782 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
15783 VINT(219)=0.5D0*(PMS12-PTS3)
15784 VINT(220)=SQL12
15785 ENDIF
15786
15787 RETURN
15788 END
15789
15790C***********************************************************************
15791
15792*$ CREATE PYSIGH.FOR
15793*COPY PYSIGH
15794C...PYSIGH
15795C...Differential matrix elements for all included subprocesses
15796C...Note that what is coded is (disregarding the COMFAC factor)
15797C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
15798C...when d(sigma-hat) is given in the zero-width limit, the delta
15799C...function in tau is replaced by a (modified) Breit-Wigner:
15800C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
15801C...where H_res = s-hat/m_res*Gamma_res(s-hat);
15802C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
15803C...i.e., dimensionless quantities
15804C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
15805C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
15806C...(2pi)^4 delta^4(P - sum p_i)
15807C...COMFAC contains the factor pi/s (or equivalent) and
15808C...the conversion factor from GeV^-2 to mb
15809
15810 SUBROUTINE PYSIGH(NCHN,SIGS)
15811
15812C...Double precision and integer declarations
15813 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15814 INTEGER PYK,PYCHGE,PYCOMP
15815C...Parameter statement to help give large particle numbers.
15816 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
15817C...Commonblocks
15818 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15819 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15820 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15821 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15822 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15823 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15824 COMMON/PYINT1/MINT(400),VINT(400)
15825 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15826 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15827 COMMON/PYINT4/MWID(500),WIDS(500,5)
15828 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15829 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15830 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15831 &SFMIX(16,4)
15832 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15833 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
15834 &/PYSSMT/
15835C...Local arrays and complex variables
15836 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
15837 &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
15838 COMPLEX A004,A204,A114,A00U,A20U,A11U
15839 COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
15840 &COULCK,COULCP,COULCD,COULCR,COULCS
15841 REAL A00L,A11L,A20L,COULXX
15842
15843C...Reset number of channels and cross-section
15844 NCHN=0
15845 SIGS=0D0
15846
15847C...Convert H or A process into equivalent h one
15848 ISUB=MINT(1)
15849 ISUBSV=ISUB
15850 IHIGG=1
15851 KFHIGG=25
15852 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
15853 &ISUB.LE.190)) THEN
15854 IHIGG=2
15855 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
15856 KFHIGG=33+IHIGG
15857 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
15858 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
15859 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
15860 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
15861 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
15862 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
15863 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
15864 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
15865 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
15866 ENDIF
15867
15868CMRENNA++
15869C...Convert almost equivalent SUSY processes into each other
15870C...Extract differences in flavours and couplings
15871 IF(ISUB.GE.200.AND.ISUB.LE.280) THEN
15872
15873C...Sleptons and sneutrinos
15874 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
15875 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15876 ISUB=201
15877 ILR=0
15878 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
15879 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15880 ISUB=201
15881 ILR=1
15882 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
15883 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15884 ISUB=203
15885 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
15886 IF(ISUB.EQ.210) THEN
15887 RKF=2.0D0
15888 ELSEIF(ISUB.EQ.211) THEN
15889 RKF=SFMIX(15,1)**2
15890 ELSEIF(ISUB.EQ.212) THEN
15891 RKF=SFMIX(15,2)**2
15892 ENDIF
15893 ISUB=210
15894 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
15895 IF(ISUB.EQ.213) THEN
15896 KFID=MOD(KFPR(ISUB,1),KSUSY1)
15897 RKF=2.0D0
15898 ELSEIF(ISUB.EQ.214) THEN
15899 KFID=16
15900 RKF=1.0D0
15901 ENDIF
15902 ISUB=213
15903
15904C...Neutralinos
15905 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
15906 IF(ISUB.EQ.216) THEN
15907 IZID1=1
15908 IZID2=1
15909 ELSEIF(ISUB.EQ.217) THEN
15910 IZID1=2
15911 IZID2=2
15912 ELSEIF(ISUB.EQ.218) THEN
15913 IZID1=3
15914 IZID2=3
15915 ELSEIF(ISUB.EQ.219) THEN
15916 IZID1=4
15917 IZID2=4
15918 ELSEIF(ISUB.EQ.220) THEN
15919 IZID1=1
15920 IZID2=2
15921 ELSEIF(ISUB.EQ.221) THEN
15922 IZID1=1
15923 IZID2=3
15924 ELSEIF(ISUB.EQ.222) THEN
15925 IZID1=1
15926 IZID2=4
15927 ELSEIF(ISUB.EQ.223) THEN
15928 IZID1=2
15929 IZID2=3
15930 ELSEIF(ISUB.EQ.224) THEN
15931 IZID1=2
15932 IZID2=4
15933 ELSEIF(ISUB.EQ.225) THEN
15934 IZID1=3
15935 IZID2=4
15936 ENDIF
15937 ISUB=216
15938
15939C...Charginos
15940 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
15941 IF(ISUB.EQ.226) THEN
15942 IZID1=1
15943 IZID2=1
15944 ELSEIF(ISUB.EQ.227) THEN
15945 IZID1=2
15946 IZID2=2
15947 ELSEIF(ISUB.EQ.228) THEN
15948 IZID1=1
15949 IZID2=2
15950 ENDIF
15951 ISUB=226
15952
15953C...Neutralino + chargino
15954 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
15955 IF(ISUB.EQ.229) THEN
15956 IZID1=1
15957 IZID2=1
15958 ELSEIF(ISUB.EQ.230) THEN
15959 IZID1=1
15960 IZID2=2
15961 ELSEIF(ISUB.EQ.231) THEN
15962 IZID1=1
15963 IZID2=3
15964 ELSEIF(ISUB.EQ.232) THEN
15965 IZID1=1
15966 IZID2=4
15967 ELSEIF(ISUB.EQ.233) THEN
15968 IZID1=2
15969 IZID2=1
15970 ELSEIF(ISUB.EQ.234) THEN
15971 IZID1=2
15972 IZID2=2
15973 ELSEIF(ISUB.EQ.235) THEN
15974 IZID1=2
15975 IZID2=3
15976 ELSEIF(ISUB.EQ.236) THEN
15977 IZID1=2
15978 IZID2=4
15979 ENDIF
15980 ISUB=229
15981
15982C...Gluino + neutralino
15983 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
15984 IF(ISUB.EQ.237) THEN
15985 IZID=1
15986 ELSEIF(ISUB.EQ.238) THEN
15987 IZID=2
15988 ELSEIF(ISUB.EQ.239) THEN
15989 IZID=3
15990 ELSEIF(ISUB.EQ.240) THEN
15991 IZID=4
15992 ENDIF
15993 ISUB=237
15994
15995C...Gluino + chargino
15996 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
15997 IF(ISUB.EQ.241) THEN
15998 IZID=1
15999 ELSEIF(ISUB.EQ.242) THEN
16000 IZID=2
16001 ENDIF
16002 ISUB=241
16003
16004C...Squark + neutralino
16005 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
16006 ILR=0
16007 IF(MOD(ISUB,2).NE.0) ILR=1
16008 IF(ISUB.LE.247) THEN
16009 IZID=1
16010 ELSEIF(ISUB.LE.249) THEN
16011 IZID=2
16012 ELSEIF(ISUB.LE.251) THEN
16013 IZID=3
16014 ELSEIF(ISUB.LE.253) THEN
16015 IZID=4
16016 ENDIF
16017 ISUB=246
16018 RKF=5D0
16019
16020C...Squark + chargino
16021 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
16022 IF(ISUB.LE.255) THEN
16023 IZID=1
16024 ELSEIF(ISUB.LE.257) THEN
16025 IZID=2
16026 ENDIF
16027 IF(MOD(ISUB,2).EQ.0) THEN
16028 ILR=0
16029 ELSE
16030 ILR=1
16031 ENDIF
16032 ISUB=254
16033 RKF=5D0
16034
16035C...Squark + gluino
16036 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
16037 ISUB=258
16038 RKF=5D0
16039
16040C...Stops
16041 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
16042 ILR=0
16043 IF(ISUB.EQ.262) ILR=1
16044 ISUB=261
16045 ELSEIF(ISUB.EQ.265) THEN
16046 ISUB=264
16047
16048C...Squarks
16049 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
16050 ILR=0
16051 IF(ISUB.LE.273) THEN
16052 IF(ISUB.EQ.273) ILR=1
16053 ISUB=271
16054 RKF=25D0
16055 ELSEIF(ISUB.LE.276) THEN
16056 IF(ISUB.EQ.276) ILR=1
16057 ISUB=274
16058 RKF=25D0
16059 ELSEIF(ISUB.LE.278) THEN
16060 IF(ISUB.EQ.278) ILR=1
16061 ISUB=277
16062 RKF=5D0
16063 ELSE
16064 IF(ISUB.EQ.280) ILR=1
16065 ISUB=279
16066 RKF=5D0
16067 ENDIF
16068 ENDIF
16069 ENDIF
16070CMRENNA--
16071
16072C...Read kinematical variables and limits
16073 ISTSB=ISET(ISUBSV)
16074 TAUMIN=VINT(11)
16075 YSTMIN=VINT(12)
16076 CTNMIN=VINT(13)
16077 CTPMIN=VINT(14)
16078 TAUPMN=VINT(16)
16079 TAU=VINT(21)
16080 YST=VINT(22)
16081 CTH=VINT(23)
16082 XT2=VINT(25)
16083 TAUP=VINT(26)
16084 TAUMAX=VINT(31)
16085 YSTMAX=VINT(32)
16086 CTNMAX=VINT(33)
16087 CTPMAX=VINT(34)
16088 TAUPMX=VINT(36)
16089
16090C...Derive kinematical quantities
16091 TAUE=TAU
16092 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
16093 X(1)=SQRT(TAUE)*EXP(YST)
16094 X(2)=SQRT(TAUE)*EXP(-YST)
16095 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
16096 IF(X(1).GT.0.9999D0) RETURN
16097 ELSEIF(MINT(45).EQ.3) THEN
16098 X(1)=MIN(0.9999989D0,X(1))
16099 ENDIF
16100 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
16101 IF(X(2).GT.0.9999D0) RETURN
16102 ELSEIF(MINT(46).EQ.3) THEN
16103 X(2)=MIN(0.9999989D0,X(2))
16104 ENDIF
16105 SH=TAU*VINT(2)
16106 SQM3=VINT(63)
16107 SQM4=VINT(64)
16108 RM3=SQM3/SH
16109 RM4=SQM4/SH
16110 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
16111 RPTS=4D0*VINT(71)**2/SH
16112 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
16113 RM34=MAX(1D-20,2D0*RM3*RM4)
16114 RSQM=1D0+RM34
16115 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) RM34=MAX(RM34,
16116 &2D0*VINT(71)**2/(VINT(21)*VINT(2)))
16117 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
16118 IF(ISTSB.EQ.0) THEN
16119 TH=VINT(45)
16120 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16121 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
16122 ELSE
16123 TH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
16124 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16125 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
16126 ENDIF
16127 SHR=SQRT(SH)
16128 SH2=SH**2
16129 TH2=TH**2
16130 UH2=UH**2
16131
16132C...Choice of Q2 scale: hard, parton distributions, parton showers
16133 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
16134 Q2=SH
16135 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
16136 IF(MSTP(32).EQ.1) THEN
16137 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
16138 ELSEIF(MSTP(32).EQ.2) THEN
16139 Q2=SQPTH+0.5D0*(SQM3+SQM4)
16140 ELSEIF(MSTP(32).EQ.3) THEN
16141 Q2=MIN(-TH,-UH)
16142 ELSEIF(MSTP(32).EQ.4) THEN
16143 Q2=SH
16144 ELSEIF(MSTP(32).EQ.5) THEN
16145 Q2=-TH
16146 ENDIF
16147 IF(ISTSB.EQ.9) Q2=SQPTH
16148 IF((ISTSB.EQ.9.AND.MSTP(82).GE.2).OR.(ISTSB.NE.9.AND.
16149 & MSTP(85).EQ.1)) Q2=Q2+PARP(82)**2
16150 ENDIF
16151 Q2SF=Q2
16152 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16153 Q2SF=PMAS(23,1)**2
16154 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124)
16155 & Q2SF=PMAS(24,1)**2
16156 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
16157 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
16158 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
16159 IF(MSTP(39).EQ.3) Q2SF=SH
16160 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
16161 ENDIF
16162 ENDIF
16163 Q2PS=Q2SF
16164 Q2SF=Q2SF*PARP(34)
16165 IF(MSTP(68).GE.2.AND.MINT(47).EQ.5) Q2SF=VINT(2)
16166 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
16167 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
16168 XBJ=X(2)
16169 IF(MINT(43).EQ.3) XBJ=X(1)
16170 IF(MSTP(22).EQ.1) THEN
16171 Q2PS=-TH
16172 ELSEIF(MSTP(22).EQ.2) THEN
16173 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
16174 ELSEIF(MSTP(22).EQ.3) THEN
16175 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
16176 ELSE
16177 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
16178 ENDIF
16179 ENDIF
16180 IF(MSTP(68).GE.1.AND.MINT(47).EQ.5) Q2PS=VINT(2)
16181
16182C...Store derived kinematical quantities
16183 VINT(41)=X(1)
16184 VINT(42)=X(2)
16185 VINT(44)=SH
16186 VINT(43)=SQRT(SH)
16187 VINT(45)=TH
16188 VINT(46)=UH
16189 VINT(48)=SQPTH
16190 VINT(47)=SQRT(SQPTH)
16191 VINT(50)=TAUP*VINT(2)
16192 VINT(49)=SQRT(MAX(0D0,VINT(50)))
16193 VINT(52)=Q2
16194 VINT(51)=SQRT(Q2)
16195 VINT(54)=Q2SF
16196 VINT(53)=SQRT(Q2SF)
16197 VINT(56)=Q2PS
16198 VINT(55)=SQRT(Q2PS)
16199
16200C...Calculate parton distributions
16201 IF(ISTSB.LE.0) GOTO 170
16202 IF(MINT(47).GE.2) THEN
16203 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
16204 XSF=X(I)
16205 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
16206 MINT(105)=MINT(102+I)
16207 MINT(109)=MINT(106+I)
16208 IF(MSTP(57).LE.1) THEN
16209 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
16210 ELSE
16211 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
16212 ENDIF
16213 DO 100 KFL=-25,25
16214 XSFX(I,KFL)=XPQ(KFL)
16215 100 CONTINUE
16216 110 CONTINUE
16217 ENDIF
16218
16219C...Calculate alpha_em, alpha_strong and K-factor
16220 XW=PARU(102)
16221 XWV=XW
16222 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
16223 &1D0-(PMAS(24,1)/PMAS(23,1))**2
16224 XW1=1D0-XW
16225 XWC=1D0/(16D0*XW*XW1)
16226 AEM=PYALEM(Q2)
16227 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16228 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
16229 FACK=1D0
16230 FACA=1D0
16231 IF(MSTP(33).EQ.1) THEN
16232 FACK=PARP(31)
16233 ELSEIF(MSTP(33).EQ.2) THEN
16234 FACK=PARP(31)
16235 FACA=PARP(32)/PARP(31)
16236 ELSEIF(MSTP(33).EQ.3) THEN
16237 Q2AS=PARP(33)*Q2
16238 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
16239 & PARU(112)*PARP(82)
16240 AS=PYALPS(Q2AS)
16241 ENDIF
16242 VINT(138)=1D0
16243 VINT(57)=AEM
16244 VINT(58)=AS
16245
16246C...Set flags for allowed reacting partons/leptons
16247 DO 140 I=1,2
16248 DO 120 J=-25,25
16249 KFAC(I,J)=0
16250 120 CONTINUE
16251 IF(MINT(44+I).EQ.1) THEN
16252 KFAC(I,MINT(10+I))=1
16253 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
16254 KFAC(I,MINT(10+I))=1
16255 KFAC(I,22)=1
16256 KFAC(I,24)=1
16257 KFAC(I,-24)=1
16258 ELSE
16259 DO 130 J=-25,25
16260 KFAC(I,J)=KFIN(I,J)
16261 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
16262 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
16263 130 CONTINUE
16264 ENDIF
16265 140 CONTINUE
16266
16267C...Lower and upper limit for fermion flavour loops
16268 MMIN1=0
16269 MMAX1=0
16270 MMIN2=0
16271 MMAX2=0
16272 DO 150 J=-20,20
16273 IF(KFAC(1,-J).EQ.1) MMIN1=-J
16274 IF(KFAC(1,J).EQ.1) MMAX1=J
16275 IF(KFAC(2,-J).EQ.1) MMIN2=-J
16276 IF(KFAC(2,J).EQ.1) MMAX2=J
16277 150 CONTINUE
16278 MMINA=MIN(MMIN1,MMIN2)
16279 MMAXA=MAX(MMAX1,MMAX2)
16280
16281C...Common resonance mass and width combinations
16282 SQMZ=PMAS(23,1)**2
16283 SQMW=PMAS(24,1)**2
16284 SQMH=PMAS(KFHIGG,1)**2
16285 GMMZ=PMAS(23,1)*PMAS(23,2)
16286 GMMW=PMAS(24,1)*PMAS(24,2)
16287 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
16288C...MRENNA+++
16289 ZWID=PMAS(23,2)
16290 WWID=PMAS(24,2)
16291 TANW=SQRT(XW/XW1)
16292C...MRENNA---
16293
16294C...Phase space integral in tau
16295 COMFAC=PARU(1)*PARU(5)/VINT(2)
16296 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
16297 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
16298 &ISTSB.NE.9) THEN
16299 ATAU1=LOG(TAUMAX/TAUMIN)
16300 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
16301 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
16302 IF(MINT(72).GE.1) THEN
16303 TAUR1=VINT(73)
16304 GAMR1=VINT(74)
16305 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
16306 ATAU3=ATAUD/TAUR1
16307 IF(ATAUD.GT.1D-6) H1=H1+
16308 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
16309 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
16310 ATAU4=ATAUD/GAMR1
16311 IF(ATAUD.GT.1D-6) H1=H1+
16312 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
16313 ENDIF
16314 IF(MINT(72).EQ.2) THEN
16315 TAUR2=VINT(75)
16316 GAMR2=VINT(76)
16317 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
16318 ATAU5=ATAUD/TAUR2
16319 IF(ATAUD.GT.1D-6) H1=H1+
16320 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
16321 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
16322 ATAU6=ATAUD/GAMR2
16323 IF(ATAUD.GT.1D-6) H1=H1+
16324 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
16325 ENDIF
16326 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
16327 ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
16328 IF(ATAU7.GT.1D-6) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
16329 & MAX(2D-6,1D0-TAU)
16330 ENDIF
16331 COMFAC=COMFAC*ATAU1/(TAU*H1)
16332 ENDIF
16333
16334C...Phase space integral in y*
16335 IF(MINT(47).GE.4.AND.ISTSB.NE.9) THEN
16336 AYST0=YSTMAX-YSTMIN
16337 IF(AYST0.LT.1D-6) THEN
16338 COMFAC=0D0
16339 ELSE
16340 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16341 AYST2=AYST1
16342 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16343 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16344 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16345 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16346 IF(MINT(45).EQ.3) THEN
16347 YST0=-0.5D0*LOG(TAUE)
16348 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
16349 & MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
16350 IF(AYST4.GT.1D-6) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
16351 & MAX(1D-6,1D0-EXP(YST-YST0))
16352 ENDIF
16353 IF(MINT(46).EQ.3) THEN
16354 YST0=-0.5D0*LOG(TAUE)
16355 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
16356 & MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
16357 IF(AYST5.GT.1D-6) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
16358 & MAX(1D-6,1D0-EXP(-YST-YST0))
16359 ENDIF
16360 COMFAC=COMFAC*AYST0/H2
16361 ENDIF
16362 ENDIF
16363
16364C...2 -> 1 processes: reduction in angular part of phase space integral
16365C...for case of decaying resonance
16366 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
16367 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
16368 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
16369 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
16370 & KFPR(ISUB,1).EQ.39) THEN
16371 COMFAC=COMFAC*0.5D0*ACTH0
16372 ELSE
16373 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
16374 & CTPMAX**3-CTPMIN**3)
16375 ENDIF
16376 ENDIF
16377
16378C...2 -> 2 processes: angular part of phase space integral
16379 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
16380 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
16381 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
16382 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
16383 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
16384 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
16385 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
16386 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
16387 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
16388 H3=COEF(ISUBSV,13)+
16389 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
16390 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
16391 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
16392 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
16393 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
16394
16395C...2 -> 2 processes: take into account final state Breit-Wigners
16396 COMFAC=COMFAC*VINT(80)
16397 ENDIF
16398
16399C...2 -> 3, 4 processes: phace space integral in tau'
16400 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16401 ATAUP1=LOG(TAUPMX/TAUPMN)
16402 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
16403 H4=COEF(ISUBSV,18)+
16404 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
16405 IF(MINT(47).EQ.5) THEN
16406 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
16407 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-6,1D0-TAUP)
16408 ENDIF
16409 COMFAC=COMFAC*ATAUP1/H4
16410 ENDIF
16411
16412C...2 -> 3, 4 processes: effective W/Z parton distributions
16413 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
16414 IF(1D0-TAU/TAUP.GT.1.D-4) THEN
16415 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
16416 ELSE
16417 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
16418 ENDIF
16419 COMFAC=COMFAC*FZW
16420 ENDIF
16421
16422C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
16423 IF(ISTSB.EQ.5) THEN
16424 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
16425 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
16426 ENDIF
16427
16428C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2
16429 IF(MSTP(85).EQ.1.AND.MOD(ISTSB,2).EQ.0) COMFAC=COMFAC*
16430 &SQPTH**2/(PARP(82)**2+SQPTH)**2
16431
16432C...gamma + gamma: include factor 2 when different nature
16433 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4)
16434 &COMFAC=2D0*COMFAC
16435
16436C...Phase space integral for low-pT and multiple interactions
16437 IF(ISTSB.EQ.9) THEN
16438 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
16439 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
16440 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
16441 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
16442 COMFAC=COMFAC*ATAU1/H1
16443 AYST0=YSTMAX-YSTMIN
16444 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16445 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16446 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16447 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16448 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16449 COMFAC=COMFAC*AYST0/H2
16450 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
16451C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16452C...introduced to make cross-section finite for xT2 -> 0
16453 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
16454 & (1D0+VINT(149)))
16455 ENDIF
16456
16457C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
16458 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
16459 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
16460C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
16461 IF(MSTP(46).LE.4) THEN
16462 HDTLH=LOG(PMAS(25,1)/PARP(44))
16463 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
16464 HDTNR=-1D0/18D0+HDTLH/6D0
16465 ELSE
16466 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
16467 HDTLQ=LOG(PARP(45)/PARP(44))
16468 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
16469 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
16470 ENDIF
16471
16472C...Calculate lowest and next-to-lowest order partial wave amplitudes
16473 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
16474 A00L=SNGL(HDTV*SH)
16475 A20L=-0.5*A00L
16476 A11L=A00L/6.
16477 HDTLS=LOG(SH/PARP(44)**2)
16478 A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16479 & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
16480 & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
16481 A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16482 & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
16483 & (20D0/9D0)*HDTLS),SNGL(PARU(1)))
16484 A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
16485 & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
16486
16487C...Unitarize partial wave amplitudes with Pade or K-matrix method
16488 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
16489 A00U=A00L/(1.-A004/A00L)
16490 A20U=A20L/(1.-A204/A20L)
16491 A11U=A11L/(1.-A114/A11L)
16492 ELSE
16493 A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
16494 A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
16495 A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
16496 ENDIF
16497 ENDIF
16498
16499C...Supersymmetric processes - all of type 2 -> 2 :
16500C...correct final-state Breit-Wigners from fixed to running width.
16501 IF(ISUB.GE.200.AND.ISUB.LE.280.AND.MSTP(42).GT.0) THEN
16502 DO 160 I=1,2
16503 KFLW=KFPR(ISUBSV,I)
16504 KCW=PYCOMP(KFLW)
16505 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
16506 IF(I.EQ.1) SQMI=SQM3
16507 IF(I.EQ.2) SQMI=SQM4
16508 SQMS=PMAS(KCW,1)**2
16509 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
16510 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
16511 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
16512 GMMI=SQRT(SQMI)*WDTP(0)
16513 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
16514 COMFAC=COMFAC*(HBWI/HBWS)
16515 160 CONTINUE
16516 ENDIF
16517
16518C...A: 2 -> 1, tree diagrams
16519
16520 170 IF(ISUB.LE.10) THEN
16521 IF(ISUB.EQ.1) THEN
16522C...f + fbar -> gamma*/Z0
16523 MINT(61)=2
16524 CALL PYWIDT(23,SH,WDTP,WDTE)
16525 HS=SHR*WDTP(0)
16526 FACZ=4D0*COMFAC*3D0
16527 HP0=AEM/3D0*SH
16528 HP1=AEM/3D0*XWC*SH
16529 DO 180 I=MMINA,MMAXA
16530 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
16531 EI=KCHG(IABS(I),1)/3D0
16532 AI=SIGN(1D0,EI)
16533 VI=AI-4D0*EI*XWV
16534 HI0=HP0
16535 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
16536 HI1=HP1
16537 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
16538 NCHN=NCHN+1
16539 ISIG(NCHN,1)=I
16540 ISIG(NCHN,2)=-I
16541 ISIG(NCHN,3)=1
16542 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
16543 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
16544 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
16545 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
16546 180 CONTINUE
16547
16548 ELSEIF(ISUB.EQ.2) THEN
16549C...f + fbar' -> W+/-
16550 CALL PYWIDT(24,SH,WDTP,WDTE)
16551 HS=SHR*WDTP(0)
16552 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
16553 HP=AEM/(24D0*XW)*SH
16554 DO 200 I=MMIN1,MMAX1
16555 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
16556 IA=IABS(I)
16557 DO 190 J=MMIN2,MMAX2
16558 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
16559 JA=IABS(J)
16560 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
16561 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
16562 & GOTO 190
16563 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16564 HI=HP*2D0
16565 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
16566 NCHN=NCHN+1
16567 ISIG(NCHN,1)=I
16568 ISIG(NCHN,2)=J
16569 ISIG(NCHN,3)=1
16570 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
16571 SIGH(NCHN)=HI*FACBW*HF
16572 190 CONTINUE
16573 200 CONTINUE
16574
16575 ELSEIF(ISUB.EQ.3) THEN
16576C...f + fbar -> h0 (or H0, or A0)
16577 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
16578 HS=SHR*WDTP(0)
16579 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16580 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
16581 & FACBW=0D0
16582 HP=AEM/(8D0*XW)*SH/SQMW*SH
16583 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16584 DO 210 I=MMINA,MMAXA
16585 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
16586 IA=IABS(I)
16587 RMQ=PMAS(IA,1)**2/SH
16588 HI=HP*RMQ
16589 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
16590 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) HI=HI*
16591 & (LOG(MAX(4D0,PARP(37)**2*RMQ*SH/PARU(117)**2))/
16592 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
16593 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16594 IKFI=1
16595 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
16596 IF(IA.GT.10) IKFI=3
16597 HI=HI*PARU(150+10*IHIGG+IKFI)**2
16598 ENDIF
16599 NCHN=NCHN+1
16600 ISIG(NCHN,1)=I
16601 ISIG(NCHN,2)=-I
16602 ISIG(NCHN,3)=1
16603 SIGH(NCHN)=HI*FACBW*HF
16604 210 CONTINUE
16605
16606 ELSEIF(ISUB.EQ.4) THEN
16607C...gamma + W+/- -> W+/-
16608
16609 ELSEIF(ISUB.EQ.5) THEN
16610C...Z0 + Z0 -> h0
16611 CALL PYWIDT(25,SH,WDTP,WDTE)
16612 HS=SHR*WDTP(0)
16613 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16614 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16615 HP=AEM/(8D0*XW)*SH/SQMW*SH
16616 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16617 HI=HP/4D0
16618 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
16619 DO 230 I=MMIN1,MMAX1
16620 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
16621 DO 220 J=MMIN2,MMAX2
16622 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
16623 EI=KCHG(IABS(I),1)/3D0
16624 AI=SIGN(1D0,EI)
16625 VI=AI-4D0*EI*XWV
16626 EJ=KCHG(IABS(J),1)/3D0
16627 AJ=SIGN(1D0,EJ)
16628 VJ=AJ-4D0*EJ*XWV
16629 NCHN=NCHN+1
16630 ISIG(NCHN,1)=I
16631 ISIG(NCHN,2)=J
16632 ISIG(NCHN,3)=1
16633 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
16634 220 CONTINUE
16635 230 CONTINUE
16636
16637 ELSEIF(ISUB.EQ.6) THEN
16638C...Z0 + W+/- -> W+/-
16639
16640 ELSEIF(ISUB.EQ.7) THEN
16641C...W+ + W- -> Z0
16642
16643 ELSEIF(ISUB.EQ.8) THEN
16644C...W+ + W- -> h0
16645 CALL PYWIDT(25,SH,WDTP,WDTE)
16646 HS=SHR*WDTP(0)
16647 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16648 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16649 HP=AEM/(8D0*XW)*SH/SQMW*SH
16650 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16651 HI=HP/2D0
16652 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
16653 DO 250 I=MMIN1,MMAX1
16654 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
16655 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
16656 DO 240 J=MMIN2,MMAX2
16657 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
16658 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
16659 IF(EI*EJ.GT.0D0) GOTO 240
16660 NCHN=NCHN+1
16661 ISIG(NCHN,1)=I
16662 ISIG(NCHN,2)=J
16663 ISIG(NCHN,3)=1
16664 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
16665 240 CONTINUE
16666 250 CONTINUE
16667
16668C...B: 2 -> 2, tree diagrams
16669
16670 ELSEIF(ISUB.EQ.10) THEN
16671C...f + f' -> f + f' (gamma/Z/W exchange)
16672 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
16673 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
16674 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
16675 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
16676 DO 270 I=MMIN1,MMAX1
16677 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
16678 IA=IABS(I)
16679 DO 260 J=MMIN2,MMAX2
16680 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
16681 JA=IABS(J)
16682C...Electroweak couplings
16683 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
16684 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
16685 VI=AI-4D0*EI*XWV
16686 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
16687 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
16688 VJ=AJ-4D0*EJ*XWV
16689 EPSIJ=ISIGN(1,I*J)
16690C...gamma/Z exchange, only gamma exchange, or only Z exchange
16691 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
16692 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
16693 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
16694 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
16695 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
16696 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16697 ELSEIF(MSTP(21).EQ.2) THEN
16698 FACNCF=FACGGF*EI**2*EJ**2
16699 ELSE
16700 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
16701 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16702 ENDIF
16703 NCHN=NCHN+1
16704 ISIG(NCHN,1)=I
16705 ISIG(NCHN,2)=J
16706 ISIG(NCHN,3)=1
16707 SIGH(NCHN)=FACNCF
16708 ENDIF
16709C...W exchange
16710 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
16711 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
16712 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
16713 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
16714 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
16715 NCHN=NCHN+1
16716 ISIG(NCHN,1)=I
16717 ISIG(NCHN,2)=J
16718 ISIG(NCHN,3)=2
16719 SIGH(NCHN)=FACCCF
16720 ENDIF
16721 260 CONTINUE
16722 270 CONTINUE
16723 ENDIF
16724
16725 ELSEIF(ISUB.LE.20) THEN
16726 IF(ISUB.EQ.11) THEN
16727C...f + f' -> f + f' (g exchange)
16728 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
16729 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
16730 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
16731 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
16732 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
16733 IF(MSTP(5).GE.1) THEN
16734C...Modifications from contact interactions (compositeness)
16735 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
16736 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16737 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
16738 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16739 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
16740 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
16741 ENDIF
16742 DO 290 I=MMIN1,MMAX1
16743 IA=IABS(I)
16744 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
16745 DO 280 J=MMIN2,MMAX2
16746 JA=IABS(J)
16747 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
16748 NCHN=NCHN+1
16749 ISIG(NCHN,1)=I
16750 ISIG(NCHN,2)=J
16751 ISIG(NCHN,3)=1
16752 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
16753 & JA.GE.3))) THEN
16754 SIGH(NCHN)=FACQQ1
16755 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
16756 ELSE
16757 SIGH(NCHN)=FACCI1
16758 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
16759 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
16760 ENDIF
16761 IF(I.EQ.J) THEN
16762 SIGH(NCHN)=0.5D0*SIGH(NCHN)
16763 NCHN=NCHN+1
16764 ISIG(NCHN,1)=I
16765 ISIG(NCHN,2)=J
16766 ISIG(NCHN,3)=2
16767 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
16768 SIGH(NCHN)=0.5D0*FACQQ2
16769 ELSE
16770 SIGH(NCHN)=0.5D0*FACCI2
16771 ENDIF
16772 ENDIF
16773 280 CONTINUE
16774 290 CONTINUE
16775
16776 ELSEIF(ISUB.EQ.12) THEN
16777C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
16778 CALL PYWIDT(21,SH,WDTP,WDTE)
16779 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
16780 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16781 IF(MSTP(5).EQ.1) THEN
16782C...Modifications from contact interactions (compositeness)
16783 FACCIB=FACQQB
16784 DO 300 I=1,2
16785 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
16786 & WDTE(I,2)+WDTE(I,4))
16787 300 CONTINUE
16788 ELSEIF(MSTP(5).GE.2) THEN
16789 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
16790 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16791 ENDIF
16792 DO 310 I=MMINA,MMAXA
16793 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16794 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
16795 NCHN=NCHN+1
16796 ISIG(NCHN,1)=I
16797 ISIG(NCHN,2)=-I
16798 ISIG(NCHN,3)=1
16799 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
16800 SIGH(NCHN)=FACQQB
16801 ELSE
16802 SIGH(NCHN)=FACCIB
16803 ENDIF
16804 310 CONTINUE
16805
16806 ELSEIF(ISUB.EQ.13) THEN
16807C...f + fbar -> g + g (q + qbar -> g + g only)
16808 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
16809 & UH2/SH2)
16810 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
16811 & TH2/SH2)
16812 DO 320 I=MMINA,MMAXA
16813 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16814 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
16815 NCHN=NCHN+1
16816 ISIG(NCHN,1)=I
16817 ISIG(NCHN,2)=-I
16818 ISIG(NCHN,3)=1
16819 SIGH(NCHN)=0.5D0*FACGG1
16820 NCHN=NCHN+1
16821 ISIG(NCHN,1)=I
16822 ISIG(NCHN,2)=-I
16823 ISIG(NCHN,3)=2
16824 SIGH(NCHN)=0.5D0*FACGG2
16825 320 CONTINUE
16826
16827 ELSEIF(ISUB.EQ.14) THEN
16828C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
16829 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
16830 DO 330 I=MMINA,MMAXA
16831 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16832 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
16833 EI=KCHG(IABS(I),1)/3D0
16834 NCHN=NCHN+1
16835 ISIG(NCHN,1)=I
16836 ISIG(NCHN,2)=-I
16837 ISIG(NCHN,3)=1
16838 SIGH(NCHN)=FACGG*EI**2
16839 330 CONTINUE
16840
16841 ELSEIF(ISUB.EQ.15) THEN
16842C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
16843 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16844C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16845 HFGG=0D0
16846 HFGZ=0D0
16847 HFZZ=0D0
16848 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16849 DO 340 I=1,MIN(16,MDCY(23,3))
16850 IDC=I+MDCY(23,2)-1
16851 IF(MDME(IDC,1).LT.0) GOTO 340
16852 IMDM=0
16853 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16854 & IMDM=1
16855 IF(I.LE.8) THEN
16856 EF=KCHG(I,1)/3D0
16857 AF=SIGN(1D0,EF+0.1D0)
16858 VF=AF-4D0*EF*XWV
16859 ELSEIF(I.LE.16) THEN
16860 EF=KCHG(I+2,1)/3D0
16861 AF=SIGN(1D0,EF+0.1D0)
16862 VF=AF-4D0*EF*XWV
16863 ENDIF
16864 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16865 IF(4D0*RM1.LT.1D0) THEN
16866 FCOF=1D0
16867 IF(I.LE.8) FCOF=3D0*RADC4
16868 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16869 IF(IMDM.EQ.1) THEN
16870 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16871 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16872 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16873 & AF**2*(1D0-4D0*RM1))*BE34
16874 ENDIF
16875 ENDIF
16876 340 CONTINUE
16877C...Propagators: as simulated in PYOFSH and as desired
16878 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16879 MINT(15)=1
16880 MINT(61)=1
16881 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16882 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16883 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16884 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16885 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16886C...Loop over flavours; consider full gamma/Z structure
16887 DO 350 I=MMINA,MMAXA
16888 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16889 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
16890 EI=KCHG(IABS(I),1)/3D0
16891 AI=SIGN(1D0,EI)
16892 VI=AI-4D0*EI*XWV
16893 NCHN=NCHN+1
16894 ISIG(NCHN,1)=I
16895 ISIG(NCHN,2)=-I
16896 ISIG(NCHN,3)=1
16897 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
16898 & (VI**2+AI**2)*HFZZ)/HBW4
16899 350 CONTINUE
16900
16901 ELSEIF(ISUB.EQ.16) THEN
16902C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
16903 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16904C...Propagators: as simulated in PYOFSH and as desired
16905 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
16906 CALL PYWIDT(24,SQM4,WDTP,WDTE)
16907 GMMWC=SQRT(SQM4)*WDTP(0)
16908 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
16909 FACWG=FACWG*HBW4C/HBW4
16910 DO 370 I=MMIN1,MMAX1
16911 IA=IABS(I)
16912 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
16913 DO 360 J=MMIN2,MMAX2
16914 JA=IABS(J)
16915 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
16916 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
16917 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16918 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
16919 FCKM=VCKM((IA+1)/2,(JA+1)/2)
16920 NCHN=NCHN+1
16921 ISIG(NCHN,1)=I
16922 ISIG(NCHN,2)=J
16923 ISIG(NCHN,3)=1
16924 SIGH(NCHN)=FACWG*FCKM*WIDSC
16925 360 CONTINUE
16926 370 CONTINUE
16927
16928 ELSEIF(ISUB.EQ.17) THEN
16929C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
16930
16931 ELSEIF(ISUB.EQ.18) THEN
16932C...f + fbar -> gamma + gamma
16933 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
16934 DO 380 I=MMINA,MMAXA
16935 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
16936 EI=KCHG(IABS(I),1)/3D0
16937 FCOI=1D0
16938 IF(IABS(I).LE.10) FCOI=FACA/3D0
16939 NCHN=NCHN+1
16940 ISIG(NCHN,1)=I
16941 ISIG(NCHN,2)=-I
16942 ISIG(NCHN,3)=1
16943 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
16944 380 CONTINUE
16945
16946 ELSEIF(ISUB.EQ.19) THEN
16947C...f + fbar -> gamma + (gamma*/Z0)
16948 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16949C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16950 HFGG=0D0
16951 HFGZ=0D0
16952 HFZZ=0D0
16953 RADC4=1D0+PYALPS(SQM4)/PARU(1)
16954 DO 390 I=1,MIN(16,MDCY(23,3))
16955 IDC=I+MDCY(23,2)-1
16956 IF(MDME(IDC,1).LT.0) GOTO 390
16957 IMDM=0
16958 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16959 & IMDM=1
16960 IF(I.LE.8) THEN
16961 EF=KCHG(I,1)/3D0
16962 AF=SIGN(1D0,EF+0.1D0)
16963 VF=AF-4D0*EF*XWV
16964 ELSEIF(I.LE.16) THEN
16965 EF=KCHG(I+2,1)/3D0
16966 AF=SIGN(1D0,EF+0.1D0)
16967 VF=AF-4D0*EF*XWV
16968 ENDIF
16969 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16970 IF(4D0*RM1.LT.1D0) THEN
16971 FCOF=1D0
16972 IF(I.LE.8) FCOF=3D0*RADC4
16973 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16974 IF(IMDM.EQ.1) THEN
16975 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16976 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16977 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16978 & AF**2*(1D0-4D0*RM1))*BE34
16979 ENDIF
16980 ENDIF
16981 390 CONTINUE
16982C...Propagators: as simulated in PYOFSH and as desired
16983 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16984 MINT(15)=1
16985 MINT(61)=1
16986 CALL PYWIDT(23,SQM4,WDTP,WDTE)
16987 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16988 HFGG=HFGG*HFAEM*VINT(111)/SQM4
16989 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16990 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16991C...Loop over flavours; consider full gamma/Z structure
16992 DO 400 I=MMINA,MMAXA
16993 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
16994 EI=KCHG(IABS(I),1)/3D0
16995 AI=SIGN(1D0,EI)
16996 VI=AI-4D0*EI*XWV
16997 FCOI=1D0
16998 IF(IABS(I).LE.10) FCOI=FACA/3D0
16999 NCHN=NCHN+1
17000 ISIG(NCHN,1)=I
17001 ISIG(NCHN,2)=-I
17002 ISIG(NCHN,3)=1
17003 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17004 & (VI**2+AI**2)*HFZZ)/HBW4
17005 400 CONTINUE
17006
17007 ELSEIF(ISUB.EQ.20) THEN
17008C...f + fbar' -> gamma + W+/-
17009 FACGW=COMFAC*0.5D0*AEM**2/XW
17010C...Propagators: as simulated in PYOFSH and as desired
17011 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17012 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17013 GMMWC=SQRT(SQM4)*WDTP(0)
17014 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17015 FACGW=FACGW*HBW4C/HBW4
17016C...Anomalous couplings
17017 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
17018 TERM2=0D0
17019 TERM3=0D0
17020 IF(MSTP(5).GE.1) THEN
17021 TERM2=PARU(153)*(TH-UH)/(TH+UH)
17022 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
17023 & (4D0*SQMW))/(TH+UH)**2
17024 ENDIF
17025 DO 420 I=MMIN1,MMAX1
17026 IA=IABS(I)
17027 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
17028 DO 410 J=MMIN2,MMAX2
17029 JA=IABS(J)
17030 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
17031 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
17032 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17033 & GOTO 410
17034 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17035 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17036 IF(IA.LE.10) THEN
17037 FACWR=UH/(TH+UH)-1D0/3D0
17038 FCKM=VCKM((IA+1)/2,(JA+1)/2)
17039 FCOI=FACA/3D0
17040 ELSE
17041 FACWR=-TH/(TH+UH)
17042 FCKM=1D0
17043 FCOI=1D0
17044 ENDIF
17045 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
17046 NCHN=NCHN+1
17047 ISIG(NCHN,1)=I
17048 ISIG(NCHN,2)=J
17049 ISIG(NCHN,3)=1
17050 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
17051 410 CONTINUE
17052 420 CONTINUE
17053 ENDIF
17054
17055 ELSEIF(ISUB.LE.30) THEN
17056 IF(ISUB.EQ.21) THEN
17057C...f + fbar -> gamma + h0
17058
17059 ELSEIF(ISUB.EQ.22) THEN
17060C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
17061C...Kinematics dependence
17062 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
17063 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
17064C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17065 DO 440 I=1,6
17066 DO 430 J=1,3
17067 HGZ(I,J)=0D0
17068 430 CONTINUE
17069 440 CONTINUE
17070 RADC3=1D0+PYALPS(SQM3)/PARU(1)
17071 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17072 DO 450 I=1,MIN(16,MDCY(23,3))
17073 IDC=I+MDCY(23,2)-1
17074 IF(MDME(IDC,1).LT.0) GOTO 450
17075 IMDM=0
17076 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
17077 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
17078 IF(I.LE.8) THEN
17079 EF=KCHG(I,1)/3D0
17080 AF=SIGN(1D0,EF+0.1D0)
17081 VF=AF-4D0*EF*XWV
17082 ELSEIF(I.LE.16) THEN
17083 EF=KCHG(I+2,1)/3D0
17084 AF=SIGN(1D0,EF+0.1D0)
17085 VF=AF-4D0*EF*XWV
17086 ENDIF
17087 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
17088 IF(4D0*RM1.LT.1D0) THEN
17089 FCOF=1D0
17090 IF(I.LE.8) FCOF=3D0*RADC3
17091 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17092 IF(IMDM.GE.1) THEN
17093 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17094 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17095 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17096 & AF**2*(1D0-4D0*RM1))*BE34
17097 ENDIF
17098 ENDIF
17099 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17100 IF(4D0*RM1.LT.1D0) THEN
17101 FCOF=1D0
17102 IF(I.LE.8) FCOF=3D0*RADC4
17103 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17104 IF(IMDM.GE.1) THEN
17105 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17106 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17107 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17108 & AF**2*(1D0-4D0*RM1))*BE34
17109 ENDIF
17110 ENDIF
17111 450 CONTINUE
17112C...Propagators: as simulated in PYOFSH and as desired
17113 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
17114 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17115 MINT(15)=1
17116 MINT(61)=1
17117 CALL PYWIDT(23,SQM3,WDTP,WDTE)
17118 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17119 DO 460 J=1,3
17120 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
17121 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
17122 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
17123 460 CONTINUE
17124 MINT(61)=1
17125 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17126 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17127 DO 470 J=1,3
17128 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
17129 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
17130 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
17131 470 CONTINUE
17132C...Loop over flavours; separate left- and right-handed couplings
17133 DO 490 I=MMINA,MMAXA
17134 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
17135 EI=KCHG(IABS(I),1)/3D0
17136 AI=SIGN(1D0,EI)
17137 VI=AI-4D0*EI*XWV
17138 VALI=VI-AI
17139 VARI=VI+AI
17140 FCOI=1D0
17141 IF(IABS(I).LE.10) FCOI=FACA/3D0
17142 DO 480 J=1,3
17143 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
17144 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
17145 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
17146 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
17147 480 CONTINUE
17148 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
17149 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
17150 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
17151 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
17152 NCHN=NCHN+1
17153 ISIG(NCHN,1)=I
17154 ISIG(NCHN,2)=-I
17155 ISIG(NCHN,3)=1
17156 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
17157 490 CONTINUE
17158
17159 ELSEIF(ISUB.EQ.23) THEN
17160C...f + fbar' -> Z0 + W+/-
17161 FACZW=COMFAC*0.5D0*(AEM/XW)**2
17162 FACZW=FACZW*WIDS(23,2)
17163 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17164 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17165 DO 510 I=MMIN1,MMAX1
17166 IA=IABS(I)
17167 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
17168 DO 500 J=MMIN2,MMAX2
17169 JA=IABS(J)
17170 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
17171 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
17172 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17173 & GOTO 500
17174 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17175 EI=KCHG(IA,1)/3D0
17176 AI=SIGN(1D0,EI+0.1D0)
17177 VI=AI-4D0*EI*XWV
17178 EJ=KCHG(JA,1)/3D0
17179 AJ=SIGN(1D0,EJ+0.1D0)
17180 VJ=AJ-4D0*EJ*XWV
17181 IF(VI+AI.GT.0) THEN
17182 VISAV=VI
17183 AISAV=AI
17184 VI=VJ
17185 AI=AJ
17186 VJ=VISAV
17187 AJ=AISAV
17188 ENDIF
17189 FCKM=1D0
17190 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17191 FCOI=1D0
17192 IF(IA.LE.10) FCOI=FACA/3D0
17193 NCHN=NCHN+1
17194 ISIG(NCHN,1)=I
17195 ISIG(NCHN,2)=J
17196 ISIG(NCHN,3)=1
17197 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
17198 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
17199 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
17200 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
17201 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
17202 & WIDS(24,(5-KCHW)/2)
17203 500 CONTINUE
17204 510 CONTINUE
17205
17206 ELSEIF(ISUB.EQ.24) THEN
17207C...f + fbar -> Z0 + h0 (or H0, or A0)
17208 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17209 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
17210 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
17211 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
17212 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
17213 & PARU(154+10*IHIGG)**2
17214 DO 520 I=MMINA,MMAXA
17215 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
17216 EI=KCHG(IABS(I),1)/3D0
17217 AI=SIGN(1D0,EI)
17218 VI=AI-4D0*EI*XWV
17219 FCOI=1D0
17220 IF(IABS(I).LE.10) FCOI=FACA/3D0
17221 NCHN=NCHN+1
17222 ISIG(NCHN,1)=I
17223 ISIG(NCHN,2)=-I
17224 ISIG(NCHN,3)=1
17225 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
17226 520 CONTINUE
17227
17228 ELSEIF(ISUB.EQ.25) THEN
17229C...f + fbar -> W+ + W-
17230C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
17231 CALL PYWIDT(23,SH,WDTP,WDTE)
17232 GMMZC=SHR*WDTP(0)
17233 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
17234 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
17235 CALL PYWIDT(24,SQM3,WDTP,WDTE)
17236 GMMW3=SQRT(SQM3)*WDTP(0)
17237 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
17238 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17239 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17240 GMMW4=SQRT(SQM4)*WDTP(0)
17241 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
17242C...Kinematical functions
17243 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17244 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
17245 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
17246 GT=THUH34+4D0*THUH/TH2
17247 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
17248 GU=THUH34+4D0*THUH/UH2
17249 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
17250C...Common factors and couplings
17251 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
17252 FACWW=FACWW*WIDS(24,1)
17253 CGG=AEM**2/2D0
17254 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
17255 CZZ=AEM**2/(32D0*XW**2)*HBWZC
17256 CNG=AEM**2/(4D0*XW)
17257 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
17258 CNN=AEM**2/(16D0*XW**2)
17259C...Coulomb factor for W+W- pair
17260 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
17261 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
17262 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
17263 IF(COULE.LT.100D0*PMAS(24,2)) THEN
17264 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17265 & PMAS(24,2)**2)-COULE))
17266 ELSE
17267 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
17268 ENDIF
17269 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
17270 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17271 & PMAS(24,2)**2)+COULE))
17272 ELSE
17273 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
17274 & ABS(COULE)))
17275 ENDIF
17276 IF(MSTP(40).EQ.1) THEN
17277 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
17278 & MAX(1D-10,2D0*COULP*COULP1))
17279 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17280 ELSEIF(MSTP(40).EQ.2) THEN
17281 COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
17282 COULCP=CMPLX(0.,SNGL(COULP))
17283 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
17284 COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
17285 COULCS=CMPLX(0.,0.)
17286 NSTP=100
17287 DO 530 ISTP=1,NSTP
17288 COULXX=(ISTP-0.5)/NSTP
17289 COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
17290 & (1.+COULXX/COULCD))
17291 530 CONTINUE
17292 COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
17293 & (COULCS/NSTP)
17294 FACCOU=ABS(COULCR)**2
17295 ELSEIF(MSTP(40).EQ.3) THEN
17296 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
17297 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
17298 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17299 ENDIF
17300 ELSEIF(MSTP(40).EQ.4) THEN
17301 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
17302 ELSE
17303 FACCOU=1D0
17304 ENDIF
17305 VINT(95)=FACCOU
17306 FACWW=FACWW*FACCOU
17307C...Loop over allowed flavours
17308 DO 540 I=MMINA,MMAXA
17309 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
17310 EI=KCHG(IABS(I),1)/3D0
17311 AI=SIGN(1D0,EI+0.1D0)
17312 VI=AI-4D0*EI*XWV
17313 FCOI=1D0
17314 IF(IABS(I).LE.10) FCOI=FACA/3D0
17315 IF(AI.LT.0D0) THEN
17316 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
17317 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
17318 ELSE
17319 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
17320 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
17321 ENDIF
17322 NCHN=NCHN+1
17323 ISIG(NCHN,1)=I
17324 ISIG(NCHN,2)=-I
17325 ISIG(NCHN,3)=1
17326 SIGH(NCHN)=FACWW*FCOI*DSIGWW
17327 540 CONTINUE
17328
17329 ELSEIF(ISUB.EQ.26) THEN
17330C...f + fbar' -> W+/- + h0 (or H0, or A0)
17331 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17332 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
17333 & ((SH-SQMW)**2+GMMW**2)
17334 FACHW=FACHW*WIDS(KFHIGG,2)
17335 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
17336 & PARU(155+10*IHIGG)**2
17337 DO 560 I=MMIN1,MMAX1
17338 IA=IABS(I)
17339 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
17340 DO 550 J=MMIN2,MMAX2
17341 JA=IABS(J)
17342 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
17343 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
17344 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17345 & GOTO 550
17346 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17347 FCKM=1D0
17348 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17349 FCOI=1D0
17350 IF(IA.LE.10) FCOI=FACA/3D0
17351 NCHN=NCHN+1
17352 ISIG(NCHN,1)=I
17353 ISIG(NCHN,2)=J
17354 ISIG(NCHN,3)=1
17355 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
17356 550 CONTINUE
17357 560 CONTINUE
17358
17359 ELSEIF(ISUB.EQ.27) THEN
17360C...f + fbar -> h0 + h0
17361
17362 ELSEIF(ISUB.EQ.28) THEN
17363C...f + g -> f + g (q + g -> q + g only)
17364 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
17365 & UH/SH)*FACA
17366 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
17367 & SH/UH)
17368 DO 580 I=MMINA,MMAXA
17369 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
17370 DO 570 ISDE=1,2
17371 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
17372 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
17373 NCHN=NCHN+1
17374 ISIG(NCHN,ISDE)=I
17375 ISIG(NCHN,3-ISDE)=21
17376 ISIG(NCHN,3)=1
17377 SIGH(NCHN)=FACQG1
17378 NCHN=NCHN+1
17379 ISIG(NCHN,ISDE)=I
17380 ISIG(NCHN,3-ISDE)=21
17381 ISIG(NCHN,3)=2
17382 SIGH(NCHN)=FACQG2
17383 570 CONTINUE
17384 580 CONTINUE
17385
17386 ELSEIF(ISUB.EQ.29) THEN
17387C...f + g -> f + gamma (q + g -> q + gamma only)
17388 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
17389 DO 600 I=MMINA,MMAXA
17390 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
17391 EI=KCHG(IABS(I),1)/3D0
17392 FACGQ=FGQ*EI**2
17393 DO 590 ISDE=1,2
17394 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
17395 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
17396 NCHN=NCHN+1
17397 ISIG(NCHN,ISDE)=I
17398 ISIG(NCHN,3-ISDE)=21
17399 ISIG(NCHN,3)=1
17400 SIGH(NCHN)=FACGQ
17401 590 CONTINUE
17402 600 CONTINUE
17403
17404 ELSEIF(ISUB.EQ.30) THEN
17405C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
17406 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
17407 & (-SH*UH)
17408C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17409 HFGG=0D0
17410 HFGZ=0D0
17411 HFZZ=0D0
17412 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17413 DO 610 I=1,MIN(16,MDCY(23,3))
17414 IDC=I+MDCY(23,2)-1
17415 IF(MDME(IDC,1).LT.0) GOTO 610
17416 IMDM=0
17417 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17418 & IMDM=1
17419 IF(I.LE.8) THEN
17420 EF=KCHG(I,1)/3D0
17421 AF=SIGN(1D0,EF+0.1D0)
17422 VF=AF-4D0*EF*XWV
17423 ELSEIF(I.LE.16) THEN
17424 EF=KCHG(I+2,1)/3D0
17425 AF=SIGN(1D0,EF+0.1D0)
17426 VF=AF-4D0*EF*XWV
17427 ENDIF
17428 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17429 IF(4D0*RM1.LT.1D0) THEN
17430 FCOF=1D0
17431 IF(I.LE.8) FCOF=3D0*RADC4
17432 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17433 IF(IMDM.EQ.1) THEN
17434 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17435 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17436 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17437 & AF**2*(1D0-4D0*RM1))*BE34
17438 ENDIF
17439 ENDIF
17440 610 CONTINUE
17441C...Propagators: as simulated in PYOFSH and as desired
17442 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17443 MINT(15)=1
17444 MINT(61)=1
17445 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17446 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17447 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17448 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17449 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17450C...Loop over flavours; consider full gamma/Z structure
17451 DO 630 I=MMINA,MMAXA
17452 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
17453 EI=KCHG(IABS(I),1)/3D0
17454 AI=SIGN(1D0,EI)
17455 VI=AI-4D0*EI*XWV
17456 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
17457 & (VI**2+AI**2)*HFZZ)/HBW4
17458 DO 620 ISDE=1,2
17459 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
17460 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
17461 NCHN=NCHN+1
17462 ISIG(NCHN,ISDE)=I
17463 ISIG(NCHN,3-ISDE)=21
17464 ISIG(NCHN,3)=1
17465 SIGH(NCHN)=FACZQ
17466 620 CONTINUE
17467 630 CONTINUE
17468 ENDIF
17469
17470 ELSEIF(ISUB.LE.40) THEN
17471 IF(ISUB.EQ.31) THEN
17472C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
17473 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
17474 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
17475C...Propagators: as simulated in PYOFSH and as desired
17476 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17477 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17478 GMMWC=SQRT(SQM4)*WDTP(0)
17479 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17480 FACWQ=FACWQ*HBW4C/HBW4
17481 DO 650 I=MMINA,MMAXA
17482 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
17483 IA=IABS(I)
17484 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17485 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17486 DO 640 ISDE=1,2
17487 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
17488 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
17489 NCHN=NCHN+1
17490 ISIG(NCHN,ISDE)=I
17491 ISIG(NCHN,3-ISDE)=21
17492 ISIG(NCHN,3)=1
17493 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17494 640 CONTINUE
17495 650 CONTINUE
17496
17497 ELSEIF(ISUB.EQ.32) THEN
17498C...f + g -> f + h0 (q + g -> q + h0 only)
17499
17500 ELSEIF(ISUB.EQ.33) THEN
17501C...f + gamma -> f + g (q + gamma -> q + g only)
17502 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
17503 DO 670 I=MMINA,MMAXA
17504 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
17505 EI=KCHG(IABS(I),1)/3D0
17506 FACGQ=FGQ*EI**2
17507 DO 660 ISDE=1,2
17508 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
17509 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
17510 NCHN=NCHN+1
17511 ISIG(NCHN,ISDE)=I
17512 ISIG(NCHN,3-ISDE)=22
17513 ISIG(NCHN,3)=1
17514 SIGH(NCHN)=FACGQ
17515 660 CONTINUE
17516 670 CONTINUE
17517
17518 ELSEIF(ISUB.EQ.34) THEN
17519C...f + gamma -> f + gamma
17520 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
17521 DO 690 I=MMINA,MMAXA
17522 IF(I.EQ.0) GOTO 690
17523 EI=KCHG(IABS(I),1)/3D0
17524 FACGQ=FGQ*EI**4
17525 DO 680 ISDE=1,2
17526 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
17527 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
17528 NCHN=NCHN+1
17529 ISIG(NCHN,ISDE)=I
17530 ISIG(NCHN,3-ISDE)=22
17531 ISIG(NCHN,3)=1
17532 SIGH(NCHN)=FACGQ
17533 680 CONTINUE
17534 690 CONTINUE
17535
17536 ELSEIF(ISUB.EQ.35) THEN
17537C...f + gamma -> f + (gamma*/Z0)
17538 FZQN=COMFAC*2D0*AEM**2*(SH2+UH2+2D0*SQM4*TH)
17539 FZQD=SQPTH*SQM4-SH*UH
17540C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17541 HFGG=0D0
17542 HFGZ=0D0
17543 HFZZ=0D0
17544 RADC4=1D0+PYALPS(SQM4)/PARU(1)
17545 DO 700 I=1,MIN(16,MDCY(23,3))
17546 IDC=I+MDCY(23,2)-1
17547 IF(MDME(IDC,1).LT.0) GOTO 700
17548 IMDM=0
17549 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17550 & IMDM=1
17551 IF(I.LE.8) THEN
17552 EF=KCHG(I,1)/3D0
17553 AF=SIGN(1D0,EF+0.1D0)
17554 VF=AF-4D0*EF*XWV
17555 ELSEIF(I.LE.16) THEN
17556 EF=KCHG(I+2,1)/3D0
17557 AF=SIGN(1D0,EF+0.1D0)
17558 VF=AF-4D0*EF*XWV
17559 ENDIF
17560 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17561 IF(4D0*RM1.LT.1D0) THEN
17562 FCOF=1D0
17563 IF(I.LE.8) FCOF=3D0*RADC4
17564 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17565 IF(IMDM.EQ.1) THEN
17566 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17567 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17568 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17569 & AF**2*(1D0-4D0*RM1))*BE34
17570 ENDIF
17571 ENDIF
17572 700 CONTINUE
17573C...Propagators: as simulated in PYOFSH and as desired
17574 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17575 MINT(15)=1
17576 MINT(61)=1
17577 CALL PYWIDT(23,SQM4,WDTP,WDTE)
17578 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17579 HFGG=HFGG*HFAEM*VINT(111)/SQM4
17580 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17581 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17582C...Loop over flavours; consider full gamma/Z structure
17583 DO 720 I=MMINA,MMAXA
17584 IF(I.EQ.0) GOTO 720
17585 EI=KCHG(IABS(I),1)/3D0
17586 AI=SIGN(1D0,EI)
17587 VI=AI-4D0*EI*XWV
17588 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17589 & (VI**2+AI**2)*HFZZ)/HBW4
17590 DO 710 ISDE=1,2
17591 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
17592 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
17593 NCHN=NCHN+1
17594 ISIG(NCHN,ISDE)=I
17595 ISIG(NCHN,3-ISDE)=22
17596 ISIG(NCHN,3)=1
17597 SIGH(NCHN)=FACZQ*FZQN/MAX(PMAS(IABS(I),1)**2*SQM4,FZQD)
17598 710 CONTINUE
17599 720 CONTINUE
17600
17601 ELSEIF(ISUB.EQ.36) THEN
17602C...f + gamma -> f' + W+/-
17603 FWQ=COMFAC*AEM**2/(2D0*XW)*
17604 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
17605C...Propagators: as simulated in PYOFSH and as desired
17606 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17607 CALL PYWIDT(24,SQM4,WDTP,WDTE)
17608 GMMWC=SQRT(SQM4)*WDTP(0)
17609 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17610 FWQ=FWQ*HBW4C/HBW4
17611 DO 740 I=MMINA,MMAXA
17612 IF(I.EQ.0) GOTO 740
17613 IA=IABS(I)
17614 EIA=ABS(KCHG(IABS(I),1)/3D0)
17615 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
17616 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17617 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17618 DO 730 ISDE=1,2
17619 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
17620 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
17621 NCHN=NCHN+1
17622 ISIG(NCHN,ISDE)=I
17623 ISIG(NCHN,3-ISDE)=22
17624 ISIG(NCHN,3)=1
17625 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17626 730 CONTINUE
17627 740 CONTINUE
17628
17629 ELSEIF(ISUB.EQ.37) THEN
17630C...f + gamma -> f + h0
17631
17632 ELSEIF(ISUB.EQ.38) THEN
17633C...f + Z0 -> f + g (q + Z0 -> q + g only)
17634
17635 ELSEIF(ISUB.EQ.39) THEN
17636C...f + Z0 -> f + gamma
17637
17638 ELSEIF(ISUB.EQ.40) THEN
17639C...f + Z0 -> f + Z0
17640 ENDIF
17641
17642 ELSEIF(ISUB.LE.50) THEN
17643 IF(ISUB.EQ.41) THEN
17644C...f + Z0 -> f' + W+/-
17645
17646 ELSEIF(ISUB.EQ.42) THEN
17647C...f + Z0 -> f + h0
17648
17649 ELSEIF(ISUB.EQ.43) THEN
17650C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
17651
17652 ELSEIF(ISUB.EQ.44) THEN
17653C...f + W+/- -> f' + gamma
17654
17655 ELSEIF(ISUB.EQ.45) THEN
17656C...f + W+/- -> f' + Z0
17657
17658 ELSEIF(ISUB.EQ.46) THEN
17659C...f + W+/- -> f' + W+/-
17660
17661 ELSEIF(ISUB.EQ.47) THEN
17662C...f + W+/- -> f' + h0
17663
17664 ELSEIF(ISUB.EQ.48) THEN
17665C...f + h0 -> f + g (q + h0 -> q + g only)
17666
17667 ELSEIF(ISUB.EQ.49) THEN
17668C...f + h0 -> f + gamma
17669
17670 ELSEIF(ISUB.EQ.50) THEN
17671C...f + h0 -> f + Z0
17672 ENDIF
17673
17674 ELSEIF(ISUB.LE.60) THEN
17675 IF(ISUB.EQ.51) THEN
17676C...f + h0 -> f' + W+/-
17677
17678 ELSEIF(ISUB.EQ.52) THEN
17679C...f + h0 -> f + h0
17680
17681 ELSEIF(ISUB.EQ.53) THEN
17682C...g + g -> f + fbar (g + g -> q + qbar only)
17683 CALL PYWIDT(21,SH,WDTP,WDTE)
17684 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
17685 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17686 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
17687 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17688 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
17689 NCHN=NCHN+1
17690 ISIG(NCHN,1)=21
17691 ISIG(NCHN,2)=21
17692 ISIG(NCHN,3)=1
17693 SIGH(NCHN)=FACQQ1
17694 NCHN=NCHN+1
17695 ISIG(NCHN,1)=21
17696 ISIG(NCHN,2)=21
17697 ISIG(NCHN,3)=2
17698 SIGH(NCHN)=FACQQ2
17699 750 CONTINUE
17700
17701 ELSEIF(ISUB.EQ.54) THEN
17702C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
17703 CALL PYWIDT(21,SH,WDTP,WDTE)
17704 WDTESU=0D0
17705 DO 760 I=1,MIN(8,MDCY(21,3))
17706 EF=KCHG(I,1)/3D0
17707 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17708 & WDTE(I,4))
17709 760 CONTINUE
17710 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
17711 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
17712 NCHN=NCHN+1
17713 ISIG(NCHN,1)=21
17714 ISIG(NCHN,2)=22
17715 ISIG(NCHN,3)=1
17716 SIGH(NCHN)=FACQQ
17717 ENDIF
17718 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
17719 NCHN=NCHN+1
17720 ISIG(NCHN,1)=22
17721 ISIG(NCHN,2)=21
17722 ISIG(NCHN,3)=1
17723 SIGH(NCHN)=FACQQ
17724 ENDIF
17725
17726 ELSEIF(ISUB.EQ.55) THEN
17727C...g + Z -> f + fbar (g + Z -> q + qbar only)
17728
17729 ELSEIF(ISUB.EQ.56) THEN
17730C...g + W -> f + f'bar (g + W -> q + q'bar only)
17731
17732 ELSEIF(ISUB.EQ.57) THEN
17733C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
17734
17735 ELSEIF(ISUB.EQ.58) THEN
17736C...gamma + gamma -> f + fbar
17737 CALL PYWIDT(22,SH,WDTP,WDTE)
17738 WDTESU=0D0
17739 DO 770 I=1,MIN(12,MDCY(22,3))
17740 IF(I.LE.8) EF= KCHG(I,1)/3D0
17741 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
17742 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17743 & WDTE(I,4))
17744 770 CONTINUE
17745 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
17746 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
17747 NCHN=NCHN+1
17748 ISIG(NCHN,1)=22
17749 ISIG(NCHN,2)=22
17750 ISIG(NCHN,3)=1
17751 SIGH(NCHN)=FACFF
17752 ENDIF
17753
17754 ELSEIF(ISUB.EQ.59) THEN
17755C...gamma + Z0 -> f + fbar
17756
17757 ELSEIF(ISUB.EQ.60) THEN
17758C...gamma + W+/- -> f + fbar'
17759 ENDIF
17760
17761 ELSEIF(ISUB.LE.70) THEN
17762 IF(ISUB.EQ.61) THEN
17763C...gamma + h0 -> f + fbar
17764
17765 ELSEIF(ISUB.EQ.62) THEN
17766C...Z0 + Z0 -> f + fbar
17767
17768 ELSEIF(ISUB.EQ.63) THEN
17769C...Z0 + W+/- -> f + fbar'
17770
17771 ELSEIF(ISUB.EQ.64) THEN
17772C...Z0 + h0 -> f + fbar
17773
17774 ELSEIF(ISUB.EQ.65) THEN
17775C...W+ + W- -> f + fbar
17776
17777 ELSEIF(ISUB.EQ.66) THEN
17778C...W+/- + h0 -> f + fbar'
17779
17780 ELSEIF(ISUB.EQ.67) THEN
17781C...h0 + h0 -> f + fbar
17782
17783 ELSEIF(ISUB.EQ.68) THEN
17784C...g + g -> g + g
17785 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
17786 & TH2/SH2)*FACA
17787 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
17788 & SH2/UH2)*FACA
17789 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
17790 & UH2/TH2)
17791 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
17792 NCHN=NCHN+1
17793 ISIG(NCHN,1)=21
17794 ISIG(NCHN,2)=21
17795 ISIG(NCHN,3)=1
17796 SIGH(NCHN)=0.5D0*FACGG1
17797 NCHN=NCHN+1
17798 ISIG(NCHN,1)=21
17799 ISIG(NCHN,2)=21
17800 ISIG(NCHN,3)=2
17801 SIGH(NCHN)=0.5D0*FACGG2
17802 NCHN=NCHN+1
17803 ISIG(NCHN,1)=21
17804 ISIG(NCHN,2)=21
17805 ISIG(NCHN,3)=3
17806 SIGH(NCHN)=0.5D0*FACGG3
17807 780 CONTINUE
17808
17809 ELSEIF(ISUB.EQ.69) THEN
17810C...gamma + gamma -> W+ + W-
17811 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17812 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
17813 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
17814 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
17815 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
17816 NCHN=NCHN+1
17817 ISIG(NCHN,1)=22
17818 ISIG(NCHN,2)=22
17819 ISIG(NCHN,3)=1
17820 SIGH(NCHN)=FACWW
17821 790 CONTINUE
17822
17823 ELSEIF(ISUB.EQ.70) THEN
17824C...gamma + W+/- -> Z0 + W+/-
17825 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17826 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
17827 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
17828 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
17829 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
17830 DO 810 KCHW=1,-1,-2
17831 DO 800 ISDE=1,2
17832 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
17833 NCHN=NCHN+1
17834 ISIG(NCHN,ISDE)=22
17835 ISIG(NCHN,3-ISDE)=24*KCHW
17836 ISIG(NCHN,3)=1
17837 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
17838 800 CONTINUE
17839 810 CONTINUE
17840 ENDIF
17841
17842 ELSEIF(ISUB.LE.80) THEN
17843 IF(ISUB.EQ.71) THEN
17844C...Z0 + Z0 -> Z0 + Z0
17845 IF(SH.LE.4.01D0*SQMZ) GOTO 840
17846
17847 IF(MSTP(46).LE.2) THEN
17848C...Exact scattering ME:s for on-mass-shell gauge bosons
17849 BE2=1D0-4D0*SQMZ/SH
17850 TH=-0.5D0*SH*BE2*(1D0-CTH)
17851 UH=-0.5D0*SH*BE2*(1D0+CTH)
17852 IF(MAX(TH,UH).GT.-1D0) GOTO 840
17853 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
17854 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17855 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17856 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
17857 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17858 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17859 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
17860 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
17861 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
17862 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17863 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17864 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
17865 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
17866 & (ASHIM+ATHIM+AUHIM)**2)
17867 IF(MSTP(46).EQ.2) FACZZ=0D0
17868
17869 ELSE
17870C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17871 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17872 & ABS(A00U+2.*A20U)**2
17873 ENDIF
17874 FACZZ=FACZZ*WIDS(23,1)
17875
17876 DO 830 I=MMIN1,MMAX1
17877 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
17878 EI=KCHG(IABS(I),1)/3D0
17879 AI=SIGN(1D0,EI)
17880 VI=AI-4D0*EI*XWV
17881 AVI=AI**2+VI**2
17882 DO 820 J=MMIN2,MMAX2
17883 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
17884 EJ=KCHG(IABS(J),1)/3D0
17885 AJ=SIGN(1D0,EJ)
17886 VJ=AJ-4D0*EJ*XWV
17887 AVJ=AJ**2+VJ**2
17888 NCHN=NCHN+1
17889 ISIG(NCHN,1)=I
17890 ISIG(NCHN,2)=J
17891 ISIG(NCHN,3)=1
17892 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
17893 820 CONTINUE
17894 830 CONTINUE
17895 840 CONTINUE
17896
17897 ELSEIF(ISUB.EQ.72) THEN
17898C...Z0 + Z0 -> W+ + W-
17899 IF(SH.LE.4.01D0*SQMZ) GOTO 870
17900
17901 IF(MSTP(46).LE.2) THEN
17902C...Exact scattering ME:s for on-mass-shell gauge bosons
17903 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
17904 CTH2=CTH**2
17905 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
17906 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
17907 IF(MAX(TH,UH).GT.-1D0) GOTO 870
17908 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
17909 & (1D0-2D0*SQMZ/SH)
17910 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17911 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17912 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
17913 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17914 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17915 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
17916 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17917 ATWIM=0D0
17918 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
17919 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17920 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17921 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
17922 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17923 AUWIM=0D0
17924 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
17925 A4IM=0D0
17926 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17927 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17928 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
17929 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
17930 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
17931 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
17932 & (ATWIM+AUWIM+A4IM)**2)
17933
17934 ELSE
17935C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17936 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17937 & ABS(A00U-A20U)**2
17938 ENDIF
17939 FACWW=FACWW*WIDS(24,1)
17940
17941 DO 860 I=MMIN1,MMAX1
17942 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
17943 EI=KCHG(IABS(I),1)/3D0
17944 AI=SIGN(1D0,EI)
17945 VI=AI-4D0*EI*XWV
17946 AVI=AI**2+VI**2
17947 DO 850 J=MMIN2,MMAX2
17948 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
17949 EJ=KCHG(IABS(J),1)/3D0
17950 AJ=SIGN(1D0,EJ)
17951 VJ=AJ-4D0*EJ*XWV
17952 AVJ=AJ**2+VJ**2
17953 NCHN=NCHN+1
17954 ISIG(NCHN,1)=I
17955 ISIG(NCHN,2)=J
17956 ISIG(NCHN,3)=1
17957 SIGH(NCHN)=FACWW*AVI*AVJ
17958 850 CONTINUE
17959 860 CONTINUE
17960 870 CONTINUE
17961
17962 ELSEIF(ISUB.EQ.73) THEN
17963C...Z0 + W+/- -> Z0 + W+/-
17964 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
17965
17966 IF(MSTP(46).LE.2) THEN
17967C...Exact scattering ME:s for on-mass-shell gauge bosons
17968 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
17969 EP1=1D0-(SQMZ-SQMW)/SH
17970 EP2=1D0+(SQMZ-SQMW)/SH
17971 TH=-0.5D0*SH*BE2*(1D0-CTH)
17972 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
17973 IF(MAX(TH,UH).GT.-1D0) GOTO 900
17974 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
17975 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17976 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17977 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
17978 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
17979 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
17980 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
17981 ASWIM=0D0
17982 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
17983 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
17984 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
17985 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
17986 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
17987 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
17988 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
17989 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
17990 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
17991 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
17992 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
17993 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
17994 AUWIM=0D0
17995 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
17996 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
17997 A4IM=0D0
17998 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
17999 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
18000 IF(MSTP(46).LE.0) FACZW=0D0
18001 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
18002 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
18003 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
18004 & (ASWIM+AUWIM+A4IM)**2)
18005
18006 ELSE
18007C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18008 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
18009 & ABS(A20U+3.*A11U*SNGL(CTH))**2
18010 ENDIF
18011 FACZW=FACZW*WIDS(23,2)
18012
18013 DO 890 I=MMIN1,MMAX1
18014 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
18015 EI=KCHG(IABS(I),1)/3D0
18016 AI=SIGN(1D0,EI)
18017 VI=AI-4D0*EI*XWV
18018 AVI=AI**2+VI**2
18019 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
18020 DO 880 J=MMIN2,MMAX2
18021 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
18022 EJ=KCHG(IABS(J),1)/3D0
18023 AJ=SIGN(1D0,EJ)
18024 VJ=AI-4D0*EJ*XWV
18025 AVJ=AJ**2+VJ**2
18026 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
18027 NCHN=NCHN+1
18028 ISIG(NCHN,1)=I
18029 ISIG(NCHN,2)=J
18030 ISIG(NCHN,3)=1
18031 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
18032 NCHN=NCHN+1
18033 ISIG(NCHN,1)=I
18034 ISIG(NCHN,2)=J
18035 ISIG(NCHN,3)=2
18036 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
18037 880 CONTINUE
18038 890 CONTINUE
18039 900 CONTINUE
18040
18041 ELSEIF(ISUB.EQ.75) THEN
18042C...W+ + W- -> gamma + gamma
18043
18044 ELSEIF(ISUB.EQ.76) THEN
18045C...W+ + W- -> Z0 + Z0
18046 IF(SH.LE.4.01D0*SQMZ) GOTO 930
18047
18048 IF(MSTP(46).LE.2) THEN
18049C...Exact scattering ME:s for on-mass-shell gauge bosons
18050 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
18051 CTH2=CTH**2
18052 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
18053 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
18054 IF(MAX(TH,UH).GT.-1D0) GOTO 930
18055 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
18056 & (1D0-2D0*SQMZ/SH)
18057 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18058 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18059 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
18060 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18061 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18062 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
18063 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18064 ATWIM=0D0
18065 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
18066 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18067 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18068 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
18069 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18070 AUWIM=0D0
18071 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
18072 A4IM=0D0
18073 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18074 & (SH/SQMW)**2*SH2
18075 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
18076 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
18077 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
18078 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
18079 & (ATWIM+AUWIM+A4IM)**2)
18080
18081 ELSE
18082C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18083 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18084 & ABS(A00U-A20U)**2
18085 ENDIF
18086 FACZZ=FACZZ*WIDS(23,1)
18087
18088 DO 920 I=MMIN1,MMAX1
18089 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
18090 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18091 DO 910 J=MMIN2,MMAX2
18092 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
18093 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18094 IF(EI*EJ.GT.0D0) GOTO 910
18095 NCHN=NCHN+1
18096 ISIG(NCHN,1)=I
18097 ISIG(NCHN,2)=J
18098 ISIG(NCHN,3)=1
18099 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
18100 910 CONTINUE
18101 920 CONTINUE
18102 930 CONTINUE
18103
18104 ELSEIF(ISUB.EQ.77) THEN
18105C...W+/- + W+/- -> W+/- + W+/-
18106 IF(SH.LE.4.01D0*SQMW) GOTO 960
18107
18108 IF(MSTP(46).LE.2) THEN
18109C...Exact scattering ME:s for on-mass-shell gauge bosons
18110 BE2=1D0-4D0*SQMW/SH
18111 BE4=BE2**2
18112 CTH2=CTH**2
18113 CTH3=CTH**3
18114 TH=-0.5D0*SH*BE2*(1D0-CTH)
18115 UH=-0.5D0*SH*BE2*(1D0+CTH)
18116 IF(MAX(TH,UH).GT.-1D0) GOTO 960
18117 SHANG=(1D0+BE2)**2
18118 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18119 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18120 THANG=(BE2-CTH)**2
18121 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
18122 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
18123 UHANG=(BE2+CTH)**2
18124 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
18125 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
18126 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
18127 ASGRE=XW*SGZANG
18128 ASGIM=0D0
18129 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
18130 ASZIM=0D0
18131 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
18132 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
18133 ATGRE=0.5D0*XW*SH/TH*TGZANG
18134 ATGIM=0D0
18135 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
18136 ATZIM=0D0
18137 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
18138 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
18139 AUGRE=0.5D0*XW*SH/UH*UGZANG
18140 AUGIM=0D0
18141 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
18142 AUZIM=0D0
18143 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
18144 A4AIM=0D0
18145 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
18146 A4SIM=0D0
18147 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18148 & (SH/SQMW)**2*SH2
18149 IF(MSTP(46).LE.0) THEN
18150 AWWARE=ASHRE
18151 AWWAIM=ASHIM
18152 AWWSRE=0D0
18153 AWWSIM=0D0
18154 ELSEIF(MSTP(46).EQ.1) THEN
18155 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18156 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18157 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18158 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18159 ELSE
18160 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18161 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18162 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18163 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18164 ENDIF
18165 AWWA2=AWWARE**2+AWWAIM**2
18166 AWWS2=AWWSRE**2+AWWSIM**2
18167
18168 ELSE
18169C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18170 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18171 & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
18172 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
18173 ENDIF
18174
18175 DO 950 I=MMIN1,MMAX1
18176 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
18177 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18178 DO 940 J=MMIN2,MMAX2
18179 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
18180 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18181 IF(EI*EJ.LT.0D0) THEN
18182C...W+W-
18183 IF(MSTP(45).EQ.1) GOTO 940
18184 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
18185 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
18186 ELSE
18187C...W+W+/W-W-
18188 IF(MSTP(45).EQ.2) GOTO 940
18189 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
18190 IF(MSTP(46).GE.3) FACWW=FWWS
18191 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
18192 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
18193 ENDIF
18194 NCHN=NCHN+1
18195 ISIG(NCHN,1)=I
18196 ISIG(NCHN,2)=J
18197 ISIG(NCHN,3)=1
18198 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
18199 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
18200 940 CONTINUE
18201 950 CONTINUE
18202 960 CONTINUE
18203
18204 ELSEIF(ISUB.EQ.78) THEN
18205C...W+/- + h0 -> W+/- + h0
18206
18207 ELSEIF(ISUB.EQ.79) THEN
18208C...h0 + h0 -> h0 + h0
18209
18210 ELSEIF(ISUB.EQ.80) THEN
18211C...q + gamma -> q' + pi+/-
18212 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
18213 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
18214 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
18215 DELSH=UH*SQRT(ASSH*Q2FPSH)
18216 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
18217 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
18218 DELUH=SH*SQRT(ASUH*Q2FPUH)
18219 DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
18220 IF(I.EQ.0) GOTO 980
18221 EI=KCHG(IABS(I),1)/3D0
18222 EJ=SIGN(1D0-ABS(EI),EI)
18223 DO 970 ISDE=1,2
18224 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
18225 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
18226 NCHN=NCHN+1
18227 ISIG(NCHN,ISDE)=I
18228 ISIG(NCHN,3-ISDE)=22
18229 ISIG(NCHN,3)=1
18230 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
18231 970 CONTINUE
18232 980 CONTINUE
18233
18234 ENDIF
18235
18236C...C: 2 -> 2, tree diagrams with masses
18237
18238 ELSEIF(ISUB.LE.90) THEN
18239 IF(ISUB.EQ.81) THEN
18240C...q + qbar -> Q + Qbar
18241 FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQM3)**2+
18242 & (UH-SQM3)**2)/SH2+2D0*SQM3/SH)
18243 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQM3,0D0)
18244 WID2=1D0
18245 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18246 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18247 FACQQB=FACQQB*WID2
18248 DO 990 I=MMINA,MMAXA
18249 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18250 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
18251 NCHN=NCHN+1
18252 ISIG(NCHN,1)=I
18253 ISIG(NCHN,2)=-I
18254 ISIG(NCHN,3)=1
18255 SIGH(NCHN)=FACQQB
18256 990 CONTINUE
18257
18258 ELSEIF(ISUB.EQ.82) THEN
18259C...g + g -> Q + Qbar
18260 IF(MSTP(34).EQ.0) THEN
18261 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18262 & 2D0*(UH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18263 & (TH-SQM3)**2)
18264 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18265 & 2D0*(TH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18266 & (UH-SQM3)**2)
18267 ELSE
18268 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18269 & 2.25D0*(UH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18270 & (TH-SQM3)**2+0.5D0*SQM3*TH/(TH-SQM3)**2-SQM3**2/
18271 & (SH*(TH-SQM3)))
18272 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18273 & 2.25D0*(TH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18274 & (UH-SQM3)**2+0.5D0*SQM3*UH/(UH-SQM3)**2-SQM3**2/
18275 & (SH*(UH-SQM3)))
18276 ENDIF
18277 IF(MSTP(35).GE.1) THEN
18278 FATRE=PYHFTH(SH,SQM3,2D0/7D0)
18279 FACQQ1=FACQQ1*FATRE
18280 FACQQ2=FACQQ2*FATRE
18281 ENDIF
18282 WID2=1D0
18283 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18284 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18285 FACQQ1=FACQQ1*WID2
18286 FACQQ2=FACQQ2*WID2
18287 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
18288 NCHN=NCHN+1
18289 ISIG(NCHN,1)=21
18290 ISIG(NCHN,2)=21
18291 ISIG(NCHN,3)=1
18292 SIGH(NCHN)=FACQQ1
18293 NCHN=NCHN+1
18294 ISIG(NCHN,1)=21
18295 ISIG(NCHN,2)=21
18296 ISIG(NCHN,3)=2
18297 SIGH(NCHN)=FACQQ2
18298 1000 CONTINUE
18299
18300 ELSEIF(ISUB.EQ.83) THEN
18301C...f + q -> f' + Q
18302 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
18303 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
18304 DO 1020 I=MMIN1,MMAX1
18305 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
18306 DO 1010 J=MMIN2,MMAX2
18307 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
18308 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
18309 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
18310 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
18311 & THEN
18312 NCHN=NCHN+1
18313 ISIG(NCHN,1)=I
18314 ISIG(NCHN,2)=J
18315 ISIG(NCHN,3)=1
18316 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18317 & (IABS(I)+1)/2)*VINT(180+J)
18318 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
18319 & (MINT(55)+1)/2)*VINT(180+J)
18320 WID2=1D0
18321 IF(I.GT.0) THEN
18322 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18323 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18324 & WIDS(MINT(55),2)
18325 ELSE
18326 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18327 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18328 & WIDS(MINT(55),3)
18329 ENDIF
18330 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18331 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18332 ENDIF
18333 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
18334 & THEN
18335 NCHN=NCHN+1
18336 ISIG(NCHN,1)=I
18337 ISIG(NCHN,2)=J
18338 ISIG(NCHN,3)=2
18339 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18340 & (IABS(J)+1)/2)*VINT(180+I)
18341 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
18342 & (MINT(55)+1)/2)*VINT(180+I)
18343 IF(J.GT.0) THEN
18344 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18345 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18346 & WIDS(MINT(55),2)
18347 ELSE
18348 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18349 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18350 & WIDS(MINT(55),3)
18351 ENDIF
18352 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18353 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18354 ENDIF
18355 1010 CONTINUE
18356 1020 CONTINUE
18357
18358 ELSEIF(ISUB.EQ.84) THEN
18359C...g + gamma -> Q + Qbar
18360 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18361 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
18362 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18363 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQM3,0D0)
18364 WID2=1D0
18365 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18366 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18367 FACQQ=FACQQ*WID2
18368 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18369 NCHN=NCHN+1
18370 ISIG(NCHN,1)=21
18371 ISIG(NCHN,2)=22
18372 ISIG(NCHN,3)=1
18373 SIGH(NCHN)=FACQQ
18374 ENDIF
18375 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18376 NCHN=NCHN+1
18377 ISIG(NCHN,1)=22
18378 ISIG(NCHN,2)=21
18379 ISIG(NCHN,3)=1
18380 SIGH(NCHN)=FACQQ
18381 ENDIF
18382
18383 ELSEIF(ISUB.EQ.85) THEN
18384C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
18385 FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18386 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
18387 & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18388 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
18389 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
18390 & FACFF=FACFF*PYHFTH(SH,SQM3,1D0)
18391 WID2=1D0
18392 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
18393 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
18394 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
18395 FACFF=FACFF*WID2
18396 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18397 NCHN=NCHN+1
18398 ISIG(NCHN,1)=22
18399 ISIG(NCHN,2)=22
18400 ISIG(NCHN,3)=1
18401 SIGH(NCHN)=FACFF
18402 ENDIF
18403
18404 ELSEIF(ISUB.EQ.86) THEN
18405C...g + g -> J/Psi + g
18406 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
18407 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18408 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18409 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18410 NCHN=NCHN+1
18411 ISIG(NCHN,1)=21
18412 ISIG(NCHN,2)=21
18413 ISIG(NCHN,3)=1
18414 SIGH(NCHN)=FACQQG
18415 ENDIF
18416
18417 ELSEIF(ISUB.EQ.87) THEN
18418C...g + g -> chi_0c + g
18419 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18420 QGTW=(SH*TH*UH)/SH**3
18421 RGTW=SQM3/SH
18422 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18423 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18424 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
18425 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
18426 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
18427 & (QGTW*(QGTW-RGTW*PGTW)**4)
18428 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18429 NCHN=NCHN+1
18430 ISIG(NCHN,1)=21
18431 ISIG(NCHN,2)=21
18432 ISIG(NCHN,3)=1
18433 SIGH(NCHN)=FACQQG
18434 ENDIF
18435
18436 ELSEIF(ISUB.EQ.88) THEN
18437C...g + g -> chi_1c + g
18438 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18439 QGTW=(SH*TH*UH)/SH**3
18440 RGTW=SQM3/SH
18441 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18442 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
18443 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
18444 & (QGTW-RGTW*PGTW)**4
18445 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18446 NCHN=NCHN+1
18447 ISIG(NCHN,1)=21
18448 ISIG(NCHN,2)=21
18449 ISIG(NCHN,3)=1
18450 SIGH(NCHN)=FACQQG
18451 ENDIF
18452
18453 ELSEIF(ISUB.EQ.89) THEN
18454C...g + g -> chi_2c + g
18455 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18456 QGTW=(SH*TH*UH)/SH**3
18457 RGTW=SQM3/SH
18458 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18459 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18460 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
18461 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
18462 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
18463 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
18464 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18465 NCHN=NCHN+1
18466 ISIG(NCHN,1)=21
18467 ISIG(NCHN,2)=21
18468 ISIG(NCHN,3)=1
18469 SIGH(NCHN)=FACQQG
18470 ENDIF
18471 ENDIF
18472
18473C...D: Mimimum bias processes
18474
18475 ELSEIF(ISUB.LE.100) THEN
18476 IF(ISUB.EQ.91) THEN
18477C...Elastic scattering
18478 SIGS=SIGT(0,0,1)
18479
18480 ELSEIF(ISUB.EQ.92) THEN
18481C...Single diffractive scattering (first side, i.e. XB)
18482 SIGS=SIGT(0,0,2)
18483
18484 ELSEIF(ISUB.EQ.93) THEN
18485C...Single diffractive scattering (second side, i.e. AX)
18486 SIGS=SIGT(0,0,3)
18487
18488 ELSEIF(ISUB.EQ.94) THEN
18489C...Double diffractive scattering
18490 SIGS=SIGT(0,0,4)
18491
18492 ELSEIF(ISUB.EQ.95) THEN
18493C...Low-pT scattering
18494 SIGS=SIGT(0,0,5)
18495
18496 ELSEIF(ISUB.EQ.96) THEN
18497C...Multiple interactions: sum of QCD processes
18498 CALL PYWIDT(21,SH,WDTP,WDTE)
18499
18500C...q + q' -> q + q'
18501 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
18502 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
18503 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
18504 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
18505 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
18506 DO 1040 I=-3,3
18507 IF(I.EQ.0) GOTO 1040
18508 DO 1030 J=-3,3
18509 IF(J.EQ.0) GOTO 1030
18510 NCHN=NCHN+1
18511 ISIG(NCHN,1)=I
18512 ISIG(NCHN,2)=J
18513 ISIG(NCHN,3)=111
18514 SIGH(NCHN)=FACQQ1
18515 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
18516 IF(I.EQ.J) THEN
18517 SIGH(NCHN)=0.5D0*SIGH(NCHN)
18518 NCHN=NCHN+1
18519 ISIG(NCHN,1)=I
18520 ISIG(NCHN,2)=J
18521 ISIG(NCHN,3)=112
18522 SIGH(NCHN)=0.5D0*FACQQ2
18523 ENDIF
18524 1030 CONTINUE
18525 1040 CONTINUE
18526
18527C...q + qbar -> q' + qbar' or g + g
18528 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
18529 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
18530 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18531 & UH2/SH2)
18532 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18533 & TH2/SH2)
18534 DO 1050 I=-3,3
18535 IF(I.EQ.0) GOTO 1050
18536 NCHN=NCHN+1
18537 ISIG(NCHN,1)=I
18538 ISIG(NCHN,2)=-I
18539 ISIG(NCHN,3)=121
18540 SIGH(NCHN)=FACQQB
18541 NCHN=NCHN+1
18542 ISIG(NCHN,1)=I
18543 ISIG(NCHN,2)=-I
18544 ISIG(NCHN,3)=131
18545 SIGH(NCHN)=0.5D0*FACGG1
18546 NCHN=NCHN+1
18547 ISIG(NCHN,1)=I
18548 ISIG(NCHN,2)=-I
18549 ISIG(NCHN,3)=132
18550 SIGH(NCHN)=0.5D0*FACGG2
18551 1050 CONTINUE
18552
18553C...q + g -> q + g
18554 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
18555 & UH/SH)*FACA
18556 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
18557 & SH/UH)
18558 DO 1070 I=-3,3
18559 IF(I.EQ.0) GOTO 1070
18560 DO 1060 ISDE=1,2
18561 NCHN=NCHN+1
18562 ISIG(NCHN,ISDE)=I
18563 ISIG(NCHN,3-ISDE)=21
18564 ISIG(NCHN,3)=281
18565 SIGH(NCHN)=FACQG1
18566 NCHN=NCHN+1
18567 ISIG(NCHN,ISDE)=I
18568 ISIG(NCHN,3-ISDE)=21
18569 ISIG(NCHN,3)=282
18570 SIGH(NCHN)=FACQG2
18571 1060 CONTINUE
18572 1070 CONTINUE
18573
18574C...g + g -> q + qbar or g + g
18575 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18576 & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18577 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18578 & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18579 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
18580 & 2D0*TH/SH+TH2/SH2)*FACA
18581 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
18582 & 2D0*SH/UH+SH2/UH2)*FACA
18583 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
18584 & 2D0*UH/TH+UH2/TH2)
18585 NCHN=NCHN+1
18586 ISIG(NCHN,1)=21
18587 ISIG(NCHN,2)=21
18588 ISIG(NCHN,3)=531
18589 SIGH(NCHN)=FACQQ1
18590 NCHN=NCHN+1
18591 ISIG(NCHN,1)=21
18592 ISIG(NCHN,2)=21
18593 ISIG(NCHN,3)=532
18594 SIGH(NCHN)=FACQQ2
18595 NCHN=NCHN+1
18596 ISIG(NCHN,1)=21
18597 ISIG(NCHN,2)=21
18598 ISIG(NCHN,3)=681
18599 SIGH(NCHN)=0.5D0*FACGG1
18600 NCHN=NCHN+1
18601 ISIG(NCHN,1)=21
18602 ISIG(NCHN,2)=21
18603 ISIG(NCHN,3)=682
18604 SIGH(NCHN)=0.5D0*FACGG2
18605 NCHN=NCHN+1
18606 ISIG(NCHN,1)=21
18607 ISIG(NCHN,2)=21
18608 ISIG(NCHN,3)=683
18609 SIGH(NCHN)=0.5D0*FACGG3
18610 ENDIF
18611
18612C...E: 2 -> 1, loop diagrams
18613
18614 ELSEIF(ISUB.LE.110) THEN
18615 IF(ISUB.EQ.101) THEN
18616C...g + g -> gamma*/Z0
18617
18618 ELSEIF(ISUB.EQ.102) THEN
18619C...g + g -> h0 (or H0, or A0)
18620 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18621 HS=SHR*WDTP(0)
18622 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18623 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18624 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18625 & FACBW=0D0
18626 HI=SHR*WDTP(13)/32D0
18627 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
18628 NCHN=NCHN+1
18629 ISIG(NCHN,1)=21
18630 ISIG(NCHN,2)=21
18631 ISIG(NCHN,3)=1
18632 SIGH(NCHN)=HI*FACBW*HF
18633 1080 CONTINUE
18634
18635 ELSEIF(ISUB.EQ.103) THEN
18636C...gamma + gamma -> h0 (or H0, or A0)
18637 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18638 HS=SHR*WDTP(0)
18639 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18640 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18641 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18642 & FACBW=0D0
18643 HI=SHR*WDTP(14)*2D0
18644 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
18645 NCHN=NCHN+1
18646 ISIG(NCHN,1)=22
18647 ISIG(NCHN,2)=22
18648 ISIG(NCHN,3)=1
18649 SIGH(NCHN)=HI*FACBW*HF
18650 1090 CONTINUE
18651
18652C...Continuation C: 2 -> 2, tree diagrams with masses.
18653
18654 ELSEIF(ISUB.EQ.106) THEN
18655C...g + g -> J/Psi + gamma.
18656 EQ=2D0/3D0
18657 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
18658 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18659 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18660 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18661 NCHN=NCHN+1
18662 ISIG(NCHN,1)=21
18663 ISIG(NCHN,2)=21
18664 ISIG(NCHN,3)=1
18665 SIGH(NCHN)=FACQQG
18666 ENDIF
18667
18668 ELSEIF(ISUB.EQ.107) THEN
18669C...g + gamma -> J/Psi + g.
18670 EQ=2D0/3D0
18671 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
18672 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18673 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18674 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18675 NCHN=NCHN+1
18676 ISIG(NCHN,1)=21
18677 ISIG(NCHN,2)=22
18678 ISIG(NCHN,3)=1
18679 SIGH(NCHN)=FACQQG
18680 ENDIF
18681 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18682 NCHN=NCHN+1
18683 ISIG(NCHN,1)=22
18684 ISIG(NCHN,2)=21
18685 ISIG(NCHN,3)=1
18686 SIGH(NCHN)=FACQQG
18687 ENDIF
18688
18689 ELSEIF(ISUB.EQ.108) THEN
18690C...gamma + gamma -> J/Psi + gamma.
18691 EQ=2D0/3D0
18692 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
18693 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18694 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18695 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18696 NCHN=NCHN+1
18697 ISIG(NCHN,1)=22
18698 ISIG(NCHN,2)=22
18699 ISIG(NCHN,3)=1
18700 SIGH(NCHN)=FACQQG
18701 ENDIF
18702
18703C...F: 2 -> 2, box diagrams
18704
18705 ELSEIF(ISUB.EQ.110) THEN
18706C...f + fbar -> gamma + h0
18707 THUH=MAX(TH*UH,SH*CKIN(3)**2)
18708 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
18709 FACHG=FACHG*WIDS(KFHIGG,2)
18710C...Calculate loop contributions for intermediate gamma* and Z0
18711 CIGTOT=CMPLX(0.,0.)
18712 CIZTOT=CMPLX(0.,0.)
18713 JMAX=3*MSTP(1)+1
18714 DO 1100 J=1,JMAX
18715 IF(J.LE.2*MSTP(1)) THEN
18716 FNC=1D0
18717 EJ=KCHG(J,1)/3D0
18718 AJ=SIGN(1D0,EJ+0.1D0)
18719 VJ=AJ-4D0*EJ*XWV
18720 BALP=SQM4/(2D0*PMAS(J,1))**2
18721 BBET=SH/(2D0*PMAS(J,1))**2
18722 ELSEIF(J.LE.3*MSTP(1)) THEN
18723 FNC=3D0
18724 JL=2*(J-2*MSTP(1))-1
18725 EJ=KCHG(10+JL,1)/3D0
18726 AJ=SIGN(1D0,EJ+0.1D0)
18727 VJ=AJ-4D0*EJ*XWV
18728 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
18729 BBET=SH/(2D0*PMAS(10+JL,1))**2
18730 ELSE
18731 BALP=SQM4/(2D0*PMAS(24,1))**2
18732 BBET=SH/(2D0*PMAS(24,1))**2
18733 ENDIF
18734 BABI=1D0/(BALP-BBET)
18735 IF(BALP.LT.1D0) THEN
18736 F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
18737 F1ALP=F0ALP**2
18738 ELSE
18739 F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
18740 & -SNGL(0.5D0*PARU(1)))
18741 F1ALP=-F0ALP**2
18742 ENDIF
18743 F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
18744 IF(BBET.LT.1D0) THEN
18745 F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
18746 F1BET=F0BET**2
18747 ELSE
18748 F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
18749 & -SNGL(0.5D0*PARU(1)))
18750 F1BET=-F0BET**2
18751 ENDIF
18752 F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
18753 IF(J.LE.3*MSTP(1)) THEN
18754 FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
18755 & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
18756 CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
18757 CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
18758 ELSE
18759 TXW=XW/XW1
18760 CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
18761 & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
18762 & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
18763 CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
18764 & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
18765 & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
18766 & (F1BET-F1ALP))
18767 ENDIF
18768 1100 CONTINUE
18769 CIGTOT=CIGTOT/SNGL(SH)
18770 CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
18771C...Loop over initial flavours
18772 DO 1110 I=MMINA,MMAXA
18773 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
18774 EI=KCHG(IABS(I),1)/3D0
18775 AI=SIGN(1D0,EI)
18776 VI=AI-4D0*EI*XWV
18777 FCOI=1D0
18778 IF(IABS(I).LE.10) FCOI=FACA/3D0
18779 NCHN=NCHN+1
18780 ISIG(NCHN,1)=I
18781 ISIG(NCHN,2)=-I
18782 ISIG(NCHN,3)=1
18783 SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
18784 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
18785 1110 CONTINUE
18786
18787 ENDIF
18788
18789 ELSEIF(ISUB.LE.120) THEN
18790 IF(ISUB.EQ.111) THEN
18791C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
18792 A5STUR=0D0
18793 A5STUI=0D0
18794 DO 1120 I=1,2*MSTP(1)
18795 SQMQ=PMAS(I,1)**2
18796 EPSS=4D0*SQMQ/SH
18797 EPSH=4D0*SQMQ/SQMH
18798 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18799 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18800 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18801 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18802 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
18803 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
18804 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
18805 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
18806 1120 CONTINUE
18807 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18808 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
18809 FACGH=FACGH*WIDS(25,2)
18810 DO 1130 I=MMINA,MMAXA
18811 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18812 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
18813 NCHN=NCHN+1
18814 ISIG(NCHN,1)=I
18815 ISIG(NCHN,2)=-I
18816 ISIG(NCHN,3)=1
18817 SIGH(NCHN)=FACGH
18818 1130 CONTINUE
18819
18820 ELSEIF(ISUB.EQ.112) THEN
18821C...f + g -> f + h0 (q + g -> q + h0 only)
18822 A5TSUR=0D0
18823 A5TSUI=0D0
18824 DO 1140 I=1,2*MSTP(1)
18825 SQMQ=PMAS(I,1)**2
18826 EPST=4D0*SQMQ/TH
18827 EPSH=4D0*SQMQ/SQMH
18828 CALL PYWAUX(1,EPST,W1TR,W1TI)
18829 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18830 CALL PYWAUX(2,EPST,W2TR,W2TI)
18831 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18832 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
18833 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
18834 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
18835 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
18836 1140 CONTINUE
18837 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18838 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
18839 FACQH=FACQH*WIDS(25,2)
18840 DO 1160 I=MMINA,MMAXA
18841 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
18842 DO 1150 ISDE=1,2
18843 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
18844 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
18845 NCHN=NCHN+1
18846 ISIG(NCHN,ISDE)=I
18847 ISIG(NCHN,3-ISDE)=21
18848 ISIG(NCHN,3)=1
18849 SIGH(NCHN)=FACQH
18850 1150 CONTINUE
18851 1160 CONTINUE
18852
18853 ELSEIF(ISUB.EQ.113) THEN
18854C...g + g -> g + h0
18855 A2STUR=0D0
18856 A2STUI=0D0
18857 A2USTR=0D0
18858 A2USTI=0D0
18859 A2TUSR=0D0
18860 A2TUSI=0D0
18861 A4STUR=0D0
18862 A4STUI=0D0
18863 DO 1170 I=1,2*MSTP(1)
18864 SQMQ=PMAS(I,1)**2
18865 EPSS=4D0*SQMQ/SH
18866 EPST=4D0*SQMQ/TH
18867 EPSU=4D0*SQMQ/UH
18868 EPSH=4D0*SQMQ/SQMH
18869 IF(EPSH.LT.1.D-6) GOTO 1170
18870 CALL PYWAUX(1,EPSS,W1SR,W1SI)
18871 CALL PYWAUX(1,EPST,W1TR,W1TI)
18872 CALL PYWAUX(1,EPSU,W1UR,W1UI)
18873 CALL PYWAUX(1,EPSH,W1HR,W1HI)
18874 CALL PYWAUX(2,EPSS,W2SR,W2SI)
18875 CALL PYWAUX(2,EPST,W2TR,W2TI)
18876 CALL PYWAUX(2,EPSU,W2UR,W2UI)
18877 CALL PYWAUX(2,EPSH,W2HR,W2HI)
18878 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
18879 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
18880 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
18881 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
18882 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
18883 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
18884 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
18885 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
18886 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
18887 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
18888 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
18889 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
18890 W3STUR=YHSTUR-Y3STUR-Y3UTSR
18891 W3STUI=YHSTUI-Y3STUI-Y3UTSI
18892 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
18893 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
18894 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
18895 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
18896 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
18897 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
18898 W3USTR=YHUSTR-Y3USTR-Y3TSUR
18899 W3USTI=YHUSTI-Y3USTI-Y3TSUI
18900 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
18901 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
18902 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
18903 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
18904 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
18905 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
18906 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
18907 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
18908 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
18909 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
18910 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
18911 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
18912 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
18913 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
18914 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
18915 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
18916 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
18917 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
18918 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
18919 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
18920 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
18921 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
18922 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
18923 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
18924 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
18925 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
18926 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
18927 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
18928 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
18929 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
18930 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
18931 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
18932 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
18933 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
18934 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
18935 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
18936 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
18937 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
18938 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
18939 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
18940 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
18941 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
18942 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
18943 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
18944 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
18945 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
18946 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
18947 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
18948 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
18949 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
18950 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
18951 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
18952 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
18953 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
18954 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
18955 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
18956 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
18957 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
18958 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
18959 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
18960 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
18961 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
18962 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18963 & (W2SR-W2HR+W3STUR))
18964 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
18965 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18966 & (W2TR-W2HR+W3TUSR))
18967 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
18968 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18969 & (W2UR-W2HR+W3USTR))
18970 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
18971 A2STUR=A2STUR+B2STUR+B2SUTR
18972 A2STUI=A2STUI+B2STUI+B2SUTI
18973 A2USTR=A2USTR+B2USTR+B2UTSR
18974 A2USTI=A2USTI+B2USTI+B2UTSI
18975 A2TUSR=A2TUSR+B2TUSR+B2TSUR
18976 A2TUSI=A2TUSI+B2TUSI+B2TSUI
18977 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
18978 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
18979 1170 CONTINUE
18980 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
18981 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
18982 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
18983 FACGH=FACGH*WIDS(25,2)
18984 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
18985 NCHN=NCHN+1
18986 ISIG(NCHN,1)=21
18987 ISIG(NCHN,2)=21
18988 ISIG(NCHN,3)=1
18989 SIGH(NCHN)=FACGH
18990 1180 CONTINUE
18991
18992 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
18993C...g + g -> gamma + gamma or g + g -> g + gamma
18994 A0STUR=0D0
18995 A0STUI=0D0
18996 A0TSUR=0D0
18997 A0TSUI=0D0
18998 A0UTSR=0D0
18999 A0UTSI=0D0
19000 A1STUR=0D0
19001 A1STUI=0D0
19002 A2STUR=0D0
19003 A2STUI=0D0
19004 ALST=LOG(-SH/TH)
19005 ALSU=LOG(-SH/UH)
19006 ALTU=LOG(TH/UH)
19007 IMAX=2*MSTP(1)
19008 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
19009 DO 1190 I=1,IMAX
19010 EI=KCHG(IABS(I),1)/3D0
19011 EIWT=EI**2
19012 IF(ISUB.EQ.115) EIWT=EI
19013 SQMQ=PMAS(I,1)**2
19014 EPSS=4D0*SQMQ/SH
19015 EPST=4D0*SQMQ/TH
19016 EPSU=4D0*SQMQ/UH
19017 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1.D-4) THEN
19018 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
19019 & PARU(1)**2)
19020 B0STUI=0D0
19021 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
19022 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
19023 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
19024 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
19025 B1STUR=-1D0
19026 B1STUI=0D0
19027 B2STUR=-1D0
19028 B2STUI=0D0
19029 ELSE
19030 CALL PYWAUX(1,EPSS,W1SR,W1SI)
19031 CALL PYWAUX(1,EPST,W1TR,W1TI)
19032 CALL PYWAUX(1,EPSU,W1UR,W1UI)
19033 CALL PYWAUX(2,EPSS,W2SR,W2SI)
19034 CALL PYWAUX(2,EPST,W2TR,W2TI)
19035 CALL PYWAUX(2,EPSU,W2UR,W2UI)
19036 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
19037 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
19038 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
19039 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
19040 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
19041 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
19042 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
19043 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
19044 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
19045 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
19046 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
19047 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19048 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
19049 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
19050 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
19051 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
19052 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
19053 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19054 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
19055 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
19056 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
19057 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
19058 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19059 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
19060 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
19061 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
19062 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
19063 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
19064 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19065 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
19066 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
19067 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
19068 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
19069 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
19070 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19071 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
19072 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
19073 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
19074 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
19075 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
19076 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19077 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
19078 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
19079 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
19080 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
19081 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19082 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
19083 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
19084 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
19085 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19086 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
19087 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
19088 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
19089 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
19090 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
19091 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
19092 ENDIF
19093 A0STUR=A0STUR+EIWT*B0STUR
19094 A0STUI=A0STUI+EIWT*B0STUI
19095 A0TSUR=A0TSUR+EIWT*B0TSUR
19096 A0TSUI=A0TSUI+EIWT*B0TSUI
19097 A0UTSR=A0UTSR+EIWT*B0UTSR
19098 A0UTSI=A0UTSI+EIWT*B0UTSI
19099 A1STUR=A1STUR+EIWT*B1STUR
19100 A1STUI=A1STUI+EIWT*B1STUI
19101 A2STUR=A2STUR+EIWT*B2STUR
19102 A2STUI=A2STUI+EIWT*B2STUI
19103 1190 CONTINUE
19104 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
19105 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
19106 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
19107 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
19108 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
19109 NCHN=NCHN+1
19110 ISIG(NCHN,1)=21
19111 ISIG(NCHN,2)=21
19112 ISIG(NCHN,3)=1
19113 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
19114 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
19115 1200 CONTINUE
19116
19117 ELSEIF(ISUB.EQ.116) THEN
19118C...g + g -> gamma + Z0
19119
19120 ELSEIF(ISUB.EQ.117) THEN
19121C...g + g -> Z0 + Z0
19122
19123 ELSEIF(ISUB.EQ.118) THEN
19124C...g + g -> W+ + W-
19125
19126 ENDIF
19127
19128C...G: 2 -> 3, tree diagrams
19129
19130 ELSEIF(ISUB.LE.140) THEN
19131 IF(ISUB.EQ.121) THEN
19132C...g + g -> Q + Qbar + h0
19133 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
19134 IA=KFPR(ISUBSV,2)
19135 PMF=PMAS(IA,1)
19136 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19137 & (0.5D0*PMF/PMAS(24,1))**2
19138 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19139 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19140 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19141 WID2=1D0
19142 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19143 FACQQH=FACQQH*WID2
19144 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19145 IKFI=1
19146 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19147 IF(IA.GT.10) IKFI=3
19148 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19149 ENDIF
19150 CALL PYQQBH(WTQQBH)
19151 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19152 HS=SHR*WDTP(0)
19153 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19154 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19155 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19156 & FACBW=0D0
19157 NCHN=NCHN+1
19158 ISIG(NCHN,1)=21
19159 ISIG(NCHN,2)=21
19160 ISIG(NCHN,3)=1
19161 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19162 1210 CONTINUE
19163
19164 ELSEIF(ISUB.EQ.122) THEN
19165C...q + qbar -> Q + Qbar + h0
19166 IA=KFPR(ISUBSV,2)
19167 PMF=PMAS(IA,1)
19168 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19169 & (0.5D0*PMF/PMAS(24,1))**2
19170 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19171 & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19172 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19173 WID2=1D0
19174 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19175 FACQQH=FACQQH*WID2
19176 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19177 IKFI=1
19178 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19179 IF(IA.GT.10) IKFI=3
19180 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19181 ENDIF
19182 CALL PYQQBH(WTQQBH)
19183 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19184 HS=SHR*WDTP(0)
19185 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19186 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19187 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19188 & FACBW=0D0
19189 DO 1220 I=MMINA,MMAXA
19190 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19191 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
19192 NCHN=NCHN+1
19193 ISIG(NCHN,1)=I
19194 ISIG(NCHN,2)=-I
19195 ISIG(NCHN,3)=1
19196 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19197 1220 CONTINUE
19198
19199 ELSEIF(ISUB.EQ.123) THEN
19200C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
19201C...inner process)
19202 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
19203 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19204 & PARU(154+10*IHIGG)**2
19205 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19206 & (VINT(216)-VINT(209)**2))**2
19207 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19208 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
19209 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19210 HS=SHR*WDTP(0)
19211 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19212 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19213 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19214 & FACBW=0D0
19215 DO 1240 I=MMIN1,MMAX1
19216 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
19217 IA=IABS(I)
19218 DO 1230 J=MMIN2,MMAX2
19219 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
19220 JA=IABS(J)
19221 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
19222 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
19223 VI=AI-4D0*EI*XWV
19224 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
19225 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
19226 VJ=AJ-4D0*EJ*XWV
19227 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
19228 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
19229 NCHN=NCHN+1
19230 ISIG(NCHN,1)=I
19231 ISIG(NCHN,2)=J
19232 ISIG(NCHN,3)=1
19233 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
19234 1230 CONTINUE
19235 1240 CONTINUE
19236
19237 ELSEIF(ISUB.EQ.124) THEN
19238C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
19239C...inner process)
19240 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
19241 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19242 & PARU(155+10*IHIGG)**2
19243 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19244 & (VINT(216)-VINT(209)**2))**2
19245 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19246 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19247 HS=SHR*WDTP(0)
19248 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19249 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19250 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19251 & FACBW=0D0
19252 DO 1260 I=MMIN1,MMAX1
19253 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
19254 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
19255 DO 1250 J=MMIN2,MMAX2
19256 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
19257 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
19258 IF(EI*EJ.GT.0D0) GOTO 1250
19259 FACLR=VINT(180+I)*VINT(180+J)
19260 NCHN=NCHN+1
19261 ISIG(NCHN,1)=I
19262 ISIG(NCHN,2)=J
19263 ISIG(NCHN,3)=1
19264 SIGH(NCHN)=FACLR*FACWW*FACBW
19265 1250 CONTINUE
19266 1260 CONTINUE
19267
19268 ELSEIF(ISUB.EQ.131) THEN
19269C...g + g -> Z0 + q + qbar
19270
19271 ENDIF
19272
19273C...H: 2 -> 1, tree diagrams, non-standard model processes
19274
19275 ELSEIF(ISUB.LE.160) THEN
19276 IF(ISUB.EQ.141) THEN
19277C...f + fbar -> gamma*/Z0/Z'0
19278 SQMZP=PMAS(32,1)**2
19279 MINT(61)=2
19280 CALL PYWIDT(32,SH,WDTP,WDTE)
19281 HP0=AEM/3D0*SH
19282 HP1=AEM/3D0*XWC*SH
19283 HP2=HP1
19284 HS=SHR*VINT(117)
19285 HSP=SHR*WDTP(0)
19286 FACZP=4D0*COMFAC*3D0
19287 DO 1270 I=MMINA,MMAXA
19288 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1270
19289 EI=KCHG(IABS(I),1)/3D0
19290 AI=SIGN(1D0,EI)
19291 VI=AI-4D0*EI*XWV
19292 IF(IABS(I).LT.10) THEN
19293 VPI=PARU(123-2*MOD(IABS(I),2))
19294 API=PARU(124-2*MOD(IABS(I),2))
19295 ELSE
19296 VPI=PARU(127-2*MOD(IABS(I),2))
19297 API=PARU(128-2*MOD(IABS(I),2))
19298 ENDIF
19299 HI0=HP0
19300 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
19301 HI1=HP1
19302 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
19303 HI2=HP2
19304 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
19305 NCHN=NCHN+1
19306 ISIG(NCHN,1)=I
19307 ISIG(NCHN,2)=-I
19308 ISIG(NCHN,3)=1
19309 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
19310 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
19311 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
19312 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
19313 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
19314 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
19315 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
19316 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
19317 1270 CONTINUE
19318
19319 ELSEIF(ISUB.EQ.142) THEN
19320C...f + fbar' -> W'+/-
19321 SQMWP=PMAS(34,1)**2
19322 CALL PYWIDT(34,SH,WDTP,WDTE)
19323 HS=SHR*WDTP(0)
19324 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
19325 HP=AEM/(24D0*XW)*SH
19326 DO 1290 I=MMIN1,MMAX1
19327 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1290
19328 IA=IABS(I)
19329 DO 1280 J=MMIN2,MMAX2
19330 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1280
19331 JA=IABS(J)
19332 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1280
19333 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19334 & GOTO 1280
19335 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19336 HI=HP*(PARU(133)**2+PARU(134)**2)
19337 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
19338 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19339 NCHN=NCHN+1
19340 ISIG(NCHN,1)=I
19341 ISIG(NCHN,2)=J
19342 ISIG(NCHN,3)=1
19343 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
19344 SIGH(NCHN)=HI*FACBW*HF
19345 1280 CONTINUE
19346 1290 CONTINUE
19347
19348 ELSEIF(ISUB.EQ.143) THEN
19349C...f + fbar' -> H+/-
19350 SQMHC=PMAS(37,1)**2
19351 CALL PYWIDT(37,SH,WDTP,WDTE)
19352 HS=SHR*WDTP(0)
19353 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
19354 HP=AEM/(8D0*XW)*SH/SQMW*SH
19355 DO 1310 I=MMIN1,MMAX1
19356 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1310
19357 IA=IABS(I)
19358 IM=(MOD(IA,10)+1)/2
19359 DO 1300 J=MMIN2,MMAX2
19360 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1300
19361 JA=IABS(J)
19362 JM=(MOD(JA,10)+1)/2
19363 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1300
19364 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19365 & GOTO 1300
19366 IF(MOD(IA,2).EQ.0) THEN
19367 IU=IA
19368 IL=JA
19369 ELSE
19370 IU=JA
19371 IL=IA
19372 ENDIF
19373 RML=PMAS(IL,1)**2/SH
19374 RMU=PMAS(IU,1)**2/SH
19375 IF(IL.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) RML=
19376 & RML*(LOG(MAX(4D0,PARP(37)**2*RML*SH/PARU(117)**2))/
19377 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-
19378 & 2D0*MSTU(118)))
19379 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
19380 IF(IA.LE.10) HI=HI*FACA/3D0
19381 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19382 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
19383 NCHN=NCHN+1
19384 ISIG(NCHN,1)=I
19385 ISIG(NCHN,2)=J
19386 ISIG(NCHN,3)=1
19387 SIGH(NCHN)=HI*FACBW*HF
19388 1300 CONTINUE
19389 1310 CONTINUE
19390
19391 ELSEIF(ISUB.EQ.144) THEN
19392C...f + fbar' -> R
19393 SQMR=PMAS(40,1)**2
19394 CALL PYWIDT(40,SH,WDTP,WDTE)
19395 HS=SHR*WDTP(0)
19396 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
19397 HP=AEM/(12D0*XW)*SH
19398 DO 1330 I=MMIN1,MMAX1
19399 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1330
19400 IA=IABS(I)
19401 DO 1320 J=MMIN2,MMAX2
19402 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1320
19403 JA=IABS(J)
19404 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1320
19405 HI=HP
19406 IF(IA.LE.10) HI=HI*FACA/3D0
19407 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
19408 NCHN=NCHN+1
19409 ISIG(NCHN,1)=I
19410 ISIG(NCHN,2)=J
19411 ISIG(NCHN,3)=1
19412 SIGH(NCHN)=HI*FACBW*HF
19413 1320 CONTINUE
19414 1330 CONTINUE
19415
19416 ELSEIF(ISUB.EQ.145) THEN
19417C...q + l -> LQ (leptoquark)
19418 SQMLQ=PMAS(39,1)**2
19419 CALL PYWIDT(39,SH,WDTP,WDTE)
19420 HS=SHR*WDTP(0)
19421 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
19422 IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
19423 HP=AEM/4D0*SH
19424 KFLQQ=KFDP(MDCY(39,2),1)
19425 KFLQL=KFDP(MDCY(39,2),2)
19426 DO 1350 I=MMIN1,MMAX1
19427 IF(KFAC(1,I).EQ.0) GOTO 1350
19428 IA=IABS(I)
19429 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1350
19430 DO 1340 J=MMIN2,MMAX2
19431 IF(KFAC(2,J).EQ.0) GOTO 1340
19432 JA=IABS(J)
19433 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1340
19434 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1340
19435 IF(JA.EQ.IA) GOTO 1340
19436 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
19437 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
19438 HI=HP*PARU(151)
19439 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
19440 NCHN=NCHN+1
19441 ISIG(NCHN,1)=I
19442 ISIG(NCHN,2)=J
19443 ISIG(NCHN,3)=1
19444 SIGH(NCHN)=HI*FACBW*HF
19445 1340 CONTINUE
19446 1350 CONTINUE
19447
19448 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
19449C...d + g -> d* and u + g -> u* (excited quarks)
19450 KFQSTR=KFPR(ISUB,1)
19451 KCQSTR=PYCOMP(KFQSTR)
19452 KFQEXC=MOD(KFQSTR,KEXCIT)
19453 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
19454 HS=SHR*WDTP(0)
19455 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
19456 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
19457 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
19458 & FACBW=0D0
19459 HP=SH
19460 DO 1370 I=-KFQEXC,KFQEXC,2*KFQEXC
19461 DO 1360 ISDE=1,2
19462 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
19463 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
19464 HI=HP
19465 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19466 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
19467 NCHN=NCHN+1
19468 ISIG(NCHN,ISDE)=I
19469 ISIG(NCHN,3-ISDE)=21
19470 ISIG(NCHN,3)=1
19471 SIGH(NCHN)=HI*FACBW*HF
19472 1360 CONTINUE
19473 1370 CONTINUE
19474
19475 ELSEIF(ISUB.EQ.149) THEN
19476C...g + g -> eta_techni
19477 CALL PYWIDT(38,SH,WDTP,WDTE)
19478 HS=SHR*WDTP(0)
19479 FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
19480 IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
19481 HP=SH
19482 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1380
19483 HI=HP*WDTP(3)
19484 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19485 NCHN=NCHN+1
19486 ISIG(NCHN,1)=21
19487 ISIG(NCHN,2)=21
19488 ISIG(NCHN,3)=1
19489 SIGH(NCHN)=HI*FACBW*HF
19490 1380 CONTINUE
19491
19492 ENDIF
19493
19494C...I: 2 -> 2, tree diagrams, non-standard model processes
19495
19496 ELSEIF(ISUB.LE.200) THEN
19497 IF(ISUB.EQ.161) THEN
19498C...f + g -> f' + H+/- (b + g -> t + H+/- only)
19499C...(choice of only b and t to avoid kinematics problems)
19500 SQMHC=PMAS(37,1)**2
19501 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
19502 DO 1400 I=MMINA,MMAXA
19503 IA=IABS(I)
19504 IF(IA.NE.5) GOTO 1400
19505 SQML=PMAS(IA,1)**2
19506 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
19507 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
19508 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19509 IUA=IA+MOD(IA,2)
19510 SQMQ=PMAS(IUA,1)**2
19511 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
19512 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
19513 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
19514 & (SQMHC-SQMQ-SH)/SH)
19515 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
19516 DO 1390 ISDE=1,2
19517 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1390
19518 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1390
19519 NCHN=NCHN+1
19520 ISIG(NCHN,ISDE)=I
19521 ISIG(NCHN,3-ISDE)=21
19522 ISIG(NCHN,3)=1
19523 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
19524 1390 CONTINUE
19525 1400 CONTINUE
19526
19527 ELSEIF(ISUB.EQ.162) THEN
19528C...q + g -> LQ + lbar; LQ=leptoquark
19529 SQMLQ=PMAS(39,1)**2
19530 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
19531 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
19532 KFLQQ=KFDP(MDCY(39,2),1)
19533 DO 1420 I=MMINA,MMAXA
19534 IF(IABS(I).NE.KFLQQ) GOTO 1420
19535 KCHLQ=ISIGN(1,I)
19536 DO 1410 ISDE=1,2
19537 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1410
19538 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1410
19539 NCHN=NCHN+1
19540 ISIG(NCHN,ISDE)=I
19541 ISIG(NCHN,3-ISDE)=21
19542 ISIG(NCHN,3)=1
19543 SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
19544 1410 CONTINUE
19545 1420 CONTINUE
19546
19547 ELSEIF(ISUB.EQ.163) THEN
19548C...g + g -> LQ + LQbar; LQ=leptoquark
19549 SQMLQ=PMAS(39,1)**2
19550 FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
19551 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
19552 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
19553 & ((TH-SQMLQ)*(UH-SQMLQ)))
19554 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1430
19555 NCHN=NCHN+1
19556 ISIG(NCHN,1)=21
19557 ISIG(NCHN,2)=21
19558C...Since don't know proper colour flow, randomize between alternatives
19559 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
19560 SIGH(NCHN)=FACLQ
19561 1430 CONTINUE
19562
19563 ELSEIF(ISUB.EQ.164) THEN
19564C...q + qbar -> LQ + LQbar; LQ=leptoquark
19565 SQMLQ=PMAS(39,1)**2
19566 FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
19567 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
19568 FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
19569 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
19570 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
19571 KFLQQ=KFDP(MDCY(39,2),1)
19572 DO 1440 I=MMINA,MMAXA
19573 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19574 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1440
19575 NCHN=NCHN+1
19576 ISIG(NCHN,1)=I
19577 ISIG(NCHN,2)=-I
19578 ISIG(NCHN,3)=1
19579 SIGH(NCHN)=FACLQA
19580 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
19581 1440 CONTINUE
19582
19583 ELSEIF(ISUB.EQ.165) THEN
19584C...q + qbar -> l+ + l- (including contact term for compositeness)
19585 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19586 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19587 KFF=IABS(KFPR(ISUB,1))
19588 EF=KCHG(KFF,1)/3D0
19589 AF=SIGN(1D0,EF+0.1D0)
19590 VF=AF-4D0*EF*XWV
19591 VALF=VF+AF
19592 VARF=VF-AF
19593 FCOF=1D0
19594 IF(KFF.LE.10) FCOF=3D0
19595 WID2=1D0
19596 IF(KFF.EQ.6) WID2=WIDS(6,1)
19597 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
19598 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19599 DO 1450 I=MMINA,MMAXA
19600 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1450
19601 EI=KCHG(IABS(I),1)/3D0
19602 AI=SIGN(1D0,EI+0.1D0)
19603 VI=AI-4D0*EI*XWV
19604 VALI=VI+AI
19605 VARI=VI-AI
19606 FCOI=1D0
19607 IF(IABS(I).LE.10) FCOI=FACA/3D0
19608 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
19609 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
19610 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
19611 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19612 ELSE
19613 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
19614 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19615 ENDIF
19616 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
19617 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
19618 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
19619 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
19620 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
19621 NCHN=NCHN+1
19622 ISIG(NCHN,1)=I
19623 ISIG(NCHN,2)=-I
19624 ISIG(NCHN,3)=1
19625 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
19626 1450 CONTINUE
19627
19628 ELSEIF(ISUB.EQ.166) THEN
19629C...q + q'bar -> l + nu_l (including contact term for compositeness)
19630 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
19631 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
19632 KFF=IABS(KFPR(ISUB,1))
19633 FCOF=1D0
19634 IF(KFF.LE.10) FCOF=3D0
19635 DO 1470 I=MMIN1,MMAX1
19636 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
19637 IA=IABS(I)
19638 DO 1460 J=MMIN2,MMAX2
19639 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
19640 JA=IABS(J)
19641 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1460
19642 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19643 & GOTO 1460
19644 FCOI=1D0
19645 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19646 WID2=1D0
19647 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
19648 & MOD(J,2).EQ.0)) THEN
19649 IF(KFF.EQ.5) WID2=WIDS(6,2)
19650 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
19651 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
19652 ELSE
19653 IF(KFF.EQ.5) WID2=WIDS(6,3)
19654 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
19655 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
19656 ENDIF
19657 NCHN=NCHN+1
19658 ISIG(NCHN,1)=I
19659 ISIG(NCHN,2)=J
19660 ISIG(NCHN,3)=1
19661 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
19662 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
19663 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
19664 1460 CONTINUE
19665 1470 CONTINUE
19666
19667 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
19668C...d + g -> d* and u + g -> u* (excited quarks)
19669 KFQSTR=KFPR(ISUB,2)
19670 KCQSTR=PYCOMP(KFQSTR)
19671 KFQEXC=MOD(KFQSTR,KEXCIT)
19672 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
19673 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
19674 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
19675C...Propagators: as simulated in PYOFSH and as desired
19676 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
19677 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
19678 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
19679 GMMQC=SQRT(SQM4)*WDTP(0)
19680 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
19681 FACQSA=FACQSA*HBW4C/HBW4
19682 FACQSB=FACQSB*HBW4C/HBW4
19683 DO 1490 I=MMIN1,MMAX1
19684 IA=IABS(I)
19685 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1490
19686 DO 1480 J=MMIN2,MMAX2
19687 JA=IABS(J)
19688 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1480
19689 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
19690 NCHN=NCHN+1
19691 ISIG(NCHN,1)=I
19692 ISIG(NCHN,2)=J
19693 ISIG(NCHN,3)=1
19694 SIGH(NCHN)=(4D0/3D0)*FACQSA
19695 NCHN=NCHN+1
19696 ISIG(NCHN,1)=I
19697 ISIG(NCHN,2)=J
19698 ISIG(NCHN,3)=2
19699 SIGH(NCHN)=(4D0/3D0)*FACQSA
19700 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
19701 NCHN=NCHN+1
19702 ISIG(NCHN,1)=I
19703 ISIG(NCHN,2)=J
19704 ISIG(NCHN,3)=1
19705 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19706 SIGH(NCHN)=FACQSA
19707 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
19708 NCHN=NCHN+1
19709 ISIG(NCHN,1)=I
19710 ISIG(NCHN,2)=J
19711 ISIG(NCHN,3)=1
19712 SIGH(NCHN)=(8D0/3D0)*FACQSB
19713 NCHN=NCHN+1
19714 ISIG(NCHN,1)=I
19715 ISIG(NCHN,2)=J
19716 ISIG(NCHN,3)=2
19717 SIGH(NCHN)=(8D0/3D0)*FACQSB
19718 ELSEIF(I.EQ.-J) THEN
19719 NCHN=NCHN+1
19720 ISIG(NCHN,1)=I
19721 ISIG(NCHN,2)=J
19722 ISIG(NCHN,3)=1
19723 SIGH(NCHN)=FACQSB
19724 NCHN=NCHN+1
19725 ISIG(NCHN,1)=I
19726 ISIG(NCHN,2)=J
19727 ISIG(NCHN,3)=2
19728 SIGH(NCHN)=FACQSB
19729 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
19730 NCHN=NCHN+1
19731 ISIG(NCHN,1)=I
19732 ISIG(NCHN,2)=J
19733 ISIG(NCHN,3)=1
19734 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19735 SIGH(NCHN)=FACQSB
19736 ENDIF
19737 1480 CONTINUE
19738 1490 CONTINUE
19739
19740 ELSEIF(ISUB.EQ.191) THEN
19741C...q + qbar -> rho_tech0.
19742 SQMRHT=PMAS(54,1)**2
19743 CALL PYWIDT(54,SH,WDTP,WDTE)
19744 HS=SHR*WDTP(0)
19745 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19746 IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
19747 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19748 ALPRHT=2.91D0*(3D0/PARP(144))
19749 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
19750 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19751 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19752 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19753 DO 1500 I=MMINA,MMAXA
19754 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
19755 IA=IABS(I)
19756 EI=KCHG(IABS(I),1)/3D0
19757 AI=SIGN(1D0,EI+0.1D0)
19758 VI=AI-4D0*EI*XWV
19759 VALI=0.5D0*(VI+AI)
19760 VARI=0.5D0*(VI-AI)
19761 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
19762 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
19763 IF(IA.LE.10) HI=HI*FACA/3D0
19764 NCHN=NCHN+1
19765 ISIG(NCHN,1)=I
19766 ISIG(NCHN,2)=-I
19767 ISIG(NCHN,3)=1
19768 SIGH(NCHN)=HI*FACBW*HF
19769 1500 CONTINUE
19770
19771 ELSEIF(ISUB.EQ.192) THEN
19772C...q + qbar' -> rho_tech+/-.
19773 SQMRHT=PMAS(55,1)**2
19774 CALL PYWIDT(55,SH,WDTP,WDTE)
19775 HS=SHR*WDTP(0)
19776 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19777 IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
19778 ALPRHT=2.91D0*(3D0/PARP(144))
19779 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
19780 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
19781 DO 1520 I=MMIN1,MMAX1
19782 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1520
19783 IA=IABS(I)
19784 DO 1510 J=MMIN2,MMAX2
19785 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1510
19786 JA=IABS(J)
19787 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1510
19788 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19789 & GOTO 1510
19790 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19791 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
19792 HI=HP
19793 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19794 NCHN=NCHN+1
19795 ISIG(NCHN,1)=I
19796 ISIG(NCHN,2)=J
19797 ISIG(NCHN,3)=1
19798 SIGH(NCHN)=HI*FACBW*HF
19799 1510 CONTINUE
19800 1520 CONTINUE
19801
19802 ELSEIF(ISUB.EQ.193) THEN
19803C...q + qbar -> omega_tech0.
19804 SQMOMT=PMAS(56,1)**2
19805 CALL PYWIDT(56,SH,WDTP,WDTE)
19806 HS=SHR*WDTP(0)
19807 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
19808 IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
19809 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19810 ALPRHT=2.91D0*(3D0/PARP(144))
19811 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
19812 & (2D0*PARP(143)-1D0)**2
19813 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19814 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19815 DO 1530 I=MMINA,MMAXA
19816 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1530
19817 IA=IABS(I)
19818 EI=KCHG(IABS(I),1)/3D0
19819 AI=SIGN(1D0,EI+0.1D0)
19820 VI=AI-4D0*EI*XWV
19821 VALI=0.5D0*(VI+AI)
19822 VARI=0.5D0*(VI-AI)
19823 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
19824 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
19825 IF(IA.LE.10) HI=HI*FACA/3D0
19826 NCHN=NCHN+1
19827 ISIG(NCHN,1)=I
19828 ISIG(NCHN,2)=-I
19829 ISIG(NCHN,3)=1
19830 SIGH(NCHN)=HI*FACBW*HF
19831 1530 CONTINUE
19832
19833 ELSEIF(ISUB.EQ.194) THEN
19834C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
19835 SQMRHT=PMAS(54,1)**2
19836 CALL PYWIDT(54,SH,WDTP,WDTE)
19837 HSRHT=SHR*WDTP(0)
19838 BWRHTR=SQMRHT**2*(SH-SQMRHT)/((SH-SQMRHT)**2+HSRHT**2)
19839 BWRHTI=SQMRHT**2*HSRHT/((SH-SQMRHT)**2+HSRHT**2)
19840 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19841 SQMOMT=PMAS(56,1)**2
19842 CALL PYWIDT(56,SH,WDTP,WDTE)
19843 HSOMT=SHR*WDTP(0)
19844 BWOMTR=SQMOMT**2*(SH-SQMOMT)/((SH-SQMOMT)**2+HSOMT**2)
19845 BWOMTI=SQMOMT**2*HSOMT/((SH-SQMOMT)**2+HSOMT**2)
19846 XWOMT=0.5D0/(1D0-XW)
19847 KFF=IABS(KFPR(ISUB,1))
19848 EF=KCHG(KFF,1)/3D0
19849 AF=SIGN(1D0,EF+0.1D0)
19850 VF=AF-4D0*EF*XWV
19851 VALF=0.5D0*(VF+AF)
19852 VARF=0.5D0*(VF-AF)
19853 FCOF=1D0
19854 IF(KFF.LE.10) FCOF=3D0
19855 WID2=1D0
19856 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
19857 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19858 ALPRHT=2.91D0*(3D0/PARP(144))
19859 FACTC=COMFAC*(AEM**2/(ALPRHT*SH2))**2*FCOF*WID2
19860 BWZ=SH/(SH-SQMZ)
19861 ALEFTF=EF+VALF*XWRHT*BWZ
19862 ARIGHF=EF+VARF*XWRHT*BWZ
19863 BLEFTF=(EF-VALF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19864 BRIGHF=(EF-VARF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19865 DO 1540 I=MMINA,MMAXA
19866 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
19867 EI=KCHG(IABS(I),1)/3D0
19868 AI=SIGN(1D0,EI+0.1D0)
19869 VI=AI-4D0*EI*XWV
19870 VALI=0.5D0*(VI+AI)
19871 VARI=0.5D0*(VI-AI)
19872 FCOI=1D0
19873 IF(IABS(I).LE.10) FCOI=FACA/3D0
19874 ALEFTI=EI+VALI*XWRHT*BWZ
19875 ARIGHI=EI+VARI*XWRHT*BWZ
19876 BLEFTI=(EI-VALI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19877 BRIGHI=(EI-VARI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19878 DIFLL=(ALEFTI*ALEFTF*BWRHTR+BLEFTI*BLEFTF*BWOMTR)**2+
19879 & (ALEFTI*ALEFTF*BWRHTI+BLEFTI*BLEFTF*BWOMTI)**2
19880 DIFRR=(ARIGHI*ARIGHF*BWRHTR+BRIGHI*BRIGHF*BWOMTR)**2+
19881 & (ARIGHI*ARIGHF*BWRHTI+BRIGHI*BRIGHF*BWOMTI)**2
19882 DIFLR=(ALEFTI*ARIGHF*BWRHTR+BLEFTI*BRIGHF*BWOMTR)**2+
19883 & (ALEFTI*ARIGHF*BWRHTI+BLEFTI*BRIGHF*BWOMTI)**2
19884 DIFRL=(ARIGHI*ALEFTF*BWRHTR+BRIGHI*BLEFTF*BWOMTR)**2+
19885 & (ARIGHI*ALEFTF*BWRHTI+BRIGHI*BLEFTF*BWOMTI)**2
19886 FACSIG=(DIFLL+DIFRR)*UH2+(DIFLR+DIFRL)*TH2
19887 NCHN=NCHN+1
19888 ISIG(NCHN,1)=I
19889 ISIG(NCHN,2)=-I
19890 ISIG(NCHN,3)=1
19891 SIGH(NCHN)=FACTC*FCOI*FACSIG
19892 1540 CONTINUE
19893
19894 ENDIF
19895
19896CMRENNA++
19897C...J: 2 -> 2, tree diagrams, SUSY processes
19898
19899 ELSEIF(ISUB.LE.210) THEN
19900 IF(ISUB.EQ.201) THEN
19901C...f + fbar -> e_L + e_Lbar
19902 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
19903 DO 1570 I=MMIN1,MMAX1
19904 IA=IABS(I)
19905 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1570
19906 EI=KCHG(IA,1)/3D0
19907 TT3I=SIGN(1D0,EI+1D-6)/2D0
19908 EJ=-1D0
19909 TT3J=-1D0/2D0
19910 FCOL=1D0
19911C...Color factor for e+ e-
19912 IF(IA.GE.11) FCOL=3D0
19913 IF(ILR.EQ.1) THEN
19914 A1=SFMIX(KFID,3)**2
19915 A2=SFMIX(KFID,4)**2
19916 ELSEIF(ILR.EQ.0) THEN
19917 A1=SFMIX(KFID,1)**2
19918 A2=SFMIX(KFID,2)**2
19919 ENDIF
19920 XLQ=(TT3J-EJ*XW)*A1
19921 XRQ=(-EJ*XW)*A2
19922 XLF=(TT3I-EI*XW)
19923 XRF=(-EI*XW)
19924 TAA=2D0*(EI*EJ)**2
19925 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
19926 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
19927 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
19928 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
19929 TNN=0.0D0
19930 TAN=0.0D0
19931 TZN=0.0D0
19932 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19933 FAC2=SQRT(2D0)
19934 TNN1=0D0
19935 TNN2=0D0
19936 TNN3=0D0
19937 DO 1560 II=1,4
19938 DK=1D0/(TH-SMZ(II)**2)
19939 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
19940 & ZMIX(II,1))
19941 FREK=FAC2*TANW*EI*ZMIX(II,1)
19942 TNN1=TNN1+FLEK**2*DK
19943 TNN2=TNN2+FREK**2*DK
19944 DO 1550 JJ=1,4
19945 DL=1D0/(TH-SMZ(JJ)**2)
19946 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
19947 & ZMIX(JJ,1))
19948 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
19949 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
19950 1550 CONTINUE
19951 1560 CONTINUE
19952 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
19953 TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
19954 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
19955 & (TNN1*XLF*A1+TNN2*XRF*A2)
19956 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
19957 & (1D0-SQMZ/SH)/SH
19958 TZN=TZN/XW**2/XW1
19959 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
19960 ENDIF
19961 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
19962 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
19963 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
19964 NCHN=NCHN+1
19965 ISIG(NCHN,1)=I
19966 ISIG(NCHN,2)=-I
19967 ISIG(NCHN,3)=1
19968 SIGH(NCHN)=FACQQ1+FACQQ2
19969 1570 CONTINUE
19970
19971 ELSEIF(ISUB.EQ.203) THEN
19972C...f + fbar -> e_L + e_Rbar
19973 DO 1600 I=MMIN1,MMAX1
19974 IA=IABS(I)
19975 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
19976 EI=KCHG(IABS(I),1)/3D0
19977 TT3I=SIGN(1D0,EI)/2D0
19978 EJ=-1
19979 TT3J=-1D0/2D0
19980 FCOL=1D0
19981C...Color factor for e+ e-
19982 IF(IA.GE.11) FCOL=3D0
19983 A1=SFMIX(KFID,1)**2
19984 A2=SFMIX(KFID,2)**2
19985 XLQ=(TT3J-EJ*XW)
19986 XRQ=(-EJ*XW)
19987 XLF=(TT3I-EI*XW)
19988 XRF=(-EI*XW)
19989 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
19990 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
19991 TNN=0.0D0
19992 TZN=0.0D0
19993 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19994 FAC2=SQRT(2D0)
19995 TNN1=0D0
19996 TNN2=0D0
19997 TNN3=0D0
19998 DO 1590 II=1,4
19999 DK=1D0/(TH-SMZ(II)**2)
20000 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
20001 & ZMIX(II,1))
20002 FREK=FAC2*TANW*EI*ZMIX(II,1)
20003 TNN1=TNN1+FLEK**2*DK
20004 TNN2=TNN2+FREK**2*DK
20005 DO 1580 JJ=1,4
20006 DL=1D0/(TH-SMZ(JJ)**2)
20007 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
20008 & ZMIX(JJ,1))
20009 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
20010 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
20011 1580 CONTINUE
20012 1590 CONTINUE
20013 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
20014 TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
20015 TZN=(UH*TH-SQM3*SQM4)*A1*A2
20016 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
20017 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
20018 & (1D0-SQMZ/SH)/SH
20019 ENDIF
20020 FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
20021 FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
20022 FACQQ=(FACQQ1+FACQQ2)
20023 NCHN=NCHN+1
20024 ISIG(NCHN,1)=I
20025 ISIG(NCHN,2)=-I
20026 ISIG(NCHN,3)=1
20027 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20028 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20029 NCHN=NCHN+1
20030 ISIG(NCHN,1)=I
20031 ISIG(NCHN,2)=-I
20032 ISIG(NCHN,3)=2
20033 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20034 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20035 1600 CONTINUE
20036
20037 ELSEIF(ISUB.EQ.210) THEN
20038C...q + qbar' -> W*- > ~l_L + ~nu_L
20039 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
20040 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
20041 DO 1620 I=MMIN1,MMAX1
20042 IA=IABS(I)
20043 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1620
20044 DO 1610 J=MMIN2,MMAX2
20045 JA=IABS(J)
20046 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1610
20047 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1610
20048 FCKM=3D0
20049 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20050 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20051 KCHW=2
20052 IF(KCHSUM.LT.0) KCHW=3
20053 NCHN=NCHN+1
20054 ISIG(NCHN,1)=I
20055 ISIG(NCHN,2)=J
20056 ISIG(NCHN,3)=1
20057 SIGH(NCHN)=FAC0*FAC1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),
20058 & 5-KCHW)*WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20059 1610 CONTINUE
20060 1620 CONTINUE
20061 ENDIF
20062
20063 ELSEIF(ISUB.LE.220) THEN
20064 IF(ISUB.EQ.213) THEN
20065C...f + fbar -> ~nu_L + ~nu_Lbar
20066 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20067 PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
20068 XLL=0.5D0
20069 XLR=0.0D0
20070 DO 1630 I=MMIN1,MMAX1
20071 IA=IABS(I)
20072 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
20073 EI=KCHG(IA,1)/3D0
20074 FCOL=1D0
20075C...Color factor for e+ e-
20076 IF(IA.GE.11) FCOL=3D0
20077 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20078 XRQ=-EI*XW
20079 TZC=0.0D0
20080 TCC=0.0D0
20081 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
20082 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
20083 & (TH-SMW(2)**2)
20084 TCC=TZC**2
20085 TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
20086 ENDIF
20087 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
20088 FACQQ2=TZC+TCC/4D0
20089 NCHN=NCHN+1
20090 ISIG(NCHN,1)=I
20091 ISIG(NCHN,2)=-I
20092 ISIG(NCHN,3)=1
20093 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
20094 & *AEM**2*FCOL/3D0/XW**2
20095 1630 CONTINUE
20096
20097 ELSEIF(ISUB.EQ.216) THEN
20098C...q + qbar -> ~chi0_1 + ~chi0_1
20099 IF(IZID1.EQ.IZID2) THEN
20100 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20101 ELSE
20102 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20103 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20104 ENDIF
20105 FACGG1=COMFAC*AEM**2/3D0/XW**2
20106 IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
20107 ZM12=SQM3
20108 ZM22=SQM4
20109 SR2=SQRT(2D0)
20110 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20111 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20112 XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
20113 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20114 REPRPZ = (SH-SQMZ)/PROPZ2
20115 OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
20116 & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
20117 DO 1640 I=MMINA,MMAXA
20118 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1640
20119 EI=KCHG(IABS(I),1)/3D0
20120 FCOL=1D0
20121 IF(ABS(I).GE.11) FCOL=3D0
20122 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20123 XRQ=-EI*XW
20124 XLQ=XLQ/XW1
20125 XRQ=XRQ/XW1
20126C...Factored out sqrt(2)
20127 FR1=TANW*EI*ZMIX(IZID1,1)
20128 FR2=TANW*EI*ZMIX(IZID2,1)
20129 FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
20130 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
20131 FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
20132 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
20133 FR12=FR1**2
20134 FR22=FR2**2
20135 FL12=FL1**2
20136 FL22=FL2**2
20137 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
20138 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
20139 FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
20140 FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
20141 & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
20142 FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
20143 & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
20144 FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
20145 & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
20146 FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
20147 & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
20148 NCHN=NCHN+1
20149 ISIG(NCHN,1)=I
20150 ISIG(NCHN,2)=-I
20151 ISIG(NCHN,3)=1
20152 SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
20153 1640 CONTINUE
20154 ENDIF
20155
20156 ELSEIF(ISUB.LE.230) THEN
20157 IF(ISUB.EQ.226) THEN
20158C...f + fbar -> ~chi+_1 + ~chi-_1
20159 FACGG1=COMFAC*AEM**2/3D0/XW**2
20160 ZM12=SQM3
20161 ZM22=SQM4
20162 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20163 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20164 WS2 = SMW(IZID1)*SMW(IZID2)/SH
20165 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20166 REPRPZ = (SH-SQMZ)/PROPZ2
20167 DIFF=0D0
20168 IF(IZID1.EQ.IZID2) DIFF=1D0
20169 DO 1650 I=MMINA,MMAXA
20170 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1650
20171 EI=KCHG(IABS(I),1)/3D0
20172 FCOL=1D0
20173 IF(IABS(I).GE.11) FCOL=3D0
20174 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20175 XRQ=-EI*XW
20176 XLQ=XLQ/XW1
20177 XRQ=XRQ/XW1
20178 XLQ2=XLQ**2
20179 XRQ2=XRQ**2
20180 OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
20181 & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
20182 ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
20183 & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
20184 ORP2=ORP**2
20185 OLP2=OLP**2
20186C...u-type quark - d-type squark
20187 IF(MOD(I,2).EQ.0) THEN
20188 FACT0 = UMIX(IZID1,1)*UMIX(IZID2,1)
20189 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
20190C...d-type quark - u-type squark
20191 ELSE
20192 FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
20193 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
20194 ENDIF
20195 FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
20196 FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
20197 & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
20198 & (WU2-WT2))*SH2/PROPZ2
20199 FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
20200 FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
20201 & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
20202 FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
20203 FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
20204 FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
20205 NCHN=NCHN+1
20206 ISIG(NCHN,1)=I
20207 ISIG(NCHN,2)=-I
20208 ISIG(NCHN,3)=1
20209 IF(IZID1.EQ.IZID2) THEN
20210 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20211 ELSE
20212 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20213 & WIDS(PYCOMP(KFPR(ISUBSV,1)),2)
20214 NCHN=NCHN+1
20215 ISIG(NCHN,1)=I
20216 ISIG(NCHN,2)=-I
20217 ISIG(NCHN,3)=2
20218 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20219 & WIDS(PYCOMP(KFPR(ISUBSV,1)),3)
20220 ENDIF
20221 1650 CONTINUE
20222
20223 ELSEIF(ISUB.EQ.229) THEN
20224C...q + qbar' -> ~chi0_1 + ~chi+-_1
20225 FACGG1=COMFAC*AEM**2/6D0/XW**2
20226 ZM12=SQM3
20227 ZM22=SQM4
20228 ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2
20229 ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2
20230 WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20231 WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20232 WS2 = SMW(IZID1)*SMZ(IZID2)/SH
20233 RT2I = 1D0/SQRT(2D0)
20234 PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
20235 OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
20236 & ZMIX(IZID2,2)*VMIX(IZID1,1)
20237 OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
20238 & ZMIX(IZID2,2)*UMIX(IZID1,1)
20239 OL2=OL**2
20240 OR2=OR**2
20241 CROSS=2D0*OL*OR
20242 FACST0=UMIX(IZID1,1)
20243 FACSU0=VMIX(IZID1,1)
20244 FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20245 FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20246 FACT0=FACST0**2
20247 FACU0=FACSU0**2
20248 FACTU0=FACSU0*FACST0
20249 FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
20250 & + SH2*WS2*OL)*FACST0
20251 FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
20252 & + SH2*WS2*OR)*FACSU0
20253 FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
20254 FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
20255 FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
20256 FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
20257 FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
20258 DO 1670 I=MMIN1,MMAX1
20259 IA=IABS(I)
20260 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1670
20261 DO 1660 J=MMIN2,MMAX2
20262 JA=IABS(J)
20263 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1660
20264 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1660
20265 FCKM=3D0
20266 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20267 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20268 KCHW=2
20269 IF(KCHSUM.LT.0) KCHW=3
20270 NCHN=NCHN+1
20271 ISIG(NCHN,1)=I
20272 ISIG(NCHN,2)=J
20273 ISIG(NCHN,3)=1
20274 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20275 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20276 1660 CONTINUE
20277 1670 CONTINUE
20278 ENDIF
20279
20280 ELSEIF(ISUB.LE.240) THEN
20281 IF(ISUB.EQ.237) THEN
20282C...q + qbar -> gluino + ~chi0_1
20283 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20284 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20285 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
20286 GM2=SQM3
20287 ZM2=SQM4
20288 DO 1680 I=MMINA,MMAXA
20289 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1680
20290 EI=KCHG(IABS(I),1)/3D0
20291 IA=IABS(I)
20292 XLQC = -TANW*EI*ZMIX(IZID,1)
20293 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20294 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20295 XLQ2=XLQC**2
20296 XRQ2=XRQC**2
20297 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
20298 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
20299 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
20300 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
20301 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
20302 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20303 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
20304 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
20305 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
20306 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20307 NCHN=NCHN+1
20308 ISIG(NCHN,1)=I
20309 ISIG(NCHN,2)=-I
20310 ISIG(NCHN,3)=1
20311 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
20312 1680 CONTINUE
20313 ENDIF
20314
20315 ELSEIF(ISUB.LE.250) THEN
20316 IF(ISUB.EQ.241) THEN
20317C...q + qbar' -> ~chi+-_1 + gluino
20318 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
20319 GM2=SQM3
20320 ZM2=SQM4
20321 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
20322 FAC0=UMIX(IZID,1)**2
20323 FAC1=VMIX(IZID,1)**2
20324 DO 1700 I=MMIN1,MMAX1
20325 IA=IABS(I)
20326 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1700
20327 DO 1690 J=MMIN2,MMAX2
20328 JA=IABS(J)
20329 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1690
20330 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1690
20331 FCKM=1D0
20332 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20333 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20334 KCHW=2
20335 IF(KCHSUM.LT.0) KCHW=3
20336 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
20337 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
20338 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
20339 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
20340 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
20341 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
20342 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
20343 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
20344 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
20345 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
20346 & SH/(TH-XMU2)/(UH-XMD2))/2D0
20347 NCHN=NCHN+1
20348 ISIG(NCHN,1)=I
20349 ISIG(NCHN,2)=J
20350 ISIG(NCHN,3)=1
20351 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
20352 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20353 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20354 1690 CONTINUE
20355 1700 CONTINUE
20356
20357 ELSEIF(ISUB.EQ.243) THEN
20358C...q + qbar -> gluino + gluino
20359 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20360 XMT=SQM3-TH
20361 XMU=SQM3-UH
20362 DO 1710 I=MMINA,MMAXA
20363 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
20364 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
20365 NCHN=NCHN+1
20366 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
20367 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
20368 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20369 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20370 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20371 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20372 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
20373 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
20374 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20375 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20376 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20377 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20378 ISIG(NCHN,1)=I
20379 ISIG(NCHN,2)=-I
20380 ISIG(NCHN,3)=1
20381C...1/2 for identical particles
20382 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
20383 1710 CONTINUE
20384
20385 ELSEIF(ISUB.EQ.244) THEN
20386C...g + g -> gluino + gluino
20387 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20388 XMT=SQM3-TH
20389 XMU=SQM3-UH
20390 FACQQ1=COMFAC*AS**2*9D0/4D0*(
20391 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
20392 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
20393 FACQQ2=COMFAC*AS**2*9D0/4D0*(
20394 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
20395 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
20396 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
20397 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
20398 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
20399 NCHN=NCHN+1
20400 ISIG(NCHN,1)=21
20401 ISIG(NCHN,2)=21
20402 ISIG(NCHN,3)=1
20403 SIGH(NCHN)=FACQQ1/2D0
20404 NCHN=NCHN+1
20405 ISIG(NCHN,1)=21
20406 ISIG(NCHN,2)=21
20407 ISIG(NCHN,3)=2
20408 SIGH(NCHN)=FACQQ2/2D0
20409 NCHN=NCHN+1
20410 ISIG(NCHN,1)=21
20411 ISIG(NCHN,2)=21
20412 ISIG(NCHN,3)=3
20413 SIGH(NCHN)=FACQQ3/2D0
20414 1720 CONTINUE
20415
20416 ELSEIF(ISUB.EQ.246) THEN
20417C...g + q_j -> ~chi0_1 + ~q_j
20418 FAC0=COMFAC*AS*AEM/6D0/XW
20419 ZM2=SQM4
20420 QM2=SQM3
20421 FACZQ0=FAC0*( (ZM2-TH)/SH +
20422 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20423 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20424 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20425 DO 1740 I=-KFNSQ,KFNSQ,2*KFNSQ
20426 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1740
20427 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
20428 EI=KCHG(IABS(I),1)/3D0
20429 IA=IABS(I)
20430 XRQZ = -TANW*EI*ZMIX(IZID,1)
20431 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20432 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20433 IF(ILR.EQ.0) THEN
20434 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
20435 ELSE
20436 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
20437 ENDIF
20438 FACZQ=FACZQ0*BS
20439 KCHQ=2
20440 IF(I.LT.0) KCHQ=3
20441 DO 1730 ISDE=1,2
20442 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1730
20443 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1730
20444 NCHN=NCHN+1
20445 ISIG(NCHN,ISDE)=I
20446 ISIG(NCHN,3-ISDE)=21
20447 ISIG(NCHN,3)=1
20448 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20449 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20450 1730 CONTINUE
20451 1740 CONTINUE
20452 ENDIF
20453
20454 ELSEIF(ISUB.LE.260) THEN
20455 IF(ISUB.EQ.254) THEN
20456C...g + q_j -> ~chi1_1 + ~q_i
20457 FAC0=COMFAC*AS*AEM/12D0/XW
20458 ZM2=SQM4
20459 QM2=SQM3
20460 AU=UMIX(IZID,1)**2
20461 AD=VMIX(IZID,1)**2
20462 FACZQ0=FAC0*( (ZM2-TH)/SH +
20463 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20464 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20465 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
20466 IF(MOD(KFNSQ1,2).EQ.0) THEN
20467 KFNSQ=KFNSQ1-1
20468 KCHW=2
20469 ELSE
20470 KFNSQ=KFNSQ1+1
20471 KCHW=3
20472 ENDIF
20473 DO 1760 I=-KFNSQ,KFNSQ,2*KFNSQ
20474 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1760
20475 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1760
20476 IA=IABS(I)
20477 IF(MOD(IA,2).EQ.0) THEN
20478 FACZQ=FACZQ0*AU
20479 ELSE
20480 FACZQ=FACZQ0*AD
20481 ENDIF
20482 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
20483 KCHQ=2
20484 IF(I.LT.0) KCHQ=3
20485 KCHWQ=KCHW
20486 IF(I.LT.0) KCHWQ=5-KCHW
20487 DO 1750 ISDE=1,2
20488 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1750
20489 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1750
20490 NCHN=NCHN+1
20491 ISIG(NCHN,ISDE)=I
20492 ISIG(NCHN,3-ISDE)=21
20493 ISIG(NCHN,3)=1
20494 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20495 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
20496 1750 CONTINUE
20497 1760 CONTINUE
20498
20499 ELSEIF(ISUB.EQ.258) THEN
20500C...g + q_j -> gluino + ~q_i
20501 XG2=SQM4
20502 XQ2=SQM3
20503 XMT=XG2-TH
20504 XMU=XG2-UH
20505 XST=XQ2-TH
20506 XSU=XQ2-UH
20507 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
20508 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
20509 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
20510 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
20511 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
20512 & (SH*(UH+XG2)
20513 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
20514 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
20515 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
20516 FACQG1=COMFAC*AS**2*FACQG1/2D0
20517 FACQG2=COMFAC*AS**2*FACQG2/2D0
20518 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20519 DO 1780 I=-KFNSQ,KFNSQ,2*KFNSQ
20520 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1780
20521 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1780
20522 KCHQ=2
20523 IF(I.LT.0) KCHQ=3
20524 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20525 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20526 DO 1770 ISDE=1,2
20527 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1770
20528 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1770
20529 NCHN=NCHN+1
20530 ISIG(NCHN,ISDE)=I
20531 ISIG(NCHN,3-ISDE)=21
20532 ISIG(NCHN,3)=1
20533 SIGH(NCHN)=FACQG1*FACSEL
20534 NCHN=NCHN+1
20535 ISIG(NCHN,ISDE)=I
20536 ISIG(NCHN,3-ISDE)=21
20537 ISIG(NCHN,3)=2
20538 SIGH(NCHN)=FACQG2*FACSEL
20539 1770 CONTINUE
20540 1780 CONTINUE
20541 ENDIF
20542
20543 ELSEIF(ISUB.LE.270) THEN
20544 IF(ISUB.EQ.261) THEN
20545C...q_i + q_ibar -> ~t_1 + ~t_1bar
20546 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
20547 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20548 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20549 FAC0=AS**2*4D0/9D0
20550 DO 1790 I=MMIN1,MMAX1
20551 IA=IABS(I)
20552 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1790
20553 IF(IA.GE.11.AND.IA.LE.18) THEN
20554 EI=KCHG(IA,1)/3D0
20555 EJ=KCHG(KFNSQ,1)/3D0
20556 T3I=SIGN(1D0,EI)/2D0
20557 T3J=SIGN(1D0,EJ)/2D0
20558 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
20559 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
20560 XLF=2D0*(T3I-EI*XW)
20561 XRF=2D0*(-EI*XW)
20562 TAA=0.5D0*(EI*EJ)**2
20563 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20564 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20565 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20566 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20567 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20568 ENDIF
20569 NCHN=NCHN+1
20570 ISIG(NCHN,1)=I
20571 ISIG(NCHN,2)=-I
20572 ISIG(NCHN,3)=1
20573 SIGH(NCHN)=FACQQ1*FAC0
20574 1790 CONTINUE
20575
20576 ELSEIF(ISUB.EQ.263) THEN
20577C...f + fbar -> ~t1 + ~t2bar
20578 DO 1800 I=MMIN1,MMAX1
20579 IA=IABS(I)
20580 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
20581 EI=KCHG(IABS(I),1)/3D0
20582 TT3I=SIGN(1D0,EI)/2D0
20583 EJ=2D0/3D0
20584 TT3J=1D0/2D0
20585 FCOL=1D0
20586C...Color factor for e+ e-
20587 IF(IA.GE.11) FCOL=3D0
20588 XLQ=2D0*(TT3J-EJ*XW)
20589 XRQ=2D0*(-EJ*XW)
20590 XLF=2D0*(TT3I-EI*XW)
20591 XRF=2D0*(-EI*XW)
20592 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
20593 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
20594 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20595C...Factor of 2 for t1 t2bar + t2 t1bar
20596 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
20597 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
20598 NCHN=NCHN+1
20599 ISIG(NCHN,1)=I
20600 ISIG(NCHN,2)=-I
20601 ISIG(NCHN,3)=1
20602 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20603 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20604 NCHN=NCHN+1
20605 ISIG(NCHN,1)=I
20606 ISIG(NCHN,2)=-I
20607 ISIG(NCHN,3)=2
20608 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20609 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20610 1800 CONTINUE
20611
20612 ELSEIF(ISUB.EQ.264) THEN
20613C...g + g -> ~t_1 + ~t_1bar
20614 XSU=SQM3-UH
20615 XST=SQM3-TH
20616 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
20617 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20618 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20619 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20620 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1810
20621 NCHN=NCHN+1
20622 ISIG(NCHN,1)=21
20623 ISIG(NCHN,2)=21
20624 ISIG(NCHN,3)=1
20625 SIGH(NCHN)=FACQQ1
20626 NCHN=NCHN+1
20627 ISIG(NCHN,1)=21
20628 ISIG(NCHN,2)=21
20629 ISIG(NCHN,3)=2
20630 SIGH(NCHN)=FACQQ2
20631 1810 CONTINUE
20632 ENDIF
20633
20634 ELSEIF(ISUB.LE.280) THEN
20635 IF(ISUB.EQ.271) THEN
20636C...q + q' -> ~q + ~q' (~g exchange)
20637 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20638 XMT=XMG2-TH
20639 XMU=XMG2-UH
20640 XSU1=SQM3-UH
20641 XSU2=SQM4-UH
20642 XST1=SQM3-TH
20643 XST2=SQM4-TH
20644 IF(ILR.EQ.1) THEN
20645 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
20646 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
20647 FACQQB=0.0D0
20648 ELSE
20649 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
20650 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
20651 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
20652 & XMT/XMU )
20653 ENDIF
20654 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20655 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20656 DO 1830 I=-KFNSQI,KFNSQI,2*KFNSQI
20657 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1830
20658 IA=IABS(I)
20659 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1830
20660 KCHQ=2
20661 IF(I.LT.0) KCHQ=3
20662 DO 1820 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20663 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1820
20664 JA=IABS(J)
20665 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1820
20666 IF(I*J.LT.0) GOTO 1820
20667 NCHN=NCHN+1
20668 ISIG(NCHN,1)=I
20669 ISIG(NCHN,2)=J
20670 ISIG(NCHN,3)=1
20671 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20672 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20673 IF(I.EQ.J) THEN
20674 IF(ISUBSV.LE.272) THEN
20675 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20676 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20677 ELSE
20678 SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20679 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20680 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20681 ENDIF
20682 NCHN=NCHN+1
20683 ISIG(NCHN,1)=I
20684 ISIG(NCHN,2)=J
20685 ISIG(NCHN,3)=2
20686 IF(ISUBSV.LE.272) THEN
20687 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20688 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20689 ELSE
20690 SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20691 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20692 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20693 ENDIF
20694 ENDIF
20695 1820 CONTINUE
20696 1830 CONTINUE
20697
20698 ELSEIF(ISUB.EQ.274) THEN
20699C...q + qbar -> ~q' + ~qbar'
20700 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20701 XMT=XMG2-TH
20702 XMU=XMG2-UH
20703 IF(ILR.EQ.0) THEN
20704 FACQQ1=COMFAC*AS**2*4D0/9D0*(
20705 & (UH*TH-SQM3*SQM4)/XMT**2 )
20706 FACQQB=COMFAC*AS**2*4D0/9D0*(
20707 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT**2))
20708 FACQQB=FACQQB+FACQQ1
20709 ELSE
20710 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
20711 FACQQB=FACQQ1
20712 ENDIF
20713 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20714 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20715 DO 1850 I=-KFNSQI,KFNSQI,2*KFNSQI
20716 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1850
20717 IA=IABS(I)
20718 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1850
20719 KCHQ=2
20720 IF(I.LT.0) KCHQ=3
20721 DO 1840 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20722 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1840
20723 JA=IABS(J)
20724 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1840
20725 IF(I*J.GT.0) GOTO 1840
20726 NCHN=NCHN+1
20727 ISIG(NCHN,1)=I
20728 ISIG(NCHN,2)=J
20729 ISIG(NCHN,3)=1
20730 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20731 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
20732 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
20733 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20734 1840 CONTINUE
20735 1850 CONTINUE
20736
20737 ELSEIF(ISUB.EQ.277) THEN
20738C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
20739C...if i .eq. j covered in 274
20740 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
20741 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20742 FAC0=0D0
20743 DO 1860 I=MMIN1,MMAX1
20744 IA=IABS(I)
20745 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
20746 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
20747 IF(IA.EQ.KFNSQ) GOTO 1860
20748 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
20749 EI=KCHG(IA,1)/3D0
20750 EJ=KCHG(KFNSQ,1)/3D0
20751 T3J=SIGN(0.5D0,EJ)
20752 T3I=SIGN(1D0,EI)/2D0
20753 IF(ILR.EQ.0) THEN
20754 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
20755 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
20756 ELSE
20757 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
20758 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
20759 ENDIF
20760 XLF=2D0*(T3I-EI*XW)
20761 XRF=2D0*(-EI*XW)
20762 IF(ILR.EQ.0) THEN
20763 XRQ=0D0
20764 ELSE
20765 XLQ=0D0
20766 ENDIF
20767 TAA=0.5D0*(EI*EJ)**2
20768 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20769 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20770 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20771 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20772 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20773 ELSEIF(IA.LE.6) THEN
20774 FAC0=AS**2*8D0/9D0/2D0
20775 ENDIF
20776 NCHN=NCHN+1
20777 ISIG(NCHN,1)=I
20778 ISIG(NCHN,2)=-I
20779 ISIG(NCHN,3)=1
20780 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20781 1860 CONTINUE
20782
20783 ELSEIF(ISUB.EQ.279) THEN
20784C...g + g -> ~q_j + ~q_jbar
20785 XSU=SQM3-UH
20786 XST=SQM3-TH
20787C...5=RKF because ~t ~tbar treated separately
20788 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
20789 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20790 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20791 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
20792 NCHN=NCHN+1
20793 ISIG(NCHN,1)=21
20794 ISIG(NCHN,2)=21
20795 ISIG(NCHN,3)=1
20796 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20797 NCHN=NCHN+1
20798 ISIG(NCHN,1)=21
20799 ISIG(NCHN,2)=21
20800 ISIG(NCHN,3)=2
20801 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20802 1870 CONTINUE
20803
20804 ENDIF
20805CMRENNA--
20806 ENDIF
20807
20808C...Multiply with parton distributions
20809 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20810 DO 1880 ICHN=1,NCHN
20811 IF(MINT(45).GE.2) THEN
20812 KFL1=ISIG(ICHN,1)
20813 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20814 ENDIF
20815 IF(MINT(46).GE.2) THEN
20816 KFL2=ISIG(ICHN,2)
20817 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20818 ENDIF
20819 SIGS=SIGS+SIGH(ICHN)
20820 1880 CONTINUE
20821 ENDIF
20822
20823 RETURN
20824 END
20825
20826C*********************************************************************
20827
20828*$ CREATE PYPDFU.FOR
20829*COPY PYPDFU
20830C...PYPDFU
20831C...Gives electron, photon, pi+, neutron, proton and hyperon
20832C...parton distributions according to a few different parametrizations.
20833C...Note that what is coded is x times the probability distribution,
20834C...i.e. xq(x,Q2) etc.
20835
20836 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
20837
20838C...Double precision and integer declarations.
20839 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20840 INTEGER PYK,PYCHGE,PYCOMP
20841C...Commonblocks.
20842 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20843 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20844 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20845 COMMON/PYINT1/MINT(400),VINT(400)
20846 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
20847 &XPDIR(-6:6)
20848 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
20849C...Local arrays.
20850 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
20851 &XPPI(-6:6),XPPR(-6:6)
20852
20853C...Interface to PDFLIB.
20854 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
20855 SAVE /W50513/
20856 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
20857 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
20858 CHARACTER*20 PARM(20)
20859 DATA VALUE/20*0D0/,PARM/20*' '/
20860
20861C...Data related to Schuler-Sjostrand photon distributions.
20862 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
20863
20864C...Reset parton distributions.
20865 MINT(92)=0
20866 DO 100 KFL=-25,25
20867 XPQ(KFL)=0D0
20868 100 CONTINUE
20869
20870C...Check x and particle species.
20871 IF(X.LE.0D0.OR.X.GE.1D0) THEN
20872 WRITE(MSTU(11),5000) X
20873 RETURN
20874 ENDIF
20875 KFA=IABS(KF)
20876 IF(KFA.NE.11.AND.KFA.NE.22.AND.KFA.NE.211.AND.KFA.NE.2112.AND.
20877 &KFA.NE.2212.AND.KFA.NE.3122.AND.KFA.NE.3112.AND.KFA.NE.3212
20878 &.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.KFA.NE.3322.AND.
20879 &KFA.NE.3334.AND.KFA.NE.111) THEN
20880 WRITE(MSTU(11),5100) KF
20881 RETURN
20882 ENDIF
20883
20884C...Electron parton distribution call.
20885 IF(KFA.EQ.11) THEN
20886 CALL PYPDEL(X,Q2,XPEL)
20887 DO 110 KFL=-25,25
20888 XPQ(KFL)=XPEL(KFL)
20889 110 CONTINUE
20890
20891C...Photon parton distribution call (VDM+anomalous).
20892 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
20893 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
20894 CALL PYPDGA(X,Q2,XPGA)
20895 DO 120 KFL=-6,6
20896 XPQ(KFL)=XPGA(KFL)
20897 120 CONTINUE
20898 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
20899 Q2MX=Q2
20900 P2MX=0.36D0
20901 IF(MSTP(55).GE.7) P2MX=4.0D0
20902 IF(MSTP(57).EQ.0) Q2MX=P2MX
20903 CALL PYGGAM(MSTP(55)-4,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20904 DO 130 KFL=-6,6
20905 XPQ(KFL)=XPGA(KFL)
20906 130 CONTINUE
20907 VINT(231)=P2MX
20908 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
20909 Q2MX=Q2
20910 P2MX=0.36D0
20911 IF(MSTP(55).GE.11) P2MX=4.0D0
20912 IF(MSTP(57).EQ.0) Q2MX=P2MX
20913 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20914 DO 140 KFL=-6,6
20915 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
20916 140 CONTINUE
20917 VINT(231)=P2MX
20918 ELSEIF(MSTP(56).EQ.2) THEN
20919C...Call PDFLIB parton distributions.
20920 PARM(1)='NPTYPE'
20921 VALUE(1)=3
20922 PARM(2)='NGROUP'
20923 VALUE(2)=MSTP(55)/1000
20924 PARM(3)='NSET'
20925 VALUE(3)=MOD(MSTP(55),1000)
20926 IF(MINT(93).NE.3000000+MSTP(55)) THEN
20927 CALL PDFSET(PARM,VALUE)
20928 MINT(93)=3000000+MSTP(55)
20929 ENDIF
20930 XX=X
20931 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20932 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20933 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20934 VINT(231)=Q2MIN
20935 XPQ(0)=GLU
20936 XPQ(1)=DNV
20937 XPQ(-1)=DNV
20938 XPQ(2)=UPV
20939 XPQ(-2)=UPV
20940 XPQ(3)=STR
20941 XPQ(-3)=STR
20942 XPQ(4)=CHM
20943 XPQ(-4)=CHM
20944 XPQ(5)=BOT
20945 XPQ(-5)=BOT
20946 XPQ(6)=TOP
20947 XPQ(-6)=TOP
20948 ELSE
20949 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
20950 ENDIF
20951
20952C...Pion/gammaVDM parton distribution call.
20953 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
20954 & MINT(109).EQ.2)) THEN
20955 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
20956 & MSTP(55).LE.12) THEN
20957 ISET=1+MOD(MSTP(55)-1,4)
20958 Q2MX=Q2
20959 P2MX=0.36D0
20960 IF(ISET.GE.3) P2MX=4.0D0
20961 IF(MSTP(57).EQ.0) Q2MX=P2MX
20962 CALL PYGVMD(ISET,2,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20963 DO 150 KFL=-6,6
20964 XPQ(KFL)=XPGA(KFL)
20965 150 CONTINUE
20966 VINT(231)=P2MX
20967 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
20968 CALL PYPDPI(X,Q2,XPPI)
20969 DO 160 KFL=-6,6
20970 XPQ(KFL)=XPPI(KFL)
20971 160 CONTINUE
20972 ELSEIF(MSTP(54).EQ.2) THEN
20973C...Call PDFLIB parton distributions.
20974 PARM(1)='NPTYPE'
20975 VALUE(1)=2
20976 PARM(2)='NGROUP'
20977 VALUE(2)=MSTP(53)/1000
20978 PARM(3)='NSET'
20979 VALUE(3)=MOD(MSTP(53),1000)
20980 IF(MINT(93).NE.2000000+MSTP(53)) THEN
20981 CALL PDFSET(PARM,VALUE)
20982 MINT(93)=2000000+MSTP(53)
20983 ENDIF
20984 XX=X
20985 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20986 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20987 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20988 VINT(231)=Q2MIN
20989 XPQ(0)=GLU
20990 XPQ(1)=DSEA
20991 XPQ(-1)=UPV+DSEA
20992 XPQ(2)=UPV+USEA
20993 XPQ(-2)=USEA
20994 XPQ(3)=STR
20995 XPQ(-3)=STR
20996 XPQ(4)=CHM
20997 XPQ(-4)=CHM
20998 XPQ(5)=BOT
20999 XPQ(-5)=BOT
21000 XPQ(6)=TOP
21001 XPQ(-6)=TOP
21002 ELSE
21003 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
21004 ENDIF
21005
21006C...Anomalous photon parton distribution call.
21007 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
21008 Q2MX=Q2
21009 P2MX=PARP(15)**2
21010 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
21011 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
21012 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
21013 IF(MSTP(57).EQ.0) Q2MX=P2MX
21014 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
21015 DO 170 KFL=-6,6
21016 XPQ(KFL)=XPGA(KFL)
21017 170 CONTINUE
21018 VINT(231)=P2MX
21019 ELSEIF(MSTP(56).EQ.1) THEN
21020 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
21021 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
21022 IF(MSTP(57).EQ.0) Q2MX=P2MX
21023 CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GM,XPGA)
21024 DO 180 KFL=-6,6
21025 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
21026 180 CONTINUE
21027 VINT(231)=P2MX
21028 ELSEIF(MSTP(56).EQ.2) THEN
21029 IF(MSTP(57).EQ.0) Q2MX=P2MX
21030 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
21031 DO 190 KFL=-6,6
21032 XPQ(KFL)=XPGA(KFL)
21033 190 CONTINUE
21034 VINT(231)=P2MX
21035 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
21036 IF(MSTP(57).EQ.0) Q2MX=P2MX
21037 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
21038 DO 200 KFL=-6,6
21039 XPQ(KFL)=XPGA(KFL)
21040 200 CONTINUE
21041 VINT(231)=P2MX
21042 ELSE
21043 210 RKF=11D0*PYR(0)
21044 KFR=1
21045 IF(RKF.GT.1D0) KFR=2
21046 IF(RKF.GT.5D0) KFR=3
21047 IF(RKF.GT.6D0) KFR=4
21048 IF(RKF.GT.10D0) KFR=5
21049 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
21050 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
21051 IF(MSTP(57).EQ.0) Q2MX=P2MX
21052 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
21053 DO 220 KFL=-6,6
21054 XPQ(KFL)=XPGA(KFL)
21055 220 CONTINUE
21056 VINT(231)=P2MX
21057 ENDIF
21058
21059C...Proton parton distribution call.
21060 ELSE
21061 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.11) THEN
21062 CALL PYPDPR(X,Q2,XPPR)
21063 DO 230 KFL=-6,6
21064 XPQ(KFL)=XPPR(KFL)
21065 230 CONTINUE
21066 ELSEIF(MSTP(52).EQ.2) THEN
21067C...Call PDFLIB parton distributions.
21068 PARM(1)='NPTYPE'
21069 VALUE(1)=1
21070 PARM(2)='NGROUP'
21071 VALUE(2)=MSTP(51)/1000
21072 PARM(3)='NSET'
21073 VALUE(3)=MOD(MSTP(51),1000)
21074 IF(MINT(93).NE.1000000+MSTP(51)) THEN
21075 CALL PDFSET(PARM,VALUE)
21076 MINT(93)=1000000+MSTP(51)
21077 ENDIF
21078 XX=X
21079 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21080 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21081 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21082 VINT(231)=Q2MIN
21083 XPQ(0)=GLU
21084 XPQ(1)=DNV+DSEA
21085 XPQ(-1)=DSEA
21086 XPQ(2)=UPV+USEA
21087 XPQ(-2)=USEA
21088 XPQ(3)=STR
21089 XPQ(-3)=STR
21090 XPQ(4)=CHM
21091 XPQ(-4)=CHM
21092 XPQ(5)=BOT
21093 XPQ(-5)=BOT
21094 XPQ(6)=TOP
21095 XPQ(-6)=TOP
21096 ELSE
21097 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
21098 ENDIF
21099 ENDIF
21100
21101C...Isospin average for pi0/gammaVDM.
21102 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
21103 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
21104 XPV=XPQ(2)-XPQ(1)
21105 XPQ(2)=XPQ(1)
21106 XPQ(-2)=XPQ(-1)
21107 ELSE
21108 XPS=0.5D0*(XPQ(1)+XPQ(-2))
21109 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
21110 XPQ(2)=XPS
21111 XPQ(-1)=XPS
21112 ENDIF
21113 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
21114 XPQ(1)=XPQ(1)+0.2D0*XPV
21115 XPQ(-1)=XPQ(-1)+0.2D0*XPV
21116 XPQ(2)=XPQ(2)+0.8D0*XPV
21117 XPQ(-2)=XPQ(-2)+0.8D0*XPV
21118 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
21119 XPQ(3)=XPQ(3)+XPV
21120 XPQ(-3)=XPQ(-3)+XPV
21121 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
21122 XPQ(4)=XPQ(4)+XPV
21123 XPQ(-4)=XPQ(-4)+XPV
21124 IF(MSTP(55).GE.9) THEN
21125 DO 240 KFL=-6,6
21126 XPQ(KFL)=0D0
21127 240 CONTINUE
21128 ENDIF
21129 ELSE
21130 XPQ(1)=XPQ(1)+0.5D0*XPV
21131 XPQ(-1)=XPQ(-1)+0.5D0*XPV
21132 XPQ(2)=XPQ(2)+0.5D0*XPV
21133 XPQ(-2)=XPQ(-2)+0.5D0*XPV
21134 ENDIF
21135
21136C...Rescale for gammaVDM by effective gamma -> rho coupling.
21137 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
21138 DO 250 KFL=-6,6
21139 XPQ(KFL)=VINT(281)*XPQ(KFL)
21140 250 CONTINUE
21141 VINT(232)=VINT(281)*XPV
21142 ENDIF
21143
21144C...Isospin conjugation for neutron.
21145 ELSEIF(KFA.EQ.2112) THEN
21146 XPS=XPQ(1)
21147 XPQ(1)=XPQ(2)
21148 XPQ(2)=XPS
21149 XPS=XPQ(-1)
21150 XPQ(-1)=XPQ(-2)
21151 XPQ(-2)=XPS
21152
21153C...Simple recipes for hyperon (average valence parton distribution).
21154 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
21155 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
21156 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
21157 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
21158 XPQ(1)=XPSEA
21159 XPQ(2)=XPSEA
21160 XPQ(-1)=XPSEA
21161 XPQ(-2)=XPSEA
21162 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
21163 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
21164 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
21165 ENDIF
21166
21167C...Charge conjugation for antiparticle.
21168 IF(KF.LT.0) THEN
21169 DO 260 KFL=1,25
21170 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
21171 XPS=XPQ(KFL)
21172 XPQ(KFL)=XPQ(-KFL)
21173 XPQ(-KFL)=XPS
21174 260 CONTINUE
21175 ENDIF
21176
21177C...Allow gluon also in position 21.
21178 XPQ(21)=XPQ(0)
21179
21180C...Check positivity and reset above maximum allowed flavour.
21181 DO 270 KFL=-25,25
21182 XPQ(KFL)=MAX(0D0,XPQ(KFL))
21183 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
21184 270 CONTINUE
21185
21186C...Formats for error printouts.
21187 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21188 5100 FORMAT(' Error: illegal particle code for parton distribution;',
21189 &' KF =',I5)
21190 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
21191 &3I5)
21192
21193 RETURN
21194 END
21195
21196C*********************************************************************
21197
21198*$ CREATE PYPDFL.FOR
21199*COPY PYPDFL
21200C...PYPDFL
21201C...Gives proton parton distribution at small x and/or Q^2 according to
21202C...correct limiting behaviour.
21203
21204 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
21205
21206C...Double precision and integer declarations.
21207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21208 INTEGER PYK,PYCHGE,PYCOMP
21209C...Commonblocks.
21210 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21211 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21212 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21213 COMMON/PYINT1/MINT(400),VINT(400)
21214 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21215C...Local arrays.
21216 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
21217 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
21218
21219C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
21220 MINT(92)=0
21221 KFA=IABS(KF)
21222 IACC=0
21223 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
21224 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
21225 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
21226 IF(IACC.EQ.0) THEN
21227 CALL PYPDFU(KF,X,Q2,XPQ)
21228 RETURN
21229 ENDIF
21230
21231C...Reset. Check x.
21232 DO 100 KFL=-25,25
21233 XPQ(KFL)=0D0
21234 100 CONTINUE
21235 IF(X.LE.0D0.OR.X.GE.1D0) THEN
21236 WRITE(MSTU(11),5000) X
21237 RETURN
21238 ENDIF
21239
21240C...Define valence content.
21241 KFC=KF
21242 NV1=2
21243 NV2=1
21244 IF(KF.EQ.2212) THEN
21245 KFV1=2
21246 KFV2=1
21247 ELSEIF(KF.EQ.-2212) THEN
21248 KFV1=-2
21249 KFV2=-1
21250 ELSEIF(KF.EQ.2112) THEN
21251 KFV1=1
21252 KFV2=2
21253 ELSEIF(KF.EQ.-2112) THEN
21254 KFV1=-1
21255 KFV2=-2
21256 ELSEIF(KF.EQ.211) THEN
21257 NV1=1
21258 KFV1=2
21259 KFV2=-1
21260 ELSEIF(KF.EQ.-211) THEN
21261 NV1=1
21262 KFV1=-2
21263 KFV2=1
21264 ELSEIF(MINT(105).LE.223) THEN
21265 KFV1=1
21266 WTV1=0.2D0
21267 KFV2=2
21268 WTV2=0.8D0
21269 ELSEIF(MINT(105).EQ.333) THEN
21270 KFV1=3
21271 WTV1=1.0D0
21272 KFV2=1
21273 WTV2=0.0D0
21274 ELSEIF(MINT(105).EQ.443) THEN
21275 KFV1=4
21276 WTV1=1.0D0
21277 KFV2=1
21278 WTV2=0.0D0
21279 ENDIF
21280
21281C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
21282 CALL PYPDFU(KFC,X,Q2,XPA)
21283 Q2MN=MAX(3D0,VINT(231))
21284 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
21285 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
21286
21287C...Large Q2 and large x: naive call is enough.
21288 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
21289 DO 110 KFL=-25,25
21290 XPQ(KFL)=XPA(KFL)
21291 110 CONTINUE
21292 MINT(92)=1
21293
21294C...Small Q2 and large x: dampen boundary value.
21295 ELSEIF(X.GT.XMN) THEN
21296
21297C...Evaluate at boundary and define dampening factors.
21298 CALL PYPDFU(KFC,X,Q2MN,XPA)
21299 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
21300 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
21301
21302C...Separate valence and sea parts of parton distribution.
21303 IF(KFA.NE.22) THEN
21304 XFV1=XPA(KFV1)-XPA(-KFV1)
21305 XPA(KFV1)=XPA(-KFV1)
21306 XFV2=XPA(KFV2)-XPA(-KFV2)
21307 XPA(KFV2)=XPA(-KFV2)
21308 ELSE
21309 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21310 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21311 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21312 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21313 ENDIF
21314
21315C...Dampen valence and sea separately. Put back together.
21316 DO 120 KFL=-25,25
21317 XPQ(KFL)=FS*XPA(KFL)
21318 120 CONTINUE
21319 IF(KFA.NE.22) THEN
21320 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
21321 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
21322 ELSE
21323 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
21324 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
21325 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
21326 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
21327 ENDIF
21328 MINT(92)=2
21329
21330C...Large Q2 and small x: interpolate behaviour.
21331 ELSEIF(Q2.GT.Q2MN) THEN
21332
21333C...Evaluate at extremes and define coefficients for interpolation.
21334 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21335 VI232A=VINT(232)
21336 CALL PYPDFU(KFC,X,Q2B,XPB)
21337 VI232B=VINT(232)
21338 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
21339 FVA=(X/XMN)**0.45D0*FLA
21340 FSA=(X/XMN)**(-0.08D0)*FLA
21341 FB=1D0-FLA
21342
21343C...Separate valence and sea parts of parton distribution.
21344 IF(KFA.NE.22) THEN
21345 XFVA1=XPA(KFV1)-XPA(-KFV1)
21346 XPA(KFV1)=XPA(-KFV1)
21347 XFVA2=XPA(KFV2)-XPA(-KFV2)
21348 XPA(KFV2)=XPA(-KFV2)
21349 XFVB1=XPB(KFV1)-XPB(-KFV1)
21350 XPB(KFV1)=XPB(-KFV1)
21351 XFVB2=XPB(KFV2)-XPB(-KFV2)
21352 XPB(KFV2)=XPB(-KFV2)
21353 ELSE
21354 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
21355 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
21356 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
21357 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
21358 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
21359 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
21360 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
21361 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
21362 ENDIF
21363
21364C...Interpolate for valence and sea. Put back together.
21365 DO 130 KFL=-25,25
21366 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
21367 130 CONTINUE
21368 IF(KFA.NE.22) THEN
21369 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
21370 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
21371 ELSE
21372 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21373 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21374 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21375 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21376 ENDIF
21377 MINT(92)=3
21378
21379C...Small Q2 and small x: dampen boundary value and add term.
21380 ELSE
21381
21382C...Evaluate at boundary and define dampening factors.
21383 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21384 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
21385 FA=1D0-FB
21386 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
21387 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
21388 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
21389 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
21390 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
21391 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
21392
21393C...Separate valence and sea parts of parton distribution.
21394 IF(KFA.NE.22) THEN
21395 XFV1=XPA(KFV1)-XPA(-KFV1)
21396 XPA(KFV1)=XPA(-KFV1)
21397 XFV2=XPA(KFV2)-XPA(-KFV2)
21398 XPA(KFV2)=XPA(-KFV2)
21399 ELSE
21400 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21401 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21402 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21403 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21404 ENDIF
21405
21406C...Dampen valence and sea separately. Add constant terms.
21407C...Put back together.
21408 DO 140 KFL=-25,25
21409 XPQ(KFL)=FSA*XPA(KFL)
21410 140 CONTINUE
21411 IF(KFA.NE.22) THEN
21412 DO 150 KFL=-3,3
21413 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
21414 150 CONTINUE
21415 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
21416 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
21417 ELSE
21418 DO 160 KFL=-3,3
21419 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
21420 160 CONTINUE
21421 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21422 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21423 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21424 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21425 ENDIF
21426 XPQ(21)=XPQ(0)
21427 MINT(92)=4
21428 ENDIF
21429
21430C...Format for error printout.
21431 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21432
21433 RETURN
21434 END
21435
21436C*********************************************************************
21437
21438*$ CREATE PYPDEL.FOR
21439*COPY PYPDEL
21440C...PYPDEL
21441C...Gives electron parton distribution.
21442
21443 SUBROUTINE PYPDEL(X,Q2,XPEL)
21444
21445C...Double precision and integer declarations.
21446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21447 INTEGER PYK,PYCHGE,PYCOMP
21448C...Commonblocks.
21449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21450 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21451 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21452 COMMON/PYINT1/MINT(400),VINT(400)
21453 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21454C...Local arrays.
21455 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
21456
21457C...Interface to PDFLIB.
21458 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
21459 SAVE /W50513/
21460 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
21461 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
21462 CHARACTER*20 PARM(20)
21463 DATA VALUE/20*0D0/,PARM/20*' '/
21464
21465C...Some common constants.
21466 DO 100 KFL=-25,25
21467 XPEL(KFL)=0D0
21468 100 CONTINUE
21469 AEM=PARU(101)
21470 PME=PMAS(11,1)
21471 XL=LOG(MAX(1D-10,X))
21472 X1L=LOG(MAX(1D-10,1D0-X))
21473 HLE=LOG(MAX(3D0,Q2/PME**2))
21474 HBE2=(AEM/PARU(1))*(HLE-1D0)
21475
21476C...Electron inside electron, see R. Kleiss et al., in Z physics at
21477C...LEP 1, CERN 89-08, p. 34
21478 IF(MSTP(59).LE.1) THEN
21479 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
21480 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
21481 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
21482 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
21483 & 4D0*XL/(1D0-X)-5D0-X)
21484 ELSE
21485 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
21486 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
21487 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
21488 ENDIF
21489 IF(X.GT.0.9999D0.AND.X.LE.0.999999D0) THEN
21490 HEE=HEE*100D0**HBE2/(100D0**HBE2-1D0)
21491 ELSEIF(X.GT.0.999999D0) THEN
21492 HEE=0D0
21493 ENDIF
21494 XPEL(11)=X*HEE
21495
21496C...Photon and (transverse) W- inside electron.
21497 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
21498 IF(MSTP(13).LE.1) THEN
21499 HLG=HLE
21500 ELSE
21501 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
21502 ENDIF
21503 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
21504 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
21505 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
21506
21507C...Electron or positron inside photon inside electron.
21508 IF(MSTP(12).EQ.1) THEN
21509 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
21510 & 2D0*X*(1D0+X)*XL)
21511 XPEL(11)=XPEL(11)+XFSEA
21512 XPEL(-11)=XFSEA
21513
21514C...Initialize PDFLIB photon parton distributions.
21515 IF(MSTP(56).EQ.2) THEN
21516 PARM(1)='NPTYPE'
21517 VALUE(1)=3
21518 PARM(2)='NGROUP'
21519 VALUE(2)=MSTP(55)/1000
21520 PARM(3)='NSET'
21521 VALUE(3)=MOD(MSTP(55),1000)
21522 IF(MINT(93).NE.3000000+MSTP(55)) THEN
21523 CALL PDFSET(PARM,VALUE)
21524 MINT(93)=3000000+MSTP(55)
21525 ENDIF
21526 ENDIF
21527
21528C...Quarks and gluons inside photon inside electron:
21529C...numerical convolution required.
21530 DO 110 KFL=0,6
21531 SXP(KFL)=0D0
21532 110 CONTINUE
21533 SUMXPP=0D0
21534 ITER=-1
21535 120 ITER=ITER+1
21536 SUMXP=SUMXPP
21537 NSTP=2**(ITER-1)
21538 IF(ITER.EQ.0) NSTP=2
21539 DO 130 KFL=0,6
21540 SXP(KFL)=0.5D0*SXP(KFL)
21541 130 CONTINUE
21542 WTSTP=0.5D0/NSTP
21543 IF(ITER.EQ.0) WTSTP=0.5D0
21544C...Pick grid of x_{gamma} values logarithmically even.
21545 DO 150 ISTP=1,NSTP
21546 IF(ITER.EQ.0) THEN
21547 XLE=XL*(ISTP-1)
21548 ELSE
21549 XLE=XL*(ISTP-0.5D0)/NSTP
21550 ENDIF
21551 XE=MIN(0.999999D0,EXP(XLE))
21552 XG=MIN(0.999999D0,X/XE)
21553C...Evaluate photon inside electron parton distribution for convolution.
21554 XPGP=1D0+(1D0-XE)**2
21555 IF(MSTP(13).LE.1) THEN
21556 XPGP=XPGP*HLE
21557 ELSE
21558 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
21559 ENDIF
21560C...Evaluate photon parton distributions for convolution.
21561 IF(MSTP(56).EQ.1) THEN
21562 CALL PYPDGA(XG,Q2,XPGA)
21563 DO 140 KFL=0,5
21564 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
21565 140 CONTINUE
21566 ELSEIF(MSTP(56).EQ.2) THEN
21567C...Call PDFLIB parton distributions.
21568 XX=XG
21569 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21570 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21571 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21572 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
21573 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
21574 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
21575 SXP(3)=SXP(3)+WTSTP*XPGP*STR
21576 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
21577 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
21578 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
21579 ENDIF
21580 150 CONTINUE
21581 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
21582 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
21583 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
21584
21585C...Put convolution into output arrays.
21586 FCONV=AEMP*(-XL)
21587 XPEL(0)=FCONV*SXP(0)
21588 DO 160 KFL=1,6
21589 XPEL(KFL)=FCONV*SXP(KFL)
21590 XPEL(-KFL)=XPEL(KFL)
21591 160 CONTINUE
21592 ENDIF
21593
21594 RETURN
21595 END
21596
21597C*********************************************************************
21598
21599*$ CREATE PYPDGA.FOR
21600*COPY PYPDGA
21601C...PYPDGA
21602C...Gives photon parton distribution.
21603
21604 SUBROUTINE PYPDGA(X,Q2,XPGA)
21605
21606C...Double precision and integer declarations.
21607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21608 INTEGER PYK,PYCHGE,PYCOMP
21609C...Commonblocks.
21610 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21611 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21612 COMMON/PYINT1/MINT(400),VINT(400)
21613 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
21614C...Local arrays.
21615 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
21616 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
21617 &DGCS(4,3),DGDS(4,3),DGES(4,3)
21618
21619C...The following data lines are coefficients needed in the
21620C...Drees and Grassie photon parton distribution parametrization.
21621 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
21622 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
21623 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
21624 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
21625 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
21626 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
21627 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
21628 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
21629 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
21630 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
21631 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
21632 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
21633 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
21634 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
21635 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
21636 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
21637 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
21638 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
21639 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
21640 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
21641 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
21642 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
21643 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
21644 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
21645 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
21646 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
21647
21648C...Photon parton distribution from Drees and Grassie.
21649C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
21650 DO 100 KFL=-6,6
21651 XPGA(KFL)=0D0
21652 100 CONTINUE
21653 VINT(231)=1D0
21654 IF(MSTP(57).LE.0) THEN
21655 T=LOG(1D0/0.16D0)
21656 ELSE
21657 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
21658 ENDIF
21659 X1=1D0-X
21660 NF=3
21661 IF(Q2.GT.25D0) NF=4
21662 IF(Q2.GT.300D0) NF=5
21663 NFE=NF-2
21664 AEM=PARU(101)
21665
21666C...Evaluate gluon content.
21667 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
21668 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
21669 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
21670 XPGL=DGA*X**DGB*X1**DGC
21671
21672C...Evaluate up- and down-type quark content.
21673 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
21674 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
21675 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
21676 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
21677 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
21678 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21679 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
21680 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
21681 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
21682 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
21683 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
21684 DGF=9D0
21685 IF(NF.EQ.4) DGF=10D0
21686 IF(NF.EQ.5) DGF=55D0/6D0
21687 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21688 IF(NF.LE.3) THEN
21689 XPQU=(XPQS+9D0*XPQN)/6D0
21690 XPQD=(XPQS-4.5D0*XPQN)/6D0
21691 ELSEIF(NF.EQ.4) THEN
21692 XPQU=(XPQS+6D0*XPQN)/8D0
21693 XPQD=(XPQS-6D0*XPQN)/8D0
21694 ELSE
21695 XPQU=(XPQS+7.5D0*XPQN)/10D0
21696 XPQD=(XPQS-5D0*XPQN)/10D0
21697 ENDIF
21698
21699C...Put into output arrays.
21700 XPGA(0)=AEM*XPGL
21701 XPGA(1)=AEM*XPQD
21702 XPGA(2)=AEM*XPQU
21703 XPGA(3)=AEM*XPQD
21704 IF(NF.GE.4) XPGA(4)=AEM*XPQU
21705 IF(NF.GE.5) XPGA(5)=AEM*XPQD
21706 DO 110 KFL=1,6
21707 XPGA(-KFL)=XPGA(KFL)
21708 110 CONTINUE
21709
21710 RETURN
21711 END
21712
21713C*********************************************************************
21714
21715*$ CREATE PYGGAM.FOR
21716*COPY PYGGAM
21717C...PYGGAM
21718C...Constructs the F2 and parton distributions of the photon
21719C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
21720C...For F2, c and b are included by the Bethe-Heitler formula;
21721C...in the 'MSbar' scheme additionally a Cgamma term is added.
21722C...Contains the SaS sets 1D, 1M, 2D and 2M.
21723C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21724
21725 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
21726
21727C...Double precision and integer declarations.
21728 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21729 INTEGER PYK,PYCHGE,PYCOMP
21730C...Commonblocks.
21731 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
21732 &XPDIR(-6:6)
21733 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
21734 SAVE /PYINT8/,/PYINT9/
21735C...Local arrays.
21736 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
21737C...Charm and bottom masses (low to compensate for J/psi etc.).
21738 DATA PMC/1.3D0/, PMB/4.6D0/
21739C...alpha_em and alpha_em/(2*pi).
21740 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
21741C...Lambda value for 4 flavours.
21742 DATA ALAM/0.20D0/
21743C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
21744 DATA FRACU/0.8D0/
21745C...VMD couplings f_V**2/(4*pi).
21746 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
21747C...Masses for rho (=omega) and phi.
21748 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
21749C...Number of points in integration for IP2=1.
21750 DATA NSTEP/100/
21751
21752C...Reset output.
21753 F2GM=0D0
21754 DO 100 KFL=-6,6
21755 XPDFGM(KFL)=0D0
21756 XPVMD(KFL)=0D0
21757 XPANL(KFL)=0D0
21758 XPANH(KFL)=0D0
21759 XPBEH(KFL)=0D0
21760 XPDIR(KFL)=0D0
21761 VXPVMD(KFL)=0D0
21762 VXPANL(KFL)=0D0
21763 VXPANH(KFL)=0D0
21764 VXPDGM(KFL)=0D0
21765 100 CONTINUE
21766
21767C...Set Q0 cut-off parameter as function of set used.
21768 IF(ISET.LE.2) THEN
21769 Q0=0.6D0
21770 ELSE
21771 Q0=2D0
21772 ENDIF
21773 Q02=Q0**2
21774
21775C...Scale choice for off-shell photon; common factors.
21776 Q2A=Q2
21777 FACNOR=1D0
21778 IF(IP2.EQ.1) THEN
21779 P2MX=P2+Q02
21780 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21781 FACNOR=LOG(Q2/Q02)/NSTEP
21782 ELSEIF(IP2.EQ.2) THEN
21783 P2MX=MAX(P2,Q02)
21784 ELSEIF(IP2.EQ.3) THEN
21785 P2MX=P2+Q02
21786 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21787 ELSEIF(IP2.EQ.4) THEN
21788 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21789 & ((Q2+P2)*(Q02+P2)))
21790 ELSEIF(IP2.EQ.5) THEN
21791 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21792 & ((Q2+P2)*(Q02+P2)))
21793 P2MX=Q0*SQRT(P2MXA)
21794 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
21795 ELSEIF(IP2.EQ.6) THEN
21796 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21797 & ((Q2+P2)*(Q02+P2)))
21798 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21799 ELSE
21800 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21801 & ((Q2+P2)*(Q02+P2)))
21802 P2MX=Q0*SQRT(P2MXA)
21803 P2MXB=P2MX
21804 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21805 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
21806 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
21807 ENDIF
21808
21809C...Call VMD parametrization for d quark and use to give rho, omega,
21810C...phi. Note dipole dampening for off-shell photon.
21811 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21812 XFVAL=VXPGA(1)
21813 XPGA(1)=XPGA(2)
21814 XPGA(-1)=XPGA(-2)
21815 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
21816 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
21817 DO 110 KFL=-5,5
21818 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
21819 110 CONTINUE
21820 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
21821 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
21822 XPVMD(3)=XPVMD(3)+FACS*XFVAL
21823 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
21824 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
21825 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
21826 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
21827 VXPVMD(2)=FRACU*FACUD*XFVAL
21828 VXPVMD(3)=FACS*XFVAL
21829 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
21830 VXPVMD(-2)=FRACU*FACUD*XFVAL
21831 VXPVMD(-3)=FACS*XFVAL
21832
21833 IF(IP2.NE.1) THEN
21834C...Anomalous parametrizations for different strategies
21835C...for off-shell photons; except full integration.
21836
21837C...Call anomalous parametrization for d + u + s.
21838 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21839 DO 120 KFL=-5,5
21840 XPANL(KFL)=FACNOR*XPGA(KFL)
21841 VXPANL(KFL)=FACNOR*VXPGA(KFL)
21842 120 CONTINUE
21843
21844C...Call anomalous parametrization for c and b.
21845 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21846 DO 130 KFL=-5,5
21847 XPANH(KFL)=FACNOR*XPGA(KFL)
21848 VXPANH(KFL)=FACNOR*VXPGA(KFL)
21849 130 CONTINUE
21850 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21851 DO 140 KFL=-5,5
21852 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
21853 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
21854 140 CONTINUE
21855
21856 ELSE
21857C...Special option: loop over flavours and integrate over k2.
21858 DO 170 KF=1,5
21859 DO 160 ISTEP=1,NSTEP
21860 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
21861 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
21862 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
21863 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
21864 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
21865 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
21866 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
21867 DO 150 KFL=-5,5
21868 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
21869 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
21870 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
21871 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
21872 150 CONTINUE
21873 160 CONTINUE
21874 170 CONTINUE
21875 ENDIF
21876
21877C...Call Bethe-Heitler term expression for charm and bottom.
21878 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
21879 XPBEH(4)=XPBH
21880 XPBEH(-4)=XPBH
21881 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
21882 XPBEH(5)=XPBH
21883 XPBEH(-5)=XPBH
21884
21885C...For MSbar subtraction call C^gamma term expression for d, u, s.
21886 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
21887 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
21888 DO 180 KFL=-5,5
21889 XPDIR(KFL)=XPGA(KFL)
21890 180 CONTINUE
21891 ENDIF
21892
21893C...Store result in output array.
21894 DO 190 KFL=-5,5
21895 CHSQ=1D0/9D0
21896 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
21897 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
21898 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
21899 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
21900 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
21901 190 CONTINUE
21902
21903 RETURN
21904 END
21905
21906C*********************************************************************
21907
21908*$ CREATE PYGVMD.FOR
21909*COPY PYGVMD
21910C...PYGVMD
21911C...Evaluates the VMD parton distributions of a photon,
21912C...evolved homogeneously from an initial scale P2 to Q2.
21913C...Does not include dipole suppression factor.
21914C...ISET is parton distribution set, see above;
21915C...additionally ISET=0 is used for the evolution of an anomalous photon
21916C...which branched at a scale P2 and then evolved homogeneously to Q2.
21917C...ALAM is the 4-flavour Lambda, which is automatically converted
21918C...to 3- and 5-flavour equivalents as needed.
21919C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21920
21921 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
21922
21923C...Double precision and integer declarations.
21924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21925 INTEGER PYK,PYCHGE,PYCOMP
21926C...Local arrays and data.
21927 DIMENSION XPGA(-6:6), VXPGA(-6:6)
21928 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
21929
21930C...Reset output.
21931 DO 100 KFL=-6,6
21932 XPGA(KFL)=0D0
21933 VXPGA(KFL)=0D0
21934 100 CONTINUE
21935 KFA=IABS(KF)
21936
21937C...Calculate Lambda; protect against unphysical Q2 and P2 input.
21938 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
21939 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
21940 P2EFF=MAX(P2,1.2D0*ALAM3**2)
21941 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
21942 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
21943 Q2EFF=MAX(Q2,P2EFF)
21944
21945C...Find number of flavours at lower and upper scale.
21946 NFP=4
21947 IF(P2EFF.LT.PMC**2) NFP=3
21948 IF(P2EFF.GT.PMB**2) NFP=5
21949 NFQ=4
21950 IF(Q2EFF.LT.PMC**2) NFQ=3
21951 IF(Q2EFF.GT.PMB**2) NFQ=5
21952
21953C...Find s as sum of 3-, 4- and 5-flavour parts.
21954 S=0D0
21955 IF(NFP.EQ.3) THEN
21956 Q2DIV=PMC**2
21957 IF(NFQ.EQ.3) Q2DIV=Q2EFF
21958 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
21959 ENDIF
21960 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
21961 P2DIV=P2EFF
21962 IF(NFP.EQ.3) P2DIV=PMC**2
21963 Q2DIV=Q2EFF
21964 IF(NFQ.EQ.5) Q2DIV=PMB**2
21965 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
21966 ENDIF
21967 IF(NFQ.EQ.5) THEN
21968 P2DIV=PMB**2
21969 IF(NFP.EQ.5) P2DIV=P2EFF
21970 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
21971 ENDIF
21972
21973C...Calculate frequent combinations of x and s.
21974 X1=1D0-X
21975 XL=-LOG(X)
21976 S2=S**2
21977 S3=S**3
21978 S4=S**4
21979
21980C...Evaluate homogeneous anomalous parton distributions below or
21981C...above threshold.
21982 IF(ISET.EQ.0) THEN
21983 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21984 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21985 XVAL = X * 1.5D0 * (X**2+X1**2)
21986 XGLU = 0D0
21987 XSEA = 0D0
21988 ELSE
21989 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
21990 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
21991 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
21992 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
21993 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
21994 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
21995 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
21996 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
21997 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
21998 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
21999 & (2D0*X-1D0)*X*XL**2)
22000 ENDIF
22001
22002C...Evaluate set 1D parton distributions below or above threshold.
22003 ELSEIF(ISET.EQ.1) THEN
22004 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22005 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22006 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
22007 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
22008 XSEA = 0.100D0 * X1**3.76D0
22009 ELSE
22010 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
22011 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
22012 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
22013 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
22014 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
22015 & X**0.40D0 * X1**(1.76D0+3D0*S)
22016 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
22017 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
22018 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
22019 XSEA0 = 0.100D0 * X1**3.76D0
22020 ENDIF
22021
22022C...Evaluate set 1M parton distributions below or above threshold.
22023 ELSEIF(ISET.EQ.2) THEN
22024 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22025 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22026 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
22027 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
22028 XSEA = 0D0
22029 ELSE
22030 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
22031 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
22032 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
22033 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
22034 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
22035 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
22036 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
22037 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
22038 & XL**(2.8D0*S)
22039 XSEA0 = 0D0
22040 ENDIF
22041
22042C...Evaluate set 2D parton distributions below or above threshold.
22043 ELSEIF(ISET.EQ.3) THEN
22044 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22045 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22046 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
22047 XGLU = 1.925D0 * X1**2
22048 XSEA = 0.242D0 * X1**4
22049 ELSE
22050 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
22051 & X**(0.46D0+0.25D0*S) *
22052 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
22053 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
22054 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
22055 & EXP(-18.67D0*S) *
22056 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
22057 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
22058 & XL**(9.3D0*S/(1D0+1.7D0*S))
22059 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
22060 & (1D0-0.607D0*S+21.95D0*S2) *
22061 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
22062 XSEA0 = 0.242D0 * X1**4
22063 ENDIF
22064
22065C...Evaluate set 2M parton distributions below or above threshold.
22066 ELSEIF(ISET.EQ.4) THEN
22067 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22068 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22069 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
22070 XGLU = 1.808D0 * X1**2
22071 XSEA = 0.209D0 * X1**4
22072 ELSE
22073 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
22074 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
22075 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
22076 & XL**(5.15D0*S/(1D0+2D0*S)) +
22077 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
22078 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
22079 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
22080 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
22081 & XL**(10.9D0*S/(1D0+2.5D0*S))
22082 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
22083 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
22084 & X1**(4D0+S) * XL**(0.45D0*S)
22085 XSEA0 = 0.209D0 * X1**4
22086 ENDIF
22087 ENDIF
22088
22089C...Threshold factors for c and b sea.
22090 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22091 XCHM=0D0
22092 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22093 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22094 IF(ISET.EQ.0) THEN
22095 XCHM=XSEA*(1D0-(SCH/SLL)**2)
22096 ELSE
22097 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
22098 ENDIF
22099 ENDIF
22100 XBOT=0D0
22101 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22102 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22103 IF(ISET.EQ.0) THEN
22104 XBOT=XSEA*(1D0-(SBT/SLL)**2)
22105 ELSE
22106 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
22107 ENDIF
22108 ENDIF
22109
22110C...Fill parton distributions.
22111 XPGA(0)=XGLU
22112 XPGA(1)=XSEA
22113 XPGA(2)=XSEA
22114 XPGA(3)=XSEA
22115 XPGA(4)=XCHM
22116 XPGA(5)=XBOT
22117 XPGA(KFA)=XPGA(KFA)+XVAL
22118 DO 110 KFL=1,5
22119 XPGA(-KFL)=XPGA(KFL)
22120 110 CONTINUE
22121 VXPGA(KFA)=XVAL
22122 VXPGA(-KFA)=XVAL
22123
22124 RETURN
22125 END
22126
22127C*********************************************************************
22128
22129*$ CREATE PYGANO.FOR
22130*COPY PYGANO
22131C...PYGANO
22132C...Evaluates the parton distributions of the anomalous photon,
22133C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
22134C...KF=0 gives the sum over (up to) 5 flavours,
22135C...KF<0 limits to flavours up to abs(KF),
22136C...KF>0 is for flavour KF only.
22137C...ALAM is the 4-flavour Lambda, which is automatically converted
22138C...to 3- and 5-flavour equivalents as needed.
22139C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22140
22141 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
22142
22143C...Double precision and integer declarations.
22144 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22145 INTEGER PYK,PYCHGE,PYCOMP
22146C...Local arrays and data.
22147 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
22148 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
22149
22150C...Reset output.
22151 DO 100 KFL=-6,6
22152 XPGA(KFL)=0D0
22153 VXPGA(KFL)=0D0
22154 100 CONTINUE
22155 IF(Q2.LE.P2) RETURN
22156 KFA=IABS(KF)
22157
22158C...Calculate Lambda; protect against unphysical Q2 and P2 input.
22159 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
22160 ALAMSQ(4)=ALAM**2
22161 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
22162 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
22163 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
22164 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
22165 Q2EFF=MAX(Q2,P2EFF)
22166 XL=-LOG(X)
22167
22168C...Find number of flavours at lower and upper scale.
22169 NFP=4
22170 IF(P2EFF.LT.PMC**2) NFP=3
22171 IF(P2EFF.GT.PMB**2) NFP=5
22172 NFQ=4
22173 IF(Q2EFF.LT.PMC**2) NFQ=3
22174 IF(Q2EFF.GT.PMB**2) NFQ=5
22175
22176C...Define range of flavour loop.
22177 IF(KF.EQ.0) THEN
22178 KFLMN=1
22179 KFLMX=5
22180 ELSEIF(KF.LT.0) THEN
22181 KFLMN=1
22182 KFLMX=KFA
22183 ELSE
22184 KFLMN=KFA
22185 KFLMX=KFA
22186 ENDIF
22187
22188C...Loop over flavours the photon can branch into.
22189 DO 110 KFL=KFLMN,KFLMX
22190
22191C...Light flavours: calculate t range and (approximate) s range.
22192 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
22193 TDIFF=LOG(Q2EFF/P2EFF)
22194 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22195 & LOG(P2EFF/ALAMSQ(NFQ)))
22196 IF(NFQ.GT.NFP) THEN
22197 Q2DIV=PMB**2
22198 IF(NFQ.EQ.4) Q2DIV=PMC**2
22199 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22200 & LOG(P2EFF/ALAMSQ(NFQ)))
22201 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22202 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22203 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22204 ENDIF
22205 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
22206 Q2DIV=PMC**2
22207 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
22208 & LOG(P2EFF/ALAMSQ(4)))
22209 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
22210 & LOG(P2EFF/ALAMSQ(3)))
22211 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
22212 ENDIF
22213
22214C...u and s quark do not need a separate treatment when d has been done.
22215 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
22216
22217C...Charm: as above, but only include range above c threshold.
22218 ELSEIF(KFL.EQ.4) THEN
22219 IF(Q2.LE.PMC**2) GOTO 110
22220 P2EFF=MAX(P2EFF,PMC**2)
22221 Q2EFF=MAX(Q2EFF,P2EFF)
22222 TDIFF=LOG(Q2EFF/P2EFF)
22223 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22224 & LOG(P2EFF/ALAMSQ(NFQ)))
22225 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
22226 Q2DIV=PMB**2
22227 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22228 & LOG(P2EFF/ALAMSQ(NFQ)))
22229 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22230 & LOG(P2EFF/ALAMSQ(NFQ-1)))
22231 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22232 ENDIF
22233
22234C...Bottom: as above, but only include range above b threshold.
22235 ELSEIF(KFL.EQ.5) THEN
22236 IF(Q2.LE.PMB**2) GOTO 110
22237 P2EFF=MAX(P2EFF,PMB**2)
22238 Q2EFF=MAX(Q2,P2EFF)
22239 TDIFF=LOG(Q2EFF/P2EFF)
22240 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22241 & LOG(P2EFF/ALAMSQ(NFQ)))
22242 ENDIF
22243
22244C...Evaluate flavour-dependent prefactor (charge^2 etc.).
22245 CHSQ=1D0/9D0
22246 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
22247 FAC=AEM2PI*2D0*CHSQ*TDIFF
22248
22249C...Evaluate parton distributions (normalized to unit momentum sum).
22250 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
22251 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
22252 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
22253 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
22254 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
22255 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
22256 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
22257 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
22258 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
22259 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
22260 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
22261 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
22262
22263C...Threshold factors for c and b sea.
22264 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22265 XCHM=0D0
22266 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22267 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22268 XCHM=XSEA*(1D0-(SCH/SLL)**3)
22269 ENDIF
22270 XBOT=0D0
22271 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22272 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22273 XBOT=XSEA*(1D0-(SBT/SLL)**3)
22274 ENDIF
22275 ENDIF
22276
22277C...Add contribution of each valence flavour.
22278 XPGA(0)=XPGA(0)+FAC*XGLU
22279 XPGA(1)=XPGA(1)+FAC*XSEA
22280 XPGA(2)=XPGA(2)+FAC*XSEA
22281 XPGA(3)=XPGA(3)+FAC*XSEA
22282 XPGA(4)=XPGA(4)+FAC*XCHM
22283 XPGA(5)=XPGA(5)+FAC*XBOT
22284 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
22285 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
22286 110 CONTINUE
22287 DO 120 KFL=1,5
22288 XPGA(-KFL)=XPGA(KFL)
22289 VXPGA(-KFL)=VXPGA(KFL)
22290 120 CONTINUE
22291
22292 RETURN
22293 END
22294
22295C*********************************************************************
22296
22297*$ CREATE PYGBEH.FOR
22298*COPY PYGBEH
22299C...PYGBEH
22300C...Evaluates the Bethe-Heitler cross section for heavy flavour
22301C...production.
22302C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22303
22304 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
22305C...Double precision and integer declarations.
22306 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22307 INTEGER PYK,PYCHGE,PYCOMP
22308
22309C...Local data.
22310 DATA AEM2PI/0.0011614D0/
22311
22312C...Reset output.
22313 XPBH=0D0
22314 SIGBH=0D0
22315
22316C...Check kinematics limits.
22317 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
22318 W2=Q2*(1D0-X)/X-P2
22319 BETA2=1D0-4D0*PM2/W2
22320 IF(BETA2.LT.1D-10) RETURN
22321 BETA=SQRT(BETA2)
22322 RMQ=4D0*PM2/Q2
22323
22324C...Simple case: P2 = 0.
22325 IF(P2.LT.1D-4) THEN
22326 IF(BETA.LT.0.99D0) THEN
22327 XBL=LOG((1D0+BETA)/(1D0-BETA))
22328 ELSE
22329 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
22330 ENDIF
22331 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
22332 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
22333
22334C...Complicated case: P2 > 0, based on approximation of
22335C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
22336 ELSE
22337 RPQ=1D0-4D0*X**2*P2/Q2
22338 IF(RPQ.GT.1D-10) THEN
22339 RPBE=SQRT(RPQ*BETA2)
22340 IF(RPBE.LT.0.99D0) THEN
22341 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
22342 XBI=2D0*RPBE/(1D0-RPBE**2)
22343 ELSE
22344 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
22345 XBL=LOG((1D0+RPBE)**2/RPBESN)
22346 XBI=2D0*RPBE/RPBESN
22347 ENDIF
22348 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
22349 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
22350 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
22351 ENDIF
22352 ENDIF
22353
22354C...Multiply by charge-squared etc. to get parton distribution.
22355 CHSQ=1D0/9D0
22356 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
22357 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
22358
22359 RETURN
22360 END
22361
22362C*********************************************************************
22363
22364*$ CREATE PYGDIR.FOR
22365*COPY PYGDIR
22366C...PYGDIR
22367C...Evaluates the direct contribution, i.e. the C^gamma term,
22368C...as needed in MSbar parametrizations.
22369C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22370
22371 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
22372
22373C...Double precision and integer declarations.
22374 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22375 INTEGER PYK,PYCHGE,PYCOMP
22376C...Local array and data.
22377 DIMENSION XPGA(-6:6)
22378 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
22379
22380C...Reset output.
22381 DO 100 KFL=-6,6
22382 XPGA(KFL)=0D0
22383 100 CONTINUE
22384
22385C...Evaluate common x-dependent expression.
22386 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
22387 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
22388
22389C...d, u, s part by simple charge factor.
22390 XPGA(1)=(1D0/9D0)*CGAM
22391 XPGA(2)=(4D0/9D0)*CGAM
22392 XPGA(3)=(1D0/9D0)*CGAM
22393
22394C...Also fill for antiquarks.
22395 DO 110 KF=1,5
22396 XPGA(-KF)=XPGA(KF)
22397 110 CONTINUE
22398
22399 RETURN
22400 END
22401
22402C*********************************************************************
22403
22404*$ CREATE PYPDPI.FOR
22405*COPY PYPDPI
22406C...PYPDPI
22407C...Gives pi+ parton distribution according to two different
22408C...parametrizations.
22409
22410 SUBROUTINE PYPDPI(X,Q2,XPPI)
22411
22412C...Double precision and integer declarations.
22413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22414 INTEGER PYK,PYCHGE,PYCOMP
22415C...Commonblocks.
22416 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22417 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22418 COMMON/PYINT1/MINT(400),VINT(400)
22419 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
22420C...Local arrays.
22421 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
22422
22423C...The following data lines are coefficients needed in the
22424C...Owens pion parton distribution parametrizations, see below.
22425C...Expansion coefficients for up and down valence quark distributions.
22426 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
22427 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22428 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22429 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22430 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
22431 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22432 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
22433 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
22434C...Expansion coefficients for gluon distribution.
22435 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
22436 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
22437 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
22438 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
22439 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
22440 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
22441 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
22442 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
22443C...Expansion coefficients for (up+down+strange) quark sea distribution.
22444 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
22445 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22446 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
22447 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
22448 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
22449 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
22450 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
22451 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
22452C...Expansion coefficients for charm quark sea distribution.
22453 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
22454 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
22455 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
22456 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
22457 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
22458 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
22459 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
22460 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
22461
22462C...Euler's beta function, requires ordinary Gamma function
22463 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
22464
22465C...Reset output array.
22466 DO 100 KFL=-6,6
22467 XPPI(KFL)=0D0
22468 100 CONTINUE
22469
22470 IF(MSTP(53).LE.2) THEN
22471C...Pion parton distributions from Owens.
22472C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
22473
22474C...Determine set, Lambda and s expansion variable.
22475 NSET=MSTP(53)
22476 IF(NSET.EQ.1) ALAM=0.2D0
22477 IF(NSET.EQ.2) ALAM=0.4D0
22478 VINT(231)=4D0
22479 IF(MSTP(57).LE.0) THEN
22480 SD=0D0
22481 ELSE
22482 Q2IN=MIN(2D3,MAX(4D0,Q2))
22483 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
22484 ENDIF
22485
22486C...Calculate parton distributions.
22487 DO 120 KFL=1,4
22488 DO 110 IS=1,5
22489 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
22490 & COW(3,IS,KFL,NSET)*SD**2
22491 110 CONTINUE
22492 IF(KFL.EQ.1) THEN
22493 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
22494 ELSE
22495 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
22496 & TS(5)*X**2)
22497 ENDIF
22498 120 CONTINUE
22499
22500C...Put into output array.
22501 XPPI(0)=XQ(2)
22502 XPPI(1)=XQ(3)/6D0
22503 XPPI(2)=XQ(1)+XQ(3)/6D0
22504 XPPI(3)=XQ(3)/6D0
22505 XPPI(4)=XQ(4)
22506 XPPI(-1)=XQ(1)+XQ(3)/6D0
22507 XPPI(-2)=XQ(3)/6D0
22508 XPPI(-3)=XQ(3)/6D0
22509 XPPI(-4)=XQ(4)
22510
22511C...Leading order pion parton distributions from Gluck, Reya and Vogt.
22512C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
22513C...10^-5 < x < 1.
22514 ELSE
22515
22516C...Determine s expansion variable and some x expressions.
22517 VINT(231)=0.25D0
22518 IF(MSTP(57).LE.0) THEN
22519 SD=0D0
22520 ELSE
22521 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
22522 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
22523 ENDIF
22524 SD2=SD**2
22525 XL=-LOG(X)
22526 XS=SQRT(X)
22527
22528C...Evaluate valence, gluon and sea distributions.
22529 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
22530 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
22531 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
22532 & SD-0.175D0*SD2)+
22533 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
22534 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
22535 & XL)))*
22536 & (1D0-X)**(0.390D0+1.053D0*SD)
22537 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
22538 & X)**3.359D0*
22539 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
22540 & XL))/
22541 & XL**(2.538D0-0.763D0*SD)
22542 IF(SD.LE.0.888D0) THEN
22543 XFCHM=0D0
22544 ELSE
22545 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
22546 & 0.771D0*SD)*
22547 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
22548 & XL))
22549 ENDIF
22550 IF(SD.LE.1.351D0) THEN
22551 XFBOT=0D0
22552 ELSE
22553 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
22554 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
22555 & XL))
22556 ENDIF
22557
22558C...Put into output array.
22559 XPPI(0)=XFGLU
22560 XPPI(1)=XFSEA
22561 XPPI(2)=XFSEA
22562 XPPI(3)=XFSEA
22563 XPPI(4)=XFCHM
22564 XPPI(5)=XFBOT
22565 DO 130 KFL=1,5
22566 XPPI(-KFL)=XPPI(KFL)
22567 130 CONTINUE
22568 XPPI(2)=XPPI(2)+XFVAL
22569 XPPI(-1)=XPPI(-1)+XFVAL
22570 ENDIF
22571
22572 RETURN
22573 END
22574
22575C*********************************************************************
22576
22577*$ CREATE PYPDPR.FOR
22578*COPY PYPDPR
22579C...PYPDPR
22580C...Gives proton parton distributions according to a few different
22581C...parametrizations.
22582
22583 SUBROUTINE PYPDPR(X,Q2,XPPR)
22584
22585C...Double precision and integer declarations.
22586 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22587 INTEGER PYK,PYCHGE,PYCOMP
22588C...Commonblocks.
22589 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22590 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22591 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22592 COMMON/PYINT1/MINT(400),VINT(400)
22593 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
22594C...Arrays and data.
22595 DIMENSION XPPR(-6:6),Q2MIN(6)
22596 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0/
22597
22598C...Reset output array.
22599 DO 100 KFL=-6,6
22600 XPPR(KFL)=0D0
22601 100 CONTINUE
22602
22603C...Common preliminaries.
22604 NSET=MAX(1,MIN(6,MSTP(51)))
22605 VINT(231)=Q2MIN(NSET)
22606 IF(MSTP(57).EQ.0) THEN
22607 Q2L=Q2MIN(NSET)
22608 ELSE
22609 Q2L=MAX(Q2MIN(NSET),Q2)
22610 ENDIF
22611
22612 IF(NSET.GE.1.AND.NSET.LE.3) THEN
22613C...Interface to the CTEQ 3 parton distributions.
22614 QRT=SQRT(MAX(1D0,Q2L))
22615
22616C...Loop over flavours.
22617 DO 110 I=-6,6
22618 IF(I.LE.0) THEN
22619 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
22620 ELSEIF(I.LE.2) THEN
22621 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
22622 ELSE
22623 XPPR(I)=XPPR(-I)
22624 ENDIF
22625 110 CONTINUE
22626
22627 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
22628C...Interface to the GRV 94 distributions.
22629 IF(NSET.EQ.4) THEN
22630 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22631 ELSEIF(NSET.EQ.5) THEN
22632 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22633 ELSE
22634 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22635 ENDIF
22636
22637C...Put into output array.
22638 XPPR(0)=GL
22639 XPPR(-1)=0.5D0*(UDB+DEL)
22640 XPPR(-2)=0.5D0*(UDB-DEL)
22641 XPPR(-3)=SB
22642 XPPR(-4)=CHM
22643 XPPR(-5)=BOT
22644 XPPR(1)=DV+XPPR(-1)
22645 XPPR(2)=UV+XPPR(-2)
22646 XPPR(3)=SB
22647 XPPR(4)=CHM
22648 XPPR(5)=BOT
22649
22650 ENDIF
22651
22652 RETURN
22653 END
22654
22655C*********************************************************************
22656
22657*$ CREATE PYCTEQ.FOR
22658*COPY PYCTEQ
22659C...PYCTEQ
22660C...Gives the CTEQ 3 parton distribution function sets in
22661C...parametrized form, of October 24, 1994.
22662C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
22663C...J. Qiu, W.K. Tung and H. Weerts.
22664
22665 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
22666
22667C...Double precision declaration.
22668 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22669
22670C...Data on Lambda values of fits, minimum Q and quark masses.
22671 DIMENSION ALM(3), QMS(4:6)
22672 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
22673 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
22674
22675C....Check flavour thresholds. Set up QI for SB.
22676 IP = IABS(IPRT)
22677 IF(IP .GE. 4) THEN
22678 IF(Q .LE. QMS(IP)) THEN
22679 PYCTEQ = 0D0
22680 RETURN
22681 ENDIF
22682 QI = QMS(IP)
22683 ELSE
22684 QI = QMN
22685 ENDIF
22686
22687C...Use "standard lambda" of parametrization program for expansion.
22688 ALAM = ALM (ISET)
22689 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
22690 SB = LOG (SBL)
22691 SB2 = SB*SB
22692 SB3 = SB2*SB
22693
22694C...Expansion for CTEQ3L.
22695 IF(ISET .EQ. 1) THEN
22696 IF(IPRT .EQ. 2) THEN
22697 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
22698 & 0.3171D+00*SB3)
22699 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
22700 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
22701 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
22702 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
22703 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
22704 ELSEIF(IPRT .EQ. 1) THEN
22705 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
22706 & 0.7728D+00*SB3)
22707 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
22708 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
22709 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
22710 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
22711 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
22712 ELSEIF(IPRT .EQ. 0) THEN
22713 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
22714 & 0.5343D+00*SB3)
22715 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
22716 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
22717 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
22718 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
22719 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
22720 ELSEIF(IPRT .EQ. -1) THEN
22721 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
22722 & 0.2031D+01*SB3)
22723 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
22724 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
22725 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
22726 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
22727 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
22728 ELSEIF(IPRT .EQ. -2) THEN
22729 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
22730 & 0.9872D-01*SB3)
22731 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
22732 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
22733 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
22734 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
22735 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
22736 ELSEIF(IPRT .EQ. -3) THEN
22737 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
22738 & 0.8390D+00*SB3)
22739 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
22740 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
22741 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
22742 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
22743 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
22744 ELSEIF(IPRT .EQ. -4) THEN
22745 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
22746 & 0.1651D-01*SB2)
22747 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
22748 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
22749 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
22750 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
22751 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
22752 ELSEIF(IPRT .EQ. -5) THEN
22753 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
22754 & 0.3702D+01*SB2)
22755 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
22756 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
22757 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
22758 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
22759 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
22760 ELSEIF(IPRT .EQ. -6) THEN
22761 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
22762 & 0.6943D+00*SB2)
22763 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
22764 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
22765 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
22766 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
22767 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
22768 ENDIF
22769
22770C...Expansion for CTEQ3M.
22771 ELSEIF(ISET .EQ. 2) THEN
22772 IF(IPRT .EQ. 2) THEN
22773 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
22774 & 0.2935D+00*SB3)
22775 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
22776 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
22777 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
22778 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
22779 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
22780 ELSEIF(IPRT .EQ. 1) THEN
22781 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
22782 & 0.4305D-01*SB3)
22783 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
22784 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
22785 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
22786 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
22787 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
22788 ELSEIF(IPRT .EQ. 0) THEN
22789 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
22790 & 0.1037D-01*SB3)
22791 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
22792 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
22793 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
22794 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
22795 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
22796 ELSEIF(IPRT .EQ. -1) THEN
22797 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
22798 & 0.1602D+01*SB3)
22799 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
22800 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
22801 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
22802 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
22803 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
22804 ELSEIF(IPRT .EQ. -2) THEN
22805 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
22806 & 0.2496D+00*SB3)
22807 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
22808 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
22809 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
22810 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
22811 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
22812 ELSEIF(IPRT .EQ. -3) THEN
22813 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
22814 & 0.1936D+01*SB3)
22815 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
22816 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
22817 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
22818 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
22819 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
22820 ELSEIF(IPRT .EQ. -4) THEN
22821 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
22822 & 0.5348D+00*SB2)
22823 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
22824 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
22825 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
22826 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
22827 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
22828 ELSEIF(IPRT .EQ. -5) THEN
22829 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
22830 & 0.1569D+01*SB2)
22831 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
22832 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
22833 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
22834 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
22835 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
22836 ELSEIF(IPRT .EQ. -6) THEN
22837 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
22838 & 0.8838D+01*SB2)
22839 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
22840 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
22841 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
22842 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
22843 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
22844 ENDIF
22845
22846C...Expansion for CTEQ3D.
22847 ELSEIF(ISET .EQ. 3) THEN
22848 IF(IPRT .EQ. 2) THEN
22849 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
22850 & 0.2902D+00*SB3)
22851 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
22852 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
22853 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
22854 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
22855 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
22856 ELSEIF(IPRT .EQ. 1) THEN
22857 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
22858 & 0.7257D+00*SB3)
22859 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
22860 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
22861 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
22862 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
22863 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
22864 ELSEIF(IPRT .EQ. 0) THEN
22865 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
22866 & 0.2734D-04*SB3)
22867 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
22868 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
22869 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
22870 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
22871 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
22872 ELSEIF(IPRT .EQ. -1) THEN
22873 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
22874 & 0.1671D+01*SB3)
22875 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
22876 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
22877 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
22878 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
22879 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
22880 ELSEIF(IPRT .EQ. -2) THEN
22881 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
22882 & 0.2223D+00*SB3)
22883 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
22884 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
22885 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
22886 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
22887 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
22888 ELSEIF(IPRT .EQ. -3) THEN
22889 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
22890 & 0.1937D+01*SB3)
22891 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
22892 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
22893 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
22894 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
22895 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
22896 ELSEIF(IPRT .EQ. -4) THEN
22897 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
22898 & 0.5137D+00*SB2)
22899 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
22900 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
22901 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
22902 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
22903 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
22904 ELSEIF(IPRT .EQ. -5) THEN
22905 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
22906 & 0.2143D+01*SB2)
22907 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
22908 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
22909 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
22910 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
22911 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
22912 ELSEIF(IPRT .EQ. -6) THEN
22913 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
22914 & 0.9998D+01*SB2)
22915 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
22916 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
22917 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
22918 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
22919 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
22920 ENDIF
22921 ENDIF
22922
22923C...Calculation of x * f(x, Q).
22924 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
22925 & *(LOG(1D0+1D0/X))**A5 )
22926
22927 RETURN
22928 END
22929
22930C*********************************************************************
22931
22932*$ CREATE PYGRVL.FOR
22933*COPY PYGRVL
22934C...PYGRVL
22935C...Gives the GRV 94 L (leading order) parton distribution function set
22936C...in parametrized form.
22937C...Authors: M. Glueck, E. Reya and A. Vogt.
22938
22939 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22940
22941C...Double precision declaration.
22942 IMPLICIT DOUBLE PRECISION (A - Z)
22943
22944C...Common expressions.
22945 MU2 = 0.23D0
22946 LAM2 = 0.2322D0 * 0.2322D0
22947 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
22948 DS = SQRT (S)
22949 S2 = S * S
22950 S3 = S2 * S
22951
22952C...uv :
22953 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
22954 AKU = 0.590D0 - 0.024D0 * S
22955 BKU = 0.131D0 + 0.063D0 * S
22956 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
22957 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
22958 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
22959 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
22960 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
22961
22962C...dv :
22963 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
22964 AKD = 0.376D0
22965 BKD = 0.486D0 + 0.062D0 * S
22966 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
22967 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
22968 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
22969 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
22970 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
22971
22972C...del :
22973 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
22974 AKE = 0.409D0 - 0.005D0 * S
22975 BKE = 0.799D0 + 0.071D0 * S
22976 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
22977 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
22978 CE = 0.0D0
22979 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
22980 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
22981
22982C...udb :
22983 ALX = 1.451D0
22984 BEX = 0.271D0
22985 AKX = 0.410D0 - 0.232D0 * S
22986 BKX = 0.534D0 - 0.457D0 * S
22987 AGX = 0.890D0 - 0.140D0 * S
22988 BGX = -0.981D0
22989 CX = 0.320D0 + 0.683D0 * S
22990 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
22991 EX = 4.119D0 + 1.713D0 * S
22992 ESX = 0.682D0 + 2.978D0 * S
22993 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
22994 & DX, EX, ESX)
22995
22996C...sb :
22997 STS = 0D0
22998 ALS = 0.914D0
22999 BES = 0.577D0
23000 AKS = 1.798D0 - 0.596D0 * S
23001 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
23002 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
23003 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
23004 EST = 3.981D0 + 1.638D0 * S
23005 ESS = 6.402D0
23006 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23007
23008C...cb :
23009 STC = 0.888D0
23010 ALC = 1.01D0
23011 BEC = 0.37D0
23012 AKC = 0D0
23013 AC = 0D0
23014 BC = 4.24D0 - 0.804D0 * S
23015 DCT = 3.46D0 - 1.076D0 * S
23016 ECT = 4.61D0 + 1.49D0 * S
23017 ESC = 2.555D0 + 1.961D0 * S
23018 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23019
23020C...bb :
23021 STB = 1.351D0
23022 ALB = 1.00D0
23023 BEB = 0.51D0
23024 AKB = 0D0
23025 AB = 0D0
23026 BB = 1.848D0
23027 DBT = 2.929D0 + 1.396D0 * S
23028 EBT = 4.71D0 + 1.514D0 * S
23029 ESB = 4.02D0 + 1.239D0 * S
23030 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23031
23032C...gl :
23033 ALG = 0.524D0
23034 BEG = 1.088D0
23035 AKG = 1.742D0 - 0.930D0 * S
23036 BKG = - 0.399D0 * S2
23037 AG = 7.486D0 - 2.185D0 * S
23038 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
23039 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
23040 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
23041 EG = 0.807D0 + 2.005D0 * S
23042 ESG = 3.841D0 + 0.316D0 * S
23043 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
23044 & DG, EG, ESG)
23045
23046 RETURN
23047 END
23048
23049C*********************************************************************
23050
23051*$ CREATE PYGRVM.FOR
23052*COPY PYGRVM
23053C...PYGRVM
23054C...Gives the GRV 94 M (MSbar) parton distribution function set
23055C...in parametrized form.
23056C...Authors: M. Glueck, E. Reya and A. Vogt.
23057
23058 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23059
23060C...Double precision declaration.
23061 IMPLICIT DOUBLE PRECISION (A - Z)
23062
23063C...Common expressions.
23064 MU2 = 0.34D0
23065 LAM2 = 0.248D0 * 0.248D0
23066 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23067 DS = SQRT (S)
23068 S2 = S * S
23069 S3 = S2 * S
23070
23071C...uv :
23072 NU = 1.304D0 + 0.863D0 * S
23073 AKU = 0.558D0 - 0.020D0 * S
23074 BKU = 0.183D0 * S
23075 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
23076 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
23077 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
23078 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
23079 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23080
23081C...dv :
23082 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
23083 AKD = 0.270D0 - 0.019D0 * S
23084 BKD = 0.260D0
23085 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
23086 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
23087 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
23088 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
23089 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23090
23091C...del :
23092 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
23093 AKE = 0.409D0 - 0.007D0 * S
23094 BKE = 0.782D0 + 0.082D0 * S
23095 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
23096 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
23097 CE = 0.0D0
23098 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
23099 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23100
23101C...udb :
23102 ALX = 0.877D0
23103 BEX = 0.561D0
23104 AKX = 0.275D0
23105 BKX = 0.0D0
23106 AGX = 0.997D0
23107 BGX = 3.210D0 - 1.866D0 * S
23108 CX = 7.300D0
23109 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
23110 EX = 3.077D0 + 1.446D0 * S
23111 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
23112 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23113 & DX, EX, ESX)
23114
23115C...sb :
23116 STS = 0D0
23117 ALS = 0.756D0
23118 BES = 0.216D0
23119 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
23120 AS = -4.329D0 + 1.131D0 * S
23121 BS = 9.568D0 - 1.744D0 * S
23122 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
23123 EST = 3.031D0 + 1.639D0 * S
23124 ESS = 5.837D0 + 0.815D0 * S
23125 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23126
23127C...cb :
23128 STC = 0.820D0
23129 ALC = 0.98D0
23130 BEC = 0D0
23131 AKC = -0.625D0 - 0.523D0 * S
23132 AC = 0D0
23133 BC = 1.896D0 + 1.616D0 * S
23134 DCT = 4.12D0 + 0.683D0 * S
23135 ECT = 4.36D0 + 1.328D0 * S
23136 ESC = 0.677D0 + 0.679D0 * S
23137 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23138
23139C...bb :
23140 STB = 1.297D0
23141 ALB = 0.99D0
23142 BEB = 0D0
23143 AKB = - 0.193D0 * S
23144 AB = 0D0
23145 BB = 0D0
23146 DBT = 3.447D0 + 0.927D0 * S
23147 EBT = 4.68D0 + 1.259D0 * S
23148 ESB = 1.892D0 + 2.199D0 * S
23149 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23150
23151C...gl :
23152 ALG = 1.014D0
23153 BEG = 1.738D0
23154 AKG = 1.724D0 + 0.157D0 * S
23155 BKG = 0.800D0 + 1.016D0 * S
23156 AG = 7.517D0 - 2.547D0 * S
23157 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
23158 CG = 4.039D0 + 1.491D0 * S
23159 DG = 3.404D0 + 0.830D0 * S
23160 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
23161 ESG = 3.256D0 - 0.436D0 * S
23162 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23163
23164 RETURN
23165 END
23166
23167C*********************************************************************
23168
23169*$ CREATE PYGRVD.FOR
23170*COPY PYGRVD
23171C...PYGRVD
23172C...Gives the GRV 94 D (DIS) parton distribution function set
23173C...in parametrized form.
23174C...Authors: M. Glueck, E. Reya and A. Vogt.
23175
23176 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23177
23178C...Double precision declaration.
23179 IMPLICIT DOUBLE PRECISION (A - Z)
23180
23181C...Common expressions.
23182 MU2 = 0.34D0
23183 LAM2 = 0.248D0 * 0.248D0
23184 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23185 DS = SQRT (S)
23186 S2 = S * S
23187 S3 = S2 * S
23188
23189C...uv :
23190 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
23191 AKU = 0.563D0 - 0.025D0 * S
23192 BKU = 0.054D0 + 0.154D0 * S
23193 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
23194 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
23195 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
23196 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
23197 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23198
23199C...dv :
23200 ND = 0.156D0 - 0.017D0 * S
23201 AKD = 0.299D0 - 0.022D0 * S
23202 BKD = 0.259D0 - 0.015D0 * S
23203 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
23204 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
23205 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
23206 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
23207 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23208
23209C...del :
23210 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
23211 AKE = 0.419D0 - 0.013D0 * S
23212 BKE = 1.064D0 - 0.038D0 * S
23213 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
23214 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
23215 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
23216 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
23217 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23218
23219C...udb :
23220 ALX = 1.215D0
23221 BEX = 0.466D0
23222 AKX = 0.326D0 + 0.150D0 * S
23223 BKX = 0.956D0 + 0.405D0 * S
23224 AGX = 0.272D0
23225 BGX = 3.794D0 - 2.359D0 * DS
23226 CX = 2.014D0
23227 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
23228 EX = 3.049D0 + 1.597D0 * S
23229 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
23230 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23231 & DX, EX, ESX)
23232
23233C...sb :
23234 STS = 0D0
23235 ALS = 0.175D0
23236 BES = 0.344D0
23237 AKS = 1.415D0 - 0.641D0 * DS
23238 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
23239 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
23240 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
23241 EST = 4.546D0 + 0.372D0 * S2
23242 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
23243 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23244
23245C...cb :
23246 STC = 0.820D0
23247 ALC = 0.98D0
23248 BEC = 0D0
23249 AKC = -0.625D0 - 0.523D0 * S
23250 AC = 0D0
23251 BC = 1.896D0 + 1.616D0 * S
23252 DCT = 4.12D0 + 0.683D0 * S
23253 ECT = 4.36D0 + 1.328D0 * S
23254 ESC = 0.677D0 + 0.679D0 * S
23255 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23256
23257C...bb :
23258 STB = 1.297D0
23259 ALB = 0.99D0
23260 BEB = 0D0
23261 AKB = - 0.193D0 * S
23262 AB = 0D0
23263 BB = 0D0
23264 DBT = 3.447D0 + 0.927D0 * S
23265 EBT = 4.68D0 + 1.259D0 * S
23266 ESB = 1.892D0 + 2.199D0 * S
23267 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23268
23269C...gl :
23270 ALG = 1.258D0
23271 BEG = 1.846D0
23272 AKG = 2.423D0
23273 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
23274 AG = 25.09D0 - 7.935D0 * S
23275 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
23276 CG = 590.3D0 - 173.8D0 * S
23277 DG = 5.196D0 + 1.857D0 * S
23278 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
23279 ESG = 3.232D0 - 0.542D0 * S
23280 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23281
23282 RETURN
23283 END
23284
23285C*********************************************************************
23286
23287*$ CREATE PYGRVV.FOR
23288*COPY PYGRVV
23289C...PYGRVV
23290C...Auxiliary for the GRV 94 parton distribution functions
23291C...for u and d valence and d-u sea.
23292C...Authors: M. Glueck, E. Reya and A. Vogt.
23293
23294 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
23295
23296C...Double precision declaration.
23297 IMPLICIT DOUBLE PRECISION (A - Z)
23298
23299C...Evaluation.
23300 DX = SQRT (X)
23301 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
23302 & (1D0- X)**D
23303
23304 RETURN
23305 END
23306
23307C*********************************************************************
23308
23309*$ CREATE PYGRVW.FOR
23310*COPY PYGRVW
23311C...PYGRVW
23312C...Auxiliary for the GRV 94 parton distribution functions
23313C...for d+u sea and gluon.
23314C...Authors: M. Glueck, E. Reya and A. Vogt.
23315
23316 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
23317
23318C...Double precision declaration.
23319 IMPLICIT DOUBLE PRECISION (A - Z)
23320
23321C...Evaluation.
23322 LX = LOG (1D0/X)
23323 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
23324 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
23325
23326 RETURN
23327 END
23328
23329C*********************************************************************
23330
23331*$ CREATE PYGRVS.FOR
23332*COPY PYGRVS
23333C...PYGRVS
23334C...Auxiliary for the GRV 94 parton distribution functions
23335C...for s, c and b sea.
23336C...Authors: M. Glueck, E. Reya and A. Vogt.
23337
23338 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
23339
23340C...Double precision declaration.
23341 IMPLICIT DOUBLE PRECISION (A - Z)
23342
23343C...Evaluation.
23344 IF(S.LE.STH) THEN
23345 PYGRVS = 0D0
23346 ELSE
23347 DX = SQRT (X)
23348 LX = LOG (1D0/X)
23349 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
23350 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
23351 ENDIF
23352
23353 RETURN
23354 END
23355
23356C*********************************************************************
23357
23358*$ CREATE PYHFTH.FOR
23359*COPY PYHFTH
23360C...PYHFTH
23361C...Gives threshold attractive/repulsive factor for heavy flavour
23362C...production.
23363
23364 FUNCTION PYHFTH(SH,SQM,FRATT)
23365
23366C...Double precision and integer declarations.
23367 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23368 INTEGER PYK,PYCHGE,PYCOMP
23369C...Commonblocks.
23370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23371 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23372 COMMON/PYINT1/MINT(400),VINT(400)
23373 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23374
23375C...Value for alpha_strong.
23376 IF(MSTP(35).LE.1) THEN
23377 ALSSG=PARP(35)
23378 ELSE
23379 MST115=MSTU(115)
23380 MSTU(115)=MSTP(36)
23381 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
23382 & PARP(36)**2)))
23383 ALSSG=PYALPS(Q2BN)
23384 MSTU(115)=MST115
23385 ENDIF
23386
23387C...Evaluate attractive and repulsive factors.
23388 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23389 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
23390 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23391 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
23392 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
23393 VINT(138)=PYHFTH
23394
23395 RETURN
23396 END
23397
23398C*********************************************************************
23399
23400*$ CREATE PYSPLI.FOR
23401*COPY PYSPLI
23402C...PYSPLI
23403C...Splits a hadron remnant into two (partons or hadron + parton)
23404C...in case it is more complicated than just a quark or a diquark.
23405
23406 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
23407
23408C...Double precision and integer declarations.
23409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23410 INTEGER PYK,PYCHGE,PYCOMP
23411C...Commonblocks.
23412 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23413 COMMON/PYINT1/MINT(400),VINT(400)
23414 SAVE /PYPARS/,/PYINT1/
23415C...Local array.
23416 DIMENSION KFL(3)
23417
23418C...Preliminaries. Parton composition.
23419 KFA=IABS(KF)
23420 KFS=ISIGN(1,KF)
23421 KFL(1)=MOD(KFA/1000,10)
23422 KFL(2)=MOD(KFA/100,10)
23423 KFL(3)=MOD(KFA/10,10)
23424 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
23425 KFL(2)=INT(1.5D0+PYR(0))
23426 IF(MINT(105).EQ.333) KFL(2)=3
23427 IF(MINT(105).EQ.443) KFL(2)=4
23428 KFL(3)=KFL(2)
23429 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
23430 KFL(2)=2
23431 KFL(3)=2
23432 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
23433 KFL(2)=1
23434 KFL(3)=1
23435 ENDIF
23436 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
23437 KFLR=KFLIN*KFS
23438 ELSE
23439 KFLR=KFLIN
23440 ENDIF
23441 KFLCH=0
23442
23443C...Subdivide lepton.
23444 IF(KFA.GE.11.AND.KFA.LE.18) THEN
23445 IF(KFLR.EQ.KFA) THEN
23446 KFLSP=KFS*22
23447 ELSEIF(KFLR.EQ.22) THEN
23448 KFLSP=KFA
23449 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
23450 KFLSP=KFA+1
23451 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
23452 KFLSP=KFA-1
23453 ELSEIF(KFLR.EQ.21) THEN
23454 KFLSP=KFA
23455 KFLCH=KFS*21
23456 ELSE
23457 KFLSP=KFA
23458 KFLCH=-KFLR
23459 ENDIF
23460
23461C...Subdivide photon.
23462 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
23463 IF(KFLR.NE.21) THEN
23464 KFLSP=-KFLR
23465 ELSE
23466 RAGR=0.75D0*PYR(0)
23467 KFLSP=1
23468 IF(RAGR.GT.0.125D0) KFLSP=2
23469 IF(RAGR.GT.0.625D0) KFLSP=3
23470 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
23471 KFLCH=-KFLSP
23472 ENDIF
23473
23474C...Subdivide Reggeon or Pomeron.
23475 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
23476 IF(KFLIN.EQ.21) THEN
23477 KFLSP=KFS*21
23478 ELSE
23479 KFLSP=-KFLIN
23480 ENDIF
23481
23482C...Subdivide meson.
23483 ELSEIF(KFL(1).EQ.0) THEN
23484 KFL(2)=KFL(2)*(-1)**KFL(2)
23485 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
23486 IF(KFLR.EQ.KFL(2)) THEN
23487 KFLSP=KFL(3)
23488 ELSEIF(KFLR.EQ.KFL(3)) THEN
23489 KFLSP=KFL(2)
23490 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
23491 KFLSP=KFL(2)
23492 KFLCH=KFL(3)
23493 ELSEIF(KFLR.EQ.21) THEN
23494 KFLSP=KFL(3)
23495 KFLCH=KFL(2)
23496 ELSEIF(KFLR*KFL(2).GT.0) THEN
23497 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
23498 KFLSP=KFL(3)
23499 ELSE
23500 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
23501 KFLSP=KFL(2)
23502 ENDIF
23503
23504C...Subdivide baryon.
23505 ELSE
23506 NAGR=0
23507 DO 100 J=1,3
23508 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
23509 100 CONTINUE
23510 IF(NAGR.GE.1) THEN
23511 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
23512 IAGR=0
23513 DO 110 J=1,3
23514 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
23515 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
23516 110 CONTINUE
23517 ELSE
23518 IAGR=1.00001D0+2.99998D0*PYR(0)
23519 ENDIF
23520 ID1=1
23521 IF(IAGR.EQ.1) ID1=2
23522 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
23523 ID2=6-IAGR-ID1
23524 KSP=3
23525 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
23526 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
23527 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
23528 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
23529 ELSEIF(MOD(KFA,10).EQ.2) THEN
23530 IF(IAGR.EQ.1) KSP=1
23531 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
23532 ENDIF
23533 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
23534 IF(KFLR.EQ.21) THEN
23535 KFLCH=KFL(IAGR)
23536 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
23537 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
23538 ELSEIF(NAGR.EQ.0) THEN
23539 CALL PYKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
23540 KFLSP=KFL(IAGR)
23541 ENDIF
23542 ENDIF
23543
23544C...Add on correct sign for result.
23545 KFLCH=KFLCH*KFS
23546 KFLSP=KFLSP*KFS
23547
23548 RETURN
23549 END
23550
23551C*********************************************************************
23552
23553*$ CREATE PYGAMM.FOR
23554*COPY PYGAMM
23555C...PYGAMM
23556C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
23557C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
23558C...(Dover, 1965) 6.1.36.
23559
23560 FUNCTION PYGAMM(X)
23561
23562C...Double precision and integer declarations.
23563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23564 INTEGER PYK,PYCHGE,PYCOMP
23565C...Local array and data.
23566 DIMENSION B(8)
23567 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
23568 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
23569
23570 NX=INT(X)
23571 DX=X-NX
23572
23573 PYGAMM=1D0
23574 DXP=1D0
23575 DO 100 I=1,8
23576 DXP=DXP*DX
23577 PYGAMM=PYGAMM+B(I)*DXP
23578 100 CONTINUE
23579 IF(X.LT.1D0) THEN
23580 PYGAMM=PYGAMM/X
23581 ELSE
23582 DO 110 IX=1,NX-1
23583 PYGAMM=(X-IX)*PYGAMM
23584 110 CONTINUE
23585 ENDIF
23586
23587 RETURN
23588 END
23589
23590C***********************************************************************
23591
23592*$ CREATE PYWAUX.FOR
23593*COPY PYWAUX
23594C...PYWAUX
23595C...Calculates real and imaginary parts of the auxiliary functions W1
23596C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
23597C...der Bij, Nucl. Phys. B297 (1988) 221.
23598
23599 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
23600
23601C...Double precision and integer declarations.
23602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23603 INTEGER PYK,PYCHGE,PYCOMP
23604C...Commonblocks.
23605 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23606 SAVE /PYDAT1/
23607
23608 ASINH(X)=LOG(X+SQRT(X**2+1D0))
23609 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
23610
23611 IF(EPS.LT.0D0) THEN
23612 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
23613 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
23614 WIM=0D0
23615 ELSEIF(EPS.LT.1D0) THEN
23616 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
23617 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
23618 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
23619 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
23620 ELSE
23621 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
23622 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
23623 WIM=0D0
23624 ENDIF
23625
23626 RETURN
23627 END
23628
23629C***********************************************************************
23630
23631*$ CREATE PYI3AU.FOR
23632*COPY PYI3AU
23633C...PYI3AU
23634C...Calculates real and imaginary parts of the auxiliary function I3;
23635C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
23636C...Nucl. Phys. B297 (1988) 221.
23637
23638 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
23639
23640C...Double precision and integer declarations.
23641 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23642 INTEGER PYK,PYCHGE,PYCOMP
23643C...Commonblocks.
23644 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23645 SAVE /PYDAT1/
23646
23647 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
23648 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
23649
23650 IF(EPS.LT.0D0) THEN
23651 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23652 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23653 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23654 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
23655 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
23656 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
23657 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
23658 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
23659 & EPS))
23660 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23661 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23662 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23663 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
23664 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
23665 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
23666 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
23667 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
23668 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23669 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23670 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23671 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
23672 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
23673 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
23674 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
23675 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
23676 ELSE
23677 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23678 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
23679 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
23680 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
23681 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
23682 ENDIF
23683 F3IM=0D0
23684 ELSEIF(EPS.LT.1D0) THEN
23685 IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23686 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23687 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23688 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
23689 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
23690 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23691 & (0.25D0*(RAT+1D0)*EPS))
23692 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23693 & (0.25D0*(RAT+1D0)*EPS))
23694 ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23695 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23696 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23697 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
23698 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
23699 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
23700 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23701 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23702 ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23703 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23704 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23705 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
23706 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
23707 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
23708 & (1D0+0.25D0*RAT*EPS-GA))
23709 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
23710 & (1D0+0.25D0*RAT*EPS-GA))
23711 ELSE
23712 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23713 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
23714 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
23715 & LOG((GA+BE-1D0)/(BE-GA))
23716 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
23717 ENDIF
23718 ELSE
23719 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
23720 RCTHE=RSQ*(1D0-2D0*BE/EPS)
23721 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
23722 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
23723 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
23724 R=SQRT(RSQ)
23725 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
23726 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
23727 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
23728 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
23729 & (PHI-THE)*(PHI+THE-PARU(1))
23730 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
23731 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
23732 ENDIF
23733
23734 Y3RE=2D0/(2D0*BE-1D0)*F3RE
23735 Y3IM=2D0/(2D0*BE-1D0)*F3IM
23736
23737 RETURN
23738 END
23739
23740C***********************************************************************
23741
23742*$ CREATE PYSPEN.FOR
23743*COPY PYSPEN
23744C...PYSPEN
23745C...Calculates real and imaginary part of Spence function; see
23746C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
23747
23748 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
23749
23750C...Double precision and integer declarations.
23751 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23752 INTEGER PYK,PYCHGE,PYCOMP
23753C...Commonblocks.
23754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23755 SAVE /PYDAT1/
23756C...Local array and data.
23757 DIMENSION B(0:14)
23758 DATA B/
23759 &1.000000D+00, -5.000000D-01, 1.666667D-01,
23760 &0.000000D+00, -3.333333D-02, 0.000000D+00,
23761 &2.380952D-02, 0.000000D+00, -3.333333D-02,
23762 &0.000000D+00, 7.575757D-02, 0.000000D+00,
23763 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
23764
23765 XRE=XREIN
23766 XIM=XIMIN
23767 IF(ABS(1D0-XRE).LT.1.D-6.AND.ABS(XIM).LT.1.D-6) THEN
23768 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
23769 IF(IREIM.EQ.2) PYSPEN=0D0
23770 RETURN
23771 ENDIF
23772
23773 XMOD=SQRT(XRE**2+XIM**2)
23774 IF(XMOD.LT.1.D-6) THEN
23775 IF(IREIM.EQ.1) PYSPEN=0D0
23776 IF(IREIM.EQ.2) PYSPEN=0D0
23777 RETURN
23778 ENDIF
23779
23780 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23781 SP0RE=0D0
23782 SP0IM=0D0
23783 SGN=1D0
23784 IF(XMOD.GT.1D0) THEN
23785 ALGXRE=LOG(XMOD)
23786 ALGXIM=XARG-SIGN(PARU(1),XARG)
23787 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
23788 SP0IM=-ALGXRE*ALGXIM
23789 SGN=-1D0
23790 XMOD=1D0/XMOD
23791 XARG=-XARG
23792 XRE=XMOD*COS(XARG)
23793 XIM=XMOD*SIN(XARG)
23794 ENDIF
23795 IF(XRE.GT.0.5D0) THEN
23796 ALGXRE=LOG(XMOD)
23797 ALGXIM=XARG
23798 XRE=1D0-XRE
23799 XIM=-XIM
23800 XMOD=SQRT(XRE**2+XIM**2)
23801 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23802 ALGYRE=LOG(XMOD)
23803 ALGYIM=XARG
23804 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
23805 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
23806 SGN=-SGN
23807 ENDIF
23808
23809 XRE=1D0-XRE
23810 XIM=-XIM
23811 XMOD=SQRT(XRE**2+XIM**2)
23812 XARG=SIGN(ACOS(XRE/XMOD),XIM)
23813 ZRE=-LOG(XMOD)
23814 ZIM=-XARG
23815
23816 SPRE=0D0
23817 SPIM=0D0
23818 SAVERE=1D0
23819 SAVEIM=0D0
23820 DO 100 I=0,14
23821 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
23822 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
23823 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
23824 SAVERE=TERMRE
23825 SAVEIM=TERMIM
23826 SPRE=SPRE+B(I)*TERMRE
23827 SPIM=SPIM+B(I)*TERMIM
23828 100 CONTINUE
23829
23830 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
23831 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
23832
23833 RETURN
23834 END
23835
23836C***********************************************************************
23837
23838*$ CREATE PYQQBH.FOR
23839*COPY PYQQBH
23840C...PYQQBH
23841C...Calculates the matrix element for the processes
23842C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
23843C...REDUCE output and part of the rest courtesy Z. Kunszt, see
23844C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
23845
23846 SUBROUTINE PYQQBH(WTQQBH)
23847
23848C...Double precision and integer declarations.
23849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23850 INTEGER PYK,PYCHGE,PYCOMP
23851C...Commonblocks.
23852 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23853 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23854 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23855 COMMON/PYINT1/MINT(400),VINT(400)
23856 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23857 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
23858C...Local arrays and function.
23859 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
23860 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
23861 &PP(I,3)*PP(J,3)
23862
23863C...Mass parameters.
23864 WTQQBH=0D0
23865 ISUB=MINT(1)
23866 SHPR=SQRT(VINT(26))*VINT(1)
23867 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
23868 PH=SQRT(VINT(21))*VINT(1)
23869 SPQ=PQ**2
23870 SPH=PH**2
23871
23872C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
23873 DO 100 I=1,2
23874 PT=SQRT(MAX(0D0,VINT(197+5*I)))
23875 PP(I,1)=PT*COS(VINT(198+5*I))
23876 PP(I,2)=PT*SIN(VINT(198+5*I))
23877 100 CONTINUE
23878 PP(3,1)=-PP(1,1)-PP(2,1)
23879 PP(3,2)=-PP(1,2)-PP(2,2)
23880 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
23881 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
23882 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
23883 PMT3=SQRT(PMS3)
23884 PP(3,3)=PMT3*SINH(VINT(211))
23885 PP(3,4)=PMT3*COSH(VINT(211))
23886 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
23887 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
23888 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
23889 PP(2,3)=-PP(1,3)-PP(3,3)
23890 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
23891 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
23892
23893C...Set up incoming kinematics and derived momentum combinations.
23894 DO 110 I=4,5
23895 PP(I,1)=0D0
23896 PP(I,2)=0D0
23897 PP(I,3)=-0.5D0*SHPR*(-1)**I
23898 PP(I,4)=-0.5D0*SHPR
23899 110 CONTINUE
23900 DO 120 J=1,4
23901 PP(6,J)=PP(1,J)+PP(2,J)
23902 PP(7,J)=PP(1,J)+PP(3,J)
23903 PP(8,J)=PP(1,J)+PP(4,J)
23904 PP(9,J)=PP(1,J)+PP(5,J)
23905 PP(10,J)=-PP(2,J)-PP(3,J)
23906 PP(11,J)=-PP(2,J)-PP(4,J)
23907 PP(12,J)=-PP(2,J)-PP(5,J)
23908 PP(13,J)=-PP(4,J)-PP(5,J)
23909 120 CONTINUE
23910
23911C...Derived kinematics invariants.
23912 X1=DOT(1,2)
23913 X2=DOT(1,3)
23914 X3=DOT(1,4)
23915 X4=DOT(1,5)
23916 X5=DOT(2,3)
23917 X6=DOT(2,4)
23918 X7=DOT(2,5)
23919 X8=DOT(3,4)
23920 X9=DOT(3,5)
23921 X10=DOT(4,5)
23922
23923C...Propagators.
23924 SS1=DOT(7,7)-SPQ
23925 SS2=DOT(8,8)-SPQ
23926 SS3=DOT(9,9)-SPQ
23927 SS4=DOT(10,10)-SPQ
23928 SS5=DOT(11,11)-SPQ
23929 SS6=DOT(12,12)-SPQ
23930 SS7=DOT(13,13)
23931 DX(1)=SS1*SS6
23932 DX(2)=SS2*SS6
23933 DX(3)=SS2*SS4
23934 DX(4)=SS1*SS5
23935 DX(5)=SS3*SS5
23936 DX(6)=SS3*SS4
23937 DX(7)=SS7*SS1
23938 DX(8)=SS7*SS4
23939
23940C...Define colour coefficients for g + g -> Q + Qbar + H.
23941 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
23942 DO 140 I=1,3
23943 DO 130 J=1,3
23944 CLR(I,J)=16D0/3D0
23945 CLR(I+3,J+3)=16D0/3D0
23946 CLR(I,J+3)=-2D0/3D0
23947 CLR(I+3,J)=-2D0/3D0
23948 130 CONTINUE
23949 140 CONTINUE
23950 DO 160 L=1,2
23951 DO 150 I=1,3
23952 CLR(I,6+L)=-6D0
23953 CLR(I+3,6+L)=6D0
23954 CLR(6+L,I)=-6D0
23955 CLR(6+L,I+3)=6D0
23956 150 CONTINUE
23957 160 CONTINUE
23958 DO 180 K1=1,2
23959 DO 170 K2=1,2
23960 CLR(6+K1,6+K2)=12D0
23961 170 CONTINUE
23962 180 CONTINUE
23963
23964C...Evaluate matrix elements for g + g -> Q + Qbar + H.
23965 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
23966 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
23967 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
23968 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
23969 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
23970 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
23971 & X10)
23972 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
23973 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
23974 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
23975 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
23976 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
23977 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
23978 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
23979 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
23980 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
23981 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
23982 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
23983 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
23984 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
23985 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
23986 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
23987 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
23988 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
23989 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
23990 & X4*X6*X5)
23991 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
23992 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
23993 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
23994 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
23995 & +X4*X9*X5+X4*X5**2)
23996 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
23997 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
23998 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
23999 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
24000 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
24001 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
24002 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
24003 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
24004 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
24005 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
24006 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
24007 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
24008 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
24009 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
24010 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
24011 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
24012 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
24013 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
24014 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
24015 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
24016 & X6)
24017 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
24018 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
24019 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
24020 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
24021 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
24022 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
24023 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
24024 & X5+X4*X6*X5)
24025 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
24026 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
24027 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
24028 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
24029 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
24030 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
24031 & X6**2)
24032 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
24033 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
24034 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
24035 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
24036 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
24037 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
24038 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
24039 & X4*X6*X5)
24040 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
24041 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
24042 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
24043 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
24044 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
24045 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
24046 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
24047 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
24048 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
24049 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
24050 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
24051 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
24052 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
24053 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
24054 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
24055 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
24056 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
24057 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
24058 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
24059 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
24060 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
24061 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
24062 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
24063 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
24064 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
24065 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
24066 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
24067 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
24068 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
24069 & +X3*X8*X5+X3*X5**2)
24070 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
24071 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
24072 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
24073 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
24074 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
24075 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
24076 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
24077 & X5+X4*X6*X5)
24078 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
24079 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
24080 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
24081 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
24082 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
24083 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
24084 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
24085 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
24086 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
24087 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
24088 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
24089 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
24090 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
24091 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
24092 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
24093 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
24094 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
24095 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
24096 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
24097 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
24098 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
24099 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
24100 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
24101 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
24102 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
24103 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
24104 & X10)
24105 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
24106 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
24107 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
24108 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
24109 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
24110 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
24111 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
24112 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
24113 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
24114 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
24115 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
24116 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
24117 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
24118 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
24119 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
24120 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
24121 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
24122 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
24123 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
24124 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
24125 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
24126 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
24127 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
24128 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
24129 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
24130 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
24131 & X7)
24132 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24133 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24134 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
24135 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
24136 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
24137 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
24138 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
24139 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
24140 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
24141 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
24142 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
24143 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24144 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24145 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
24146 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
24147 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
24148 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
24149 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
24150 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
24151 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
24152 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
24153 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
24154 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
24155 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
24156 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
24157 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
24158 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
24159 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
24160 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
24161 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
24162 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
24163 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
24164 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
24165 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
24166 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
24167 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
24168 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
24169 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
24170 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
24171 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
24172 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
24173 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
24174 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
24175 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
24176 & *X6)
24177 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
24178 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
24179 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
24180 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
24181 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
24182 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
24183 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
24184 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
24185 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
24186 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
24187 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
24188 & X8)
24189 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24190 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
24191 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
24192 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24193 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
24194 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
24195 & X9*X5)
24196 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24197 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
24198 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
24199 & X8*X5)
24200 FM(9,10)=0.5D0*(FMXX+FM(9,10))
24201 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24202 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
24203 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
24204
24205C...Repackage matrix elements.
24206 DO 200 I=1,8
24207 DO 190 J=1,8
24208 RM(I,J)=FM(I,J)
24209 190 CONTINUE
24210 200 CONTINUE
24211 RM(7,7)=FM(7,7)-2D0*FM(9,9)
24212 RM(7,8)=FM(7,8)-2D0*FM(9,10)
24213 RM(8,8)=FM(8,8)-2D0*FM(10,10)
24214
24215C...Produce final result: matrix elements * colours * propagators.
24216 DO 220 I=1,8
24217 DO 210 J=I,8
24218 FAC=8D0
24219 IF(I.EQ.J)FAC=4D0
24220 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
24221 210 CONTINUE
24222 220 CONTINUE
24223 WTQQBH=-WTQQBH/256D0
24224
24225 ELSE
24226C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
24227 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
24228 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
24229 & *X6+X8*X7)
24230 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
24231 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
24232 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
24233 & X5)
24234 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
24235 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
24236 & *X9+X4*X8)
24237
24238C...Produce final result: matrix elements * propagators.
24239 A11=A11/DX(7)**2
24240 A12=A12/(DX(7)*DX(8))
24241 A22=A22/DX(8)**2
24242 WTQQBH=-(A11+A22+2D0*A12)/8D0
24243 ENDIF
24244
24245 RETURN
24246 END
24247
24248C*********************************************************************
24249
24250*$ CREATE PYMSIN.FOR
24251*COPY PYMSIN
24252C...PYMSIN
24253C...Initializes supersymmetry: finds sparticle masses and
24254C...branching ratios and stores this information.
24255C...AUTHOR: STEPHEN MRENNA
24256
24257 SUBROUTINE PYMSIN
24258
24259C...Double precision and integer declarations.
24260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24261 INTEGER PYK,PYCHGE,PYCOMP
24262C...Parameter statement to help give large particle numbers.
24263 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24264C...Commonblocks.
24265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24267 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
24268 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24269 COMMON/PYINT4/MWID(500),WIDS(500,5)
24270 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24271 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24272 &SFMIX(16,4)
24273 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
24274 &/PYSSMT/
24275
24276C...Local variables.
24277 INTEGER NSTR
24278 DOUBLE PRECISION ALFA,BETA
24279 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
24280 DOUBLE PRECISION PYALEM
24281 INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
24282 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
24283 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
24284 DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
24285 DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
24286 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
24287 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
24288 DOUBLE PRECISION DELM,XMDIF,BRLIM
24289 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
24290 DOUBLE PRECISION ARG,SGNMU,R,GAM
24291 INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
24292 INTEGER IMSSM,KFHIGG
24293 INTEGER IRPRTY
24294 INTEGER KFSUSY(36)
24295 DATA KFSUSY/
24296 &1000001,2000001,1000002,2000002,1000003,2000003,
24297 &1000004,2000004,1000005,2000005,1000006,2000006,
24298 &1000011,2000011,1000012,2000012,1000013,2000013,
24299 &1000014,2000014,1000015,2000015,1000016,2000016,
24300 &1000021,1000022,1000023,1000025,1000035,1000024,
24301 &1000037,1000039, 25, 35, 36, 37/
24302
24303C...Do nothing if SUSY not requested.
24304 IMSSM=IMSS(1)
24305 IF(IMSSM.EQ.0) RETURN
24306
24307C...First part of routine: set masses and couplings.
24308
24309C...Reset mixing values in sfermion sector to pure left/right.
24310 DO 100 I=1,16
24311 SFMIX(I,1)=1D0
24312 SFMIX(I,4)=1D0
24313 SFMIX(I,2)=0D0
24314 SFMIX(I,3)=0D0
24315 100 CONTINUE
24316
24317C...Common couplings.
24318 TANB=RMSS(5)
24319 BETA=ATAN(TANB)
24320 COSB=COS(BETA)
24321 SINB=TANB*COSB
24322 COS2B=COS(2D0*BETA)
24323 ALFA=RMSS(18)
24324 XMW2=PMAS(24,1)**2
24325 XMZ2=PMAS(23,1)**2
24326 XW=PARU(102)
24327
24328C...Define sparticle masses for a general MSSM simulation.
24329 IF(IMSSM.EQ.1) THEN
24330 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
24331 DO 110 I=1,5,2
24332 KC=PYCOMP(KSUSY1+I)
24333 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
24334 KC=PYCOMP(KSUSY2+I)
24335 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
24336 KC=PYCOMP(KSUSY1+I+1)
24337 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
24338 KC=PYCOMP(KSUSY2+I+1)
24339 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
24340 110 CONTINUE
24341 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
24342 IF(XARG.LT.0D0) THEN
24343 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24344 & ' FROM THE SUM RULE. '
24345 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24346 RETURN
24347 ELSE
24348 XARG=SQRT(XARG)
24349 ENDIF
24350 DO 120 I=11,15,2
24351 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
24352 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
24353 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24354 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24355 120 CONTINUE
24356 IF(IMSS(8).EQ.1) THEN
24357 RMSS(13)=RMSS(6)
24358 RMSS(14)=RMSS(7)
24359 ENDIF
24360
24361C...Alternatively derive masses from SUGRA relations.
24362 ELSEIF(IMSSM.EQ.2) THEN
24363 CALL PYAPPS
24364 ENDIF
24365
24366C...Add in extra D-term contributions.
24367 IF(IMSS(7).EQ.1) THEN
24368 R=0.43D0
24369 DX=RMSS(23)
24370 DY=RMSS(24)
24371 DS=RMSS(25)
24372 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24373 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
24374 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
24375 WRITE(MSTU(11),*) 'C DX = ',DX
24376 WRITE(MSTU(11),*) 'C DY = ',DY
24377 WRITE(MSTU(11),*) 'C DS = ',DS
24378 WRITE(MSTU(11),*) 'C '
24379 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
24380 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
24381 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24382 DQ2=DY/6D0-DX/3D0-DS/3D0
24383 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
24384 DD2=DY/3D0+DX-2D0*DS/3D0
24385 DL2=-DY/2D0+DX-2D0*DS/3D0
24386 DE2=DY-DX/3D0-DS/3D0
24387 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
24388 DHD2=-DY/2D0-2D0*DX/3D0+DS
24389 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
24390 & /ABS(COS2B)
24391 DMA2 = 2D0*DMU2+DHU2+DHD2
24392 DO 130 I=1,5,2
24393 KC=PYCOMP(KSUSY1+I)
24394 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24395 KC=PYCOMP(KSUSY2+I)
24396 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
24397 KC=PYCOMP(KSUSY1+I+1)
24398 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24399 KC=PYCOMP(KSUSY2+I+1)
24400 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
24401 130 CONTINUE
24402 DO 140 I=11,15,2
24403 KC=PYCOMP(KSUSY1+I)
24404 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24405 KC=PYCOMP(KSUSY2+I)
24406 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
24407 KC=PYCOMP(KSUSY1+I+1)
24408 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24409 140 CONTINUE
24410 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
24411 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
24412 STOP
24413 ENDIF
24414 SGNMU=SIGN(1D0,RMSS(4))
24415 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
24416 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
24417 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
24418 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
24419 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
24420 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
24421 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
24422 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
24423 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
24424 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
24425 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
24426 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
24427 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
24428 STOP
24429 ENDIF
24430 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
24431 RMSS(6)=SQRT(RMSS(6)**2+DL2)
24432 RMSS(7)=SQRT(RMSS(7)**2+DE2)
24433 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
24434 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
24435 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
24436 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
24437 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
24438 ENDIF
24439
24440C...Fix the third generation sfermions.
24441 CALL PYTHRG
24442 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
24443 IF(XARG.LT.0D0) THEN
24444 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
24445 & ' THE SUM RULE. '
24446 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24447 RETURN
24448 ELSE
24449 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
24450 ENDIF
24451
24452C...Fix the neutralino--chargino--gluino sector.
24453 CALL PYINOM
24454
24455C...Fix the Higgs sector.
24456 CALL PYHGGM(ALFA)
24457
24458C...Choose the Gunion-Haber convention.
24459 ALFA=-ALFA
24460 RMSS(18)=ALFA
24461
24462C...Print information on mass parameters.
24463 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
24464 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24465 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
24466 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
24467 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
24468 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
24469 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
24470 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
24471 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
24472 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
24473 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24474 ENDIF
24475 IF(IMSS(20).EQ.1) THEN
24476 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24477 WRITE(MSTU(11),*) ' DEBUG MODE '
24478 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
24479 & UMIX(2,1),UMIX(2,2)
24480 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
24481 & VMIX(2,1),VMIX(2,2)
24482 WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
24483 WRITE(MSTU(11),*) ' ALFA = ',ALFA
24484 WRITE(MSTU(11),*) ' BETA = ',BETA
24485 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
24486 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
24487 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24488 ENDIF
24489
24490C...Set up the Higgs couplings - needed here since initialization
24491C...in PYINRE did not yet occur when PYWIDT is called below.
24492 AL=ALFA
24493 BE=BETA
24494 SINA=SIN(AL)
24495 COSA=COS(AL)
24496 COSB=COS(BE)
24497 SINB=TANB*COSB
24498C...tanb (used for H+)
24499 PARU(141)=TANB
24500
24501C...Firstly: h
24502C...Coupling to d-type quarks
24503 PARU(161)=SINA/COSB
24504C...Coupling to u-type quarks
24505 PARU(162)=-COSA/SINB
24506C...Coupling to leptons
24507 PARU(163)=PARU(161)
24508C...Coupling to Z
24509 PARU(164)=SIN(BE-AL)
24510C...Coupling to W
24511 PARU(165)=PARU(164)
24512C...Coupling to H+
24513 PARU(168)=-SIN(BE-AL)-COS(2D0*BE)*SIN(BE+AL)/2D0/(1D0-XW)
24514
24515C...Secondly: H
24516C...Coupling to d-type quarks
24517 PARU(171)=-COSA/COSB
24518C...Coupling to u-type quarks
24519 PARU(172)=-SINA/SINB
24520C...Coupling to leptons
24521 PARU(173)=PARU(171)
24522C...Coupling to Z
24523 PARU(174)=COS(BE-AL)
24524C...Coupling to W
24525 PARU(175)=PARU(174)
24526C...Coupling to h
24527 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
24528C...Coupling to A
24529 PARU(177)=COS(2D0*BE)*COS(BE+AL)
24530C...Coupling to H+
24531 PARU(178)=-COS(BE-AL)+COS(2D0*BE)*COS(BE+AL)/2D0/(1D0-XW)
24532
24533C...Thirdly, A
24534C...Coupling to d-type quarks
24535 PARU(181)=TANB
24536C...Coupling to u-type quarks
24537 PARU(182)=1D0/PARU(181)
24538C...Coupling to leptons
24539 PARU(183)=PARU(181)
24540 PARU(184)=0D0
24541 PARU(185)=0D0
24542C...Coupling to Z h
24543 PARU(186)=COS(BE-AL)
24544C...Coupling to Z H
24545 PARU(187)=SIN(BE-AL)
24546 PARU(188)=0D0
24547 PARU(189)=0D0
24548 PARU(190)=0D0
24549
24550C...Finally: H+
24551C...Coupling to W h
24552 PARU(195)=COS(BE-AL)
24553
24554C...Tell that all Higgs couplings have been set.
24555 MSTP(4)=1
24556
24557C...Second part of routine: set decay modes and branching ratios.
24558
24559C...Allow chi10 -> gravitino + gamma or not.
24560 KC=PYCOMP(KSUSY1+39)
24561 IF( IMSS(11) .NE. 0 ) THEN
24562 PMAS(KC,1)=RMSS(21)/1000000000D0
24563 PMAS(KC,2)=0.0001D0
24564 IRPRTY=0
24565 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
24566 ELSE
24567 PMAS(KC,1)=9999D0
24568 IRPRTY=1
24569 ENDIF
24570
24571C...Loop over sparticle and Higgs species.
24572 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
24573 DO 200 I=1,36
24574 KF=KFSUSY(I)
24575 KC=PYCOMP(KF)
24576 LKNT=0
24577
24578C...Sfermion decays.
24579 IF(I.LE.24) THEN
24580C...First check to see if sneutrino is lighter than chi10.
24581 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
24582 & PMAS(KC,1).LT.PMCHI1) THEN
24583 ELSE
24584 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
24585 ENDIF
24586
24587C...Gluino decays.
24588 ELSEIF(I.EQ.25) THEN
24589 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
24590
24591C...Neutralino decays.
24592 ELSEIF(I.GE.26.AND.I.LE.29) THEN
24593 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
24594C...chi10 stable or chi10 -> gravitino + gamma.
24595 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
24596 PMAS(KC,2)=1D-6
24597 MDCY(KC,1)=0
24598 MWID(KC)=0
24599 ENDIF
24600
24601C...Chargino decays.
24602 ELSEIF(I.GE.30.AND.I.LE.31) THEN
24603 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
24604
24605C...Gravitino is stable.
24606 ELSEIF(I.EQ.32) THEN
24607 MDCY(KC,1)=0
24608 MWID(KC)=0
24609
24610C...Higgs decays.
24611 ELSEIF(I.GE.33.AND.I.LE.36) THEN
24612C...Calculate decays to non-SUSY particles.
24613 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
24614 LKNT=0
24615 DO 150 I1=0,100
24616 XLAM(I1)=0D0
24617 150 CONTINUE
24618 DO 170 I1=1,MDCY(KC,3)
24619 K1=MDCY(KC,2)+I1-1
24620 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
24621 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 170
24622 XLAM(I1)=WDTP(I1)
24623 XLAM(0)=XLAM(0)+XLAM(I1)
24624 DO 160 J1=1,3
24625 IDLAM(I1,J1)=KFDP(K1,J1)
24626 160 CONTINUE
24627 LKNT=LKNT+1
24628 170 CONTINUE
24629C...Add the decays to SUSY particles.
24630 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
24631 ENDIF
24632
24633C...Set stable particles.
24634 IF(LKNT.EQ.0) THEN
24635 MDCY(KC,1)=0
24636 MWID(KC)=0
24637 PMAS(KC,2)=1D-6
24638 PMAS(KC,3)=1D-5
24639 PMAS(KC,4)=0D0
24640
24641C...Store branching ratios in the standard tables.
24642 ELSE
24643 IDC=MDCY(KC,2)+MDCY(KC,3)-1
24644 DELM=1D6
24645 DO 190 IL=1,LKNT
24646 IDCSV=IDC
24647 180 IDC=IDC+1
24648 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
24649 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
24650 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
24651 BRAT(IDC)=XLAM(IL)/XLAM(0)
24652 XMDIF=PMAS(KC,1)
24653 IF(MDME(IDC,1).GE.1) THEN
24654 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
24655 & PMAS(PYCOMP(KFDP(IDC,2)),1)
24656 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
24657 & PMAS(PYCOMP(KFDP(IDC,3)),1)
24658 ENDIF
24659 IF(I.LE.32) THEN
24660 IF(XMDIF.GE.0D0) THEN
24661 DELM=MIN(DELM,XMDIF)
24662 ELSE
24663 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
24664 WRITE(MSTU(11),*) ' KF = ',KF
24665 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
24666 ENDIF
24667 ENDIF
24668 GOTO 190
24669 ELSEIF(IDC.EQ.IDCSV) THEN
24670 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
24671 & 'channel not recognized:'
24672 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
24673 GOTO 190
24674 ELSE
24675 GOTO 180
24676 ENDIF
24677 190 CONTINUE
24678
24679C...Store width, cutoff and lifetime.
24680 PMAS(KC,2)=XLAM(0)
24681 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
24682 PMAS(KC,3)=PMAS(KC,2)*10D0
24683 ELSE
24684 PMAS(KC,3)=0.95D0*DELM
24685 ENDIF
24686 IF(PMAS(KC,2).NE.0D0) THEN
24687 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
24688 ENDIF
24689 ENDIF
24690 200 CONTINUE
24691
24692 RETURN
24693 END
24694
24695C*********************************************************************
24696
24697*$ CREATE PYAPPS.FOR
24698*COPY PYAPPS
24699C...PYAPPS
24700C...Uses approximate analytical formulae to determine the full set of
24701C...MSSM parameters from SUGRA input.
24702C...See M. Drees and S.P. Martin, hep-ph/9504124
24703
24704 SUBROUTINE PYAPPS
24705
24706C...Double precision and integer declarations.
24707 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24708 INTEGER PYK,PYCHGE,PYCOMP
24709C...Parameter statement to help give large particle numbers.
24710 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24711C...Commonblocks.
24712 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24713 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24714 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24715 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
24716
24717 XMT=PMAS(6,1)
24718 XMZ2=PMAS(23,1)**2
24719 XMW2=PMAS(24,1)**2
24720 TANB=RMSS(5)
24721 BETA=ATAN(TANB)
24722 XW=PARU(102)
24723 XMG=RMSS(1)
24724 XMG2=XMG*XMG
24725 XM0=RMSS(8)
24726 XM02=XM0*XM0
24727 AT=-RMSS(16)
24728 RMSS(15)=AT
24729 RMSS(17)=AT
24730 COSB=COS(BETA)
24731 SINB=TANB*COSB
24732
24733 DTERM=XMZ2*COS(2D0*BETA)
24734 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
24735 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
24736 RMSS(6)=XMEL
24737 RMSS(7)=XMER
24738 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
24739 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
24740 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
24741 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
24742 DO 100 I=1,5,2
24743 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
24744 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
24745 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
24746 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
24747 100 CONTINUE
24748 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
24749 IF(XARG.LT.0D0) THEN
24750 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24751 & ' FROM THE SUM RULE. '
24752 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
24753 RETURN
24754 ELSE
24755 XARG=SQRT(XARG)
24756 ENDIF
24757 DO 110 I=11,15,2
24758 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
24759 PMAS(PYCOMP(KSUSY2+I),1)=XMER
24760 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24761 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24762 110 CONTINUE
24763 XMNU=XARG
24764
24765 RMT=PYRNMT(XMT)
24766 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
24767 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
24768 RMB=3D0
24769 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
24770 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
24771 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
24772 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
24773 &SINB)**2)
24774 RMSS(16)=-ATP
24775 XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
24776 XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
24777 XMU=SIGN(SQRT(XMU2),RMSS(4))
24778 RMSS(4)=XMU
24779 RMSS(19)=SQRT(XMA2)
24780 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
24781 IF(ARG.GT.0D0) THEN
24782 RMSS(14)=SQRT(ARG)
24783 ELSE
24784 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
24785 STOP
24786 ENDIF
24787 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
24788 IF(ARG.GT.0D0) THEN
24789 RMSS(13)=SQRT(ARG)
24790 ELSE
24791 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
24792 STOP
24793 ENDIF
24794 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
24795 IF(ARG.GT.0D0) THEN
24796 RMSS(10)=SQRT(ARG)
24797 ELSE
24798 RMSS(10)=-SQRT(-ARG)
24799 ENDIF
24800 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
24801 IF(ARG.GT.0D0) THEN
24802 RMSS(12)=SQRT(ARG)
24803 ELSE
24804 RMSS(12)=-SQRT(-ARG)
24805 ENDIF
24806 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
24807 IF(ARG.GT.0D0) THEN
24808 RMSS(11)=SQRT(ARG)
24809 ELSE
24810 RMSS(11)=-SQRT(-ARG)
24811 ENDIF
24812
24813 RETURN
24814 END
24815
24816C*********************************************************************
24817
24818*$ CREATE PYRNMQ.FOR
24819*COPY PYRNMQ
24820C...PYRNMQ
24821C...Determines the running mass of quarks.
24822
24823 FUNCTION PYRNMQ(ID,DTERM)
24824
24825C...Double precision and integer declarations.
24826 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24827 INTEGER PYK,PYCHGE,PYCOMP
24828C...Commonblock.
24829 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24830 SAVE /PYMSSM/
24831
24832C...Local variables.
24833 DOUBLE PRECISION PI,R
24834 DOUBLE PRECISION TOL
24835 DOUBLE PRECISION CI(3)
24836 EXTERNAL PYALPS
24837 DATA TOL/0.001D0/
24838 DATA PI,R/3.141592654D0,.61803399D0/
24839 DATA CI/0.47D0,0.07D0,0.02D0/
24840
24841 C=1D0-R
24842 CA=CI(ID)
24843 AG=(0.71D0)**2/4D0/PI
24844 AG=RMSS(20)
24845 XM0=RMSS(8)
24846 XMG=RMSS(1)
24847 XM02=XM0*XM0
24848 XMG2=XMG*XMG
24849
24850 AS=PYALPS(XM02+6D0*XMG2)
24851 CG=8D0/9D0*((AS/AG)**2-1D0)
24852 BX=XM02+(CA+CG)*XMG2+DTERM
24853 AX=MIN(50D0**2,0.5D0*BX)
24854 CX=MAX(2000D0**2,2D0*BX)
24855
24856 X0=AX
24857 X3=CX
24858 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24859 X1=BX
24860 X2=BX+C*(CX-BX)
24861 ELSE
24862 X2=BX
24863 X1=BX-C*(BX-AX)
24864 ENDIF
24865 AS1=PYALPS(X1)
24866 CG=8D0/9D0*((AS1/AG)**2-1D0)
24867 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24868 AS2=PYALPS(X2)
24869 CG=8D0/9D0*((AS2/AG)**2-1D0)
24870 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24871 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24872 IF(F2.LT.F1) THEN
24873 X0=X1
24874 X1=X2
24875 X2=R*X1+C*X3
24876 F1=F2
24877 AS2=PYALPS(X2)
24878 CG=8D0/9D0*((AS2/AG)**2-1D0)
24879 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24880 ELSE
24881 X3=X2
24882 X2=X1
24883 X1=R*X2+C*X0
24884 F2=F1
24885 AS1=PYALPS(X1)
24886 CG=8D0/9D0*((AS1/AG)**2-1D0)
24887 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24888 ENDIF
24889 GOTO 100
24890 ENDIF
24891 IF(F1.LT.F2) THEN
24892 PYRNMQ=X1
24893 XMIN=X1
24894 ELSE
24895 PYRNMQ=X2
24896 XMIN=X2
24897 ENDIF
24898
24899 RETURN
24900 END
24901
24902C*********************************************************************
24903
24904*$ CREATE PYRNMT.FOR
24905*COPY PYRNMT
24906C...PYRNMT
24907C...Determines the running mass of the top quark.
24908
24909 FUNCTION PYRNMT(XMT)
24910
24911C...Double precision and integer declarations.
24912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24913 INTEGER PYK,PYCHGE,PYCOMP
24914C...Commonblock.
24915 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24916 SAVE /PYMSSM/
24917
24918C...Local variables.
24919 DOUBLE PRECISION XMT
24920 DOUBLE PRECISION PI,R
24921 DOUBLE PRECISION TOL
24922 EXTERNAL PYALPS
24923 DATA TOL/0.001D0/
24924 DATA PI,R/3.141592654D0,0.61803399D0/
24925
24926 C=1D0-R
24927
24928 BX=XMT
24929 AX=MIN(50D0,BX*0.5D0)
24930 CX=MAX(300D0,2D0*BX)
24931
24932 X0=AX
24933 X3=CX
24934 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24935 X1=BX
24936 X2=BX+C*(CX-BX)
24937 ELSE
24938 X2=BX
24939 X1=BX-C*(BX-AX)
24940 ENDIF
24941 AS1=PYALPS(X1**2)/PI
24942 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24943 AS2=PYALPS(X2**2)/PI
24944 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24945 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24946 IF(F2.LT.F1) THEN
24947 X0=X1
24948 X1=X2
24949 X2=R*X1+C*X3
24950 F1=F2
24951 AS2=PYALPS(X2**2)/PI
24952 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24953 ELSE
24954 X3=X2
24955 X2=X1
24956 X1=R*X2+C*X0
24957 F2=F1
24958 AS1=PYALPS(X1**2)/PI
24959 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24960 ENDIF
24961 GOTO 100
24962 ENDIF
24963 IF(F1.LT.F2) THEN
24964 PYRNMT=X1
24965 XMIN=X1
24966 ELSE
24967 PYRNMT=X2
24968 XMIN=X2
24969 ENDIF
24970
24971 RETURN
24972 END
24973
24974C*********************************************************************
24975
24976*$ CREATE PYTHRG.FOR
24977*COPY PYTHRG
24978C...PYTHRG
24979C...Calculates the mass eigenstates of the third generation sfermions.
24980C...Created: 5-31-96
24981
24982 SUBROUTINE PYTHRG
24983
24984C...Double precision and integer declarations.
24985 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24986 INTEGER PYK,PYCHGE,PYCOMP
24987C...Parameter statement to help give large particle numbers.
24988 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24989C...Commonblocks.
24990 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24991 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24992 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24993 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24994 &SFMIX(16,4)
24995 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
24996
24997C...Local variables.
24998 DOUBLE PRECISION BETA
24999 DOUBLE PRECISION PYRNMT
25000 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
25001 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
25002 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
25003 DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
25004 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
25005 INTEGER IF,I,J,II,JJ,IT,L
25006 LOGICAL DTERM
25007 DATA SMALL/1D-3/
25008 DATA ID1/10,10,13/
25009 DATA ID2/5,6,15/
25010 DATA ID3/15,16,17/
25011 DATA ID4/11,12,14/
25012 DATA DTERM/.TRUE./
25013
25014 XMZ2=PMAS(23,1)**2
25015 XMW2=PMAS(24,1)**2
25016 TANB=RMSS(5)
25017 XMU=-RMSS(4)
25018 BETA=ATAN(TANB)
25019 COS2B=COS(2D0*BETA)
25020
25021C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
25022
25023 IOPT=IMSS(5)
25024 IF(IOPT.EQ.1) THEN
25025 CTT=RMSS(27)
25026 CTT2=CTT**2
25027 STT2=1D0-CTT2
25028 STT=SQRT(STT2)
25029 XM12=RMSS(12)**2
25030 XM22=RMSS(10)**2
25031 XMQL2=CTT2*XM12+STT2*XM22
25032 XMQR2=STT2*XM12+CTT2*XM22
25033 XMFR=PMAS(6,1)
25034 XMF2=PYRNMT(XMFR)**2
25035 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25036 ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
25037 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
25038 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
25039 STT=-STT
25040 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25041 ENDIF
25042 RMSS(16)=ATOP
25043C......SUBTRACT OUT D-TERM AND FERMION MASS
25044 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
25045 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
25046 IF(XMQL2.GE.0D0) THEN
25047 RMSS(10)=SQRT(XMQL2)
25048 ELSE
25049 RMSS(10)=-SQRT(-XMQL2)
25050 ENDIF
25051 IF(XMQR2.GE.0D0) THEN
25052 RMSS(12)=SQRT(XMQR2)
25053 ELSE
25054 RMSS(12)=-SQRT(-XMQR2)
25055 ENDIF
25056C SAME FOR SBOTTOM SQUARK
25057 CTT=RMSS(26)
25058 CTT2=CTT**2
25059 STT2=1D0-CTT2
25060 STT=MAX(SQRT(STT2),1D-6)
25061 XMF=3D00
25062 XMF2=XMF**2
25063 XM12=RMSS(11)**2
25064 XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
25065 IF(ABS(CTT).EQ.1D0) THEN
25066 XM22=XM12
25067 XM12=XMQL2
25068 XMQR2=XM22
25069 ELSEIF(CTT.EQ.0D0) THEN
25070 XM22=XMQL2
25071 XMQR2=XM12
25072 ELSE
25073 XM22=(XMQL2-CTT2*XM12)/STT2
25074 XMQR2=STT2*XM12+CTT2*XM22
25075 ENDIF
25076 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25077 ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
25078 XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
25079 IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
25080 STT=-STT
25081 ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25082 ENDIF
25083 RMSS(15)=ABOT
25084C......SUBTRACT OUT D-TERM AND FERMION MASS
25085 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
25086 IF(XMQR2.GE.0D0) THEN
25087 RMSS(11)=SQRT(XMQR2)
25088 ELSE
25089 RMSS(11)=-SQRT(-XMQR2)
25090 ENDIF
25091 ENDIF
25092
25093 DO 170 L=1,3
25094 AMQL=RMSS(ID1(L))
25095 IF(AMQL.LT.0D0) THEN
25096 XMQL2=-AMQL**2
25097 ELSE
25098 XMQL2=AMQL**2
25099 ENDIF
25100 IF=ID2(L)
25101 XMF=PMAS(IF,1)
25102 IF(L.EQ.1) XMF=3D0
25103 IF(L.EQ.2) XMF=PYRNMT(XMF)
25104 XMF2=XMF**2
25105 ATR=RMSS(ID3(L))
25106 AMQR=RMSS(ID4(L))
25107 IF(AMQR.LT.0D0) THEN
25108 XMQR2=-AMQR**2
25109 ELSE
25110 XMQR2=AMQR**2
25111 ENDIF
25112 AM2(1,1)=XMQL2+XMF2
25113 AM2(2,2)=XMQR2+XMF2
25114 IF(DTERM) THEN
25115 IF(L.EQ.1) THEN
25116 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
25117 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
25118 AM2(1,2)=XMF*(ATR+XMU*TANB)
25119 ELSEIF(L.EQ.2) THEN
25120 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
25121 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
25122 AM2(1,2)=XMF*(ATR+XMU/TANB)
25123 ELSEIF(L.EQ.3) THEN
25124 IF(IMSS(8).EQ.1) THEN
25125 AM2(1,1)=RMSS(6)**2
25126 AM2(2,2)=RMSS(7)**2
25127 AM2(1,2)=0D0
25128 RMSS(13)=RMSS(6)
25129 RMSS(14)=RMSS(7)
25130 ELSE
25131 AM2(1,2)=XMF*(ATR+XMU*TANB)
25132 ENDIF
25133 ENDIF
25134 ENDIF
25135 AM2(2,1)=AM2(1,2)
25136 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
25137 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
25138 XMF12=SAME-DIFF
25139 XMF22=SAME+DIFF
25140 IF(XMF12.LT.0D0) THEN
25141 WRITE(MSTU(11),*) ' NEGATIVE**2 MASS FOR SFERMION '
25142 STOP
25143 ENDIF
25144 IT=0
25145 IF(XMF22-XMF12.GT.0D0) THEN
25146 RT(1,1) = SQRT((XMF22-AM2(1,1))/(XMF22-XMF12))
25147 RT(2,2) = RT(1,1)
25148 RT(1,2) = -SIGN(SQRT(1D0-RT(1,1)**2),AM2(1,2)/(XMF22-XMF12))
25149 RT(2,1) = -RT(1,2)
25150 ELSE
25151 RT(1,1) = 1D0
25152 RT(2,2) = RT(1,1)
25153 RT(1,2) = 0D0
25154 RT(2,1) = -RT(1,2)
25155 ENDIF
25156 100 CONTINUE
25157 IT=IT+1
25158
25159 DO 140 I=1,2
25160 DO 130 JJ=1,2
25161 DI(I,JJ)=0D0
25162 DO 120 II=1,2
25163 DO 110 J=1,2
25164 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
25165 110 CONTINUE
25166 120 CONTINUE
25167 130 CONTINUE
25168 140 CONTINUE
25169
25170 IF(DI(1,1).GT.DI(2,2)) THEN
25171 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
25172 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
25173 WRITE(MSTU(11),*) AM2
25174 WRITE(MSTU(11),*) DI
25175 WRITE(MSTU(11),*) RT
25176 DI(1,1)=-RT(2,1)
25177 DI(2,2)=RT(1,2)
25178 DI(1,2)=-RT(2,2)
25179 DI(2,1)=RT(1,1)
25180 DO 160 I=1,2
25181 DO 150 J=1,2
25182 RT(I,J)=DI(I,J)
25183 150 CONTINUE
25184 160 CONTINUE
25185 GOTO 100
25186 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
25187 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25188 & ' OFF DIAGONAL ELEMENTS '
25189 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
25190 WRITE(MSTU(11),*) DI
25191 WRITE(MSTU(11),*) ' ROTATION = ',RT
25192C...STOP
25193 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
25194 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25195 & ' NEGATIVE MASSES '
25196 STOP
25197 ENDIF
25198 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
25199 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
25200 SFMIX(IF,1)=RT(1,1)
25201 SFMIX(IF,2)=RT(1,2)
25202 SFMIX(IF,3)=RT(2,1)
25203 SFMIX(IF,4)=RT(2,2)
25204 170 CONTINUE
25205
25206 RETURN
25207 END
25208
25209C*********************************************************************
25210
25211*$ CREATE PYINOM.FOR
25212*COPY PYINOM
25213C...PYINOM
25214C...Finds the mass eigenstates and mixing matrices for neutralinos
25215C...and charginos.
25216
25217 SUBROUTINE PYINOM
25218
25219C...Double precision and integer declarations.
25220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25221 INTEGER PYK,PYCHGE,PYCOMP
25222C...Parameter statement to help give large particle numbers.
25223 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25224C...Commonblocks.
25225 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25226 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25227 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25228 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25229 &SFMIX(16,4)
25230 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
25231
25232C...Local variables.
25233 DOUBLE PRECISION XMW,XMZ
25234 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
25235 DOUBLE PRECISION ZP(4,4)
25236 DOUBLE PRECISION DETX,XI(2,2)
25237 DOUBLE PRECISION XXX,YYY,XMH,XML
25238 DOUBLE PRECISION COSW,SINW
25239 DOUBLE PRECISION XMU
25240 DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
25241 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
25242 DOUBLE PRECISION XM1,XM2,XM3,BETA
25243 DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
25244 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
25245 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
25246 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
25247 DOUBLE PRECISION PYALPS,PYALEM
25248 DOUBLE PRECISION PYRNM3
25249 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
25250 DATA KFNCHI/1000022,1000023,1000025,1000035/
25251
25252 IOPT=IMSS(2)
25253 IF(IMSS(1).EQ.2) THEN
25254 IOPT=1
25255 ENDIF
25256C...M1, M2, AND M3 ARE INDEPENDENT
25257 IF(IOPT.EQ.0) THEN
25258 XM1=RMSS(1)
25259 XM2=RMSS(2)
25260 XM3=RMSS(3)
25261 ELSEIF(IOPT.GE.1) THEN
25262 Q2=PMAS(23,1)**2
25263 AEM=PYALEM(Q2)
25264 A2=AEM/PARU(102)
25265 A1=AEM/(1D0-PARU(102))
25266 XM1=RMSS(1)
25267 XM2=RMSS(2)
25268 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
25269 IF(IOPT.EQ.1) THEN
25270 XM2=XM1*A2/A1*3D0/5D0
25271 ELSEIF(IOPT.EQ.3) THEN
25272 XM1=XM2*5D0/3D0*A1/A2
25273 ENDIF
25274 XM3=PYRNM3(XM2/A2)
25275 IF(XM3.LE.0D0) THEN
25276 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
25277 STOP
25278 ENDIF
25279 ENDIF
25280
25281C...GLUINO MASS
25282 IF(IMSS(3).EQ.1) THEN
25283 PMAS(PYCOMP(KSUSY1+21),1)=XM3
25284 ELSE
25285 AQ=0D0
25286 DO 110 I=1,4
25287 DO 100 ILR=1,2
25288 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25289 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
25290 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
25291 100 CONTINUE
25292 110 CONTINUE
25293
25294 DO 130 I=5,6
25295 DO 120 ILR=1,2
25296 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25297 RM2=PMAS(I,1)**2/XM3**2
25298 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
25299 IF(ARG.GE.0D0) THEN
25300 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
25301 AX0=ABS(X0)
25302 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
25303 AX1=ABS(X1)
25304 IF(X0.EQ.1D0) THEN
25305 AT=-1D0
25306 BT=0.25D0
25307 ELSEIF(X0.EQ.0D0) THEN
25308 AT=0D0
25309 BT=-0.25D0
25310 ELSE
25311 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
25312 & 0.5D0*X0**2*LOG(AX0)
25313 BT=(-1D0-2D0*X0)/4D0
25314 ENDIF
25315 IF(X1.EQ.1D0) THEN
25316 AT=-1D0+AT
25317 BT=0.25D0+BT
25318 ELSEIF(X1.EQ.0D0) THEN
25319 AT=0D0+AT
25320 BT=-0.25D0+BT
25321 ELSE
25322 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
25323 & X1**2*LOG(AX1)+AT
25324 BT=(-1D0-2D0*X1)/4D0+BT
25325 ENDIF
25326 AQ=AQ+AT+BT
25327 ELSE
25328 X0=0.5D0*(1D0+RM2-RM1)
25329 Y0=-0.5D0*SQRT(-ARG)
25330 AMGX0=SQRT(X0**2+Y0**2)
25331 AM1X0=SQRT((1D0-X0)**2+Y0**2)
25332 ARGX0=ATAN2(-X0,-Y0)
25333 AR1X0=ATAN2(1D0-X0,Y0)
25334 X1=X0
25335 Y1=-Y0
25336 AMGX1=AMGX0
25337 AM1X1=AM1X0
25338 ARGX1=ATAN2(-X1,-Y1)
25339 AR1X1=ATAN2(1D0-X1,Y1)
25340 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
25341 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
25342 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
25343 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
25344 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
25345 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
25346 AQ=AQ+AT+BT
25347 ENDIF
25348 120 CONTINUE
25349 130 CONTINUE
25350 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
25351 & (15D0+AQ))
25352 ENDIF
25353
25354C...NEUTRALINO MASSES
25355 XMZ=PMAS(23,1)
25356 XMW=PMAS(24,1)
25357 XMU=RMSS(4)
25358 SINW=SQRT(PARU(102))
25359 COSW=SQRT(1D0-PARU(102))
25360 TANB=RMSS(5)
25361 BETA=ATAN(TANB)
25362 COSB=COS(BETA)
25363 SINB=TANB*COSB
25364 AR(1,1) = XM1
25365 AR(2,2) = XM2
25366 AR(3,3) = 0D0
25367 AR(4,4) = 0D0
25368 AR(1,2) = 0D0
25369 AR(2,1) = 0D0
25370 AR(1,3) = -XMZ*SINW*COSB
25371 AR(3,1) = AR(1,3)
25372 AR(1,4) = XMZ*SINW*SINB
25373 AR(4,1) = AR(1,4)
25374 AR(2,3) = XMZ*COSW*COSB
25375 AR(3,2) = AR(2,3)
25376 AR(2,4) = -XMZ*COSW*SINB
25377 AR(4,2) = AR(2,4)
25378 AR(3,4) = -XMU
25379 AR(4,3) = -XMU
25380 CALL PYEIG4(AR,WR,ZR)
25381 DO 150 I=1,4
25382 SMZ(I)=WR(I)
25383 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
25384 DO 140 J=1,4
25385 ZMIX(I,J)=ZR(I,J)
25386 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
25387 140 CONTINUE
25388 150 CONTINUE
25389
25390C...CHARGINO MASSES
25391 AR(1,1) = XM2
25392 AR(2,2) = XMU
25393 AR(1,2) = SQRT(2D0)*XMW*SINB
25394 AR(2,1) = SQRT(2D0)*XMW*COSB
25395 TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
25396 TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
25397 TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
25398 &(AR(1,2)**2+AR(2,1)**2)+
25399 &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
25400 DISCR=TERMC
25401 IF(DISCR.LT.0D0) THEN
25402 WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
25403 ELSE
25404 DISCR=SQRT(DISCR)
25405 ENDIF
25406 XML2=0.5D0*(TERMB-DISCR)
25407 XMH2=0.5D0*(TERMB+DISCR)
25408 XML=SQRT(XML2)
25409 XMH=SQRT(XMH2)
25410 PMAS(PYCOMP(KSUSY1+24),1)=XML
25411 PMAS(PYCOMP(KSUSY1+37),1)=XMH
25412 SMW(1)=XML
25413 SMW(2)=XMH
25414 XXX=AR(1,1)**2+AR(2,1)**2
25415 YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
25416 VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
25417 VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25418 VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
25419 VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25420 ZR(1,1) = XML
25421 ZR(1,2) = 0D0
25422 ZR(2,1) = 0D0
25423 ZR(2,2) = XMH
25424 DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
25425 XI(1,1) = AR(2,2)/DETX
25426 XI(2,2) = AR(1,1)/DETX
25427 XI(1,2) = -AR(1,2)/DETX
25428 XI(2,1) = -AR(2,1)/DETX
25429 DO 190 I=1,2
25430 DO 180 J=1,2
25431 UMIX(I,J)=0D0
25432 DO 170 K=1,2
25433 DO 160 L=1,2
25434 UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
25435 160 CONTINUE
25436 170 CONTINUE
25437 180 CONTINUE
25438 190 CONTINUE
25439
25440 RETURN
25441 END
25442
25443C*********************************************************************
25444
25445*$ CREATE PYRNM3.FOR
25446*COPY PYRNM3
25447C...PYRNM3
25448C...Calculates the running of M3, the SU(3) gluino mass parameter.
25449
25450 FUNCTION PYRNM3(RGUT)
25451
25452C...Double precision and integer declarations.
25453 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25454 INTEGER PYK,PYCHGE,PYCOMP
25455
25456C...Local variables.
25457 DOUBLE PRECISION PI,R
25458 DOUBLE PRECISION TOL
25459 EXTERNAL PYALPS
25460 DATA TOL/0.001D0/
25461 DATA PI,R/3.141592654D0,0.61803399D0/
25462
25463 C=1D0-R
25464
25465 BX=RGUT*PYALPS(RGUT**2)
25466 AX=MIN(50D0,BX*0.5D0)
25467 CX=MAX(2000D0,2D0*BX)
25468
25469 X0=AX
25470 X3=CX
25471 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
25472 X1=BX
25473 X2=BX+C*(CX-BX)
25474 ELSE
25475 X2=BX
25476 X1=BX-C*(BX-AX)
25477 ENDIF
25478 AS1=PYALPS(X1**2)
25479 F1=ABS(X1-RGUT*AS1)
25480 AS2=PYALPS(X2**2)
25481 F2=ABS(X2-RGUT*AS2)
25482 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
25483 IF(F2.LT.F1) THEN
25484 X0=X1
25485 X1=X2
25486 X2=R*X1+C*X3
25487 F1=F2
25488 AS2=PYALPS(X2**2)
25489 F2=ABS(X2-RGUT*AS2)
25490 ELSE
25491 X3=X2
25492 X2=X1
25493 X1=R*X2+C*X0
25494 F2=F1
25495 AS1=PYALPS(X1**2)
25496 F1=ABS(X1-RGUT*AS1)
25497 ENDIF
25498 GOTO 100
25499 ENDIF
25500 IF(F1.LT.F2) THEN
25501 PYRNM3=X1
25502 XMIN=X1
25503 ELSE
25504 PYRNM3=X2
25505 XMIN=X2
25506 ENDIF
25507
25508 RETURN
25509 END
25510
25511C*********************************************************************
25512
25513*$ CREATE PYEIG4.FOR
25514*COPY PYEIG4
25515C...PYEIG4
25516C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
25517C...Specific application: mixing in neutralino sector.
25518
25519 SUBROUTINE PYEIG4(A,W,Z)
25520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25521 INTEGER PYK,PYCHGE,PYCOMP
25522
25523C...Arrays: in call and local.
25524 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
25525
25526C...Coefficients of fourth-degree equation from matrix.
25527C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
25528 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
25529 B2=0D0
25530 DO 110 I=1,3
25531 DO 100 J=I+1,4
25532 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
25533 100 CONTINUE
25534 110 CONTINUE
25535 B1=0D0
25536 B0=0D0
25537 DO 120 I=1,4
25538 I1=MOD(I,4)+1
25539 I2=MOD(I+1,4)+1
25540 I3=MOD(I+2,4)+1
25541 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
25542 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
25543 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
25544 B0=B0+(-1D0)**(I+1)*A(1,I)*(
25545 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
25546 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
25547 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
25548 120 CONTINUE
25549
25550C...Coefficients of third-degree equation needed for
25551C...separation into two second-degree equations.
25552C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
25553 C2=-B2
25554 C1=B1*B3-4D0*B0
25555 C0=-B1**2-B0*B3**2+4D0*B0*B2
25556 CQ=C1/3D0-C2**2/9D0
25557 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
25558 CQR=CQ**3+CR**2
25559
25560C...Cases with one or three real roots.
25561 IF(CQR.GE.0D0) THEN
25562 S1=(CR+SQRT(CQR))**(1D0/3D0)
25563 S2=(CR-SQRT(CQR))**(1D0/3D0)
25564 U=S1+S2-C2/3D0
25565 ELSE
25566 SABS=SQRT(-CQ)
25567 THE=ACOS(CR/SABS**3)/3D0
25568 SRE=SABS*COS(THE)
25569 U=2D0*SRE-C2/3D0
25570 ENDIF
25571
25572C...Find and solve two second-degree equations.
25573 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
25574 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
25575 Q1=U/2D0+SQRT(U**2/4D0-B0)
25576 Q2=U/2D0-SQRT(U**2/4D0-B0)
25577 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
25578 QSAV=Q1
25579 Q1=Q2
25580 Q2=QSAV
25581 ENDIF
25582 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
25583 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
25584 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
25585 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
25586
25587C...Order eigenvalues in asceding mass.
25588 W(1)=X(1)
25589 DO 150 I1=2,4
25590 DO 130 I2=I1-1,1,-1
25591 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
25592 W(I2+1)=W(I2)
25593 130 CONTINUE
25594 140 W(I2+1)=X(I1)
25595 150 CONTINUE
25596
25597C...Find equation system for eigenvectors.
25598 DO 250 I=1,4
25599 DO 170 J1=1,4
25600 D(J1,J1)=A(J1,J1)-W(I)
25601 DO 160 J2=J1+1,4
25602 D(J1,J2)=A(J1,J2)
25603 D(J2,J1)=A(J2,J1)
25604 160 CONTINUE
25605 170 CONTINUE
25606
25607C...Find largest element in matrix.
25608 DAMAX=0D0
25609 DO 190 J1=1,4
25610 DO 180 J2=1,4
25611 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
25612 JA=J1
25613 JB=J2
25614 DAMAX=ABS(D(J1,J2))
25615 180 CONTINUE
25616 190 CONTINUE
25617
25618C...Subtract others by multiple of row selected above.
25619 DAMAX=0D0
25620 DO 210 J3=JA+1,JA+3
25621 J1=J3-4*((J3-1)/4)
25622 RL=D(J1,JB)/D(JA,JB)
25623 DO 200 J2=1,4
25624 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
25625 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
25626 JC=J1
25627 JD=J2
25628 DAMAX=ABS(D(J1,J2))
25629 200 CONTINUE
25630 210 CONTINUE
25631
25632C...Do one more subtraction of a row.
25633 DAMAX=0D0
25634 DO 230 J3=JC+1,JC+3
25635 J1=J3-4*((J3-1)/4)
25636 IF(J1.EQ.JA) GOTO 230
25637 RL=D(J1,JD)/D(JC,JD)
25638 DO 220 J2=1,4
25639 IF(J2.EQ.JB) GOTO 220
25640 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
25641 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
25642 JE=J1
25643 DAMAX=ABS(D(J1,J2))
25644 220 CONTINUE
25645 230 CONTINUE
25646
25647C...Construct unnormalized eigenvector.
25648 JF1=JD+1-4*(JD/4)
25649 JF2=JD+2-4*((JD+1)/4)
25650 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
25651 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
25652 E(JF1)=-D(JE,JF2)
25653 E(JF2)=D(JE,JF1)
25654 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
25655 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
25656 & D(JA,JB)
25657
25658C...Normalize and fill in final array.
25659 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
25660 SGN=(-1D0)**INT(PYR(0)+0.5D0)
25661 DO 240 J=1,4
25662 Z(I,J)=SGN*E(J)/EA
25663 240 CONTINUE
25664 250 CONTINUE
25665
25666 RETURN
25667 END
25668
25669C*********************************************************************
25670
25671*$ CREATE PYHGGM.FOR
25672*COPY PYHGGM
25673C...PYHGGM
25674C...Determines the Higgs boson mass spectrum using several inputs.
25675
25676 SUBROUTINE PYHGGM(ALPHA)
25677
25678C...Double precision and integer declarations.
25679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25680 INTEGER PYK,PYCHGE,PYCOMP
25681C...Parameter statement to help give large particle numbers.
25682 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25683C...Commonblocks.
25684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25685 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25686 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25687 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25688 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
25689
25690C...Local variables.
25691 DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
25692 DOUBLE PRECISION ALPHA
25693 INTEGER I,J,IHOPT,II,JJ,IT
25694 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
25695 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
25696 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
25697 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
25698
25699 IHOPT=IMSS(4)
25700 IF(IHOPT.EQ.2) THEN
25701 ALPHA=RMSS(18)
25702 RETURN
25703 ENDIF
25704 AT=RMSS(16)
25705 AB=RMSS(15)
25706 XMU=RMSS(4)
25707 TANB=RMSS(5)
25708
25709 DMA=RMSS(19)
25710 DTANB=TANB
25711 DMQ=RMSS(10)
25712 DMUR=RMSS(12)
25713 DMDR=RMSS(11)
25714 DMTOP=PMAS(6,1)
25715 DMC=PMAS(PYCOMP(KSUSY1+37),1)
25716 DAU=AT
25717 DAD=AB
25718 DMU=XMU
25719
25720 IF(IHOPT.EQ.0) THEN
25721 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25722 & DMHCH,DSA,DCA,DTANBA)
25723 ELSEIF(IHOPT.EQ.1) THEN
25724 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25725 & DMHCH,DSA,DCA,DTANBA)
25726 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
25727 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
25728 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
25729 DMH=DMHP
25730 DHM=DHMP
25731 DMA=DAMP
25732 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.1D-1) THEN
25733 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
25734 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
25735 & PMAS(PYCOMP(1000006),1),DSTOP2
25736 ENDIF
25737 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.1D-1) THEN
25738 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
25739 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
25740 & PMAS(PYCOMP(2000006),1),DSTOP1
25741 ENDIF
25742 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.1D-1) THEN
25743 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
25744 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
25745 & PMAS(PYCOMP(1000005),1),DSBOT2
25746 ENDIF
25747 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.1D-1) THEN
25748 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
25749 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
25750 & PMAS(PYCOMP(2000005),1),DSBOT1
25751 ENDIF
25752
25753 ENDIF
25754
25755 ALPHA=ACOS(DCA)
25756
25757 PMAS(25,1)=DMH
25758 PMAS(35,1)=DHM
25759 PMAS(36,1)=DMA
25760 PMAS(37,1)=DMHCH
25761
25762 RETURN
25763 END
25764
25765C*********************************************************************
25766
25767*$ CREATE PYSUBH.FOR
25768*COPY PYSUBH
25769C...PYSUBH
25770C...This routine computes the renormalization group improved
25771C...values of Higgs masses and couplings in the MSSM.
25772
25773C...Program based on the work by M. Carena, J.R. Espinosa,
25774c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
25775
25776C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
25777C...All masses in GeV units. MA is the CP-odd Higgs mass,
25778C...MTOP is the physical top mass, MQ and MUR are the soft
25779C...supersymmetry breaking mass parameters of left handed
25780C...and right handed stops respectively, AU and AD are the
25781C...stop and sbottom trilinear soft breaking terms,
25782C...respectively, and MU is the supersymmetric
25783C...Higgs mass parameter. We use the conventions from
25784C...the physics report of Haber and Kane: left right
25785C...stop mixing term proportional to (AU - MU/TANB)
25786C...We use as input TANB defined at the scale MTOP
25787
25788C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
25789C...where MH and HM are the lightest and heaviest CP-even
25790C...Higgs masses, MHCH is the charged Higgs mass and
25791C...ALPHA is the Higgs mixing angle
25792C...TANBA is the angle TANB at the CP-odd Higgs mass scale
25793
25794C...Range of validity:
25795C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
25796C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
25797C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
25798C...are the sbottom mass eigenvalues, respectively. This
25799C...range automatically excludes the existence of tachyons.
25800C...For the charged Higgs mass computation, the method is
25801C...valid if
25802C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
25803C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
25804C...where M_SUSY**2 is the average of the squared stop mass
25805C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
25806C...masses have been assumed to be of order of the stop ones
25807C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
25808
25809 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
25810 &XMHCH,SA,CA,TANBA)
25811
25812C...Double precision and integer declarations.
25813 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25814 INTEGER PYK,PYCHGE,PYCOMP
25815C...Parameter statement to help give large particle numbers.
25816 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25817C...Commonblocks.
25818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25819 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25820 SAVE /PYDAT1/,/PYDAT2/
25821
25822C...Local variables.
25823 DOUBLE PRECISION PYALEM,PYALPS
25824 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
25825 DOUBLE PRECISION XMHCH,SA,CA
25826 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
25827 DOUBLE PRECISION Q02
25828 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
25829 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
25830 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
25831 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
25832 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
25833 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
25834 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
25835 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
25836
25837 XMZ = PMAS(23,1)
25838 Q02=XMZ**2
25839 AEM=PYALEM(Q02)
25840 ALP1=AEM/(1D0-PARU(102))
25841 ALP2=AEM/PARU(102)
25842 ALPH3Z=PYALPS(Q02)
25843
25844 ALP1 = 0.0101D0
25845 ALP2 = 0.0337D0
25846 ALPH3Z = 0.12D0
25847
25848 V = 174.1D0
25849 PI = PARU(1)
25850 TANBA = TANB
25851 TANBT = TANB
25852
25853C...MBOTTOM(MTOP) = 3. GEV
25854 XMB = 3D0
25855 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
25856 &LOG(XMTOP**2/XMZ**2))
25857
25858C...RMTOP= RUNNING TOP QUARK MASS
25859 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
25860 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
25861 T = LOG(XMS**2/XMTOP**2)
25862 SINB = TANB/((1D0 + TANB**2)**0.5D0)
25863 COSB = SINB/TANB
25864C...IF(MA.LE.XMTOP) TANBA = TANBT
25865 IF(XMA.GT.XMTOP)
25866 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
25867 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
25868 &LOG(XMA**2/XMTOP**2))
25869
25870 SINBT = TANBT/SQRT(1D0 + TANBT**2)
25871 COSBT = 1D0/SQRT(1D0 + TANBT**2)
25872 COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
25873 G1 = SQRT(ALP1*4D0*PI)
25874 G2 = SQRT(ALP2*4D0*PI)
25875 G3 = SQRT(ALP3*4D0*PI)
25876 HU = RMTOP/V/SINBT
25877 HD = XMB/V/COSBT
25878 HU2=HU*HU
25879 HD2=HD*HD
25880 HU4=HU2*HU2
25881 HD4=HD2*HD2
25882 AU2=AU**2
25883 AD2=AD**2
25884 XMS2=XMS**2
25885 XMS3=XMS**3
25886 XMS4=XMS2*XMS2
25887 XMU2=XMU*XMU
25888 PI2=PI*PI
25889
25890 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
25891 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
25892 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
25893 &+ 3D0*(AU + AD)**2/XMS2)/6D0
25894 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
25895 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
25896 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
25897 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
25898 &- 16D0*G3**2) *T/16D0/PI2)
25899 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
25900 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
25901 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
25902 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
25903 &- 16D0*G3**2) *T/16D0/PI2)
25904 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
25905 &(HU2 + HD2)*T/16D0/PI2)
25906 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25907 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25908 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25909 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
25910 &- 16D0*G3**2) *T/16D0/PI2)
25911 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25912 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
25913 &- 16D0*G3**2) *T/16D0/PI2)
25914 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
25915 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25916 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25917 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25918 &XMS4)*
25919 &(1+ (6D0*HU2 -2D0* HD2
25920 &- 16D0*G3**2) *T/16D0/PI2)
25921 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25922 &XMS4)*
25923 &(1+ (6D0*HD2 -2D0* HU2/2D0
25924 &- 16D0*G3**2) *T/16D0/PI2)
25925 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
25926 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
25927 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
25928 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
25929 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
25930 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25931 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
25932 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25933 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
25934 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25935 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
25936 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25937 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
25938 &2D0* XLAM6*SINBT*COSBT
25939 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
25940 &+ XLAM5*COSBT**2)
25941 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
25942 &XLAM6*COSBT**2
25943 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
25944 &2D0* XLAM6* COSBT*SINBT
25945 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25946 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
25947 &((XLAM1* COSBT**2 +2D0*
25948 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
25949 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
25950 &*SINBT**2
25951 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
25952 &+ XLAM4) + XLAM6*COSBT**2
25953 &+ XLAM7* SINBT**2))
25954
25955 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
25956 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
25957 XHM = SQRT(XHM2)
25958 XMH = SQRT(XMH2)
25959 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
25960 XMHCH = SQRT(XMHCH2)
25961
25962 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25963 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25964 &XLAM6* COSBT*SINBT
25965 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25966 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25967 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
25968 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
25969
25970 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
25971 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
25972 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
25973 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
25974 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25975 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25976 &XLAM6* COSBT*SINBT
25977 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25978 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25979 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
25980
25981 SA = -SINALP
25982 CA = -COSALP
25983
25984 100 CONTINUE
25985
25986 RETURN
25987 END
25988
25989C*********************************************************************
25990
25991*$ CREATE PYPOLE.FOR
25992*COPY PYPOLE
25993C...PYPOLE
25994C...This subroutine computes the CP-even higgs and CP-odd pole
25995c...Higgs masses and mixing angles.
25996
25997C...Program based on the work by M. Carena, M. Quiros
25998C...and C.E.M. Wagner, "Effective potential methods and
25999C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
26000
26001C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
26002C...AT,AB,MU
26003C...where MCHI is the largest chargino mass, MA is the running
26004C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
26005C...expectaion values at the scale MTOP, MQ is the third generation
26006C...left handed squark mass parameter, MUR is the third generation
26007C...right handed stop mass parameter, MDR is the third generation
26008C...right handed sbottom mass parameter, MTOP is the pole top quark
26009C...mass; AT,AB are the soft supersymmetry breaking trilinear
26010C...couplings of the stop and sbottoms, respectively, and MU is the
26011C...supersymmetric mass parameter
26012
26013C...The parameter IHIGGS=0,1,2,3 corresponds to the
26014c...number of Higgses whose pole mass is computed
26015c...by the subroutine PYVACU(...). If IHIGGS=0 only running
26016c...masses are given, what makes the running of the program
26017c...much faster and it is quite generally a good approximation
26018c...(for a theoretical discussion see ref. below).
26019c...If IHIGGS=1, only the pole
26020c...mass for H is computed. If IHIGGS=2, then h and H, and
26021c...if IHIGGS=3, then h,H,A polarizations are computed
26022
26023C...Output: MH and MHP which are the lightest CP-even Higgs running
26024C...and pole masses, respectively; HM and HMP are the heaviest CP-even
26025C...Higgs running and pole masses, repectively; SA and CA are the
26026C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
26027C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
26028C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
26029C...the value of TANB at the CP-odd Higgs mass scale
26030
26031C...This subroutine makes use of CERN library subroutine
26032C...integration package, which makes the computation of the
26033C...pole Higgs masses somewhat faster. We thank P. Janot for this
26034C...improvement. Those who are not able to call the CERN
26035C...libraries, please use the subroutine SUBHPOLE2.F, which
26036C...although somewhat slower, gives identical results
26037
26038 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
26039 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
26040
26041C...Double precision and integer declarations.
26042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26043 INTEGER PYK,PYCHGE,PYCOMP
26044
26045 CALL PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
26046 &XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,SBOT1,SBOT2,
26047 &SA,CA,STOP1W,STOP2W,TANBA)
26048 SINB = TANB/(TANB**2+1D0)**0.5D0
26049 COSB = 1D0/(TANB**2+1D0)**0.5D0
26050 SINBMA = SINB*CA - COSB*SA
26051
26052 RETURN
26053 END
26054
26055C*********************************************************************
26056
26057*$ CREATE PYVACU.FOR
26058*COPY PYVACU
26059C...PYVACU
26060C...Computes Higgs masses and mixing angles, see PYPOLE above.
26061
26062 SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
26063 &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
26064 &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
26065
26066C...Double precision and integer declarations.
26067 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26068C...Parameters.
26069 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26070 INTEGER PYK,PYCHGE,PYCOMP
26071
26072C...Local variables.
26073 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
26074 &SSBOT2(2),B(2,2),COUPB(2,2),
26075 &HCOUPT(2,2),HCOUPB(2,2),
26076 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
26077
26078 DELTA(1,1) = 1D0
26079 DELTA(2,2) = 1D0
26080 DELTA(1,2) = 0D0
26081 DELTA(2,1) = 0D0
26082 V = 174.1D0
26083 XMZ=91.18D0
26084 PI=3.14159D0
26085 ALP3Z=0.12D0
26086 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
26087
26088C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
26089 RXMT = PYRNMT(XMT)
26090
26091 HT = RXMT /V
26092 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
26093 &XMU,XMH,HM,SA,CA,TANBA)
26094 SINB = TANB/(TANB**2+1D0)**0.5D0
26095 COSB = 1D0/(TANB**2+1D0)**0.5D0
26096 COS2B = SINB**2 - COSB**2
26097 SINBPA = SINB*CA + COSB*SA
26098 COSBPA = COSB*CA - SINB*SA
26099 RMBOT = 3D0
26100 XMQ2 = XMQ**2
26101 XMUR2 = XMUR**2
26102 IF(XMUR.LT.0D0) XMUR2=-XMUR2
26103 XMDR2 = XMDR**2
26104 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
26105 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
26106 IF(XMST11.LT.0D0) GOTO 500
26107 IF(XMST22.LT.0D0) GOTO 500
26108 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
26109 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
26110 IF(XMSB11.LT.0D0) GOTO 500
26111 IF(XMSB22.LT.0D0) GOTO 500
26112 WMST11 = RXMT**2 + XMQ2
26113 WMST22 = RXMT**2 + XMUR2
26114 XMST12 = RXMT*(AT - XMU/TANB)
26115 XMSB12 = RMBOT*(AB - XMU*TANB)
26116
26117CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26118C...STOP EIGENVALUES CALCULATION
26119CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26120
26121 STOP12 = 0.5D0*(XMST11+XMST22) +
26122 &0.5D0*((XMST11+XMST22)**2 -
26123 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
26124 STOP22 = 0.5D0*(XMST11+XMST22) -
26125 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
26126 &XMST12**2))**0.5D0
26127
26128 IF(STOP22.LT.0D0) GOTO 500
26129 SSTOP2(1) = STOP12
26130 SSTOP2(2) = STOP22
26131 STOP1 = STOP12**0.5D0
26132 STOP2 = STOP22**0.5D0
26133 STOP1W = STOP1
26134 STOP2W = STOP2
26135
26136 IF(XMST12.EQ.0D0) XST11 = 1D0
26137 IF(XMST12.EQ.0D0) XST12 = 0D0
26138 IF(XMST12.EQ.0D0) XST21 = 0D0
26139 IF(XMST12.EQ.0D0) XST22 = 1D0
26140
26141 IF(XMST12.EQ.0D0) GOTO 110
26142
26143 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26144 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26145 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26146 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26147
26148 110 T(1,1) = XST11
26149 T(2,2) = XST22
26150 T(1,2) = XST12
26151 T(2,1) = XST21
26152
26153 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
26154 &0.5D0*((XMSB11+XMSB22)**2 -
26155 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
26156 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
26157 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
26158 &XMSB12**2))**0.5D0
26159 IF(SBOT22.LT.0D0) GOTO 500
26160 SBOT1 = SBOT12**0.5D0
26161 SBOT2 = SBOT22**0.5D0
26162
26163 SSBOT2(1) = SBOT12
26164 SSBOT2(2) = SBOT22
26165
26166 IF(XMSB12.EQ.0D0) XSB11 = 1D0
26167 IF(XMSB12.EQ.0D0) XSB12 = 0D0
26168 IF(XMSB12.EQ.0D0) XSB21 = 0D0
26169 IF(XMSB12.EQ.0D0) XSB22 = 1D0
26170
26171 IF(XMSB12.EQ.0D0) GOTO 130
26172
26173 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26174 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26175 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26176 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26177
26178 130 B(1,1) = XSB11
26179 B(2,2) = XSB22
26180 B(1,2) = XSB12
26181 B(2,1) = XSB21
26182
26183
26184 SINT = 0.2320D0
26185 SQR = 2D0**0.5D0
26186 VP = 174.1D0*SQR
26187
26188CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26189C...STARTING OF LIGHT HIGGS
26190CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26191
26192 IF(IHIGGS.EQ.0) GOTO 490
26193
26194 DO 150 I = 1,2
26195 DO 140 J = 1,2
26196 COUPT(I,J) =
26197 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
26198 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26199 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
26200 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
26201 & T(1,J)*T(2,I))
26202 140 CONTINUE
26203 150 CONTINUE
26204
26205
26206 DO 170 I = 1,2
26207 DO 160 J = 1,2
26208 COUPB(I,J) =
26209 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
26210 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26211 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
26212 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
26213 & B(1,J)*B(2,I))
26214 160 CONTINUE
26215 170 CONTINUE
26216
26217 PRUN = XMH
26218 EPS = 1D-4*PRUN
26219 ITER = 0
26220 180 ITER = ITER + 1
26221 DO 230 I3 = 1,3
26222
26223 PR(I3)=PRUN+(I3-2)*EPS/2
26224 P2=PR(I3)**2
26225 POLT = 0D0
26226 DO 200 I = 1,2
26227 DO 190 J = 1,2
26228 POLT = POLT + COUPT(I,J)**2*3D0*
26229 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26230 190 CONTINUE
26231 200 CONTINUE
26232 POLB = 0D0
26233 DO 220 I = 1,2
26234 DO 210 J = 1,2
26235 POLB = POLB + COUPB(I,J)**2*3D0*
26236 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26237 210 CONTINUE
26238 220 CONTINUE
26239 RXMT2 = RXMT**2
26240 XMT2=XMT**2
26241
26242 POLTT =
26243 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26244 & CA**2/SINB**2 *
26245 & (-2D0*XMT**2+0.5D0*P2)*
26246 & PYFINT(P2,XMT2,XMT2)
26247
26248 POL = POLT + POLB + POLTT
26249 POLAR(I3) = P2 - XMH**2 - POL
26250 230 CONTINUE
26251 DERIV = (POLAR(3)-POLAR(1))/EPS
26252 DRUN = - POLAR(2)/DERIV
26253 PRUN = PRUN + DRUN
26254 P2 = PRUN**2
26255 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
26256 GOTO 180
26257 240 CONTINUE
26258
26259 XMHP = P2**0.5D0
26260
26261CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26262C...END OF LIGHT HIGGS
26263CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26264
26265 250 IF(IHIGGS.EQ.1) GOTO 490
26266
26267CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26268C... STARTING OF HEAVY HIGGS
26269CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26270
26271 DO 270 I = 1,2
26272 DO 260 J = 1,2
26273 HCOUPT(I,J) =
26274 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
26275 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26276 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
26277 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
26278 & T(1,J)*T(2,I))
26279 260 CONTINUE
26280 270 CONTINUE
26281
26282 DO 290 I = 1,2
26283 DO 280 J = 1,2
26284 HCOUPB(I,J) =
26285 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
26286 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26287 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
26288 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
26289 & B(1,J)*B(2,I))
26290 HCOUPB(I,J)=0D0
26291 280 CONTINUE
26292 290 CONTINUE
26293
26294 PRUN = HM
26295 EPS = 1D-4*PRUN
26296 ITER = 0
26297 300 ITER = ITER + 1
26298 DO 350 I3 = 1,3
26299 PR(I3)=PRUN+(I3-2)*EPS/2
26300 HP2=PR(I3)**2
26301
26302 HPOLT = 0D0
26303 DO 320 I = 1,2
26304 DO 310 J = 1,2
26305 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
26306 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26307 310 CONTINUE
26308 320 CONTINUE
26309
26310 HPOLB = 0D0
26311 DO 340 I = 1,2
26312 DO 330 J = 1,2
26313 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
26314 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26315 330 CONTINUE
26316 340 CONTINUE
26317
26318 RXMT2 = RXMT**2
26319 XMT2 = XMT**2
26320
26321 HPOLTT =
26322 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26323 & SA**2/SINB**2 *
26324 & (-2D0*XMT**2+0.5D0*HP2)*
26325 & PYFINT(HP2,XMT2,XMT2)
26326
26327 HPOL = HPOLT + HPOLB + HPOLTT
26328 POLAR(I3) =HP2-HM**2-HPOL
26329 350 CONTINUE
26330 DERIV = (POLAR(3)-POLAR(1))/EPS
26331 DRUN = - POLAR(2)/DERIV
26332 PRUN = PRUN + DRUN
26333 HP2 = PRUN**2
26334 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
26335 GOTO 300
26336 360 CONTINUE
26337
26338
26339 370 CONTINUE
26340 HMP = HP2**0.5D0
26341
26342CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26343C... END OF HEAVY HIGGS
26344CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26345
26346 IF(IHIGGS.EQ.2) GOTO 490
26347
26348CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26349C...BEGINNING OF PSEUDOSCALAR HIGGS
26350CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26351
26352 DO 390 I = 1,2
26353 DO 380 J = 1,2
26354 ACOUPT(I,J) =
26355 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
26356 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
26357 380 CONTINUE
26358 390 CONTINUE
26359 DO 410 I = 1,2
26360 DO 400 J = 1,2
26361 ACOUPB(I,J) =
26362 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
26363 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
26364 400 CONTINUE
26365 410 CONTINUE
26366
26367 PRUN = XMA
26368 EPS = 1D-4*PRUN
26369 ITER = 0
26370 420 ITER = ITER + 1
26371 DO 470 I3 = 1,3
26372 PR(I3)=PRUN+(I3-2)*EPS/2
26373 AP2=PR(I3)**2
26374 APOLT = 0D0
26375 DO 440 I = 1,2
26376 DO 430 J = 1,2
26377 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
26378 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26379 430 CONTINUE
26380 440 CONTINUE
26381 APOLB = 0D0
26382 DO 460 I = 1,2
26383 DO 450 J = 1,2
26384 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
26385 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26386 450 CONTINUE
26387 460 CONTINUE
26388 RXMT2 = RXMT**2
26389 XMT2=XMT**2
26390 APOLTT =
26391 & 3D0*RXMT**2/8D0/PI**2/ V **2*
26392 & COSB**2/SINB**2 *
26393 & (-0.5D0*AP2)*
26394 & PYFINT(AP2,XMT2,XMT2)
26395 APOL = APOLT + APOLB + APOLTT
26396 POLAR(I3) = AP2 - XMA**2 -APOL
26397 470 CONTINUE
26398 DERIV = (POLAR(3)-POLAR(1))/EPS
26399 DRUN = - POLAR(2)/DERIV
26400 PRUN = PRUN + DRUN
26401 AP2 = PRUN**2
26402 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
26403 GOTO 420
26404 480 CONTINUE
26405
26406 AMP = AP2**0.5D0
26407
26408CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26409C...END OF PSEUDOSCALAR HIGGS
26410CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26411
26412 IF(IHIGGS.EQ.3) GOTO 490
26413
26414 490 CONTINUE
26415 RETURN
26416 500 CONTINUE
26417 WRITE(MSTU(11),*) ' EXITING IN PYVACU '
26418 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
26419 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
26420 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
26421 STOP
26422 END
26423
26424C*********************************************************************
26425
26426*$ CREATE PYRGHM.FOR
26427*COPY PYRGHM
26428C...PYRGHM
26429C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26430
26431 SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
26432 &XMHP,HMP,SA,CA,TANBA)
26433
26434C...Double precision and integer declarations.
26435 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26436 INTEGER PYK,PYCHGE,PYCOMP
26437
26438C...Local variables.
26439 DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
26440
26441 XMZ = 91.18D0
26442 ALP1 = 0.0101D0
26443 ALP2 = 0.0337D0
26444 ALP3Z = 0.12D0
26445 V = 174.1D0
26446 PI = 3.14159D0
26447 TANBA = TANB
26448 TANBT = TANB
26449
26450C...MBOTTOM(XMT) = 3. GEV
26451 XMB = 3D0
26452 ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
26453 &LOG(XMT**2/XMZ**2))
26454
26455C...RXMT= RUNNING TOP QUARK MASS
26456 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26457 TQ = LOG((XMQ**2+XMT**2)/XMT**2)
26458 TU = LOG((XMUR**2 + XMT**2)/XMT**2)
26459 TD = LOG((XMDL**2 + XMT**2)/XMT**2)
26460 SINB = TANB/((1D0 + TANB**2)**0.5D0)
26461 COSB = SINB/TANB
26462 IF(XMA.GT.XMT)
26463 &TANBA = TANB*(1D0-3D0/32D0/PI**2*
26464 &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
26465 &LOG(XMA**2/XMT**2))
26466 IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
26467 SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
26468 COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
26469 COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
26470 G1 = (ALP1*4D0*PI)**0.5D0
26471 G2 = (ALP2*4D0*PI)**0.5D0
26472 G3 = (ALP3*4D0*PI)**0.5D0
26473 HU = RXMT/V/SINB
26474 HD = XMB/V/COSB
26475
26476 CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
26477 &XMU,VH,STOP1,STOP2)
26478
26479 IF(XMQ.GT.XMUR) TP = TQ - TU
26480 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
26481 IF(XMQ.GT.XMUR) TDP = TU
26482 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
26483 IF(XMQ.GT.XMDL) TPD = TQ - TD
26484 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
26485 IF(XMQ.GT.XMDL) TDPD = TD
26486 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
26487
26488 IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
26489 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
26490 &HD**2*(G1**2/3D0+G2**2)*TPD
26491
26492 IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
26493 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
26494 &HU**2*(-G1**2/3D0+G2**2)*TP
26495
26496 DLAM3 = 0D0
26497 DLAM4 = 0D0
26498
26499 IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
26500 IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
26501 &(G2**2-G1**2/3D0)*TPD
26502
26503 IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
26504 &1D0/16D0/PI**2*G1**2*HU**2*TP
26505 IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
26506 &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
26507
26508 IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
26509 IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
26510 &HD**2*TPD
26511
26512 XLAM1 = ((G1**2 + G2**2)/4D0)*
26513 &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
26514 &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
26515 &+ (3D0*HD**2/2D0 + HU**2/2D0
26516 &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
26517 &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
26518 &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
26519 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
26520 &(TP + TDP)/8D0/PI**2)
26521 &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
26522 &+ (3D0*HU**2/2D0 + HD**2/2D0
26523 &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
26524 &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
26525 &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
26526 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
26527 &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
26528 &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
26529 XLAM4 = (- G2**2/2D0)*(1D0
26530 &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
26531 &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
26532
26533 XLAM5 = 0D0
26534 XLAM6 = 0D0
26535 XLAM7 = 0D0
26536
26537 XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
26538 &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
26539
26540 XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
26541 &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
26542 XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
26543 &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
26544
26545 XM2(2,1) = XM2(1,2)
26546
26547CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26548C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
26549CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26550
26551 XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
26552
26553 IF(XMC.GT.XMSSU) GOTO 100
26554 IF(XMC.LT.XMT) XMC=XMT
26555
26556 TCHAR=LOG(XMSSU**2/XMC**2)
26557
26558 DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
26559 DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
26560 &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
26561
26562 DEM112=2D0*DEL12*V**2*COSB**2
26563 DEM222=2D0*DEL12*V**2*SINB**2
26564 DEM122=2D0*DEL3P4*V**2*SINB*COSB
26565
26566 XM2(1,1)=XM2(1,1)+DEM112
26567 XM2(2,2)=XM2(2,2)+DEM222
26568 XM2(1,2)=XM2(1,2)+DEM122
26569 XM2(2,1)=XM2(2,1)+DEM122
26570
26571 100 CONTINUE
26572
26573CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26574C...END OF CHARGINOS/NEUTRALINOS
26575CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26576
26577 DO 120 I = 1,2
26578 DO 110 J = 1,2
26579 XM2P(I,J) = XM2(I,J) + VH(I,J)
26580 110 CONTINUE
26581 120 CONTINUE
26582
26583 TRM2P = XM2P(1,1) + XM2P(2,2)
26584 DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
26585
26586 XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26587 HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26588 HMP = HM2P**0.5D0
26589 IF(XMH2P.LT.0D0) GOTO 130
26590 XMHP = XMH2P**0.5D0
26591 S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
26592 C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
26593 IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
26594 IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
26595 SA = SIN(ALP)
26596 CA = COS(ALP)
26597 SQBMA = (SINB*CA - COSB*SA)**2
26598 130 XIN = 1D0
26599 140 CONTINUE
26600
26601 RETURN
26602 END
26603
26604C*********************************************************************
26605
26606*$ CREATE PYGFXX.FOR
26607*COPY PYGFXX
26608C...PYGFXX
26609C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
26610
26611 SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
26612 &STOP1,STOP2)
26613
26614C...Double precision and integer declarations.
26615 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26616 INTEGER PYK,PYCHGE,PYCOMP
26617
26618C...Local variables.
26619 DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
26620 &VH3T(2,2),VH3B(2,2),
26621 &HMIX(2,2),AL(2,2),XM2(2,2)
26622
26623C...Statement function.
26624 G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
26625
26626 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
26627 XMQ2 = XMQ**2
26628 XMUR2 = XMUR**2
26629 XMDL2 = XMDL**2
26630 TANBA = TANB
26631 SINBA = TANBA/(TANBA**2+1D0)**0.5D0
26632 COSBA = SINBA/TANBA
26633
26634 SINB = TANB/(TANB**2+1D0)**0.5D0
26635 COSB = SINB/TANB
26636 PI = 3.14159D0
26637 G2 = (0.0336D0*4D0*PI)**0.5D0
26638 G12 = (0.0101D0*4D0*PI)
26639 G1 = G12**0.5D0
26640 XMZ = 91.18D0
26641 V = 174.1D0
26642 MW = (G2**2*V**2/2D0)**0.5D0
26643 ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
26644
26645 XMB = 3D0
26646 IF(XMQ.GT.XMUR) XMST = XMQ
26647 IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
26648
26649 XMSUT = (XMST**2 + XMT**2)**0.5D0
26650
26651 IF(XMQ.GT.XMDL) XMSB = XMQ
26652 IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
26653
26654 XMSUB = (XMSB**2 + XMB**2)**0.5D0
26655
26656 TT = LOG(XMSUT**2/XMT**2)
26657 TB = LOG(XMSUB**2/XMT**2)
26658
26659 RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26660 HT = RXMT/(174.1D0*SINB)
26661 HTST = RXMT/174.1D0
26662 HB = XMB/174.1D0/COSB
26663 G32 = ALP3*4D0*PI
26664 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
26665 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
26666 AL2 = 3D0/8D0/PI**2*HT**2
26667 BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
26668 ALST = 3D0/8D0/PI**2*HTST**2
26669 AL1 = 3D0/8D0/PI**2*HB**2
26670
26671 AL(1,1) = AL1
26672 AL(1,2) = (AL2+AL1)/2D0
26673 AL(2,1) = (AL2+AL1)/2D0
26674 AL(2,2) = AL2
26675
26676 XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
26677 XMT2 = SQRT(XMT4)
26678 XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
26679 XMBOT2 = SQRT(XMBOT4)
26680
26681 IF(XMA.GT.XMT) THEN
26682 VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
26683 & LOG(XMT**2/XMA**2))
26684 H1I = VI* COSBA
26685 H2I = VI*SINBA
26686 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
26687 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
26688 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
26689 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
26690 ELSE
26691 VI = 174.1D0
26692 H1I = VI*COSB
26693 H2I = VI*SINB
26694 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
26695 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
26696 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
26697 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
26698 ENDIF
26699
26700 TANBST = H2T/H1T
26701 SINBT = TANBST/(1D0+TANBST**2)**0.5D0
26702 COSBT = SINBT/TANBST
26703
26704 TANBSB = H2B/H1B
26705 SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
26706 COSBB = SINBB/TANBSB
26707
26708 STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26709 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26710 &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26711 &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
26712 STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26713 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26714 &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26715 &XMQ2 - XMUR2)**2*0.25D0
26716 &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
26717 IF(STOP22.LT.0D0) GOTO 120
26718 SBOT12 = (XMQ2 + XMDL2)*0.5D0
26719 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26720 &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26721 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26722 SBOT22 = (XMQ2 + XMDL2)*0.5D0
26723 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26724 &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26725 &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26726 IF(SBOT22.LT.0D0) GOTO 120
26727
26728 STOP1 = STOP12**0.5D0
26729 STOP2 = STOP22**0.5D0
26730 SBOT1 = SBOT12**0.5D0
26731 SBOT2 = SBOT22**0.5D0
26732
26733 VH1(1,1) = 1D0/TANBST
26734 VH1(2,1) = -1D0
26735 VH1(1,2) = -1D0
26736 VH1(2,2) = TANBST
26737 VH2(1,1) = TANBST
26738 VH2(1,2) = -1D0
26739 VH2(2,1) = -1D0
26740 VH2(2,2) = 1D0/TANBST
26741
26742CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26743C...D-TERMS
26744CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26745 STW=0.2320D0
26746
26747 F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
26748 &LOG(STOP1/STOP2)
26749 &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
26750 &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
26751
26752 F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
26753 &LOG(SBOT1/SBOT2)
26754 &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
26755 &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
26756
26757 F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
26758 &(-0.5D0*LOG(STOP12/STOP22)
26759 &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
26760 &G(STOP12,STOP22))
26761
26762 F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
26763 &(0.5D0*LOG(SBOT12/SBOT22)
26764 &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
26765 &G(SBOT12,SBOT22))
26766
26767 VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
26768 &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
26769 &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
26770 &LOG(SBOT1**2/SBOT2**2)) +
26771 &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
26772 &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
26773
26774 VH3T(1,1) =
26775 &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
26776 &-STOP2**2))**2*G(STOP12,STOP22)
26777
26778 VH3B(1,1)=VH3B(1,1)+
26779 &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
26780
26781 VH3T(1,1) = VH3T(1,1) +
26782 &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
26783
26784 VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
26785 &(XMQ2+XMT2)/(XMUR2+XMT2))
26786 &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
26787 &LOG(STOP1**2/STOP2**2)) +
26788 &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
26789 &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
26790
26791 VH3B(2,2) =
26792 &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
26793 &-SBOT2**2))**2*G(SBOT12,SBOT22)
26794
26795 VH3T(2,2)=VH3T(2,2)+
26796 &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
26797
26798 VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
26799
26800 VH3T(1,2) = -
26801 &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
26802 &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
26803 &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
26804
26805 VH3B(1,2) =
26806 &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
26807 &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
26808 &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
26809
26810 VH3T(1,2)=VH3T(1,2) +
26811 &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
26812
26813 VH3B(1,2)=VH3B(1,2)
26814 &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
26815
26816 VH3T(2,1) = VH3T(1,2)
26817 VH3B(2,1) = VH3B(1,2)
26818
26819 TQ = LOG((XMQ2 + XMT2)/XMT2)
26820 TU = LOG((XMUR2+XMT2)/XMT2)
26821 TQD = LOG((XMQ2 + XMB**2)/XMB**2)
26822 TD = LOG((XMDL2+XMB**2)/XMB**2)
26823
26824 DO 110 I = 1,2
26825 DO 100 J = 1,2
26826
26827 VH(I,J) =
26828 & 6D0/(8D0*PI**2*(H1T**2+H2T**2))
26829 & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
26830 & 6D0/(8D0*PI**2*(H1B**2+H2B**2))
26831 & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
26832
26833 100 CONTINUE
26834 110 CONTINUE
26835
26836 GOTO 150
26837 120 DO 140 I =1,2
26838 DO 130 J = 1,2
26839 VH(I,J) = -1D+15
26840 130 CONTINUE
26841 140 CONTINUE
26842
26843 150 CONTINUE
26844
26845 RETURN
26846 END
26847
26848C*********************************************************************
26849
26850*$ CREATE PYFINT.FOR
26851*COPY PYFINT
26852C...PYFINT
26853C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26854
26855 FUNCTION PYFINT(A,B,C)
26856
26857C...Double precision and integer declarations.
26858 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26859 INTEGER PYK,PYCHGE,PYCOMP
26860C...Commonblock.
26861 COMMON/PYINTS/XXM(20)
26862 SAVE/PYINTS/
26863
26864C...Local variables.
26865 EXTERNAL PYFISB
26866
26867 XXM(1)=A
26868 XXM(2)=B
26869 XXM(3)=C
26870 XLO=0D0
26871 XHI=1D0
26872 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
26873
26874 RETURN
26875 END
26876
26877C*********************************************************************
26878
26879*$ CREATE PYFISB.FOR
26880*COPY PYFISB
26881C...PYFISB
26882C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
26883
26884 FUNCTION PYFISB(X)
26885
26886C...Double precision and integer declarations.
26887 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26888 INTEGER PYK,PYCHGE,PYCOMP
26889C...Commonblock.
26890 COMMON/PYINTS/XXM(20)
26891 SAVE/PYINTS/
26892
26893 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
26894 &(X*(XXM(2)-XXM(3))+XXM(3)))
26895
26896 RETURN
26897 END
26898
26899C*********************************************************************
26900
26901*$ CREATE PYSFDC.FOR
26902*COPY PYSFDC
26903C...PYSFDC
26904C...Calculates decays of sfermions.
26905
26906 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
26907
26908C...Double precision and integer declarations.
26909 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26910 INTEGER PYK,PYCHGE,PYCOMP
26911C...Parameter statement to help give large particle numbers.
26912 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
26913C...Commonblocks.
26914 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26915 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26916 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
26917 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
26918 &SFMIX(16,4)
26919 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
26920
26921C...Local variables.
26922 INTEGER KFIN,KCIN
26923 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
26924 &XMZ2,AXMJ,AXMI
26925 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
26926 DOUBLE PRECISION PYLAMF,XL
26927 DOUBLE PRECISION TANW,XW,AEM,C1,AS
26928 DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
26929 DOUBLE PRECISION CH1,CH2,CH3,CH4
26930 DOUBLE PRECISION XMBOT,XMTOP
26931 DOUBLE PRECISION XLAM(0:200)
26932 INTEGER IDLAM(200,3)
26933 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
26934 DOUBLE PRECISION SR2
26935 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
26936 DOUBLE PRECISION CW
26937 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
26938 DOUBLE PRECISION COSA,SINA,TANB
26939 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
26940 DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
26941 INTEGER IG,KF1,KF2,ILR2,IDP
26942 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
26943 DATA IGG/23,25,35,36/
26944 DATA PI/3.141592654D0/
26945 DATA SR2/1.4142136D0/
26946 DATA KFNCHI/1000022,1000023,1000025,1000035/
26947 DATA KFCCHI/1000024,1000037/
26948
26949C...COUNT THE NUMBER OF DECAY MODES
26950 LKNT=0
26951
26952C...NO NU_R DECAYS
26953 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
26954 &KFIN.EQ.KSUSY2+16) RETURN
26955
26956 XMW=PMAS(24,1)
26957 XMW2=XMW**2
26958 XMZ=PMAS(23,1)
26959 XMZ2=XMZ**2
26960 XW=PARU(102)
26961 TANW = SQRT(XW/(1D0-XW))
26962 CW=SQRT(1D0-XW)
26963
26964C...KCIN
26965 KCIN=PYCOMP(KFIN)
26966C...ILR is 1 for left and 2 for right.
26967 ILR=KFIN/KSUSY1
26968C...IFL is matching non-SUSY flavour.
26969 IFL=MOD(KFIN,KSUSY1)
26970C...IDU is weak isospin, 1 for down and 2 for up.
26971 IDU=2-MOD(IFL,2)
26972
26973 XMI=PMAS(KCIN,1)
26974 XMI2=XMI**2
26975 AEM=PYALEM(XMI2)
26976 AS =PYALPS(XMI2)
26977 C1=AEM/XW
26978 XMI3=XMI**3
26979 EI=KCHG(IFL,1)/3D0
26980
26981 XMBOT=3D0
26982 XMTOP=PYRNMT(PMAS(6,1))
26983 XMBOT=0D0
26984
26985 TANB=RMSS(5)
26986 BETA=ATAN(TANB)
26987 ALFA=RMSS(18)
26988 CBETA=COS(BETA)
26989 SBETA=TANB*CBETA
26990 SINA=SIN(ALFA)
26991 COSA=COS(ALFA)
26992 XMU=-RMSS(4)
26993 ATRIT=RMSS(16)
26994 ATRIB=RMSS(15)
26995 ATRIL=RMSS(17)
26996
26997C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
26998
26999 IF(IMSS(11).EQ.1) THEN
27000 XMP=RMSS(28)
27001 IDG=39+KSUSY1
27002 XMGR=PMAS(PYCOMP(IDG),1)
27003 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27004 IF(IFL.EQ.5) THEN
27005 XMF=XMBOT
27006 ELSEIF(IFL.EQ.6) THEN
27007 XMF=XMTOP
27008 ELSE
27009 XMF=PMAS(IFL,1)
27010 ENDIF
27011 IF(XMI.GT.XMGR+XMF) THEN
27012 LKNT=LKNT+1
27013 IDLAM(LKNT,1)=IDG
27014 IDLAM(LKNT,2)=IFL
27015 IDLAM(LKNT,3)=0
27016 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
27017 ENDIF
27018 ENDIF
27019
27020C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
27021
27022C...CHARGED DECAYS:
27023 DO 100 IX=1,2
27024C...DI -> U CHI1-,CHI2-
27025 IF(IDU.EQ.1) THEN
27026 XMFP=PMAS(IFL+1,1)
27027 XMF =PMAS(IFL,1)
27028C...UI -> D CHI1+,CHI2+
27029 ELSE
27030 XMFP=PMAS(IFL-1,1)
27031 XMF =PMAS(IFL,1)
27032 ENDIF
27033 XMJ=SMW(IX)
27034 AXMJ=ABS(XMJ)
27035 IF(XMI.GE.AXMJ+XMFP) THEN
27036 XMA2=XMJ**2
27037 XMB2=XMFP**2
27038 IF(IDU.EQ.2) THEN
27039 IF(IFL.EQ.6) THEN
27040 XMFP=XMBOT
27041 XMF =XMTOP
27042 ELSEIF(IFL.LT.6) THEN
27043 XMF=0D0
27044 XMFP=0D0
27045 ENDIF
27046 BL=VMIX(IX,1)
27047 AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
27048 BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
27049 AR=0D0
27050 ELSE
27051 IF(IFL.EQ.5) THEN
27052 XMF =XMBOT
27053 XMFP=XMTOP
27054 ELSEIF(IFL.LT.5) THEN
27055 XMF=0D0
27056 XMFP=0D0
27057 ENDIF
27058 BL=UMIX(IX,1)
27059 AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
27060 BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
27061 AR=0D0
27062 ENDIF
27063
27064 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
27065 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
27066 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
27067 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
27068 AL=ALP
27069 BL=BLP
27070 AR=ARP
27071 BR=BRP
27072
27073C...F1 -> F` CHI
27074 IF(ILR.EQ.1) THEN
27075 CA=AL
27076 CB=BL
27077C...F2 -> F` CHI
27078 ELSE
27079 CA=AR
27080 CB=BR
27081 ENDIF
27082 LKNT=LKNT+1
27083 XL=PYLAMF(XMI2,XMA2,XMB2)
27084C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27085 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27086 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
27087 IDLAM(LKNT,3)=0
27088 IF(IDU.EQ.1) THEN
27089 IDLAM(LKNT,1)=-KFCCHI(IX)
27090 IDLAM(LKNT,2)=IFL+1
27091 ELSE
27092 IDLAM(LKNT,1)=KFCCHI(IX)
27093 IDLAM(LKNT,2)=IFL-1
27094 ENDIF
27095 ENDIF
27096 100 CONTINUE
27097
27098C...NEUTRAL DECAYS
27099 DO 110 IX=1,4
27100C...DI -> D CHI10
27101 XMF=PMAS(IFL,1)
27102 XMJ=SMZ(IX)
27103 AXMJ=ABS(XMJ)
27104 IF(XMI.GE.AXMJ+XMF) THEN
27105 XMA2=XMJ**2
27106 XMB2=XMF**2
27107 IF(IDU.EQ.1) THEN
27108 IF(IFL.EQ.5) THEN
27109 XMF=XMBOT
27110 ELSEIF(IFL.LT.5) THEN
27111 XMF=0D0
27112 ENDIF
27113 BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
27114 AL=XMF*ZMIX(IX,3)/XMW/CBETA
27115 AR=-2D0*EI*TANW*ZMIX(IX,1)
27116 BR=AL
27117 ELSE
27118 IF(IFL.EQ.6) THEN
27119 XMF=XMTOP
27120 ELSEIF(IFL.LT.5) THEN
27121 XMF=0D0
27122 ENDIF
27123 BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
27124 AL=XMF*ZMIX(IX,4)/XMW/SBETA
27125 AR=-2D0*EI*TANW*ZMIX(IX,1)
27126 BR=AL
27127 ENDIF
27128
27129 ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
27130 BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
27131 ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
27132 BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
27133 AL=ALP
27134 BL=BLP
27135 AR=ARP
27136 BR=BRP
27137
27138C...F1 -> F CHI
27139 IF(ILR.EQ.1) THEN
27140 CA=AL
27141 CB=BL
27142C...F2 -> F CHI
27143 ELSE
27144 CA=AR
27145 CB=BR
27146 ENDIF
27147 LKNT=LKNT+1
27148 XL=PYLAMF(XMI2,XMA2,XMB2)
27149C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27150 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27151 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27152 IDLAM(LKNT,1)=KFNCHI(IX)
27153 IDLAM(LKNT,2)=IFL
27154 IDLAM(LKNT,3)=0
27155 ENDIF
27156 110 CONTINUE
27157
27158C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
27159C...IG=23,25,35,36
27160 DO 120 II=1,4
27161 IG=IGG(II)
27162 IF(ILR.EQ.1) GOTO 120
27163 XMB=PMAS(IG,1)
27164 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
27165 IF(XMI.LT.XMSF1+XMB) GOTO 120
27166 IF(IG.EQ.23) THEN
27167 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
27168 BR=EI*XW/CW
27169 BLR=0D0
27170 ELSEIF(IG.EQ.25) THEN
27171 IF(IFL.EQ.5) THEN
27172 XMF=XMBOT
27173 ELSEIF(IFL.EQ.6) THEN
27174 XMF=XMTOP
27175 ELSEIF(IFL.LT.5) THEN
27176 XMF=0D0
27177 ELSE
27178 XMF=PMAS(IFL,1)
27179 ENDIF
27180 IF(IDU.EQ.2) THEN
27181 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27182 & XMF**2/XMW*COSA/SBETA
27183 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27184 & XMF**2/XMW*COSA/SBETA
27185 ELSE
27186 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27187 & XMF**2/XMW*(-SINA)/CBETA
27188 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27189 & XMF**2/XMW*(-SINA)/CBETA
27190 ENDIF
27191 IF(IFL.EQ.5) THEN
27192 AT=ATRIB
27193 ELSEIF(IFL.EQ.6) THEN
27194 AT=ATRIT
27195 ELSEIF(IFL.EQ.15) THEN
27196 AT=ATRIL
27197 ELSE
27198 AT=0D0
27199 ENDIF
27200 IF(IDU.EQ.2) THEN
27201 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
27202 & AT*COSA)
27203 ELSE
27204 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
27205 & AT*SINA)
27206 ENDIF
27207 BL=GHLL
27208 BR=GHRR
27209 BLR=-GHLR
27210 ELSEIF(IG.EQ.35) THEN
27211 IF(IFL.EQ.5) THEN
27212 XMF=XMBOT
27213 ELSEIF(IFL.EQ.6) THEN
27214 XMF=XMTOP
27215 ELSEIF(IFL.LT.5) THEN
27216 XMF=0D0
27217 ELSE
27218 XMF=PMAS(IFL,1)
27219 ENDIF
27220 IF(IDU.EQ.2) THEN
27221 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27222 & XMF**2/XMW*SINA/SBETA
27223 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27224 & XMF**2/XMW*SINA/SBETA
27225 ELSE
27226 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27227 & XMF**2/XMW*COSA/CBETA
27228 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27229 & XMF**2/XMW*COSA/CBETA
27230 ENDIF
27231 IF(IFL.EQ.5) THEN
27232 AT=ATRIB
27233 ELSEIF(IFL.EQ.6) THEN
27234 AT=ATRIT
27235 ELSEIF(IFL.EQ.15) THEN
27236 AT=ATRIL
27237 ELSE
27238 AT=0D0
27239 ENDIF
27240 IF(IDU.EQ.2) THEN
27241 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
27242 & AT*SINA)
27243 ELSE
27244 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
27245 & AT*COSA)
27246 ENDIF
27247 BL=GHLL
27248 BR=GHRR
27249 BLR=GHLR
27250 ELSEIF(IG.EQ.36) THEN
27251 GHLL=0D0
27252 GHRR=0D0
27253 IF(IFL.EQ.5) THEN
27254 XMF=XMBOT
27255 ELSEIF(IFL.EQ.6) THEN
27256 XMF=XMTOP
27257 ELSEIF(IFL.LT.5) THEN
27258 XMF=0D0
27259 ELSE
27260 XMF=PMAS(IFL,1)
27261 ENDIF
27262 IF(IFL.EQ.5) THEN
27263 AT=ATRIB
27264 ELSEIF(IFL.EQ.6) THEN
27265 AT=ATRIT
27266 ELSEIF(IFL.EQ.15) THEN
27267 AT=ATRIL
27268 ELSE
27269 AT=0D0
27270 ENDIF
27271 IF(IDU.EQ.2) THEN
27272 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
27273 ELSE
27274 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
27275 ENDIF
27276 BL=GHLL
27277 BR=GHRR
27278 BLR=GHLR
27279 ENDIF
27280 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
27281 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
27282 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
27283 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27284 LKNT=LKNT+1
27285 IF(IG.EQ.23) THEN
27286 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27287 ELSE
27288 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
27289 ENDIF
27290 IDLAM(LKNT,3)=0
27291 IDLAM(LKNT,1)=KFIN-KSUSY1
27292 IDLAM(LKNT,2)=IG
27293 120 CONTINUE
27294
27295C...SF -> SF' + W
27296 XMB=PMAS(24,1)
27297 IF(MOD(IFL,2).EQ.0) THEN
27298 KF1=KSUSY1+IFL-1
27299 ELSE
27300 KF1=KSUSY1+IFL+1
27301 ENDIF
27302 KF2=KF1+KSUSY1
27303 XMSF1=PMAS(PYCOMP(KF1),1)
27304 XMSF2=PMAS(PYCOMP(KF2),1)
27305 IF(XMI.GT.XMB+XMSF1) THEN
27306 IF(MOD(IFL,2).EQ.0) THEN
27307 IF(ILR.EQ.1) THEN
27308 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
27309 ELSE
27310 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
27311 ENDIF
27312 ELSE
27313 IF(ILR.EQ.1) THEN
27314 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
27315 ELSE
27316 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
27317 ENDIF
27318 ENDIF
27319 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27320 LKNT=LKNT+1
27321 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27322 IDLAM(LKNT,3)=0
27323 IDLAM(LKNT,1)=KF1
27324 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27325 ENDIF
27326 IF(XMI.GT.XMB+XMSF2) THEN
27327 IF(MOD(IFL,2).EQ.0) THEN
27328 IF(ILR.EQ.1) THEN
27329 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
27330 ELSE
27331 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
27332 ENDIF
27333 ELSE
27334 IF(ILR.EQ.1) THEN
27335 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
27336 ELSE
27337 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
27338 ENDIF
27339 ENDIF
27340 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
27341 LKNT=LKNT+1
27342 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27343 IDLAM(LKNT,3)=0
27344 IDLAM(LKNT,1)=KF2
27345 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27346 ENDIF
27347
27348C...SF -> SF' + HC
27349 XMB=PMAS(37,1)
27350 IF(MOD(IFL,2).EQ.0) THEN
27351 KF1=KSUSY1+IFL-1
27352 ELSE
27353 KF1=KSUSY1+IFL+1
27354 ENDIF
27355 KF2=KF1+KSUSY1
27356 XMSF1=PMAS(PYCOMP(KF1),1)
27357 XMSF2=PMAS(PYCOMP(KF2),1)
27358 IF(XMI.GT.XMB+XMSF1) THEN
27359 XMF=0D0
27360 XMFP=0D0
27361 AT=0D0
27362 AB=0D0
27363 IF(MOD(IFL,2).EQ.0) THEN
27364C...T1-> B1 HC
27365 IF(ILR.EQ.1) THEN
27366 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
27367 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
27368 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
27369 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
27370C...T2-> B1 HC
27371 ELSE
27372 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
27373 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
27374 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
27375 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
27376 ENDIF
27377 IF(IFL.EQ.6) THEN
27378 XMF=XMTOP
27379 XMFP=XMBOT
27380 AT=ATRIT
27381 AB=ATRIB
27382 ENDIF
27383 ELSE
27384C...B1 -> T1 HC
27385 IF(ILR.EQ.1) THEN
27386 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
27387 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
27388 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
27389 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
27390C...B2-> T1 HC
27391 ELSE
27392 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
27393 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
27394 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
27395 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
27396 ENDIF
27397 IF(IFL.EQ.5) THEN
27398 XMF=XMTOP
27399 XMFP=XMBOT
27400 AT=ATRIT
27401 AB=ATRIB
27402 ENDIF
27403 ENDIF
27404 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27405 LKNT=LKNT+1
27406 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27407 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27408 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27409 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27410 IDLAM(LKNT,3)=0
27411 IDLAM(LKNT,1)=KF1
27412 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27413 ENDIF
27414 IF(XMI.GT.XMB+XMSF2) THEN
27415 XMF=0D0
27416 XMFP=0D0
27417 AT=0D0
27418 AB=0D0
27419 IF(MOD(IFL,2).EQ.0) THEN
27420C...T1-> B2 HC
27421 IF(ILR.EQ.1) THEN
27422 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
27423 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
27424 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
27425 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
27426C...T2-> B2 HC
27427 ELSE
27428 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
27429 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
27430 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
27431 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
27432 ENDIF
27433 IF(IFL.EQ.6) THEN
27434 XMF=XMTOP
27435 XMFP=XMBOT
27436 AT=ATRIT
27437 AB=ATRIB
27438 ENDIF
27439 ELSE
27440C...B1 -> T2 HC
27441 IF(ILR.EQ.1) THEN
27442 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
27443 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
27444 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
27445 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
27446C...B2-> T2 HC
27447 ELSE
27448 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
27449 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
27450 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
27451 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
27452 ENDIF
27453 IF(IFL.EQ.5) THEN
27454 XMF=XMTOP
27455 XMFP=XMBOT
27456 AT=ATRIT
27457 AB=ATRIB
27458 ENDIF
27459 ENDIF
27460 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27461 LKNT=LKNT+1
27462 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27463 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27464 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27465 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27466 IDLAM(LKNT,3)=0
27467 IDLAM(LKNT,1)=KF2
27468 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27469 ENDIF
27470
27471C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
27472
27473 IF(IFL.LE.6) THEN
27474 XMFP=0D0
27475 XMF=0D0
27476 IF(IFL.EQ.6) XMF=PMAS(6,1)
27477 IF(IFL.EQ.5) XMF=PMAS(5,1)
27478 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
27479 AXMJ=ABS(XMJ)
27480 IF(XMI.GE.AXMJ+XMF) THEN
27481 AL=-SFMIX(IFL,2)
27482 BL=SFMIX(IFL,1)
27483 AR=-SFMIX(IFL,4)
27484 BR=SFMIX(IFL,3)
27485C...F1 -> F CHI
27486 IF(ILR.EQ.1) THEN
27487 CA=AL
27488 CB=BL
27489C...F2 -> F CHI
27490 ELSE
27491 CA=AR
27492 CB=BR
27493 ENDIF
27494 LKNT=LKNT+1
27495 XMA2=XMJ**2
27496 XMB2=XMF**2
27497 XL=PYLAMF(XMI2,XMA2,XMB2)
27498 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27499 & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27500 IDLAM(LKNT,1)=KSUSY1+21
27501 IDLAM(LKNT,2)=IFL
27502 IDLAM(LKNT,3)=0
27503 ENDIF
27504 ENDIF
27505
27506C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
27507 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
27508 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
27509C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
27510C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
27511C...M*M = C1**2 * G**2/(16PI**2)
27512C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
27513 LKNT=LKNT+1
27514 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
27515 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
27516 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
27517 IDLAM(LKNT,1)=KSUSY1+22
27518 IDLAM(LKNT,2)=4
27519 IDLAM(LKNT,3)=0
27520 ENDIF
27521
27522 IKNT=LKNT
27523 XLAM(0)=0D0
27524 DO 130 I=1,IKNT
27525 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27526 XLAM(0)=XLAM(0)+XLAM(I)
27527 130 CONTINUE
27528 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
27529
27530 RETURN
27531 END
27532
27533C*********************************************************************
27534
27535*$ CREATE PYGLUI.FOR
27536*COPY PYGLUI
27537C...PYGLUI
27538C...Calculates gluino decay modes.
27539
27540 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
27541
27542C...Double precision and integer declarations.
27543 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27544 INTEGER PYK,PYCHGE,PYCOMP
27545C...Parameter statement to help give large particle numbers.
27546 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27547C...Commonblocks.
27548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27550 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27551 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27552 &SFMIX(16,4)
27553 COMMON/PYINTS/XXM(20)
27554 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
27555
27556C...Local variables.
27557 INTEGER KFIN,KCIN,KF
27558 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
27559 &XMZ,XMZ2,AXMJ,AXMI
27560 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
27561 DOUBLE PRECISION C1L,C1R,D1L,D1R
27562 DOUBLE PRECISION C2L,C2R,D2L,D2R
27563 DOUBLE PRECISION PYLAMF,XL
27564 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
27565 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
27566 DOUBLE PRECISION ALFA,BETA
27567 DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
27568 DOUBLE PRECISION XLAM(0:200)
27569 INTEGER IDLAM(200,3)
27570 INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
27571 DOUBLE PRECISION SR2
27572 DOUBLE PRECISION GAM
27573 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
27574 DOUBLE PRECISION PYGAUS
27575 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
27576 DOUBLE PRECISION PREC
27577 INTEGER KFNCHI(4),KFCCHI(2)
27578 DATA PI/3.141592654D0/
27579 DATA SR2/1.4142136D0/
27580 DATA PREC/1D-2/
27581 DATA KFNCHI/1000022,1000023,1000025,1000035/
27582 DATA KFCCHI/1000024,1000037/
27583
27584C...COUNT THE NUMBER OF DECAY MODES
27585 LKNT=0
27586 IF(KFIN.NE.KSUSY1+21) RETURN
27587 KCIN=PYCOMP(KFIN)
27588
27589 XMW=PMAS(24,1)
27590 XMW2=XMW**2
27591 XMZ=PMAS(23,1)
27592 XMZ2=XMZ**2
27593 XW=PARU(102)
27594 TANW = SQRT(XW/(1D0-XW))
27595
27596 XMI=PMAS(KCIN,1)
27597 AXMI=ABS(XMI)
27598 XMI2=XMI**2
27599 AEM=PYALEM(XMI2)
27600 AS =PYALPS(XMI2)
27601 C1=AEM/XW
27602 XMI3=XMI**3
27603 BETA=ATAN(RMSS(5))
27604
27605C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
27606
27607 IF(IMSS(11).EQ.1) THEN
27608 XMP=RMSS(28)
27609 IDG=39+KSUSY1
27610 XMGR=PMAS(PYCOMP(IDG),1)
27611 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27612 IF(AXMI.GT.XMGR) THEN
27613 LKNT=LKNT+1
27614 IDLAM(LKNT,1)=IDG
27615 IDLAM(LKNT,2)=21
27616 IDLAM(LKNT,3)=0
27617 XLAM(LKNT)=XFAC
27618 ENDIF
27619 ENDIF
27620
27621C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
27622
27623 DO 110 IFL=1,6
27624 DO 100 ILR=1,2
27625 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
27626 AXMJ=ABS(XMJ)
27627 XMF=PMAS(IFL,1)
27628 IDU=3-(1+MOD(IFL,2))
27629 IF(XMI.GE.AXMJ+XMF) THEN
27630 AL=SFMIX(IFL,1)
27631 BL=SFMIX(IFL,2)
27632 AR=SFMIX(IFL,3)
27633 BR=SFMIX(IFL,4)
27634C...F1 -> F CHI
27635 IF(ILR.EQ.1) THEN
27636 CA=AL
27637 CB=BL
27638C...F2 -> F CHI
27639 ELSE
27640 CA=AR
27641 CB=BR
27642 ENDIF
27643 LKNT=LKNT+1
27644 XMA2=XMJ**2
27645 XMB2=XMF**2
27646 XL=PYLAMF(XMI2,XMA2,XMB2)
27647 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
27648 & (CA**2+CB**2)+4D0*CA*CB*XMI*XMF)
27649 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
27650 IDLAM(LKNT,2)=-IFL
27651 IDLAM(LKNT,3)=0
27652 LKNT=LKNT+1
27653 XLAM(LKNT)=XLAM(LKNT-1)
27654 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27655 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27656 IDLAM(LKNT,3)=0
27657 ENDIF
27658 100 CONTINUE
27659 110 CONTINUE
27660
27661C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
27662C...GLUINO -> NI Q QBAR
27663 DO 160 IX=1,4
27664 XMJ=SMZ(IX)
27665 AXMJ=ABS(XMJ)
27666 IF(XMI.GE.AXMJ) THEN
27667 XXM(1)=0D0
27668 XXM(2)=XMJ
27669 XXM(3)=0D0
27670 XXM(4)=XMI
27671 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
27672 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
27673 XXM(7)=1D6
27674 XXM(8)=0D0
27675 XXM(9)=0D0
27676 XXM(10)=0D0
27677 S12MIN=0D0
27678 S12MAX=(XMI-AXMJ)**2
27679C...D-TYPE QUARKS
27680 XXM(11)=0D0
27681 XXM(12)=0D0
27682 XXM(13)=1D0
27683 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27684 XXM(15)=1D0
27685 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
27686 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
27687 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
27688 LKNT=LKNT+1
27689 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27690 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27691 IDLAM(LKNT,1)=KFNCHI(IX)
27692 IDLAM(LKNT,2)=1
27693 IDLAM(LKNT,3)=-1
27694 ENDIF
27695 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
27696 LKNT=LKNT+1
27697 XLAM(LKNT)=XLAM(LKNT-1)
27698 IDLAM(LKNT,1)=KFNCHI(IX)
27699 IDLAM(LKNT,2)=3
27700 IDLAM(LKNT,3)=-3
27701 ENDIF
27702 120 CONTINUE
27703 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
27704 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
27705 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
27706 LKNT=LKNT+1
27707 XLAM(LKNT)=GAM
27708 IDLAM(LKNT,1)=KFNCHI(IX)
27709 IDLAM(LKNT,2)=5
27710 IDLAM(LKNT,3)=-5
27711 ENDIF
27712C...U-TYPE QUARKS
27713 130 CONTINUE
27714 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
27715 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
27716 XXM(13)=1D0
27717 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27718 XXM(15)=1D0
27719 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
27720 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
27721 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
27722 LKNT=LKNT+1
27723 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27724 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27725 IDLAM(LKNT,1)=KFNCHI(IX)
27726 IDLAM(LKNT,2)=2
27727 IDLAM(LKNT,3)=-2
27728 ENDIF
27729 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
27730 LKNT=LKNT+1
27731 XLAM(LKNT)=XLAM(LKNT-1)
27732 IDLAM(LKNT,1)=KFNCHI(IX)
27733 IDLAM(LKNT,2)=4
27734 IDLAM(LKNT,3)=-4
27735 ENDIF
27736 140 CONTINUE
27737C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
27738C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
27739 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
27740 XMF=PMAS(6,1)
27741 IF(XMI.GE.AXMJ+2D0*XMF) THEN
27742 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
27743 LKNT=LKNT+1
27744 XLAM(LKNT)=GAM
27745 IDLAM(LKNT,1)=KFNCHI(IX)
27746 IDLAM(LKNT,2)=6
27747 IDLAM(LKNT,3)=-6
27748 ENDIF
27749 150 CONTINUE
27750 ENDIF
27751 160 CONTINUE
27752
27753C...GLUINO -> CI Q QBAR'
27754 DO 190 IX=1,2
27755 XMJ=SMW(IX)
27756 AXMJ=ABS(XMJ)
27757 IF(XMI.GE.AXMJ) THEN
27758 S12MIN=0D0
27759 S12MAX=(AXMI-AXMJ)**2
27760 XXM(1)=0D0
27761 XXM(2)=XMJ
27762 XXM(3)=0D0
27763 XXM(4)=XMI
27764 XXM(5)=0D0
27765 XXM(6)=0D0
27766 XXM(9)=1D6
27767 XXM(10)=0D0
27768 XXM(7)=UMIX(IX,1)*SR2
27769 XXM(8)=VMIX(IX,1)*SR2
27770 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
27771 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
27772 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
27773 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
27774 LKNT=LKNT+1
27775 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
27776 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
27777 IDLAM(LKNT,1)=KFCCHI(IX)
27778 IDLAM(LKNT,2)=1
27779 IDLAM(LKNT,3)=-2
27780 LKNT=LKNT+1
27781 XLAM(LKNT)=XLAM(LKNT-1)
27782 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27783 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27784 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27785 ENDIF
27786 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
27787 LKNT=LKNT+1
27788 XLAM(LKNT)=XLAM(LKNT-1)
27789 IDLAM(LKNT,1)=KFCCHI(IX)
27790 IDLAM(LKNT,2)=3
27791 IDLAM(LKNT,3)=-4
27792 LKNT=LKNT+1
27793 XLAM(LKNT)=XLAM(LKNT-1)
27794 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27795 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27796 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27797 ENDIF
27798 170 CONTINUE
27799
27800 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
27801 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
27802 XMF=PMAS(6,1)
27803 XMFP=PMAS(5,1)
27804 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
27805 CALL PYTBBC(IX,80,AXMI,GAM)
27806 LKNT=LKNT+1
27807 XLAM(LKNT)=GAM
27808 IDLAM(LKNT,1)=KFCCHI(IX)
27809 IDLAM(LKNT,2)=5
27810 IDLAM(LKNT,3)=-6
27811 LKNT=LKNT+1
27812 XLAM(LKNT)=XLAM(LKNT-1)
27813 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27814 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27815 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27816 ENDIF
27817 180 CONTINUE
27818 ENDIF
27819 190 CONTINUE
27820
27821 IKNT=LKNT
27822 XLAM(0)=0D0
27823 DO 200 I=1,IKNT
27824 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27825 XLAM(0)=XLAM(0)+XLAM(I)
27826 200 CONTINUE
27827 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
27828
27829 RETURN
27830 END
27831
27832C*********************************************************************
27833
27834*$ CREATE PYTBBN.FOR
27835*COPY PYTBBN
27836C...PYTBBN
27837C...Calculates the three-body decay of gluinos into
27838C...neutralinos and third generation fermions.
27839
27840 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
27841
27842C...Double precision and integer declarations.
27843 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27844 INTEGER PYK,PYCHGE,PYCOMP
27845C...Parameter statement to help give large particle numbers.
27846 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27847C...Commonblocks.
27848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27850 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27851 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27852 &SFMIX(16,4)
27853 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
27854
27855C...Local variables.
27856 EXTERNAL PYSIMP,PYLAMF
27857 INTEGER LIN,NN
27858 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
27859 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
27860 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
27861 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
27862 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
27863 DOUBLE PRECISION XLN1,XLN2,B1,B2
27864 DOUBLE PRECISION E,XMGLU,GAM
27865 DOUBLE PRECISION PYSIMP,PYLAMF
27866 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
27867 SAVE HRB,HLB,FLB,FRB
27868 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
27869 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
27870 SAVE HLT,HRT,FLT,FRT
27871 DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
27872 &FLD(4),FRD(4)
27873 SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
27874 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
27875 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
27876 SAVE AMSB,AMST
27877 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
27878 DOUBLE PRECISION ROT1(4,4)
27879 LOGICAL IFIRST
27880 SAVE IFIRST
27881 DATA IFIRST/.TRUE./
27882
27883 TANB=RMSS(5)
27884 SINB=TANB/SQRT(1D0+TANB**2)
27885 COSB=SINB/TANB
27886 XW=PARU(102)
27887 SINW=SQRT(XW)
27888 COSW=SQRT(1D0-XW)
27889 TANW=SINW/COSW
27890 AMW=PMAS(24,1)
27891 COSC=SFMIX(5,1)
27892 SINC=SFMIX(5,3)
27893 COSA=SFMIX(6,1)
27894 SINA=SFMIX(6,3)
27895 AMBOT=0D0
27896 AMTOP=PYRNMT(PMAS(6,1))
27897 W2=SQRT(2D0)
27898 FAKT1=AMBOT/W2/AMW/COSB
27899 FAKT2=AMTOP/W2/AMW/SINB
27900 IF(IFIRST) THEN
27901 DO 110 II=1,4
27902 AMN(II)=SMZ(II)
27903 DO 100 J=1,4
27904 ROT1(II,J)=0D0
27905 AN(II,J)=0D0
27906 100 CONTINUE
27907 110 CONTINUE
27908 ROT1(1,1)=COSW
27909 ROT1(1,2)=-SINW
27910 ROT1(2,1)=-ROT1(1,2)
27911 ROT1(2,2)=ROT1(1,1)
27912 ROT1(3,3)=COSB
27913 ROT1(3,4)=SINB
27914 ROT1(4,3)=-ROT1(3,4)
27915 ROT1(4,4)=ROT1(3,3)
27916 DO 140 II=1,4
27917 DO 130 J=1,4
27918 DO 120 JJ=1,4
27919 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
27920 120 CONTINUE
27921 130 CONTINUE
27922 140 CONTINUE
27923 DO 150 J=1,4
27924 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
27925 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27926 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
27927 & XW)*AN(J,2)/COSW
27928 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
27929 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
27930 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
27931 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
27932 FLU(J)=ZN(3)
27933 FRU(J)=ZN(2)
27934 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
27935 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27936 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
27937 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
27938 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
27939 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
27940 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
27941 FLD(J)=ZN(3)
27942 FRD(J)=ZN(2)
27943 150 CONTINUE
27944 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
27945 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
27946 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
27947 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
27948 IFIRST=.FALSE.
27949 ENDIF
27950
27951 IF(NINT(3D0*E).EQ.2) THEN
27952 HL=HLT(I)
27953 HR=HRT(I)
27954 FL=FLT(I)
27955 FR=FRT(I)
27956 COSD=SFMIX(6,1)
27957 SIND=SFMIX(6,3)
27958 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
27959 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
27960 XM=PMAS(6,1)
27961 ELSE
27962 HL=HLB(I)
27963 HR=HRB(I)
27964 FL=FLB(I)
27965 FR=FRB(I)
27966 COSD=SFMIX(5,1)
27967 SIND=SFMIX(5,3)
27968 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
27969 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
27970 XM=PMAS(5,1)
27971 ENDIF
27972 COSD2=COSD*COSD
27973 SIND2=SIND*SIND
27974 COS2D=COSD2-SIND2
27975 SIN2D=SIND*COSD*2D0
27976 HL2=HL*HL
27977 HR2=HR*HR
27978 FL2=FL*FL
27979 FR2=FR*FR
27980 FF=FL*FR
27981 HH=HL*HR
27982 HFL=HL*FL
27983 HFR=HR*FR
27984 HRFL=HR*FL
27985 HLFR=HL*FR
27986 XM2=XM*XM
27987 XMG=XMGLU
27988 XMG2=XMG*XMG
27989 ALPHAW=PYALEM(XMG2)
27990 ALPHAS=PYALPS(XMG2)
27991 XMR=AMN(I)
27992 XMR2=XMR*XMR
27993 XMQ4=XMG*XM2*XMR
27994 XM24=(XMG2+XM2)*(XM2+XMR2)
27995 SMIN=4D0*XM2
27996 SMAX=(XMG-ABS(XMR))**2
27997 XMQA=XMG2+2D0*XM2+XMR2
27998 DO 170 LIN=1,NN-1
27999 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28000 GRS=SBAR-XMQA
28001 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
28002 W=DSQRT(W)
28003 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
28004 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
28005 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
28006 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
28007 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
28008 & +2D0*(FF*SIND2-HH*COSD2))*W
28009 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
28010 & +4D0*HFL*XM*XMR)*XLN1
28011 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
28012 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
28013 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
28014 & +8D0*HFL*XMQ4*SIN2D)*B1
28015 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
28016 & +4D0*HFR*XMR*XM)*XLN2
28017 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
28018 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
28019 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
28020 & -8D0*HFR*XMQ4*SIN2D)*B2
28021 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
28022 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
28023 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
28024 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
28025 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
28026 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
28027 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
28028 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
28029 G(5)=(2D0*(HH*COSD2-FF*SIND2)
28030 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
28031 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
28032 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
28033 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
28034 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
28035 & +COS2D*XM*(SBAR+XMG2-XMR2))
28036 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
28037 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
28038 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
28039 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
28040 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
28041 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
28042 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
28043 SUMME(LIN)=0D0
28044 DO 160 J=0,6
28045 SUMME(LIN)=SUMME(LIN)+G(J)
28046 160 CONTINUE
28047 170 CONTINUE
28048 SUMME(0)=0D0
28049 SUMME(NN)=0D0
28050 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28051 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28052
28053 RETURN
28054 END
28055
28056C*********************************************************************
28057
28058*$ CREATE PYTBBC.FOR
28059*COPY PYTBBC
28060C...PYTBBC
28061C...Calculates the three-body decay of gluinos into
28062C...charginos and third generation fermions.
28063
28064 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
28065
28066C...Double precision and integer declarations.
28067 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28068 INTEGER PYK,PYCHGE,PYCOMP
28069C...Parameter statement to help give large particle numbers.
28070 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28071C...Commonblocks.
28072 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28073 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28074 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28075 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28076 &SFMIX(16,4)
28077 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
28078
28079C...Local variables.
28080 EXTERNAL PYSIMP,PYLAMF
28081 INTEGER I,NN,LIN
28082 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
28083 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
28084 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
28085 DOUBLE PRECISION SUMME(0:100),A(4,8)
28086 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
28087 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
28088 DOUBLE PRECISION XMGLU,GAM
28089 DOUBLE PRECISION PYSIMP,PYLAMF
28090 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
28091 &DDD(2),EEE(2),FFF(2)
28092 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
28093 DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
28094 DOUBLE PRECISION AMC(2),AMN(4)
28095 SAVE AMC,AMN
28096 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
28097 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
28098 SAVE AMSB,AMST
28099 DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
28100 LOGICAL IFIRST
28101 SAVE IFIRST
28102 DATA IFIRST/.TRUE./
28103
28104 TANB=RMSS(5)
28105 SINB=TANB/SQRT(1D0+TANB**2)
28106 COSB=SINB/TANB
28107 XW=PARU(102)
28108 SINW=SQRT(XW)
28109 COSW=SQRT(1D0-XW)
28110 AMW=PMAS(24,1)
28111 COSC=SFMIX(5,1)
28112 SINC=SFMIX(5,3)
28113 COSA=SFMIX(6,1)
28114 SINA=SFMIX(6,3)
28115 AMBOT=0D0
28116 AMTOP=PYRNMT(PMAS(6,1))
28117 W2=SQRT(2D0)
28118 AMW=PMAS(24,1)
28119 FAKT1=AMBOT/W2/AMW/COSB
28120 FAKT2=AMTOP/W2/AMW/SINB
28121 IF(IFIRST) THEN
28122 AMC(1)=SMW(1)
28123 AMC(2)=SMW(2)
28124 DO 100 JJ=1,2
28125 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
28126 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
28127 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
28128 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
28129 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
28130 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
28131 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
28132 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
28133 100 CONTINUE
28134 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
28135 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
28136 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
28137 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
28138 IFIRST=.FALSE.
28139 ENDIF
28140 AMTOP=PMAS(6,1)
28141
28142 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
28143 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
28144 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
28145 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
28146
28147 COS2A=COSA**2-SINA**2
28148 SIN2A=SINA*COSA*2D0
28149 COS2C=COSC**2-SINC**2
28150 SIN2C=SINC*COSC*2D0
28151
28152 XMG=XMGLU
28153 XMT=AMTOP
28154 XMB=0D0
28155 XMR=AMC(I)
28156 XMG2=XMG*XMG
28157 ALPHAW=PYALEM(XMG2)
28158 ALPHAS=PYALPS(XMG2)
28159 XMT2=XMT*XMT
28160 XMB2=XMB*XMB
28161 XMR2=XMR*XMR
28162 XMQ2=XMG2+XMT2+XMB2+XMR2
28163 XMQ4=XMG*XMT*XMB*XMR
28164 XMQ3=XMG2*XMR2+XMT2*XMB2
28165 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
28166 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
28167
28168 XMST(1)=AMST(1)*AMST(1)
28169 XMST(2)=AMST(1)*AMST(1)
28170 XMST(3)=AMST(2)*AMST(2)
28171 XMST(4)=AMST(2)*AMST(2)
28172 XMSB(1)=AMSB(1)*AMSB(1)
28173 XMSB(2)=AMSB(2)*AMSB(2)
28174 XMSB(3)=AMSB(1)*AMSB(1)
28175 XMSB(4)=AMSB(2)*AMSB(2)
28176
28177 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
28178 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
28179 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
28180 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
28181 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
28182 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
28183 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
28184 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
28185
28186 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
28187 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
28188 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
28189 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
28190 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
28191 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
28192 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
28193 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
28194
28195 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
28196 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
28197 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
28198 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
28199 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
28200 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
28201 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
28202 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
28203
28204 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
28205 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
28206 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
28207 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
28208 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
28209 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
28210 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
28211 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
28212
28213 SMAX=(XMG-ABS(XMR))**2
28214 SMIN=(XMB+XMT)**2+0.1D0
28215
28216 DO 120 LIN=0,NN-1
28217 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28218 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
28219 GRS=SBAR-XMQ2
28220 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
28221 W=DSQRT(W)/2D0/SBAR
28222 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
28223 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
28224 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
28225 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
28226 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
28227 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
28228 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
28229 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
28230 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
28231 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
28232 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
28233 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
28234 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
28235 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
28236 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
28237 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
28238 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
28239 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
28240 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
28241 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
28242 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
28243 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
28244 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
28245 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
28246 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
28247 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
28248 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
28249 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
28250 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
28251 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
28252 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
28253 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
28254 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
28255 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
28256 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
28257 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
28258 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
28259 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
28260 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
28261 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
28262 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
28263 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
28264 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
28265 DO 110 J=1,4
28266 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
28267 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
28268 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
28269 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
28270 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
28271 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
28272 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
28273 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
28274 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
28275 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
28276 & -A(J,6)*(XMG2+XMR2-SBAR)
28277 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
28278 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
28279 & /(GRS+XMSB(J)+XMST(J))
28280 110 CONTINUE
28281 120 CONTINUE
28282 SUMME(NN)=0D0
28283 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28284 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28285
28286 RETURN
28287 END
28288
28289C*********************************************************************
28290
28291*$ CREATE PYNJDC.FOR
28292*COPY PYNJDC
28293C...PYNJDC
28294C...Calculates decay widths for the neutralinos (admixtures of
28295C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
28296
28297C...Input: KCIN = KF code for particle
28298C...Output: XLAM = widths
28299C... IDLAM = KF codes for decay particles
28300C... IKNT = number of decay channels defined
28301C...AUTHOR: STEPHEN MRENNA
28302C...Last change:
28303C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
28304C...when CHIGAMMA .NE. 0
28305C...10 FEB 96: Calculate this decay for small tan(beta)
28306
28307 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
28308
28309C...Double precision and integer declarations.
28310 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28311 INTEGER PYK,PYCHGE,PYCOMP
28312C...Parameter statement to help give large particle numbers.
28313 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28314C...Commonblocks.
28315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28317 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28318 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28319 &SFMIX(16,4)
28320 COMMON/PYINTS/XXM(20)
28321 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
28322
28323C...Local variables.
28324 INTEGER KFIN,KCIN
28325 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
28326 &XMZ,XMZ2,AXMJ,AXMI
28327 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
28328 DOUBLE PRECISION S12MIN,S12MAX
28329 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
28330 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
28331 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
28332 DOUBLE PRECISION PYX2XH,PYX2XG
28333 DOUBLE PRECISION XLAM(0:200)
28334 INTEGER IDLAM(200,3)
28335 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
28336 INTEGER ITH(3),KF1,KF2
28337 INTEGER ITHC
28338 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
28339 DOUBLE PRECISION SR2
28340 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
28341 DOUBLE PRECISION GAMCON,XMT1,XMT2
28342 DOUBLE PRECISION PYALEM,PI,PYALPS
28343 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
28344 DOUBLE PRECISION RAT1,RAT2
28345 DOUBLE PRECISION T3T,CA,CB,FCOL
28346 DOUBLE PRECISION ALFA,BETA,TANB
28347 DOUBLE PRECISION PYGAUS,PYXXGA
28348 EXTERNAL PYXXW5,PYGAUS,PYXXZ5
28349 DOUBLE PRECISION PREC
28350 INTEGER KFNCHI(4),KFCCHI(2)
28351 DATA ETAH/1D0,1D0,-1D0/
28352 DATA ITH/25,35,36/
28353 DATA ITHC/37/
28354 DATA PREC/1D-2/
28355 DATA PI/3.141592654D0/
28356 DATA SR2/1.4142136D0/
28357 DATA KFNCHI/1000022,1000023,1000025,1000035/
28358 DATA KFCCHI/1000024,1000037/
28359
28360C...COUNT THE NUMBER OF DECAY MODES
28361 LKNT=0
28362
28363 XMW=PMAS(24,1)
28364 XMW2=XMW**2
28365 XMZ=PMAS(23,1)
28366 XMZ2=XMZ**2
28367 XW=1D0-XMW2/XMZ2
28368 TANW = SQRT(XW/(1D0-XW))
28369
28370C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
28371 KCIN=PYCOMP(KFIN)
28372 IX=1
28373 IF(KFIN.EQ.KFNCHI(2)) IX=2
28374 IF(KFIN.EQ.KFNCHI(3)) IX=3
28375 IF(KFIN.EQ.KFNCHI(4)) IX=4
28376
28377 XMI=SMZ(IX)
28378 XMI2=XMI**2
28379 AXMI=ABS(XMI)
28380 AEM=PYALEM(XMI2)
28381 AS =PYALPS(XMI2)
28382 C1=AEM/XW
28383 XMI3=ABS(XMI**3)
28384
28385 TANB=RMSS(5)
28386 BETA=ATAN(TANB)
28387 ALFA=RMSS(18)
28388 CBETA=COS(BETA)
28389 SBETA=TANB*CBETA
28390 CALFA=COS(ALFA)
28391 SALFA=SIN(ALFA)
28392
28393C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
28394 IF(IX.EQ.1.AND.IMSS(11).EQ.0) THEN
28395 RETURN
28396 ENDIF
28397
28398C...FORCE CHI0_2 -> CHI0_1 + GAMMA
28399 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
28400 XMJ=SMZ(1)
28401 AXMJ=ABS(XMJ)
28402 LKNT=LKNT+1
28403 GAMCON=AEM**3/8D0/PI/XMW2/XW
28404 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28405 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28406 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28407 IDLAM(LKNT,1)=KSUSY1+22
28408 IDLAM(LKNT,2)=22
28409 IDLAM(LKNT,3)=0
28410 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
28411 GOTO 290
28412 ENDIF
28413
28414C...GRAVITINO DECAY MODES
28415
28416 IF(IMSS(11).EQ.1) THEN
28417 XMP=RMSS(28)
28418 IDG=39+KSUSY1
28419 XMGR=PMAS(PYCOMP(IDG),1)
28420 SINW=SQRT(XW)
28421 COSW=SQRT(1D0-XW)
28422 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
28423 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
28424 LKNT=LKNT+1
28425 IDLAM(LKNT,1)=IDG
28426 IDLAM(LKNT,2)=22
28427 IDLAM(LKNT,3)=0
28428 XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
28429 ENDIF
28430 IF(AXMI.GT.XMGR+XMZ) THEN
28431 LKNT=LKNT+1
28432 IDLAM(LKNT,1)=IDG
28433 IDLAM(LKNT,2)=23
28434 IDLAM(LKNT,3)=0
28435 XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
28436 $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
28437 ENDIF
28438 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
28439 LKNT=LKNT+1
28440 IDLAM(LKNT,1)=IDG
28441 IDLAM(LKNT,2)=25
28442 IDLAM(LKNT,3)=0
28443 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
28444 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
28445 ENDIF
28446 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
28447 LKNT=LKNT+1
28448 IDLAM(LKNT,1)=IDG
28449 IDLAM(LKNT,2)=35
28450 IDLAM(LKNT,3)=0
28451 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
28452 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
28453 ENDIF
28454 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
28455 LKNT=LKNT+1
28456 IDLAM(LKNT,1)=IDG
28457 IDLAM(LKNT,2)=36
28458 IDLAM(LKNT,3)=0
28459 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
28460 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
28461 ENDIF
28462 ENDIF
28463
28464 DO 180 IJ=1,IX-1
28465 XMJ=SMZ(IJ)
28466 AXMJ=ABS(XMJ)
28467 XMJ2=XMJ**2
28468
28469C...CHI0_I -> CHI0_J + GAMMA
28470 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
28471 RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
28472 RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
28473 RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
28474 RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
28475 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
28476 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
28477 LKNT=LKNT+1
28478 IDLAM(LKNT,1)=KFNCHI(IJ)
28479 IDLAM(LKNT,2)=22
28480 IDLAM(LKNT,3)=0
28481 GAMCON=AEM**3/8D0/PI/XMW2/XW
28482 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28483 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28484 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28485 ENDIF
28486 ENDIF
28487
28488C...CHI0_I -> CHI0_J + Z0
28489 IF(AXMI.GE.AXMJ+XMZ) THEN
28490 LKNT=LKNT+1
28491 GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28492 GR=-GL
28493 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
28494 IDLAM(LKNT,1)=KFNCHI(IJ)
28495 IDLAM(LKNT,2)=23
28496 IDLAM(LKNT,3)=0
28497 ELSEIF(AXMI.GE.AXMJ) THEN
28498 FID=11
28499 EI=KCHG(FID,1)/3D0
28500 T3=-0.5D0
28501 XXM(1)=0D0
28502 XXM(2)=XMJ
28503 XXM(3)=0D0
28504 XXM(4)=XMI
28505 XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
28506 XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
28507 XXM(7)=XMZ
28508 XXM(8)=PMAS(23,2)
28509 XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28510 XXM(10)=-XXM(9)
28511 XXM(11)=(T3-EI*XW)/(1D0-XW)
28512 XXM(12)=-EI*XW/(1D0-XW)
28513 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28514 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28515 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28516 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28517 S12MIN=0D0
28518 S12MAX=(AXMI-AXMJ)**2
28519
28520C...CHARGED LEPTONS
28521 IF( XXM(5).LT.AXMI ) THEN
28522 XXM(5)=1D6
28523 ENDIF
28524 IF(XXM(6).LT.AXMI ) THEN
28525 XXM(6)=1D6
28526 ENDIF
28527 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
28528 LKNT=LKNT+1
28529 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28530 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28531 IDLAM(LKNT,1)=KFNCHI(IJ)
28532 IDLAM(LKNT,2)=11
28533 IDLAM(LKNT,3)=-11
28534 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
28535 LKNT=LKNT+1
28536 XLAM(LKNT)=XLAM(LKNT-1)
28537 IDLAM(LKNT,1)=KFNCHI(IJ)
28538 IDLAM(LKNT,2)=13
28539 IDLAM(LKNT,3)=-13
28540 ENDIF
28541 ENDIF
28542 100 CONTINUE
28543 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28544 XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
28545 XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
28546 ELSE
28547 XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
28548 XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
28549 ENDIF
28550 IF( XXM(5).LT.AXMI ) THEN
28551 XXM(5)=1D6
28552 ENDIF
28553 IF(XXM(6).LT.AXMI ) THEN
28554 XXM(6)=1D6
28555 ENDIF
28556
28557 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
28558 LKNT=LKNT+1
28559 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28560 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28561 IDLAM(LKNT,1)=KFNCHI(IJ)
28562 IDLAM(LKNT,2)=15
28563 IDLAM(LKNT,3)=-15
28564 ENDIF
28565
28566C...NEUTRINOS
28567 110 CONTINUE
28568 FID=12
28569 EI=KCHG(FID,1)/3D0
28570 T3=0.5D0
28571 XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
28572 XXM(6)=1D6
28573 XXM(11)=(T3-EI*XW)/(1D0-XW)
28574 XXM(12)=-EI*XW/(1D0-XW)
28575 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28576 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28577 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28578 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28579
28580 IF( XXM(5).LT.AXMI ) THEN
28581 XXM(5)=1D6
28582 ENDIF
28583
28584 LKNT=LKNT+1
28585 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28586 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28587 IDLAM(LKNT,1)=KFNCHI(IJ)
28588 IDLAM(LKNT,2)=12
28589 IDLAM(LKNT,3)=-12
28590 LKNT=LKNT+1
28591 XLAM(LKNT)=XLAM(LKNT-1)
28592 IDLAM(LKNT,1)=KFNCHI(IJ)
28593 IDLAM(LKNT,2)=14
28594 IDLAM(LKNT,3)=-14
28595 120 CONTINUE
28596 XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
28597 IF( XXM(5).LT.AXMI ) THEN
28598 XXM(5)=1D6
28599 ENDIF
28600 LKNT=LKNT+1
28601 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28602 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28603 IDLAM(LKNT,1)=KFNCHI(IJ)
28604 IDLAM(LKNT,2)=16
28605 IDLAM(LKNT,3)=-16
28606
28607C...D-TYPE QUARKS
28608 130 CONTINUE
28609 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28610 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28611 FID=1
28612 EI=KCHG(FID,1)/3D0
28613 T3=-0.5D0
28614
28615 XXM(11)=(T3-EI*XW)/(1D0-XW)
28616 XXM(12)=-EI*XW/(1D0-XW)
28617 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28618 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28619 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28620 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28621
28622 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
28623 IF( XXM(5).LT.AXMI ) THEN
28624 XXM(5)=1D6
28625 ELSEIF( XXM(6).LT.AXMI ) THEN
28626 XXM(6)=1D6
28627 ENDIF
28628 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
28629 LKNT=LKNT+1
28630 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28631 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28632 IDLAM(LKNT,1)=KFNCHI(IJ)
28633 IDLAM(LKNT,2)=1
28634 IDLAM(LKNT,3)=-1
28635 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
28636 LKNT=LKNT+1
28637 XLAM(LKNT)=XLAM(LKNT-1)
28638 IDLAM(LKNT,1)=KFNCHI(IJ)
28639 IDLAM(LKNT,2)=3
28640 IDLAM(LKNT,3)=-3
28641 ENDIF
28642 ENDIF
28643 140 CONTINUE
28644 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
28645 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
28646 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
28647 ELSE
28648 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
28649 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
28650 ENDIF
28651 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
28652 IF(XXM(5).LT.AXMI) THEN
28653 XXM(5)=1D6
28654 ELSEIF(XXM(6).LT.AXMI) THEN
28655 XXM(6)=1D6
28656 ENDIF
28657 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
28658 LKNT=LKNT+1
28659 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28660 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28661 IDLAM(LKNT,1)=KFNCHI(IJ)
28662 IDLAM(LKNT,2)=5
28663 IDLAM(LKNT,3)=-5
28664 ENDIF
28665
28666C...U-TYPE QUARKS
28667 150 CONTINUE
28668 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
28669 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
28670 FID=2
28671 EI=KCHG(FID,1)/3D0
28672 T3=0.5D0
28673
28674 XXM(11)=(T3-EI*XW)/(1D0-XW)
28675 XXM(12)=-EI*XW/(1D0-XW)
28676 XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28677 XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28678 XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28679 XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28680
28681 IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
28682 IF(XXM(5).LT.AXMI) THEN
28683 XXM(5)=1D6
28684 ELSEIF(XXM(6).LT.AXMI) THEN
28685 XXM(6)=1D6
28686 ENDIF
28687 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
28688 LKNT=LKNT+1
28689 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28690 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28691 IDLAM(LKNT,1)=KFNCHI(IJ)
28692 IDLAM(LKNT,2)=2
28693 IDLAM(LKNT,3)=-2
28694 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
28695 LKNT=LKNT+1
28696 XLAM(LKNT)=XLAM(LKNT-1)
28697 IDLAM(LKNT,1)=KFNCHI(IJ)
28698 IDLAM(LKNT,2)=4
28699 IDLAM(LKNT,3)=-4
28700 ENDIF
28701 ENDIF
28702 160 CONTINUE
28703 ENDIF
28704
28705C...CHI0_I -> CHI0_J + H0_K
28706 EH(1)=SIN(ALFA)
28707 EH(2)=COS(ALFA)
28708 EH(3)=-SIN(BETA)
28709 DH(1)=COS(ALFA)
28710 DH(2)=-SIN(ALFA)
28711 DH(3)=COS(BETA)
28712
28713 QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
28714 & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
28715 RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
28716 & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
28717
28718 DO 170 IH=1,3
28719 XMH=PMAS(ITH(IH),1)
28720 XMH2=XMH**2
28721 IF(AXMI.GE.AXMJ+XMH) THEN
28722 LKNT=LKNT+1
28723 XL=PYLAMF(XMI2,XMJ2,XMH2)
28724 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
28725 F12K=F21K
28726C...SIGN OF MASSES I,J
28727 XMK=XMJ
28728 IF(IH.EQ.3) XMK=-XMK
28729 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
28730 IDLAM(LKNT,1)=KFNCHI(IJ)
28731 IDLAM(LKNT,2)=ITH(IH)
28732 IDLAM(LKNT,3)=0
28733 ENDIF
28734 170 CONTINUE
28735 180 CONTINUE
28736
28737C...CHI0_I -> CHI+_J + W-
28738 DO 220 IJ=1,2
28739 XMJ=SMW(IJ)
28740 AXMJ=ABS(XMJ)
28741 XMJ2=XMJ**2
28742 IF(AXMI.GE.AXMJ+XMW) THEN
28743 LKNT=LKNT+1
28744 GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28745 GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28746 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
28747 IDLAM(LKNT,1)=KFCCHI(IJ)
28748 IDLAM(LKNT,2)=-24
28749 IDLAM(LKNT,3)=0
28750 LKNT=LKNT+1
28751 XLAM(LKNT)=XLAM(LKNT-1)
28752 IDLAM(LKNT,1)=-KFCCHI(IJ)
28753 IDLAM(LKNT,2)=24
28754 IDLAM(LKNT,3)=0
28755 ELSEIF(AXMI.GE.AXMJ) THEN
28756 S12MIN=0D0
28757 S12MAX=(AXMI-AXMJ)**2
28758 XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28759 XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28760
28761C...LEPTONS
28762 FID=11
28763 EI=KCHG(FID,1)/3D0
28764 T3=-0.5D0
28765 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28766 FID=12
28767 EI=KCHG(FID,1)/3D0
28768 T3=0.5D0
28769 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28770
28771 XXM(1)=0D0
28772 XXM(2)=XMJ
28773 XXM(3)=0D0
28774 XXM(4)=XMI
28775 XXM(9)=PMAS(24,1)
28776 XXM(10)=PMAS(24,2)
28777 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
28778 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
28779 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
28780 IF(XXM(11).LT.AXMI) THEN
28781 XXM(11)=1D6
28782 ELSEIF(XXM(12).LT.AXMI) THEN
28783 XXM(12)=1D6
28784 ENDIF
28785 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
28786 LKNT=LKNT+1
28787 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28788 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28789 IDLAM(LKNT,1)=KFCCHI(IJ)
28790 IDLAM(LKNT,2)=11
28791 IDLAM(LKNT,3)=-12
28792 LKNT=LKNT+1
28793 XLAM(LKNT)=XLAM(LKNT-1)
28794 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28795 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28796 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28797 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
28798 LKNT=LKNT+1
28799 XLAM(LKNT)=XLAM(LKNT-1)
28800 IDLAM(LKNT,1)=KFCCHI(IJ)
28801 IDLAM(LKNT,2)=13
28802 IDLAM(LKNT,3)=-14
28803 LKNT=LKNT+1
28804 XLAM(LKNT)=XLAM(LKNT-1)
28805 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28806 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28807 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28808 ENDIF
28809 ENDIF
28810 190 CONTINUE
28811 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28812 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
28813 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28814 ELSE
28815 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
28816 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28817 ENDIF
28818
28819 IF(XXM(11).LT.AXMI) THEN
28820 XXM(11)=1D6
28821 ENDIF
28822 IF(XXM(12).LT.AXMI) THEN
28823 XXM(12)=1D6
28824 ENDIF
28825 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
28826 LKNT=LKNT+1
28827 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28828 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28829 XLAM(LKNT)=XLAM(LKNT-1)
28830 IDLAM(LKNT,1)=KFCCHI(IJ)
28831 IDLAM(LKNT,2)=15
28832 IDLAM(LKNT,3)=-16
28833 LKNT=LKNT+1
28834 XLAM(LKNT)=XLAM(LKNT-1)
28835 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28836 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28837 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28838 ENDIF
28839
28840C...NOW, DO THE QUARKS
28841 200 CONTINUE
28842 FID=1
28843 EI=KCHG(FID,1)/3D0
28844 T3=-0.5D0
28845 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28846 FID=2
28847 EI=KCHG(FID,1)/3D0
28848 T3=0.5D0
28849 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28850
28851 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
28852 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
28853 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
28854 IF(XXM(11).LT.AXMI) THEN
28855 XXM(11)=1D6
28856 ELSEIF(XXM(12).LT.AXMI) THEN
28857 XXM(12)=1D6
28858 ENDIF
28859 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
28860 LKNT=LKNT+1
28861 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
28862 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28863 IDLAM(LKNT,1)=KFCCHI(IJ)
28864 IDLAM(LKNT,2)=1
28865 IDLAM(LKNT,3)=-2
28866 LKNT=LKNT+1
28867 XLAM(LKNT)=XLAM(LKNT-1)
28868 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28869 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28870 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28871 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
28872 LKNT=LKNT+1
28873 XLAM(LKNT)=XLAM(LKNT-1)
28874 IDLAM(LKNT,1)=KFCCHI(IJ)
28875 IDLAM(LKNT,2)=3
28876 IDLAM(LKNT,3)=-4
28877 LKNT=LKNT+1
28878 XLAM(LKNT)=XLAM(LKNT-1)
28879 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28880 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28881 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28882 ENDIF
28883 ENDIF
28884 210 CONTINUE
28885 ENDIF
28886 220 CONTINUE
28887 230 CONTINUE
28888
28889C...CHI0_I -> CHI+_I + H-
28890 DO 240 IJ=1,2
28891 XMJ=SMW(IJ)
28892 AXMJ=ABS(XMJ)
28893 XMJ2=XMJ**2
28894 XMHP=PMAS(ITHC,1)
28895 XMHP2=XMHP**2
28896 IF(AXMI.GE.AXMJ+XMHP) THEN
28897 LKNT=LKNT+1
28898 GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
28899 & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
28900 GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
28901 & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
28902 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
28903 IDLAM(LKNT,1)=KFCCHI(IJ)
28904 IDLAM(LKNT,2)=-ITHC
28905 IDLAM(LKNT,3)=0
28906 LKNT=LKNT+1
28907 XLAM(LKNT)=XLAM(LKNT-1)
28908 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28909 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28910 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28911 ELSE
28912
28913 ENDIF
28914 240 CONTINUE
28915
28916C...2-BODY DECAYS TO FERMION SFERMION
28917 DO 250 J=1,16
28918 IF(J.GE.7.AND.J.LE.10) GOTO 250
28919 KF1=KSUSY1+J
28920 KF2=KSUSY2+J
28921 XMSF1=PMAS(PYCOMP(KF1),1)
28922 XMSF2=PMAS(PYCOMP(KF2),1)
28923 XMF=PMAS(J,1)
28924 IF(J.LE.6) THEN
28925 FCOL=3D0
28926 ELSE
28927 FCOL=1D0
28928 ENDIF
28929
28930 EI=KCHG(J,1)/3D0
28931 T3T=SIGN(1D0,EI)
28932 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
28933 IF(MOD(J,2).EQ.0) THEN
28934 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28935 AL=XMF*ZMIX(IX,4)/XMW/SBETA
28936 AR=-2D0*EI*TANW*ZMIX(IX,1)
28937 BR=AL
28938 ELSE
28939 BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28940 AL=XMF*ZMIX(IX,3)/XMW/CBETA
28941 AR=-2D0*EI*TANW*ZMIX(IX,1)
28942 BR=AL
28943 ENDIF
28944
28945C...D~ D_L
28946 IF(AXMI.GE.XMF+XMSF1) THEN
28947 LKNT=LKNT+1
28948 XMA2=XMSF1**2
28949 XMB2=XMF**2
28950 XL=PYLAMF(XMI2,XMA2,XMB2)
28951 CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
28952 CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
28953 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28954 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28955 IDLAM(LKNT,1)=KF1
28956 IDLAM(LKNT,2)=-J
28957 IDLAM(LKNT,3)=0
28958 LKNT=LKNT+1
28959 XLAM(LKNT)=XLAM(LKNT-1)
28960 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28961 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28962 IDLAM(LKNT,3)=0
28963 ENDIF
28964
28965C...D~ D_R
28966 IF(AXMI.GE.XMF+XMSF2) THEN
28967 LKNT=LKNT+1
28968 XMA2=XMSF2**2
28969 XMB2=XMF**2
28970 CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
28971 CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
28972 XL=PYLAMF(XMI2,XMA2,XMB2)
28973 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28974 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28975 IDLAM(LKNT,1)=KF2
28976 IDLAM(LKNT,2)=-J
28977 IDLAM(LKNT,3)=0
28978 LKNT=LKNT+1
28979 XLAM(LKNT)=XLAM(LKNT-1)
28980 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28981 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28982 IDLAM(LKNT,3)=0
28983 ENDIF
28984 250 CONTINUE
28985
28986C...3-BODY DECAY TO Q Q~ GLUINO
28987 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
28988 IF(AXMI.GE.XMJ) THEN
28989 AXMJ=ABS(XMJ)
28990 XXM(1)=0D0
28991 XXM(2)=XMJ
28992 XXM(3)=0D0
28993 XXM(4)=XMI
28994 XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28995 XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28996 XXM(7)=1D6
28997 XXM(8)=0D0
28998 XXM(9)=0D0
28999 XXM(10)=0D0
29000 S12MIN=0D0
29001 S12MAX=(AXMI-AXMJ)**2
29002C...ALL QUARKS BUT T
29003 XXM(11)=0D0
29004 XXM(12)=0D0
29005 XXM(13)=1D0
29006 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
29007 XXM(15)=1D0
29008 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
29009 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 260
29010 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29011 LKNT=LKNT+1
29012 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29013 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29014 IDLAM(LKNT,1)=KSUSY1+21
29015 IDLAM(LKNT,2)=1
29016 IDLAM(LKNT,3)=-1
29017 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29018 LKNT=LKNT+1
29019 XLAM(LKNT)=XLAM(LKNT-1)
29020 IDLAM(LKNT,1)=KSUSY1+21
29021 IDLAM(LKNT,2)=3
29022 IDLAM(LKNT,3)=-3
29023 ENDIF
29024 ENDIF
29025 260 CONTINUE
29026 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
29027 XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
29028 XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
29029 ELSE
29030 XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
29031 XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
29032 ENDIF
29033 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
29034 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29035 LKNT=LKNT+1
29036 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
29037 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29038 IDLAM(LKNT,1)=KSUSY1+21
29039 IDLAM(LKNT,2)=5
29040 IDLAM(LKNT,3)=-5
29041 ENDIF
29042C...U-TYPE QUARKS
29043 270 CONTINUE
29044 XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
29045 XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
29046 XXM(13)=1D0
29047 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
29048 XXM(15)=1D0
29049 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
29050 IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
29051 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29052 LKNT=LKNT+1
29053 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
29054 & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29055 IDLAM(LKNT,1)=KSUSY1+21
29056 IDLAM(LKNT,2)=2
29057 IDLAM(LKNT,3)=-2
29058 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29059 LKNT=LKNT+1
29060 XLAM(LKNT)=XLAM(LKNT-1)
29061 IDLAM(LKNT,1)=KSUSY1+21
29062 IDLAM(LKNT,2)=4
29063 IDLAM(LKNT,3)=-4
29064 ENDIF
29065 ENDIF
29066 280 CONTINUE
29067 ENDIF
29068
29069 290 IKNT=LKNT
29070 XLAM(0)=0D0
29071 DO 300 I=1,IKNT
29072 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
29073 XLAM(0)=XLAM(0)+XLAM(I)
29074 300 CONTINUE
29075 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
29076
29077 RETURN
29078 END
29079
29080C*********************************************************************
29081
29082*$ CREATE PYCJDC.FOR
29083*COPY PYCJDC
29084C...PYCJDC
29085C...Calculate decay widths for the charginos (admixtures of
29086C...charged Wino and charged Higgsino.
29087
29088C...Input: KCIN = KF code for particle
29089C...Output: XLAM = widths
29090C... IDLAM = KF codes for decay particles
29091C... IKNT = number of decay channels defined
29092C...AUTHOR: STEPHEN MRENNA
29093C...Last change:
29094C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
29095C...when CHIENU .NE. 0
29096
29097 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
29098
29099C...Double precision and integer declarations.
29100 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29101 INTEGER PYK,PYCHGE,PYCOMP
29102C...Parameter statement to help give large particle numbers.
29103 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29104C...Commonblocks.
29105 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29106 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29107 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29108 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29109 &SFMIX(16,4)
29110 COMMON/PYINTS/XXM(20)
29111 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
29112
29113C...Local variables.
29114 INTEGER KFIN,KCIN
29115 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
29116 &XMZ,XMZ2,AXMJ,AXMI
29117 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
29118 DOUBLE PRECISION S12MIN,S12MAX
29119 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
29120 DOUBLE PRECISION PYLAMF,XL
29121 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
29122 DOUBLE PRECISION PYX2XH,PYX2XG
29123 DOUBLE PRECISION XLAM(0:200)
29124 INTEGER IDLAM(200,3)
29125 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
29126 INTEGER ITH(3)
29127 INTEGER ITHC
29128 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
29129 DOUBLE PRECISION SR2
29130 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
29131
29132 DOUBLE PRECISION PYALEM,PI,PYALPS
29133 DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
29134 DOUBLE PRECISION CA,CB,FCOL
29135 INTEGER KF1,KF2,ISF
29136 INTEGER KFNCHI(4),KFCCHI(2)
29137
29138 DOUBLE PRECISION TEMP
29139 DOUBLE PRECISION PYGAUS
29140 EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
29141 DOUBLE PRECISION PREC
29142 DATA ITH/25,35,36/
29143 DATA ITHC/37/
29144 DATA ETAH/1D0,1D0,-1D0/
29145 DATA SR2/1.4142136D0/
29146 DATA PI/3.141592654D0/
29147 DATA PREC/1D-2/
29148 DATA KFNCHI/1000022,1000023,1000025,1000035/
29149 DATA KFCCHI/1000024,1000037/
29150
29151C...COUNT THE NUMBER OF DECAY MODES
29152 LKNT=0
29153 XMW=PMAS(24,1)
29154 XMW2=XMW**2
29155 XMZ=PMAS(23,1)
29156 XMZ2=XMZ**2
29157 XW=1D0-XMW2/XMZ2
29158 TANW = SQRT(XW/(1D0-XW))
29159
29160C...1 OR 2 DEPENDING ON CHARGINO TYPE
29161 IX=1
29162 IF(KFIN.EQ.KFCCHI(2)) IX=2
29163 KCIN=PYCOMP(KFIN)
29164
29165 XMI=SMW(IX)
29166 XMI2=XMI**2
29167 AXMI=ABS(XMI)
29168 AEM=PYALEM(XMI2)
29169 AS =PYALPS(XMI2)
29170 C1=AEM/XW
29171 XMI3=ABS(XMI**3)
29172 TANB=RMSS(5)
29173 BETA=ATAN(TANB)
29174 CBETA=COS(BETA)
29175 SBETA=TANB*CBETA
29176 ALFA=RMSS(18)
29177
29178C...GRAVITINO DECAY MODES
29179
29180 IF(IMSS(11).EQ.1) THEN
29181 XMP=RMSS(28)
29182 IDG=39+KSUSY1
29183 XMGR=PMAS(PYCOMP(IDG),1)
29184 SINW=SQRT(XW)
29185 COSW=SQRT(1D0-XW)
29186 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
29187 IF(AXMI.GT.XMGR+XMW) THEN
29188 LKNT=LKNT+1
29189 IDLAM(LKNT,1)=IDG
29190 IDLAM(LKNT,2)=24
29191 IDLAM(LKNT,3)=0
29192 XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
29193 & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
29194 & (1D0-XMW2/XMI2)**4
29195 ENDIF
29196 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
29197 LKNT=LKNT+1
29198 IDLAM(LKNT,1)=IDG
29199 IDLAM(LKNT,2)=37
29200 IDLAM(LKNT,3)=0
29201 XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
29202 & (UMIX(IX,2)*SBETA)**2))
29203 & *(1D0-PMAS(37,1)**2/XMI2)**4
29204 ENDIF
29205 ENDIF
29206
29207C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
29208 IF(IX.EQ.1) GOTO 150
29209 XMJ=SMW(1)
29210 AXMJ=ABS(XMJ)
29211 XMJ2=XMJ**2
29212
29213C...CHI_2+ -> CHI_1+ + Z0
29214 IF(AXMI.GE.AXMJ+XMZ) THEN
29215 LKNT=LKNT+1
29216 GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
29217 GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
29218 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
29219 IDLAM(LKNT,1)=KFCCHI(1)
29220 IDLAM(LKNT,2)=23
29221 IDLAM(LKNT,3)=0
29222
29223C...CHARGED LEPTONS
29224 ELSEIF(AXMI.GE.AXMJ) THEN
29225 XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
29226 XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
29227 XXM(9)=XMZ
29228 XXM(10)=PMAS(23,2)
29229 XXM(1)=0D0
29230 XXM(2)=XMJ
29231 XXM(3)=0D0
29232 XXM(4)=XMI
29233 S12MIN=0D0
29234 S12MAX=(AXMJ-AXMI)**2
29235 XXM(7)= (-0.5D0+XW)/(1D0-XW)
29236 XXM(8)= XW/(1D0-XW)
29237 XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
29238 XXM(12)=VMIX(2,1)*VMIX(1,1)
29239 IF( XXM(11).LT.AXMI ) THEN
29240 XXM(11)=1D6
29241 ENDIF
29242 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
29243 LKNT=LKNT+1
29244 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29245 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29246 IDLAM(LKNT,1)=KFCCHI(1)
29247 IDLAM(LKNT,2)=11
29248 IDLAM(LKNT,3)=-11
29249 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
29250 LKNT=LKNT+1
29251 XLAM(LKNT)=XLAM(LKNT-1)
29252 IDLAM(LKNT,1)=KFCCHI(1)
29253 IDLAM(LKNT,2)=13
29254 IDLAM(LKNT,3)=-13
29255 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
29256 LKNT=LKNT+1
29257 XLAM(LKNT)=XLAM(LKNT-1)
29258 IDLAM(LKNT,1)=KFCCHI(1)
29259 IDLAM(LKNT,2)=15
29260 IDLAM(LKNT,3)=-15
29261 ENDIF
29262 ENDIF
29263 ENDIF
29264
29265C...NEUTRINOS
29266 100 CONTINUE
29267 XXM(7)= (0.5D0)/(1D0-XW)
29268 XXM(8)= 0D0
29269 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29270 XXM(12)=UMIX(2,1)*UMIX(1,1)
29271 IF( XXM(11).LT.AXMI ) THEN
29272 XXM(11)=1D6
29273 ENDIF
29274 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
29275 LKNT=LKNT+1
29276 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29277 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29278 IDLAM(LKNT,1)=KFCCHI(1)
29279 IDLAM(LKNT,2)=12
29280 IDLAM(LKNT,3)=-12
29281 LKNT=LKNT+1
29282 XLAM(LKNT)=XLAM(LKNT-1)
29283 IDLAM(LKNT,1)=KFCCHI(1)
29284 IDLAM(LKNT,2)=14
29285 IDLAM(LKNT,3)=-14
29286 LKNT=LKNT+1
29287 XLAM(LKNT)=XLAM(LKNT-1)
29288 IDLAM(LKNT,1)=KFCCHI(1)
29289 IDLAM(LKNT,2)=16
29290 IDLAM(LKNT,3)=-16
29291 ENDIF
29292
29293C...D-TYPE QUARKS
29294 110 CONTINUE
29295 XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
29296 XXM(8)= XW/3D0/(1D0-XW)
29297 XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
29298 XXM(12)=VMIX(2,1)*VMIX(1,1)
29299 IF( XXM(11).LT.AXMI ) GOTO 120
29300 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29301 LKNT=LKNT+1
29302 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29303 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29304 IDLAM(LKNT,1)=KFCCHI(1)
29305 IDLAM(LKNT,2)=1
29306 IDLAM(LKNT,3)=-1
29307 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29308 LKNT=LKNT+1
29309 XLAM(LKNT)=XLAM(LKNT-1)
29310 IDLAM(LKNT,1)=KFCCHI(1)
29311 IDLAM(LKNT,2)=3
29312 IDLAM(LKNT,3)=-3
29313 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29314 LKNT=LKNT+1
29315 XLAM(LKNT)=XLAM(LKNT-1)
29316 IDLAM(LKNT,1)=KFCCHI(1)
29317 IDLAM(LKNT,2)=5
29318 IDLAM(LKNT,3)=-5
29319 ENDIF
29320 ENDIF
29321 ENDIF
29322
29323C...U-TYPE QUARKS
29324 120 CONTINUE
29325 XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
29326 XXM(8)= -2D0*XW/3D0/(1D0-XW)
29327 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29328 XXM(12)=UMIX(2,1)*UMIX(1,1)
29329 IF( XXM(11).LT.AXMI ) GOTO 130
29330 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29331 LKNT=LKNT+1
29332 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29333 & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29334 IDLAM(LKNT,1)=KFCCHI(1)
29335 IDLAM(LKNT,2)=2
29336 IDLAM(LKNT,3)=-2
29337 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29338 LKNT=LKNT+1
29339 XLAM(LKNT)=XLAM(LKNT-1)
29340 IDLAM(LKNT,1)=KFCCHI(1)
29341 IDLAM(LKNT,2)=4
29342 IDLAM(LKNT,3)=-4
29343 ENDIF
29344 ENDIF
29345 130 CONTINUE
29346 ENDIF
29347
29348C...CHI_2+ -> CHI_1+ + H0_K
29349 EH(2)=COS(ALFA)
29350 EH(1)=SIN(ALFA)
29351 EH(3)=-SBETA
29352 DH(2)=-SIN(ALFA)
29353 DH(1)=COS(ALFA)
29354 DH(3)=COS(BETA)
29355 DO 140 IH=1,3
29356 XMH=PMAS(ITH(IH),1)
29357 XMH2=XMH**2
29358C...NO 3-BODY OPTION
29359 IF(AXMI.GE.AXMJ+XMH) THEN
29360 LKNT=LKNT+1
29361 XL=PYLAMF(XMI2,XMJ2,XMH2)
29362 F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
29363 & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
29364 F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
29365 & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
29366 XMK=XMJ*ETAH(IH)
29367 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
29368 IDLAM(LKNT,1)=KFCCHI(1)
29369 IDLAM(LKNT,2)=ITH(IH)
29370 IDLAM(LKNT,3)=0
29371 ENDIF
29372 140 CONTINUE
29373
29374C...CHI1 JUMPS TO HERE
29375 150 CONTINUE
29376
29377C...CHI+_I -> CHI0_J + W+
29378 DO 180 IJ=1,4
29379 XMJ=SMZ(IJ)
29380 AXMJ=ABS(XMJ)
29381 XMJ2=XMJ**2
29382 IF(AXMI.GE.AXMJ+XMW) THEN
29383 LKNT=LKNT+1
29384 GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
29385 GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
29386 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
29387 IDLAM(LKNT,1)=KFNCHI(IJ)
29388 IDLAM(LKNT,2)=24
29389 IDLAM(LKNT,3)=0
29390
29391C...LEPTONS
29392 ELSEIF(AXMI.GE.AXMJ) THEN
29393 XMF1=0D0
29394 XMF2=0D0
29395 S12MIN=(XMF1+XMF2)**2
29396 S12MAX=(AXMJ-AXMI)**2
29397 XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
29398 XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
29399 FID=11
29400 EI=KCHG(FID,1)/3D0
29401 T3=-0.5D0
29402 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29403 FID=12
29404 EI=KCHG(FID,1)/3D0
29405 T3=0.5D0
29406 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29407
29408 XXM(4)=XMI
29409 XXM(1)=XMF1
29410 XXM(2)=XMJ
29411 XXM(3)=XMF2
29412 XXM(9)=PMAS(24,1)
29413 XXM(10)=PMAS(24,2)
29414 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29415 XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
29416
29417C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
29418C...--> 1/(16PI)/M**3*(AEM/XW)**2
29419
29420 IF(XXM(11).LT.AXMI) THEN
29421 XXM(11)=1D6
29422 ENDIF
29423 IF(XXM(12).LT.AXMI) THEN
29424 XXM(12)=1D6
29425 ENDIF
29426 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
29427 LKNT=LKNT+1
29428 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29429 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29430 IDLAM(LKNT,1)=KFNCHI(IJ)
29431 IDLAM(LKNT,2)=-11
29432 IDLAM(LKNT,3)=12
29433
29434C...ONLY DECAY CHI+1 -> E+ NU_E
29435 IF( IMSS(12).NE. 0 ) GOTO 220
29436 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
29437 LKNT=LKNT+1
29438 XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
29439 XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
29440 IF(XXM(11).LT.AXMI) THEN
29441 XXM(11)=1D6
29442 ELSEIF(XXM(12).LT.AXMI) THEN
29443 XXM(12)=1D6
29444 ENDIF
29445 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29446 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29447 IDLAM(LKNT,1)=KFNCHI(IJ)
29448 IDLAM(LKNT,2)=-13
29449 IDLAM(LKNT,3)=14
29450 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
29451 LKNT=LKNT+1
29452 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
29453 XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
29454 ELSE
29455 XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
29456 ENDIF
29457 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
29458 IF(XXM(11).LT.AXMI) THEN
29459 XXM(11)=1D6
29460 ENDIF
29461 IF(XXM(12).LT.AXMI) THEN
29462 XXM(12)=1D6
29463 ENDIF
29464 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29465 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29466 IDLAM(LKNT,1)=KFNCHI(IJ)
29467 IDLAM(LKNT,2)=-15
29468 IDLAM(LKNT,3)=16
29469 ENDIF
29470 ENDIF
29471 ENDIF
29472
29473C...NOW, DO THE QUARKS
29474 160 CONTINUE
29475 FID=1
29476 EI=KCHG(FID,1)/3D0
29477 T3=-0.5D0
29478 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29479 FID=1
29480 EI=KCHG(FID,1)/3D0
29481 T3=0.5D0
29482 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29483
29484 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29485 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29486 IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
29487 IF(XXM(11).LT.AXMI) THEN
29488 XXM(11)=1D6
29489 ELSEIF(XXM(12).LT.AXMI) THEN
29490 XXM(12)=1D6
29491 ENDIF
29492 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29493 LKNT=LKNT+1
29494 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29495 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29496 IDLAM(LKNT,1)=KFNCHI(IJ)
29497 IDLAM(LKNT,2)=-1
29498 IDLAM(LKNT,3)=2
29499 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29500 LKNT=LKNT+1
29501 XLAM(LKNT)=XLAM(LKNT-1)
29502 IDLAM(LKNT,1)=KFNCHI(IJ)
29503 IDLAM(LKNT,2)=-3
29504 IDLAM(LKNT,3)=4
29505 ENDIF
29506 ENDIF
29507 170 CONTINUE
29508 ENDIF
29509 180 CONTINUE
29510
29511C...CHI+_I -> CHI0_J + H+
29512 DO 190 IJ=1,4
29513 XMJ=SMZ(IJ)
29514 AXMJ=ABS(XMJ)
29515 XMJ2=XMJ**2
29516 XMHP=PMAS(ITHC,1)
29517 XMHP2=XMHP**2
29518 IF(AXMI.GE.AXMJ+XMHP) THEN
29519 LKNT=LKNT+1
29520 GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
29521 & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
29522 GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
29523 & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
29524 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
29525 IDLAM(LKNT,1)=KFNCHI(IJ)
29526 IDLAM(LKNT,2)=ITHC
29527 IDLAM(LKNT,3)=0
29528 ELSE
29529
29530 ENDIF
29531 190 CONTINUE
29532
29533C...2-BODY DECAYS TO FERMION SFERMION
29534 DO 200 J=1,16
29535 IF(J.GE.7.AND.J.LE.10) GOTO 200
29536 IF(MOD(J,2).EQ.0) THEN
29537 KF1=KSUSY1+J-1
29538 ELSE
29539 KF1=KSUSY1+J+1
29540 ENDIF
29541 KF2=KF1+KSUSY1
29542 XMSF1=PMAS(PYCOMP(KF1),1)
29543 XMSF2=PMAS(PYCOMP(KF2),1)
29544 XMF=PMAS(J,1)
29545 IF(J.LE.6) THEN
29546 FCOL=3D0
29547 ELSE
29548 FCOL=1D0
29549 ENDIF
29550
29551C...U~ D_L
29552 IF(MOD(J,2).EQ.0) THEN
29553 XMFP=PMAS(J-1,1)
29554 AL=UMIX(IX,1)
29555 BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
29556 AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
29557 BR=0D0
29558 ISF=J-1
29559 ELSE
29560 XMFP=PMAS(J+1,1)
29561 AL=VMIX(IX,1)
29562 BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
29563 BR=0D0
29564 AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
29565 ISF=J+1
29566 ENDIF
29567
29568C...~U_L D
29569 IF(AXMI.GE.XMF+XMSF1) THEN
29570 LKNT=LKNT+1
29571 XMA2=XMSF1**2
29572 XMB2=XMF**2
29573 XL=PYLAMF(XMI2,XMA2,XMB2)
29574 CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
29575 CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
29576 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29577 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29578 IDLAM(LKNT,3)=0
29579 IF(MOD(J,2).EQ.0) THEN
29580 IDLAM(LKNT,1)=-KF1
29581 IDLAM(LKNT,2)=J
29582 ELSE
29583 IDLAM(LKNT,1)=KF1
29584 IDLAM(LKNT,2)=-J
29585 ENDIF
29586 ENDIF
29587
29588C...U~ D_R
29589 IF(AXMI.GE.XMF+XMSF2) THEN
29590 LKNT=LKNT+1
29591 XMA2=XMSF2**2
29592 XMB2=XMF**2
29593 CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
29594 CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
29595 XL=PYLAMF(XMI2,XMA2,XMB2)
29596 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29597 & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29598 IDLAM(LKNT,3)=0
29599 IF(MOD(J,2).EQ.0) THEN
29600 IDLAM(LKNT,1)=-KF2
29601 IDLAM(LKNT,2)=J
29602 ELSE
29603 IDLAM(LKNT,1)=KF2
29604 IDLAM(LKNT,2)=-J
29605 ENDIF
29606 ENDIF
29607 200 CONTINUE
29608
29609C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
29610C...A 2-BODY -- 2-BODY CHAIN
29611 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
29612 IF(AXMI.GE.XMJ) THEN
29613 AXMJ=ABS(XMJ)
29614 S12MIN=0D0
29615 S12MAX=(AXMI-AXMJ)**2
29616 XXM(1)=0D0
29617 XXM(2)=XMJ
29618 XXM(3)=0D0
29619 XXM(4)=XMI
29620 XXM(5)=0D0
29621 XXM(6)=0D0
29622 XXM(9)=1D6
29623 XXM(10)=0D0
29624 XXM(7)=UMIX(IX,1)*SR2
29625 XXM(8)=VMIX(IX,1)*SR2
29626 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29627 XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29628 IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
29629 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29630 LKNT=LKNT+1
29631 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29632 & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29633 IDLAM(LKNT,1)=KSUSY1+21
29634 IDLAM(LKNT,2)=-1
29635 IDLAM(LKNT,3)=2
29636 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29637 LKNT=LKNT+1
29638 XLAM(LKNT)=XLAM(LKNT-1)
29639 IDLAM(LKNT,1)=KSUSY1+21
29640 IDLAM(LKNT,2)=-3
29641 IDLAM(LKNT,3)=4
29642 ENDIF
29643 ENDIF
29644 210 CONTINUE
29645 ENDIF
29646
29647 220 IKNT=LKNT
29648 XLAM(0)=0D0
29649 DO 230 I=1,IKNT
29650 XLAM(0)=XLAM(0)+XLAM(I)
29651 IF(XLAM(I).LT.0D0) THEN
29652 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
29653 & (IDLAM(I,J),J=1,3)
29654 XLAM(I)=0D0
29655 ENDIF
29656 230 CONTINUE
29657 IF(XLAM(0).EQ.0D0) THEN
29658 XLAM(0)=1D-6
29659 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
29660 WRITE(MSTU(11),*) LKNT
29661 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
29662 ENDIF
29663
29664 RETURN
29665 END
29666
29667C*********************************************************************
29668
29669*$ CREATE PYXXZ5.FOR
29670*COPY PYXXZ5
29671C...PYXXZ5
29672C...Calculates chi0 -> chi0 + f + ~f.
29673
29674 FUNCTION PYXXZ5(X)
29675
29676C...Double precision and integer declarations.
29677 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29678 INTEGER PYK,PYCHGE,PYCOMP
29679C...Parameter statement to help give large particle numbers.
29680 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29681C...Commonblocks.
29682 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29683 COMMON/PYINTS/XXM(20)
29684 SAVE /PYDAT1/,/PYINTS/
29685
29686C...Local variables.
29687 DOUBLE PRECISION PYXXZ5,X
29688 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
29689 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
29690 DOUBLE PRECISION SIJ
29691 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
29692 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
29693 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29694 INTEGER I
29695 DATA SR2/1.4142136D0/
29696
29697C...Statement functions.
29698C...Integral from x to y of (t-a)(b-t) dt.
29699 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29700C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29701 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29702 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29703C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29704 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29705 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29706C...Integral from x to y of (t-a)/(b-t) dt.
29707 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29708C...Integral from x to y of 1/(t-a) dt.
29709 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29710
29711 XM12=XXM(1)**2
29712 XM22=XXM(2)**2
29713 XM32=XXM(3)**2
29714 S=XXM(4)**2
29715 S13=X
29716
29717 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29718 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29719 &( (X-XM22-S)**2 -4D0*XM22*S ) )
29720
29721 S23MIN=(S23AVE-S23DEL)
29722 S23MAX=(S23AVE+S23DEL)
29723
29724 XMV=XXM(7)
29725 XMG=XXM(8)
29726 XMSD=XXM(5)**2
29727 XMSU=XXM(6)**2
29728 OL=XXM(9)
29729 OR=XXM(10)
29730 OL2=OL**2
29731 OR2=OR**2
29732 LE=XXM(11)
29733 RE=XXM(12)
29734 LE2=LE**2
29735 RE2=RE**2
29736 FLI=XXM(13)
29737 FLJ=XXM(14)
29738 FRI=XXM(15)
29739 FRJ=XXM(16)
29740
29741 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
29742 SIJ=2D0*XXM(2)*XXM(4)*S13
29743
29744 IF(XMV.LE.1000D0) THEN
29745 WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
29746 & +SIJ*(S23MAX-S23MIN) )/WPROP2
29747 IF(XXM(5).LE.10000D0) THEN
29748 WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29749 & + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
29750 WFL1=WFL1*(S13-XMV**2)/WPROP2
29751 ELSE
29752 WFL1=0D0
29753 ENDIF
29754 IF(XXM(6).LE.10000D0) THEN
29755 WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29756 & + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
29757 WFL2=WFL2*(S13-XMV**2)/WPROP2
29758 ELSE
29759 WFL2=0D0
29760 ENDIF
29761 ELSE
29762 WW=0D0
29763 WFL1=0D0
29764 WFL2=0D0
29765 ENDIF
29766 IF(XXM(5).LE.10000D0) THEN
29767 WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29768 & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
29769 ELSE
29770 WF1=0D0
29771 ENDIF
29772 IF(XXM(6).LE.10000D0) THEN
29773 WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29774 & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
29775 ELSE
29776 WF2=0D0
29777 ENDIF
29778
29779C...WFL1=0.0
29780C...WFL2=0.0
29781 PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
29782 IF(PYXXZ5.LT.0D0) THEN
29783 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
29784 WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
29785 WRITE(MSTU(11),*) (XXM(I),I=5,8)
29786 WRITE(MSTU(11),*) (XXM(I),I=9,12)
29787 WRITE(MSTU(11),*) (XXM(I),I=13,16)
29788 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
29789 WRITE(MSTU(11),*) S23MIN,S23MAX
29790 PYXXZ5=0D0
29791 ENDIF
29792
29793 RETURN
29794 END
29795
29796C*********************************************************************
29797
29798*$ CREATE PYXXW5.FOR
29799*COPY PYXXW5
29800C...PYXXW5
29801C...Calculates chi0(+) -> chi+(0) + f + ~f'.
29802
29803 FUNCTION PYXXW5(X)
29804
29805C...Double precision and integer declarations.
29806 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29807 INTEGER PYK,PYCHGE,PYCOMP
29808C...Parameter statement to help give large particle numbers.
29809 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29810C...Commonblocks.
29811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29812 COMMON/PYINTS/XXM(20)
29813 SAVE /PYDAT1/,/PYINTS/
29814
29815C...Local variables.
29816 DOUBLE PRECISION PYXXW5,X
29817 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
29818 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
29819 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
29820 DOUBLE PRECISION SIJ
29821 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29822 INTEGER IK
29823 SAVE IK
29824 DATA IK/0/
29825 DATA SR2/1.4142136D0/
29826
29827C...Statement functions.
29828C...Integral from x to y of (t-a)(b-t) dt.
29829 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29830C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29831 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29832 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29833C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29834 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29835 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29836C...Integral from x to y of (t-a)/(b-t) dt.
29837 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29838C...Integral from x to y of 1/(t-a) dt.
29839 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29840
29841 XM12=XXM(1)**2
29842 XM22=XXM(2)**2
29843 XM32=XXM(3)**2
29844 S=XXM(4)**2
29845 S13=X
29846 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
29847 S23AVE=0.5D0*(XM22+S-S13)
29848 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
29849 ELSE
29850 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29851 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29852 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
29853 ENDIF
29854 S23MIN=(S23AVE-S23DEL)
29855 S23MAX=(S23AVE+S23DEL)
29856 IF(S23DEL.LT.1D-3) THEN
29857 PYXXW5=0D0
29858 RETURN
29859 ENDIF
29860 XMV=XXM(9)
29861 XMG=XXM(10)
29862 XMSD=XXM(11)**2
29863 XMSU=XXM(12)**2
29864 OL=XXM(5)
29865 OR=XXM(6)
29866 FLD=XXM(7)
29867 FLU=XXM(8)
29868
29869 WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
29870 SIJ=S13*XXM(2)*XXM(4)
29871 IF(XMV.LE.1000D0) THEN
29872 WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
29873 & -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
29874 WW=WW/WPROP2
29875 IF(XXM(11).LE.10000D0) THEN
29876 WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
29877 & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29878 WWD=-WWD*SR2*FLD
29879 WWD=WWD*(S13-XMV**2)/WPROP2
29880 ELSE
29881 WWD=0D0
29882 ENDIF
29883 IF(XXM(12).LE.10000D0) THEN
29884 WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
29885 & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29886 WWU=WWU*SR2*FLU
29887 WWU=WWU*(S13-XMV**2)/WPROP2
29888 ELSE
29889 WWU=0D0
29890 ENDIF
29891 ELSE
29892 WW=0D0
29893 WWD=0D0
29894 WWU=0D0
29895 ENDIF
29896 IF(XXM(12).LE.10000D0) THEN
29897 WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29898 ELSE
29899 WU=0D0
29900 ENDIF
29901 IF(XXM(11).LE.10000D0) THEN
29902 WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29903 ELSE
29904 WD=0D0
29905 ENDIF
29906 IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
29907 WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
29908 ELSE
29909 WUD=0D0
29910 ENDIF
29911
29912 PYXXW5=WW+WU+WD+WWU+WWD+WUD
29913
29914 IF(PYXXW5.LT.0D0) THEN
29915 IF(IK.EQ.0) THEN
29916 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
29917 WRITE(MSTU(11),*) WW,WU,WD
29918 WRITE(MSTU(11),*) WWD,WWU,WUD
29919 WRITE(MSTU(11),*) SQRT(S13)
29920 WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
29921 IK=1
29922 ENDIF
29923 PYXXW5=0D0
29924 ENDIF
29925
29926 RETURN
29927 END
29928
29929C*********************************************************************
29930
29931*$ CREATE PYXXGA.FOR
29932*COPY PYXXGA
29933C...PYXXGA
29934C...Calculates chi0_i -> chi0_j + gamma.
29935
29936 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
29937
29938C...Double precision and integer declarations.
29939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29940 INTEGER PYK,PYCHGE,PYCOMP
29941
29942C...Local variables.
29943 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
29944 DOUBLE PRECISION F1,F2
29945
29946 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
29947 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
29948 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
29949 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
29950
29951 RETURN
29952 END
29953
29954C*********************************************************************
29955
29956*$ CREATE PYX2XG.FOR
29957*COPY PYX2XG
29958C...PYX2XG
29959C...Calculates the decay rate for ino -> ino + gauge boson.
29960
29961 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
29962
29963C...Double precision and integer declarations.
29964 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29965 INTEGER PYK,PYCHGE,PYCOMP
29966
29967C...Local variables.
29968 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
29969 DOUBLE PRECISION XL,PYLAMF,C1
29970 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
29971
29972 XMI2=XM1**2
29973 XMI3=ABS(XM1**3)
29974 XMJ2=XM2**2
29975 XMV2=XM3**2
29976 XL=PYLAMF(XMI2,XMJ2,XMV2)
29977 PYX2XG=C1/8D0/XMI3*SQRT(XL)
29978 &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
29979 &12D0*GL*GR*XM1*XM2*XMV2)
29980
29981 RETURN
29982 END
29983
29984C*********************************************************************
29985
29986*$ CREATE PYX2XH.FOR
29987*COPY PYX2XH
29988C...PYX2XH
29989C...Calculates the decay rate for ino -> ino + H.
29990
29991 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
29992
29993C...Double precision and integer declarations.
29994 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29995 INTEGER PYK,PYCHGE,PYCOMP
29996
29997C...Local variables.
29998 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
29999 DOUBLE PRECISION XL,PYLAMF,C1
30000 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
30001
30002 XMI2=XM1**2
30003 XMI3=ABS(XM1**3)
30004 XMJ2=XM2**2
30005 XMV2=XM3**2
30006 XL=PYLAMF(XMI2,XMJ2,XMV2)
30007 PYX2XH=C1/8D0/XMI3*SQRT(XL)
30008 &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
30009 &4D0*GL*GR*XM1*XM2)
30010
30011 RETURN
30012 END
30013
30014C*********************************************************************
30015
30016*$ CREATE PYXXZ2.FOR
30017*COPY PYXXZ2
30018C...PYXXZ2
30019C...Calculates chi+ -> chi+ + f + ~f.
30020
30021 FUNCTION PYXXZ2(X)
30022
30023C...Double precision and integer declarations.
30024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30025 INTEGER PYK,PYCHGE,PYCOMP
30026C...Parameter statement to help give large particle numbers.
30027 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30028C...Commonblocks.
30029 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30030 COMMON/PYINTS/XXM(20)
30031 SAVE /PYDAT1/,/PYINTS/
30032
30033C...Local variables.
30034 DOUBLE PRECISION PYXXZ2,X
30035 DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
30036 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
30037 DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
30038 DOUBLE PRECISION SIJ
30039 DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
30040 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
30041 INTEGER I
30042 DATA SR2/1.4142136D0/
30043
30044C...Statement functions.
30045C...Integral from x to y of (t-a)(b-t) dt.
30046 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
30047C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
30048 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
30049 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
30050C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
30051 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
30052 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
30053C...Integral from x to y of 1/(t-a) dt.
30054 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
30055
30056 XM12=XXM(1)**2
30057 XM22=XXM(2)**2
30058 XM32=XXM(3)**2
30059 S=XXM(4)**2
30060 S13=X
30061 IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
30062 S23AVE=0.5D0*(XM22+S-S13)
30063 S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
30064 ELSE
30065 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
30066 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
30067 & ( (X-XM22-S)**2 -4D0*XM22*S ) )
30068 ENDIF
30069 S23MIN=(S23AVE-S23DEL)
30070 S23MAX=(S23AVE+S23DEL)
30071 IF(S23DEL.LT.1D-3) THEN
30072 PYXXZ2=0D0
30073 RETURN
30074 ENDIF
30075
30076 XMV=XXM(9)
30077 XMG=XXM(10)
30078 XMSL=XXM(11)**2
30079 OL=XXM(5)
30080 OR=XXM(6)
30081 OL2=OL**2
30082 OR2=OR**2
30083 LE=XXM(7)
30084 RE=XXM(8)
30085 LE2=LE**2
30086 RE2=RE**2
30087 CT=XXM(12)
30088
30089 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
30090 SIJ=XXM(2)*XXM(4)*S13
30091 WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
30092 &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
30093 WW=WW/WPROP2
30094 IF(XMSL.GT.1D4*S) THEN
30095 WD=0D0
30096 WWD=0D0
30097 ELSE
30098 WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
30099 WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
30100 & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
30101 WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
30102 ENDIF
30103
30104 PYXXZ2=(WW+WD+WWD)
30105 IF(PYXXZ2.LT.0D0) THEN
30106 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
30107 WRITE(MSTU(11),*) WW,WD,WWD
30108 WRITE(MSTU(11),*) S23MIN,S23MAX
30109 WRITE(MSTU(11),*) (XXM(I),I=1,4)
30110 WRITE(MSTU(11),*) (XXM(I),I=5,8)
30111 WRITE(MSTU(11),*) (XXM(I),I=9,12)
30112 PYXXZ2=0D0
30113 ENDIF
30114
30115 RETURN
30116 END
30117
30118C*********************************************************************
30119
30120*$ CREATE PYHEXT.FOR
30121*COPY PYHEXT
30122C...PYHEXT
30123C...Calculates the non-standard decay modes of the Higgs boson.
30124
30125 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
30126
30127C...Double precision and integer declarations.
30128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30129 INTEGER PYK,PYCHGE,PYCOMP
30130C...Parameter statement to help give large particle numbers.
30131 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30132C...Commonblocks.
30133 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30134 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30135 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30136 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
30137 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
30138 &SFMIX(16,4)
30139 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
30140
30141C...Local variables.
30142 INTEGER KFIN
30143 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
30144 &XMZ,XMZ2,AXMJ,AXMI
30145 DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
30146 DOUBLE PRECISION S12MIN,S12MAX
30147 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
30148 DOUBLE PRECISION PYLAMF,XL,CF,EI
30149 INTEGER IDU,IC,ILR,IFL
30150 DOUBLE PRECISION TANW,XW,AEM,C1,AS
30151 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
30152 DOUBLE PRECISION XLAM(0:200)
30153 INTEGER IDLAM(200,3)
30154 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
30155 INTEGER ITH(4)
30156 INTEGER KFNCHI(4),KFCCHI(2)
30157 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
30158 DOUBLE PRECISION SR2
30159 DOUBLE PRECISION BETA,ALFA
30160 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
30161 DOUBLE PRECISION PYALEM,PI,PYALPS
30162 DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
30163 DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
30164 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
30165 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
30166 DATA ITH/25,35,36,37/
30167 DATA ETAH/1D0,1D0,-1D0/
30168 DATA SR2/1.4142136D0/
30169 DATA PI/3.141592654D0/
30170 DATA KFNCHI/1000022,1000023,1000025,1000035/
30171 DATA KFCCHI/1000024,1000037/
30172
30173C...COUNT THE NUMBER OF DECAY MODES
30174 LKNT=IKNT
30175
30176 XMW=PMAS(24,1)
30177 XMW2=XMW**2
30178 XMZ=PMAS(23,1)
30179 XMZ2=XMZ**2
30180 XW=PARU(102)
30181 TANW = SQRT(XW/(1D0-XW))
30182 CW=SQRT(1D0-XW)
30183
30184C...1 - 4 DEPENDING ON Higgs species.
30185 IH=1
30186 IF(KFIN.EQ.ITH(2)) IH=2
30187 IF(KFIN.EQ.ITH(3)) IH=3
30188 IF(KFIN.EQ.ITH(4)) IH=4
30189
30190 XMI=PMAS(KFIN,1)
30191 XMI2=XMI**2
30192 AXMI=ABS(XMI)
30193 AEM=PYALEM(XMI2)
30194 AS =PYALPS(XMI2)
30195 C1=AEM/XW
30196 XMI3=ABS(XMI**3)
30197
30198 TANB=RMSS(5)
30199 BETA=ATAN(TANB)
30200 CBETA=COS(BETA)
30201 SBETA=TANB*CBETA
30202 ALFA=RMSS(18)
30203 COSA=COS(ALFA)
30204 SINA=SIN(ALFA)
30205 ATRIT=RMSS(16)
30206 ATRIB=RMSS(15)
30207 ATRIL=RMSS(17)
30208 XMUZ=-RMSS(4)
30209
30210 IF(IH.EQ.4) GOTO 180
30211
30212C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
30213C...H0_K -> CHI0_I + CHI0_J
30214 EH(1)=SINA
30215 EH(2)=COSA
30216 EH(3)=-SBETA
30217 DH(1)=COSA
30218 DH(2)=-SINA
30219 DH(3)=CBETA
30220 DO 110 IJ=1,4
30221 XMJ=SMZ(IJ)
30222 AXMJ=ABS(XMJ)
30223 DO 100 IK=1,IJ
30224 XMK=SMZ(IK)
30225 AXMK=ABS(XMK)
30226 IF(AXMI.GE.AXMJ+AXMK) THEN
30227 LKNT=LKNT+1
30228 F21K=0.5D0*
30229 & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
30230 & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
30231 & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
30232 & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
30233 F12K=0.5D0*
30234 & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
30235 & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
30236 & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
30237 & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
30238C...SIGN OF MASSES I,J
30239 XML=XMK*ETAH(IH)
30240 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30241 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
30242 IDLAM(LKNT,1)=KFNCHI(IJ)
30243 IDLAM(LKNT,2)=KFNCHI(IK)
30244 IDLAM(LKNT,3)=0
30245 ENDIF
30246 100 CONTINUE
30247 110 CONTINUE
30248
30249C...H0_K -> CHI+_I CHI-_J
30250 DO 130 IJ=1,2
30251 XMJ=SMW(IJ)
30252 AXMJ=ABS(XMJ)
30253 DO 120 IK=1,2
30254 XMK=SMW(IK)
30255 AXMK=ABS(XMK)
30256 IF(AXMI.GE.AXMJ+AXMK) THEN
30257 LKNT=LKNT+1
30258 F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
30259 & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
30260 F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
30261 & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
30262 XML=-XMK*ETAH(IH)
30263 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30264 IDLAM(LKNT,1)=KFCCHI(IJ)
30265 IDLAM(LKNT,2)=-KFCCHI(IK)
30266 IDLAM(LKNT,3)=0
30267 ENDIF
30268 120 CONTINUE
30269 130 CONTINUE
30270
30271C...HIGGS TO SFERMION SFERMION
30272 DO 160 IFL=1,16
30273 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
30274 IJ=KSUSY1+IFL
30275 XMJL=PMAS(PYCOMP(IJ),1)
30276 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
30277 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
30278 XMJ=XMJL
30279 XMJ2=XMJ**2
30280 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30281 XMF=PMAS(IFL,1)
30282 EI=KCHG(IFL,1)/3D0
30283 IDU=2-MOD(IFL,2)
30284
30285 IF(IH.EQ.1) THEN
30286 IF(IDU.EQ.1) THEN
30287 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
30288 & XMF**2/XMW*SINA/CBETA
30289 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
30290 & XMF**2/XMW*SINA/CBETA
30291 IF(IFL.EQ.5) THEN
30292 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30293 & ATRIB*SINA)
30294 ELSEIF(IFL.EQ.15) THEN
30295 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30296 & ATRIL*SINA)
30297 ELSE
30298 GHLR=0D0
30299 ENDIF
30300 ELSE
30301 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
30302 & XMF**2/XMW*COSA/SBETA
30303 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
30304 & XMF**2/XMW*COSA/SBETA
30305 IF(IFL.EQ.6) THEN
30306 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
30307 & ATRIT*COSA)
30308 ELSE
30309 GHLR=0D0
30310 ENDIF
30311 ENDIF
30312
30313 ELSEIF(IH.EQ.2) THEN
30314 IF(IDU.EQ.1) THEN
30315 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
30316 & XMF**2/XMW*COSA/CBETA
30317 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30318 & XMF**2/XMW*COSA/CBETA
30319 IF(IFL.EQ.5) THEN
30320 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30321 & ATRIB*COSA)
30322 ELSEIF(IFL.EQ.15) THEN
30323 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30324 & ATRIL*COSA)
30325 ELSE
30326 GHLR=0D0
30327 ENDIF
30328 ELSE
30329 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
30330 & XMF**2/XMW*SINA/SBETA
30331 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30332 & XMF**2/XMW*SINA/SBETA
30333 IF(IFL.EQ.6) THEN
30334 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
30335 & ATRIT*SINA)
30336 ELSE
30337 GHLR=0D0
30338 ENDIF
30339 ENDIF
30340
30341 ELSEIF(IH.EQ.3) THEN
30342 GHLL=0D0
30343 GHRR=0D0
30344 GHLR=0D0
30345 IF(IDU.EQ.1) THEN
30346 IF(IFL.EQ.5) THEN
30347 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
30348 ELSEIF(IFL.EQ.15) THEN
30349 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
30350 ENDIF
30351 ELSE
30352 IF(IFL.EQ.6) THEN
30353 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
30354 ENDIF
30355 ENDIF
30356 ENDIF
30357 IF(IH.EQ.3) GOTO 140
30358
30359 AL=SFMIX(IFL,1)**2
30360 AR=SFMIX(IFL,2)**2
30361 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
30362 IF(IFL.LE.6) THEN
30363 CF=3D0
30364 ELSE
30365 CF=1D0
30366 ENDIF
30367
30368 IF(AXMI.GE.2D0*XMJ) THEN
30369 LKNT=LKNT+1
30370 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30371 & (GHLL*AL+GHRR*AR
30372 & +2D0*GHLR*ALR)**2
30373 IDLAM(LKNT,1)=IJ
30374 IDLAM(LKNT,2)=-IJ
30375 IDLAM(LKNT,3)=0
30376 ENDIF
30377
30378 IF(AXMI.GE.2D0*XMJR) THEN
30379 LKNT=LKNT+1
30380 AL=SFMIX(IFL,3)**2
30381 AR=SFMIX(IFL,4)**2
30382 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
30383 XMJ=XMJR
30384 XMJ2=XMJ**2
30385 XL=PYLAMF(XMI2,XMJ2,XMJ2)
30386 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30387 & (GHLL*AL+GHRR*AR
30388 & +2D0*GHLR*ALR)**2
30389 IDLAM(LKNT,1)=IJ+KSUSY1
30390 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30391 IDLAM(LKNT,3)=0
30392 ENDIF
30393 140 CONTINUE
30394
30395 IF(AXMI.GE.XMJL+XMJR) THEN
30396 LKNT=LKNT+1
30397 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
30398 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
30399 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
30400 XMJ=XMJR
30401 XMJ2=XMJ**2
30402 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
30403 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30404 & (GHLL*AL+GHRR*AR)**2
30405 IDLAM(LKNT,1)=IJ
30406 IDLAM(LKNT,2)=-(IJ+KSUSY1)
30407 IDLAM(LKNT,3)=0
30408 LKNT=LKNT+1
30409 IDLAM(LKNT,1)=-IJ
30410 IDLAM(LKNT,2)=IJ+KSUSY1
30411 IDLAM(LKNT,3)=0
30412 XLAM(LKNT)=XLAM(LKNT-1)
30413 ENDIF
30414 ENDIF
30415 150 CONTINUE
30416 160 CONTINUE
30417 170 CONTINUE
30418
30419 GOTO 230
30420 180 CONTINUE
30421
30422C...H+ -> CHI+_I + CHI0_J
30423 DO 200 IJ=1,4
30424 XMJ=SMZ(IJ)
30425 AXMJ=ABS(XMJ)
30426 XMJ2=XMJ**2
30427 DO 190 IK=1,2
30428 XMK=SMW(IK)
30429 AXMK=ABS(XMK)
30430 XMK2=XMK**2
30431 IF(AXMI.GE.AXMJ+AXMK) THEN
30432 LKNT=LKNT+1
30433 GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
30434 & TANW)*VMIX(IK,2)/SR2)
30435 GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
30436 & TANW)*UMIX(IK,2)/SR2)
30437 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
30438 IDLAM(LKNT,1)=KFNCHI(IJ)
30439 IDLAM(LKNT,2)=KFCCHI(IK)
30440 IDLAM(LKNT,3)=0
30441 ENDIF
30442 190 CONTINUE
30443 200 CONTINUE
30444
30445 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
30446 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
30447 AL=0D0
30448 AR=0D0
30449 CF=3D0
30450
30451C...H+ -> T_1 B_1~
30452 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30453 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30454 IF(XMI.GE.XM1+XM2) THEN
30455 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30456 LKNT=LKNT+1
30457 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30458 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
30459 IDLAM(LKNT,1)=KSUSY1+6
30460 IDLAM(LKNT,2)=-(KSUSY1+5)
30461 IDLAM(LKNT,3)=0
30462 ENDIF
30463
30464C...H+ -> T_2 B_1~
30465 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30466 XM2=PMAS(PYCOMP(KSUSY1+5),1)
30467 IF(XMI.GE.XM1+XM2) THEN
30468 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30469 LKNT=LKNT+1
30470 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30471 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
30472 IDLAM(LKNT,1)=KSUSY2+6
30473 IDLAM(LKNT,2)=-(KSUSY1+5)
30474 IDLAM(LKNT,3)=0
30475 ENDIF
30476
30477C...H+ -> T_1 B_2~
30478 XM1=PMAS(PYCOMP(KSUSY1+6),1)
30479 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30480 IF(XMI.GE.XM1+XM2) THEN
30481 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30482 LKNT=LKNT+1
30483 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30484 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
30485 IDLAM(LKNT,1)=KSUSY1+6
30486 IDLAM(LKNT,2)=-(KSUSY2+5)
30487 IDLAM(LKNT,3)=0
30488 ENDIF
30489
30490C...H+ -> T_2 B_2~
30491 XM1=PMAS(PYCOMP(KSUSY2+6),1)
30492 XM2=PMAS(PYCOMP(KSUSY2+5),1)
30493 IF(XMI.GE.XM1+XM2) THEN
30494 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30495 LKNT=LKNT+1
30496 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30497 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
30498 IDLAM(LKNT,1)=KSUSY2+6
30499 IDLAM(LKNT,2)=-(KSUSY2+5)
30500 IDLAM(LKNT,3)=0
30501 ENDIF
30502
30503C...H+ -> UL DL~
30504 GL=-XMW/SR2*SIN(2D0*BETA)
30505 DO 210 IJ=1,3,2
30506 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30507 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30508 IF(XMI.GE.XM1+XM2) THEN
30509 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30510 LKNT=LKNT+1
30511 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30512 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30513 IDLAM(LKNT,2)=KSUSY1+IJ+1
30514 IDLAM(LKNT,3)=0
30515 ENDIF
30516 210 CONTINUE
30517
30518C...H+ -> EL~ NUL
30519 CF=1D0
30520 DO 220 IJ=11,13,2
30521 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30522 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30523 IF(XMI.GE.XM1+XM2) THEN
30524 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30525 LKNT=LKNT+1
30526 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30527 IDLAM(LKNT,1)=-(KSUSY1+IJ)
30528 IDLAM(LKNT,2)=KSUSY1+IJ+1
30529 IDLAM(LKNT,3)=0
30530 ENDIF
30531 220 CONTINUE
30532
30533C...H+ -> TAU1 NUTAUL
30534 XM1=PMAS(PYCOMP(KSUSY1+15),1)
30535 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30536 IF(XMI.GE.XM1+XM2) THEN
30537 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30538 LKNT=LKNT+1
30539 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
30540 IDLAM(LKNT,1)=-(KSUSY1+15)
30541 IDLAM(LKNT,2)= KSUSY1+16
30542 IDLAM(LKNT,3)=0
30543 ENDIF
30544
30545C...H+ -> TAU2 NUTAUL
30546 XM1=PMAS(PYCOMP(KSUSY2+15),1)
30547 XM2=PMAS(PYCOMP(KSUSY1+16),1)
30548 IF(XMI.GE.XM1+XM2) THEN
30549 XL=PYLAMF(XMI2,XM1**2,XM2**2)
30550 LKNT=LKNT+1
30551 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
30552 IDLAM(LKNT,1)=-(KSUSY2+15)
30553 IDLAM(LKNT,2)= KSUSY1+16
30554 IDLAM(LKNT,3)=0
30555 ENDIF
30556
30557 230 CONTINUE
30558 IKNT=LKNT
30559 XLAM(0)=0D0
30560 DO 240 I=1,IKNT
30561 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
30562 XLAM(0)=XLAM(0)+XLAM(I)
30563 240 CONTINUE
30564 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
30565
30566 RETURN
30567 END
30568
30569C*********************************************************************
30570
30571*$ CREATE PYH2XX.FOR
30572*COPY PYH2XX
30573C...PYH2XX
30574C...Calculates the decay rate for a Higgs to an ino pair.
30575
30576 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
30577
30578C...Double precision and integer declarations.
30579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30580 INTEGER PYK,PYCHGE,PYCOMP
30581C...Commonblocks.
30582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30583 SAVE /PYDAT1/
30584
30585C...Local variables.
30586 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
30587 DOUBLE PRECISION XL,PYLAMF,C1
30588 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
30589
30590 XMI2=XM1**2
30591 XMI3=ABS(XM1**3)
30592 XMJ2=XM2**2
30593 XMK2=XM3**2
30594 XL=PYLAMF(XMI2,XMJ2,XMK2)
30595 PYH2XX=C1/4D0/XMI3*SQRT(XL)
30596 &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
30597 &4D0*GL*GR*XM3*XM2)
30598 IF(PYH2XX.LT.0D0) THEN
30599 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
30600 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
30601 STOP
30602 ENDIF
30603
30604 RETURN
30605 END
30606
30607C*********************************************************************
30608
30609*$ CREATE PYGAUS.FOR
30610*COPY PYGAUS
30611C...PYGAUS
30612C...Integration by adaptive Gaussian quadrature.
30613C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
30614
30615 FUNCTION PYGAUS(F, A, B, EPS)
30616
30617C...Double precision and integer declarations.
30618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30619 INTEGER PYK,PYCHGE,PYCOMP
30620
30621C...Local declarations.
30622 EXTERNAL F
30623 DOUBLE PRECISION W(12), X(12)
30624 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
30625 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
30626 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
30627 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
30628 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
30629 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
30630 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
30631 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
30632 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
30633 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
30634 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
30635 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
30636
30637C...The Gaussian quadrature algorithm.
30638 H = 0D0
30639 IF(B .EQ. A) GO TO 140
30640 CONST = 5D-3 / ABS(B-A)
30641 BB = A
30642 100 CONTINUE
30643 AA = BB
30644 BB = B
30645 110 CONTINUE
30646 C1 = 0.5D0*(BB+AA)
30647 C2 = 0.5D0*(BB-AA)
30648 S8 = 0D0
30649 DO 120 I = 1, 4
30650 U = C2*X(I)
30651 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
30652 120 CONTINUE
30653 S16 = 0D0
30654 DO 130 I = 5, 12
30655 U = C2*X(I)
30656 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
30657 130 CONTINUE
30658 S16 = C2*S16
30659 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
30660 H = H + S16
30661 IF(BB .NE. B) GO TO 100
30662 ELSE
30663 BB = C1
30664 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
30665 H = 0D0
30666 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
30667 GO TO 140
30668 ENDIF
30669 140 CONTINUE
30670 PYGAUS = H
30671
30672 RETURN
30673 END
30674
30675C*********************************************************************
30676
30677*$ CREATE PYSIMP.FOR
30678*COPY PYSIMP
30679C...PYSIMP
30680C...Simpson formula for an integral.
30681
30682 FUNCTION PYSIMP(Y,X0,X1,N)
30683
30684C...Double precision and integer declarations.
30685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30686 INTEGER PYK,PYCHGE,PYCOMP
30687
30688C...Local variables.
30689 DOUBLE PRECISION Y,X0,X1,H,S
30690 DIMENSION Y(0:N)
30691
30692 S=0D0
30693 H=(X1-X0)/N
30694 DO 100 I=0,N-2,2
30695 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
30696 100 CONTINUE
30697 PYSIMP=S*H/3D0
30698
30699 RETURN
30700 END
30701
30702C*********************************************************************
30703
30704*$ CREATE PYLAMF.FOR
30705*COPY PYLAMF
30706C...PYLAMF
30707C...The standard lambda function.
30708
30709 FUNCTION PYLAMF(X,Y,Z)
30710
30711C...Double precision and integer declarations.
30712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30713 INTEGER PYK,PYCHGE,PYCOMP
30714
30715C...Local variables.
30716 DOUBLE PRECISION PYLAMF,X,Y,Z
30717
30718 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
30719 IF(PYLAMF.LT.0D0) PYLAMF=0D0
30720
30721 RETURN
30722 END
30723
30724C*********************************************************************
30725
30726*$ CREATE PYTBDY.FOR
30727*COPY PYTBDY
30728C...PYTBDY
30729C...Generates 3-body decays of gauginos.
30730
30731 SUBROUTINE PYTBDY(XM)
30732
30733C...Double precision and integer declarations.
30734 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30735 INTEGER PYK,PYCHGE,PYCOMP
30736C...Parameter statement to help give large particle numbers.
30737 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30738C...Commonblocks.
30739 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30740 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30741 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30742 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
30743 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30744 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
30745
30746C...Local variables.
30747 DOUBLE PRECISION XM(5)
30748 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
30749 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
30750 DOUBLE PRECISION CPHI1,SPHI1
30751 DOUBLE PRECISION S23DEL,EPS
30752 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
30753 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
30754 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
30755 DATA EPS/1D-6/
30756
30757C...GENERATE S12
30758 S12MIN=(XM(1)+XM(2))**2
30759 S12MAX=(XM(5)-XM(3))**2
30760 YJACO1=S12MAX-S12MIN
30761
30762C...FIND S12*
30763 AX=S12MIN
30764 CX=S12MAX
30765 BX=S12MIN+0.5D0*YJACO1
30766 X0=AX
30767 X3=CX
30768 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
30769 X1=BX
30770 X2=BX+C*(CX-BX)
30771 ELSE
30772 X2=BX
30773 X1=BX-C*(BX-AX)
30774 ENDIF
30775
30776C...SOLVE FOR F1 AND F2
30777 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30778 &-(2D0*XM(1)*XM(2))**2
30779 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30780 &-(2D0*XM(3)*XM(5))**2
30781 S23DF1=S23DF1*EPS
30782 S23DF2=S23DF2*EPS
30783 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30784 F1=-2D0*S23DEL/EPS
30785 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30786 &-(2D0*XM(1)*XM(2))**2
30787 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30788 &-(2D0*XM(3)*XM(5))**2
30789 S23DF1=S23DF1*EPS
30790 S23DF2=S23DF2*EPS
30791 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30792 F2=-2D0*S23DEL/EPS
30793
30794 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
30795 IF(F2.LT.F1)THEN
30796 X0=X1
30797 X1=X2
30798 X2=R*X1+C*X3
30799 F1=F2
30800 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30801 & -(2D0*XM(1)*XM(2))**2
30802 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30803 & -(2D0*XM(3)*XM(5))**2
30804 S23DF1=S23DF1*EPS
30805 S23DF2=S23DF2*EPS
30806 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30807 F2=-2D0*S23DEL/EPS
30808 ELSE
30809 X3=X2
30810 X2=X1
30811 X1=R*X2+C*X0
30812 F2=F1
30813 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30814 & -(2D0*XM(1)*XM(2))**2
30815 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30816 & -(2D0*XM(3)*XM(5))**2
30817 S23DF1=S23DF1*EPS
30818 S23DF2=S23DF2*EPS
30819 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30820 F1=-2D0*S23DEL/EPS
30821 ENDIF
30822 GOTO 100
30823 ENDIF
30824C...WE WANT THE MAXIMUM, NOT THE MINIMUM
30825 IF(F1.LT.F2)THEN
30826 GOLDEN=-F1
30827 XMIN=X1
30828 ELSE
30829 GOLDEN=-F2
30830 XMIN=X2
30831 ENDIF
30832
30833 IKNT=0
30834 110 S12=S12MIN+PYR(0)*YJACO1
30835 IKNT=IKNT+1
30836C...GENERATE S23
30837 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
30838 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
30839 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
30840 &-(2D0*XM(1)*XM(2))**2
30841 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
30842 &-(2D0*XM(3)*XM(5))**2
30843 S23DF1=S23DF1*EPS
30844 S23DF2=S23DF2*EPS
30845 S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
30846 S23DEL=S23DEL/EPS
30847 S23MIN=S23AVE-S23DEL
30848 S23MAX=S23AVE+S23DEL
30849 YJACO2=S23MAX-S23MIN
30850 S23=S23MIN+PYR(0)*YJACO2
30851
30852C...CHECK THE SAMPLING
30853 IF(IKNT.GT.100) THEN
30854 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
30855 GOTO 120
30856 ENDIF
30857 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
30858 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
30859 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
30860 D2=XM(5)-D1-D3
30861 P1=SQRT(D1*D1-XM(1)**2)
30862 P2=SQRT(D2*D2-XM(2)**2)
30863 P3=SQRT(D3*D3-XM(3)**2)
30864 CTHE1=2D0*PYR(0)-1D0
30865 ANG1=2D0*PYR(0)*PARU(1)
30866 CPHI1=COS(ANG1)
30867 SPHI1=SIN(ANG1)
30868 ARG=1D0-CTHE1**2
30869 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30870 STHE1=SQRT(ARG)
30871 P(N+1,1)=P1*STHE1*CPHI1
30872 P(N+1,2)=P1*STHE1*SPHI1
30873 P(N+1,3)=P1*CTHE1
30874 P(N+1,4)=D1
30875
30876C...GET CPHI3
30877 ANG3=2D0*PYR(0)*PARU(1)
30878 CPHI3=COS(ANG3)
30879 SPHI3=SIN(ANG3)
30880 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
30881 ARG=1D0-CTHE3**2
30882 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30883 STHE3=SQRT(ARG)
30884 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
30885 &+P3*STHE3*SPHI3*SPHI1
30886 &+P3*CTHE3*STHE1*CPHI1
30887 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
30888 &-P3*STHE3*SPHI3*CPHI1
30889 &+P3*CTHE3*STHE1*SPHI1
30890 P(N+3,3)=P3*STHE3*CPHI3*STHE1
30891 &+P3*CTHE3*CTHE1
30892 P(N+3,4)=D3
30893
30894 DO 130 I=1,3
30895 P(N+2,I)=-P(N+1,I)-P(N+3,I)
30896 130 CONTINUE
30897 P(N+2,4)=D2
30898
30899 RETURN
30900 END
30901
30902C*********************************************************************
30903
30904*$ CREATE PY1ENT.FOR
30905*COPY PY1ENT
30906C...PY1ENT
30907C...Stores one parton/particle in commonblock PYJETS.
30908
30909 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
30910
30911C...Double precision and integer declarations.
30912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30913 INTEGER PYK,PYCHGE,PYCOMP
30914C...Commonblocks.
30915 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30916 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30917 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30918 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30919
30920C...Standard checks.
30921 MSTU(28)=0
30922 IF(MSTU(12).GE.1) CALL PYLIST(0)
30923 IPA=MAX(1,IABS(IP))
30924 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
30925 &'(PY1ENT:) writing outside PYJETS memory')
30926 KC=PYCOMP(KF)
30927 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
30928
30929C...Find mass. Reset K, P and V vectors.
30930 PM=0D0
30931 IF(MSTU(10).EQ.1) PM=P(IPA,5)
30932 IF(MSTU(10).GE.2) PM=PYMASS(KF)
30933 DO 100 J=1,5
30934 K(IPA,J)=0
30935 P(IPA,J)=0D0
30936 V(IPA,J)=0D0
30937 100 CONTINUE
30938
30939C...Store parton/particle in K and P vectors.
30940 K(IPA,1)=1
30941 IF(IP.LT.0) K(IPA,1)=2
30942 K(IPA,2)=KF
30943 P(IPA,5)=PM
30944 P(IPA,4)=MAX(PE,PM)
30945 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
30946 P(IPA,1)=PA*SIN(THE)*COS(PHI)
30947 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
30948 P(IPA,3)=PA*COS(THE)
30949
30950C...Set N. Optionally fragment/decay.
30951 N=IPA
30952 IF(IP.EQ.0) CALL PYEXEC
30953
30954 RETURN
30955 END
30956
30957C*********************************************************************
30958
30959*$ CREATE PY2ENT.FOR
30960*COPY PY2ENT
30961C...PY2ENT
30962C...Stores two partons/particles in their CM frame,
30963C...with the first along the +z axis.
30964
30965 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
30966
30967C...Double precision and integer declarations.
30968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30969 INTEGER PYK,PYCHGE,PYCOMP
30970C...Commonblocks.
30971 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30972 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30973 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30974 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30975
30976C...Standard checks.
30977 MSTU(28)=0
30978 IF(MSTU(12).GE.1) CALL PYLIST(0)
30979 IPA=MAX(1,IABS(IP))
30980 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
30981 &'(PY2ENT:) writing outside PYJETS memory')
30982 KC1=PYCOMP(KF1)
30983 KC2=PYCOMP(KF2)
30984 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
30985 &'(PY2ENT:) unknown flavour code')
30986
30987C...Find masses. Reset K, P and V vectors.
30988 PM1=0D0
30989 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
30990 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
30991 PM2=0D0
30992 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
30993 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
30994 DO 110 I=IPA,IPA+1
30995 DO 100 J=1,5
30996 K(I,J)=0
30997 P(I,J)=0D0
30998 V(I,J)=0D0
30999 100 CONTINUE
31000 110 CONTINUE
31001
31002C...Check flavours.
31003 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31004 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31005 IF(MSTU(19).EQ.1) THEN
31006 MSTU(19)=0
31007 ELSE
31008 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
31009 & '(PY2ENT:) unphysical flavour combination')
31010 ENDIF
31011 K(IPA,2)=KF1
31012 K(IPA+1,2)=KF2
31013
31014C...Store partons/particles in K vectors for normal case.
31015 IF(IP.GE.0) THEN
31016 K(IPA,1)=1
31017 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
31018 K(IPA+1,1)=1
31019
31020C...Store partons in K vectors for parton shower evolution.
31021 ELSE
31022 K(IPA,1)=3
31023 K(IPA+1,1)=3
31024 K(IPA,4)=MSTU(5)*(IPA+1)
31025 K(IPA,5)=K(IPA,4)
31026 K(IPA+1,4)=MSTU(5)*IPA
31027 K(IPA+1,5)=K(IPA+1,4)
31028 ENDIF
31029
31030C...Check kinematics and store partons/particles in P vectors.
31031 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
31032 &'(PY2ENT:) energy smaller than sum of masses')
31033 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
31034 &(2D0*PECM)
31035 P(IPA,3)=PA
31036 P(IPA,4)=SQRT(PM1**2+PA**2)
31037 P(IPA,5)=PM1
31038 P(IPA+1,3)=-PA
31039 P(IPA+1,4)=SQRT(PM2**2+PA**2)
31040 P(IPA+1,5)=PM2
31041
31042C...Set N. Optionally fragment/decay.
31043 N=IPA+1
31044 IF(IP.EQ.0) CALL PYEXEC
31045
31046 RETURN
31047 END
31048
31049C*********************************************************************
31050
31051*$ CREATE PY3ENT.FOR
31052*COPY PY3ENT
31053C...PY3ENT
31054C...Stores three partons or particles in their CM frame,
31055C...with the first along the +z axis and the third in the (x,z)
31056C...plane with x > 0.
31057
31058 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
31059
31060C...Double precision and integer declarations.
31061 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31062 INTEGER PYK,PYCHGE,PYCOMP
31063C...Commonblocks.
31064 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31065 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31066 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31067 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31068
31069C...Standard checks.
31070 MSTU(28)=0
31071 IF(MSTU(12).GE.1) CALL PYLIST(0)
31072 IPA=MAX(1,IABS(IP))
31073 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
31074 &'(PY3ENT:) writing outside PYJETS memory')
31075 KC1=PYCOMP(KF1)
31076 KC2=PYCOMP(KF2)
31077 KC3=PYCOMP(KF3)
31078 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
31079 &'(PY3ENT:) unknown flavour code')
31080
31081C...Find masses. Reset K, P and V vectors.
31082 PM1=0D0
31083 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31084 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31085 PM2=0D0
31086 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31087 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31088 PM3=0D0
31089 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31090 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31091 DO 110 I=IPA,IPA+2
31092 DO 100 J=1,5
31093 K(I,J)=0
31094 P(I,J)=0D0
31095 V(I,J)=0D0
31096 100 CONTINUE
31097 110 CONTINUE
31098
31099C...Check flavours.
31100 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31101 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31102 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31103 IF(MSTU(19).EQ.1) THEN
31104 MSTU(19)=0
31105 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
31106 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
31107 & KQ1+KQ3.EQ.4)) THEN
31108 ELSE
31109 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
31110 ENDIF
31111 K(IPA,2)=KF1
31112 K(IPA+1,2)=KF2
31113 K(IPA+2,2)=KF3
31114
31115C...Store partons/particles in K vectors for normal case.
31116 IF(IP.GE.0) THEN
31117 K(IPA,1)=1
31118 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
31119 K(IPA+1,1)=1
31120 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
31121 K(IPA+2,1)=1
31122
31123C...Store partons in K vectors for parton shower evolution.
31124 ELSE
31125 K(IPA,1)=3
31126 K(IPA+1,1)=3
31127 K(IPA+2,1)=3
31128 KCS=4
31129 IF(KQ1.EQ.-1) KCS=5
31130 K(IPA,KCS)=MSTU(5)*(IPA+1)
31131 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
31132 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31133 K(IPA+1,9-KCS)=MSTU(5)*IPA
31134 K(IPA+2,KCS)=MSTU(5)*IPA
31135 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31136 ENDIF
31137
31138C...Check kinematics.
31139 MKERR=0
31140 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
31141 &0.5D0*X3*PECM.LE.PM3) MKERR=1
31142 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31143 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
31144 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
31145 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
31146 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
31147 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
31148 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
31149 IF(MKERR.NE.0) CALL PYERRM(13,
31150 &'(PY3ENT:) unphysical kinematical variable setup')
31151
31152C...Store partons/particles in P vectors.
31153 P(IPA,3)=PA1
31154 P(IPA,4)=SQRT(PA1**2+PM1**2)
31155 P(IPA,5)=PM1
31156 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
31157 P(IPA+2,3)=PA3*CTHE3
31158 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
31159 P(IPA+2,5)=PM3
31160 P(IPA+1,1)=-P(IPA+2,1)
31161 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
31162 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
31163 P(IPA+1,5)=PM2
31164
31165C...Set N. Optionally fragment/decay.
31166 N=IPA+2
31167 IF(IP.EQ.0) CALL PYEXEC
31168
31169 RETURN
31170 END
31171
31172C*********************************************************************
31173
31174*$ CREATE PY4ENT.FOR
31175*COPY PY4ENT
31176C...PY4ENT
31177C...Stores four partons or particles in their CM frame, with
31178C...the first along the +z axis, the last in the xz plane with x > 0
31179C...and the second having y < 0 and y > 0 with equal probability.
31180
31181 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
31182
31183C...Double precision and integer declarations.
31184 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31185 INTEGER PYK,PYCHGE,PYCOMP
31186C...Commonblocks.
31187 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31188 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31189 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31190 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31191
31192C...Standard checks.
31193 MSTU(28)=0
31194 IF(MSTU(12).GE.1) CALL PYLIST(0)
31195 IPA=MAX(1,IABS(IP))
31196 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
31197 &'(PY4ENT:) writing outside PYJETS momory')
31198 KC1=PYCOMP(KF1)
31199 KC2=PYCOMP(KF2)
31200 KC3=PYCOMP(KF3)
31201 KC4=PYCOMP(KF4)
31202 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
31203 &'(PY4ENT:) unknown flavour code')
31204
31205C...Find masses. Reset K, P and V vectors.
31206 PM1=0D0
31207 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31208 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31209 PM2=0D0
31210 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31211 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31212 PM3=0D0
31213 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31214 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31215 PM4=0D0
31216 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
31217 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
31218 DO 110 I=IPA,IPA+3
31219 DO 100 J=1,5
31220 K(I,J)=0
31221 P(I,J)=0D0
31222 V(I,J)=0D0
31223 100 CONTINUE
31224 110 CONTINUE
31225
31226C...Check flavours.
31227 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31228 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31229 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31230 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
31231 IF(MSTU(19).EQ.1) THEN
31232 MSTU(19)=0
31233 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
31234 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
31235 & KQ1+KQ4.EQ.4)) THEN
31236 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
31237 & THEN
31238 ELSE
31239 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
31240 ENDIF
31241 K(IPA,2)=KF1
31242 K(IPA+1,2)=KF2
31243 K(IPA+2,2)=KF3
31244 K(IPA+3,2)=KF4
31245
31246C...Store partons/particles in K vectors for normal case.
31247 IF(IP.GE.0) THEN
31248 K(IPA,1)=1
31249 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
31250 K(IPA+1,1)=1
31251 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
31252 & K(IPA+1,1)=2
31253 K(IPA+2,1)=1
31254 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
31255 K(IPA+3,1)=1
31256
31257C...Store partons for parton shower evolution from q-g-g-qbar or
31258C...g-g-g-g event.
31259 ELSEIF(KQ1+KQ2.NE.0) THEN
31260 K(IPA,1)=3
31261 K(IPA+1,1)=3
31262 K(IPA+2,1)=3
31263 K(IPA+3,1)=3
31264 KCS=4
31265 IF(KQ1.EQ.-1) KCS=5
31266 K(IPA,KCS)=MSTU(5)*(IPA+1)
31267 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
31268 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31269 K(IPA+1,9-KCS)=MSTU(5)*IPA
31270 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
31271 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31272 K(IPA+3,KCS)=MSTU(5)*IPA
31273 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
31274
31275C...Store partons for parton shower evolution from q-qbar-q-qbar event.
31276 ELSE
31277 K(IPA,1)=3
31278 K(IPA+1,1)=3
31279 K(IPA+2,1)=3
31280 K(IPA+3,1)=3
31281 K(IPA,4)=MSTU(5)*(IPA+1)
31282 K(IPA,5)=K(IPA,4)
31283 K(IPA+1,4)=MSTU(5)*IPA
31284 K(IPA+1,5)=K(IPA+1,4)
31285 K(IPA+2,4)=MSTU(5)*(IPA+3)
31286 K(IPA+2,5)=K(IPA+2,4)
31287 K(IPA+3,4)=MSTU(5)*(IPA+2)
31288 K(IPA+3,5)=K(IPA+3,4)
31289 ENDIF
31290
31291C...Check kinematics.
31292 MKERR=0
31293 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
31294 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
31295 &MKERR=1
31296 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31297 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
31298 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
31299 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
31300 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
31301 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
31302 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
31303 STHE4=SQRT(1D0-CTHE4**2)
31304 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
31305 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
31306 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
31307 STHE2=SQRT(1D0-CTHE2**2)
31308 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
31309 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
31310 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
31311 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
31312 IF(MKERR.EQ.1) CALL PYERRM(13,
31313 &'(PY4ENT:) unphysical kinematical variable setup')
31314
31315C...Store partons/particles in P vectors.
31316 P(IPA,3)=PA1
31317 P(IPA,4)=SQRT(PA1**2+PM1**2)
31318 P(IPA,5)=PM1
31319 P(IPA+3,1)=PA4*STHE4
31320 P(IPA+3,3)=PA4*CTHE4
31321 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
31322 P(IPA+3,5)=PM4
31323 P(IPA+1,1)=PA2*STHE2*CPHI2
31324 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
31325 P(IPA+1,3)=PA2*CTHE2
31326 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
31327 P(IPA+1,5)=PM2
31328 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
31329 P(IPA+2,2)=-P(IPA+1,2)
31330 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
31331 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
31332 P(IPA+2,5)=PM3
31333
31334C...Set N. Optionally fragment/decay.
31335 N=IPA+3
31336 IF(IP.EQ.0) CALL PYEXEC
31337
31338 RETURN
31339 END
31340
31341C*********************************************************************
31342
31343*$ CREATE PYJOIN.FOR
31344*COPY PYJOIN
31345C...PYJOIN
31346C...Connects a sequence of partons with colour flow indices,
31347C...as required for subsequent shower evolution (or other operations).
31348
31349 SUBROUTINE PYJOIN(NJOIN,IJOIN)
31350
31351C...Double precision and integer declarations.
31352 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31353 INTEGER PYK,PYCHGE,PYCOMP
31354C...Commonblocks.
31355 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31356 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31357 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31358 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31359C...Local array.
31360 DIMENSION IJOIN(*)
31361
31362C...Check that partons are of right types to be connected.
31363 IF(NJOIN.LT.2) GOTO 120
31364 KQSUM=0
31365 DO 100 IJN=1,NJOIN
31366 I=IJOIN(IJN)
31367 IF(I.LE.0.OR.I.GT.N) GOTO 120
31368 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
31369 KC=PYCOMP(K(I,2))
31370 IF(KC.EQ.0) GOTO 120
31371 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
31372 IF(KQ.EQ.0) GOTO 120
31373 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
31374 IF(KQ.NE.2) KQSUM=KQSUM+KQ
31375 IF(IJN.EQ.1) KQS=KQ
31376 100 CONTINUE
31377 IF(KQSUM.NE.0) GOTO 120
31378
31379C...Connect the partons sequentially (closing for gluon loop).
31380 KCS=(9-KQS)/2
31381 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
31382 DO 110 IJN=1,NJOIN
31383 I=IJOIN(IJN)
31384 K(I,1)=3
31385 IF(IJN.NE.1) IP=IJOIN(IJN-1)
31386 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
31387 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
31388 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
31389 K(I,KCS)=MSTU(5)*IN
31390 K(I,9-KCS)=MSTU(5)*IP
31391 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
31392 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
31393 110 CONTINUE
31394
31395C...Error exit: no action taken.
31396 RETURN
31397 120 CALL PYERRM(12,
31398 &'(PYJOIN:) given entries can not be joined by one string')
31399
31400 RETURN
31401 END
31402
31403C*********************************************************************
31404
31405*$ CREATE PYGIVE.FOR
31406*COPY PYGIVE
31407C...PYGIVE
31408C...Sets values of commonblock variables.
31409
31410 SUBROUTINE PYGIVE(CHIN)
31411
31412C...Double precision and integer declarations.
31413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31414 INTEGER PYK,PYCHGE,PYCOMP
31415C...Commonblocks.
31416 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31417 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31418 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31419 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31420 COMMON/PYDAT4/CHAF(500,2)
31421 CHARACTER CHAF*16
31422 COMMON/PYDATR/MRPY(6),RRPY(100)
31423 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31424 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31425 COMMON/PYINT1/MINT(400),VINT(400)
31426 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31427 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31428 COMMON/PYINT4/MWID(500),WIDS(500,5)
31429 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
31430 COMMON/PYINT6/PROC(0:500)
31431 CHARACTER PROC*28
31432 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
31433 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
31434 &XPDIR(-6:6)
31435 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31436 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
31437 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
31438 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
31439C...Local arrays and character variables.
31440 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
31441 &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
31442 &CHINR*16
31443 DIMENSION MSVAR(49,8)
31444
31445C...For each variable to be translated give: name,
31446C...integer/real/character, no. of indices, lower&upper index bounds.
31447 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
31448 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
31449 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
31450 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
31451 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
31452 &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
31453 DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0,
31454 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
31455 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31456 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
31457 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0,
31458 &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0,
31459 &1,1,1,6,4*0, 2,1,1,100,4*0,
31460 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
31461 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
31462 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
31463 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
31464 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
31465 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
31466 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
31467 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
31468 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
31469 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
31470 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
31471
31472C...Length of character variable. Subdivide it into instructions.
31473 IF(MSTU(12).GE.1) CALL PYLIST(0)
31474 CHBIT=CHIN//' '
31475 LBIT=101
31476 100 LBIT=LBIT-1
31477 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
31478 LTOT=0
31479 DO 110 LCOM=1,LBIT
31480 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
31481 LTOT=LTOT+1
31482 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
31483 110 CONTINUE
31484 LLOW=0
31485 120 LHIG=LLOW+1
31486 130 LHIG=LHIG+1
31487 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
31488 LBIT=LHIG-LLOW-1
31489 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
31490
31491C...Identify commonblock variable.
31492 LNAM=1
31493 140 LNAM=LNAM+1
31494 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
31495 &LNAM.LE.6) GOTO 140
31496 CHNAM=CHBIT(1:LNAM-1)//' '
31497 DO 160 LCOM=1,LNAM-1
31498 DO 150 LALP=1,26
31499 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
31500 & CHALP(2)(LALP:LALP)
31501 150 CONTINUE
31502 160 CONTINUE
31503 IVAR=0
31504 DO 170 IV=1,49
31505 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
31506 170 CONTINUE
31507 IF(IVAR.EQ.0) THEN
31508 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
31509 LLOW=LHIG
31510 IF(LLOW.LT.LTOT) GOTO 120
31511 RETURN
31512 ENDIF
31513
31514C...Identify any indices.
31515 I1=0
31516 I2=0
31517 I3=0
31518 NINDX=0
31519 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
31520 LIND=LNAM
31521 180 LIND=LIND+1
31522 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
31523 CHIND=' '
31524 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
31525 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
31526 & THEN
31527 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
31528 READ(CHIND,'(I8)') KF
31529 I1=PYCOMP(KF)
31530 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
31531 & 'c') THEN
31532 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
31533 & CHNAM)
31534 LLOW=LHIG
31535 IF(LLOW.LT.LTOT) GOTO 120
31536 RETURN
31537 ELSE
31538 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31539 READ(CHIND,'(I8)') I1
31540 ENDIF
31541 LNAM=LIND
31542 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31543 NINDX=1
31544 ENDIF
31545 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31546 LIND=LNAM
31547 190 LIND=LIND+1
31548 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
31549 CHIND=' '
31550 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31551 READ(CHIND,'(I8)') I2
31552 LNAM=LIND
31553 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31554 NINDX=2
31555 ENDIF
31556 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31557 LIND=LNAM
31558 200 LIND=LIND+1
31559 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
31560 CHIND=' '
31561 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31562 READ(CHIND,'(I8)') I3
31563 LNAM=LIND+1
31564 NINDX=3
31565 ENDIF
31566
31567C...Check that indices allowed.
31568 IERR=0
31569 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
31570 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
31571 &IERR=2
31572 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
31573 &IERR=3
31574 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
31575 &IERR=4
31576 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
31577 IF(IERR.GE.1) THEN
31578 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
31579 & CHBIT(1:LNAM-1))
31580 LLOW=LHIG
31581 IF(LLOW.LT.LTOT) GOTO 120
31582 RETURN
31583 ENDIF
31584
31585C...Save old value of variable.
31586 IF(IVAR.EQ.1) THEN
31587 IOLD=N
31588 ELSEIF(IVAR.EQ.2) THEN
31589 IOLD=K(I1,I2)
31590 ELSEIF(IVAR.EQ.3) THEN
31591 ROLD=P(I1,I2)
31592 ELSEIF(IVAR.EQ.4) THEN
31593 ROLD=V(I1,I2)
31594 ELSEIF(IVAR.EQ.5) THEN
31595 IOLD=MSTU(I1)
31596 ELSEIF(IVAR.EQ.6) THEN
31597 ROLD=PARU(I1)
31598 ELSEIF(IVAR.EQ.7) THEN
31599 IOLD=MSTJ(I1)
31600 ELSEIF(IVAR.EQ.8) THEN
31601 ROLD=PARJ(I1)
31602 ELSEIF(IVAR.EQ.9) THEN
31603 IOLD=KCHG(I1,I2)
31604 ELSEIF(IVAR.EQ.10) THEN
31605 ROLD=PMAS(I1,I2)
31606 ELSEIF(IVAR.EQ.11) THEN
31607 ROLD=PARF(I1)
31608 ELSEIF(IVAR.EQ.12) THEN
31609 ROLD=VCKM(I1,I2)
31610 ELSEIF(IVAR.EQ.13) THEN
31611 IOLD=MDCY(I1,I2)
31612 ELSEIF(IVAR.EQ.14) THEN
31613 IOLD=MDME(I1,I2)
31614 ELSEIF(IVAR.EQ.15) THEN
31615 ROLD=BRAT(I1)
31616 ELSEIF(IVAR.EQ.16) THEN
31617 IOLD=KFDP(I1,I2)
31618 ELSEIF(IVAR.EQ.17) THEN
31619 CHOLD=CHAF(I1,I2)
31620 ELSEIF(IVAR.EQ.18) THEN
31621 IOLD=MRPY(I1)
31622 ELSEIF(IVAR.EQ.19) THEN
31623 ROLD=RRPY(I1)
31624 ELSEIF(IVAR.EQ.20) THEN
31625 IOLD=MSEL
31626 ELSEIF(IVAR.EQ.21) THEN
31627 IOLD=MSUB(I1)
31628 ELSEIF(IVAR.EQ.22) THEN
31629 IOLD=KFIN(I1,I2)
31630 ELSEIF(IVAR.EQ.23) THEN
31631 ROLD=CKIN(I1)
31632 ELSEIF(IVAR.EQ.24) THEN
31633 IOLD=MSTP(I1)
31634 ELSEIF(IVAR.EQ.25) THEN
31635 ROLD=PARP(I1)
31636 ELSEIF(IVAR.EQ.26) THEN
31637 IOLD=MSTI(I1)
31638 ELSEIF(IVAR.EQ.27) THEN
31639 ROLD=PARI(I1)
31640 ELSEIF(IVAR.EQ.28) THEN
31641 IOLD=MINT(I1)
31642 ELSEIF(IVAR.EQ.29) THEN
31643 ROLD=VINT(I1)
31644 ELSEIF(IVAR.EQ.30) THEN
31645 IOLD=ISET(I1)
31646 ELSEIF(IVAR.EQ.31) THEN
31647 IOLD=KFPR(I1,I2)
31648 ELSEIF(IVAR.EQ.32) THEN
31649 ROLD=COEF(I1,I2)
31650 ELSEIF(IVAR.EQ.33) THEN
31651 IOLD=ICOL(I1,I2,I3)
31652 ELSEIF(IVAR.EQ.34) THEN
31653 ROLD=XSFX(I1,I2)
31654 ELSEIF(IVAR.EQ.35) THEN
31655 IOLD=ISIG(I1,I2)
31656 ELSEIF(IVAR.EQ.36) THEN
31657 ROLD=SIGH(I1)
31658 ELSEIF(IVAR.EQ.37) THEN
31659 IOLD=MWID(I1)
31660 ELSEIF(IVAR.EQ.38) THEN
31661 ROLD=WIDS(I1,I2)
31662 ELSEIF(IVAR.EQ.39) THEN
31663 IOLD=NGEN(I1,I2)
31664 ELSEIF(IVAR.EQ.40) THEN
31665 ROLD=XSEC(I1,I2)
31666 ELSEIF(IVAR.EQ.41) THEN
31667 CHOLD2=PROC(I1)
31668 ELSEIF(IVAR.EQ.42) THEN
31669 ROLD=SIGT(I1,I2,I3)
31670 ELSEIF(IVAR.EQ.43) THEN
31671 ROLD=XPVMD(I1)
31672 ELSEIF(IVAR.EQ.44) THEN
31673 ROLD=XPANL(I1)
31674 ELSEIF(IVAR.EQ.45) THEN
31675 ROLD=XPANH(I1)
31676 ELSEIF(IVAR.EQ.46) THEN
31677 ROLD=XPBEH(I1)
31678 ELSEIF(IVAR.EQ.47) THEN
31679 ROLD=XPDIR(I1)
31680 ELSEIF(IVAR.EQ.48) THEN
31681 IOLD=IMSS(I1)
31682 ELSEIF(IVAR.EQ.49) THEN
31683 ROLD=RMSS(I1)
31684 ENDIF
31685
31686C...Print current value of variable. Loop back.
31687 IF(LNAM.GE.LBIT) THEN
31688 CHBIT(LNAM:14)=' '
31689 CHBIT(15:60)=' has the value '
31690 IF(MSVAR(IVAR,1).EQ.1) THEN
31691 WRITE(CHBIT(51:60),'(I10)') IOLD
31692 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31693 WRITE(CHBIT(47:60),'(F14.5)') ROLD
31694 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31695 CHBIT(53:60)=CHOLD
31696 ELSE
31697 CHBIT(33:60)=CHOLD
31698 ENDIF
31699 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31700 LLOW=LHIG
31701 IF(LLOW.LT.LTOT) GOTO 120
31702 RETURN
31703 ENDIF
31704
31705C...Read in new variable value.
31706 IF(MSVAR(IVAR,1).EQ.1) THEN
31707 CHINI=' '
31708 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
31709 READ(CHINI,'(I10)') INEW
31710 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31711 CHINR=' '
31712 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
31713 READ(CHINR,*) RNEW
31714 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31715 CHNEW=CHBIT(LNAM+1:LBIT)//' '
31716 ELSE
31717 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
31718 ENDIF
31719
31720C...Store new variable value.
31721 IF(IVAR.EQ.1) THEN
31722 N=INEW
31723 ELSEIF(IVAR.EQ.2) THEN
31724 K(I1,I2)=INEW
31725 ELSEIF(IVAR.EQ.3) THEN
31726 P(I1,I2)=RNEW
31727 ELSEIF(IVAR.EQ.4) THEN
31728 V(I1,I2)=RNEW
31729 ELSEIF(IVAR.EQ.5) THEN
31730 MSTU(I1)=INEW
31731 ELSEIF(IVAR.EQ.6) THEN
31732 PARU(I1)=RNEW
31733 ELSEIF(IVAR.EQ.7) THEN
31734 MSTJ(I1)=INEW
31735 ELSEIF(IVAR.EQ.8) THEN
31736 PARJ(I1)=RNEW
31737 ELSEIF(IVAR.EQ.9) THEN
31738 KCHG(I1,I2)=INEW
31739 ELSEIF(IVAR.EQ.10) THEN
31740 PMAS(I1,I2)=RNEW
31741 ELSEIF(IVAR.EQ.11) THEN
31742 PARF(I1)=RNEW
31743 ELSEIF(IVAR.EQ.12) THEN
31744 VCKM(I1,I2)=RNEW
31745 ELSEIF(IVAR.EQ.13) THEN
31746 MDCY(I1,I2)=INEW
31747 ELSEIF(IVAR.EQ.14) THEN
31748 MDME(I1,I2)=INEW
31749 ELSEIF(IVAR.EQ.15) THEN
31750 BRAT(I1)=RNEW
31751 ELSEIF(IVAR.EQ.16) THEN
31752 KFDP(I1,I2)=INEW
31753 ELSEIF(IVAR.EQ.17) THEN
31754 CHAF(I1,I2)=CHNEW
31755 ELSEIF(IVAR.EQ.18) THEN
31756 MRPY(I1)=INEW
31757 ELSEIF(IVAR.EQ.19) THEN
31758 RRPY(I1)=RNEW
31759 ELSEIF(IVAR.EQ.20) THEN
31760 MSEL=INEW
31761 ELSEIF(IVAR.EQ.21) THEN
31762 MSUB(I1)=INEW
31763 ELSEIF(IVAR.EQ.22) THEN
31764 KFIN(I1,I2)=INEW
31765 ELSEIF(IVAR.EQ.23) THEN
31766 CKIN(I1)=RNEW
31767 ELSEIF(IVAR.EQ.24) THEN
31768 MSTP(I1)=INEW
31769 ELSEIF(IVAR.EQ.25) THEN
31770 PARP(I1)=RNEW
31771 ELSEIF(IVAR.EQ.26) THEN
31772 MSTI(I1)=INEW
31773 ELSEIF(IVAR.EQ.27) THEN
31774 PARI(I1)=RNEW
31775 ELSEIF(IVAR.EQ.28) THEN
31776 MINT(I1)=INEW
31777 ELSEIF(IVAR.EQ.29) THEN
31778 VINT(I1)=RNEW
31779 ELSEIF(IVAR.EQ.30) THEN
31780 ISET(I1)=INEW
31781 ELSEIF(IVAR.EQ.31) THEN
31782 KFPR(I1,I2)=INEW
31783 ELSEIF(IVAR.EQ.32) THEN
31784 COEF(I1,I2)=RNEW
31785 ELSEIF(IVAR.EQ.33) THEN
31786 ICOL(I1,I2,I3)=INEW
31787 ELSEIF(IVAR.EQ.34) THEN
31788 XSFX(I1,I2)=RNEW
31789 ELSEIF(IVAR.EQ.35) THEN
31790 ISIG(I1,I2)=INEW
31791 ELSEIF(IVAR.EQ.36) THEN
31792 SIGH(I1)=RNEW
31793 ELSEIF(IVAR.EQ.37) THEN
31794 MWID(I1)=INEW
31795 ELSEIF(IVAR.EQ.38) THEN
31796 WIDS(I1,I2)=RNEW
31797 ELSEIF(IVAR.EQ.39) THEN
31798 NGEN(I1,I2)=INEW
31799 ELSEIF(IVAR.EQ.40) THEN
31800 XSEC(I1,I2)=RNEW
31801 ELSEIF(IVAR.EQ.41) THEN
31802 PROC(I1)=CHNEW2
31803 ELSEIF(IVAR.EQ.42) THEN
31804 SIGT(I1,I2,I3)=RNEW
31805 ELSEIF(IVAR.EQ.43) THEN
31806 XPVMD(I1)=RNEW
31807 ELSEIF(IVAR.EQ.44) THEN
31808 XPANL(I1)=RNEW
31809 ELSEIF(IVAR.EQ.45) THEN
31810 XPANH(I1)=RNEW
31811 ELSEIF(IVAR.EQ.46) THEN
31812 XPBEH(I1)=RNEW
31813 ELSEIF(IVAR.EQ.47) THEN
31814 XPDIR(I1)=RNEW
31815 ELSEIF(IVAR.EQ.48) THEN
31816 IMSS(I1)=INEW
31817 ELSEIF(IVAR.EQ.49) THEN
31818 RMSS(I1)=RNEW
31819 ENDIF
31820
31821C...Write old and new value. Loop back.
31822 CHBIT(LNAM:14)=' '
31823 CHBIT(15:60)=' changed from to '
31824 IF(MSVAR(IVAR,1).EQ.1) THEN
31825 WRITE(CHBIT(33:42),'(I10)') IOLD
31826 WRITE(CHBIT(51:60),'(I10)') INEW
31827 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31828 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31829 WRITE(CHBIT(29:42),'(F14.5)') ROLD
31830 WRITE(CHBIT(47:60),'(F14.5)') RNEW
31831 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31832 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31833 CHBIT(35:42)=CHOLD
31834 CHBIT(53:60)=CHNEW
31835 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31836 ELSE
31837 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
31838 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
31839 ENDIF
31840 LLOW=LHIG
31841 IF(LLOW.LT.LTOT) GOTO 120
31842
31843C...Format statement for output on unit MSTU(11) (by default 6).
31844 5000 FORMAT(5X,A60)
31845 5100 FORMAT(5X,A88)
31846
31847 RETURN
31848 END
31849
31850C*********************************************************************
31851
31852*$ CREATE PYEXEC.FOR
31853*COPY PYEXEC
31854C...PYEXEC
31855C...Administrates the fragmentation and decay chain.
31856
31857 SUBROUTINE PYEXEC
31858
31859C...Double precision and integer declarations.
31860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31861 INTEGER PYK,PYCHGE,PYCOMP
31862C...Commonblocks.
31863 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31864 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31865 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31866 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31867 COMMON/PYINT4/MWID(500),WIDS(500,5)
31868 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
31869C...Local array.
31870 DIMENSION PS(2,6),IJOIN(100)
31871
31872C...Initialize and reset.
31873 MSTU(24)=0
31874 IF(MSTU(12).GE.1) CALL PYLIST(0)
31875 MSTU(31)=MSTU(31)+1
31876 MSTU(1)=0
31877 MSTU(2)=0
31878 MSTU(3)=0
31879 IF(MSTU(17).LE.0) MSTU(90)=0
31880 MCONS=1
31881
31882C...Sum up momentum, energy and charge for starting entries.
31883 NSAV=N
31884 DO 110 I=1,2
31885 DO 100 J=1,6
31886 PS(I,J)=0D0
31887 100 CONTINUE
31888 110 CONTINUE
31889 DO 130 I=1,N
31890 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
31891 DO 120 J=1,4
31892 PS(1,J)=PS(1,J)+P(I,J)
31893 120 CONTINUE
31894 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
31895 130 CONTINUE
31896 PARU(21)=PS(1,4)
31897
31898C...Prepare system for subsequent fragmentation/decay.
31899 CALL PYPREP(0)
31900
31901C...Loop through jet fragmentation and particle decays.
31902 MBE=0
31903 140 MBE=MBE+1
31904 IP=0
31905 150 IP=IP+1
31906 KC=0
31907 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
31908 IF(KC.EQ.0) THEN
31909
31910C...Deal with any remaining undecayed resonance
31911C...(normally the task of PYEVNT, so seldom used).
31912 ELSEIF(MWID(KC).NE.0) THEN
31913 IBEG=IP
31914 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
31915 IBEG=IP+1
31916 160 IBEG=IBEG-1
31917 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
31918 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
31919 IEND=IP-1
31920 170 IEND=IEND+1
31921 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
31922 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
31923 NJOIN=0
31924 DO 180 I=IBEG,IEND
31925 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
31926 NJOIN=NJOIN+1
31927 IJOIN(NJOIN)=I
31928 ENDIF
31929 180 CONTINUE
31930 ENDIF
31931 CALL PYRESD(IP)
31932 CALL PYPREP(IBEG)
31933
31934C...Particle decay if unstable and allowed. Save long-lived particle
31935C...decays until second pass after Bose-Einstein effects.
31936 ELSEIF(KCHG(KC,2).EQ.0) THEN
31937 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
31938 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
31939 & CALL PYDECY(IP)
31940
31941C...Decay products may develop a shower.
31942 IF(MSTJ(92).GT.0) THEN
31943 IP1=MSTJ(92)
31944 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
31945 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
31946 CALL PYSHOW(IP1,IP1+1,QMAX)
31947 CALL PYPREP(IP1)
31948 MSTJ(92)=0
31949 ELSEIF(MSTJ(92).LT.0) THEN
31950 IP1=-MSTJ(92)
31951 CALL PYSHOW(IP1,-3,P(IP,5))
31952 CALL PYPREP(IP1)
31953 MSTJ(92)=0
31954 ENDIF
31955
31956C...Jet fragmentation: string or independent fragmentation.
31957 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
31958 MFRAG=MSTJ(1)
31959 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
31960 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
31961 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
31962 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
31963 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
31964 ENDIF
31965 ENDIF
31966 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
31967 IF(MFRAG.EQ.2) CALL PYINDF(IP)
31968 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
31969 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
31970 ENDIF
31971
31972C...Loop back if enough space left in PYJETS and no error abort.
31973 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
31974 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
31975 GOTO 150
31976 ELSEIF(IP.LT.N) THEN
31977 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
31978 ENDIF
31979
31980C...Include simple Bose-Einstein effect parametrization if desired.
31981 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
31982 CALL PYBOEI(NSAV)
31983 GOTO 140
31984 ENDIF
31985
31986C...Check that momentum, energy and charge were conserved.
31987 DO 200 I=1,N
31988 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
31989 DO 190 J=1,4
31990 PS(2,J)=PS(2,J)+P(I,J)
31991 190 CONTINUE
31992 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
31993 200 CONTINUE
31994 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
31995 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
31996 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
31997 &'(PYEXEC:) four-momentum was not conserved')
31998 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
31999 &'(PYEXEC:) charge was not conserved')
32000
32001 RETURN
32002 END
32003
32004C*********************************************************************
32005
32006*$ CREATE PYPREP.FOR
32007*COPY PYPREP
32008C...PYPREP
32009C...Rearranges partons along strings. Allows small systems
32010C...to collapse into one or two particles and checks flavours.
32011
32012 SUBROUTINE PYPREP(IP)
32013
32014C...Double precision and integer declarations.
32015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32016 INTEGER PYK,PYCHGE,PYCOMP
32017C...Commonblocks.
32018 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32019 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32020 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32021 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
32022 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
32023C...Local arrays.
32024 DIMENSION DPS(5),DPC(5),UE(3)
32025
32026C...Rearrange parton shower product listing along strings: begin loop.
32027 I1=N
32028 DO 130 MQGST=1,2
32029 DO 120 I=MAX(1,IP),N
32030 IF(K(I,1).NE.3) GOTO 120
32031 KC=PYCOMP(K(I,2))
32032 IF(KC.EQ.0) GOTO 120
32033 KQ=KCHG(KC,2)
32034 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
32035
32036C...Pick up loose string end.
32037 KCS=4
32038 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
32039 IA=I
32040 NSTP=0
32041 100 NSTP=NSTP+1
32042 IF(NSTP.GT.4*N) THEN
32043 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
32044 RETURN
32045 ENDIF
32046
32047C...Copy undecayed parton.
32048 IF(K(IA,1).EQ.3) THEN
32049 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
32050 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
32051 RETURN
32052 ENDIF
32053 I1=I1+1
32054 K(I1,1)=2
32055 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
32056 K(I1,2)=K(IA,2)
32057 K(I1,3)=IA
32058 K(I1,4)=0
32059 K(I1,5)=0
32060 DO 110 J=1,5
32061 P(I1,J)=P(IA,J)
32062 V(I1,J)=V(IA,J)
32063 110 CONTINUE
32064 K(IA,1)=K(IA,1)+10
32065 IF(K(I1,1).EQ.1) GOTO 120
32066 ENDIF
32067
32068C...Go to next parton in colour space.
32069 IB=IA
32070 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
32071 & .NE.0) THEN
32072 IA=MOD(K(IB,KCS),MSTU(5))
32073 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
32074 MREV=0
32075 ELSE
32076 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
32077 & MSTU(5)).EQ.0) KCS=9-KCS
32078 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
32079 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
32080 MREV=1
32081 ENDIF
32082 IF(IA.LE.0.OR.IA.GT.N) THEN
32083 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
32084 RETURN
32085 ENDIF
32086 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
32087 & MSTU(5)).EQ.IB) THEN
32088 IF(MREV.EQ.1) KCS=9-KCS
32089 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
32090 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
32091 ELSE
32092 IF(MREV.EQ.0) KCS=9-KCS
32093 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
32094 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
32095 ENDIF
32096 IF(IA.NE.I) GOTO 100
32097 K(I1,1)=1
32098 120 CONTINUE
32099 130 CONTINUE
32100 N=I1
32101 IF(MSTJ(14).LT.0) RETURN
32102
32103C...Find lowest-mass colour singlet jet system, OK if above threshold.
32104 IF(MSTJ(14).EQ.0) GOTO 320
32105 NS=N
32106 140 NSIN=N-NS
32107 PDM=1D0+PARJ(32)
32108 IC=0
32109 DO 190 I=MAX(1,IP),NS
32110 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
32111 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
32112 NSIN=NSIN+1
32113 IC=I
32114 DO 150 J=1,4
32115 DPS(J)=P(I,J)
32116 150 CONTINUE
32117 MSTJ(93)=1
32118 DPS(5)=PYMASS(K(I,2))
32119 ELSEIF(K(I,1).EQ.2) THEN
32120 DO 160 J=1,4
32121 DPS(J)=DPS(J)+P(I,J)
32122 160 CONTINUE
32123 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
32124 DO 170 J=1,4
32125 DPS(J)=DPS(J)+P(I,J)
32126 170 CONTINUE
32127 MSTJ(93)=1
32128 DPS(5)=DPS(5)+PYMASS(K(I,2))
32129 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
32130 & DPS(5)
32131 IF(PD.LT.PDM) THEN
32132 PDM=PD
32133 DO 180 J=1,5
32134 DPC(J)=DPS(J)
32135 180 CONTINUE
32136 IC1=IC
32137 IC2=I
32138 ENDIF
32139 IC=0
32140 ELSE
32141 NSIN=NSIN+1
32142 ENDIF
32143 190 CONTINUE
32144 IF(PDM.GE.PARJ(32)) GOTO 320
32145
32146C...Fill small-mass system as cluster.
32147 NSAV=N
32148 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
32149 K(N+1,1)=11
32150 K(N+1,2)=91
32151 K(N+1,3)=IC1
32152 K(N+1,4)=N+2
32153 K(N+1,5)=N+3
32154 P(N+1,1)=DPC(1)
32155 P(N+1,2)=DPC(2)
32156 P(N+1,3)=DPC(3)
32157 P(N+1,4)=DPC(4)
32158 P(N+1,5)=PECM
32159
32160C...Form two particles from flavours of lowest-mass system, if feasible.
32161 K(N+2,1)=1
32162 K(N+3,1)=1
32163 IF(MSTU(16).NE.2) THEN
32164 K(N+2,3)=N+1
32165 K(N+3,3)=N+1
32166 ELSE
32167 K(N+2,3)=IC1
32168 K(N+3,3)=IC2
32169 ENDIF
32170 K(N+2,4)=0
32171 K(N+3,4)=0
32172 K(N+2,5)=0
32173 K(N+3,5)=0
32174 IF(IABS(K(IC1,2)).NE.21) THEN
32175 KC1=PYCOMP(K(IC1,2))
32176 KC2=PYCOMP(K(IC2,2))
32177 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
32178 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
32179 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
32180 IF(KQ1+KQ2.NE.0) GOTO 320
32181C.. Start with qq, if there is one. Only allow for rank 1 popcorn meson
32182 200 K1=K(IC1,2)
32183 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
32184 MSTU(125)=0
32185 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
32186 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
32187 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
32188 ELSE
32189 IF(IABS(K(IC2,2)).NE.21) GOTO 320
32190C.. No room for popcorn mesons in closed string -> 2 hadrons.
32191 MSTU(125)=0
32192 210 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
32193 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
32194 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
32195 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
32196 ENDIF
32197 P(N+2,5)=PYMASS(K(N+2,2))
32198 P(N+3,5)=PYMASS(K(N+3,2))
32199 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
32200 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
32201
32202C...Perform two-particle decay of jet system, if possible.
32203 IF(PECM.GE.0.02D0*DPC(4)) THEN
32204 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
32205 & (P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
32206 UE(3)=2D0*PYR(0)-1D0
32207 PHI=PARU(2)*PYR(0)
32208 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
32209 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
32210 DO 220 J=1,3
32211 P(N+2,J)=PA*UE(J)
32212 P(N+3,J)=-PA*UE(J)
32213 220 CONTINUE
32214 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
32215 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
32216 MSTU(33)=1
32217 CALL PYROBO(N+2,N+3,0D0,0D0,DPC(1)/DPC(4),DPC(2)/DPC(4),
32218 & DPC(3)/DPC(4))
32219 ELSE
32220 NP=0
32221 DO 230 I=IC1,IC2
32222 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
32223 230 CONTINUE
32224 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
32225 & P(IC1,3)*P(IC2,3)
32226 IF(NP.GE.3.OR.HA.LE.1.25D0*P(IC1,5)*P(IC2,5)) GOTO 260
32227 HD1=0.5D0*(P(N+2,5)**2-P(IC1,5)**2)
32228 HD2=0.5D0*(P(N+3,5)**2-P(IC2,5)**2)
32229 HR=SQRT(MAX(0D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
32230 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1D0
32231 HC=P(IC1,5)**2+2D0*HA+P(IC2,5)**2
32232 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
32233 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
32234 DO 240 J=1,4
32235 P(N+2,J)=(1D0+HK1)*P(IC1,J)-HK2*P(IC2,J)
32236 P(N+3,J)=(1D0+HK2)*P(IC2,J)-HK1*P(IC1,J)
32237 240 CONTINUE
32238 ENDIF
32239 DO 250 J=1,4
32240 V(N+1,J)=V(IC1,J)
32241 V(N+2,J)=V(IC1,J)
32242 V(N+3,J)=V(IC2,J)
32243 250 CONTINUE
32244 V(N+1,5)=0D0
32245 V(N+2,5)=0D0
32246 V(N+3,5)=0D0
32247 N=N+3
32248 GOTO 300
32249
32250C...Else form one particle from the flavours available, if possible.
32251 260 K(N+1,5)=N+2
32252 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
32253 GOTO 320
32254 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
32255 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
32256 ELSE
32257 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
32258 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
32259 ENDIF
32260 IF(K(N+2,2).EQ.0) GOTO 260
32261 P(N+2,5)=PYMASS(K(N+2,2))
32262
32263C...Find parton/particle which combines to largest extra mass.
32264 IR=0
32265 HA=0D0
32266 HSM=0D0
32267 DO 280 MCOMB=1,3
32268 IF(IR.NE.0) GOTO 280
32269 DO 270 I=MAX(1,IP),N
32270 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
32271 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
32272 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
32273 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
32274 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
32275 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
32276 & GOTO 270
32277 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
32278 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
32279 IF(HSR.GT.HSM) THEN
32280 IR=I
32281 HA=HCR
32282 HSM=HSR
32283 ENDIF
32284 270 CONTINUE
32285 280 CONTINUE
32286
32287C...Shuffle energy and momentum to put new particle on mass shell.
32288 IF(IR.NE.0) THEN
32289 HB=PECM**2+HA
32290 HC=P(N+2,5)**2+HA
32291 HD=P(IR,5)**2+HA
32292 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
32293 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
32294 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
32295 DO 290 J=1,4
32296 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
32297 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
32298 V(N+1,J)=V(IC1,J)
32299 V(N+2,J)=V(IC1,J)
32300 290 CONTINUE
32301 V(N+1,5)=0D0
32302 V(N+2,5)=0D0
32303 N=N+2
32304 ELSE
32305 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
32306 RETURN
32307 ENDIF
32308
32309C...Mark collapsed system and store daughter pointers. Iterate.
32310 300 DO 310 I=IC1,IC2
32311 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(PYCOMP(K(I,2)),2).NE.0)
32312 & THEN
32313 K(I,1)=K(I,1)+10
32314 IF(MSTU(16).NE.2) THEN
32315 K(I,4)=NSAV+1
32316 K(I,5)=NSAV+1
32317 ELSE
32318 K(I,4)=NSAV+2
32319 K(I,5)=N
32320 ENDIF
32321 ENDIF
32322 310 CONTINUE
32323 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
32324
32325C...Check flavours and invariant masses in parton systems.
32326 320 NP=0
32327 KFN=0
32328 KQS=0
32329 DO 330 J=1,5
32330 DPS(J)=0D0
32331 330 CONTINUE
32332 DO 360 I=MAX(1,IP),N
32333 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
32334 KC=PYCOMP(K(I,2))
32335 IF(KC.EQ.0) GOTO 360
32336 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32337 IF(KQ.EQ.0) GOTO 360
32338 NP=NP+1
32339 IF(KQ.NE.2) THEN
32340 KFN=KFN+1
32341 KQS=KQS+KQ
32342 MSTJ(93)=1
32343 DPS(5)=DPS(5)+PYMASS(K(I,2))
32344 ENDIF
32345 DO 340 J=1,4
32346 DPS(J)=DPS(J)+P(I,J)
32347 340 CONTINUE
32348 IF(K(I,1).EQ.1) THEN
32349 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
32350 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
32351 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32352 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
32353 & '(PYPREP:) too small mass in jet system')
32354**sr
32355C IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32356C & (0.9D0*PARJ(32)+DPS(5))**2)
32357C & WRITE(*,*) 'I,DPS',I,DPS
32358**
32359 NP=0
32360 KFN=0
32361 KQS=0
32362 DO 350 J=1,5
32363 DPS(J)=0D0
32364 350 CONTINUE
32365 ENDIF
32366 360 CONTINUE
32367
32368 RETURN
32369 END
32370
32371C*********************************************************************
32372
32373*$ CREATE PYSTRF.FOR
32374*COPY PYSTRF
32375C...PYSTRF
32376C...Handles the fragmentation of an arbitrary colour singlet
32377C...jet system according to the Lund string fragmentation model.
32378
32379 SUBROUTINE PYSTRF(IP)
32380
32381C...Double precision and integer declarations.
32382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32383 INTEGER PYK,PYCHGE,PYCOMP
32384C...Commonblocks.
32385 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32386 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32387 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32388 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
32389C...Local arrays. All MOPS variables ends with MO
32390 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
32391 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
32392 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
32393 &INMO(9),PM2QMO(2),XTMO(2)
32394
32395C...Function: four-product of two vectors.
32396 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)
32397 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
32398 &DP(I,3)*DP(J,3)
32399
32400C...Reset counters. Identify parton system.
32401 MSTJ(91)=0
32402 NSAV=N
32403 MSTU90=MSTU(90)
32404 NP=0
32405 KQSUM=0
32406 DO 100 J=1,5
32407 DPS(J)=0D0
32408 100 CONTINUE
32409 MJU(1)=0
32410 MJU(2)=0
32411 I=IP-1
32412 110 I=I+1
32413 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
32414 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
32415 IF(MSTU(21).GE.1) RETURN
32416 ENDIF
32417 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
32418 KC=PYCOMP(K(I,2))
32419 IF(KC.EQ.0) GOTO 110
32420 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32421 IF(KQ.EQ.0) GOTO 110
32422 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
32423 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32424 IF(MSTU(21).GE.1) RETURN
32425 ENDIF
32426
32427C...Take copy of partons to be considered. Check flavour sum.
32428 NP=NP+1
32429 DO 120 J=1,5
32430 K(N+NP,J)=K(I,J)
32431 P(N+NP,J)=P(I,J)
32432 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
32433 120 CONTINUE
32434 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
32435 K(N+NP,3)=I
32436 IF(KQ.NE.2) KQSUM=KQSUM+KQ
32437 IF(K(I,1).EQ.41) THEN
32438 KQSUM=KQSUM+2*KQ
32439 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
32440 IF(KQSUM.NE.KQ) MJU(2)=N+NP
32441 ENDIF
32442 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
32443 IF(KQSUM.NE.0) THEN
32444 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32445 IF(MSTU(21).GE.1) RETURN
32446 ENDIF
32447
32448C...Boost copied system to CM frame (for better numerical precision).
32449 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
32450 MBST=0
32451 MSTU(33)=1
32452 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
32453 & -DPS(3)/DPS(4))
32454 ELSE
32455 MBST=1
32456 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
32457 DO 130 I=N+1,N+NP
32458 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
32459 IF(P(I,3).GT.0D0) THEN
32460 HHPEZ=(P(I,4)+P(I,3))/HHBZ
32461 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
32462 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32463 ELSE
32464 HHPEZ=(P(I,4)-P(I,3))*HHBZ
32465 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
32466 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32467 ENDIF
32468 130 CONTINUE
32469 ENDIF
32470
32471C...Search for very nearby partons that may be recombined.
32472 NTRYR=0
32473 PARU12=PARU(12)
32474 PARU13=PARU(13)
32475 MJU(3)=MJU(1)
32476 MJU(4)=MJU(2)
32477 NR=NP
32478 140 IF(NR.GE.3) THEN
32479 PDRMIN=2D0*PARU12
32480 DO 150 I=N+1,N+NR
32481 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
32482 I1=I+1
32483 IF(I.EQ.N+NR) I1=N+1
32484 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
32485 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
32486 & GOTO 150
32487 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
32488 & GOTO 150
32489 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
32490 & P(I1,2)**2+P(I1,3)**2))
32491 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
32492 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
32493 IF(PDR.LT.PDRMIN) THEN
32494 IR=I
32495 PDRMIN=PDR
32496 ENDIF
32497 150 CONTINUE
32498
32499C...Recombine very nearby partons to avoid machine precision problems.
32500 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
32501 DO 160 J=1,4
32502 P(N+1,J)=P(N+1,J)+P(N+NR,J)
32503 160 CONTINUE
32504 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
32505 & P(N+1,3)**2))
32506 NR=NR-1
32507 GOTO 140
32508 ELSEIF(PDRMIN.LT.PARU12) THEN
32509 DO 170 J=1,4
32510 P(IR,J)=P(IR,J)+P(IR+1,J)
32511 170 CONTINUE
32512 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
32513 & P(IR,3)**2))
32514 DO 190 I=IR+1,N+NR-1
32515 K(I,2)=K(I+1,2)
32516 DO 180 J=1,5
32517 P(I,J)=P(I+1,J)
32518 180 CONTINUE
32519 190 CONTINUE
32520 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
32521 NR=NR-1
32522 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
32523 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
32524 GOTO 140
32525 ENDIF
32526 ENDIF
32527 NTRYR=NTRYR+1
32528
32529C...Reset particle counter. Skip ahead if no junctions are present;
32530C...this is usually the case!
32531 NRS=MAX(5*NR+11,NP)
32532 NTRY=0
32533 200 NTRY=NTRY+1
32534 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32535 PARU12=4D0*PARU12
32536 PARU13=2D0*PARU13
32537 GOTO 140
32538 ELSEIF(NTRY.GT.100) THEN
32539 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32540 IF(MSTU(21).GE.1) RETURN
32541 ENDIF
32542 I=N+NRS
32543 MSTU(90)=MSTU90
32544 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
32545 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
32546 & ' junction strings not handled by MSTJ(12)>3 options')
32547 DO 570 JT=1,2
32548 NJS(JT)=0
32549 IF(MJU(JT).EQ.0) GOTO 570
32550 JS=3-2*JT
32551
32552C...Find and sum up momentum on three sides of junction. Check flavours.
32553 DO 220 IU=1,3
32554 IJU(IU)=0
32555 DO 210 J=1,5
32556 PJU(IU,J)=0D0
32557 210 CONTINUE
32558 220 CONTINUE
32559 IU=0
32560 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
32561 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
32562 IU=IU+1
32563 IJU(IU)=I1
32564 ENDIF
32565 DO 230 J=1,4
32566 PJU(IU,J)=PJU(IU,J)+P(I1,J)
32567 230 CONTINUE
32568 240 CONTINUE
32569 DO 250 IU=1,3
32570 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
32571 250 CONTINUE
32572 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
32573 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
32574 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32575 IF(MSTU(21).GE.1) RETURN
32576 ENDIF
32577
32578C...Calculate (approximate) boost to rest frame of junction.
32579 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
32580 & (PJU(1,5)*PJU(2,5))
32581 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
32582 & (PJU(1,5)*PJU(3,5))
32583 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
32584 & (PJU(2,5)*PJU(3,5))
32585 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
32586 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
32587 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
32588 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
32589 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
32590 DO 260 J=1,3
32591 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
32592 260 CONTINUE
32593 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
32594 DO 270 IU=1,3
32595 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
32596 & TJU(3)*PJU(IU,3)
32597 270 CONTINUE
32598
32599C...Put junction at rest if motion could give inconsistencies.
32600 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
32601 DO 280 J=1,3
32602 TJU(J)=0D0
32603 280 CONTINUE
32604 TJU(4)=1D0
32605 PJU(1,5)=PJU(1,4)
32606 PJU(2,5)=PJU(2,4)
32607 PJU(3,5)=PJU(3,4)
32608 ENDIF
32609
32610C...Start preparing for fragmentation of two strings from junction.
32611 ISTA=I
32612 DO 550 IU=1,2
32613 NS=IJU(IU+1)-IJU(IU)
32614
32615C...Junction strings: find longitudinal string directions.
32616 DO 310 IS=1,NS
32617 IS1=IJU(IU)+IS-1
32618 IS2=IJU(IU)+IS
32619 DO 290 J=1,5
32620 DP(1,J)=0.5D0*P(IS1,J)
32621 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
32622 DP(2,J)=0.5D0*P(IS2,J)
32623 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
32624 290 CONTINUE
32625 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
32626 & PJU(IU,3)**2)
32627 IF(IS.EQ.NS) DP(2,5)=0D0
32628 DP(3,5)=DFOUR(1,1)
32629 DP(4,5)=DFOUR(2,2)
32630 DHKC=DFOUR(1,2)
32631 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32632 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32633 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32634 DP(3,5)=0D0
32635 DP(4,5)=0D0
32636 DHKC=DFOUR(1,2)
32637 ENDIF
32638 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32639 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32640 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32641 IN1=N+NR+4*IS-3
32642 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32643 DO 300 J=1,4
32644 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32645 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32646 300 CONTINUE
32647 310 CONTINUE
32648
32649C...Junction strings: initialize flavour, momentum and starting pos.
32650 ISAV=I
32651 MSTU91=MSTU(90)
32652 320 NTRY=NTRY+1
32653 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32654 PARU12=4D0*PARU12
32655 PARU13=2D0*PARU13
32656 GOTO 140
32657 ELSEIF(NTRY.GT.100) THEN
32658 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32659 IF(MSTU(21).GE.1) RETURN
32660 ENDIF
32661 I=ISAV
32662 MSTU(90)=MSTU91
32663 IRANKJ=0
32664 IE(1)=K(N+1+(JT/2)*(NP-1),3)
32665 IN(4)=N+NR+1
32666 IN(5)=IN(4)+1
32667 IN(6)=N+NR+4*NS+1
32668 DO 340 JQ=1,2
32669 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
32670 P(IN1,1)=2-JQ
32671 P(IN1,2)=JQ-1
32672 P(IN1,3)=1D0
32673 330 CONTINUE
32674 340 CONTINUE
32675 KFL(1)=K(IJU(IU),2)
32676 PX(1)=0D0
32677 PY(1)=0D0
32678 GAM(1)=0D0
32679 DO 350 J=1,5
32680 PJU(IU+3,J)=0D0
32681 350 CONTINUE
32682
32683C...Junction strings: find initial transverse directions.
32684 DO 360 J=1,4
32685 DP(1,J)=P(IN(4),J)
32686 DP(2,J)=P(IN(4)+1,J)
32687 DP(3,J)=0D0
32688 DP(4,J)=0D0
32689 360 CONTINUE
32690 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32691 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32692 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32693 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32694 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32695 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32696 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32697 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32698 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32699 DHC12=DFOUR(1,2)
32700 DHCX1=DFOUR(3,1)/DHC12
32701 DHCX2=DFOUR(3,2)/DHC12
32702 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32703 DHCY1=DFOUR(4,1)/DHC12
32704 DHCY2=DFOUR(4,2)/DHC12
32705 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32706 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32707 DO 370 J=1,4
32708 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32709 P(IN(6),J)=DP(3,J)
32710 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32711 & DHCYX*DP(3,J))
32712 370 CONTINUE
32713
32714C...Junction strings: produce new particle, origin.
32715 380 I=I+1
32716 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
32717 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32718 IF(MSTU(21).GE.1) RETURN
32719 ENDIF
32720 IRANKJ=IRANKJ+1
32721 K(I,1)=1
32722 K(I,3)=IE(1)
32723 K(I,4)=0
32724 K(I,5)=0
32725
32726C...Junction strings: generate flavour, hadron, pT, z and Gamma.
32727 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
32728 IF(K(I,2).EQ.0) GOTO 320
32729 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
32730 & IABS(KFL(3)).GT.10) THEN
32731 IF(PYR(0).GT.PARJ(19)) GOTO 390
32732 ENDIF
32733 P(I,5)=PYMASS(K(I,2))
32734 CALL PYPTDI(KFL(1),PX(3),PY(3))
32735 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
32736 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
32737 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
32738 & MSTU(90).LT.8) THEN
32739 MSTU(90)=MSTU(90)+1
32740 MSTU(90+MSTU(90))=I
32741 PARU(90+MSTU(90))=Z
32742 ENDIF
32743 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
32744 DO 400 J=1,3
32745 IN(J)=IN(3+J)
32746 400 CONTINUE
32747
32748C...Junction strings: stepping within or from 'low' string region easy.
32749 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
32750 & P(IN(1),5)**2.GE.PR(1)) THEN
32751 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
32752 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
32753 DO 410 J=1,4
32754 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
32755 410 CONTINUE
32756 GOTO 500
32757 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
32758 P(IN(2)+2,4)=P(IN(2)+2,3)
32759 P(IN(2)+2,1)=1D0
32760 IN(2)=IN(2)+4
32761 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32762 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32763 P(IN(1)+2,4)=P(IN(1)+2,3)
32764 P(IN(1)+2,1)=0D0
32765 IN(1)=IN(1)+4
32766 ENDIF
32767 ENDIF
32768
32769C...Junction strings: find new transverse directions.
32770 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
32771 & IN(1).GT.IN(2)) GOTO 320
32772 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
32773 DO 430 J=1,4
32774 DP(1,J)=P(IN(1),J)
32775 DP(2,J)=P(IN(2),J)
32776 DP(3,J)=0D0
32777 DP(4,J)=0D0
32778 430 CONTINUE
32779 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32780 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32781 DHC12=DFOUR(1,2)
32782 IF(DHC12.LE.1D-2) THEN
32783 P(IN(1)+2,4)=P(IN(1)+2,3)
32784 P(IN(1)+2,1)=0D0
32785 IN(1)=IN(1)+4
32786 GOTO 420
32787 ENDIF
32788 IN(3)=N+NR+4*NS+5
32789 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32790 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32791 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32792 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32793 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32794 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32795 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32796 DHCX1=DFOUR(3,1)/DHC12
32797 DHCX2=DFOUR(3,2)/DHC12
32798 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32799 DHCY1=DFOUR(4,1)/DHC12
32800 DHCY2=DFOUR(4,2)/DHC12
32801 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32802 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32803 DO 440 J=1,4
32804 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32805 P(IN(3),J)=DP(3,J)
32806 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32807 & DHCYX*DP(3,J))
32808 440 CONTINUE
32809C...Express pT with respect to new axes, if sensible.
32810 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
32811 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
32812 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
32813 PX(3)=PXP
32814 PY(3)=PYP
32815 ENDIF
32816 ENDIF
32817
32818C...Junction strings: sum up known four-momentum, coefficients for m2.
32819 DO 470 J=1,4
32820 DHG(J)=0D0
32821 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
32822 & PY(3)*P(IN(3)+1,J)
32823 DO 450 IN1=IN(4),IN(1)-4,4
32824 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
32825 450 CONTINUE
32826 DO 460 IN2=IN(5),IN(2)-4,4
32827 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
32828 460 CONTINUE
32829 470 CONTINUE
32830 DHM(1)=FOUR(I,I)
32831 DHM(2)=2D0*FOUR(I,IN(1))
32832 DHM(3)=2D0*FOUR(I,IN(2))
32833 DHM(4)=2D0*FOUR(IN(1),IN(2))
32834
32835C...Junction strings: find coefficients for Gamma expression.
32836 DO 490 IN2=IN(1)+1,IN(2),4
32837 DO 480 IN1=IN(1),IN2-1,4
32838 DHC=2D0*FOUR(IN1,IN2)
32839 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
32840 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
32841 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
32842 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
32843 480 CONTINUE
32844 490 CONTINUE
32845
32846C...Junction strings: solve (m2, Gamma) equation system for energies.
32847 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
32848 IF(ABS(DHS1).LT.1D-4) GOTO 320
32849 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
32850 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
32851 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
32852 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
32853 & ABS(DHS1)-DHS2/DHS1)
32854 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
32855 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
32856 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
32857
32858C...Junction strings: step to new region if necessary.
32859 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
32860 P(IN(2)+2,4)=P(IN(2)+2,3)
32861 P(IN(2)+2,1)=1D0
32862 IN(2)=IN(2)+4
32863 IF(IN(2).GT.N+NR+4*NS) GOTO 320
32864 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32865 P(IN(1)+2,4)=P(IN(1)+2,3)
32866 P(IN(1)+2,1)=0D0
32867 IN(1)=IN(1)+4
32868 ENDIF
32869 GOTO 420
32870 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
32871 P(IN(1)+2,4)=P(IN(1)+2,3)
32872 P(IN(1)+2,1)=0D0
32873 IN(1)=IN(1)+JS
32874 GOTO 890
32875 ENDIF
32876
32877C...Junction strings: particle four-momentum, remainder, loop back.
32878 500 DO 510 J=1,4
32879 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
32880 & P(IN(2)+2,4)*P(IN(2),J)
32881 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
32882 510 CONTINUE
32883 IF(P(I,4).LT.P(I,5)) GOTO 320
32884 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
32885 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
32886 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
32887 KFL(1)=-KFL(3)
32888 PX(1)=-PX(3)
32889 PY(1)=-PY(3)
32890 GAM(1)=GAM(3)
32891 IF(IN(3).NE.IN(6)) THEN
32892 DO 520 J=1,4
32893 P(IN(6),J)=P(IN(3),J)
32894 P(IN(6)+1,J)=P(IN(3)+1,J)
32895 520 CONTINUE
32896 ENDIF
32897 DO 530 JQ=1,2
32898 IN(3+JQ)=IN(JQ)
32899 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
32900 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
32901 530 CONTINUE
32902 GOTO 380
32903 ENDIF
32904
32905C...Junction strings: save quantities left after each string.
32906 IF(IABS(KFL(1)).GT.10) GOTO 320
32907 I=I-1
32908 KFJH(IU)=KFL(1)
32909 DO 540 J=1,4
32910 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
32911 540 CONTINUE
32912 550 CONTINUE
32913
32914C...Junction strings: put together to new effective string endpoint.
32915 NJS(JT)=I-ISTA
32916 KFJS(JT)=K(K(MJU(JT+2),3),2)
32917 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
32918 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
32919 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
32920 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
32921 & KFLS,KFJH(1))
32922 DO 560 J=1,4
32923 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
32924 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
32925 560 CONTINUE
32926 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
32927 & PJS(JT,3)**2))
32928 570 CONTINUE
32929
32930C...Open versus closed strings. Choose breakup region for latter.
32931 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
32932 NS=MJU(2)-MJU(1)
32933 NB=MJU(1)-N
32934 ELSEIF(MJU(1).NE.0) THEN
32935 NS=N+NR-MJU(1)
32936 NB=MJU(1)-N
32937 ELSEIF(MJU(2).NE.0) THEN
32938 NS=MJU(2)-N
32939 NB=1
32940 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
32941 NS=NR-1
32942 NB=1
32943 ELSE
32944 NS=NR+1
32945 W2SUM=0D0
32946 DO 590 IS=1,NR
32947 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
32948 W2SUM=W2SUM+P(N+NR+IS,1)
32949 590 CONTINUE
32950 W2RAN=PYR(0)*W2SUM
32951 NB=0
32952 600 NB=NB+1
32953 W2SUM=W2SUM-P(N+NR+NB,1)
32954 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
32955 ENDIF
32956
32957C...Find longitudinal string directions (i.e. lightlike four-vectors).
32958 DO 630 IS=1,NS
32959 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
32960 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
32961 DO 610 J=1,5
32962 DP(1,J)=P(IS1,J)
32963 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
32964 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
32965 DP(2,J)=P(IS2,J)
32966 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
32967 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
32968 610 CONTINUE
32969 DP(3,5)=DFOUR(1,1)
32970 DP(4,5)=DFOUR(2,2)
32971 DHKC=DFOUR(1,2)
32972 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32973 DP(3,5)=DP(1,5)**2
32974 DP(4,5)=DP(2,5)**2
32975 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
32976 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
32977 DHKC=DFOUR(1,2)
32978 ENDIF
32979 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32980 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32981 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32982 IN1=N+NR+4*IS-3
32983 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32984 DO 620 J=1,4
32985 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32986 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32987 620 CONTINUE
32988 630 CONTINUE
32989
32990C...Begin initialization: sum up energy, set starting position.
32991 ISAV=I
32992 MSTU91=MSTU(90)
32993 640 NTRY=NTRY+1
32994 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32995 PARU12=4D0*PARU12
32996 PARU13=2D0*PARU13
32997 GOTO 140
32998 ELSEIF(NTRY.GT.100) THEN
32999 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
33000 IF(MSTU(21).GE.1) RETURN
33001 ENDIF
33002 I=ISAV
33003 MSTU(90)=MSTU91
33004 DO 660 J=1,4
33005 P(N+NRS,J)=0D0
33006 DO 650 IS=1,NR
33007 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
33008 650 CONTINUE
33009 660 CONTINUE
33010 DO 680 JT=1,2
33011 IRANK(JT)=0
33012 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
33013 IF(NS.GT.NR) IRANK(JT)=1
33014 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
33015 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
33016 IN(3*JT+2)=IN(3*JT+1)+1
33017 IN(3*JT+3)=N+NR+4*NS+2*JT-1
33018 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
33019 P(IN1,1)=2-JT
33020 P(IN1,2)=JT-1
33021 P(IN1,3)=1D0
33022 670 CONTINUE
33023 680 CONTINUE
33024C.. MOPS variables and switches
33025 NRVMO=0
33026 XBMO=1D0
33027 MSTU(121)=0
33028 MSTU(122)=0
33029
33030C...Initialize flavour and pT variables for open string.
33031 IF(NS.LT.NR) THEN
33032 PX(1)=0D0
33033 PY(1)=0D0
33034 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
33035 PX(2)=-PX(1)
33036 PY(2)=-PY(1)
33037 DO 690 JT=1,2
33038 KFL(JT)=K(IE(JT),2)
33039 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
33040 MSTJ(93)=1
33041 PMQ(JT)=PYMASS(KFL(JT))
33042 GAM(JT)=0D0
33043 690 CONTINUE
33044
33045C...Closed string: random initial breakup flavour, pT and vertex.
33046 ELSE
33047 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33048 IBMO=0
33049 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
33050C.. Closed string: first vertex diq attempt => enforced second
33051C.. vertex diq
33052 IF(IABS(KFL(1)).GT.10)THEN
33053 IBMO=1
33054 MSTU(121)=0
33055 GOTO 700
33056 ENDIF
33057 IF(IBMO.EQ.1) MSTU(121)=-1
33058 KFL(2)=-KFL(1)
33059 CALL PYPTDI(KFL(1),PX(1),PY(1))
33060 PX(2)=-PX(1)
33061 PY(2)=-PY(1)
33062 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
33063 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
33064 ZR=PR3/(Z*P(N+NR+1,5)**2)
33065 IF(ZR.GE.1D0) GOTO 710
33066 DO 720 JT=1,2
33067 MSTJ(93)=1
33068 PMQ(JT)=PYMASS(KFL(JT))
33069 GAM(JT)=PR3*(1D0-Z)/Z
33070 IN1=N+NR+3+4*(JT/2)*(NS-1)
33071 P(IN1,JT)=1D0-Z
33072 P(IN1,3-JT)=JT-1
33073 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
33074 P(IN1+1,JT)=ZR
33075 P(IN1+1,3-JT)=2-JT
33076 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
33077 720 CONTINUE
33078 ENDIF
33079C.. MOPS variables
33080 DO 730 JT=1,2
33081 XTMO(JT)=1D0
33082 PM2QMO(JT)=PMQ(JT)**2
33083 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
33084 730 CONTINUE
33085
33086C...Find initial transverse directions (i.e. spacelike four-vectors).
33087 DO 770 JT=1,2
33088 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
33089 IN1=IN(3*JT+1)
33090 IN3=IN(3*JT+3)
33091 DO 740 J=1,4
33092 DP(1,J)=P(IN1,J)
33093 DP(2,J)=P(IN1+1,J)
33094 DP(3,J)=0D0
33095 DP(4,J)=0D0
33096 740 CONTINUE
33097 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33098 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33099 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33100 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33101 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33102 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33103 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33104 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33105 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33106 DHC12=DFOUR(1,2)
33107 DHCX1=DFOUR(3,1)/DHC12
33108 DHCX2=DFOUR(3,2)/DHC12
33109 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33110 DHCY1=DFOUR(4,1)/DHC12
33111 DHCY2=DFOUR(4,2)/DHC12
33112 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33113 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33114 DO 750 J=1,4
33115 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33116 P(IN3,J)=DP(3,J)
33117 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33118 & DHCYX*DP(3,J))
33119 750 CONTINUE
33120 ELSE
33121 DO 760 J=1,4
33122 P(IN3+2,J)=P(IN3,J)
33123 P(IN3+3,J)=P(IN3+1,J)
33124 760 CONTINUE
33125 ENDIF
33126 770 CONTINUE
33127
33128C...Remove energy used up in junction string fragmentation.
33129 IF(MJU(1)+MJU(2).GT.0) THEN
33130 DO 790 JT=1,2
33131 IF(NJS(JT).EQ.0) GOTO 790
33132 DO 780 J=1,4
33133 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
33134 780 CONTINUE
33135 790 CONTINUE
33136 ENDIF
33137
33138C...Produce new particle: side, origin.
33139 800 I=I+1
33140 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
33141 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
33142 IF(MSTU(21).GE.1) RETURN
33143 ENDIF
33144C.. New side priority for popcorn systems
33145 IF(MSTU(121).LE.0)THEN
33146 JT=1.5D0+PYR(0)
33147 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
33148 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
33149 ENDIF
33150 JR=3-JT
33151 JS=3-2*JT
33152 IRANK(JT)=IRANK(JT)+1
33153 K(I,1)=1
33154 K(I,3)=IE(JT)
33155 K(I,4)=0
33156 K(I,5)=0
33157
33158C...Generate flavour, hadron and pT.
33159 810 CONTINUE
33160 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
33161 IF(K(I,2).EQ.0) GOTO 640
33162 MU90MO=MSTU(90)
33163 IF(MSTU(121).EQ.-1) GOTO 840
33164 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
33165 &IABS(KFL(3)).GT.10) THEN
33166 IF(PYR(0).GT.PARJ(19)) GOTO 810
33167 ENDIF
33168 P(I,5)=PYMASS(K(I,2))
33169 CALL PYPTDI(KFL(JT),PX(3),PY(3))
33170 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
33171
33172C...Final hadrons for small invariant mass.
33173 MSTJ(93)=1
33174 PMQ(3)=PYMASS(KFL(3))
33175 PARJST=PARJ(33)
33176 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
33177 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
33178 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
33179 &WMIN-0.5D0*PARJ(36)*PMQ(3)
33180 WREM2=FOUR(N+NRS,N+NRS)
33181 IF(WREM2.LT.0.10D0) GOTO 640
33182 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
33183 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
33184
33185C...Choose z, which gives Gamma. Shift z for heavy flavours.
33186 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
33187 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
33188 &MSTU(90).LT.8) THEN
33189 MSTU(90)=MSTU(90)+1
33190 MSTU(90+MSTU(90))=I
33191 PARU(90+MSTU(90))=Z
33192 ENDIF
33193 KFL1A=IABS(KFL(1))
33194 KFL2A=IABS(KFL(2))
33195 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33196 &MOD(KFL2A/1000,10)).GE.4) THEN
33197 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33198 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
33199 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
33200 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33201 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
33202 ENDIF
33203 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
33204
33205C.. MOPS baryon model modification
33206 XTMO3=(1D0-Z)*XTMO(JT)
33207 IF(IABS(KFL(3)).LE.10) NRVMO=0
33208 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
33209 GTSTMO=1D0
33210 PTSTMO=1D0
33211 RTSTMO=PYR(0)
33212 IF(IABS(KFL(JT)).LE.10)THEN
33213 XBMO=MIN(XTMO3,1D0-(2D-10))
33214 GBMO=GAM(3)
33215 PMMO=0D0
33216 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
33217 GTSTMO=1D0-PARF(192)**PGMO
33218 ELSE
33219 IF(IRANK(JT).EQ.1) THEN
33220 GBMO=GAM(JT)
33221 PMMO=0D0
33222 XBMO=1D0
33223 ENDIF
33224 IF(XBMO.LT.1D0-(1D-10))THEN
33225 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
33226 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
33227 PGMO=PGNMO
33228 ENDIF
33229 IF(MSTJ(12).GE.5)THEN
33230 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
33231 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
33232 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
33233 PMMO=PMNMO
33234 ENDIF
33235 ENDIF
33236
33237C.. MOPS Accepting popcorn system hadron.
33238 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
33239 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
33240 NRVMO=I-N-NR
33241 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
33242 CALL PYERRM(11,
33243 & '(PYSTRF:) no more memory left in PYJETS')
33244 IF(MSTU(21).GE.1) RETURN
33245 ENDIF
33246 IMO=I
33247 KFLMO=KFL(JT)
33248 PMQMO=PMQ(JT)
33249 PXMO=PX(JT)
33250 PYMO=PY(JT)
33251 GAMMO=GAM(JT)
33252 IRMO=IRANK(JT)
33253 XMO=XTMO(JT)
33254 DO 830 J=1,9
33255 IF(J.LE.5) THEN
33256 DO 820 LINE=1,I-N-NR
33257 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
33258 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
33259 820 CONTINUE
33260 ENDIF
33261 INMO(J)=IN(J)
33262 830 CONTINUE
33263 ENDIF
33264 ELSE
33265C..Reject popcorn system, flag=-1 if enforcing new one
33266 MSTU(121)=-1
33267 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
33268 ENDIF
33269 ENDIF
33270
33271
33272C..Lift restoring string outside MOPS block
33273 840 IF(MSTU(121).LT.0) THEN
33274 IF(MSTU(121).EQ.-2) MSTU(121)=0
33275 MSTU(90)=MU90MO
33276 NRVMO=0
33277 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
33278 I=IMO
33279 KFL(JT)=KFLMO
33280 PMQ(JT)=PMQMO
33281 PX(JT)=PXMO
33282 PY(JT)=PYMO
33283 GAM(JT)=GAMMO
33284 IRANK(JT)=IRMO
33285 XTMO(JT)=XMO
33286 DO 860 J=1,9
33287 IF(J.LE.5) THEN
33288 DO 850 LINE=1,I-N-NR
33289 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
33290 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
33291 850 CONTINUE
33292 ENDIF
33293 IN(J)=INMO(J)
33294 860 CONTINUE
33295 GOTO 810
33296 ENDIF
33297 XTMO(JT)=XTMO3
33298C.. MOPS end of modification
33299
33300 DO 870 J=1,3
33301 IN(J)=IN(3*JT+J)
33302 870 CONTINUE
33303
33304C...Stepping within or from 'low' string region easy.
33305 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
33306 &P(IN(1),5)**2.GE.PR(JT)) THEN
33307 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
33308 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
33309 DO 880 J=1,4
33310 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
33311 880 CONTINUE
33312 GOTO 970
33313 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
33314 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33315 P(IN(JR)+2,JT)=1D0
33316 IN(JR)=IN(JR)+4*JS
33317 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33318 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33319 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33320 P(IN(JT)+2,JT)=0D0
33321 IN(JT)=IN(JT)+4*JS
33322 ENDIF
33323 ENDIF
33324
33325C...Find new transverse directions (i.e. spacelike string vectors).
33326 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
33327 &IN(1).GT.IN(2)) GOTO 640
33328 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
33329 DO 900 J=1,4
33330 DP(1,J)=P(IN(1),J)
33331 DP(2,J)=P(IN(2),J)
33332 DP(3,J)=0D0
33333 DP(4,J)=0D0
33334 900 CONTINUE
33335 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33336 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33337 DHC12=DFOUR(1,2)
33338 IF(DHC12.LE.1D-2) THEN
33339 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33340 P(IN(JT)+2,JT)=0D0
33341 IN(JT)=IN(JT)+4*JS
33342 GOTO 890
33343 ENDIF
33344 IN(3)=N+NR+4*NS+5
33345 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33346 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33347 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33348 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33349 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33350 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33351 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33352 DHCX1=DFOUR(3,1)/DHC12
33353 DHCX2=DFOUR(3,2)/DHC12
33354 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33355 DHCY1=DFOUR(4,1)/DHC12
33356 DHCY2=DFOUR(4,2)/DHC12
33357 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33358 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33359 DO 910 J=1,4
33360 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33361 P(IN(3),J)=DP(3,J)
33362 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33363 & DHCYX*DP(3,J))
33364 910 CONTINUE
33365C...Express pT with respect to new axes, if sensible.
33366 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
33367 & FOUR(IN(3*JT+3)+1,IN(3)))
33368 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
33369 & FOUR(IN(3*JT+3)+1,IN(3)+1))
33370 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
33371 PX(3)=PXP
33372 PY(3)=PYP
33373 ENDIF
33374 ENDIF
33375
33376C...Sum up known four-momentum. Gives coefficients for m2 expression.
33377 DO 940 J=1,4
33378 DHG(J)=0D0
33379 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
33380 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
33381 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
33382 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
33383 920 CONTINUE
33384 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
33385 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
33386 930 CONTINUE
33387 940 CONTINUE
33388 DHM(1)=FOUR(I,I)
33389 DHM(2)=2D0*FOUR(I,IN(1))
33390 DHM(3)=2D0*FOUR(I,IN(2))
33391 DHM(4)=2D0*FOUR(IN(1),IN(2))
33392
33393C...Find coefficients for Gamma expression.
33394 DO 960 IN2=IN(1)+1,IN(2),4
33395 DO 950 IN1=IN(1),IN2-1,4
33396 DHC=2D0*FOUR(IN1,IN2)
33397 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
33398 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
33399 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
33400 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
33401 950 CONTINUE
33402 960 CONTINUE
33403
33404C...Solve (m2, Gamma) equation system for energies taken.
33405 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
33406 IF(ABS(DHS1).LT.1D-4) GOTO 640
33407 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
33408 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
33409 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
33410 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
33411 &ABS(DHS1)-DHS2/DHS1)
33412 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
33413 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
33414 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
33415
33416C...Step to new region if necessary.
33417 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
33418 P(IN(JR)+2,4)=P(IN(JR)+2,3)
33419 P(IN(JR)+2,JT)=1D0
33420 IN(JR)=IN(JR)+4*JS
33421 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33422 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33423 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33424 P(IN(JT)+2,JT)=0D0
33425 IN(JT)=IN(JT)+4*JS
33426 ENDIF
33427 GOTO 890
33428 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
33429 P(IN(JT)+2,4)=P(IN(JT)+2,3)
33430 P(IN(JT)+2,JT)=0D0
33431 IN(JT)=IN(JT)+4*JS
33432 GOTO 890
33433 ENDIF
33434
33435C...Four-momentum of particle. Remaining quantities. Loop back.
33436 970 DO 980 J=1,4
33437 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
33438 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
33439 980 CONTINUE
33440 IF(P(I,4).LT.P(I,5)) GOTO 640
33441 KFL(JT)=-KFL(3)
33442 PMQ(JT)=PMQ(3)
33443 PX(JT)=-PX(3)
33444 PY(JT)=-PY(3)
33445 GAM(JT)=GAM(3)
33446 IF(IN(3).NE.IN(3*JT+3)) THEN
33447 DO 990 J=1,4
33448 P(IN(3*JT+3),J)=P(IN(3),J)
33449 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
33450 990 CONTINUE
33451 ENDIF
33452 DO 1000 JQ=1,2
33453 IN(3*JT+JQ)=IN(JQ)
33454 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
33455 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
33456 1000 CONTINUE
33457 GOTO 800
33458
33459C...Final hadron: side, flavour, hadron, mass.
33460 1010 I=I+1
33461 K(I,1)=1
33462 K(I,3)=IE(JR)
33463 K(I,4)=0
33464 K(I,5)=0
33465 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
33466 IF(K(I,2).EQ.0) GOTO 640
33467 P(I,5)=PYMASS(K(I,2))
33468 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33469
33470C...Final two hadrons: find common setup of four-vectors.
33471 JQ=1
33472 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
33473 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
33474 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
33475 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
33476 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
33477 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
33478 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
33479 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
33480 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
33481 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
33482 ENDIF
33483
33484C...Solve kinematics for final two hadrons, if possible.
33485 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
33486 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
33487 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
33488 IF(FD.GE.1D0) GOTO 640
33489 FA=WREM2+PR(JT)-PR(JR)
33490 IF(MSTJ(11).NE.2) PREV=0.5D0*EXP(MAX(-50D0,LOG(FD)*PARJ(38)*
33491 &(PR(1)+PR(2))**2))
33492 IF(MSTJ(11).EQ.2) PREV=0.5D0*FD**PARJ(39)
33493 FB=SIGN(SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))),JS*(PYR(0)-PREV))
33494 KFL1A=IABS(KFL(1))
33495 KFL2A=IABS(KFL(2))
33496 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33497 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
33498 &4D0*WREM2*PR(JT))),DBLE(JS))
33499 DO 1020 J=1,4
33500 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
33501 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
33502 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
33503 P(I,J)=P(N+NRS,J)-P(I-1,J)
33504 1020 CONTINUE
33505 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
33506
33507C...Mark jets as fragmented and give daughter pointers.
33508 N=I-NRS+1
33509 DO 1030 I=NSAV+1,NSAV+NP
33510 IM=K(I,3)
33511 K(IM,1)=K(IM,1)+10
33512 IF(MSTU(16).NE.2) THEN
33513 K(IM,4)=NSAV+1
33514 K(IM,5)=NSAV+1
33515 ELSE
33516 K(IM,4)=NSAV+2
33517 K(IM,5)=N
33518 ENDIF
33519 1030 CONTINUE
33520
33521C...Document string system. Move up particles.
33522 NSAV=NSAV+1
33523 K(NSAV,1)=11
33524 K(NSAV,2)=92
33525 K(NSAV,3)=IP
33526 K(NSAV,4)=NSAV+1
33527 K(NSAV,5)=N
33528 DO 1040 J=1,4
33529 P(NSAV,J)=DPS(J)
33530 V(NSAV,J)=V(IP,J)
33531 1040 CONTINUE
33532 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
33533 V(NSAV,5)=0D0
33534 DO 1060 I=NSAV+1,N
33535 DO 1050 J=1,5
33536 K(I,J)=K(I+NRS-1,J)
33537 P(I,J)=P(I+NRS-1,J)
33538 V(I,J)=0D0
33539 1050 CONTINUE
33540 1060 CONTINUE
33541 MSTU91=MSTU(90)
33542 DO 1070 IZ=MSTU90+1,MSTU91
33543 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
33544 PARU9T(IZ)=PARU(90+IZ)
33545 1070 CONTINUE
33546 MSTU(90)=MSTU90
33547
33548C...Order particles in rank along the chain. Update mother pointer.
33549 DO 1090 I=NSAV+1,N
33550 DO 1080 J=1,5
33551 K(I-NSAV+N,J)=K(I,J)
33552 P(I-NSAV+N,J)=P(I,J)
33553 1080 CONTINUE
33554 1090 CONTINUE
33555 I1=NSAV
33556 DO 1120 I=N+1,2*N-NSAV
33557 IF(K(I,3).NE.IE(1)) GOTO 1120
33558 I1=I1+1
33559 DO 1100 J=1,5
33560 K(I1,J)=K(I,J)
33561 P(I1,J)=P(I,J)
33562 1100 CONTINUE
33563 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33564 DO 1110 IZ=MSTU90+1,MSTU91
33565 IF(MSTU9T(IZ).EQ.I) THEN
33566 MSTU(90)=MSTU(90)+1
33567 MSTU(90+MSTU(90))=I1
33568 PARU(90+MSTU(90))=PARU9T(IZ)
33569 ENDIF
33570 1110 CONTINUE
33571 1120 CONTINUE
33572 DO 1150 I=2*N-NSAV,N+1,-1
33573 IF(K(I,3).EQ.IE(1)) GOTO 1150
33574 I1=I1+1
33575 DO 1130 J=1,5
33576 K(I1,J)=K(I,J)
33577 P(I1,J)=P(I,J)
33578 1130 CONTINUE
33579 IF(MSTU(16).NE.2) K(I1,3)=NSAV
33580 DO 1140 IZ=MSTU90+1,MSTU91
33581 IF(MSTU9T(IZ).EQ.I) THEN
33582 MSTU(90)=MSTU(90)+1
33583 MSTU(90+MSTU(90))=I1
33584 PARU(90+MSTU(90))=PARU9T(IZ)
33585 ENDIF
33586 1140 CONTINUE
33587 1150 CONTINUE
33588
33589C...Boost back particle system. Set production vertices.
33590 IF(MBST.EQ.0) THEN
33591 MSTU(33)=1
33592 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
33593 & DPS(3)/DPS(4))
33594 ELSE
33595 DO 1160 I=NSAV+1,N
33596 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
33597 IF(P(I,3).GT.0D0) THEN
33598 HHPEZ=(P(I,4)+P(I,3))*HHBZ
33599 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
33600 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33601 ELSE
33602 HHPEZ=(P(I,4)-P(I,3))/HHBZ
33603 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
33604 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33605 ENDIF
33606 1160 CONTINUE
33607 ENDIF
33608 DO 1180 I=NSAV+1,N
33609 DO 1170 J=1,4
33610 V(I,J)=V(IP,J)
33611 1170 CONTINUE
33612 1180 CONTINUE
33613
33614 RETURN
33615 END
33616
33617C*********************************************************************
33618
33619*$ CREATE PYINDF.FOR
33620*COPY PYINDF
33621C...PYINDF
33622C...Handles the fragmentation of a jet system (or a single
33623C...jet) according to independent fragmentation models.
33624
33625 SUBROUTINE PYINDF(IP)
33626
33627C...Double precision and integer declarations.
33628 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33629 INTEGER PYK,PYCHGE,PYCOMP
33630C...Commonblocks.
33631 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33632 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33633 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33634 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
33635C...Local arrays.
33636 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
33637 &KFLO(2),PXO(2),PYO(2),WO(2)
33638
33639C.. MOPS error message
33640 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
33641 &' are not treated as expected in independent fragmentation')
33642
33643C...Reset counters. Identify parton system and take copy. Check flavour.
33644 NSAV=N
33645 MSTU90=MSTU(90)
33646 NJET=0
33647 KQSUM=0
33648 DO 100 J=1,5
33649 DPS(J)=0D0
33650 100 CONTINUE
33651 I=IP-1
33652 110 I=I+1
33653 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
33654 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
33655 IF(MSTU(21).GE.1) RETURN
33656 ENDIF
33657 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
33658 KC=PYCOMP(K(I,2))
33659 IF(KC.EQ.0) GOTO 110
33660 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
33661 IF(KQ.EQ.0) GOTO 110
33662 NJET=NJET+1
33663 IF(KQ.NE.2) KQSUM=KQSUM+KQ
33664 DO 120 J=1,5
33665 K(NSAV+NJET,J)=K(I,J)
33666 P(NSAV+NJET,J)=P(I,J)
33667 DPS(J)=DPS(J)+P(I,J)
33668 120 CONTINUE
33669 K(NSAV+NJET,3)=I
33670 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
33671 &K(I+1,1).EQ.2)) GOTO 110
33672 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
33673 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
33674 IF(MSTU(21).GE.1) RETURN
33675 ENDIF
33676
33677C...Boost copied system to CM frame. Find CM energy and sum flavours.
33678 IF(NJET.NE.1) THEN
33679 MSTU(33)=1
33680 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
33681 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
33682 ENDIF
33683 PECM=0D0
33684 DO 130 J=1,3
33685 NFI(J)=0
33686 130 CONTINUE
33687 DO 140 I=NSAV+1,NSAV+NJET
33688 PECM=PECM+P(I,4)
33689 KFA=IABS(K(I,2))
33690 IF(KFA.LE.3) THEN
33691 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
33692 ELSEIF(KFA.GT.1000) THEN
33693 KFLA=MOD(KFA/1000,10)
33694 KFLB=MOD(KFA/100,10)
33695 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
33696 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
33697 ENDIF
33698 140 CONTINUE
33699
33700C...Loop over attempts made. Reset counters.
33701 NTRY=0
33702 150 NTRY=NTRY+1
33703 IF(NTRY.GT.200) THEN
33704 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
33705 IF(MSTU(21).GE.1) RETURN
33706 ENDIF
33707 N=NSAV+NJET
33708 MSTU(90)=MSTU90
33709 DO 160 J=1,3
33710 NFL(J)=NFI(J)
33711 IFET(J)=0
33712 KFLF(J)=0
33713 160 CONTINUE
33714
33715C...Loop over jets to be fragmented.
33716 DO 230 IP1=NSAV+1,NSAV+NJET
33717 MSTJ(91)=0
33718 NSAV1=N
33719 MSTU91=MSTU(90)
33720
33721C...Initial flavour and momentum values. Jet along +z axis.
33722 KFLH=IABS(K(IP1,2))
33723 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
33724 KFLO(2)=0
33725 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
33726
33727C...Initial values for quark or diquark jet.
33728 170 IF(IABS(K(IP1,2)).NE.21) THEN
33729 NSTR=1
33730 KFLO(1)=K(IP1,2)
33731 CALL PYPTDI(0,PXO(1),PYO(1))
33732 WO(1)=WF
33733
33734C...Initial values for gluon treated like random quark jet.
33735 ELSEIF(MSTJ(2).LE.2) THEN
33736 NSTR=1
33737 IF(MSTJ(2).EQ.2) MSTJ(91)=1
33738 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33739 CALL PYPTDI(0,PXO(1),PYO(1))
33740 WO(1)=WF
33741
33742C...Initial values for gluon treated like quark-antiquark jet pair,
33743C...sharing energy according to Altarelli-Parisi splitting function.
33744 ELSE
33745 NSTR=2
33746 IF(MSTJ(2).EQ.4) MSTJ(91)=1
33747 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33748 KFLO(2)=-KFLO(1)
33749 CALL PYPTDI(0,PXO(1),PYO(1))
33750 PXO(2)=-PXO(1)
33751 PYO(2)=-PYO(1)
33752 WO(1)=WF*PYR(0)**(1D0/3D0)
33753 WO(2)=WF-WO(1)
33754 ENDIF
33755
33756C...Initial values for rank, flavour, pT and W+.
33757 DO 220 ISTR=1,NSTR
33758 180 I=N
33759 MSTU(90)=MSTU91
33760 IRANK=0
33761 KFL1=KFLO(ISTR)
33762 PX1=PXO(ISTR)
33763 PY1=PYO(ISTR)
33764 W=WO(ISTR)
33765
33766C...New hadron. Generate flavour and hadron species.
33767 190 I=I+1
33768 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
33769 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
33770 IF(MSTU(21).GE.1) RETURN
33771 ENDIF
33772 IRANK=IRANK+1
33773 K(I,1)=1
33774 K(I,3)=IP1
33775 K(I,4)=0
33776 K(I,5)=0
33777 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
33778 IF(K(I,2).EQ.0) GOTO 180
33779 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
33780 IF(PYR(0).GT.PARJ(19)) GOTO 200
33781 ENDIF
33782
33783C...Find hadron mass. Generate four-momentum.
33784 P(I,5)=PYMASS(K(I,2))
33785 CALL PYPTDI(KFL1,PX2,PY2)
33786 P(I,1)=PX1+PX2
33787 P(I,2)=PY1+PY2
33788 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
33789 CALL PYZDIS(KFL1,KFL2,PR,Z)
33790 MZSAV=0
33791 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
33792 MZSAV=1
33793 MSTU(90)=MSTU(90)+1
33794 MSTU(90+MSTU(90))=I
33795 PARU(90+MSTU(90))=Z
33796 ENDIF
33797 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
33798 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
33799 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
33800 & P(I,3).LE.0.001D0) THEN
33801 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
33802 P(I,3)=0.0001D0
33803 P(I,4)=SQRT(PR)
33804 Z=P(I,4)/W
33805 ENDIF
33806
33807C...Remaining flavour and momentum.
33808 KFL1=-KFL2
33809 PX1=-PX2
33810 PY1=-PY2
33811 W=(1D0-Z)*W
33812 DO 210 J=1,5
33813 V(I,J)=0D0
33814 210 CONTINUE
33815
33816C...Check if pL acceptable. Go back for new hadron if enough energy.
33817 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
33818 I=I-1
33819 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
33820 ENDIF
33821 IF(W.GT.PARJ(31)) GOTO 190
33822 N=I
33823 220 CONTINUE
33824 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
33825 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
33826
33827C...Rotate jet to new direction.
33828 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
33829 PHI=PYANGL(P(IP1,1),P(IP1,2))
33830 MSTU(33)=1
33831 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
33832 K(K(IP1,3),4)=NSAV1+1
33833 K(K(IP1,3),5)=N
33834
33835C...End of jet generation loop. Skip conservation in some cases.
33836 230 CONTINUE
33837 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
33838 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
33839
33840C...Subtract off produced hadron flavours, finished if zero.
33841 DO 240 I=NSAV+NJET+1,N
33842 KFA=IABS(K(I,2))
33843 KFLA=MOD(KFA/1000,10)
33844 KFLB=MOD(KFA/100,10)
33845 KFLC=MOD(KFA/10,10)
33846 IF(KFLA.EQ.0) THEN
33847 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
33848 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
33849 ELSE
33850 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
33851 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
33852 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
33853 ENDIF
33854 240 CONTINUE
33855 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33856 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33857 IF(NREQ.EQ.0) GOTO 320
33858
33859C...Take away flavour of low-momentum particles until enough freedom.
33860 NREM=0
33861 250 IREM=0
33862 P2MIN=PECM**2
33863 DO 260 I=NSAV+NJET+1,N
33864 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
33865 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
33866 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
33867 260 CONTINUE
33868 IF(IREM.EQ.0) GOTO 150
33869 K(IREM,1)=7
33870 KFA=IABS(K(IREM,2))
33871 KFLA=MOD(KFA/1000,10)
33872 KFLB=MOD(KFA/100,10)
33873 KFLC=MOD(KFA/10,10)
33874 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
33875 IF(K(IREM,1).EQ.8) GOTO 250
33876 IF(KFLA.EQ.0) THEN
33877 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
33878 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
33879 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
33880 ELSE
33881 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
33882 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
33883 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
33884 ENDIF
33885 NREM=NREM+1
33886 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33887 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33888 IF(NREQ.GT.NREM) GOTO 250
33889 DO 270 I=NSAV+NJET+1,N
33890 IF(K(I,1).EQ.8) K(I,1)=1
33891 270 CONTINUE
33892
33893C...Find combination of existing and new flavours for hadron.
33894 280 NFET=2
33895 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
33896 IF(NREQ.LT.NREM) NFET=1
33897 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
33898 DO 290 J=1,NFET
33899 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
33900 KFLF(J)=ISIGN(1,NFL(1))
33901 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
33902 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
33903 290 CONTINUE
33904 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
33905 &GOTO 280
33906 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
33907 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
33908 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
33909 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
33910 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
33911 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
33912 IF(NFET.LE.2) KFLF(3)=0
33913 IF(KFLF(3).NE.0) THEN
33914 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
33915 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
33916 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
33917 & KFLFC=KFLFC+ISIGN(2,KFLFC)
33918 ELSE
33919 KFLFC=KFLF(1)
33920 ENDIF
33921 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
33922 IF(KF.EQ.0) GOTO 280
33923 DO 300 J=1,MAX(2,NFET)
33924 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
33925 300 CONTINUE
33926
33927C...Store hadron at random among free positions.
33928 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
33929 DO 310 I=NSAV+NJET+1,N
33930 IF(K(I,1).EQ.7) NPOS=NPOS-1
33931 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
33932 K(I,1)=1
33933 K(I,2)=KF
33934 P(I,5)=PYMASS(K(I,2))
33935 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33936 310 CONTINUE
33937 NREM=NREM-1
33938 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33939 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33940 IF(NREM.GT.0) GOTO 280
33941
33942C...Compensate for missing momentum in global scheme (3 options).
33943 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
33944 DO 340 J=1,3
33945 PSI(J)=0D0
33946 DO 330 I=NSAV+NJET+1,N
33947 PSI(J)=PSI(J)+P(I,J)
33948 330 CONTINUE
33949 340 CONTINUE
33950 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
33951 PWS=0D0
33952 DO 350 I=NSAV+NJET+1,N
33953 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
33954 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33955 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33956 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
33957 350 CONTINUE
33958 DO 370 I=NSAV+NJET+1,N
33959 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
33960 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33961 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33962 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
33963 DO 360 J=1,3
33964 P(I,J)=P(I,J)-PSI(J)*PW/PWS
33965 360 CONTINUE
33966 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33967 370 CONTINUE
33968
33969C...Compensate for missing momentum withing each jet separately.
33970 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
33971 DO 390 I=N+1,N+NJET
33972 K(I,1)=0
33973 DO 380 J=1,5
33974 P(I,J)=0D0
33975 380 CONTINUE
33976 390 CONTINUE
33977 DO 410 I=NSAV+NJET+1,N
33978 IR1=K(I,3)
33979 IR2=N+IR1-NSAV
33980 K(IR2,1)=K(IR2,1)+1
33981 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33982 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33983 DO 400 J=1,3
33984 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
33985 400 CONTINUE
33986 P(IR2,4)=P(IR2,4)+P(I,4)
33987 P(IR2,5)=P(IR2,5)+PLS
33988 410 CONTINUE
33989 PSS=0D0
33990 DO 420 I=N+1,N+NJET
33991 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
33992 420 CONTINUE
33993 DO 440 I=NSAV+NJET+1,N
33994 IR1=K(I,3)
33995 IR2=N+IR1-NSAV
33996 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33997 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33998 DO 430 J=1,3
33999 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
34000 & PLS*P(IR1,J)
34001 430 CONTINUE
34002 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
34003 440 CONTINUE
34004 ENDIF
34005
34006C...Scale momenta for energy conservation.
34007 IF(MOD(MSTJ(3),5).NE.0) THEN
34008 PMS=0D0
34009 PES=0D0
34010 PQS=0D0
34011 DO 450 I=NSAV+NJET+1,N
34012 PMS=PMS+P(I,5)
34013 PES=PES+P(I,4)
34014 PQS=PQS+P(I,5)**2/P(I,4)
34015 450 CONTINUE
34016 IF(PMS.GE.PECM) GOTO 150
34017 NECO=0
34018 460 NECO=NECO+1
34019 PFAC=(PECM-PQS)/(PES-PQS)
34020 PES=0D0
34021 PQS=0D0
34022 DO 480 I=NSAV+NJET+1,N
34023 DO 470 J=1,3
34024 P(I,J)=PFAC*P(I,J)
34025 470 CONTINUE
34026 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
34027 PES=PES+P(I,4)
34028 PQS=PQS+P(I,5)**2/P(I,4)
34029 480 CONTINUE
34030 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
34031 ENDIF
34032
34033C...Origin of produced particles and parton daughter pointers.
34034 490 DO 500 I=NSAV+NJET+1,N
34035 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
34036 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
34037 500 CONTINUE
34038 DO 510 I=NSAV+1,NSAV+NJET
34039 I1=K(I,3)
34040 K(I1,1)=K(I1,1)+10
34041 IF(MSTU(16).NE.2) THEN
34042 K(I1,4)=NSAV+1
34043 K(I1,5)=NSAV+1
34044 ELSE
34045 K(I1,4)=K(I1,4)-NJET+1
34046 K(I1,5)=K(I1,5)-NJET+1
34047 IF(K(I1,5).LT.K(I1,4)) THEN
34048 K(I1,4)=0
34049 K(I1,5)=0
34050 ENDIF
34051 ENDIF
34052 510 CONTINUE
34053
34054C...Document independent fragmentation system. Remove copy of jets.
34055 NSAV=NSAV+1
34056 K(NSAV,1)=11
34057 K(NSAV,2)=93
34058 K(NSAV,3)=IP
34059 K(NSAV,4)=NSAV+1
34060 K(NSAV,5)=N-NJET+1
34061 DO 520 J=1,4
34062 P(NSAV,J)=DPS(J)
34063 V(NSAV,J)=V(IP,J)
34064 520 CONTINUE
34065 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
34066 V(NSAV,5)=0D0
34067 DO 540 I=NSAV+NJET,N
34068 DO 530 J=1,5
34069 K(I-NJET+1,J)=K(I,J)
34070 P(I-NJET+1,J)=P(I,J)
34071 V(I-NJET+1,J)=V(I,J)
34072 530 CONTINUE
34073 540 CONTINUE
34074 N=N-NJET+1
34075 DO 550 IZ=MSTU90+1,MSTU(90)
34076 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
34077 550 CONTINUE
34078
34079C...Boost back particle system. Set production vertices.
34080 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
34081 &DPS(2)/DPS(4),DPS(3)/DPS(4))
34082 DO 570 I=NSAV+1,N
34083 DO 560 J=1,4
34084 V(I,J)=V(IP,J)
34085 560 CONTINUE
34086 570 CONTINUE
34087
34088 RETURN
34089 END
34090
34091C*********************************************************************
34092
34093*$ CREATE PYDECY.FOR
34094*COPY PYDECY
34095C...PYDECY
34096C...Handles the decay of unstable particles.
34097
34098 SUBROUTINE PYDECY(IP)
34099
34100C...Double precision and integer declarations.
34101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34102 INTEGER PYK,PYCHGE,PYCOMP
34103C...Commonblocks.
34104 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
34105 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34106 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34107 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
34108 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
34109C...Local arrays.
34110 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
34111 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
34112 CHARACTER CIDC*4
34113 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
34114
34115C...Functions: momentum in two-particle decays and four-product.
34116 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
34117 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)
34118
34119C...Initial values.
34120 NTRY=0
34121 NSAV=N
34122 KFA=IABS(K(IP,2))
34123 KFS=ISIGN(1,K(IP,2))
34124 KC=PYCOMP(KFA)
34125 MSTJ(92)=0
34126
34127C...Choose lifetime and determine decay vertex.
34128 IF(K(IP,1).EQ.5) THEN
34129 V(IP,5)=0D0
34130 ELSEIF(K(IP,1).NE.4) THEN
34131 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
34132 ENDIF
34133 DO 100 J=1,4
34134 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
34135 100 CONTINUE
34136
34137C...Determine whether decay allowed or not.
34138 MOUT=0
34139 IF(MSTJ(22).EQ.2) THEN
34140 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
34141 ELSEIF(MSTJ(22).EQ.3) THEN
34142 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
34143 ELSEIF(MSTJ(22).EQ.4) THEN
34144 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
34145 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
34146 ENDIF
34147 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
34148 K(IP,1)=4
34149 RETURN
34150 ENDIF
34151
34152C...Interface to external tau decay library (for tau polarization).
34153 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
34154
34155C...Starting values for pointers and momenta.
34156 ITAU=IP
34157 DO 110 J=1,4
34158 PTAU(J)=P(ITAU,J)
34159 PCMTAU(J)=P(ITAU,J)
34160 110 CONTINUE
34161
34162C...Iterate to find position and code of mother of tau.
34163 IMTAU=ITAU
34164 120 IMTAU=K(IMTAU,3)
34165
34166 IF(IMTAU.EQ.0) THEN
34167C...If no known origin then impossible to do anything further.
34168 KFORIG=0
34169 IORIG=0
34170
34171 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
34172C...If tau -> tau + gamma then add gamma energy and loop.
34173 IF(K(K(IMTAU,4),2).EQ.22) THEN
34174 DO 130 J=1,4
34175 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
34176 130 CONTINUE
34177 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
34178 DO 140 J=1,4
34179 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
34180 140 CONTINUE
34181 ENDIF
34182 GOTO 120
34183
34184 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
34185C...If coming from weak decay of hadron then W is not stored in record,
34186C...but can be reconstructed by adding neutrino momentum.
34187 KFORIG=-ISIGN(24,K(ITAU,2))
34188 IORIG=0
34189 DO 160 II=K(IMTAU,4),K(IMTAU,5)
34190 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
34191 DO 150 J=1,4
34192 PCMTAU(J)=PCMTAU(J)+P(II,J)
34193 150 CONTINUE
34194 ENDIF
34195 160 CONTINUE
34196
34197 ELSE
34198C...If coming from resonance decay then find latest copy of this
34199C...resonance (may not completely agree).
34200 KFORIG=K(IMTAU,2)
34201 IORIG=IMTAU
34202 DO 170 II=IMTAU+1,IP-1
34203 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
34204 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
34205 170 CONTINUE
34206 DO 180 J=1,4
34207 PCMTAU(J)=P(IORIG,J)
34208 180 CONTINUE
34209 ENDIF
34210
34211C...Boost tau to rest frame of production process (where known)
34212C...and rotate it to sit along +z axis.
34213 DO 190 J=1,3
34214 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
34215 190 CONTINUE
34216 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
34217 & -DBETAU(2),-DBETAU(3))
34218 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
34219 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
34220 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
34221 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
34222
34223C...Call tau decay routine (if meaningful) and fill extra info.
34224 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34225 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
34226 DO 200 II=NSAV+1,NSAV+NDECAY
34227 K(II,1)=1
34228 K(II,3)=IP
34229 K(II,4)=0
34230 K(II,5)=0
34231 200 CONTINUE
34232 N=NSAV+NDECAY
34233 ENDIF
34234
34235C...Boost back decay tau and decay products.
34236 DO 210 J=1,4
34237 P(ITAU,J)=PTAU(J)
34238 210 CONTINUE
34239 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34240 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
34241 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
34242 & DBETAU(2),DBETAU(3))
34243
34244C...Skip past ordinary tau decay treatment.
34245 MMAT=0
34246 MBST=0
34247 ND=0
34248 GOTO 630
34249 ENDIF
34250 ENDIF
34251
34252C...B-Bbar mixing: flip sign of meson appropriately.
34253 MMIX=0
34254 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
34255 XBBMIX=PARJ(76)
34256 IF(KFA.EQ.531) XBBMIX=PARJ(77)
34257 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
34258 IF(MMIX.EQ.1) KFS=-KFS
34259 ENDIF
34260
34261C...Check existence of decay channels. Particle/antiparticle rules.
34262 KCA=KC
34263 IF(MDCY(KC,2).GT.0) THEN
34264 MDMDCY=MDME(MDCY(KC,2),2)
34265 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
34266 ENDIF
34267 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
34268 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
34269 RETURN
34270 ENDIF
34271 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
34272 IF(KCHG(KC,3).EQ.0) THEN
34273 KFSP=1
34274 KFSN=0
34275 IF(PYR(0).GT.0.5D0) KFS=-KFS
34276 ELSEIF(KFS.GT.0) THEN
34277 KFSP=1
34278 KFSN=0
34279 ELSE
34280 KFSP=0
34281 KFSN=1
34282 ENDIF
34283
34284C...Sum branching ratios of allowed decay channels.
34285 220 NOPE=0
34286 BRSU=0D0
34287 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
34288 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34289 & KFSN*MDME(IDL,1).NE.3) GOTO 230
34290 IF(MDME(IDL,2).GT.100) GOTO 230
34291 NOPE=NOPE+1
34292 BRSU=BRSU+BRAT(IDL)
34293 230 CONTINUE
34294 IF(NOPE.EQ.0) THEN
34295 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
34296 RETURN
34297 ENDIF
34298
34299C...Select decay channel among allowed ones.
34300 240 RBR=BRSU*PYR(0)
34301 IDL=MDCY(KCA,2)-1
34302 250 IDL=IDL+1
34303 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34304 &KFSN*MDME(IDL,1).NE.3) THEN
34305 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34306 ELSEIF(MDME(IDL,2).GT.100) THEN
34307 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34308 ELSE
34309 IDC=IDL
34310 RBR=RBR-BRAT(IDL)
34311 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
34312 ENDIF
34313
34314C...Start readout of decay channel: matrix element, reset counters.
34315 MMAT=MDME(IDC,2)
34316 260 NTRY=NTRY+1
34317 IF(MOD(NTRY,200).EQ.0) THEN
34318 WRITE(CIDC,'(I4)') IDC
34319 CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
34320 & CIDC)
34321 GOTO 240
34322 ENDIF
34323 IF(NTRY.GT.1000) THEN
34324 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34325 IF(MSTU(21).GE.1) RETURN
34326 ENDIF
34327 I=N
34328 NP=0
34329 NQ=0
34330 MBST=0
34331 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
34332 DO 270 J=1,4
34333 PV(1,J)=0D0
34334 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
34335 270 CONTINUE
34336 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
34337 PV(1,5)=P(IP,5)
34338 PS=0D0
34339 PSQ=0D0
34340 MREM=0
34341 MHADDY=0
34342 IF(KFA.GT.80) MHADDY=1
34343C.. Random flavour and popcorn system memory.
34344 IRNDMO=0
34345 JTMO=0
34346 MSTU(121)=0
34347 MSTU(125)=10
34348
34349C...Read out decay products. Convert to standard flavour code.
34350 JTMAX=5
34351 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
34352 DO 280 JT=1,JTMAX
34353 IF(JT.LE.5) KP=KFDP(IDC,JT)
34354 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
34355 IF(KP.EQ.0) GOTO 280
34356 KPA=IABS(KP)
34357 KCP=PYCOMP(KPA)
34358 IF(KPA.GT.80) MHADDY=1
34359 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
34360 KFP=KP
34361 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
34362 KFP=KFS*KP
34363 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
34364 KFP=-KFS*MOD(KFA/10,10)
34365 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
34366 KFP=KFS*(100*MOD(KFA/10,100)+3)
34367 ELSEIF(KPA.EQ.81) THEN
34368 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
34369 ELSEIF(KP.EQ.82) THEN
34370 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
34371 IF(KFP.EQ.0) GOTO 260
34372 KFP=-KFP
34373 IRNDMO=1
34374 MSTJ(93)=1
34375 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
34376 ELSEIF(KP.EQ.-82) THEN
34377 KFP=MSTU(124)
34378 ENDIF
34379 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
34380
34381C...Add decay product to event record or to quark flavour list.
34382 KFPA=IABS(KFP)
34383 KQP=KCHG(KCP,2)
34384 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
34385 NQ=NQ+1
34386 KFLO(NQ)=KFP
34387C...set rndmflav popcorn system pointer
34388 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
34389 MSTJ(93)=2
34390 PSQ=PSQ+PYMASS(KFLO(NQ))
34391 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
34392 & MOD(NQ,2).EQ.1) THEN
34393 NQ=NQ-1
34394 PS=PS-P(I,5)
34395 K(I,1)=1
34396 KFI=K(I,2)
34397 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
34398 IF(K(I,2).EQ.0) GOTO 260
34399 MSTJ(93)=1
34400 P(I,5)=PYMASS(K(I,2))
34401 PS=PS+P(I,5)
34402 ELSE
34403 I=I+1
34404 NP=NP+1
34405 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
34406 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
34407 K(I,1)=1+MOD(NQ,2)
34408 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
34409 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
34410 K(I,2)=KFP
34411 K(I,3)=IP
34412 K(I,4)=0
34413 K(I,5)=0
34414 P(I,5)=PYMASS(KFP)
34415 PS=PS+P(I,5)
34416 ENDIF
34417 280 CONTINUE
34418
34419C...Check masses for resonance decays.
34420 IF(MHADDY.EQ.0) THEN
34421 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
34422 ENDIF
34423
34424C...Choose decay multiplicity in phase space model.
34425 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
34426 PSP=PS
34427 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
34428 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
34429 300 NTRY=NTRY+1
34430C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
34431 IF(IRNDMO.EQ.0) THEN
34432 MSTU(121)=0
34433 JTMO=0
34434 ELSEIF(IRNDMO.EQ.1) THEN
34435 IRNDMO=2
34436 ELSE
34437 GOTO 260
34438 ENDIF
34439 IF(NTRY.GT.1000) THEN
34440 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34441 IF(MSTU(21).GE.1) RETURN
34442 ENDIF
34443 IF(MMAT.LE.20) THEN
34444 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
34445 & SIN(PARU(2)*PYR(0))
34446 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
34447 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
34448 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
34449 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
34450 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
34451 ELSE
34452 ND=MMAT-20
34453 ENDIF
34454C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
34455 MSTU(125)=ND-NQ/2
34456 IF(MSTU(121).GT.MSTU(125)) GOTO 300
34457
34458C...Form hadrons from flavour content.
34459 DO 310 JT=1,4
34460 KFL1(JT)=KFLO(JT)
34461 310 CONTINUE
34462 IF(ND.EQ.NP+NQ/2) GOTO 330
34463 DO 320 I=N+NP+1,N+ND-NQ/2
34464C.. Stick to started popcorn system, else pick side at random
34465 JT=JTMO
34466 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
34467 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
34468 IF(K(I,2).EQ.0) GOTO 300
34469 MSTU(125)=MSTU(125)-1
34470 JTMO=0
34471 IF(MSTU(121).GT.0) JTMO=JT
34472 KFL1(JT)=-KFL2
34473 320 CONTINUE
34474 330 JT=2
34475 JT2=3
34476 JT3=4
34477 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
34478 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
34479 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
34480 IF(JT.EQ.3) JT2=2
34481 IF(JT.EQ.4) JT3=2
34482 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
34483 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
34484 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
34485 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
34486
34487C...Check that sum of decay product masses not too large.
34488 PS=PSP
34489 DO 340 I=N+NP+1,N+ND
34490 K(I,1)=1
34491 K(I,3)=IP
34492 K(I,4)=0
34493 K(I,5)=0
34494 P(I,5)=PYMASS(K(I,2))
34495 PS=PS+P(I,5)
34496 340 CONTINUE
34497 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
34498
34499C...Rescale energy to subtract off spectator quark mass.
34500 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
34501 & .AND.NP.GE.3) THEN
34502 PS=PS-P(N+NP,5)
34503 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
34504 DO 350 J=1,5
34505 P(N+NP,J)=PQT*PV(1,J)
34506 PV(1,J)=(1D0-PQT)*PV(1,J)
34507 350 CONTINUE
34508 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34509 ND=NP-1
34510 MREM=1
34511
34512C...Fully specified final state: check mass broadening effects.
34513 ELSE
34514 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
34515 ND=NP
34516 ENDIF
34517
34518C...Determine position of grandmother, number of sisters.
34519 NM=0
34520 KFAS=0
34521 MSGN=0
34522 IF(MMAT.EQ.3) THEN
34523 IM=K(IP,3)
34524 IF(IM.LT.0.OR.IM.GE.IP) IM=0
34525 IF(IM.NE.0) KFAM=IABS(K(IM,2))
34526 IF(IM.NE.0) THEN
34527 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
34528 IF(K(IL,3).EQ.IM) NM=NM+1
34529 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
34530 360 CONTINUE
34531 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
34532 & MOD(KFAM/1000,10).NE.0) NM=0
34533 IF(NM.EQ.2) THEN
34534 KFAS=IABS(K(ISIS,2))
34535 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
34536 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
34537 ENDIF
34538 ENDIF
34539 ENDIF
34540
34541C...Kinematics of one-particle decays.
34542 IF(ND.EQ.1) THEN
34543 DO 370 J=1,4
34544 P(N+1,J)=P(IP,J)
34545 370 CONTINUE
34546 GOTO 630
34547 ENDIF
34548
34549C...Calculate maximum weight ND-particle decay.
34550 PV(ND,5)=P(N+ND,5)
34551 IF(ND.GE.3) THEN
34552 WTMAX=1D0/WTCOR(ND-2)
34553 PMAX=PV(1,5)-PS+P(N+ND,5)
34554 PMIN=0D0
34555 DO 380 IL=ND-1,1,-1
34556 PMAX=PMAX+P(N+IL,5)
34557 PMIN=PMIN+P(N+IL+1,5)
34558 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
34559 380 CONTINUE
34560 ENDIF
34561
34562C...Find virtual gamma mass in Dalitz decay.
34563 390 IF(ND.EQ.2) THEN
34564 ELSEIF(MMAT.EQ.2) THEN
34565 PMES=4D0*PMAS(11,1)**2
34566 PMRHO2=PMAS(131,1)**2
34567 PGRHO2=PMAS(131,2)**2
34568 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
34569 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
34570 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
34571 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
34572 IF(WT.LT.PYR(0)) GOTO 400
34573 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
34574
34575C...M-generator gives weight. If rejected, try again.
34576 ELSE
34577 410 RORD(1)=1D0
34578 DO 440 IL1=2,ND-1
34579 RSAV=PYR(0)
34580 DO 420 IL2=IL1-1,1,-1
34581 IF(RSAV.LE.RORD(IL2)) GOTO 430
34582 RORD(IL2+1)=RORD(IL2)
34583 420 CONTINUE
34584 430 RORD(IL2+1)=RSAV
34585 440 CONTINUE
34586 RORD(ND)=0D0
34587 WT=1D0
34588 DO 450 IL=ND-1,1,-1
34589 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
34590 & (PV(1,5)-PS)
34591 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34592 450 CONTINUE
34593 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
34594 ENDIF
34595
34596C...Perform two-particle decays in respective CM frame.
34597 460 DO 480 IL=1,ND-1
34598 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34599 UE(3)=2D0*PYR(0)-1D0
34600 PHI=PARU(2)*PYR(0)
34601 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
34602 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
34603 DO 470 J=1,3
34604 P(N+IL,J)=PA*UE(J)
34605 PV(IL+1,J)=-PA*UE(J)
34606 470 CONTINUE
34607 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
34608 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
34609 480 CONTINUE
34610
34611C...Lorentz transform decay products to lab frame.
34612 DO 490 J=1,4
34613 P(N+ND,J)=PV(ND,J)
34614 490 CONTINUE
34615 DO 530 IL=ND-1,1,-1
34616 DO 500 J=1,3
34617 BE(J)=PV(IL,J)/PV(IL,4)
34618 500 CONTINUE
34619 GA=PV(IL,4)/PV(IL,5)
34620 DO 520 I=N+IL,N+ND
34621 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34622 DO 510 J=1,3
34623 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34624 510 CONTINUE
34625 P(I,4)=GA*(P(I,4)+BEP)
34626 520 CONTINUE
34627 530 CONTINUE
34628
34629C...Check that no infinite loop in matrix element weight.
34630 NTRY=NTRY+1
34631 IF(NTRY.GT.800) GOTO 560
34632
34633C...Matrix elements for omega and phi decays.
34634 IF(MMAT.EQ.1) THEN
34635 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
34636 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
34637 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
34638 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
34639
34640C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
34641 ELSEIF(MMAT.EQ.2) THEN
34642 FOUR12=FOUR(N+1,N+2)
34643 FOUR13=FOUR(N+1,N+3)
34644 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
34645 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
34646 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
34647
34648C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
34649C...V vector), of form cos**2(theta02) in V1 rest frame, and for
34650C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
34651 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
34652 FOUR10=FOUR(IP,IM)
34653 FOUR12=FOUR(IP,N+1)
34654 FOUR02=FOUR(IM,N+1)
34655 PMS1=P(IP,5)**2
34656 PMS0=P(IM,5)**2
34657 PMS2=P(N+1,5)**2
34658 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
34659 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
34660 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
34661 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
34662 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
34663 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
34664
34665C...Matrix element for "onium" -> g + g + g or gamma + g + g.
34666 ELSEIF(MMAT.EQ.4) THEN
34667 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34668 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
34669 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
34670 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
34671 & ((1D0-HX3)/(HX1*HX2))**2
34672 IF(WT.LT.2D0*PYR(0)) GOTO 390
34673 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
34674 & GOTO 390
34675
34676C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
34677 ELSEIF(MMAT.EQ.41) THEN
34678 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34679 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
34680 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
34681
34682C...Matrix elements for weak decays (only semileptonic for c and b)
34683 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34684 & .AND.ND.EQ.3) THEN
34685 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
34686 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
34687 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34688 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
34689 DO 550 J=1,4
34690 P(N+NP+1,J)=0D0
34691 DO 540 IS=N+3,N+NP
34692 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
34693 540 CONTINUE
34694 550 CONTINUE
34695 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
34696 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
34697 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34698 ENDIF
34699
34700C...Scale back energy and reattach spectator.
34701 560 IF(MREM.EQ.1) THEN
34702 DO 570 J=1,5
34703 PV(1,J)=PV(1,J)/(1D0-PQT)
34704 570 CONTINUE
34705 ND=ND+1
34706 MREM=0
34707 ENDIF
34708
34709C...Low invariant mass for system with spectator quark gives particle,
34710C...not two jets. Readjust momenta accordingly.
34711 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
34712 MSTJ(93)=1
34713 PM2=PYMASS(K(N+2,2))
34714 MSTJ(93)=1
34715 PM3=PYMASS(K(N+3,2))
34716 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
34717 & (PARJ(32)+PM2+PM3)**2) GOTO 630
34718 K(N+2,1)=1
34719 KFTEMP=K(N+2,2)
34720 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
34721 IF(K(N+2,2).EQ.0) GOTO 260
34722 P(N+2,5)=PYMASS(K(N+2,2))
34723 PS=P(N+1,5)+P(N+2,5)
34724 PV(2,5)=P(N+2,5)
34725 MMAT=0
34726 ND=2
34727 GOTO 460
34728 ELSEIF(MMAT.EQ.44) THEN
34729 MSTJ(93)=1
34730 PM3=PYMASS(K(N+3,2))
34731 MSTJ(93)=1
34732 PM4=PYMASS(K(N+4,2))
34733 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
34734 & (PARJ(32)+PM3+PM4)**2) GOTO 600
34735 K(N+3,1)=1
34736 KFTEMP=K(N+3,2)
34737 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
34738 IF(K(N+3,2).EQ.0) GOTO 260
34739 P(N+3,5)=PYMASS(K(N+3,2))
34740 DO 580 J=1,3
34741 P(N+3,J)=P(N+3,J)+P(N+4,J)
34742 580 CONTINUE
34743 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)
34744 HA=P(N+1,4)**2-P(N+2,4)**2
34745 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
34746 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
34747 & (P(N+1,3)-P(N+2,3))**2
34748 HD=(PV(1,4)-P(N+3,4))**2
34749 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
34750 HF=HD*HC-HB**2
34751 HG=HD*HC-HA*HB
34752 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
34753 DO 590 J=1,3
34754 PCOR=HH*(P(N+1,J)-P(N+2,J))
34755 P(N+1,J)=P(N+1,J)+PCOR
34756 P(N+2,J)=P(N+2,J)-PCOR
34757 590 CONTINUE
34758 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)
34759 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)
34760 ND=ND-1
34761 ENDIF
34762
34763C...Check invariant mass of W jets. May give one particle or start over.
34764 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34765 &.AND.IABS(K(N+1,2)).LT.10) THEN
34766 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
34767 MSTJ(93)=1
34768 PM1=PYMASS(K(N+1,2))
34769 MSTJ(93)=1
34770 PM2=PYMASS(K(N+2,2))
34771 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
34772 KFLDUM=INT(1.5D0+PYR(0))
34773 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
34774 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
34775 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
34776 PSM=PYMASS(KF1)+PYMASS(KF2)
34777 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
34778 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
34779 IF(MMAT.EQ.48) GOTO 390
34780 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
34781 K(N+1,1)=1
34782 KFTEMP=K(N+1,2)
34783 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
34784 IF(K(N+1,2).EQ.0) GOTO 260
34785 P(N+1,5)=PYMASS(K(N+1,2))
34786 K(N+2,2)=K(N+3,2)
34787 P(N+2,5)=P(N+3,5)
34788 PS=P(N+1,5)+P(N+2,5)
34789 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34790 PV(2,5)=P(N+3,5)
34791 MMAT=0
34792 ND=2
34793 GOTO 460
34794 ENDIF
34795
34796C...Phase space decay of partons from W decay.
34797 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
34798 KFLO(1)=K(N+1,2)
34799 KFLO(2)=K(N+2,2)
34800 K(N+1,1)=K(N+3,1)
34801 K(N+1,2)=K(N+3,2)
34802 DO 620 J=1,5
34803 PV(1,J)=P(N+1,J)+P(N+2,J)
34804 P(N+1,J)=P(N+3,J)
34805 620 CONTINUE
34806 PV(1,5)=PMR
34807 N=N+1
34808 NP=0
34809 NQ=2
34810 PS=0D0
34811 MSTJ(93)=2
34812 PSQ=PYMASS(KFLO(1))
34813 MSTJ(93)=2
34814 PSQ=PSQ+PYMASS(KFLO(2))
34815 MMAT=11
34816 GOTO 290
34817 ENDIF
34818
34819C...Boost back for rapidly moving particle.
34820 630 N=N+ND
34821 IF(MBST.EQ.1) THEN
34822 DO 640 J=1,3
34823 BE(J)=P(IP,J)/P(IP,4)
34824 640 CONTINUE
34825 GA=P(IP,4)/P(IP,5)
34826 DO 660 I=NSAV+1,N
34827 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34828 DO 650 J=1,3
34829 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34830 650 CONTINUE
34831 P(I,4)=GA*(P(I,4)+BEP)
34832 660 CONTINUE
34833 ENDIF
34834
34835C...Fill in position of decay vertex.
34836 DO 680 I=NSAV+1,N
34837 DO 670 J=1,4
34838 V(I,J)=VDCY(J)
34839 670 CONTINUE
34840 V(I,5)=0D0
34841 680 CONTINUE
34842
34843C...Set up for parton shower evolution from jets.
34844 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
34845 K(NSAV+1,1)=3
34846 K(NSAV+2,1)=3
34847 K(NSAV+3,1)=3
34848 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34849 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34850 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34851 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34852 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34853 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34854 MSTJ(92)=-(NSAV+1)
34855 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
34856 K(NSAV+2,1)=3
34857 K(NSAV+3,1)=3
34858 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34859 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
34860 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
34861 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34862 MSTJ(92)=NSAV+2
34863 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34864 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
34865 K(NSAV+1,1)=3
34866 K(NSAV+2,1)=3
34867 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34868 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
34869 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
34870 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34871 MSTJ(92)=NSAV+1
34872 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34873 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
34874 MSTJ(92)=NSAV+1
34875 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
34876 & THEN
34877 K(NSAV+1,1)=3
34878 K(NSAV+2,1)=3
34879 K(NSAV+3,1)=3
34880 KCP=PYCOMP(K(NSAV+1,2))
34881 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
34882 JCON=4
34883 IF(KQP.LT.0) JCON=5
34884 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
34885 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
34886 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
34887 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
34888 MSTJ(92)=NSAV+1
34889 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
34890 K(NSAV+1,1)=3
34891 K(NSAV+3,1)=3
34892 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
34893 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34894 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34895 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
34896 MSTJ(92)=NSAV+1
34897 ENDIF
34898
34899C...Mark decayed particle; special option for B-Bbar mixing.
34900 IF(K(IP,1).EQ.5) K(IP,1)=15
34901 IF(K(IP,1).LE.10) K(IP,1)=11
34902 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
34903 K(IP,4)=NSAV+1
34904 K(IP,5)=N
34905
34906 RETURN
34907 END
34908
34909C*********************************************************************
34910
34911*$ CREATE PYDCYK.FOR
34912*COPY PYDCYK
34913C...PYDCYK
34914C...Handles flavour production in the decay of unstable particles
34915C...and small string clusters.
34916
34917 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
34918
34919C...Double precision and integer declarations.
34920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34921 INTEGER PYK,PYCHGE,PYCOMP
34922C...Commonblocks.
34923 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34924 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34925 SAVE /PYDAT1/,/PYDAT2/
34926
34927
34928C.. Call PYKFDI directly if no popcorn option is on
34929 IF(MSTJ(12).LT.2) THEN
34930 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34931 MSTU(124)=KFL3
34932 RETURN
34933 ENDIF
34934
34935 KFL3=0
34936 KF=0
34937 IF(KFL1.EQ.0) RETURN
34938 KF1A=IABS(KFL1)
34939 KF2A=IABS(KFL2)
34940
34941 NSTO=130
34942 NMAX=MIN(MSTU(125),10)
34943
34944C.. Identify rank 0 cluster qq
34945 IRANK=1
34946 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
34947
34948 IF(KF2A.GT.0)THEN
34949C.. Join jets: Fails if store not empty
34950 IF(MSTU(121).GT.0) THEN
34951 MSTU(121)=0
34952 RETURN
34953 ENDIF
34954 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34955 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
34956C.. Pick popcorn meson from store, return same qq, decrease store
34957 KF=MSTU(NSTO+MSTU(121))
34958 KFL3=-KFL1
34959 MSTU(121)=MSTU(121)-1
34960 ELSE
34961C.. Generate new flavour. Then done if no diquark is generated
34962 100 CALL PYKFDI(KFL1,0,KFL3,KF)
34963 IF(MSTU(121).EQ.-1) GOTO 100
34964 MSTU(124)=KFL3
34965 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
34966
34967C.. Simple case if no dynamical popcorn suppressions are considered
34968 IF(MSTJ(12).LT.4) THEN
34969 IF(MSTU(121).EQ.0) RETURN
34970 NMES=1
34971 KFPREV=-KFL3
34972 CALL PYKFDI(KFPREV,0,KFL3,KFM)
34973C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
34974 IF(IABS(KFL3).LE.10)THEN
34975 KFL3=-KFPREV
34976 RETURN
34977 ENDIF
34978 GOTO 120
34979 ENDIF
34980
34981C test output qq against fake Gamma, then return if no popcorn.
34982 GB=2D0
34983 IF(IRANK.NE.0)THEN
34984 CALL PYZDIS(1,2103,5D0,Z)
34985 GB=3D0*(1D0-Z)/Z
34986 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
34987 MSTU(121)=0
34988 GOTO 100
34989 ENDIF
34990 ENDIF
34991 IF(MSTU(121).EQ.0) RETURN
34992
34993C..Set store size memory. Pick fake dynamical variables of qq.
34994 NMES=MSTU(121)
34995 CALL PYPTDI(1,PX3,PY3)
34996 X=1D0
34997 POPM=0D0
34998 G=GB
34999 POPG=GB
35000
35001C.. Pick next popcorn meson, test with fake dynamical variables
35002 110 KFPREV=-KFL3
35003 PX1=-PX3
35004 PY1=-PY3
35005 CALL PYKFDI(KFPREV,0,KFL3,KFM)
35006 IF(MSTU(121).EQ.-1) GOTO 100
35007 CALL PYPTDI(KFL3,PX3,PY3)
35008 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
35009 CALL PYZDIS(KFPREV,KFL3,PM,Z)
35010 G=(1D0-Z)*(G+PM/Z)
35011 X=(1D0-Z)*X
35012
35013 PTST=1D0
35014 GTST=1D0
35015 RTST=PYR(0)
35016 IF(MSTJ(12).GT.4)THEN
35017 POPMN=SQRT((1D0-X)*(G/X-GB))
35018 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35019 PTST=EXP((POPM-POPMN)*PARF(193))
35020 POPM=POPMN
35021 ENDIF
35022 IF(IRANK.NE.0)THEN
35023 POPGN=X*GB
35024 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
35025 POPG=POPGN
35026 ENDIF
35027 IF(RTST.GT.PTST*GTST)THEN
35028 MSTU(121)=0
35029 IF(RTST.GT.PTST) MSTU(121)=-1
35030 GOTO 100
35031 ENDIF
35032
35033C.. Store meson
35034 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
35035 IF(MSTU(121).GT.0) GOTO 110
35036
35037C.. Test accepted system size. If OK set global popcorn size variable.
35038 IF(NMES.GT.NMAX)THEN
35039 KF=0
35040 KFL3=0
35041 RETURN
35042 ENDIF
35043 MSTU(121)=NMES
35044 ENDIF
35045
35046 RETURN
35047 END
35048
35049C********************************************************************
35050
35051*$ CREATE PYKFDI.FOR
35052*COPY PYKFDI
35053C...PYKFDI
35054C...Generates a new flavour pair and combines off a hadron
35055
35056 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
35057
35058C...Double precision and integer declarations.
35059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35060 INTEGER PYK,PYCHGE,PYCOMP
35061C...Commonblocks.
35062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35063 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35064 SAVE /PYDAT1/,/PYDAT2/
35065C...Local arrays.
35066 DIMENSION PD(7)
35067
35068 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
35069
35070C...Default flavour values. Input consistency checks.
35071 KF1A=IABS(KFL1)
35072 KF2A=IABS(KFL2)
35073 KFL3=0
35074 KF=0
35075 IF(KF1A.EQ.0) RETURN
35076 IF(KF2A.NE.0)THEN
35077 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
35078 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
35079 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
35080 ENDIF
35081
35082C...Check if tabulated flavour probabilities are to be used.
35083 IF(MSTJ(15).EQ.1) THEN
35084 IF(MSTJ(12).GE.5) CALL PYERRM(29,
35085 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
35086 & ' together with MSTJ(12)>=5 modification')
35087 KTAB1=-1
35088 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
35089 KFL1A=MOD(KF1A/1000,10)
35090 KFL1B=MOD(KF1A/100,10)
35091 KFL1S=MOD(KF1A,10)
35092 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
35093 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
35094 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
35095 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
35096 KTAB2=0
35097 IF(KF2A.NE.0) THEN
35098 KTAB2=-1
35099 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
35100 KFL2A=MOD(KF2A/1000,10)
35101 KFL2B=MOD(KF2A/100,10)
35102 KFL2S=MOD(KF2A,10)
35103 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
35104 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
35105 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
35106 ENDIF
35107 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
35108 ENDIF
35109
35110C.. Recognize rank 0 diquark case
35111 100 IRANK=1
35112 KFDIQ=MAX(KF1A,KF2A)
35113 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
35114
35115C.. Join two flavours to meson or baryon. Test for popcorn.
35116 IF(KF2A.GT.0)THEN
35117 MBARY=0
35118 IF(KFDIQ.GT.10) THEN
35119 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
35120 & CALL PYNMES(KFDIQ)
35121 IF(MSTU(121).NE.0) RETURN
35122 MBARY=2
35123 ENDIF
35124 KFQOLD=KF1A
35125 KFQVER=KF2A
35126 GOTO 130
35127 ENDIF
35128
35129C.. Separate incoming flavours, curtain flavour consistency check
35130 KFIN=KFL1
35131 KFQOLD=KF1A
35132 KFQPOP=KF1A/10000
35133 IF(KF1A.GT.10)THEN
35134 KFIN=-KFL1
35135 KFL1A=MOD(KF1A/1000,10)
35136 KFL1B=MOD(KF1A/100,10)
35137 IF(IRANK.EQ.0)THEN
35138 QAWT=1D0
35139 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
35140 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
35141 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
35142 ENDIF
35143 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) RETURN
35144 KFQOLD=KFL1A+KFL1B-KFQPOP
35145 ENDIF
35146
35147C...Meson/baryon choice. Set number of mesons if starting a popcorn
35148C...system.
35149 110 MBARY=0
35150 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
35151 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
35152 MBARY=1
35153 CALL PYNMES(0)
35154 ENDIF
35155 ELSEIF(KF1A.GT.10)THEN
35156 MBARY=2
35157 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
35158 IF(MSTU(121).GT.0) MBARY=-1
35159 ENDIF
35160
35161C..x->H+q: Choose single vertex quark. Jump to form hadron.
35162 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
35163 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
35164 KFL3=ISIGN(KFQVER,-KFIN)
35165 GOTO 130
35166 ENDIF
35167
35168C..x->H+qq: (IDW=proper PARF position for diquark weights)
35169 IDW=160
35170C.. q->B+qq: Get curtain quark, different weights for q->B+B and
35171C.. q->B+M+...
35172 IF(MBARY.EQ.1)THEN
35173 IF(MSTU(121).EQ.0) IDW=150
35174 SQWT=PARF(IDW+1)
35175 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
35176 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
35177C.. Shift to s-curtain parameters if needed
35178 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
35179 PARF(194)=PARF(138)*PARF(139)
35180 PARF(193)=PARJ(8)+PARJ(9)
35181 ENDIF
35182 ENDIF
35183
35184C.. x->H+qq: Get vertex quark
35185 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35186 IDW=MSTU(122)
35187 MSTU(121)=MSTU(121)-1
35188 IF(IDW.EQ.170) THEN
35189 IF(MSTU(121).EQ.0)THEN
35190 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
35191 ELSE
35192 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
35193 ENDIF
35194 ELSE
35195 IF(MSTU(121).EQ.0)THEN
35196 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
35197 ELSE
35198 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
35199 ENDIF
35200 ENDIF
35201 IPOS=200+30*IPOS+1
35202
35203 IMES=-1
35204 RMES=PYR(0)*PARF(194)
35205 120 IMES=IMES+1
35206 RMES=RMES-PARF(IPOS+IMES)
35207 IF(IMES.EQ.30) THEN
35208 MSTU(121)=-1
35209 KF=-111
35210 RETURN
35211 ENDIF
35212 IF(RMES.GT.0D0) GOTO 120
35213 KMUL=IMES/5
35214 KFJ=2*KMUL+1
35215 IF(KMUL.EQ.2) KFJ=10003
35216 IF(KMUL.EQ.3) KFJ=10001
35217 IF(KMUL.EQ.4) KFJ=20003
35218 IF(KMUL.EQ.5) KFJ=5
35219 IDIAG=0
35220 KFQVER=MOD(IMES,5)+1
35221 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
35222 IF(KFQVER.GT.3)THEN
35223 IDIAG=KFQVER-3
35224 KFQVER=KFQOLD
35225 ENDIF
35226 ELSE
35227 IF(MBARY.EQ.-1) IDW=170
35228 SQWT=PARF(IDW+2)
35229 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
35230 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
35231 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
35232 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
35233 KFQVER=KFQPOP
35234 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
35235 ENDIF
35236 ENDIF
35237
35238C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
35239 KFLDS=3
35240 IF(KFQPOP.NE.KFQVER)THEN
35241 SWT=PARF(IDW+7)
35242 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
35243 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
35244 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
35245 ENDIF
35246 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
35247 & +10000*KFQPOP
35248 KFL3=ISIGN(KFDIQ,KFIN)
35249
35250C..x->M+y: flavour for meson.
35251 130 IF(MBARY.LE.0)THEN
35252 KFLA=MAX(KFQOLD,KFQVER)
35253 KFLB=MIN(KFQOLD,KFQVER)
35254 KFS=ISIGN(1,KFL1)
35255 IF(KFLA.NE.KFQOLD) KFS=-KFS
35256C... Form meson, with spin and flavour mixing for diagonal states.
35257 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35258 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
35259 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
35260 RETURN
35261 ENDIF
35262 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
35263 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
35264 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
35265 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
35266 IF(PYR(0).LT.PARJ(14)) KMUL=2
35267 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
35268 RMUL=PYR(0)
35269 IF(RMUL.LT.PARJ(15)) KMUL=3
35270 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
35271 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
35272 ENDIF
35273 KFLS=3
35274 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
35275 IF(KMUL.EQ.5) KFLS=5
35276 IF(KFLA.NE.KFLB)THEN
35277 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
35278 ELSE
35279 RMIX=PYR(0)
35280 IMIX=2*KFLA+10*KMUL
35281 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
35282 & INT(RMIX+PARF(IMIX)))+KFLS
35283 IF(KFLA.GE.4) KF=110*KFLA+KFLS
35284 ENDIF
35285 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
35286 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
35287
35288C..Optional extra suppression of eta and eta'.
35289C..Allow shift to qq->B+q in old version (set IRANK to 0)
35290 IF(KF.EQ.221.OR.KF.EQ.331)THEN
35291 IF(PYR(0).GT.PARJ(25+KF/300))THEN
35292 IF(KF2A.GT.0) GOTO 130
35293 IF(MSTJ(12).LT.4) IRANK=0
35294 GOTO 110
35295 ENDIF
35296 ENDIF
35297 MSTU(121)=0
35298
35299C.. x->B+y: Flavour for baryon
35300 ELSE
35301 KFLA=KFQVER
35302 IF(KF1A.LE.10) KFLA=KFQOLD
35303 KFLB=MOD(KFDIQ/1000,10)
35304 KFLC=MOD(KFDIQ/100,10)
35305 KFLDS=MOD(KFDIQ,10)
35306 KFLD=MAX(KFLA,KFLB,KFLC)
35307 KFLF=MIN(KFLA,KFLB,KFLC)
35308 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35309
35310C... SU(6) factors for formation of baryon.
35311 KBARY=3
35312 KDMAX=5
35313 KFLG=KFLB
35314 IF(KFLB.NE.KFLC)THEN
35315 KBARY=2*KFLDS-1
35316 KDMAX=1+KFLDS/2
35317 IF(KFLB.GT.2) KDMAX=KDMAX+2
35318 ENDIF
35319 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
35320 KBARY=KBARY+1
35321 KFLG=KFLA
35322 ENDIF
35323
35324 SU6MAX=PARF(140+KDMAX)
35325 SU6DEC=PARJ(18)
35326 SU6S =PARF(146)
35327 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
35328 SU6MAX=1D0
35329 SU6DEC=1D0
35330 SU6S =1D0
35331 ENDIF
35332 SU6OCT=PARF(60+KBARY)
35333 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
35334 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
35335 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
35336 ELSE
35337 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
35338 ENDIF
35339 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
35340
35341C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
35342 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
35343 MSTU(121)=0
35344 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
35345 GOTO 110
35346 ENDIF
35347
35348C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
35349 KSIG=1
35350 KFLS=2
35351 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
35352 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
35353 KSIG=KFLDS/3
35354 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
35355 ENDIF
35356 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
35357 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
35358 ENDIF
35359 RETURN
35360
35361C...Use tabulated probabilities to select new flavour and hadron.
35362 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
35363 KT3L=1
35364 KT3U=6
35365 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
35366 KT3L=1
35367 KT3U=6
35368 ELSEIF(KTAB2.EQ.0) THEN
35369 KT3L=1
35370 KT3U=22
35371 ELSE
35372 KT3L=KTAB2
35373 KT3U=KTAB2
35374 ENDIF
35375 RFL=0D0
35376 DO 160 KTS=0,2
35377 DO 150 KT3=KT3L,KT3U
35378 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
35379 150 CONTINUE
35380 160 CONTINUE
35381 RFL=PYR(0)*RFL
35382 DO 180 KTS=0,2
35383 KTABS=KTS
35384 DO 170 KT3=KT3L,KT3U
35385 KTAB3=KT3
35386 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
35387 IF(RFL.LE.0D0) GOTO 190
35388 170 CONTINUE
35389 180 CONTINUE
35390 190 CONTINUE
35391
35392C...Reconstruct flavour of produced quark/diquark.
35393 IF(KTAB3.LE.6) THEN
35394 KFL3A=KTAB3
35395 KFL3B=0
35396 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
35397 ELSE
35398 KFL3A=1
35399 IF(KTAB3.GE.8) KFL3A=2
35400 IF(KTAB3.GE.11) KFL3A=3
35401 IF(KTAB3.GE.16) KFL3A=4
35402 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
35403 KFL3=1000*KFL3A+100*KFL3B+1
35404 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
35405 & KFL3+2
35406 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
35407 ENDIF
35408
35409C...Reconstruct meson code.
35410 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
35411 &KFL3B.NE.0)) THEN
35412 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35413 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
35414 KF=110+2*KTABS+1
35415 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
35416 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35417 & 25*KTABS)) KF=330+2*KTABS+1
35418 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
35419 KFLA=MAX(KTAB1,KTAB3)
35420 KFLB=MIN(KTAB1,KTAB3)
35421 KFS=ISIGN(1,KFL1)
35422 IF(KFLA.NE.KF1A) KFS=-KFS
35423 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35424 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
35425 KFS=ISIGN(1,KFL1)
35426 IF(KFL1A.EQ.KFL3A) THEN
35427 KFLA=MAX(KFL1B,KFL3B)
35428 KFLB=MIN(KFL1B,KFL3B)
35429 IF(KFLA.NE.KFL1B) KFS=-KFS
35430 ELSEIF(KFL1A.EQ.KFL3B) THEN
35431 KFLA=KFL3A
35432 KFLB=KFL1B
35433 KFS=-KFS
35434 ELSEIF(KFL1B.EQ.KFL3A) THEN
35435 KFLA=KFL1A
35436 KFLB=KFL3B
35437 ELSEIF(KFL1B.EQ.KFL3B) THEN
35438 KFLA=MAX(KFL1A,KFL3A)
35439 KFLB=MIN(KFL1A,KFL3A)
35440 IF(KFLA.NE.KFL1A) KFS=-KFS
35441 ELSE
35442 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
35443 GOTO 100
35444 ENDIF
35445 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35446
35447C...Reconstruct baryon code.
35448 ELSE
35449 IF(KTAB1.GE.7) THEN
35450 KFLA=KFL3A
35451 KFLB=KFL1A
35452 KFLC=KFL1B
35453 ELSE
35454 KFLA=KFL1A
35455 KFLB=KFL3A
35456 KFLC=KFL3B
35457 ENDIF
35458 KFLD=MAX(KFLA,KFLB,KFLC)
35459 KFLF=MIN(KFLA,KFLB,KFLC)
35460 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35461 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
35462 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
35463 ENDIF
35464
35465C...Check that constructed flavour code is an allowed one.
35466 IF(KFL2.NE.0) KFL3=0
35467 KC=PYCOMP(KF)
35468 IF(KC.EQ.0) THEN
35469 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
35470 & 'failed')
35471 GOTO 100
35472 ENDIF
35473
35474 RETURN
35475 END
35476
35477C*********************************************************************
35478
35479*$ CREATE PYNMES.FOR
35480*COPY PYNMES
35481C...PYNMES
35482C...Generates number of popcorn mesons and stores some relevant
35483C...parameters.
35484
35485 SUBROUTINE PYNMES(KFDIQ)
35486
35487C...Double precision and integer declarations.
35488 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35489 INTEGER PYK,PYCHGE,PYCOMP
35490C...Commonblocks.
35491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35492 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35493 SAVE /PYDAT1/,/PYDAT2/
35494
35495 MSTU(121)=0
35496 IF(MSTJ(12).LT.2) RETURN
35497
35498C..Old version: Get 1 or 0 popcorn mesons
35499 IF(MSTJ(12).LT.5)THEN
35500 POPWT=PARF(131)
35501 IF(KFDIQ.NE.0) THEN
35502 KFDIQA=IABS(KFDIQ)
35503 KFA=MOD(KFDIQA/1000,10)
35504 KFB=MOD(KFDIQA/100,10)
35505 KFS=MOD(KFDIQA,10)
35506 POPWT=PARF(132)
35507 IF(KFA.EQ.3) POPWT=PARF(133)
35508 IF(KFB.EQ.3) POPWT=PARF(134)
35509 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
35510 ENDIF
35511 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
35512 RETURN
35513 ENDIF
35514
35515C..New version: Store popcorn- or rank 0 diquark parameters
35516 MSTU(122)=170
35517 PARF(193)=PARJ(8)
35518 PARF(194)=PARF(139)
35519 IF(KFDIQ.NE.0) THEN
35520 MSTU(122)=180
35521 PARF(193)=PARJ(10)
35522 PARF(194)=PARF(140)
35523 ENDIF
35524 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
35525 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
35526 & '(PYNMES:) Neglecting too large popcorn possibility')
35527 RETURN
35528 ENDIF
35529
35530C..New version: Get number of popcorn mesons
35531 100 RTST=PYR(0)
35532 MSTU(121)=-1
35533 110 MSTU(121)=MSTU(121)+1
35534 RTST=RTST/PARF(194)
35535 IF(RTST.LT.1D0) GOTO 110
35536 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)).GT.
35537 & (2D0+PARF(135)*PARF(138)**MSTU(121))) GOTO 100
35538 RETURN
35539 END
35540
35541C*********************************************************************
35542
35543*$ CREATE PYKFIN.FOR
35544*COPY PYKFIN
35545C...PYKFIN
35546C...Precalculates a set of diquark and popcorn weights.
35547C.. (Results stored in order SU0,US0,SS1,UU1,SU1,US1,UD1)
35548
35549 SUBROUTINE PYKFIN
35550
35551C...Double precision and integer declarations.
35552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35553 INTEGER PYK,PYCHGE,PYCOMP
35554C...Commonblocks.
35555 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35556 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35557 SAVE /PYDAT1/,/PYDAT2/
35558
35559 DIMENSION SU6(12),SU6M(7)
35560
35561 MSTU(123)=1
35562C..Curtain tunneling factor T(D,q)/T(ud0,u).
35563 IF(MSTJ(12).GE.5) THEN
35564 PMUD0=PYMASS(2101)
35565 PMUD1=PYMASS(2103)-PMUD0
35566 PMUS0=PYMASS(3201)-PMUD0
35567 PMUS1=PYMASS(3203)-PMUS0-PMUD0
35568 PMSS1=PYMASS(3303)-PMUS0-PMUD0
35569 PARF(151)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
35570 PARF(152)=EXP(-PARJ(8)*PMUS0)
35571 PARF(153)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*PARF(151)
35572 PARF(154)=EXP(-PARJ(8)*PMUD1)
35573 PARF(155)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*PARF(151)
35574 PARF(156)=EXP(-PARJ(8)*PMUS1)*PARF(152)
35575 PARF(157)=PARF(154)
35576 ELSE
35577 PAR2M=SQRT(PARJ(2))
35578 PAR3M=SQRT(PARJ(3))
35579 PAR4M=SQRT(PARJ(4))
35580 PARF(151)=PAR2M*PAR3M
35581 PARF(152)=PAR3M
35582 PARF(153)=PAR2M*PARJ(3)*PAR4M
35583 PARF(154)=PAR4M
35584 PARF(155)=PAR4M*PARF(151)
35585 PARF(156)=PAR4M*PARF(152)
35586 PARF(157)=PAR4M
35587 ENDIF
35588
35589C.. Total tunneling factor tau(D,q)=T*vertex*spin.
35590 PARF(161)=PARF(151)
35591 PARF(162)=PARJ(2)*PARF(152)
35592 PARF(163)=PARJ(2)*6D0*PARF(153)
35593 PARF(164)=6D0*PARF(154)
35594 PARF(165)=3D0*PARF(155)
35595 PARF(166)=PARJ(2)*3D0*PARF(156)
35596 PARF(167)=3D0*PARF(157)
35597
35598 DO 100 I=1,7
35599 PARF(150+I)=PARF(150+I)*PARF(160+I)
35600 100 CONTINUE
35601
35602C..Modified SU(6) factors.
35603 PARF(146)=1D0
35604 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
35605 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
35606 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
35607 DO 110 I=1,6
35608 SU6(I)=PARF(60+I)
35609 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
35610 110 CONTINUE
35611 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
35612 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
35613 DO 120 I=1,6
35614 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
35615 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
35616 120 CONTINUE
35617
35618C..Total diquark quark*SU(6).
35619 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
35620 PARF(171)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
35621 PARF(172)=PARF(171)
35622 PARF(173)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
35623 PARF(174)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
35624 PARF(175)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
35625 PARF(176)=PARF(175)
35626 PARF(177)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
35627
35628C..SU(6)max q q' s,c,b
35629 SU6MUD =MAX(SU6(1) , SU6(8) )
35630 SU6M(7)=MAX(SU6(5) , SU6(12))
35631 SU6M(1)=MAX(SU6(7) ,SU6(2),SU6MUD )
35632 SU6M(4)=MAX(SU6(3) ,SU6(4),SU6(10))
35633 SU6M(5)=MAX(SU6(11),SU6(6),SU6M(7))
35634 SU6M(2)=SU6M(1)
35635 SU6M(3)=SU6M(4)
35636 SU6M(6)=SU6M(5)
35637
35638 IF(MSTJ(12).GE.5)THEN
35639C..New version: tau for rank 0 diquark.
35640 PARF(181)=EXP(-PARJ(10)*PMUS0)
35641 PARF(182)=PARJ(2)*PARF(181)
35642 PARF(183)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*PARF(181)
35643 PARF(184)=3D0*EXP(-PARJ(10)*PMUD1)
35644 PARF(185)=3D0*EXP(-PARJ(10)*PMUS1)*PARF(181)
35645 PARF(186)=PARJ(2)*PARF(185)
35646 PARF(187)=2D0*PARF(184)
35647
35648C..New version: s/u curtain ratios.
35649 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35650 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35651 WU=1D0+PARF(187)+PARF(182)+PARF(186)+PARF(184)
35652 PARF(136)=(2D0*(PARF(181)+PARF(185))+PARF(183))/WU
35653 PARF(137)=(PARF(181)+PARF(185))*
35654 & (2D0+PARF(183)/(2D0*PARF(185)))/WU
35655 ELSE
35656C..Old version: Shuffle PARJ(7) into tau
35657 PARF(162)=PARF(162)*PARJ(7)
35658 PARF(163)=PARF(163)*PARJ(7)
35659 PARF(166)=PARF(166)*PARJ(7)
35660
35661C..Old version: s/u curtain ratios.
35662 WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35663 PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35664 PARF(136)=PARF(135)*PARJ(6)*PARF(161)/PARF(162)
35665 PARF(137)=(1D0+PARF(167))*(2D0+PARF(162))/WU
35666 ENDIF
35667
35668C..Combine SU(6), SU(6)max, tau and T into proper products
35669 DO 140 I=1,7
35670 PARF(180+I)=PARF(180+I)*PARF(170+I)
35671 PARF(170+I)=PARF(170+I)*PARF(160+I)
35672 PARF(160+I)=PARF(160+I)*SU6M(I)/SU6MUD
35673 PARF(150+I)=PARF(150+I)*SU6M(I)/SU6MUD
35674 140 CONTINUE
35675
35676C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
35677 PARF(141)=SU6MUD
35678 PARF(142)=SU6M(7)
35679 PARF(143)=SU6M(1)
35680 PARF(144)=SU6M(5)
35681 PARF(145)=SU6M(3)
35682
35683 IF(MSTJ(12).LT.5)THEN
35684C.. Old version: Resulting popcorn weights.
35685 PARF(138)=PARJ(6)
35686 WS=PARF(135)*PARF(138)
35687 WQ=WU*PARJ(5)/3D0
35688 PARF(132)=WQ*PARF(167)/PARF(157)
35689 PARF(133)=WQ*(PARF(166)/PARF(156)+WS*PARF(165)/PARF(155))/2D0
35690 PARF(134)=WQ*WS*PARF(163)/PARF(153)
35691 PARF(131)=WQ*((1D0+PARF(167))*(1D0+PARF(162)+WS*PARF(161))+
35692 & PARF(164)+WS*PARF(163)/2D0)/
35693 & ((1D0+PARF(157))*(1D0+2D0*PARF(152))+PARF(154)+PARF(153)/2D0)
35694 ELSE
35695C..New version: Store weights for popcorn mesons,
35696C..get prel. popcorn weights.
35697 DO 150 IPOS=201,1400
35698 PARF(IPOS)=0D0
35699 150 CONTINUE
35700 DO 160 I=138,140
35701 PARF(I)=0D0
35702 160 CONTINUE
35703 IPOS=200
35704 PARF(193)=PARJ(8)
35705 DO 240 MR=170,180,10
35706 IF(MR.EQ.180) PARF(193)=PARJ(10)
35707 SQWT=2D0*(PARF(MR+2)+PARF(MR+6))/(1D0+PARF(MR+7)+PARF(MR+4))
35708 QQWT=PARF(MR+4)/(1D0+PARF(MR+7)+PARF(MR+4))
35709 DO 230 NMES=0,1
35710 IF(NMES.EQ.1) SQWT=PARJ(2)
35711 DO 220 KFQPOP=1,4
35712 IF(MR.EQ.170.AND.KFQPOP.GT.3) GOTO 220
35713 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
35714 SQWT=PARF(MR+3)/(PARF(MR+1)+PARF(MR+5))
35715 QQWT=0.5D0
35716 IF(MR.EQ.170) PARF(193)=PARJ(8)+PARJ(9)
35717 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/PARF(185)+1D0)/2D0
35718 ENDIF
35719 DO 210 KFQOLD =1,5
35720 IF(MR.EQ.170.AND.KFQOLD.GT.3) GOTO 210
35721 IF(MR*NMES.EQ.170.AND.KFQPOP.EQ.1) GOTO 210
35722 IF(MR*NMES.EQ.180.AND.KFQPOP.NE.1) GOTO 210
35723 WTTOT=0D0
35724 WTFAIL=0D0
35725 DO 190 KMUL=0,5
35726 PJWT=PARJ(12+KMUL)
35727 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
35728 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
35729 IF(PJWT.LE.0D0) GOTO 190
35730 IF(PJWT.GT.1D0) PJWT=1D0
35731 IMES=5*KMUL
35732 IMIX=2*KFQOLD+10*KMUL
35733 KFJ=2*KMUL+1
35734 IF(KMUL.EQ.2) KFJ=10003
35735 IF(KMUL.EQ.3) KFJ=10001
35736 IF(KMUL.EQ.4) KFJ=20003
35737 IF(KMUL.EQ.5) KFJ=5
35738 DO 180 KFQVER =1,3
35739 KFLA=MAX(KFQOLD,KFQVER)
35740 KFLB=MIN(KFQOLD,KFQVER)
35741 SWT=PARJ(11+KFLA/3+KFLA/4)
35742 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
35743 SWT=SWT*PJWT
35744 QWT=SQWT/(2D0+SQWT)
35745 IF(KFQVER.LT.3)THEN
35746 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
35747 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
35748 ENDIF
35749 IF(KFQVER.NE.KFQOLD)THEN
35750 IMES=IMES+1
35751 KFM=100*KFLA+10*KFLB+KFJ
35752 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35753 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
35754 WTTOT=WTTOT+PARF(IPOS+IMES)
35755 ELSE
35756 DO 170 ID=3,5
35757 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
35758 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
35759 IF(ID.EQ.5) DWT=PARF(IMIX)
35760 KFM=110*(ID-2)+KFJ
35761 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35762 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
35763 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
35764 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
35765 PARF(IPOS+5*KMUL+ID)=
35766 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
35767 ENDIF
35768 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
35769 170 CONTINUE
35770 ENDIF
35771 180 CONTINUE
35772 190 CONTINUE
35773 DO 200 IMES=1,30
35774 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
35775 200 CONTINUE
35776 IF(MR.EQ.180) PARF(140)=
35777 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
35778 IF(MR.EQ.170) PARF(139-KFQPOP/3)=
35779 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
35780 IPOS=IPOS+30
35781 210 CONTINUE
35782 220 CONTINUE
35783 230 CONTINUE
35784 240 CONTINUE
35785 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
35786 MSTU(121)=0
35787
35788 PARF(186)=PARF(186)/PARF(182)
35789 PARF(185)=PARF(185)/PARF(181)
35790 ENDIF
35791
35792C..Recombine diquark weights to flavour and spin ratios
35793 DO 250 I=150,170,10
35794 WSWQ=(2D0*(PARF(I+1)+PARF(I+5))+PARF(I+3))/
35795 & (1D0+PARF(I+7)+PARF(I+4)+PARF(I+2)+PARF(I+6))
35796 WSSWSQ=PARF(I+3)/(PARF(I+1)+PARF(I+5))
35797 WQSWQQ=2D0*(PARF(I+2)+PARF(I+6))/(1D0+PARF(I+7)+PARF(I+4))
35798 WUUWQQ=PARF(I+4)/(1D0+PARF(I+7)+PARF(I+4))
35799 PARF(I+5)=PARF(I+5)/PARF(I+1)
35800 PARF(I+6)=PARF(I+6)/PARF(I+2)
35801 PARF(I+1)=WSWQ
35802 PARF(I+2)=WQSWQQ
35803 PARF(I+3)=WSSWSQ
35804 PARF(I+4)=WUUWQQ
35805 250 CONTINUE
35806 RETURN
35807 END
35808
35809C*********************************************************************
35810
35811*$ CREATE PYPTDI.FOR
35812*COPY PYPTDI
35813C...PYPTDI
35814C...Generates transverse momentum according to a Gaussian.
35815
35816 SUBROUTINE PYPTDI(KFL,PX,PY)
35817
35818C...Double precision and integer declarations.
35819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35820 INTEGER PYK,PYCHGE,PYCOMP
35821C...Commonblocks.
35822 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35823 SAVE /PYDAT1/
35824
35825C...Generate p_T and azimuthal angle, gives p_x and p_y.
35826 KFLA=IABS(KFL)
35827 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
35828 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
35829 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
35830 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
35831 PHI=PARU(2)*PYR(0)
35832 PX=PT*COS(PHI)
35833 PY=PT*SIN(PHI)
35834
35835 RETURN
35836 END
35837
35838C*********************************************************************
35839
35840*$ CREATE PYZDIS.FOR
35841*COPY PYZDIS
35842C...PYZDIS
35843C...Generates the longitudinal splitting variable z.
35844
35845 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
35846
35847C...Double precision and integer declarations.
35848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35849 INTEGER PYK,PYCHGE,PYCOMP
35850C...Commonblocks.
35851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35852 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35853 SAVE /PYDAT1/,/PYDAT2/
35854
35855C...Check if heavy flavour fragmentation.
35856 KFLA=IABS(KFL1)
35857 KFLB=IABS(KFL2)
35858 KFLH=KFLA
35859 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
35860
35861C...Lund symmetric scaling function: determine parameters of shape.
35862 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
35863 &MSTJ(11).GE.4) THEN
35864 FA=PARJ(41)
35865 IF(MSTJ(91).EQ.1) FA=PARJ(43)
35866 IF(KFLB.GE.10) FA=FA+PARJ(45)
35867 FBB=PARJ(42)
35868 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
35869 FB=FBB*PR
35870 FC=1D0
35871 IF(KFLA.GE.10) FC=FC-PARJ(45)
35872 IF(KFLB.GE.10) FC=FC+PARJ(45)
35873 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
35874 FRED=PARJ(46)
35875 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
35876 FC=FC+FRED*FBB*PARF(100+KFLH)**2
35877 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
35878 FRED=PARJ(46)
35879 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
35880 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
35881 ENDIF
35882 MC=1
35883 IF(ABS(FC-1D0).GT.0.01D0) MC=2
35884
35885C...Determine position of maximum. Special cases for a = 0 or a = c.
35886 IF(FA.LT.0.02D0) THEN
35887 MA=1
35888 ZMAX=1D0
35889 IF(FC.GT.FB) ZMAX=FB/FC
35890 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
35891 MA=2
35892 ZMAX=FB/(FB+FC)
35893 ELSE
35894 MA=3
35895 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
35896 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
35897 ENDIF
35898
35899C...Subdivide z range if distribution very peaked near endpoint.
35900 MMAX=2
35901 IF(ZMAX.LT.0.1D0) THEN
35902 MMAX=1
35903 ZDIV=2.75D0*ZMAX
35904 IF(MC.EQ.1) THEN
35905 FINT=1D0-LOG(ZDIV)
35906 ELSE
35907 ZDIVC=ZDIV**(1D0-FC)
35908 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
35909 ENDIF
35910 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
35911 MMAX=3
35912 FSCB=SQRT(4D0+(FC/FB)**2)
35913 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
35914 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
35915 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
35916 FINT=1D0+FB*(1D0-ZDIV)
35917 ENDIF
35918
35919C...Choice of z, preweighted for peaks at low or high z.
35920 100 Z=PYR(0)
35921 FPRE=1D0
35922 IF(MMAX.EQ.1) THEN
35923 IF(FINT*PYR(0).LE.1D0) THEN
35924 Z=ZDIV*Z
35925 ELSEIF(MC.EQ.1) THEN
35926 Z=ZDIV**Z
35927 FPRE=ZDIV/Z
35928 ELSE
35929 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
35930 FPRE=(ZDIV/Z)**FC
35931 ENDIF
35932 ELSEIF(MMAX.EQ.3) THEN
35933 IF(FINT*PYR(0).LE.1D0) THEN
35934 Z=ZDIV+LOG(Z)/FB
35935 FPRE=EXP(FB*(Z-ZDIV))
35936 ELSE
35937 Z=ZDIV+Z*(1D0-ZDIV)
35938 ENDIF
35939 ENDIF
35940
35941C...Weighting according to correct formula.
35942 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
35943 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
35944 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
35945 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
35946 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
35947
35948C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
35949 ELSE
35950 FC=PARJ(50+MAX(1,KFLH))
35951 IF(MSTJ(91).EQ.1) FC=PARJ(59)
35952 110 Z=PYR(0)
35953 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
35954 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
35955 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
35956 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
35957 & GOTO 110
35958 ELSE
35959 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
35960 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
35961 ENDIF
35962 ENDIF
35963
35964 RETURN
35965 END
35966
35967C*********************************************************************
35968
35969*$ CREATE PYSHOW.FOR
35970*COPY PYSHOW
35971C...PYSHOW
35972C...Generates timelike parton showers from given partons.
35973
35974 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
35975
35976C...Double precision and integer declarations.
35977 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35978 INTEGER PYK,PYCHGE,PYCOMP
35979C...Commonblocks.
35980 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
35981 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35982 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35983 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
35984C...Local arrays.
35985 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
35986 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
35987 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
35988 &ISII(2)
35989
35990C...Initialization of cutoff masses etc.
35991 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
35992 &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
35993 DO 100 IFL=0,40
35994 KSH(IFL)=0
35995 100 CONTINUE
35996 KSH(21)=1
35997 PMTH(1,21)=PYMASS(21)
35998 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
35999 PMTH(3,21)=2D0*PMTH(2,21)
36000 PMTH(4,21)=PMTH(3,21)
36001 PMTH(5,21)=PMTH(3,21)
36002 PMTH(1,22)=PYMASS(22)
36003 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
36004 PMTH(3,22)=2D0*PMTH(2,22)
36005 PMTH(4,22)=PMTH(3,22)
36006 PMTH(5,22)=PMTH(3,22)
36007 PMQTH1=PARJ(82)
36008 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
36009 PMQTH2=PMTH(2,21)
36010 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
36011 DO 110 IFL=1,8
36012 KSH(IFL)=1
36013 PMTH(1,IFL)=PYMASS(IFL)
36014 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
36015 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
36016 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
36017 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
36018 110 CONTINUE
36019 DO 120 IFL=11,17,2
36020 IF(MSTJ(41).GE.2) KSH(IFL)=1
36021 PMTH(1,IFL)=PYMASS(IFL)
36022 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)
36023 PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
36024 PMTH(4,IFL)=PMTH(3,IFL)
36025 PMTH(5,IFL)=PMTH(3,IFL)
36026 120 CONTINUE
36027 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
36028 ALAMS=PARJ(81)**2
36029 ALFM=LOG(PT2MIN/ALAMS)
36030
36031C...Store positions of shower initiating partons.
36032 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
36033 NPA=1
36034 IPA(1)=IP1
36035 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
36036 & MSTU(32))) THEN
36037 NPA=2
36038 IPA(1)=IP1
36039 IPA(2)=IP2
36040 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
36041 & .AND.IP2.GE.-3) THEN
36042 NPA=IABS(IP2)
36043 DO 130 I=1,NPA
36044 IPA(I)=IP1+I-1
36045 130 CONTINUE
36046 ELSE
36047 CALL PYERRM(12,
36048 & '(PYSHOW:) failed to reconstruct showering system')
36049 IF(MSTU(21).GE.1) RETURN
36050 ENDIF
36051
36052C...Check on phase space available for emission.
36053 IREJ=0
36054 DO 140 J=1,5
36055 PS(J)=0D0
36056 140 CONTINUE
36057 PM=0D0
36058 DO 160 I=1,NPA
36059 KFLA(I)=IABS(K(IPA(I),2))
36060 PMA(I)=P(IPA(I),5)
36061C...Special cutoff masses for t, l, h with variable masses.
36062 IFLA=KFLA(I)
36063 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
36064 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
36065 PMTH(1,IFLA)=PMA(I)
36066 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
36067 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
36068 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
36069 & PMTH(2,21)
36070 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
36071 & PMTH(2,22)
36072 ENDIF
36073 IF(KFLA(I).LE.40) THEN
36074 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
36075 ENDIF
36076 PM=PM+PMA(I)
36077 IF(KFLA(I).GT.40) THEN
36078 IREJ=IREJ+1
36079 ELSE
36080 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
36081 ENDIF
36082 DO 150 J=1,4
36083 PS(J)=PS(J)+P(IPA(I),J)
36084 150 CONTINUE
36085 160 CONTINUE
36086 IF(IREJ.EQ.NPA) RETURN
36087 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
36088 IF(NPA.EQ.1) PS(5)=PS(4)
36089 IF(PS(5).LE.PM+PMQTH1) RETURN
36090
36091C...Check if 3-jet matrix elements to be used.
36092 M3JC=0
36093 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
36094 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
36095 & KFLA(2).LE.8) M3JC=1
36096 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
36097 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
36098 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
36099 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
36100 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
36101 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
36102 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
36103 M3JCM=0
36104 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
36105 M3JCM=1
36106 QME=(2D0*PMTH(1,KFLA(1))/PS(5))**2
36107 ENDIF
36108 ENDIF
36109
36110C...Find if interference with initial state partons.
36111 MIIS=0
36112 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
36113 IF(MIIS.NE.0) THEN
36114 DO 180 I=1,2
36115 KCII(I)=0
36116 KCA=PYCOMP(KFLA(I))
36117 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
36118 NIIS(I)=0
36119 IF(KCII(I).NE.0) THEN
36120 DO 170 J=1,2
36121 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
36122 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
36123 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
36124 NIIS(I)=NIIS(I)+1
36125 IIIS(I,NIIS(I))=ICSI
36126 ENDIF
36127 170 CONTINUE
36128 ENDIF
36129 180 CONTINUE
36130 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
36131 ENDIF
36132
36133C...Boost interfering initial partons to rest frame
36134C...and reconstruct their polar and azimuthal angles.
36135 IF(MIIS.NE.0) THEN
36136 DO 200 I=1,2
36137 DO 190 J=1,5
36138 K(N+I,J)=K(IPA(I),J)
36139 P(N+I,J)=P(IPA(I),J)
36140 V(N+I,J)=0D0
36141 190 CONTINUE
36142 200 CONTINUE
36143 DO 220 I=3,2+NIIS(1)
36144 DO 210 J=1,5
36145 K(N+I,J)=K(IIIS(1,I-2),J)
36146 P(N+I,J)=P(IIIS(1,I-2),J)
36147 V(N+I,J)=0D0
36148 210 CONTINUE
36149 220 CONTINUE
36150 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
36151 DO 230 J=1,5
36152 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
36153 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
36154 V(N+I,J)=0D0
36155 230 CONTINUE
36156 240 CONTINUE
36157 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
36158 & -PS(2)/PS(4),-PS(3)/PS(4))
36159 PHI=PYANGL(P(N+1,1),P(N+1,2))
36160 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
36161 THE=PYANGL(P(N+1,3),P(N+1,1))
36162 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
36163 DO 250 I=3,2+NIIS(1)
36164 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
36165 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
36166 250 CONTINUE
36167 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
36168 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
36169 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
36170 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
36171 260 CONTINUE
36172 ENDIF
36173
36174C...Define imagined single initiator of shower for parton system.
36175 NS=N
36176 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36177 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36178 IF(MSTU(21).GE.1) RETURN
36179 ENDIF
36180 IF(NPA.GE.2) THEN
36181 K(N+1,1)=11
36182 K(N+1,2)=21
36183 K(N+1,3)=0
36184 K(N+1,4)=0
36185 K(N+1,5)=0
36186 P(N+1,1)=0D0
36187 P(N+1,2)=0D0
36188 P(N+1,3)=0D0
36189 P(N+1,4)=PS(5)
36190 P(N+1,5)=PS(5)
36191 V(N+1,5)=PS(5)**2
36192 N=N+1
36193 ENDIF
36194
36195C...Loop over partons that may branch.
36196 NEP=NPA
36197 IM=NS
36198 IF(NPA.EQ.1) IM=NS-1
36199 270 IM=IM+1
36200 IF(N.GT.NS) THEN
36201 IF(IM.GT.N) GOTO 510
36202 KFLM=IABS(K(IM,2))
36203 IF(KFLM.GT.40) GOTO 270
36204 IF(KSH(KFLM).EQ.0) GOTO 270
36205 IFLM=KFLM
36206 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
36207 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
36208 IGM=K(IM,3)
36209 ELSE
36210 IGM=-1
36211 ENDIF
36212 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
36213 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36214 IF(MSTU(21).GE.1) RETURN
36215 ENDIF
36216
36217C...Position of aunt (sister to branching parton).
36218C...Origin and flavour of daughters.
36219 IAU=0
36220 IF(IGM.GT.0) THEN
36221 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
36222 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
36223 ENDIF
36224 IF(IGM.GE.0) THEN
36225 K(IM,4)=N+1
36226 DO 280 I=1,NEP
36227 K(N+I,3)=IM
36228 280 CONTINUE
36229 ELSE
36230 K(N+1,3)=IPA(1)
36231 ENDIF
36232 IF(IGM.LE.0) THEN
36233 DO 290 I=1,NEP
36234 K(N+I,2)=K(IPA(I),2)
36235 290 CONTINUE
36236 ELSEIF(KFLM.NE.21) THEN
36237 K(N+1,2)=K(IM,2)
36238 K(N+2,2)=K(IM,5)
36239 ELSEIF(K(IM,5).EQ.21) THEN
36240 K(N+1,2)=21
36241 K(N+2,2)=21
36242 ELSE
36243 K(N+1,2)=K(IM,5)
36244 K(N+2,2)=-K(IM,5)
36245 ENDIF
36246
36247C...Reset flags on daughers and tries made.
36248 DO 300 IP=1,NEP
36249 K(N+IP,1)=3
36250 K(N+IP,4)=0
36251 K(N+IP,5)=0
36252 KFLD(IP)=IABS(K(N+IP,2))
36253 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
36254 ITRY(IP)=0
36255 ISL(IP)=0
36256 ISI(IP)=0
36257 IF(KFLD(IP).LE.40) THEN
36258 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
36259 ENDIF
36260 300 CONTINUE
36261 ISLM=0
36262
36263C...Maximum virtuality of daughters.
36264 IF(IGM.LE.0) THEN
36265 DO 310 I=1,NPA
36266 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
36267 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
36268 P(N+I,5)=MIN(QMAX,PS(5))
36269 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
36270 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
36271 310 CONTINUE
36272 ELSE
36273 IF(MSTJ(43).LE.2) PEM=V(IM,2)
36274 IF(MSTJ(43).GE.3) PEM=P(IM,4)
36275 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
36276 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
36277 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
36278 ENDIF
36279 DO 320 I=1,NEP
36280 PMSD(I)=P(N+I,5)
36281 IF(ISI(I).EQ.1) THEN
36282 IFLD=KFLD(I)
36283 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36284 & ISIGN(2,K(N+I,2))
36285 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
36286 ENDIF
36287 V(N+I,5)=P(N+I,5)**2
36288 320 CONTINUE
36289
36290C...Choose one of the daughters for evolution.
36291 330 INUM=0
36292 IF(NEP.EQ.1) INUM=1
36293 DO 340 I=1,NEP
36294 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
36295 340 CONTINUE
36296 DO 350 I=1,NEP
36297 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
36298 IFLD=KFLD(I)
36299 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36300 & ISIGN(2,K(N+I,2))
36301 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
36302 ENDIF
36303 350 CONTINUE
36304 IF(INUM.EQ.0) THEN
36305 RMAX=0D0
36306 DO 360 I=1,NEP
36307 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
36308 RPM=P(N+I,5)/PMSD(I)
36309 IFLD=KFLD(I)
36310 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36311 & ISIGN(2,K(N+I,2))
36312 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
36313 RMAX=RPM
36314 INUM=I
36315 ENDIF
36316 ENDIF
36317 360 CONTINUE
36318 ENDIF
36319
36320C...Store information on choice of evolving daughter.
36321 INUM=MAX(1,INUM)
36322 IEP(1)=N+INUM
36323 DO 370 I=2,NEP
36324 IEP(I)=IEP(I-1)+1
36325 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
36326 370 CONTINUE
36327 DO 380 I=1,NEP
36328 KFL(I)=IABS(K(IEP(I),2))
36329 380 CONTINUE
36330 ITRY(INUM)=ITRY(INUM)+1
36331 IF(ITRY(INUM).GT.200) THEN
36332 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
36333 IF(MSTU(21).GE.1) RETURN
36334 ENDIF
36335 Z=0.5D0
36336 IF(KFL(1).GT.40) GOTO 430
36337 IF(KSH(KFL(1)).EQ.0) GOTO 430
36338 IFL=KFL(1)
36339 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
36340 &ISIGN(2,K(IEP(1),2))
36341 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
36342
36343C...Select side for interference with initial state partons.
36344 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
36345 III=IEP(1)-NS-1
36346 ISII(III)=0
36347 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
36348 ISII(III)=1
36349 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
36350 IF(PYR(0).GT.0.5D0) ISII(III)=1
36351 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
36352 ISII(III)=1
36353 IF(PYR(0).GT.0.5D0) ISII(III)=2
36354 ENDIF
36355 ENDIF
36356
36357C...Calculate allowed z range.
36358 IF(NEP.EQ.1) THEN
36359 PMED=PS(4)
36360 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36361 PMED=P(IM,5)
36362 ELSE
36363 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
36364 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
36365 ENDIF
36366 IF(MOD(MSTJ(43),2).EQ.1) THEN
36367 ZC=PMTH(2,21)/PMED
36368 ZCE=PMTH(2,22)/PMED
36369 ELSE
36370 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
36371 IF(ZC.LT.1D-4) ZC=(PMTH(2,21)/PMED)**2
36372 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,22)/PMED)**2)))
36373 IF(ZCE.LT.1D-4) ZCE=(PMTH(2,22)/PMED)**2
36374 ENDIF
36375 ZC=MIN(ZC,0.491D0)
36376 ZCE=MIN(ZCE,0.491D0)
36377 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
36378 &MIN(ZC,ZCE).GT.0.49D0)) THEN
36379 P(IEP(1),5)=PMTH(1,IFL)
36380 V(IEP(1),5)=P(IEP(1),5)**2
36381 GOTO 430
36382 ENDIF
36383
36384C...Integral of Altarelli-Parisi z kernel for QCD.
36385 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
36386 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*(0.5D0-ZC)
36387 ELSEIF(MSTJ(49).EQ.0) THEN
36388 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
36389
36390C...Integral of Altarelli-Parisi z kernel for scalar gluon.
36391 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
36392 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
36393 ELSEIF(MSTJ(49).EQ.1) THEN
36394 FBR=(1D0-2D0*ZC)/3D0
36395 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
36396
36397C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
36398 ELSEIF(KFL(1).EQ.21) THEN
36399 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
36400 ELSE
36401 FBR=2D0*LOG((1D0-ZC)/ZC)
36402 ENDIF
36403
36404C...Reset QCD probability for lepton.
36405 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
36406
36407C...Integral of Altarelli-Parisi kernel for photon emission.
36408 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36409 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
36410 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
36411 ENDIF
36412
36413C...Inner veto algorithm starts. Find maximum mass for evolution.
36414 390 PMS=V(IEP(1),5)
36415 IF(IGM.GE.0) THEN
36416 PM2=0D0
36417 DO 400 I=2,NEP
36418 PM=P(IEP(I),5)
36419 IF(KFL(I).LE.40) THEN
36420 IFLI=KFL(I)
36421 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
36422 & ISIGN(2,K(IEP(I),2))
36423 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
36424 ENDIF
36425 PM2=PM2+PM
36426 400 CONTINUE
36427 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
36428 ENDIF
36429
36430C...Select mass for daughter in QCD evolution.
36431 B0=27D0/6D0
36432 DO 410 IFF=4,MSTJ(45)
36433 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
36434 410 CONTINUE
36435 IF(FBR.LT.1D-3) THEN
36436 PMSQCD=0D0
36437 ELSEIF(MSTJ(44).LE.0) THEN
36438 PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
36439 ELSEIF(MSTJ(44).EQ.1) THEN
36440 PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
36441 ELSE
36442 PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
36443 ENDIF
36444 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
36445 V(IEP(1),5)=PMSQCD
36446 MCE=1
36447
36448C...Select mass for daughter in QED evolution.
36449 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36450 PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
36451 IF(ZCE.GT.0.49D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
36452 & PMTH(2,IFL)**2
36453 IF(PMSQED.GT.PMSQCD) THEN
36454 V(IEP(1),5)=PMSQED
36455 MCE=2
36456 ENDIF
36457 ENDIF
36458
36459C...Check whether daughter mass below cutoff.
36460 P(IEP(1),5)=SQRT(V(IEP(1),5))
36461 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
36462 P(IEP(1),5)=PMTH(1,IFL)
36463 V(IEP(1),5)=P(IEP(1),5)**2
36464 GOTO 430
36465 ENDIF
36466
36467C...Select z value of branching: q -> qgamma.
36468 IF(MCE.EQ.2) THEN
36469 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
36470 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36471 K(IEP(1),5)=22
36472
36473C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
36474 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
36475 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36476 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36477 K(IEP(1),5)=21
36478 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5D0-ZC).LT.PYR(0)*FBR) THEN
36479 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36480 IF(PYR(0).GT.0.5D0) Z=1D0-Z
36481 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
36482 K(IEP(1),5)=21
36483 ELSEIF(MSTJ(49).NE.1) THEN
36484 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36485 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
36486 KFLB=1+INT(MSTJ(45)*PYR(0))
36487 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36488 IF(PMQ.GE.1D0) GOTO 390
36489 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
36490 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.
36491 & PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
36492 K(IEP(1),5)=KFLB
36493
36494C...Ditto for scalar gluon model.
36495 ELSEIF(KFL(1).NE.21) THEN
36496 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
36497 K(IEP(1),5)=21
36498 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
36499 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36500 K(IEP(1),5)=21
36501 ELSE
36502 Z=ZC+(1D0-2D0*ZC)*PYR(0)
36503 KFLB=1+INT(MSTJ(45)*PYR(0))
36504 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36505 IF(PMQ.GE.1D0) GOTO 390
36506 K(IEP(1),5)=KFLB
36507 ENDIF
36508 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
36509 IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
36510 IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
36511 ENDIF
36512
36513C...Check if z consistent with chosen m.
36514 IF(KFL(1).EQ.21) THEN
36515 KFLGD1=IABS(K(IEP(1),5))
36516 KFLGD2=KFLGD1
36517 ELSE
36518 KFLGD1=KFL(1)
36519 KFLGD2=IABS(K(IEP(1),5))
36520 ENDIF
36521 IF(NEP.EQ.1) THEN
36522 PED=PS(4)
36523 ELSEIF(NEP.GE.3) THEN
36524 PED=P(IEP(1),4)
36525 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36526 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
36527 ELSE
36528 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
36529 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
36530 ENDIF
36531 IF(MOD(MSTJ(43),2).EQ.1) THEN
36532 IFLGD1=KFLGD1
36533 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
36534 PMQTH3=0.5D0*PARJ(82)
36535 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36536 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
36537 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
36538 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36539 & 4D0*PMQ1*PMQ2)))
36540 ZH=1D0+PMQ1-PMQ2
36541 ELSE
36542 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
36543 ZH=1D0
36544 ENDIF
36545 ZL=0.5D0*(ZH-ZD)
36546 ZU=0.5D0*(ZH+ZD)
36547 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
36548 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
36549 &(1D0-ZU)))
36550 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36551
36552C...Width suppression for q -> q + g.
36553 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
36554 IF(IGM.EQ.0) THEN
36555 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
36556 ELSE
36557 EGLU=PMED*(1D0-Z)
36558 ENDIF
36559 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
36560 IF(MSTJ(40).EQ.1) THEN
36561 IF(CHI.LT.PYR(0)) GOTO 390
36562 ELSEIF(MSTJ(40).EQ.2) THEN
36563 IF(1D0-CHI.LT.PYR(0)) GOTO 390
36564 ENDIF
36565 ENDIF
36566
36567C...Three-jet matrix element correction.
36568 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
36569 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
36570 X2=1D0-V(IEP(1),5)/V(NS+1,5)
36571 X3=(1D0-X1)+(1D0-X2)
36572 IF(MCE.EQ.2) THEN
36573 KI1=K(IPA(INUM),2)
36574 KI2=K(IPA(3-INUM),2)
36575 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
36576 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
36577 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
36578 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
36579 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
36580 ELSEIF(MSTJ(49).NE.1) THEN
36581 WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
36582 & (1D0-X2)/X3*(X2/(2D0-X1))**2
36583 WME=X1**2+X2**2
36584 IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5D0*QME**2-
36585 & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-7,1D0-X1)+
36586 & (1D0-X1)/MAX(1D-7,1D0-X2))
36587 ELSE
36588 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
36589 WME=X3**2
36590 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
36591 & PARJ(171)
36592 ENDIF
36593 IF(WME.LT.PYR(0)*WSHOW) GOTO 390
36594
36595C...Impose angular ordering by rejection of nonordered emission.
36596 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
36597 MAOM=1
36598 ZM=V(IM,1)
36599 IF(IEP(1).EQ.N+2) ZM=1D0-V(IM,1)
36600 THE2ID=Z*(1D0-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
36601 IAOM=IM
36602 420 IF(K(IAOM,5).EQ.22) THEN
36603 IAOM=K(IAOM,3)
36604 IF(K(IAOM,3).LE.NS) MAOM=0
36605 IF(MAOM.EQ.1) GOTO 420
36606 ENDIF
36607 IF(MAOM.EQ.1) THEN
36608 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
36609 IF(THE2ID.LT.THE2IM) GOTO 390
36610 ENDIF
36611 ENDIF
36612
36613C...Impose user-defined maximum angle at first branching.
36614 IF(MSTJ(48).EQ.1) THEN
36615 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
36616 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
36617 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36618 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
36619 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36620 IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36621 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
36622 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36623 IF(THE2ID.LT.1D0/PARJ(86)**2) GOTO 390
36624 ENDIF
36625 ENDIF
36626
36627C...Impose angular constraint in first branching from interference
36628C...with initial state partons.
36629 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
36630 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
36631 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
36632 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
36633 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
36634 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
36635 ENDIF
36636 ENDIF
36637
36638C...End of inner veto algorithm. Check if only one leg evolved so far.
36639 430 V(IEP(1),1)=Z
36640 ISL(1)=0
36641 ISL(2)=0
36642 IF(NEP.EQ.1) GOTO 460
36643 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
36644 DO 440 I=1,NEP
36645 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
36646 IF(KSH(KFLD(I)).EQ.1) THEN
36647 IFLD=KFLD(I)
36648 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36649 & ISIGN(2,K(N+I,2))
36650 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
36651 ENDIF
36652 ENDIF
36653 440 CONTINUE
36654
36655C...Check if chosen multiplet m1,m2,z1,z2 is physical.
36656 IF(NEP.EQ.3) THEN
36657 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
36658 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
36659 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
36660 PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
36661 & PA1S**2-PA2S**2-PA3S**2)/PA1S
36662 IF(PTS.LE.0D0) GOTO 330
36663 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
36664 DO 450 I1=N+1,N+2
36665 KFLDA=IABS(K(I1,2))
36666 IF(KFLDA.GT.40) GOTO 450
36667 IF(KSH(KFLDA).EQ.0) GOTO 450
36668 IFLDA=KFLDA
36669 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
36670 & ISIGN(2,K(I1,2))
36671 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
36672 IF(KFLDA.EQ.21) THEN
36673 KFLGD1=IABS(K(I1,5))
36674 KFLGD2=KFLGD1
36675 ELSE
36676 KFLGD1=KFLDA
36677 KFLGD2=IABS(K(I1,5))
36678 ENDIF
36679 I2=2*N+3-I1
36680 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36681 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
36682 ELSE
36683 IF(I1.EQ.N+1) ZM=V(IM,1)
36684 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
36685 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
36686 & 4D0*V(N+1,5)*V(N+2,5))
36687 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
36688 ENDIF
36689 IF(MOD(MSTJ(43),2).EQ.1) THEN
36690 PMQTH3=0.5D0*PARJ(82)
36691 IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36692 IFLGD1=KFLGD1
36693 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
36694 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
36695 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
36696 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36697 & 4D0*PMQ1*PMQ2)))
36698 ZH=1D0+PMQ1-PMQ2
36699 ELSE
36700 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
36701 ZH=1D0
36702 ENDIF
36703 ZL=0.5D0*(ZH-ZD)
36704 ZU=0.5D0*(ZH+ZD)
36705 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
36706 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
36707 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
36708 & ZL*(1D0-ZU)))
36709 IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36710 450 CONTINUE
36711 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
36712 ISL(3-ISLM)=0
36713 ISLM=3-ISLM
36714 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
36715 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
36716 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
36717 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
36718 IF(ISL(1).EQ.1) ISL(2)=0
36719 IF(ISL(1).EQ.0) ISLM=1
36720 IF(ISL(2).EQ.0) ISLM=2
36721 ENDIF
36722 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
36723 ENDIF
36724 IFLD1=KFLD(1)
36725 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
36726 &ISIGN(2,K(N+1,2))
36727 IFLD2=KFLD(2)
36728 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
36729 &ISIGN(2,K(N+2,2))
36730 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
36731 &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
36732 PMQ1=V(N+1,5)/V(IM,5)
36733 PMQ2=V(N+2,5)/V(IM,5)
36734 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
36735 & 4D0*PMQ1*PMQ2)))
36736 ZH=1D0+PMQ1-PMQ2
36737 ZL=0.5D0*(ZH-ZD)
36738 ZU=0.5D0*(ZH+ZD)
36739 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
36740 ENDIF
36741
36742C...Accepted branch. Construct four-momentum for initial partons.
36743 460 MAZIP=0
36744 MAZIC=0
36745 IF(NEP.EQ.1) THEN
36746 P(N+1,1)=0D0
36747 P(N+1,2)=0D0
36748 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
36749 & P(N+1,5))))
36750 P(N+1,4)=P(IPA(1),4)
36751 V(N+1,2)=P(N+1,4)
36752 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
36753 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
36754 P(N+1,1)=0D0
36755 P(N+1,2)=0D0
36756 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
36757 P(N+1,4)=PED1
36758 P(N+2,1)=0D0
36759 P(N+2,2)=0D0
36760 P(N+2,3)=-P(N+1,3)
36761 P(N+2,4)=P(IM,5)-PED1
36762 V(N+1,2)=P(N+1,4)
36763 V(N+2,2)=P(N+2,4)
36764 ELSEIF(NEP.EQ.3) THEN
36765 P(N+1,1)=0D0
36766 P(N+1,2)=0D0
36767 P(N+1,3)=SQRT(MAX(0D0,PA1S))
36768 P(N+2,1)=SQRT(PTS)
36769 P(N+2,2)=0D0
36770 P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
36771 P(N+3,1)=-P(N+2,1)
36772 P(N+3,2)=0D0
36773 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
36774 V(N+1,2)=P(N+1,4)
36775 V(N+2,2)=P(N+2,4)
36776 V(N+3,2)=P(N+3,4)
36777
36778C...Construct transverse momentum for ordinary branching in shower.
36779 ELSE
36780 ZM=V(IM,1)
36781 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
36782 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
36783 IF(PZM.LE.0D0) THEN
36784 PTS=0D0
36785 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
36786 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
36787 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
36788 ELSE
36789 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
36790 ENDIF
36791 PT=SQRT(MAX(0D0,PTS))
36792
36793C...Find coefficient of azimuthal asymmetry due to gluon polarization.
36794 HAZIP=0D0
36795 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
36796 & .AND.IAU.NE.0) THEN
36797 IF(K(IGM,3).NE.0) MAZIP=1
36798 ZAU=V(IGM,1)
36799 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
36800 IF(MAZIP.EQ.0) ZAU=0D0
36801 IF(K(IGM,2).NE.21) THEN
36802 HAZIP=2D0*ZAU/(1D0+ZAU**2)
36803 ELSE
36804 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
36805 ENDIF
36806 IF(K(N+1,2).NE.21) THEN
36807 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
36808 ELSE
36809 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
36810 ENDIF
36811 ENDIF
36812
36813C...Find coefficient of azimuthal asymmetry due to soft gluon
36814C...interference.
36815 HAZIC=0D0
36816 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
36817 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
36818 IF(K(IGM,3).NE.0) MAZIC=N+1
36819 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
36820 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36821 & ZM.GT.0.5D0) MAZIC=N+2
36822 IF(K(IAU,2).EQ.22) MAZIC=0
36823 ZS=ZM
36824 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
36825 ZGM=V(IGM,1)
36826 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
36827 IF(MAZIC.EQ.0) ZGM=1D0
36828 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
36829 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
36830 HAZIC=MIN(0.95D0,HAZIC)
36831 ENDIF
36832 ENDIF
36833
36834C...Construct kinematics for ordinary branching in shower.
36835 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
36836 IF(MOD(MSTJ(43),2).EQ.1) THEN
36837 P(N+1,4)=PEM*V(IM,1)
36838 ELSE
36839 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
36840 & SQRT(PMLS)*ZM)/V(IM,5)
36841 ENDIF
36842 PHI=PARU(2)*PYR(0)
36843 P(N+1,1)=PT*COS(PHI)
36844 P(N+1,2)=PT*SIN(PHI)
36845 IF(PZM.GT.0D0) THEN
36846 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
36847 & 2D0*PEM*P(N+1,4))/PZM
36848 ELSE
36849 P(N+1,3)=0D0
36850 ENDIF
36851 P(N+2,1)=-P(N+1,1)
36852 P(N+2,2)=-P(N+1,2)
36853 P(N+2,3)=PZM-P(N+1,3)
36854 P(N+2,4)=PEM-P(N+1,4)
36855 IF(MSTJ(43).LE.2) THEN
36856 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
36857 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
36858 ENDIF
36859 ENDIF
36860
36861C...Rotate and boost daughters.
36862 IF(IGM.GT.0) THEN
36863 IF(MSTJ(43).LE.2) THEN
36864 BEX=P(IGM,1)/P(IGM,4)
36865 BEY=P(IGM,2)/P(IGM,4)
36866 BEZ=P(IGM,3)/P(IGM,4)
36867 GA=P(IGM,4)/P(IGM,5)
36868 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
36869 & P(IM,4))
36870 ELSE
36871 BEX=0D0
36872 BEY=0D0
36873 BEZ=0D0
36874 GA=1D0
36875 GABEP=0D0
36876 ENDIF
36877 THE=PYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
36878 & (P(IM,2)+GABEP*BEY)**2))
36879 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
36880 DO 480 I=N+1,N+2
36881 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
36882 & SIN(THE)*COS(PHI)*P(I,3)
36883 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
36884 & SIN(THE)*SIN(PHI)*P(I,3)
36885 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
36886 DP(4)=P(I,4)
36887 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
36888 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
36889 P(I,1)=DP(1)+DGABP*BEX
36890 P(I,2)=DP(2)+DGABP*BEY
36891 P(I,3)=DP(3)+DGABP*BEZ
36892 P(I,4)=GA*(DP(4)+DBP)
36893 480 CONTINUE
36894 ENDIF
36895
36896C...Weight with azimuthal distribution, if required.
36897 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
36898 DO 490 J=1,3
36899 DPT(1,J)=P(IM,J)
36900 DPT(2,J)=P(IAU,J)
36901 DPT(3,J)=P(N+1,J)
36902 490 CONTINUE
36903 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
36904 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
36905 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
36906 DO 500 J=1,3
36907 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
36908 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
36909 500 CONTINUE
36910 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
36911 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
36912 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
36913 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
36914 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
36915 IF(MAZIP.NE.0) THEN
36916 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
36917 & GOTO 470
36918 ENDIF
36919 IF(MAZIC.NE.0) THEN
36920 IF(MAZIC.EQ.N+2) CAD=-CAD
36921 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
36922 & .LT.PYR(0)) GOTO 470
36923 ENDIF
36924 ENDIF
36925 ENDIF
36926
36927C...Azimuthal anisotropy due to interference with initial state partons.
36928 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
36929 &K(N+2,2).EQ.21)) THEN
36930 III=IM-NS-1
36931 IF(ISII(III).GE.1) THEN
36932 IAZIID=N+1
36933 IF(K(N+1,2).NE.21) IAZIID=N+2
36934 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36935 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
36936 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
36937 IF(III.EQ.2) THEIID=PARU(1)-THEIID
36938 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
36939 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
36940 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
36941 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
36942 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
36943 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
36944 & .LT.PYR(0)) GOTO 470
36945 ENDIF
36946 ENDIF
36947
36948C...Continue loop over partons that may branch, until none left.
36949 IF(IGM.GE.0) K(IM,1)=14
36950 N=N+NEP
36951 NEP=2
36952 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36953 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36954 IF(MSTU(21).GE.1) N=NS
36955 IF(MSTU(21).GE.1) RETURN
36956 ENDIF
36957 GOTO 270
36958
36959C...Set information on imagined shower initiator.
36960 510 IF(NPA.GE.2) THEN
36961 K(NS+1,1)=11
36962 K(NS+1,2)=94
36963 K(NS+1,3)=IP1
36964 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
36965 K(NS+1,4)=NS+2
36966 K(NS+1,5)=NS+1+NPA
36967 IIM=1
36968 ELSE
36969 IIM=0
36970 ENDIF
36971
36972C...Reconstruct string drawing information.
36973 DO 520 I=NS+1+IIM,N
36974 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
36975 K(I,1)=1
36976 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
36977 & IABS(K(I,2)).LE.18) THEN
36978 K(I,1)=1
36979 ELSEIF(K(I,1).LE.10) THEN
36980 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
36981 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
36982 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
36983 ID1=MOD(K(I,4),MSTU(5))
36984 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
36985 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
36986 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36987 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
36988 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36989 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
36990 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
36991 K(ID2,5)=K(ID2,5)+MSTU(5)*I
36992 ELSE
36993 ID1=MOD(K(I,4),MSTU(5))
36994 ID2=ID1+1
36995 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36996 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
36997 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
36998 K(ID1,4)=K(ID1,4)+MSTU(5)*I
36999 K(ID1,5)=K(ID1,5)+MSTU(5)*I
37000 ELSE
37001 K(ID1,4)=0
37002 K(ID1,5)=0
37003 ENDIF
37004 K(ID2,4)=0
37005 K(ID2,5)=0
37006 ENDIF
37007 520 CONTINUE
37008
37009C...Transformation from CM frame.
37010 IF(NPA.GE.2) THEN
37011 BEX=PS(1)/PS(4)
37012 BEY=PS(2)/PS(4)
37013 BEZ=PS(3)/PS(4)
37014 GA=PS(4)/PS(5)
37015 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
37016 & /(1D0+GA)-P(IPA(1),4))
37017 ELSE
37018 BEX=0D0
37019 BEY=0D0
37020 BEZ=0D0
37021 GABEP=0D0
37022 ENDIF
37023 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
37024 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
37025 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
37026 IF(NPA.EQ.3) THEN
37027 CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
37028 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
37029 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
37030 & GABEP*BEY))
37031 MSTU(33)=1
37032 CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
37033 ENDIF
37034 MSTU(33)=1
37035 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
37036
37037C...Decay vertex of shower.
37038 DO 540 I=NS+1,N
37039 DO 530 J=1,5
37040 V(I,J)=V(IP1,J)
37041 530 CONTINUE
37042 540 CONTINUE
37043
37044C...Delete trivial shower, else connect initiators.
37045 IF(N.EQ.NS+NPA+IIM) THEN
37046 N=NS
37047 ELSE
37048 DO 550 IP=1,NPA
37049 K(IPA(IP),1)=14
37050 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
37051 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
37052 K(NS+IIM+IP,3)=IPA(IP)
37053 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
37054 IF(K(NS+IIM+IP,1).NE.1) THEN
37055 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
37056 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
37057 ENDIF
37058 550 CONTINUE
37059 ENDIF
37060
37061 RETURN
37062 END
37063
37064C*********************************************************************
37065
37066*$ CREATE PYBOEI.FOR
37067*COPY PYBOEI
37068C...PYBOEI
37069C...Modifies an event so as to approximately take into account
37070C...Bose-Einstein effects according to a simple phenomenological
37071C...parametrization.
37072
37073 SUBROUTINE PYBOEI(NSAV)
37074
37075C...Double precision and integer declarations.
37076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37077 INTEGER PYK,PYCHGE,PYCOMP
37078C...Commonblocks.
37079 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37080 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37081 SAVE /PYJETS/,/PYDAT1/
37082C...Local arrays and data.
37083 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
37084 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
37085
37086C...Boost event to overall CM frame. Calculate CM energy.
37087 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
37088 DO 100 J=1,4
37089 DPS(J)=0D0
37090 100 CONTINUE
37091 DO 120 I=1,N
37092 KFA=IABS(K(I,2))
37093 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
37094 & .AND.K(I,3).GT.0) THEN
37095 KFMA=IABS(K(K(I,3),2))
37096 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
37097 ENDIF
37098 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
37099 DO 110 J=1,4
37100 DPS(J)=DPS(J)+P(I,J)
37101 110 CONTINUE
37102 120 CONTINUE
37103 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
37104 &-DPS(3)/DPS(4))
37105 PECM=0D0
37106 DO 130 I=1,N
37107 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
37108 130 CONTINUE
37109
37110C...Reserve copy of particles by species at end of record.
37111 NBE(0)=N+MSTU(3)
37112 DO 160 IBE=1,MIN(9,MSTJ(52))
37113 NBE(IBE)=NBE(IBE-1)
37114 DO 150 I=NSAV+1,N
37115 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
37116 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
37117 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
37118 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
37119 RETURN
37120 ENDIF
37121 NBE(IBE)=NBE(IBE)+1
37122 K(NBE(IBE),1)=I
37123 DO 140 J=1,3
37124 P(NBE(IBE),J)=0D0
37125 140 CONTINUE
37126 150 CONTINUE
37127 160 CONTINUE
37128 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
37129
37130C...Tabulate integral for subsequent momentum shift.
37131 DO 220 IBE=1,MIN(9,MSTJ(52))
37132 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
37133 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
37134 & .LE.1) GOTO 180
37135 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
37136 & NBE(7)-NBE(6)).LE.1) GOTO 180
37137 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
37138 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
37139 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
37140 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
37141 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
37142 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
37143 IF(MSTJ(51).EQ.1) THEN
37144 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
37145 BEEX=EXP(0.5D0*QDEL/PARJ(93))
37146 BERT=EXP(-QDEL/PARJ(93))
37147 ELSE
37148 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
37149 ENDIF
37150 DO 170 IBIN=1,NBIN
37151 QBIN=QDEL*(IBIN-0.5D0)
37152 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
37153 IF(MSTJ(51).EQ.1) THEN
37154 BEEX=BEEX*BERT
37155 BEI(IBIN)=BEI(IBIN)*BEEX
37156 ELSE
37157 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
37158 ENDIF
37159 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
37160 170 CONTINUE
37161
37162C...Loop through particle pairs and find old relative momentum.
37163 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
37164 I1=K(I1M,1)
37165 DO 200 I2M=I1M+1,NBE(IBE)
37166 I2=K(I2M,1)
37167 Q2OLD=MAX(0D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
37168 & (P(I1,2)+ P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
37169 & (P(I1,5)+P(I2,5))**2)
37170 QOLD=SQRT(Q2OLD)
37171
37172C...Calculate new relative momentum.
37173 IF(QOLD.LT.1D-3*QDEL) THEN
37174 GOTO 200
37175 ELSEIF(QOLD.LE.QDEL) THEN
37176 QMOV=QOLD/3D0
37177 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
37178 RBIN=QOLD/QDEL
37179 IBIN=RBIN
37180 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
37181 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
37182 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
37183 ELSE
37184 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
37185 ENDIF
37186 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
37187
37188C...Calculate and save shift to be performed on three-momenta.
37189 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
37190 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
37191 HA=0.5D0*(1D0-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
37192 DO 190 J=1,3
37193 PD=HA*(P(I2,J)-P(I1,J))
37194 P(I1M,J)=P(I1M,J)+PD
37195 P(I2M,J)=P(I2M,J)-PD
37196 190 CONTINUE
37197 200 CONTINUE
37198 210 CONTINUE
37199 220 CONTINUE
37200
37201C...Shift momenta and recalculate energies.
37202 DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
37203 I=K(IM,1)
37204 DO 230 J=1,3
37205 P(I,J)=P(I,J)+P(IM,J)
37206 230 CONTINUE
37207 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37208 240 CONTINUE
37209
37210C...Rescale all momenta for energy conservation.
37211 PES=0D0
37212 PQS=0D0
37213 DO 250 I=1,N
37214 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
37215 PES=PES+P(I,4)
37216 PQS=PQS+P(I,5)**2/P(I,4)
37217 250 CONTINUE
37218 FAC=(PECM-PQS)/(PES-PQS)
37219 DO 270 I=1,N
37220 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
37221 DO 260 J=1,3
37222 P(I,J)=FAC*P(I,J)
37223 260 CONTINUE
37224 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37225 270 CONTINUE
37226
37227C...Boost back to correct reference frame.
37228 280 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
37229 DO 290 I=1,N
37230 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
37231 290 CONTINUE
37232
37233 RETURN
37234 END
37235
37236C*********************************************************************
37237
37238*$ CREATE PYMASS.FOR
37239*COPY PYMASS
37240C...PYMASS
37241C...Gives the mass of a particle/parton.
37242
37243 FUNCTION PYMASS(KF)
37244
37245C...Double precision and integer declarations.
37246 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37247 INTEGER PYK,PYCHGE,PYCOMP
37248C...Commonblocks.
37249 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37250 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37251 SAVE /PYDAT1/,/PYDAT2/
37252
37253C...Reset variables. Compressed code. Special case for popcorn diquarks.
37254 PYMASS=0D0
37255 KFA=IABS(KF)
37256 KC=PYCOMP(KF)
37257 IF(KC.EQ.0) THEN
37258 MSTJ(93)=0
37259 RETURN
37260 ENDIF
37261
37262C...Guarantee use of constituent masses for internal checks.
37263 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
37264 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
37265 PARF(106)=PMAS(6,1)
37266 PARF(107)=PMAS(7,1)
37267 PARF(108)=PMAS(8,1)
37268 IF(KFA.LE.10) THEN
37269 PYMASS=PARF(100+KFA)
37270 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
37271 ELSEIF(MSTJ(93).EQ.1) THEN
37272 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
37273 ELSE
37274 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
37275 ENDIF
37276
37277C...Other masses can be read directly off table.
37278 ELSE
37279 PYMASS=PMAS(KC,1)
37280 ENDIF
37281
37282C...Optional mass broadening according to truncated Breit-Wigner
37283C...(either in m or in m^2).
37284 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
37285 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
37286 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
37287 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
37288 ELSE
37289 PM0=PYMASS
37290 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
37291 & (PM0*PMAS(KC,2)))
37292 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
37293 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
37294 & (PMUPP-PMLOW)*PYR(0))))
37295 ENDIF
37296 ENDIF
37297 MSTJ(93)=0
37298
37299 RETURN
37300 END
37301
37302C*********************************************************************
37303
37304*$ CREATE PYNAME.FOR
37305*COPY PYNAME
37306C...PYNAME
37307C...Gives the particle/parton name as a character string.
37308
37309 SUBROUTINE PYNAME(KF,CHAU)
37310
37311C...Double precision and integer declarations.
37312 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37313 INTEGER PYK,PYCHGE,PYCOMP
37314C...Commonblocks.
37315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37317 COMMON/PYDAT4/CHAF(500,2)
37318 CHARACTER CHAF*16
37319 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
37320C...Local character variable.
37321 CHARACTER CHAU*16
37322
37323C...Read out code with distinction particle/antiparticle.
37324 CHAU=' '
37325 KC=PYCOMP(KF)
37326 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
37327
37328
37329 RETURN
37330 END
37331
37332C*********************************************************************
37333
37334*$ CREATE PYCHGE.FOR
37335*COPY PYCHGE
37336C...PYCHGE
37337C...Gives three times the charge for a particle/parton.
37338
37339 FUNCTION PYCHGE(KF)
37340
37341C...Double precision and integer declarations.
37342 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37343 INTEGER PYK,PYCHGE,PYCOMP
37344C...Commonblocks.
37345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37346 SAVE /PYDAT2/
37347
37348C...Read out charge and change sign for antiparticle.
37349 PYCHGE=0
37350 KC=PYCOMP(KF)
37351 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
37352
37353 RETURN
37354 END
37355
37356C*********************************************************************
37357
37358*$ CREATE PYCOMP.FOR
37359*COPY PYCOMP
37360C...PYCOMP
37361C...Compress the standard KF codes for use in mass and decay arrays;
37362C...also checks whether a given code actually is defined.
37363
37364 FUNCTION PYCOMP(KF)
37365
37366C...Double precision and integer declarations.
37367 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37368 INTEGER PYK,PYCHGE,PYCOMP
37369C...Commonblocks.
37370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37372 SAVE /PYDAT1/,/PYDAT2/
37373C...Local arrays and saved data.
37374 DIMENSION KFORD(100:500),KCORD(101:500)
37375 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
37376
37377C...Whenever necessary reorder codes for faster search.
37378 IF(MSTU(20).EQ.0) THEN
37379 NFORD=100
37380 KFORD(100)=0
37381 DO 120 I=101,500
37382 KFA=KCHG(I,4)
37383 IF(KFA.LE.100) GOTO 120
37384 NFORD=NFORD+1
37385 DO 100 I1=NFORD-1,0,-1
37386 IF(KFA.GE.KFORD(I1)) GOTO 110
37387 KFORD(I1+1)=KFORD(I1)
37388 KCORD(I1+1)=KCORD(I1)
37389 100 CONTINUE
37390 110 KFORD(I1+1)=KFA
37391 KCORD(I1+1)=I
37392 120 CONTINUE
37393 MSTU(20)=1
37394 KFLAST=0
37395 KCLAST=0
37396 ENDIF
37397
37398C...Fast action if same code as in latest call.
37399 IF(KF.EQ.KFLAST) THEN
37400 PYCOMP=KCLAST
37401 RETURN
37402 ENDIF
37403
37404C...Starting values. Remove internal diquark flags.
37405 PYCOMP=0
37406 KFA=IABS(KF)
37407 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
37408 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
37409
37410C...Simple cases: direct translation.
37411 IF(KFA.GT.KFORD(NFORD)) THEN
37412 ELSEIF(KFA.LE.100) THEN
37413 PYCOMP=KFA
37414
37415C...Else binary search.
37416 ELSE
37417 IMIN=100
37418 IMAX=NFORD+1
37419 130 IAVG=(IMIN+IMAX)/2
37420 IF(KFORD(IAVG).GT.KFA) THEN
37421 IMAX=IAVG
37422 IF(IMAX.GT.IMIN+1) GOTO 130
37423 ELSEIF(KFORD(IAVG).LT.KFA) THEN
37424 IMIN=IAVG
37425 IF(IMAX.GT.IMIN+1) GOTO 130
37426 ELSE
37427 PYCOMP=KCORD(IAVG)
37428 ENDIF
37429 ENDIF
37430
37431C...Check if antiparticle allowed.
37432 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
37433 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
37434 ENDIF
37435
37436C...Save codes for possible future fast action.
37437 KFLAST=KF
37438 KCLAST=PYCOMP
37439
37440 RETURN
37441 END
37442
37443C*********************************************************************
37444
37445*$ CREATE PYERRM.FOR
37446*COPY PYERRM
37447C...PYERRM
37448C...Informs user of errors in program execution.
37449
37450 SUBROUTINE PYERRM(MERR,CHMESS)
37451
37452C...Double precision and integer declarations.
37453 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37454 INTEGER PYK,PYCHGE,PYCOMP
37455C...Commonblocks.
37456 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37458 SAVE /PYJETS/,/PYDAT1/
37459C...Local character variable.
37460 CHARACTER CHMESS*(*)
37461
37462C...Write first few warnings, then be silent.
37463 IF(MERR.LE.10) THEN
37464 MSTU(27)=MSTU(27)+1
37465 MSTU(28)=MERR
37466 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
37467 & MERR,MSTU(31),CHMESS
37468
37469C...Write first few errors, then be silent or stop program.
37470 ELSEIF(MERR.LE.20) THEN
37471 MSTU(23)=MSTU(23)+1
37472 MSTU(24)=MERR-10
37473 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
37474 & MERR-10,MSTU(31),CHMESS
37475 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
37476 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
37477 WRITE(MSTU(11),5200)
37478 IF(MERR.NE.17) CALL PYLIST(2)
37479 STOP
37480 ENDIF
37481
37482C...Stop program in case of irreparable error.
37483 ELSE
37484 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
37485 STOP
37486 ENDIF
37487
37488C...Formats for output.
37489 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
37490 &' PYEXEC calls:'/5X,A)
37491 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
37492 &' PYEXEC calls:'/5X,A)
37493 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
37494 &'event!')
37495 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
37496 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
37497
37498 RETURN
37499 END
37500
37501C*********************************************************************
37502
37503*$ CREATE PYALEM.FOR
37504*COPY PYALEM
37505C...PYALEM
37506C...Calculates the running alpha_electromagnetic.
37507
37508 FUNCTION PYALEM(Q2)
37509
37510C...Double precision and integer declarations.
37511 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37512 INTEGER PYK,PYCHGE,PYCOMP
37513C...Commonblocks.
37514 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37515 SAVE /PYDAT1/
37516
37517C...Calculate real part of photon vacuum polarization.
37518C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
37519C...For hadrons use parametrization of H. Burkhardt et al.
37520C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
37521 AEMPI=PARU(101)/(3D0*PARU(1))
37522 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
37523 RPIGG=0D0
37524 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
37525 RPIGG=0D0
37526 ELSEIF(MSTU(101).EQ.2) THEN
37527 RPIGG=1D0-PARU(101)/PARU(103)
37528 ELSEIF(Q2.LT.0.09D0) THEN
37529 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
37530 ELSEIF(Q2.LT.9D0) THEN
37531 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
37532 & 0.00238D0*LOG(1D0+3.927D0*Q2)
37533 ELSEIF(Q2.LT.1D4) THEN
37534 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
37535 & 0.00299D0*LOG(1D0+Q2)
37536 ELSE
37537 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
37538 & 0.00293D0*LOG(1D0+Q2)
37539 ENDIF
37540
37541C...Calculate running alpha_em.
37542 PYALEM=PARU(101)/(1D0-RPIGG)
37543 PARU(108)=PYALEM
37544
37545 RETURN
37546 END
37547
37548C*********************************************************************
37549
37550*$ CREATE PYALPS.FOR
37551*COPY PYALPS
37552C...PYALPS
37553C...Gives the value of alpha_strong.
37554
37555 FUNCTION PYALPS(Q2)
37556
37557C...Double precision and integer declarations.
37558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37559 INTEGER PYK,PYCHGE,PYCOMP
37560C...Commonblocks.
37561 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37562 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37563 SAVE /PYDAT1/,/PYDAT2/
37564
37565C...Constant alpha_strong trivial. Pick artificial Lambda.
37566 IF(MSTU(111).LE.0) THEN
37567 PYALPS=PARU(111)
37568 MSTU(118)=MSTU(112)
37569 PARU(117)=0.2D0
37570 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
37571 & ((33D0-2D0*MSTU(112))*PARU(111)))
37572 PARU(118)=PARU(111)
37573 RETURN
37574 ENDIF
37575
37576C...Find effective Q2, number of flavours and Lambda.
37577 Q2EFF=Q2
37578 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
37579 NF=MSTU(112)
37580 ALAM2=PARU(112)**2
37581 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
37582 Q2THR=PARU(113)*PMAS(NF,1)**2
37583 IF(Q2EFF.LT.Q2THR) THEN
37584 NF=NF-1
37585 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
37586 GOTO 100
37587 ENDIF
37588 ENDIF
37589 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
37590 Q2THR=PARU(113)*PMAS(NF+1,1)**2
37591 IF(Q2EFF.GT.Q2THR) THEN
37592 NF=NF+1
37593 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
37594 GOTO 110
37595 ENDIF
37596 ENDIF
37597 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
37598 PARU(117)=SQRT(ALAM2)
37599
37600C...Evaluate first or second order alpha_strong.
37601 B0=(33D0-2D0*NF)/6D0
37602 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
37603 IF(MSTU(111).EQ.1) THEN
37604 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
37605 ELSE
37606 B1=(153D0-19D0*NF)/6D0
37607 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
37608 & (B0**2*ALGQ)))
37609 ENDIF
37610 MSTU(118)=NF
37611 PARU(118)=PYALPS
37612
37613 RETURN
37614 END
37615
37616C*********************************************************************
37617
37618*$ CREATE PYANGL.FOR
37619*COPY PYANGL
37620C...PYANGL
37621C...Reconstructs an angle from given x and y coordinates.
37622
37623 FUNCTION PYANGL(X,Y)
37624
37625C...Double precision and integer declarations.
37626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37627 INTEGER PYK,PYCHGE,PYCOMP
37628C...Commonblocks.
37629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37630 SAVE /PYDAT1/
37631
37632 PYANGL=0D0
37633 R=SQRT(X**2+Y**2)
37634 IF(R.LT.1D-20) RETURN
37635 IF(ABS(X)/R.LT.0.8D0) THEN
37636 PYANGL=SIGN(ACOS(X/R),Y)
37637 ELSE
37638 PYANGL=ASIN(Y/R)
37639 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
37640 PYANGL=PARU(1)-PYANGL
37641 ELSEIF(X.LT.0D0) THEN
37642 PYANGL=-PARU(1)-PYANGL
37643 ENDIF
37644 ENDIF
37645
37646 RETURN
37647 END
37648
37649C*********************************************************************
37650
37651*$ CREATE XPYR.FOR
37652*COPY XPYR
37653C...PYR
37654C...Generates random numbers uniformly distributed between
37655C...0 and 1, excluding the endpoints.
37656
37657**sr renamed for use of internal dpmjet3 random number generator
37658 FUNCTION XPYR(IDUMMY)
37659**
37660
37661C...Double precision and integer declarations.
37662 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37663 INTEGER PYK,PYCHGE,PYCOMP
37664C...Commonblocks.
37665 COMMON/PYDATR/MRPY(6),RRPY(100)
37666 SAVE /PYDATR/
37667C...Equivalence between commonblock and local variables.
37668 EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
37669 &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
37670 &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
37671
37672C...Initialize generation from given seed.
37673 IF(MRPY2.EQ.0) THEN
37674 IJ=MOD(MRPY1/30082,31329)
37675 KL=MOD(MRPY1,30082)
37676 I=MOD(IJ/177,177)+2
37677 J=MOD(IJ,177)+2
37678 K=MOD(KL/169,178)+1
37679 L=MOD(KL,169)
37680 DO 110 II=1,97
37681 S=0D0
37682 T=0.5D0
37683 DO 100 JJ=1,48
37684 M=MOD(MOD(I*J,179)*K,179)
37685 I=J
37686 J=K
37687 K=M
37688 L=MOD(53*L+1,169)
37689 IF(MOD(L*M,64).GE.32) S=S+T
37690 T=0.5D0*T
37691 100 CONTINUE
37692 RRPY(II)=S
37693 110 CONTINUE
37694 TWOM24=1D0
37695 DO 120 I24=1,24
37696 TWOM24=0.5D0*TWOM24
37697 120 CONTINUE
37698 RRPY98=362436D0*TWOM24
37699 RRPY99=7654321D0*TWOM24
37700 RRPY00=16777213D0*TWOM24
37701 MRPY2=1
37702 MRPY3=0
37703 MRPY4=97
37704 MRPY5=33
37705 ENDIF
37706
37707C...Generate next random number.
37708 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
37709 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37710 RRPY(MRPY4)=RUNI
37711 MRPY4=MRPY4-1
37712 IF(MRPY4.EQ.0) MRPY4=97
37713 MRPY5=MRPY5-1
37714 IF(MRPY5.EQ.0) MRPY5=97
37715 RRPY98=RRPY98-RRPY99
37716 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
37717 RUNI=RUNI-RRPY98
37718 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37719 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
37720
37721C...Update counters. Random number to output.
37722 MRPY3=MRPY3+1
37723 IF(MRPY3.EQ.1000000000) THEN
37724 MRPY2=MRPY2+1
37725 MRPY3=0
37726 ENDIF
ad1d1bfc 37727 XPYR=RUNI
9aaba0d6 37728
37729 RETURN
37730 END
37731
37732C*********************************************************************
37733
37734*$ CREATE PYRGET.FOR
37735*COPY PYRGET
37736C...PYRGET
37737C...Dumps the state of the random number generator on a file
37738C...for subsequent startup from this state onwards.
37739
37740 SUBROUTINE PYRGET(LFN,MOVE)
37741
37742C...Double precision and integer declarations.
37743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37744 INTEGER PYK,PYCHGE,PYCOMP
37745C...Commonblocks.
37746 COMMON/PYDATR/MRPY(6),RRPY(100)
37747 SAVE /PYDATR/
37748C...Local character variable.
37749 CHARACTER CHERR*8
37750
37751C...Backspace required number of records (or as many as there are).
37752 IF(MOVE.LT.0) THEN
37753 NBCK=MIN(MRPY(6),-MOVE)
37754 DO 100 IBCK=1,NBCK
37755 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
37756 100 CONTINUE
37757 MRPY(6)=MRPY(6)-NBCK
37758 ENDIF
37759
37760C...Unformatted write on unit LFN.
37761 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37762 &(RRPY(I2),I2=1,100)
37763 MRPY(6)=MRPY(6)+1
37764 RETURN
37765
37766C...Write error.
37767 110 WRITE(CHERR,'(I8)') IERR
37768 CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
37769 &CHERR)
37770
37771 RETURN
37772 END
37773
37774C*********************************************************************
37775
37776*$ CREATE PYRSET.FOR
37777*COPY PYRSET
37778C...PYRSET
37779C...Reads a state of the random number generator from a file
37780C...for subsequent generation from this state onwards.
37781
37782 SUBROUTINE PYRSET(LFN,MOVE)
37783
37784C...Double precision and integer declarations.
37785 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37786 INTEGER PYK,PYCHGE,PYCOMP
37787C...Commonblocks.
37788 COMMON/PYDATR/MRPY(6),RRPY(100)
37789 SAVE /PYDATR/
37790C...Local character variable.
37791 CHARACTER CHERR*8
37792
37793C...Backspace required number of records (or as many as there are).
37794 IF(MOVE.LT.0) THEN
37795 NBCK=MIN(MRPY(6),-MOVE)
37796 DO 100 IBCK=1,NBCK
37797 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
37798 100 CONTINUE
37799 MRPY(6)=MRPY(6)-NBCK
37800 ENDIF
37801
37802C...Unformatted read from unit LFN.
37803 NFOR=1+MAX(0,MOVE)
37804 DO 110 IFOR=1,NFOR
37805 READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37806 & (RRPY(I2),I2=1,100)
37807 110 CONTINUE
37808 MRPY(6)=MRPY(6)+NFOR
37809 RETURN
37810
37811C...Write error.
37812 120 WRITE(CHERR,'(I8)') IERR
37813 CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
37814 &CHERR)
37815
37816 RETURN
37817 END
37818
37819C*********************************************************************
37820
37821*$ CREATE PYROBO.FOR
37822*COPY PYROBO
37823C...PYROBO
37824C...Performs rotations and boosts.
37825
37826 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
37827
37828C...Double precision and integer declarations.
37829 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37830 INTEGER PYK,PYCHGE,PYCOMP
37831C...Commonblocks.
37832 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37833 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37834 SAVE /PYJETS/,/PYDAT1/
37835C...Local arrays.
37836 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
37837
37838C...Find and check range of rotation/boost.
37839 IMIN=IMI
37840 IF(IMIN.LE.0) IMIN=1
37841 IF(MSTU(1).GT.0) IMIN=MSTU(1)
37842 IMAX=IMA
37843 IF(IMAX.LE.0) IMAX=N
37844 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37845 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
37846 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
37847 RETURN
37848 ENDIF
37849
37850C...Optional resetting of V (when not set before.)
37851 IF(MSTU(33).NE.0) THEN
37852 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
37853 DO 100 J=1,5
37854 V(I,J)=0D0
37855 100 CONTINUE
37856 110 CONTINUE
37857 MSTU(33)=0
37858 ENDIF
37859
37860C...Rotate, typically from z axis to direction (theta,phi).
37861 IF(THE**2+PHI**2.GT.1D-20) THEN
37862 ROT(1,1)=COS(THE)*COS(PHI)
37863 ROT(1,2)=-SIN(PHI)
37864 ROT(1,3)=SIN(THE)*COS(PHI)
37865 ROT(2,1)=COS(THE)*SIN(PHI)
37866 ROT(2,2)=COS(PHI)
37867 ROT(2,3)=SIN(THE)*SIN(PHI)
37868 ROT(3,1)=-SIN(THE)
37869 ROT(3,2)=0D0
37870 ROT(3,3)=COS(THE)
37871 DO 140 I=IMIN,IMAX
37872 IF(K(I,1).LE.0) GOTO 140
37873 DO 120 J=1,3
37874 PR(J)=P(I,J)
37875 VR(J)=V(I,J)
37876 120 CONTINUE
37877 DO 130 J=1,3
37878 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
37879 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
37880 130 CONTINUE
37881 140 CONTINUE
37882 ENDIF
37883
37884C...Boost, typically from rest to momentum/energy=beta.
37885 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
37886 DBX=BEX
37887 DBY=BEY
37888 DBZ=BEZ
37889 DB=SQRT(DBX**2+DBY**2+DBZ**2)
37890 EPS1=1D0-1D-12
37891 IF(DB.GT.EPS1) THEN
37892C...Rescale boost vector if too close to unity.
37893 CALL PYERRM(3,'(PYROBO:) boost vector too large')
37894 DBX=DBX*(EPS1/DB)
37895 DBY=DBY*(EPS1/DB)
37896 DBZ=DBZ*(EPS1/DB)
37897 DB=EPS1
37898 ENDIF
37899 DGA=1D0/SQRT(1D0-DB**2)
37900 DO 160 I=IMIN,IMAX
37901 IF(K(I,1).LE.0) GOTO 160
37902 DO 150 J=1,4
37903 DP(J)=P(I,J)
37904 DV(J)=V(I,J)
37905 150 CONTINUE
37906 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
37907 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
37908 P(I,1)=DP(1)+DGABP*DBX
37909 P(I,2)=DP(2)+DGABP*DBY
37910 P(I,3)=DP(3)+DGABP*DBZ
37911 P(I,4)=DGA*(DP(4)+DBP)
37912 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
37913 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
37914 V(I,1)=DV(1)+DGABV*DBX
37915 V(I,2)=DV(2)+DGABV*DBY
37916 V(I,3)=DV(3)+DGABV*DBZ
37917 V(I,4)=DGA*(DV(4)+DBV)
37918 160 CONTINUE
37919 ENDIF
37920
37921 RETURN
37922 END
37923
37924C*********************************************************************
37925
37926*$ CREATE PYEDIT.FOR
37927*COPY PYEDIT
37928C...PYEDIT
37929C...Performs global manipulations on the event record, in particular
37930C...to exclude unstable or undetectable partons/particles.
37931
37932 SUBROUTINE PYEDIT(MEDIT)
37933
37934C...Double precision and integer declarations.
37935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37936 INTEGER PYK,PYCHGE,PYCOMP
37937C...Commonblocks.
37938 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37939 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37940 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37941 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37942C...Local arrays.
37943 DIMENSION NS(2),PTS(2),PLS(2)
37944
37945C...Remove unwanted partons/particles.
37946 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
37947 IMAX=N
37948 IF(MSTU(2).GT.0) IMAX=MSTU(2)
37949 I1=MAX(1,MSTU(1))-1
37950 DO 110 I=MAX(1,MSTU(1)),IMAX
37951 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
37952 IF(MEDIT.EQ.1) THEN
37953 IF(K(I,1).GT.10) GOTO 110
37954 ELSEIF(MEDIT.EQ.2) THEN
37955 IF(K(I,1).GT.10) GOTO 110
37956 KC=PYCOMP(K(I,2))
37957 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
37958 & GOTO 110
37959 ELSEIF(MEDIT.EQ.3) THEN
37960 IF(K(I,1).GT.10) GOTO 110
37961 KC=PYCOMP(K(I,2))
37962 IF(KC.EQ.0) GOTO 110
37963 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
37964 ELSEIF(MEDIT.EQ.5) THEN
37965 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
37966 KC=PYCOMP(K(I,2))
37967 IF(KC.EQ.0) GOTO 110
37968 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
37969 ENDIF
37970
37971C...Pack remaining partons/particles. Origin no longer known.
37972 I1=I1+1
37973 DO 100 J=1,5
37974 K(I1,J)=K(I,J)
37975 P(I1,J)=P(I,J)
37976 V(I1,J)=V(I,J)
37977 100 CONTINUE
37978 K(I1,3)=0
37979 110 CONTINUE
37980 IF(I1.LT.N) MSTU(3)=0
37981 IF(I1.LT.N) MSTU(70)=0
37982 N=I1
37983
37984C...Selective removal of class of entries. New position of retained.
37985 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
37986 I1=0
37987 DO 120 I=1,N
37988 K(I,3)=MOD(K(I,3),MSTU(5))
37989 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
37990 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
37991 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
37992 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
37993 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
37994 & K(I,2).EQ.94)) GOTO 120
37995 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
37996 I1=I1+1
37997 K(I,3)=K(I,3)+MSTU(5)*I1
37998 120 CONTINUE
37999
38000C...Find new event history information and replace old.
38001 DO 140 I=1,N
38002 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
38003 & GOTO 140
38004 ID=I
38005 130 IM=MOD(K(ID,3),MSTU(5))
38006 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
38007 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
38008 & K(IM,2).NE.94) THEN
38009 ID=IM
38010 GOTO 130
38011 ENDIF
38012 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
38013 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
38014 ID=IM
38015 GOTO 130
38016 ENDIF
38017 ENDIF
38018 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
38019 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
38020 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
38021 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
38022 & K(K(I,4),3)/MSTU(5)
38023 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
38024 & K(K(I,5),3)/MSTU(5)
38025 ELSE
38026 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
38027 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
38028 KCD=MOD(K(I,4),MSTU(5))
38029 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
38030 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
38031 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
38032 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
38033 KCD=MOD(K(I,5),MSTU(5))
38034 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
38035 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
38036 ENDIF
38037 140 CONTINUE
38038
38039C...Pack remaining entries.
38040 I1=0
38041 MSTU90=MSTU(90)
38042 MSTU(90)=0
38043 DO 170 I=1,N
38044 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
38045 I1=I1+1
38046 DO 150 J=1,5
38047 K(I1,J)=K(I,J)
38048 P(I1,J)=P(I,J)
38049 V(I1,J)=V(I,J)
38050 150 CONTINUE
38051 K(I1,3)=MOD(K(I1,3),MSTU(5))
38052 DO 160 IZ=1,MSTU90
38053 IF(I.EQ.MSTU(90+IZ)) THEN
38054 MSTU(90)=MSTU(90)+1
38055 MSTU(90+MSTU(90))=I1
38056 PARU(90+MSTU(90))=PARU(90+IZ)
38057 ENDIF
38058 160 CONTINUE
38059 170 CONTINUE
38060 IF(I1.LT.N) MSTU(3)=0
38061 IF(I1.LT.N) MSTU(70)=0
38062 N=I1
38063
38064C...Fill in some missing daughter pointers (lost in colour flow).
38065 ELSEIF(MEDIT.EQ.16) THEN
38066 DO 220 I=1,N
38067 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
38068 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
38069C...Find daughters who point to mother.
38070 DO 180 I1=I+1,N
38071 IF(K(I1,3).NE.I) THEN
38072 ELSEIF(K(I,4).EQ.0) THEN
38073 K(I,4)=I1
38074 ELSE
38075 K(I,5)=I1
38076 ENDIF
38077 180 CONTINUE
38078 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38079 IF(K(I,4).NE.0) GOTO 220
38080C...Find daughters who point to documentation version of mother.
38081 IM=K(I,3)
38082 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
38083 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
38084 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
38085 DO 190 I1=I+1,N
38086 IF(K(I1,3).NE.IM) THEN
38087 ELSEIF(K(I,4).EQ.0) THEN
38088 K(I,4)=I1
38089 ELSE
38090 K(I,5)=I1
38091 ENDIF
38092 190 CONTINUE
38093 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38094 IF(K(I,4).NE.0) GOTO 220
38095C...Find daughters who point to documentation daughters who,
38096C...in their turn, point to documentation mother.
38097 ID1=IM
38098 ID2=IM
38099 DO 200 I1=IM+1,I-1
38100 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
38101 ID2=I1
38102 IF(ID1.EQ.IM) ID1=I1
38103 ENDIF
38104 200 CONTINUE
38105 DO 210 I1=I+1,N
38106 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
38107 ELSEIF(K(I,4).EQ.0) THEN
38108 K(I,4)=I1
38109 ELSE
38110 K(I,5)=I1
38111 ENDIF
38112 210 CONTINUE
38113 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38114 220 CONTINUE
38115
38116C...Save top entries at bottom of PYJETS commonblock.
38117 ELSEIF(MEDIT.EQ.21) THEN
38118 IF(2*N.GE.MSTU(4)) THEN
38119 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
38120 RETURN
38121 ENDIF
38122 DO 240 I=1,N
38123 DO 230 J=1,5
38124 K(MSTU(4)-I,J)=K(I,J)
38125 P(MSTU(4)-I,J)=P(I,J)
38126 V(MSTU(4)-I,J)=V(I,J)
38127 230 CONTINUE
38128 240 CONTINUE
38129 MSTU(32)=N
38130
38131C...Restore bottom entries of commonblock PYJETS to top.
38132 ELSEIF(MEDIT.EQ.22) THEN
38133 DO 260 I=1,MSTU(32)
38134 DO 250 J=1,5
38135 K(I,J)=K(MSTU(4)-I,J)
38136 P(I,J)=P(MSTU(4)-I,J)
38137 V(I,J)=V(MSTU(4)-I,J)
38138 250 CONTINUE
38139 260 CONTINUE
38140 N=MSTU(32)
38141
38142C...Mark primary entries at top of commonblock PYJETS as untreated.
38143 ELSEIF(MEDIT.EQ.23) THEN
38144 I1=0
38145 DO 270 I=1,N
38146 KH=K(I,3)
38147 IF(KH.GE.1) THEN
38148 IF(K(KH,1).GT.20) KH=0
38149 ENDIF
38150 IF(KH.NE.0) GOTO 280
38151 I1=I1+1
38152 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
38153 270 CONTINUE
38154 280 N=I1
38155
38156C...Place largest axis along z axis and second largest in xy plane.
38157 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
38158 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
38159 & P(MSTU(61),2)),0D0,0D0,0D0)
38160 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
38161 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
38162 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
38163 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
38164 IF(MEDIT.EQ.31) RETURN
38165
38166C...Rotate to put slim jet along +z axis.
38167 DO 290 IS=1,2
38168 NS(IS)=0
38169 PTS(IS)=0D0
38170 PLS(IS)=0D0
38171 290 CONTINUE
38172 DO 300 I=1,N
38173 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
38174 IF(MSTU(41).GE.2) THEN
38175 KC=PYCOMP(K(I,2))
38176 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
38177 & KC.EQ.18) GOTO 300
38178 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
38179 & .EQ.0) GOTO 300
38180 ENDIF
38181 IS=2D0-SIGN(0.5D0,P(I,3))
38182 NS(IS)=NS(IS)+1
38183 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
38184 300 CONTINUE
38185 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
38186 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
38187
38188C...Rotate to put second largest jet into -z,+x quadrant.
38189 DO 310 I=1,N
38190 IF(P(I,3).GE.0D0) GOTO 310
38191 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
38192 IF(MSTU(41).GE.2) THEN
38193 KC=PYCOMP(K(I,2))
38194 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
38195 & KC.EQ.18) GOTO 310
38196 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
38197 & .EQ.0) GOTO 310
38198 ENDIF
38199 IS=2D0-SIGN(0.5D0,P(I,1))
38200 PLS(IS)=PLS(IS)-P(I,3)
38201 310 CONTINUE
38202 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
38203 & 0D0,0D0,0D0)
38204 ENDIF
38205
38206 RETURN
38207 END
38208
38209C*********************************************************************
38210
38211*$ CREATE PYLIST.FOR
38212*COPY PYLIST
38213C...PYLIST
38214C...Gives program heading, or lists an event, or particle
38215C...data, or current parameter values.
38216
38217 SUBROUTINE PYLIST(MLIST)
38218
38219C...Double precision and integer declarations.
38220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38221 INTEGER PYK,PYCHGE,PYCOMP
38222C...Parameter statement to help give large particle numbers.
38223 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
38224C...Commonblocks.
38225 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38226 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38227 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38228 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38229 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
38230C...Local arrays, character variables and data.
38231 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
38232 DIMENSION PS(6)
38233 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
38234
38235C...Initialization printout: version number and date of last change.
38236 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
38237 CALL PYLOGO
38238 MSTU(12)=0
38239 IF(MLIST.EQ.0) RETURN
38240 ENDIF
38241
38242C...List event data, including additional lines after N.
38243 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
38244 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
38245 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
38246 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
38247 LMX=12
38248 IF(MLIST.GE.2) LMX=16
38249 ISTR=0
38250 IMAX=N
38251 IF(MSTU(2).GT.0) IMAX=MSTU(2)
38252 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
38253 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
38254
38255C...Get particle name, pad it and check it is not too long.
38256 CALL PYNAME(K(I,2),CHAP)
38257 LEN=0
38258 DO 100 LEM=1,16
38259 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
38260 100 CONTINUE
38261 MDL=(K(I,1)+19)/10
38262 LDL=0
38263 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
38264 CHAC=CHAP
38265 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
38266 ELSE
38267 LDL=1
38268 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
38269 IF(LEN.EQ.0) THEN
38270 CHAC=CHDL(MDL)(1:2*LDL)//' '
38271 ELSE
38272 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
38273 & CHDL(MDL)(LDL+1:2*LDL)//' '
38274 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
38275 ENDIF
38276 ENDIF
38277
38278C...Add information on string connection.
38279 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
38280 & THEN
38281 KC=PYCOMP(K(I,2))
38282 KCC=0
38283 IF(KC.NE.0) KCC=KCHG(KC,2)
38284 IF(IABS(K(I,2)).EQ.39) THEN
38285 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
38286 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
38287 ISTR=1
38288 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
38289 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
38290 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
38291 ELSEIF(KCC.NE.0) THEN
38292 ISTR=0
38293 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
38294 ENDIF
38295 ENDIF
38296
38297C...Write data for particle/jet.
38298 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
38299 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
38300 & (P(I,J2),J2=1,5)
38301 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
38302 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
38303 & (P(I,J2),J2=1,5)
38304 ELSEIF(MLIST.EQ.1) THEN
38305 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
38306 & (P(I,J2),J2=1,5)
38307 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
38308 & K(I,1).EQ.14)) THEN
38309 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
38310 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
38311 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
38312 & (P(I,J2),J2=1,5)
38313 ELSE
38314 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
38315 & (P(I,J2),J2=1,5)
38316 ENDIF
38317 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
38318
38319C...Insert extra separator lines specified by user.
38320 IF(MSTU(70).GE.1) THEN
38321 ISEP=0
38322 DO 110 J=1,MIN(10,MSTU(70))
38323 IF(I.EQ.MSTU(70+J)) ISEP=1
38324 110 CONTINUE
38325 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
38326 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
38327 ENDIF
38328 120 CONTINUE
38329
38330C...Sum of charges and momenta.
38331 DO 130 J=1,6
38332 PS(J)=PYP(0,J)
38333 130 CONTINUE
38334 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
38335 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
38336 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
38337 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
38338 ELSEIF(MLIST.EQ.1) THEN
38339 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
38340 ELSE
38341 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
38342 ENDIF
38343
38344C...Give simple list of KF codes defined in program.
38345 ELSEIF(MLIST.EQ.11) THEN
38346 WRITE(MSTU(11),6600)
38347 DO 140 KF=1,80
38348 CALL PYNAME(KF,CHAP)
38349 CALL PYNAME(-KF,CHAN)
38350 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38351 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38352 140 CONTINUE
38353 DO 170 KFLS=1,3,2
38354 DO 160 KFLA=1,5
38355 DO 150 KFLB=1,KFLA-(3-KFLS)/2
38356 KF=1000*KFLA+100*KFLB+KFLS
38357 CALL PYNAME(KF,CHAP)
38358 CALL PYNAME(-KF,CHAN)
38359 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38360 150 CONTINUE
38361 160 CONTINUE
38362 170 CONTINUE
38363 KF=130
38364 CALL PYNAME(KF,CHAP)
38365 WRITE(MSTU(11),6700) KF,CHAP
38366 KF=310
38367 CALL PYNAME(KF,CHAP)
38368 WRITE(MSTU(11),6700) KF,CHAP
38369 DO 200 KMUL=0,5
38370 KFLS=3
38371 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
38372 IF(KMUL.EQ.5) KFLS=5
38373 KFLR=0
38374 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
38375 IF(KMUL.EQ.4) KFLR=2
38376 DO 190 KFLB=1,5
38377 DO 180 KFLC=1,KFLB-1
38378 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
38379 CALL PYNAME(KF,CHAP)
38380 CALL PYNAME(-KF,CHAN)
38381 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38382 180 CONTINUE
38383 KF=10000*KFLR+110*KFLB+KFLS
38384 CALL PYNAME(KF,CHAP)
38385 WRITE(MSTU(11),6700) KF,CHAP
38386 190 CONTINUE
38387 200 CONTINUE
38388 KF=100443
38389 CALL PYNAME(KF,CHAP)
38390 WRITE(MSTU(11),6700) KF,CHAP
38391 KF=100553
38392 CALL PYNAME(KF,CHAP)
38393 WRITE(MSTU(11),6700) KF,CHAP
38394 DO 240 KFLSP=1,3
38395 KFLS=2+2*(KFLSP/3)
38396 DO 230 KFLA=1,5
38397 DO 220 KFLB=1,KFLA
38398 DO 210 KFLC=1,KFLB
38399 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
38400 & GOTO 210
38401 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
38402 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
38403 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
38404 CALL PYNAME(KF,CHAP)
38405 CALL PYNAME(-KF,CHAN)
38406 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38407 210 CONTINUE
38408 220 CONTINUE
38409 230 CONTINUE
38410 240 CONTINUE
38411 DO 250 KF=KSUSY1+1,KSUSY1+40
38412 CALL PYNAME(KF,CHAP)
38413 CALL PYNAME(-KF,CHAN)
38414 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38415 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38416 250 CONTINUE
38417 DO 260 KF=KSUSY2+1,KSUSY2+40
38418 CALL PYNAME(KF,CHAP)
38419 CALL PYNAME(-KF,CHAN)
38420 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38421 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38422 260 CONTINUE
38423 DO 270 KF=KEXCIT+1,KEXCIT+40
38424 CALL PYNAME(KF,CHAP)
38425 CALL PYNAME(-KF,CHAN)
38426 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38427 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38428 270 CONTINUE
38429
38430C...List parton/particle data table. Check whether to be listed.
38431 ELSEIF(MLIST.EQ.12) THEN
38432 WRITE(MSTU(11),6800)
38433 DO 300 KC=1,MSTU(6)
38434 KF=KCHG(KC,4)
38435 IF(KF.EQ.0) GOTO 300
38436 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
38437 & GOTO 300
38438
38439C...Find particle name and mass. Print information.
38440 CALL PYNAME(KF,CHAP)
38441 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
38442 CALL PYNAME(-KF,CHAN)
38443 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
38444 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
38445
38446C...Particle decay: channel number, branching ratios, matrix element,
38447C...decay products.
38448 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38449 DO 280 J=1,5
38450 CALL PYNAME(KFDP(IDC,J),CHAD(J))
38451 280 CONTINUE
38452 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38453 & (CHAD(J),J=1,5)
38454 290 CONTINUE
38455 300 CONTINUE
38456
38457C...List parameter value table.
38458 ELSEIF(MLIST.EQ.13) THEN
38459 WRITE(MSTU(11),7100)
38460 DO 310 I=1,200
38461 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
38462 310 CONTINUE
38463 ENDIF
38464
38465C...Format statements for output on unit MSTU(11) (by default 6).
38466 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
38467 &5X,'KF orig p_x p_y p_z E m'/)
38468 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
38469 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38470 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
38471 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
38472 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
38473 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
38474 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
38475 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
38476 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
38477 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
38478 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
38479 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
38480 5900 FORMAT(66X,5(1X,F12.3))
38481 6000 FORMAT(1X,78('='))
38482 6100 FORMAT(1X,130('='))
38483 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
38484 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
38485 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
38486 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
38487 &5F13.5)
38488 6600 FORMAT(///20X,'List of KF codes in program'/)
38489 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
38490 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
38491 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
38492 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
38493 &1X,'ME',3X,'Br.rat.',4X,'decay products')
38494 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
38495 &1X,1P,E13.5,3X,I2)
38496 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
38497 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
38498 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
38499 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
38500
38501 RETURN
38502 END
38503
38504C*********************************************************************
38505
38506*$ CREATE PYLOGO.FOR
38507*COPY PYLOGO
38508C...PYLOGO
38509C...Writes a logo for the program.
38510
38511 SUBROUTINE PYLOGO
38512
38513C...Double precision and integer declarations.
38514 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38515 INTEGER PYK,PYCHGE,PYCOMP
38516C...Parameter for length of information block.
38517 PARAMETER (IREFER=17)
38518C...Commonblocks.
38519 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38520 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38521 SAVE /PYDAT1/,/PYPARS/
38522C...Local arrays and character variables.
38523 INTEGER IDATI(6)
38524 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
38525 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
38526
38527C...Data on months, logo, titles, and references.
38528 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
38529 &'Oct','Nov','Dec'/
38530 DATA (LOGO(J),J=1,19)/
38531 &' *......* ',
38532 &' *:::!!:::::::::::* ',
38533 &' *::::::!!::::::::::::::* ',
38534 &' *::::::::!!::::::::::::::::* ',
38535 &' *:::::::::!!:::::::::::::::::* ',
38536 &' *:::::::::!!:::::::::::::::::* ',
38537 &' *::::::::!!::::::::::::::::*! ',
38538 &' *::::::!!::::::::::::::* !! ',
38539 &' !! *:::!!:::::::::::* !! ',
38540 &' !! !* -><- * !! ',
38541 &' !! !! !! ',
38542 &' !! !! !! ',
38543 &' !! !! ',
38544 &' !! ep !! ',
38545 &' !! !! ',
38546 &' !! pp !! ',
38547 &' !! e+e- !! ',
38548 &' !! !! ',
38549 &' !! '/
38550 DATA (LOGO(J),J=20,38)/
38551 &'Welcome to the Lund Monte Carlo!',
38552 &' ',
38553 &'PPP Y Y TTTTT H H III A ',
38554 &'P P Y Y T H H I A A ',
38555 &'PPP Y T HHHHH I AAAAA',
38556 &'P Y T H H I A A',
38557 &'P Y T H H III A A',
38558 &' ',
38559 &'This is PYTHIA version x.xxx ',
38560 &'Last date of change: xx xxx 199x',
38561 &' ',
38562 &'Now is xx xxx 199x at xx:xx:xx ',
38563 &' ',
38564 &'Disclaimer: this program comes ',
38565 &'without any guarantees. Beware ',
38566 &'of errors and use common sense ',
38567 &'when interpreting results. ',
38568 &' ',
38569 &'Copyright T. Sjostrand (1997) '/
38570 DATA (REFER(J),J=1,18)/
38571 &'An archive of program versions and d',
38572 &'ocumentation is found on the web: ',
38573 &'http://www.thep.lu.se/tf2/staff/torb',
38574 &'jorn/Pythia.html ',
38575 &' ',
38576 &' ',
38577 &'When you cite this program, currentl',
38578 &'y the official reference is ',
38579 &'T. Sjostrand, Computer Physics Commu',
38580 &'n. 82 (1994) 74. ',
38581 &'The supersymmetry extensions are des',
38582 &'cribed in ',
38583 &'S. Mrenna, Computer Physics Commun. ',
38584 &'101 (1997) 232 ',
38585 &'Also remember that the program, to a',
38586 &' large extent, represents original ',
38587 &'physics research. Other publications',
38588 &' of special relevance to your '/
38589 DATA (REFER(J),J=19,2*IREFER)/
38590 &'studies may therefore deserve separa',
38591 &'te mention. ',
38592 &' ',
38593 &' ',
38594 &'Main author: Torbjorn Sjostrand; Dep',
38595 &'artment of Theoretical Physics 2, ',
38596 &' Lund University, Solvegatan 14A, S',
38597 &'-223 62 Lund, Sweden; ',
38598 &' phone: + 46 - 46 - 222 48 16; e-ma',
38599 &'il: torbjorn@thep.lu.se ',
38600 &'SUSY author: Stephen Mrenna, Argonne',
38601 &' National Laboratory, ',
38602 &' 9700 South Cass Avenue, Argonne, I',
38603 &'L 60439, USA; ',
38604 &' phone: + 1 - 630 - 252 - 7615; e-m',
38605 &'ail: mrenna@hep.anl.gov '/
38606
38607C...Check that PYDATA linked.
38608 IF(MSTP(183)/10.NE.199) THEN
38609 WRITE(MSTU(11),'(1X,A)')
38610 & 'Error: PYDATA has not been linked.'
38611 WRITE(MSTU(11),'(1X,A)') 'Execution stopped!'
38612 STOP
38613
38614C...Write current version number and current date+time.
38615 ELSE
38616 WRITE(VERS,'(I1)') MSTP(181)
38617 LOGO(28)(24:24)=VERS
38618 WRITE(SUBV,'(I3)') MSTP(182)
38619 LOGO(28)(26:28)=SUBV
38620 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
38621 WRITE(DATE,'(I2)') MSTP(185)
38622 LOGO(29)(22:23)=DATE
38623 LOGO(29)(25:27)=MONTH(MSTP(184))
38624 WRITE(YEAR,'(I4)') MSTP(183)
38625 LOGO(29)(29:32)=YEAR
38626 CALL PYTIME(IDATI)
38627 IF(IDATI(1).LE.0) THEN
38628 LOGO(31)=' '
38629 ELSE
38630 WRITE(DATE,'(I2)') IDATI(3)
38631 LOGO(31)(8:9)=DATE
38632 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
38633 WRITE(YEAR,'(I4)') IDATI(1)
38634 LOGO(31)(15:18)=YEAR
38635 WRITE(HOUR,'(I2)') IDATI(4)
38636 LOGO(31)(23:24)=HOUR
38637 WRITE(MINU,'(I2)') IDATI(5)
38638 LOGO(31)(26:27)=MINU
38639 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
38640 WRITE(SECO,'(I2)') IDATI(6)
38641 LOGO(31)(29:30)=SECO
38642 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
38643 ENDIF
38644 ENDIF
38645
38646C...Loop over lines in header. Define page feed and side borders.
38647 DO 100 ILIN=1,29+IREFER
38648 LINE=' '
38649 IF(ILIN.EQ.1) THEN
38650 LINE(1:1)='1'
38651 ELSE
38652 LINE(2:3)='**'
38653 LINE(78:79)='**'
38654 ENDIF
38655
38656C...Separator lines and logos.
38657 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
38658 LINE(4:77)='***********************************************'//
38659 & '***************************'
38660 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
38661 LINE(6:37)=LOGO(ILIN-5)
38662 LINE(44:75)=LOGO(ILIN+14)
38663 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
38664 LINE(5:40)=REFER(2*ILIN-51)
38665 LINE(41:76)=REFER(2*ILIN-50)
38666 ENDIF
38667
38668C...Write lines to appropriate unit.
38669 WRITE(MSTU(11),'(A79)') LINE
38670 100 CONTINUE
38671
38672 RETURN
38673 END
38674
38675C*********************************************************************
38676
38677*$ CREATE PYUPDA.FOR
38678*COPY PYUPDA
38679C...PYUPDA
38680C...Facilitates the updating of particle and decay data
38681C...by allowing it to be done in an external file.
38682
38683 SUBROUTINE PYUPDA(MUPDA,LFN)
38684
38685C...Double precision and integer declarations.
38686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38687 INTEGER PYK,PYCHGE,PYCOMP
38688C...Commonblocks.
38689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38690 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38691 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38692 COMMON/PYDAT4/CHAF(500,2)
38693 CHARACTER CHAF*16
38694 COMMON/PYINT4/MWID(500),WIDS(500,5)
38695 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
38696C...Local arrays, character variables and data.
38697 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
38698 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
38699 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
38700 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
38701 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
38702 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
38703 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
38704
38705C...Write header if not yet done.
38706 IF(MSTU(12).GE.1) CALL PYLIST(0)
38707
38708C...Write information on file for editing.
38709 IF(MUPDA.EQ.1) THEN
38710 DO 110 KC=1,500
38711 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38712 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38713 & MWID(KC),MDCY(KC,1)
38714 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38715 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38716 & (KFDP(IDC,J),J=1,5)
38717 100 CONTINUE
38718 110 CONTINUE
38719
38720C...Read complete set of information from edited file or
38721C...read partial set of new or updated information from edited file.
38722 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
38723
38724C...Reset counters.
38725 KCC=100
38726 NDC=0
38727 CHKF=' '
38728 IF(MUPDA.EQ.2) THEN
38729 DO 120 I=1,MSTU(6)
38730 KCHG(I,4)=0
38731 120 CONTINUE
38732 ELSE
38733 DO 130 KC=1,MSTU(6)
38734 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
38735 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
38736 130 CONTINUE
38737 ENDIF
38738
38739C...Begin of loop: read new line; unknown whether particle or
38740C...decay data.
38741 140 READ(LFN,5200,END=190) CHINL
38742
38743C...Identify particle code and whether already defined (for MUPDA=3).
38744 IF(CHINL(2:10).NE.' ') THEN
38745 CHKF=CHINL(2:10)
38746 READ(CHKF,5300) KF
38747 IF(MUPDA.EQ.2) THEN
38748 IF(KF.LE.100) THEN
38749 KC=KF
38750 ELSE
38751 KCC=KCC+1
38752 KC=KCC
38753 ENDIF
38754 ELSE
38755 KCREP=0
38756 IF(KF.LE.100) THEN
38757 KCREP=KF
38758 ELSE
38759 DO 150 KCR=101,KCC
38760 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
38761 150 CONTINUE
38762 ENDIF
38763C...Remove duplicate old decay data.
38764 IF(KCREP.NE.0) THEN
38765 IDCREP=MDCY(KCREP,2)
38766 NDCREP=MDCY(KCREP,3)
38767 DO 160 I=1,KCC
38768 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
38769 160 CONTINUE
38770 DO 180 I=IDCREP,NDC-NDCREP
38771 MDME(I,1)=MDME(I+NDCREP,1)
38772 MDME(I,2)=MDME(I+NDCREP,2)
38773 BRAT(I)=BRAT(I+NDCREP)
38774 DO 170 J=1,5
38775 KFDP(I,J)=KFDP(I+NDCREP,J)
38776 170 CONTINUE
38777 180 CONTINUE
38778 NDC=NDC-NDCREP
38779 KC=KCREP
38780 ELSE
38781 KCC=KCC+1
38782 KC=KCC
38783 ENDIF
38784 ENDIF
38785
38786C...Study line with particle data.
38787 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
38788 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
38789 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38790 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38791 & MWID(KC),MDCY(KC,1)
38792 MDCY(KC,2)=0
38793 MDCY(KC,3)=0
38794
38795C...Study line with decay data.
38796 ELSE
38797 NDC=NDC+1
38798 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
38799 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
38800 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
38801 MDCY(KC,3)=MDCY(KC,3)+1
38802 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
38803 & (KFDP(NDC,J),J=1,5)
38804 ENDIF
38805
38806C...End of loop; ensure that PYCOMP tables are updated.
38807 GOTO 140
38808 190 CONTINUE
38809 MSTU(20)=0
38810
38811C...Perform possible tests that new information is consistent.
38812 MSTJ24=MSTJ(24)
38813 MSTJ(24)=0
38814 DO 220 KC=1,MSTU(6)
38815 KF=KCHG(KC,4)
38816 IF(KF.EQ.0) GOTO 220
38817 WRITE(CHKF,5300) KF
38818 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
38819 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
38820 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
38821 BRSUM=0D0
38822 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38823 IF(MDME(IDC,2).GT.80) GOTO 210
38824 KQ=KCHG(KC,1)
38825 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
38826 MERR=0
38827 DO 200 J=1,5
38828 KP=KFDP(IDC,J)
38829 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
38830 IF(KP.EQ.81) KQ=0
38831 ELSEIF(PYCOMP(KP).EQ.0) THEN
38832 MERR=3
38833 ELSE
38834 KQ=KQ-PYCHGE(KP)
38835 PMS=PMS-PYMASS(KP)
38836 KPC=PYCOMP(KP)
38837 PMS=PMS-PMAS(KPC,1)
38838 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
38839 & PMAS(KPC,3))
38840 ENDIF
38841 200 CONTINUE
38842 IF(KQ.NE.0) MERR=MAX(2,MERR)
38843 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
38844 & MERR=MAX(1,MERR)
38845 IF(MERR.EQ.3) CALL PYERRM(17,
38846 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
38847 IF(MERR.EQ.2) CALL PYERRM(17,
38848 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
38849 IF(MERR.EQ.1) CALL PYERRM(7,
38850 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
38851 BRSUM=BRSUM+BRAT(IDC)
38852 210 CONTINUE
38853 WRITE(CHTMP,5500) BRSUM
38854 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
38855 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
38856 & CHTMP(9:16)//' for KF ='//CHKF)
38857 220 CONTINUE
38858 MSTJ(24)=MSTJ24
38859
38860C...Write DATA statements for inclusion in program.
38861 ELSEIF(MUPDA.EQ.4) THEN
38862
38863C...Find out how many codes and decay channels are actually used.
38864 KCC=0
38865 NDC=0
38866 DO 230 I=1,MSTU(6)
38867 IF(KCHG(I,4).NE.0) THEN
38868 KCC=I
38869 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
38870 ENDIF
38871 230 CONTINUE
38872
38873C...Initialize writing of DATA statements for inclusion in program.
38874 DO 300 IVAR=1,22
38875 NDIM=MSTU(6)
38876 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
38877 NLIN=1
38878 CHLIN=' '
38879 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
38880 LLIN=35
38881 CHOLD='START'
38882
38883C...Loop through variables for conversion to characters.
38884 DO 280 IDIM=1,NDIM
38885 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
38886 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
38887 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
38888 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
38889 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
38890 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
38891 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
38892 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
38893 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
38894 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
38895 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
38896 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
38897 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
38898 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
38899 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
38900 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
38901 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
38902 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
38903 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
38904 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
38905 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
38906 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
38907
38908C...Replace variables beyond what is properly defined.
38909 IF(IVAR.LE.4) THEN
38910 IF(IDIM.GT.KCC) CHTMP=' 0'
38911 ELSEIF(IVAR.LE.8) THEN
38912 IF(IDIM.GT.KCC) CHTMP=' 0.0'
38913 ELSEIF(IVAR.LE.11) THEN
38914 IF(IDIM.GT.KCC) CHTMP=' 0'
38915 ELSEIF(IVAR.LE.13) THEN
38916 IF(IDIM.GT.NDC) CHTMP=' 0'
38917 ELSEIF(IVAR.LE.14) THEN
38918 IF(IDIM.GT.NDC) CHTMP=' 0.0'
38919 ELSEIF(IVAR.LE.19) THEN
38920 IF(IDIM.GT.NDC) CHTMP=' 0'
38921 ELSEIF(IVAR.LE.21) THEN
38922 IF(IDIM.GT.KCC) CHTMP=' '
38923 ELSE
38924 IF(IDIM.GT.KCC) CHTMP=' 0'
38925 ENDIF
38926
38927C...Length of variable, trailing decimal zeros, quotation marks.
38928 LLOW=1
38929 LHIG=1
38930 DO 240 LL=1,16
38931 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
38932 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
38933 240 CONTINUE
38934 CHNEW=CHTMP(LLOW:LHIG)//' '
38935 LNEW=1+LHIG-LLOW
38936 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
38937 LNEW=LNEW+1
38938 250 LNEW=LNEW-1
38939 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
38940 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
38941 IF(LNEW.EQ.0) THEN
38942 CHNEW(1:3)='0D0'
38943 LNEW=3
38944 ELSE
38945 CHNEW(LNEW+1:LNEW+2)='D0'
38946 LNEW=LNEW+2
38947 ENDIF
38948 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
38949 DO 260 LL=LNEW,1,-1
38950 IF(CHNEW(LL:LL).EQ.'''') THEN
38951 CHTMP=CHNEW
38952 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
38953 LNEW=LNEW+1
38954 ENDIF
38955 260 CONTINUE
38956 LNEW=MIN(14,LNEW)
38957 CHTMP=CHNEW
38958 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
38959 LNEW=LNEW+2
38960 ENDIF
38961
38962C...Form composite character string, often including repetition counter.
38963 IF(CHNEW.NE.CHOLD) THEN
38964 NRPT=1
38965 CHOLD=CHNEW
38966 CHCOM=CHNEW
38967 LCOM=LNEW
38968 ELSE
38969 LRPT=LNEW+1
38970 IF(NRPT.GE.2) LRPT=LNEW+3
38971 IF(NRPT.GE.10) LRPT=LNEW+4
38972 IF(NRPT.GE.100) LRPT=LNEW+5
38973 IF(NRPT.GE.1000) LRPT=LNEW+6
38974 LLIN=LLIN-LRPT
38975 NRPT=NRPT+1
38976 WRITE(CHTMP,5400) NRPT
38977 LRPT=1
38978 IF(NRPT.GE.10) LRPT=2
38979 IF(NRPT.GE.100) LRPT=3
38980 IF(NRPT.GE.1000) LRPT=4
38981 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
38982 LCOM=LRPT+1+LNEW
38983 ENDIF
38984
38985C...Add characters to end of line, to new line (after storing old line),
38986C...or to new block of lines (after writing old block).
38987 IF(LLIN+LCOM.LE.70) THEN
38988 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
38989 LLIN=LLIN+LCOM+1
38990 ELSEIF(NLIN.LE.19) THEN
38991 CHLIN(LLIN+1:72)=' '
38992 CHBLK(NLIN)=CHLIN
38993 NLIN=NLIN+1
38994 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
38995 LLIN=6+LCOM+1
38996 ELSE
38997 CHLIN(LLIN:72)='/'//' '
38998 CHBLK(NLIN)=CHLIN
38999 WRITE(CHTMP,5400) IDIM-NRPT
39000 CHBLK(1)(30:33)=CHTMP(13:16)
39001 DO 270 ILIN=1,NLIN
39002 WRITE(LFN,5700) CHBLK(ILIN)
39003 270 CONTINUE
39004 NLIN=1
39005 CHLIN=' '
39006 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
39007 & ',I= , )/'//CHCOM(1:LCOM)//','
39008 WRITE(CHTMP,5400) IDIM-NRPT+1
39009 CHLIN(25:28)=CHTMP(13:16)
39010 LLIN=35+LCOM+1
39011 ENDIF
39012 280 CONTINUE
39013
39014C...Write final block of lines.
39015 CHLIN(LLIN:72)='/'//' '
39016 CHBLK(NLIN)=CHLIN
39017 WRITE(CHTMP,5400) NDIM
39018 CHBLK(1)(30:33)=CHTMP(13:16)
39019 DO 290 ILIN=1,NLIN
39020 WRITE(LFN,5700) CHBLK(ILIN)
39021 290 CONTINUE
39022 300 CONTINUE
39023 ENDIF
39024
39025C...Formats for reading and writing particle data.
39026 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
39027 5100 FORMAT(10X,2I5,F12.6,5I10)
39028 5200 FORMAT(A120)
39029 5300 FORMAT(I9)
39030 5400 FORMAT(I16)
39031 5500 FORMAT(F16.5)
39032 5600 FORMAT(F16.6)
39033 5700 FORMAT(A72)
39034
39035 RETURN
39036 END
39037
39038C*********************************************************************
39039
39040*$ CREATE PYK.FOR
39041*COPY PYK
39042C...PYK
39043C...Provides various integer-valued event related data.
39044
39045 FUNCTION PYK(I,J)
39046
39047C...Double precision and integer declarations.
39048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39049 INTEGER PYK,PYCHGE,PYCOMP
39050C...Commonblocks.
39051 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39052 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39053 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39054 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39055
39056C...Default value. For I=0 number of entries, number of stable entries
39057C...or 3 times total charge.
39058 PYK=0
39059 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
39060 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
39061 PYK=N
39062 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
39063 DO 100 I1=1,N
39064 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
39065 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
39066 & PYCHGE(K(I1,2))
39067 100 CONTINUE
39068 ELSEIF(I.EQ.0) THEN
39069
39070C...For I > 0 direct readout of K matrix or charge.
39071 ELSEIF(J.LE.5) THEN
39072 PYK=K(I,J)
39073 ELSEIF(J.EQ.6) THEN
39074 PYK=PYCHGE(K(I,2))
39075
39076C...Status (existing/fragmented/decayed), parton/hadron separation.
39077 ELSEIF(J.LE.8) THEN
39078 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
39079 IF(J.EQ.8) PYK=PYK*K(I,2)
39080 ELSEIF(J.LE.12) THEN
39081 KFA=IABS(K(I,2))
39082 KC=PYCOMP(KFA)
39083 KQ=0
39084 IF(KC.NE.0) KQ=KCHG(KC,2)
39085 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
39086 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
39087 IF(J.EQ.11) PYK=KC
39088 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
39089
39090C...Heaviest flavour in hadron/diquark.
39091 ELSEIF(J.EQ.13) THEN
39092 KFA=IABS(K(I,2))
39093 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
39094 IF(KFA.LT.10) PYK=KFA
39095 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
39096 PYK=PYK*ISIGN(1,K(I,2))
39097
39098C...Particle history: generation, ancestor, rank.
39099 ELSEIF(J.LE.15) THEN
39100 I2=I
39101 I1=I
39102 110 PYK=PYK+1
39103 I2=I1
39104 I1=K(I1,3)
39105 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
39106 IF(J.EQ.15) PYK=I2
39107 ELSEIF(J.EQ.16) THEN
39108 KFA=IABS(K(I,2))
39109 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
39110 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
39111 I1=I
39112 120 I2=I1
39113 I1=K(I1,3)
39114 IF(I1.GT.0) THEN
39115 KFAM=IABS(K(I1,2))
39116 ILP=1
39117 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
39118 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
39119 & ILP=0
39120 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
39121 IF(ILP.EQ.1) GOTO 120
39122 ENDIF
39123 IF(K(I1,1).EQ.12) THEN
39124 DO 130 I3=I1+1,I2
39125 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
39126 & .AND.K(I3,2).NE.93) PYK=PYK+1
39127 130 CONTINUE
39128 ELSE
39129 I3=I2
39130 140 PYK=PYK+1
39131 I3=I3+1
39132 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
39133 ENDIF
39134 ENDIF
39135
39136C...Particle coming from collapsing jet system or not.
39137 ELSEIF(J.EQ.17) THEN
39138 I1=I
39139 150 PYK=PYK+1
39140 I3=I1
39141 I1=K(I1,3)
39142 I0=MAX(1,I1)
39143 KC=PYCOMP(K(I0,2))
39144 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
39145 IF(PYK.EQ.1) PYK=-1
39146 IF(PYK.GT.1) PYK=0
39147 RETURN
39148 ENDIF
39149 IF(KCHG(KC,2).EQ.0) GOTO 150
39150 IF(K(I1,1).NE.12) PYK=0
39151 IF(K(I1,1).NE.12) RETURN
39152 I2=I1
39153 160 I2=I2+1
39154 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
39155 K3M=K(I3-1,3)
39156 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
39157 K3P=K(I3+1,3)
39158 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
39159
39160C...Number of decay products. Colour flow.
39161 ELSEIF(J.EQ.18) THEN
39162 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
39163 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
39164 ELSEIF(J.LE.22) THEN
39165 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
39166 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
39167 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
39168 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
39169 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
39170 ELSE
39171 ENDIF
39172
39173 RETURN
39174 END
39175
39176C*********************************************************************
39177
39178*$ CREATE PYP.FOR
39179*COPY PYP
39180C...PYP
39181C...Provides various real-valued event related data.
39182
39183 FUNCTION PYP(I,J)
39184
39185C...Double precision and integer declarations.
39186 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39187 INTEGER PYK,PYCHGE,PYCOMP
39188C...Commonblocks.
39189 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39190 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39191 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39192 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39193C...Local array.
39194 DIMENSION PSUM(4)
39195
39196C...Set default value. For I = 0 sum of momenta or charges,
39197C...or invariant mass of system.
39198 PYP=0D0
39199 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
39200 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
39201 DO 100 I1=1,N
39202 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
39203 100 CONTINUE
39204 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
39205 DO 120 J1=1,4
39206 PSUM(J1)=0D0
39207 DO 110 I1=1,N
39208 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
39209 & P(I1,J1)
39210 110 CONTINUE
39211 120 CONTINUE
39212 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
39213 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
39214 DO 130 I1=1,N
39215 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
39216 130 CONTINUE
39217 ELSEIF(I.EQ.0) THEN
39218
39219C...Direct readout of P matrix.
39220 ELSEIF(J.LE.5) THEN
39221 PYP=P(I,J)
39222
39223C...Charge, total momentum, transverse momentum, transverse mass.
39224 ELSEIF(J.LE.12) THEN
39225 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
39226 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
39227 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
39228 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
39229 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
39230
39231C...Theta and phi angle in radians or degrees.
39232 ELSEIF(J.LE.16) THEN
39233 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
39234 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
39235 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
39236
39237C...True rapidity, rapidity with pion mass, pseudorapidity.
39238 ELSEIF(J.LE.19) THEN
39239 PMR=0D0
39240 IF(J.EQ.17) PMR=P(I,5)
39241 IF(J.EQ.18) PMR=PYMASS(211)
39242 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
39243 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
39244 & 1D20)),P(I,3))
39245
39246C...Energy and momentum fractions (only to be used in CM frame).
39247 ELSEIF(J.LE.25) THEN
39248 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
39249 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
39250 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
39251 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
39252 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
39253 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
39254 ENDIF
39255
39256 RETURN
39257 END
39258
39259C*********************************************************************
39260
39261*$ CREATE PYSPHE.FOR
39262*COPY PYSPHE
39263C...PYSPHE
39264C...Performs sphericity tensor analysis to give sphericity,
39265C...aplanarity and the related event axes.
39266
39267 SUBROUTINE PYSPHE(SPH,APL)
39268
39269C...Double precision and integer declarations.
39270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39271 INTEGER PYK,PYCHGE,PYCOMP
39272C...Commonblocks.
39273 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39276 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39277C...Local arrays.
39278 DIMENSION SM(3,3),SV(3,3)
39279
39280C...Calculate matrix to be diagonalized.
39281 NP=0
39282 DO 110 J1=1,3
39283 DO 100 J2=J1,3
39284 SM(J1,J2)=0D0
39285 100 CONTINUE
39286 110 CONTINUE
39287 PS=0D0
39288 DO 140 I=1,N
39289 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39290 IF(MSTU(41).GE.2) THEN
39291 KC=PYCOMP(K(I,2))
39292 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39293 & KC.EQ.18) GOTO 140
39294 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39295 & GOTO 140
39296 ENDIF
39297 NP=NP+1
39298 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39299 PWT=1D0
39300 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
39301 & MAX(1D-10,PA)**(PARU(41)-2D0)
39302 DO 130 J1=1,3
39303 DO 120 J2=J1,3
39304 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
39305 120 CONTINUE
39306 130 CONTINUE
39307 PS=PS+PWT*PA**2
39308 140 CONTINUE
39309
39310C...Very low multiplicities (0 or 1) not considered.
39311 IF(NP.LE.1) THEN
39312 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
39313 SPH=-1D0
39314 APL=-1D0
39315 RETURN
39316 ENDIF
39317 DO 160 J1=1,3
39318 DO 150 J2=J1,3
39319 SM(J1,J2)=SM(J1,J2)/PS
39320 150 CONTINUE
39321 160 CONTINUE
39322
39323C...Find eigenvalues to matrix (third degree equation).
39324 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
39325 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
39326 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
39327 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
39328 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
39329 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
39330 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
39331 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
39332 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
39333 IF(P(N+2,4).LT.1D-5) THEN
39334 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
39335 SPH=-1D0
39336 APL=-1D0
39337 RETURN
39338 ENDIF
39339
39340C...Find first and last eigenvector by solving equation system.
39341 DO 240 I=1,3,2
39342 DO 180 J1=1,3
39343 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
39344 DO 170 J2=J1+1,3
39345 SV(J1,J2)=SM(J1,J2)
39346 SV(J2,J1)=SM(J1,J2)
39347 170 CONTINUE
39348 180 CONTINUE
39349 SMAX=0D0
39350 DO 200 J1=1,3
39351 DO 190 J2=1,3
39352 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
39353 JA=J1
39354 JB=J2
39355 SMAX=ABS(SV(J1,J2))
39356 190 CONTINUE
39357 200 CONTINUE
39358 SMAX=0D0
39359 DO 220 J3=JA+1,JA+2
39360 J1=J3-3*((J3-1)/3)
39361 RL=SV(J1,JB)/SV(JA,JB)
39362 DO 210 J2=1,3
39363 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
39364 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
39365 JC=J1
39366 SMAX=ABS(SV(J1,J2))
39367 210 CONTINUE
39368 220 CONTINUE
39369 JB1=JB+1-3*(JB/3)
39370 JB2=JB+2-3*((JB+1)/3)
39371 P(N+I,JB1)=-SV(JC,JB2)
39372 P(N+I,JB2)=SV(JC,JB1)
39373 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
39374 & SV(JA,JB)
39375 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
39376 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39377 DO 230 J=1,3
39378 P(N+I,J)=SGN*P(N+I,J)/PA
39379 230 CONTINUE
39380 240 CONTINUE
39381
39382C...Middle axis orthogonal to other two. Fill other codes.
39383 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39384 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
39385 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
39386 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
39387 DO 260 I=1,3
39388 K(N+I,1)=31
39389 K(N+I,2)=95
39390 K(N+I,3)=I
39391 K(N+I,4)=0
39392 K(N+I,5)=0
39393 P(N+I,5)=0D0
39394 DO 250 J=1,5
39395 V(I,J)=0D0
39396 250 CONTINUE
39397 260 CONTINUE
39398
39399C...Calculate sphericity and aplanarity. Select storing option.
39400 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
39401 APL=1.5D0*P(N+3,4)
39402 MSTU(61)=N+1
39403 MSTU(62)=NP
39404 IF(MSTU(43).LE.1) MSTU(3)=3
39405 IF(MSTU(43).GE.2) N=N+3
39406
39407 RETURN
39408 END
39409
39410C*********************************************************************
39411
39412*$ CREATE PYTHRU.FOR
39413*COPY PYTHRU
39414C...PYTHRU
39415C...Performs thrust analysis to give thrust, oblateness
39416C...and the related event axes.
39417
39418 SUBROUTINE PYTHRU(THR,OBL)
39419
39420C...Double precision and integer declarations.
39421 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39422 INTEGER PYK,PYCHGE,PYCOMP
39423C...Commonblocks.
39424 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39425 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39426 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39427 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39428C...Local arrays.
39429 DIMENSION TDI(3),TPR(3)
39430
39431C...Take copy of particles that are to be considered in thrust analysis.
39432 NP=0
39433 PS=0D0
39434 DO 100 I=1,N
39435 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
39436 IF(MSTU(41).GE.2) THEN
39437 KC=PYCOMP(K(I,2))
39438 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39439 & KC.EQ.18) GOTO 100
39440 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39441 & GOTO 100
39442 ENDIF
39443 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
39444 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
39445 THR=-2D0
39446 OBL=-2D0
39447 RETURN
39448 ENDIF
39449 NP=NP+1
39450 K(N+NP,1)=23
39451 P(N+NP,1)=P(I,1)
39452 P(N+NP,2)=P(I,2)
39453 P(N+NP,3)=P(I,3)
39454 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39455 P(N+NP,5)=1D0
39456 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
39457 & P(N+NP,4)**(PARU(42)-1D0)
39458 PS=PS+P(N+NP,4)*P(N+NP,5)
39459 100 CONTINUE
39460
39461C...Very low multiplicities (0 or 1) not considered.
39462 IF(NP.LE.1) THEN
39463 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
39464 THR=-1D0
39465 OBL=-1D0
39466 RETURN
39467 ENDIF
39468
39469C...Loop over thrust and major. T axis along z direction in latter case.
39470 DO 320 ILD=1,2
39471 IF(ILD.EQ.2) THEN
39472 K(N+NP+1,1)=31
39473 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
39474 MSTU(33)=1
39475 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
39476 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
39477 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
39478 ENDIF
39479
39480C...Find and order particles with highest p (pT for major).
39481 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
39482 P(ILF,4)=0D0
39483 110 CONTINUE
39484 DO 160 I=N+1,N+NP
39485 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
39486 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
39487 IF(P(I,4).LE.P(ILF,4)) GOTO 140
39488 DO 120 J=1,5
39489 P(ILF+1,J)=P(ILF,J)
39490 120 CONTINUE
39491 130 CONTINUE
39492 ILF=N+NP+3
39493 140 DO 150 J=1,5
39494 P(ILF+1,J)=P(I,J)
39495 150 CONTINUE
39496 160 CONTINUE
39497
39498C...Find and order initial axes with highest thrust (major).
39499 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
39500 P(ILG,4)=0D0
39501 170 CONTINUE
39502 NC=2**(MIN(MSTU(44),NP)-1)
39503 DO 250 ILC=1,NC
39504 DO 180 J=1,3
39505 TDI(J)=0D0
39506 180 CONTINUE
39507 DO 200 ILF=1,MIN(MSTU(44),NP)
39508 SGN=P(N+NP+ILF+3,5)
39509 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
39510 DO 190 J=1,4-ILD
39511 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
39512 190 CONTINUE
39513 200 CONTINUE
39514 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
39515 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
39516 IF(TDS.LE.P(ILG,4)) GOTO 230
39517 DO 210 J=1,4
39518 P(ILG+1,J)=P(ILG,J)
39519 210 CONTINUE
39520 220 CONTINUE
39521 ILG=N+NP+MSTU(44)+4
39522 230 DO 240 J=1,3
39523 P(ILG+1,J)=TDI(J)
39524 240 CONTINUE
39525 P(ILG+1,4)=TDS
39526 250 CONTINUE
39527
39528C...Iterate direction of axis until stable maximum.
39529 P(N+NP+ILD,4)=0D0
39530 ILG=0
39531 260 ILG=ILG+1
39532 THP=0D0
39533 270 THPS=THP
39534 DO 280 J=1,3
39535 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
39536 IF(THP.GT.1D-10) TDI(J)=TPR(J)
39537 TPR(J)=0D0
39538 280 CONTINUE
39539 DO 300 I=N+1,N+NP
39540 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
39541 DO 290 J=1,4-ILD
39542 TPR(J)=TPR(J)+SGN*P(I,J)
39543 290 CONTINUE
39544 300 CONTINUE
39545 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
39546 IF(THP.GE.THPS+PARU(48)) GOTO 270
39547
39548C...Save good axis. Try new initial axis until a number of tries agree.
39549 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
39550 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
39551 IAGR=0
39552 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39553 DO 310 J=1,3
39554 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
39555 310 CONTINUE
39556 P(N+NP+ILD,4)=THP
39557 P(N+NP+ILD,5)=0D0
39558 ENDIF
39559 IAGR=IAGR+1
39560 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
39561 320 CONTINUE
39562
39563C...Find minor axis and value by orthogonality.
39564 SGN=(-1D0)**INT(PYR(0)+0.5D0)
39565 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
39566 P(N+NP+3,2)=SGN*P(N+NP+2,1)
39567 P(N+NP+3,3)=0D0
39568 THP=0D0
39569 DO 330 I=N+1,N+NP
39570 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
39571 330 CONTINUE
39572 P(N+NP+3,4)=THP/PS
39573 P(N+NP+3,5)=0D0
39574
39575C...Fill axis information. Rotate back to original coordinate system.
39576 DO 350 ILD=1,3
39577 K(N+ILD,1)=31
39578 K(N+ILD,2)=96
39579 K(N+ILD,3)=ILD
39580 K(N+ILD,4)=0
39581 K(N+ILD,5)=0
39582 DO 340 J=1,5
39583 P(N+ILD,J)=P(N+NP+ILD,J)
39584 V(N+ILD,J)=0D0
39585 340 CONTINUE
39586 350 CONTINUE
39587 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
39588
39589C...Calculate thrust and oblateness. Select storing option.
39590 THR=P(N+1,4)
39591 OBL=P(N+2,4)-P(N+3,4)
39592 MSTU(61)=N+1
39593 MSTU(62)=NP
39594 IF(MSTU(43).LE.1) MSTU(3)=3
39595 IF(MSTU(43).GE.2) N=N+3
39596
39597 RETURN
39598 END
39599
39600C*********************************************************************
39601
39602*$ CREATE PYCLUS.FOR
39603*COPY PYCLUS
39604C...PYCLUS
39605C...Subdivides the particle content of an event into jets/clusters.
39606
39607 SUBROUTINE PYCLUS(NJET)
39608
39609C...Double precision and integer declarations.
39610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39611 INTEGER PYK,PYCHGE,PYCOMP
39612C...Commonblocks.
39613 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39615 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39616 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39617C...Local arrays and saved variables.
39618 DIMENSION PS(5)
39619 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
39620
39621C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
39622 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
39623 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
39624 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
39625 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39626 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
39627 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39628
39629C...If first time, reset. If reentering, skip preliminaries.
39630 IF(MSTU(48).LE.0) THEN
39631 NP=0
39632 DO 100 J=1,5
39633 PS(J)=0D0
39634 100 CONTINUE
39635 PSS=0D0
39636 PIMASS=PMAS(PYCOMP(211),1)
39637 ELSE
39638 NJET=NSAV
39639 IF(MSTU(43).GE.2) N=N-NJET
39640 DO 110 I=N+1,N+NJET
39641 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39642 110 CONTINUE
39643 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39644 R2ACC=PARU(44)**2
39645 ELSE
39646 R2ACC=PARU(45)*PS(5)**2
39647 ENDIF
39648 NLOOP=0
39649 GOTO 300
39650 ENDIF
39651
39652C...Find which particles are to be considered in cluster search.
39653 DO 140 I=1,N
39654 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39655 IF(MSTU(41).GE.2) THEN
39656 KC=PYCOMP(K(I,2))
39657 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39658 & KC.EQ.18) GOTO 140
39659 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39660 & GOTO 140
39661 ENDIF
39662 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
39663 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
39664 NJET=-1
39665 RETURN
39666 ENDIF
39667
39668C...Take copy of these particles, with space left for jets later on.
39669 NP=NP+1
39670 K(N+NP,3)=I
39671 DO 120 J=1,5
39672 P(N+NP,J)=P(I,J)
39673 120 CONTINUE
39674 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
39675 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
39676 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
39677 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39678 DO 130 J=1,4
39679 PS(J)=PS(J)+P(N+NP,J)
39680 130 CONTINUE
39681 PSS=PSS+P(N+NP,5)
39682 140 CONTINUE
39683 DO 160 I=N+1,N+NP
39684 K(I+NP,3)=K(I,3)
39685 DO 150 J=1,5
39686 P(I+NP,J)=P(I,J)
39687 150 CONTINUE
39688 160 CONTINUE
39689 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
39690
39691C...Very low multiplicities not considered.
39692 IF(NP.LT.MSTU(47)) THEN
39693 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
39694 NJET=-1
39695 RETURN
39696 ENDIF
39697
39698C...Find precluster configuration. If too few jets, make harder cuts.
39699 NLOOP=0
39700 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39701 R2ACC=PARU(44)**2
39702 ELSE
39703 R2ACC=PARU(45)*PS(5)**2
39704 ENDIF
39705 RINIT=1.25D0*PARU(43)
39706 IF(NP.LE.MSTU(47)+2) RINIT=0D0
39707 170 RINIT=0.8D0*RINIT
39708 NPRE=0
39709 NREM=NP
39710 DO 180 I=N+NP+1,N+2*NP
39711 K(I,4)=0
39712 180 CONTINUE
39713
39714C...Sum up small momentum region. Jet if enough absolute momentum.
39715 IF(MSTU(46).LE.2) THEN
39716 DO 190 J=1,4
39717 P(N+1,J)=0D0
39718 190 CONTINUE
39719 DO 210 I=N+NP+1,N+2*NP
39720 IF(P(I,5).GT.2D0*RINIT) GOTO 210
39721 NREM=NREM-1
39722 K(I,4)=1
39723 DO 200 J=1,4
39724 P(N+1,J)=P(N+1,J)+P(I,J)
39725 200 CONTINUE
39726 210 CONTINUE
39727 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
39728 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
39729 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39730 IF(NREM.EQ.0) GOTO 170
39731 ENDIF
39732
39733C...Find fastest remaining particle.
39734 220 NPRE=NPRE+1
39735 PMAX=0D0
39736 DO 230 I=N+NP+1,N+2*NP
39737 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
39738 IMAX=I
39739 PMAX=P(I,5)
39740 230 CONTINUE
39741 DO 240 J=1,5
39742 P(N+NPRE,J)=P(IMAX,J)
39743 240 CONTINUE
39744 NREM=NREM-1
39745 K(IMAX,4)=NPRE
39746
39747C...Sum up precluster around it according to pT separation.
39748 IF(MSTU(46).LE.2) THEN
39749 DO 260 I=N+NP+1,N+2*NP
39750 IF(K(I,4).NE.0) GOTO 260
39751 R2=R2T(I,IMAX)
39752 IF(R2.GT.RINIT**2) GOTO 260
39753 NREM=NREM-1
39754 K(I,4)=NPRE
39755 DO 250 J=1,4
39756 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
39757 250 CONTINUE
39758 260 CONTINUE
39759 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39760
39761C...Sum up precluster around it according to mass or
39762C...Durham pT separation.
39763 ELSE
39764 270 IMIN=0
39765 R2MIN=RINIT**2
39766 DO 280 I=N+NP+1,N+2*NP
39767 IF(K(I,4).NE.0) GOTO 280
39768 IF(MSTU(46).LE.4) THEN
39769 R2=R2M(I,N+NPRE)
39770 ELSE
39771 R2=R2D(I,N+NPRE)
39772 ENDIF
39773 IF(R2.GE.R2MIN) GOTO 280
39774 IMIN=I
39775 R2MIN=R2
39776 280 CONTINUE
39777 IF(IMIN.NE.0) THEN
39778 DO 290 J=1,4
39779 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
39780 290 CONTINUE
39781 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39782 NREM=NREM-1
39783 K(IMIN,4)=NPRE
39784 GOTO 270
39785 ENDIF
39786 ENDIF
39787
39788C...Check if more preclusters to be found. Start over if too few.
39789 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39790 IF(NREM.GT.0) GOTO 220
39791 NJET=NPRE
39792
39793C...Reassign all particles to nearest jet. Sum up new jet momenta.
39794 300 TSAV=0D0
39795 PSJT=0D0
39796 310 IF(MSTU(46).LE.1) THEN
39797 DO 330 I=N+1,N+NJET
39798 DO 320 J=1,4
39799 V(I,J)=0D0
39800 320 CONTINUE
39801 330 CONTINUE
39802 DO 360 I=N+NP+1,N+2*NP
39803 R2MIN=PSS**2
39804 DO 340 IJET=N+1,N+NJET
39805 IF(P(IJET,5).LT.RINIT) GOTO 340
39806 R2=R2T(I,IJET)
39807 IF(R2.GE.R2MIN) GOTO 340
39808 IMIN=IJET
39809 R2MIN=R2
39810 340 CONTINUE
39811 K(I,4)=IMIN-N
39812 DO 350 J=1,4
39813 V(IMIN,J)=V(IMIN,J)+P(I,J)
39814 350 CONTINUE
39815 360 CONTINUE
39816 PSJT=0D0
39817 DO 380 I=N+1,N+NJET
39818 DO 370 J=1,4
39819 P(I,J)=V(I,J)
39820 370 CONTINUE
39821 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39822 PSJT=PSJT+P(I,5)
39823 380 CONTINUE
39824 ENDIF
39825
39826C...Find two closest jets.
39827 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
39828 DO 400 ITRY1=N+1,N+NJET-1
39829 DO 390 ITRY2=ITRY1+1,N+NJET
39830 IF(MSTU(46).LE.2) THEN
39831 R2=R2T(ITRY1,ITRY2)
39832 ELSEIF(MSTU(46).LE.4) THEN
39833 R2=R2M(ITRY1,ITRY2)
39834 ELSE
39835 R2=R2D(ITRY1,ITRY2)
39836 ENDIF
39837 IF(R2.GE.R2MIN) GOTO 390
39838 IMIN1=ITRY1
39839 IMIN2=ITRY2
39840 R2MIN=R2
39841 390 CONTINUE
39842 400 CONTINUE
39843
39844C...If allowed, join two closest jets and start over.
39845 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
39846 IREC=MIN(IMIN1,IMIN2)
39847 IDEL=MAX(IMIN1,IMIN2)
39848 DO 410 J=1,4
39849 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
39850 410 CONTINUE
39851 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
39852 DO 430 I=IDEL+1,N+NJET
39853 DO 420 J=1,5
39854 P(I-1,J)=P(I,J)
39855 420 CONTINUE
39856 430 CONTINUE
39857 IF(MSTU(46).GE.2) THEN
39858 DO 440 I=N+NP+1,N+2*NP
39859 IORI=N+K(I,4)
39860 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
39861 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
39862 440 CONTINUE
39863 ENDIF
39864 NJET=NJET-1
39865 GOTO 300
39866
39867C...Divide up broad jet if empty cluster in list of final ones.
39868 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
39869 DO 450 I=N+1,N+NJET
39870 K(I,5)=0
39871 450 CONTINUE
39872 DO 460 I=N+NP+1,N+2*NP
39873 K(N+K(I,4),5)=K(N+K(I,4),5)+1
39874 460 CONTINUE
39875 IEMP=0
39876 DO 470 I=N+1,N+NJET
39877 IF(K(I,5).EQ.0) IEMP=I
39878 470 CONTINUE
39879 IF(IEMP.NE.0) THEN
39880 NLOOP=NLOOP+1
39881 ISPL=0
39882 R2MAX=0D0
39883 DO 480 I=N+NP+1,N+2*NP
39884 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
39885 IJET=N+K(I,4)
39886 R2=R2T(I,IJET)
39887 IF(R2.LE.R2MAX) GOTO 480
39888 ISPL=I
39889 R2MAX=R2
39890 480 CONTINUE
39891 IF(ISPL.NE.0) THEN
39892 IJET=N+K(ISPL,4)
39893 DO 490 J=1,4
39894 P(IEMP,J)=P(ISPL,J)
39895 P(IJET,J)=P(IJET,J)-P(ISPL,J)
39896 490 CONTINUE
39897 P(IEMP,5)=P(ISPL,5)
39898 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
39899 IF(NLOOP.LE.2) GOTO 300
39900 ENDIF
39901 ENDIF
39902 ENDIF
39903
39904C...If generalized thrust has not yet converged, continue iteration.
39905 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
39906 &THEN
39907 TSAV=PSJT/PSS
39908 GOTO 310
39909 ENDIF
39910
39911C...Reorder jets according to energy.
39912 DO 510 I=N+1,N+NJET
39913 DO 500 J=1,5
39914 V(I,J)=P(I,J)
39915 500 CONTINUE
39916 510 CONTINUE
39917 DO 540 INEW=N+1,N+NJET
39918 PEMAX=0D0
39919 DO 520 ITRY=N+1,N+NJET
39920 IF(V(ITRY,4).LE.PEMAX) GOTO 520
39921 IMAX=ITRY
39922 PEMAX=V(ITRY,4)
39923 520 CONTINUE
39924 K(INEW,1)=31
39925 K(INEW,2)=97
39926 K(INEW,3)=INEW-N
39927 K(INEW,4)=0
39928 DO 530 J=1,5
39929 P(INEW,J)=V(IMAX,J)
39930 530 CONTINUE
39931 V(IMAX,4)=-1D0
39932 K(IMAX,5)=INEW
39933 540 CONTINUE
39934
39935C...Clean up particle-jet assignments and jet information.
39936 DO 550 I=N+NP+1,N+2*NP
39937 IORI=K(N+K(I,4),5)
39938 K(I,4)=IORI-N
39939 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
39940 K(IORI,4)=K(IORI,4)+1
39941 550 CONTINUE
39942 IEMP=0
39943 PSJT=0D0
39944 DO 570 I=N+1,N+NJET
39945 K(I,5)=0
39946 PSJT=PSJT+P(I,5)
39947 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
39948 DO 560 J=1,5
39949 V(I,J)=0D0
39950 560 CONTINUE
39951 IF(K(I,4).EQ.0) IEMP=I
39952 570 CONTINUE
39953
39954C...Select storing option. Output variables. Check for failure.
39955 MSTU(61)=N+1
39956 MSTU(62)=NP
39957 MSTU(63)=NPRE
39958 PARU(61)=PS(5)
39959 PARU(62)=PSJT/PSS
39960 PARU(63)=SQRT(R2MIN)
39961 IF(NJET.LE.1) PARU(63)=0D0
39962 IF(IEMP.NE.0) THEN
39963 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
39964 NJET=-1
39965 ENDIF
39966 IF(MSTU(43).LE.1) MSTU(3)=NJET
39967 IF(MSTU(43).GE.2) N=N+NJET
39968 NSAV=NJET
39969
39970 RETURN
39971 END
39972
39973C*********************************************************************
39974
39975*$ CREATE PYCELL.FOR
39976*COPY PYCELL
39977C...PYCELL
39978C...Provides a simple way of jet finding in eta-phi-ET coordinates,
39979C...as used for calorimeters at hadron colliders.
39980
39981 SUBROUTINE PYCELL(NJET)
39982
39983C...Double precision and integer declarations.
39984 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39985 INTEGER PYK,PYCHGE,PYCOMP
39986C...Commonblocks.
39987 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39988 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39989 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39990 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39991
39992C...Loop over all particles. Find cell that was hit by given particle.
39993 PTLRAT=1D0/SINH(PARU(51))**2
39994 NP=0
39995 NC=N
39996 DO 110 I=1,N
39997 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
39998 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
39999 IF(MSTU(41).GE.2) THEN
40000 KC=PYCOMP(K(I,2))
40001 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40002 & KC.EQ.18) GOTO 110
40003 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40004 & GOTO 110
40005 ENDIF
40006 NP=NP+1
40007 PT=SQRT(P(I,1)**2+P(I,2)**2)
40008 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
40009 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
40010 & (ETA/PARU(51)+1D0))))
40011 PHI=PYANGL(P(I,1),P(I,2))
40012 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
40013 & (PHI/PARU(1)+1D0))))
40014 IETPH=MSTU(52)*IETA+IPHI
40015
40016C...Add to cell already hit, or book new cell.
40017 DO 100 IC=N+1,NC
40018 IF(IETPH.EQ.K(IC,3)) THEN
40019 K(IC,4)=K(IC,4)+1
40020 P(IC,5)=P(IC,5)+PT
40021 GOTO 110
40022 ENDIF
40023 100 CONTINUE
40024 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
40025 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
40026 NJET=-2
40027 RETURN
40028 ENDIF
40029 NC=NC+1
40030 K(NC,3)=IETPH
40031 K(NC,4)=1
40032 K(NC,5)=2
40033 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
40034 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
40035 P(NC,5)=PT
40036 110 CONTINUE
40037
40038C...Smear true bin content by calorimeter resolution.
40039 IF(MSTU(53).GE.1) THEN
40040 DO 130 IC=N+1,NC
40041 PEI=P(IC,5)
40042 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
40043 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
40044 & COS(PARU(2)*PYR(0))
40045 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
40046 P(IC,5)=PEF
40047 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
40048 130 CONTINUE
40049 ENDIF
40050
40051C...Remove cells below threshold.
40052 IF(PARU(58).GT.0D0) THEN
40053 NCC=NC
40054 NC=N
40055 DO 140 IC=N+1,NCC
40056 IF(P(IC,5).GT.PARU(58)) THEN
40057 NC=NC+1
40058 K(NC,3)=K(IC,3)
40059 K(NC,4)=K(IC,4)
40060 K(NC,5)=K(IC,5)
40061 P(NC,1)=P(IC,1)
40062 P(NC,2)=P(IC,2)
40063 P(NC,5)=P(IC,5)
40064 ENDIF
40065 140 CONTINUE
40066 ENDIF
40067
40068C...Find initiator cell: the one with highest pT of not yet used ones.
40069 NJ=NC
40070 150 ETMAX=0D0
40071 DO 160 IC=N+1,NC
40072 IF(K(IC,5).NE.2) GOTO 160
40073 IF(P(IC,5).LE.ETMAX) GOTO 160
40074 ICMAX=IC
40075 ETA=P(IC,1)
40076 PHI=P(IC,2)
40077 ETMAX=P(IC,5)
40078 160 CONTINUE
40079 IF(ETMAX.LT.PARU(52)) GOTO 220
40080 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
40081 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
40082 NJET=-2
40083 RETURN
40084 ENDIF
40085 K(ICMAX,5)=1
40086 NJ=NJ+1
40087 K(NJ,4)=0
40088 K(NJ,5)=1
40089 P(NJ,1)=ETA
40090 P(NJ,2)=PHI
40091 P(NJ,3)=0D0
40092 P(NJ,4)=0D0
40093 P(NJ,5)=0D0
40094
40095C...Sum up unused cells within required distance of initiator.
40096 DO 170 IC=N+1,NC
40097 IF(K(IC,5).EQ.0) GOTO 170
40098 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
40099 DPHIA=ABS(P(IC,2)-PHI)
40100 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
40101 PHIC=P(IC,2)
40102 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
40103 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
40104 K(IC,5)=-K(IC,5)
40105 K(NJ,4)=K(NJ,4)+K(IC,4)
40106 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
40107 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
40108 P(NJ,5)=P(NJ,5)+P(IC,5)
40109 170 CONTINUE
40110
40111C...Reject cluster below minimum ET, else accept.
40112 IF(P(NJ,5).LT.PARU(53)) THEN
40113 NJ=NJ-1
40114 DO 180 IC=N+1,NC
40115 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
40116 180 CONTINUE
40117 ELSEIF(MSTU(54).LE.2) THEN
40118 P(NJ,3)=P(NJ,3)/P(NJ,5)
40119 P(NJ,4)=P(NJ,4)/P(NJ,5)
40120 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
40121 & P(NJ,4))
40122 DO 190 IC=N+1,NC
40123 IF(K(IC,5).LT.0) K(IC,5)=0
40124 190 CONTINUE
40125 ELSE
40126 DO 200 J=1,4
40127 P(NJ,J)=0D0
40128 200 CONTINUE
40129 DO 210 IC=N+1,NC
40130 IF(K(IC,5).GE.0) GOTO 210
40131 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
40132 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
40133 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
40134 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
40135 K(IC,5)=0
40136 210 CONTINUE
40137 ENDIF
40138 GOTO 150
40139
40140C...Arrange clusters in falling ET sequence.
40141 220 DO 250 I=1,NJ-NC
40142 ETMAX=0D0
40143 DO 230 IJ=NC+1,NJ
40144 IF(K(IJ,5).EQ.0) GOTO 230
40145 IF(P(IJ,5).LT.ETMAX) GOTO 230
40146 IJMAX=IJ
40147 ETMAX=P(IJ,5)
40148 230 CONTINUE
40149 K(IJMAX,5)=0
40150 K(N+I,1)=31
40151 K(N+I,2)=98
40152 K(N+I,3)=I
40153 K(N+I,4)=K(IJMAX,4)
40154 K(N+I,5)=0
40155 DO 240 J=1,5
40156 P(N+I,J)=P(IJMAX,J)
40157 V(N+I,J)=0D0
40158 240 CONTINUE
40159 250 CONTINUE
40160 NJET=NJ-NC
40161
40162C...Convert to massless or massive four-vectors.
40163 IF(MSTU(54).EQ.2) THEN
40164 DO 260 I=N+1,N+NJET
40165 ETA=P(I,3)
40166 P(I,1)=P(I,5)*COS(P(I,4))
40167 P(I,2)=P(I,5)*SIN(P(I,4))
40168 P(I,3)=P(I,5)*SINH(ETA)
40169 P(I,4)=P(I,5)*COSH(ETA)
40170 P(I,5)=0D0
40171 260 CONTINUE
40172 ELSEIF(MSTU(54).GE.3) THEN
40173 DO 270 I=N+1,N+NJET
40174 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
40175 270 CONTINUE
40176 ENDIF
40177
40178C...Information about storage.
40179 MSTU(61)=N+1
40180 MSTU(62)=NP
40181 MSTU(63)=NC-N
40182 IF(MSTU(43).LE.1) MSTU(3)=NJET
40183 IF(MSTU(43).GE.2) N=N+NJET
40184
40185 RETURN
40186 END
40187
40188C*********************************************************************
40189
40190*$ CREATE PYJMAS.FOR
40191*COPY PYJMAS
40192C...PYJMAS
40193C...Determines, approximately, the two jet masses that minimize
40194C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
40195
40196 SUBROUTINE PYJMAS(PMH,PML)
40197
40198C...Double precision and integer declarations.
40199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40200 INTEGER PYK,PYCHGE,PYCOMP
40201C...Commonblocks.
40202 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40204 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40205 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40206C...Local arrays.
40207 DIMENSION SM(3,3),SAX(3),PS(3,5)
40208
40209C...Reset.
40210 NP=0
40211 DO 120 J1=1,3
40212 DO 100 J2=J1,3
40213 SM(J1,J2)=0D0
40214 100 CONTINUE
40215 DO 110 J2=1,4
40216 PS(J1,J2)=0D0
40217 110 CONTINUE
40218 120 CONTINUE
40219 PSS=0D0
40220 PIMASS=PMAS(PYCOMP(211),1)
40221
40222C...Take copy of particles that are to be considered in mass analysis.
40223 DO 170 I=1,N
40224 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
40225 IF(MSTU(41).GE.2) THEN
40226 KC=PYCOMP(K(I,2))
40227 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40228 & KC.EQ.18) GOTO 170
40229 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40230 & GOTO 170
40231 ENDIF
40232 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
40233 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
40234 PMH=-2D0
40235 PML=-2D0
40236 RETURN
40237 ENDIF
40238 NP=NP+1
40239 DO 130 J=1,5
40240 P(N+NP,J)=P(I,J)
40241 130 CONTINUE
40242 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
40243 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
40244 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40245
40246C...Fill information in sphericity tensor and total momentum vector.
40247 DO 150 J1=1,3
40248 DO 140 J2=J1,3
40249 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
40250 140 CONTINUE
40251 150 CONTINUE
40252 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40253 DO 160 J=1,4
40254 PS(3,J)=PS(3,J)+P(N+NP,J)
40255 160 CONTINUE
40256 170 CONTINUE
40257
40258C...Very low multiplicities (0 or 1) not considered.
40259 IF(NP.LE.1) THEN
40260 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
40261 PMH=-1D0
40262 PML=-1D0
40263 RETURN
40264 ENDIF
40265 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
40266 &PS(3,3)**2))
40267
40268C...Find largest eigenvalue to matrix (third degree equation).
40269 DO 190 J1=1,3
40270 DO 180 J2=J1,3
40271 SM(J1,J2)=SM(J1,J2)/PSS
40272 180 CONTINUE
40273 190 CONTINUE
40274 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
40275 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
40276 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
40277 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
40278 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
40279 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
40280 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
40281
40282C...Find largest eigenvector by solving equation system.
40283 DO 210 J1=1,3
40284 SM(J1,J1)=SM(J1,J1)-SMA
40285 DO 200 J2=J1+1,3
40286 SM(J2,J1)=SM(J1,J2)
40287 200 CONTINUE
40288 210 CONTINUE
40289 SMAX=0D0
40290 DO 230 J1=1,3
40291 DO 220 J2=1,3
40292 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
40293 JA=J1
40294 JB=J2
40295 SMAX=ABS(SM(J1,J2))
40296 220 CONTINUE
40297 230 CONTINUE
40298 SMAX=0D0
40299 DO 250 J3=JA+1,JA+2
40300 J1=J3-3*((J3-1)/3)
40301 RL=SM(J1,JB)/SM(JA,JB)
40302 DO 240 J2=1,3
40303 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
40304 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
40305 JC=J1
40306 SMAX=ABS(SM(J1,J2))
40307 240 CONTINUE
40308 250 CONTINUE
40309 JB1=JB+1-3*(JB/3)
40310 JB2=JB+2-3*((JB+1)/3)
40311 SAX(JB1)=-SM(JC,JB2)
40312 SAX(JB2)=SM(JC,JB1)
40313 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
40314
40315C...Divide particles into two initial clusters by hemisphere.
40316 DO 270 I=N+1,N+NP
40317 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
40318 IS=1
40319 IF(PSAX.LT.0D0) IS=2
40320 K(I,3)=IS
40321 DO 260 J=1,4
40322 PS(IS,J)=PS(IS,J)+P(I,J)
40323 260 CONTINUE
40324 270 CONTINUE
40325 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
40326 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
40327
40328C...Reassign one particle at a time; find maximum decrease of m^2 sum.
40329 280 PMD=0D0
40330 IM=0
40331 DO 290 J=1,4
40332 PS(3,J)=PS(1,J)-PS(2,J)
40333 290 CONTINUE
40334 DO 300 I=N+1,N+NP
40335 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)
40336 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
40337 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
40338 IF(PMDI.LT.PMD) THEN
40339 PMD=PMDI
40340 IM=I
40341 ENDIF
40342 300 CONTINUE
40343
40344C...Loop back if significant reduction in sum of m^2.
40345 IF(PMD.LT.-PARU(48)*PMS) THEN
40346 PMS=PMS+PMD
40347 IS=K(IM,3)
40348 DO 310 J=1,4
40349 PS(IS,J)=PS(IS,J)-P(IM,J)
40350 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
40351 310 CONTINUE
40352 K(IM,3)=3-IS
40353 GOTO 280
40354 ENDIF
40355
40356C...Final masses and output.
40357 MSTU(61)=N+1
40358 MSTU(62)=NP
40359 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
40360 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
40361 PMH=MAX(PS(1,5),PS(2,5))
40362 PML=MIN(PS(1,5),PS(2,5))
40363
40364 RETURN
40365 END
40366
40367C*********************************************************************
40368
40369*$ CREATE PYFOWO.FOR
40370*COPY PYFOWO
40371C...PYFOWO
40372C...Calculates the first few Fox-Wolfram moments.
40373
40374 SUBROUTINE PYFOWO(H10,H20,H30,H40)
40375
40376C...Double precision and integer declarations.
40377 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40378 INTEGER PYK,PYCHGE,PYCOMP
40379C...Commonblocks.
40380 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40381 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40382 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40383 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40384
40385C...Copy momenta for particles and calculate H0.
40386 NP=0
40387 H0=0D0
40388 HD=0D0
40389 DO 110 I=1,N
40390 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
40391 IF(MSTU(41).GE.2) THEN
40392 KC=PYCOMP(K(I,2))
40393 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40394 & KC.EQ.18) GOTO 110
40395 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40396 & GOTO 110
40397 ENDIF
40398 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
40399 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
40400 H10=-1D0
40401 H20=-1D0
40402 H30=-1D0
40403 H40=-1D0
40404 RETURN
40405 ENDIF
40406 NP=NP+1
40407 DO 100 J=1,3
40408 P(N+NP,J)=P(I,J)
40409 100 CONTINUE
40410 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40411 H0=H0+P(N+NP,4)
40412 HD=HD+P(N+NP,4)**2
40413 110 CONTINUE
40414 H0=H0**2
40415
40416C...Very low multiplicities (0 or 1) not considered.
40417 IF(NP.LE.1) THEN
40418 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
40419 H10=-1D0
40420 H20=-1D0
40421 H30=-1D0
40422 H40=-1D0
40423 RETURN
40424 ENDIF
40425
40426C...Calculate H1 - H4.
40427 H10=0D0
40428 H20=0D0
40429 H30=0D0
40430 H40=0D0
40431 DO 130 I1=N+1,N+NP
40432 DO 120 I2=I1+1,N+NP
40433 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40434 & (P(I1,4)*P(I2,4))
40435 H10=H10+P(I1,4)*P(I2,4)*CTHE
40436 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
40437 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
40438 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
40439 & 0.375D0)
40440 120 CONTINUE
40441 130 CONTINUE
40442
40443C...Calculate H1/H0 - H4/H0. Output.
40444 MSTU(61)=N+1
40445 MSTU(62)=NP
40446 H10=(HD+2D0*H10)/H0
40447 H20=(HD+2D0*H20)/H0
40448 H30=(HD+2D0*H30)/H0
40449 H40=(HD+2D0*H40)/H0
40450
40451 RETURN
40452 END
40453
40454C*********************************************************************
40455
40456*$ CREATE PYTABU.FOR
40457*COPY PYTABU
40458C...PYTABU
40459C...Evaluates various properties of an event, with statistics
40460C...accumulated during the course of the run and
40461C...printed at the end.
40462
40463 SUBROUTINE PYTABU(MTABU)
40464
40465C...Double precision and integer declarations.
40466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40467 INTEGER PYK,PYCHGE,PYCOMP
40468C...Commonblocks.
40469 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40470 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40471 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40472 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
40473 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
40474C...Local arrays, character variables, saved variables and data.
40475 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
40476 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
40477 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
40478 &KFDM(8),KFDC(200,0:8),NPDC(200)
40479 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
40480 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
40481 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
40482 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
40483 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
40484 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
40485 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
40486 &NEVDC/0/,NKFDC/0/,NREDC/0/
40487
40488C...Reset statistics on initial parton state.
40489 IF(MTABU.EQ.10) THEN
40490 NEVIS=0
40491 NKFIS=0
40492
40493C...Identify and order flavour content of initial state.
40494 ELSEIF(MTABU.EQ.11) THEN
40495 NEVIS=NEVIS+1
40496 KFM1=2*IABS(MSTU(161))
40497 IF(MSTU(161).GT.0) KFM1=KFM1-1
40498 KFM2=2*IABS(MSTU(162))
40499 IF(MSTU(162).GT.0) KFM2=KFM2-1
40500 KFMN=MIN(KFM1,KFM2)
40501 KFMX=MAX(KFM1,KFM2)
40502 DO 100 I=1,NKFIS
40503 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
40504 IKFIS=-I
40505 GOTO 110
40506 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
40507 & KFMX.LT.KFIS(I,2))) THEN
40508 IKFIS=I
40509 GOTO 110
40510 ENDIF
40511 100 CONTINUE
40512 IKFIS=NKFIS+1
40513 110 IF(IKFIS.LT.0) THEN
40514 IKFIS=-IKFIS
40515 ELSE
40516 IF(NKFIS.GE.100) RETURN
40517 DO 130 I=NKFIS,IKFIS,-1
40518 KFIS(I+1,1)=KFIS(I,1)
40519 KFIS(I+1,2)=KFIS(I,2)
40520 DO 120 J=0,10
40521 NPIS(I+1,J)=NPIS(I,J)
40522 120 CONTINUE
40523 130 CONTINUE
40524 NKFIS=NKFIS+1
40525 KFIS(IKFIS,1)=KFMN
40526 KFIS(IKFIS,2)=KFMX
40527 DO 140 J=0,10
40528 NPIS(IKFIS,J)=0
40529 140 CONTINUE
40530 ENDIF
40531 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
40532
40533C...Count number of partons in initial state.
40534 NP=0
40535 DO 160 I=1,N
40536 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
40537 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
40538 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
40539 & THEN
40540 ELSE
40541 IM=I
40542 150 IM=K(IM,3)
40543 IF(IM.LE.0.OR.IM.GT.N) THEN
40544 NP=NP+1
40545 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40546 NP=NP+1
40547 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
40548 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
40549 & .NE.0) THEN
40550 ELSE
40551 GOTO 150
40552 ENDIF
40553 ENDIF
40554 160 CONTINUE
40555 NPCO=MAX(NP,1)
40556 IF(NP.GE.6) NPCO=6
40557 IF(NP.GE.8) NPCO=7
40558 IF(NP.GE.11) NPCO=8
40559 IF(NP.GE.16) NPCO=9
40560 IF(NP.GE.26) NPCO=10
40561 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
40562 MSTU(62)=NP
40563
40564C...Write statistics on initial parton state.
40565 ELSEIF(MTABU.EQ.12) THEN
40566 FAC=1D0/MAX(1,NEVIS)
40567 WRITE(MSTU(11),5000) NEVIS
40568 DO 170 I=1,NKFIS
40569 KFMN=KFIS(I,1)
40570 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40571 KFM1=(KFMN+1)/2
40572 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40573 CALL PYNAME(KFM1,CHAU)
40574 CHIS(1)=CHAU(1:12)
40575 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
40576 KFMX=KFIS(I,2)
40577 IF(KFIS(I,1).EQ.0) KFMX=0
40578 KFM2=(KFMX+1)/2
40579 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40580 CALL PYNAME(KFM2,CHAU)
40581 CHIS(2)=CHAU(1:12)
40582 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
40583 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
40584 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
40585 170 CONTINUE
40586
40587C...Copy statistics on initial parton state into /PYJETS/.
40588 ELSEIF(MTABU.EQ.13) THEN
40589 FAC=1D0/MAX(1,NEVIS)
40590 DO 190 I=1,NKFIS
40591 KFMN=KFIS(I,1)
40592 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40593 KFM1=(KFMN+1)/2
40594 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40595 KFMX=KFIS(I,2)
40596 IF(KFIS(I,1).EQ.0) KFMX=0
40597 KFM2=(KFMX+1)/2
40598 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40599 K(I,1)=32
40600 K(I,2)=99
40601 K(I,3)=KFM1
40602 K(I,4)=KFM2
40603 K(I,5)=NPIS(I,0)
40604 DO 180 J=1,5
40605 P(I,J)=FAC*NPIS(I,J)
40606 V(I,J)=FAC*NPIS(I,J+5)
40607 180 CONTINUE
40608 190 CONTINUE
40609 N=NKFIS
40610 DO 200 J=1,5
40611 K(N+1,J)=0
40612 P(N+1,J)=0D0
40613 V(N+1,J)=0D0
40614 200 CONTINUE
40615 K(N+1,1)=32
40616 K(N+1,2)=99
40617 K(N+1,5)=NEVIS
40618 MSTU(3)=1
40619
40620C...Reset statistics on number of particles/partons.
40621 ELSEIF(MTABU.EQ.20) THEN
40622 NEVFS=0
40623 NPRFS=0
40624 NFIFS=0
40625 NCHFS=0
40626 NKFFS=0
40627
40628C...Identify whether particle/parton is primary or not.
40629 ELSEIF(MTABU.EQ.21) THEN
40630 NEVFS=NEVFS+1
40631 MSTU(62)=0
40632 DO 260 I=1,N
40633 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
40634 MSTU(62)=MSTU(62)+1
40635 KC=PYCOMP(K(I,2))
40636 MPRI=0
40637 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
40638 MPRI=1
40639 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
40640 MPRI=1
40641 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
40642 MPRI=1
40643 ELSEIF(KC.EQ.0) THEN
40644 ELSEIF(K(K(I,3),1).EQ.13) THEN
40645 IM=K(K(I,3),3)
40646 IF(IM.LE.0.OR.IM.GT.N) THEN
40647 MPRI=1
40648 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40649 MPRI=1
40650 ENDIF
40651 ELSEIF(KCHG(KC,2).EQ.0) THEN
40652 KCM=PYCOMP(K(K(I,3),2))
40653 IF(KCM.NE.0) THEN
40654 IF(KCHG(KCM,2).NE.0) MPRI=1
40655 ENDIF
40656 ENDIF
40657 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
40658 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
40659 ENDIF
40660 IF(K(I,1).LE.10) THEN
40661 NFIFS=NFIFS+1
40662 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
40663 ENDIF
40664
40665C...Fill statistics on number of particles/partons in event.
40666 KFA=IABS(K(I,2))
40667 KFS=3-ISIGN(1,K(I,2))-MPRI
40668 DO 210 IP=1,NKFFS
40669 IF(KFA.EQ.KFFS(IP)) THEN
40670 IKFFS=-IP
40671 GOTO 220
40672 ELSEIF(KFA.LT.KFFS(IP)) THEN
40673 IKFFS=IP
40674 GOTO 220
40675 ENDIF
40676 210 CONTINUE
40677 IKFFS=NKFFS+1
40678 220 IF(IKFFS.LT.0) THEN
40679 IKFFS=-IKFFS
40680 ELSE
40681 IF(NKFFS.GE.400) RETURN
40682 DO 240 IP=NKFFS,IKFFS,-1
40683 KFFS(IP+1)=KFFS(IP)
40684 DO 230 J=1,4
40685 NPFS(IP+1,J)=NPFS(IP,J)
40686 230 CONTINUE
40687 240 CONTINUE
40688 NKFFS=NKFFS+1
40689 KFFS(IKFFS)=KFA
40690 DO 250 J=1,4
40691 NPFS(IKFFS,J)=0
40692 250 CONTINUE
40693 ENDIF
40694 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
40695 260 CONTINUE
40696
40697C...Write statistics on particle/parton composition of events.
40698 ELSEIF(MTABU.EQ.22) THEN
40699 FAC=1D0/MAX(1,NEVFS)
40700 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
40701 DO 270 I=1,NKFFS
40702 CALL PYNAME(KFFS(I),CHAU)
40703 KC=PYCOMP(KFFS(I))
40704 MDCYF=0
40705 IF(KC.NE.0) MDCYF=MDCY(KC,1)
40706 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
40707 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
40708 270 CONTINUE
40709
40710C...Copy particle/parton composition information into /PYJETS/.
40711 ELSEIF(MTABU.EQ.23) THEN
40712 FAC=1D0/MAX(1,NEVFS)
40713 DO 290 I=1,NKFFS
40714 K(I,1)=32
40715 K(I,2)=99
40716 K(I,3)=KFFS(I)
40717 K(I,4)=0
40718 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
40719 DO 280 J=1,4
40720 P(I,J)=FAC*NPFS(I,J)
40721 V(I,J)=0D0
40722 280 CONTINUE
40723 P(I,5)=FAC*K(I,5)
40724 V(I,5)=0D0
40725 290 CONTINUE
40726 N=NKFFS
40727 DO 300 J=1,5
40728 K(N+1,J)=0
40729 P(N+1,J)=0D0
40730 V(N+1,J)=0D0
40731 300 CONTINUE
40732 K(N+1,1)=32
40733 K(N+1,2)=99
40734 K(N+1,5)=NEVFS
40735 P(N+1,1)=FAC*NPRFS
40736 P(N+1,2)=FAC*NFIFS
40737 P(N+1,3)=FAC*NCHFS
40738 MSTU(3)=1
40739
40740C...Reset factorial moments statistics.
40741 ELSEIF(MTABU.EQ.30) THEN
40742 NEVFM=0
40743 NMUFM=0
40744 DO 330 IM=1,3
40745 DO 320 IB=1,10
40746 DO 310 IP=1,4
40747 FM1FM(IM,IB,IP)=0D0
40748 FM2FM(IM,IB,IP)=0D0
40749 310 CONTINUE
40750 320 CONTINUE
40751 330 CONTINUE
40752
40753C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
40754 ELSEIF(MTABU.EQ.31) THEN
40755 NEVFM=NEVFM+1
40756 NLOW=N+MSTU(3)
40757 NUPP=NLOW
40758 DO 410 I=1,N
40759 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
40760 IF(MSTU(41).GE.2) THEN
40761 KC=PYCOMP(K(I,2))
40762 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40763 & KC.EQ.18) GOTO 410
40764 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40765 & PYCHGE(K(I,2)).EQ.0) GOTO 410
40766 ENDIF
40767 PMR=0D0
40768 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40769 IF(MSTU(42).GE.2) PMR=P(I,5)
40770 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
40771 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
40772 & 1D20)),P(I,3))
40773 IF(ABS(YETA).GT.PARU(57)) GOTO 410
40774 PHI=PYANGL(P(I,1),P(I,2))
40775 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
40776 IYETA=MAX(0,MIN(511,IYETA))
40777 IPHI=512D0*(PHI+PARU(1))/PARU(2)
40778 IPHI=MAX(0,MIN(511,IPHI))
40779 IYEP=0
40780 DO 340 IB=0,9
40781 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
40782 340 CONTINUE
40783
40784C...Order particles in (pseudo)rapidity and/or azimuth.
40785 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40786 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40787 RETURN
40788 ENDIF
40789 NUPP=NUPP+1
40790 IF(NUPP.EQ.NLOW+1) THEN
40791 K(NUPP,1)=IYETA
40792 K(NUPP,2)=IPHI
40793 K(NUPP,3)=IYEP
40794 ELSE
40795 DO 350 I1=NUPP-1,NLOW+1,-1
40796 IF(IYETA.GE.K(I1,1)) GOTO 360
40797 K(I1+1,1)=K(I1,1)
40798 350 CONTINUE
40799 360 K(I1+1,1)=IYETA
40800 DO 370 I1=NUPP-1,NLOW+1,-1
40801 IF(IPHI.GE.K(I1,2)) GOTO 380
40802 K(I1+1,2)=K(I1,2)
40803 370 CONTINUE
40804 380 K(I1+1,2)=IPHI
40805 DO 390 I1=NUPP-1,NLOW+1,-1
40806 IF(IYEP.GE.K(I1,3)) GOTO 400
40807 K(I1+1,3)=K(I1,3)
40808 390 CONTINUE
40809 400 K(I1+1,3)=IYEP
40810 ENDIF
40811 410 CONTINUE
40812 K(NUPP+1,1)=2**10
40813 K(NUPP+1,2)=2**10
40814 K(NUPP+1,3)=4**10
40815
40816C...Calculate sum of factorial moments in event.
40817 DO 480 IM=1,3
40818 DO 430 IB=1,10
40819 DO 420 IP=1,4
40820 FEVFM(IB,IP)=0D0
40821 420 CONTINUE
40822 430 CONTINUE
40823 DO 450 IB=1,10
40824 IF(IM.LE.2) IBIN=2**(10-IB)
40825 IF(IM.EQ.3) IBIN=4**(10-IB)
40826 IAGR=K(NLOW+1,IM)/IBIN
40827 NAGR=1
40828 DO 440 I=NLOW+2,NUPP+1
40829 ICUT=K(I,IM)/IBIN
40830 IF(ICUT.EQ.IAGR) THEN
40831 NAGR=NAGR+1
40832 ELSE
40833 IF(NAGR.EQ.1) THEN
40834 ELSEIF(NAGR.EQ.2) THEN
40835 FEVFM(IB,1)=FEVFM(IB,1)+2D0
40836 ELSEIF(NAGR.EQ.3) THEN
40837 FEVFM(IB,1)=FEVFM(IB,1)+6D0
40838 FEVFM(IB,2)=FEVFM(IB,2)+6D0
40839 ELSEIF(NAGR.EQ.4) THEN
40840 FEVFM(IB,1)=FEVFM(IB,1)+12D0
40841 FEVFM(IB,2)=FEVFM(IB,2)+24D0
40842 FEVFM(IB,3)=FEVFM(IB,3)+24D0
40843 ELSE
40844 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
40845 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
40846 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40847 & (NAGR-3D0)
40848 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40849 & (NAGR-3D0)*(NAGR-4D0)
40850 ENDIF
40851 IAGR=ICUT
40852 NAGR=1
40853 ENDIF
40854 440 CONTINUE
40855 450 CONTINUE
40856
40857C...Add results to total statistics.
40858 DO 470 IB=10,1,-1
40859 DO 460 IP=1,4
40860 IF(FEVFM(1,IP).LT.0.5D0) THEN
40861 FEVFM(IB,IP)=0D0
40862 ELSEIF(IM.LE.2) THEN
40863 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40864 ELSE
40865 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40866 ENDIF
40867 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
40868 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
40869 460 CONTINUE
40870 470 CONTINUE
40871 480 CONTINUE
40872 NMUFM=NMUFM+(NUPP-NLOW)
40873 MSTU(62)=NUPP-NLOW
40874
40875C...Write accumulated statistics on factorial moments.
40876 ELSEIF(MTABU.EQ.32) THEN
40877 FAC=1D0/MAX(1,NEVFM)
40878 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
40879 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
40880 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
40881 DO 510 IM=1,3
40882 WRITE(MSTU(11),5500)
40883 DO 500 IB=1,10
40884 BYETA=2D0*PARU(57)
40885 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
40886 BPHI=PARU(2)
40887 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
40888 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
40889 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
40890 DO 490 IP=1,4
40891 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
40892 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40893 & FMOMA(IP)**2)))
40894 490 CONTINUE
40895 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
40896 & IP=1,4)
40897 500 CONTINUE
40898 510 CONTINUE
40899
40900C...Copy statistics on factorial moments into /PYJETS/.
40901 ELSEIF(MTABU.EQ.33) THEN
40902 FAC=1D0/MAX(1,NEVFM)
40903 DO 540 IM=1,3
40904 DO 530 IB=1,10
40905 I=10*(IM-1)+IB
40906 K(I,1)=32
40907 K(I,2)=99
40908 K(I,3)=1
40909 IF(IM.NE.2) K(I,3)=2**(IB-1)
40910 K(I,4)=1
40911 IF(IM.NE.1) K(I,4)=2**(IB-1)
40912 K(I,5)=0
40913 P(I,1)=2D0*PARU(57)/K(I,3)
40914 V(I,1)=PARU(2)/K(I,4)
40915 DO 520 IP=1,4
40916 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
40917 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40918 & P(I,IP+1)**2)))
40919 520 CONTINUE
40920 530 CONTINUE
40921 540 CONTINUE
40922 N=30
40923 DO 550 J=1,5
40924 K(N+1,J)=0
40925 P(N+1,J)=0D0
40926 V(N+1,J)=0D0
40927 550 CONTINUE
40928 K(N+1,1)=32
40929 K(N+1,2)=99
40930 K(N+1,5)=NEVFM
40931 MSTU(3)=1
40932
40933C...Reset statistics on Energy-Energy Correlation.
40934 ELSEIF(MTABU.EQ.40) THEN
40935 NEVEE=0
40936 DO 560 J=1,25
40937 FE1EC(J)=0D0
40938 FE2EC(J)=0D0
40939 FE1EC(51-J)=0D0
40940 FE2EC(51-J)=0D0
40941 FE1EA(J)=0D0
40942 FE2EA(J)=0D0
40943 560 CONTINUE
40944
40945C...Find particles to include, with proper assumed mass.
40946 ELSEIF(MTABU.EQ.41) THEN
40947 NEVEE=NEVEE+1
40948 NLOW=N+MSTU(3)
40949 NUPP=NLOW
40950 ECM=0D0
40951 DO 570 I=1,N
40952 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
40953 IF(MSTU(41).GE.2) THEN
40954 KC=PYCOMP(K(I,2))
40955 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40956 & KC.EQ.18) GOTO 570
40957 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40958 & PYCHGE(K(I,2)).EQ.0) GOTO 570
40959 ENDIF
40960 PMR=0D0
40961 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40962 IF(MSTU(42).GE.2) PMR=P(I,5)
40963 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40964 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40965 RETURN
40966 ENDIF
40967 NUPP=NUPP+1
40968 P(NUPP,1)=P(I,1)
40969 P(NUPP,2)=P(I,2)
40970 P(NUPP,3)=P(I,3)
40971 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40972 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
40973 ECM=ECM+P(NUPP,4)
40974 570 CONTINUE
40975 IF(NUPP.EQ.NLOW) RETURN
40976
40977C...Analyze Energy-Energy Correlation in event.
40978 FAC=(2D0/ECM**2)*50D0/PARU(1)
40979 DO 580 J=1,50
40980 FEVEE(J)=0D0
40981 580 CONTINUE
40982 DO 600 I1=NLOW+2,NUPP
40983 DO 590 I2=NLOW+1,I1-1
40984 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40985 & (P(I1,5)*P(I2,5))
40986 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
40987 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
40988 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
40989 590 CONTINUE
40990 600 CONTINUE
40991 DO 610 J=1,25
40992 FE1EC(J)=FE1EC(J)+FEVEE(J)
40993 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
40994 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
40995 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
40996 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
40997 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
40998 610 CONTINUE
40999 MSTU(62)=NUPP-NLOW
41000
41001C...Write statistics on Energy-Energy Correlation.
41002 ELSEIF(MTABU.EQ.42) THEN
41003 FAC=1D0/MAX(1,NEVEE)
41004 WRITE(MSTU(11),5700) NEVEE
41005 DO 620 J=1,25
41006 FEEC1=FAC*FE1EC(J)
41007 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
41008 FEEC2=FAC*FE1EC(51-J)
41009 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
41010 FEECA=FAC*FE1EA(J)
41011 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
41012 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
41013 & FEEC2,FEES2,FEECA,FEESA
41014 620 CONTINUE
41015
41016C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
41017 ELSEIF(MTABU.EQ.43) THEN
41018 FAC=1D0/MAX(1,NEVEE)
41019 DO 630 I=1,25
41020 K(I,1)=32
41021 K(I,2)=99
41022 K(I,3)=0
41023 K(I,4)=0
41024 K(I,5)=0
41025 P(I,1)=FAC*FE1EC(I)
41026 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
41027 P(I,2)=FAC*FE1EC(51-I)
41028 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
41029 P(I,3)=FAC*FE1EA(I)
41030 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
41031 P(I,4)=PARU(1)*(I-1)/50D0
41032 P(I,5)=PARU(1)*I/50D0
41033 V(I,4)=3.6D0*(I-1)
41034 V(I,5)=3.6D0*I
41035 630 CONTINUE
41036 N=25
41037 DO 640 J=1,5
41038 K(N+1,J)=0
41039 P(N+1,J)=0D0
41040 V(N+1,J)=0D0
41041 640 CONTINUE
41042 K(N+1,1)=32
41043 K(N+1,2)=99
41044 K(N+1,5)=NEVEE
41045 MSTU(3)=1
41046
41047C...Reset statistics on decay channels.
41048 ELSEIF(MTABU.EQ.50) THEN
41049 NEVDC=0
41050 NKFDC=0
41051 NREDC=0
41052
41053C...Identify and order flavour content of final state.
41054 ELSEIF(MTABU.EQ.51) THEN
41055 NEVDC=NEVDC+1
41056 NDS=0
41057 DO 670 I=1,N
41058 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
41059 NDS=NDS+1
41060 IF(NDS.GT.8) THEN
41061 NREDC=NREDC+1
41062 RETURN
41063 ENDIF
41064 KFM=2*IABS(K(I,2))
41065 IF(K(I,2).LT.0) KFM=KFM-1
41066 DO 650 IDS=NDS-1,1,-1
41067 IIN=IDS+1
41068 IF(KFM.LT.KFDM(IDS)) GOTO 660
41069 KFDM(IDS+1)=KFDM(IDS)
41070 650 CONTINUE
41071 IIN=1
41072 660 KFDM(IIN)=KFM
41073 670 CONTINUE
41074
41075C...Find whether old or new final state.
41076 DO 690 IDC=1,NKFDC
41077 IF(NDS.LT.KFDC(IDC,0)) THEN
41078 IKFDC=IDC
41079 GOTO 700
41080 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
41081 DO 680 I=1,NDS
41082 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
41083 IKFDC=IDC
41084 GOTO 700
41085 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
41086 GOTO 690
41087 ENDIF
41088 680 CONTINUE
41089 IKFDC=-IDC
41090 GOTO 700
41091 ENDIF
41092 690 CONTINUE
41093 IKFDC=NKFDC+1
41094 700 IF(IKFDC.LT.0) THEN
41095 IKFDC=-IKFDC
41096 ELSEIF(NKFDC.GE.200) THEN
41097 NREDC=NREDC+1
41098 RETURN
41099 ELSE
41100 DO 720 IDC=NKFDC,IKFDC,-1
41101 NPDC(IDC+1)=NPDC(IDC)
41102 DO 710 I=0,8
41103 KFDC(IDC+1,I)=KFDC(IDC,I)
41104 710 CONTINUE
41105 720 CONTINUE
41106 NKFDC=NKFDC+1
41107 KFDC(IKFDC,0)=NDS
41108 DO 730 I=1,NDS
41109 KFDC(IKFDC,I)=KFDM(I)
41110 730 CONTINUE
41111 NPDC(IKFDC)=0
41112 ENDIF
41113 NPDC(IKFDC)=NPDC(IKFDC)+1
41114
41115C...Write statistics on decay channels.
41116 ELSEIF(MTABU.EQ.52) THEN
41117 FAC=1D0/MAX(1,NEVDC)
41118 WRITE(MSTU(11),5900) NEVDC
41119 DO 750 IDC=1,NKFDC
41120 DO 740 I=1,KFDC(IDC,0)
41121 KFM=KFDC(IDC,I)
41122 KF=(KFM+1)/2
41123 IF(2*KF.NE.KFM) KF=-KF
41124 CALL PYNAME(KF,CHAU)
41125 CHDC(I)=CHAU(1:12)
41126 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
41127 740 CONTINUE
41128 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
41129 750 CONTINUE
41130 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
41131
41132C...Copy statistics on decay channels into /PYJETS/.
41133 ELSEIF(MTABU.EQ.53) THEN
41134 FAC=1D0/MAX(1,NEVDC)
41135 DO 780 IDC=1,NKFDC
41136 K(IDC,1)=32
41137 K(IDC,2)=99
41138 K(IDC,3)=0
41139 K(IDC,4)=0
41140 K(IDC,5)=KFDC(IDC,0)
41141 DO 760 J=1,5
41142 P(IDC,J)=0D0
41143 V(IDC,J)=0D0
41144 760 CONTINUE
41145 DO 770 I=1,KFDC(IDC,0)
41146 KFM=KFDC(IDC,I)
41147 KF=(KFM+1)/2
41148 IF(2*KF.NE.KFM) KF=-KF
41149 IF(I.LE.5) P(IDC,I)=KF
41150 IF(I.GE.6) V(IDC,I-5)=KF
41151 770 CONTINUE
41152 V(IDC,5)=FAC*NPDC(IDC)
41153 780 CONTINUE
41154 N=NKFDC
41155 DO 790 J=1,5
41156 K(N+1,J)=0
41157 P(N+1,J)=0D0
41158 V(N+1,J)=0D0
41159 790 CONTINUE
41160 K(N+1,1)=32
41161 K(N+1,2)=99
41162 K(N+1,5)=NEVDC
41163 V(N+1,5)=FAC*NREDC
41164 MSTU(3)=1
41165 ENDIF
41166
41167C...Format statements for output on unit MSTU(11) (default 6).
41168 5000 FORMAT(///20X,'Event statistics - initial state'/
41169 &20X,'based on an analysis of ',I6,' events'//
41170 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
41171 &'according to fragmenting system multiplicity'/
41172 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
41173 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
41174 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
41175 5200 FORMAT(///20X,'Event statistics - final state'/
41176 &20X,'based on an analysis of ',I7,' events'//
41177 &5X,'Mean primary multiplicity =',F10.4/
41178 &5X,'Mean final multiplicity =',F10.4/
41179 &5X,'Mean charged multiplicity =',F10.4//
41180 &5X,'Number of particles produced per event (directly and via ',
41181 &'decays/branchings)'/
41182 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
41183 &8X,'Total'/35X,'prim seco prim seco'/)
41184 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
41185 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
41186 &20X,'based on an analysis of ',I6,' events'//
41187 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
41188 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
41189 5500 FORMAT(10X)
41190 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
41191 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
41192 &20X,'based on an analysis of ',I6,' events'//
41193 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
41194 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
41195 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
41196 5900 FORMAT(///20X,'Decay channel analysis - final state'/
41197 &20X,'based on an analysis of ',I6,' events'//
41198 &2X,'Probability',10X,'Complete final state'/)
41199 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
41200 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
41201 &'or table overflow)')
41202
41203 RETURN
41204 END
41205
41206C*********************************************************************
41207
41208*$ CREATE PYEEVT.FOR
41209*COPY PYEEVT
41210C...PYEEVT
41211C...Handles the generation of an e+e- annihilation jet event.
41212
41213 SUBROUTINE PYEEVT(KFL,ECM)
41214C...Double precision and integer declarations.
41215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41216 INTEGER PYK,PYCHGE,PYCOMP
41217C...Commonblocks.
41218 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41219 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41220 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41221 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41222
41223C...Check input parameters.
41224 IF(MSTU(12).GE.1) CALL PYLIST(0)
41225 IF(KFL.LT.0.OR.KFL.GT.8) THEN
41226 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
41227 IF(MSTU(21).GE.1) RETURN
41228 ENDIF
41229 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
41230 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
41231 IF(ECM.LT.ECMMIN) THEN
41232 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
41233 IF(MSTU(21).GE.1) RETURN
41234 ENDIF
41235
41236C...Check consistency of MSTJ options set.
41237 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
41238 CALL PYERRM(6,
41239 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
41240 MSTJ(110)=1
41241 ENDIF
41242 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
41243 CALL PYERRM(6,
41244 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
41245 MSTJ(111)=0
41246 ENDIF
41247
41248C...Initialize alpha_strong and total cross-section.
41249 MSTU(111)=MSTJ(108)
41250 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
41251 &MSTU(111)=1
41252 PARU(112)=PARJ(121)
41253 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
41254 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
41255 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
41256 &XTOT)
41257 IF(MSTJ(116).GE.3) MSTJ(116)=1
41258 PARJ(171)=0D0
41259
41260C...Add initial e+e- to event record (documentation only).
41261 NTRY=0
41262 100 NTRY=NTRY+1
41263 IF(NTRY.GT.100) THEN
41264 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
41265 RETURN
41266 ENDIF
41267 MSTU(24)=0
41268 NC=0
41269 IF(MSTJ(115).GE.2) THEN
41270 NC=NC+2
41271 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
41272 K(NC-1,1)=21
41273 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
41274 K(NC,1)=21
41275 ENDIF
41276
41277C...Radiative photon (in initial state).
41278 MK=0
41279 ECMC=ECM
41280 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
41281 &THEK,PHIK,ALPK)
41282 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
41283 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
41284 NC=NC+1
41285 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
41286 K(NC,3)=MIN(MSTJ(115)/2,1)
41287 ENDIF
41288
41289C...Virtual exchange boson (gamma or Z0).
41290 IF(MSTJ(115).GE.3) THEN
41291 NC=NC+1
41292 KF=22
41293 IF(MSTJ(102).EQ.2) KF=23
41294 MSTU10=MSTU(10)
41295 MSTU(10)=1
41296 P(NC,5)=ECMC
41297 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
41298 K(NC,1)=21
41299 K(NC,3)=1
41300 MSTU(10)=MSTU10
41301 ENDIF
41302
41303C...Choice of flavour and jet configuration.
41304 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
41305 IF(KFLC.EQ.0) GOTO 100
41306 CALL PYXJET(ECMC,NJET,CUT)
41307 KFLN=21
41308 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
41309 &X12,X14)
41310 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
41311 IF(NJET.EQ.2) MSTJ(120)=1
41312
41313C...Fill jet configuration and origin.
41314 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
41315 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
41316 &ECMC)
41317 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
41318 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
41319 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41320 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
41321 &-KFLC,ECMC,X1,X2,X4,X12,X14)
41322 IF(MSTU(24).NE.0) GOTO 100
41323 DO 110 IP=NC+1,N
41324 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
41325 110 CONTINUE
41326
41327C...Angular orientation according to matrix element.
41328 IF(MSTJ(106).EQ.1) THEN
41329 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
41330 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
41331 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
41332 ENDIF
41333
41334C...Rotation and boost from radiative photon.
41335 IF(MK.EQ.1) THEN
41336 DBEK=-PAK/(ECM-PAK)
41337 NMIN=NC+1-MSTJ(115)/3
41338 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
41339 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
41340 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
41341 ENDIF
41342
41343C...Generate parton shower. Rearrange along strings and check.
41344 IF(MSTJ(101).EQ.5) THEN
41345 CALL PYSHOW(N-1,N,ECMC)
41346 MSTJ14=MSTJ(14)
41347 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
41348 IF(MSTJ(105).GE.0) MSTU(28)=0
41349 CALL PYPREP(0)
41350 MSTJ(14)=MSTJ14
41351 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
41352 ENDIF
41353
41354C...Fragmentation/decay generation. Information for PYTABU.
41355 IF(MSTJ(105).EQ.1) CALL PYEXEC
41356 MSTU(161)=KFLC
41357 MSTU(162)=-KFLC
41358
41359 RETURN
41360 END
41361
41362C*********************************************************************
41363
41364*$ CREATE PYXTEE.FOR
41365*COPY PYXTEE
41366C...PYXTEE
41367C...Calculates total cross-section, including initial state
41368C...radiation effects.
41369
41370 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
41371
41372C...Double precision and integer declarations.
41373 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41374 INTEGER PYK,PYCHGE,PYCOMP
41375C...Commonblocks.
41376 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41377 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41378 SAVE /PYDAT1/,/PYDAT2/
41379
41380C...Status, (optimized) Q^2 scale, alpha_strong.
41381 PARJ(151)=ECM
41382 MSTJ(119)=10*MSTJ(102)+KFL
41383 IF(MSTJ(111).EQ.0) THEN
41384 Q2R=ECM**2
41385 ELSEIF(MSTU(111).EQ.0) THEN
41386 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41387 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41388 Q2R=PARJ(168)*ECM**2
41389 ELSE
41390 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41391 & (2D0*PARU(112)/ECM)**2))
41392 Q2R=PARJ(168)*ECM**2
41393 ENDIF
41394 ALSPI=PYALPS(Q2R)/PARU(1)
41395
41396C...QCD corrections factor in R.
41397 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
41398 RQCD=1D0
41399 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
41400 RQCD=1D0+ALSPI
41401 ELSEIF(MSTJ(109).EQ.0) THEN
41402 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41403 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
41404 & LOG(PARJ(168))*ALSPI**2)
41405 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
41406 RQCD=1D0+(3D0/4D0)*ALSPI
41407 ELSE
41408 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
41409 ENDIF
41410
41411C...Calculate Z0 width if default value not acceptable.
41412 IF(MSTJ(102).GE.3) THEN
41413 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
41414 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
41415 DO 100 KFLC=5,6
41416 VQ=1D0
41417 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
41418 & (2D0*PYMASS(KFLC)/ ECM)**2))
41419 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
41420 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
41421 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
41422 100 CONTINUE
41423 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
41424 & (1D0-PARU(102)))
41425 ENDIF
41426
41427C...Calculate propagator and related constants for QFD case.
41428 POLL=1D0-PARJ(131)*PARJ(132)
41429 IF(MSTJ(102).GE.2) THEN
41430 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41431 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41432 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
41433 VE=4D0*PARU(102)-1D0
41434 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
41435 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41436 HF1I=SFI*SF1I
41437 HF1W=SFW*SF1W
41438 ENDIF
41439
41440C...Loop over different flavours: charge, velocity.
41441 RTOT=0D0
41442 RQQ=0D0
41443 RQV=0D0
41444 RVA=0D0
41445 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
41446 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
41447 MSTJ(93)=1
41448 PMQ=PYMASS(KFLC)
41449 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
41450 QF=KCHG(KFLC,1)/3D0
41451 VQ=1D0
41452 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
41453
41454C...Calculate R and sum of charges for QED or QFD case.
41455 RQQ=RQQ+3D0*QF**2*POLL
41456 IF(MSTJ(102).LE.1) THEN
41457 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
41458 ELSE
41459 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41460 RQV=RQV-6D0*QF*VF*SF1I
41461 RVA=RVA+3D0*(VF**2+1D0)*SF1W
41462 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
41463 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
41464 ENDIF
41465 110 CONTINUE
41466 RSUM=RQQ
41467 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
41468
41469C...Calculate cross-section, including QCD corrections.
41470 PARJ(141)=RQQ
41471 PARJ(142)=RTOT
41472 PARJ(143)=RTOT*RQCD
41473 PARJ(144)=PARJ(143)
41474 PARJ(145)=PARJ(141)*86.8D0/ECM**2
41475 PARJ(146)=PARJ(142)*86.8D0/ECM**2
41476 PARJ(147)=PARJ(143)*86.8D0/ECM**2
41477 PARJ(148)=PARJ(147)
41478 PARJ(157)=RSUM*RQCD
41479 PARJ(158)=0D0
41480 PARJ(159)=0D0
41481 XTOT=PARJ(147)
41482 IF(MSTJ(107).LE.0) RETURN
41483
41484C...Virtual cross-section.
41485 XKL=PARJ(135)
41486 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41487 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
41488 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
41489 &1.526D0*LOG(ECM**2/0.932D0)
41490
41491C...Soft and hard radiative cross-section in QED case.
41492 IF(MSTJ(102).LE.1) THEN
41493 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
41494 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
41495 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
41496
41497C...Soft and hard radiative cross-section in QFD case.
41498 ELSE
41499 SZM=1D0-(PARJ(123)/ECM)**2
41500 SZW=PARJ(123)*PARJ(124)/ECM**2
41501 PARJ(161)=-RQQ/RSUM
41502 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
41503 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
41504 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
41505 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
41506 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
41507 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
41508 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
41509 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
41510 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
41511 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
41512 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
41513 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
41514 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
41515 ENDIF
41516
41517C...Total cross-section and fraction of hard photon events.
41518 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
41519 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
41520 PARJ(144)=PARJ(157)
41521 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41522 XTOT=PARJ(148)
41523
41524 RETURN
41525 END
41526
41527C*********************************************************************
41528
41529*$ CREATE PYRADK.FOR
41530*COPY PYRADK
41531C...PYRADK
41532C...Generates initial state photon radiation.
41533
41534 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
41535
41536C...Double precision and integer declarations.
41537 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41538 INTEGER PYK,PYCHGE,PYCOMP
41539C...Commonblocks.
41540 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41541 SAVE /PYDAT1/
41542
41543C...Function: cumulative hard photon spectrum in QFD case.
41544 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
41545 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
41546
41547C...Determine whether radiative photon or not.
41548 MK=0
41549 PAK=0D0
41550 IF(PARJ(160).LT.PYR(0)) RETURN
41551 MK=1
41552
41553C...Photon energy range. Find photon momentum in QED case.
41554 XKL=PARJ(135)
41555 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41556 IF(MSTJ(102).LE.1) THEN
41557 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
41558 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
41559
41560C...Ditto in QFD case, by numerical inversion of integrated spectrum.
41561 ELSE
41562 SZM=1D0-(PARJ(123)/ECM)**2
41563 SZW=PARJ(123)*PARJ(124)/ECM**2
41564 FXKL=FXK(XKL)
41565 FXKU=FXK(XKU)
41566 FXKD=1D-4*(FXKU-FXKL)
41567 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
41568 NXK=0
41569 110 NXK=NXK+1
41570 XK=0.5D0*(XKL+XKU)
41571 FXKV=FXK(XK)
41572 IF(FXKV.GT.FXKR) THEN
41573 XKU=XK
41574 FXKU=FXKV
41575 ELSE
41576 XKL=XK
41577 FXKL=FXKV
41578 ENDIF
41579 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
41580 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
41581 ENDIF
41582 PAK=0.5D0*ECM*XK
41583
41584C...Photon polar and azimuthal angle.
41585 PME=2D0*(PYMASS(11)/ECM)**2
41586 120 CTHM=PME*(2D0/PME)**PYR(0)
41587 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
41588 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
41589 CTHE=1D0-CTHM
41590 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
41591 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
41592 THEK=PYANGL(CTHE,STHE)
41593 PHIK=PARU(2)*PYR(0)
41594
41595C...Rotation angle for hadronic system.
41596 SGN=1D0
41597 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
41598 &PYR(0)) SGN=-1D0
41599 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
41600 &(2D0-XK*(1D0-SGN*CTHE)))
41601
41602 RETURN
41603 END
41604
41605C*********************************************************************
41606
41607*$ CREATE PYXKFL.FOR
41608*COPY PYXKFL
41609C...PYXKFL
41610C...Selects flavour for produced qqbar pair.
41611
41612 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
41613
41614C...Double precision and integer declarations.
41615 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41616 INTEGER PYK,PYCHGE,PYCOMP
41617C...Commonblocks.
41618 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41619 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41620 SAVE /PYDAT1/,/PYDAT2/
41621
41622C...Calculate maximum weight in QED or QFD case.
41623 IF(MSTJ(102).LE.1) THEN
41624 RFMAX=4D0/9D0
41625 ELSE
41626 POLL=1D0-PARJ(131)*PARJ(132)
41627 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41628 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41629 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
41630 VE=4D0*PARU(102)-1D0
41631 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
41632 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41633 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
41634 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
41635 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
41636 & 1D0)*HF1W)
41637 ENDIF
41638
41639C...Choose flavour. Gives charge and velocity.
41640 NTRY=0
41641 100 NTRY=NTRY+1
41642 IF(NTRY.GT.100) THEN
41643 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
41644 KFLC=0
41645 RETURN
41646 ENDIF
41647 KFLC=KFL
41648 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
41649 MSTJ(93)=1
41650 PMQ=PYMASS(KFLC)
41651 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
41652 QF=KCHG(KFLC,1)/3D0
41653 VQ=1D0
41654 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
41655
41656C...Calculate weight in QED or QFD case.
41657 IF(MSTJ(102).LE.1) THEN
41658 RF=QF**2
41659 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
41660 ELSE
41661 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41662 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
41663 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
41664 & VQ**3*HF1W
41665 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
41666 ENDIF
41667
41668C...Weighting or new event (radiative photon). Cross-section update.
41669 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
41670 PARJ(158)=PARJ(158)+1D0
41671 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
41672 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
41673 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
41674 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
41675 PARJ(148)=PARJ(144)*86.8D0/ECM**2
41676
41677 RETURN
41678 END
41679
41680C*********************************************************************
41681
41682*$ CREATE PYXJET.FOR
41683*COPY PYXJET
41684C...PYXJET
41685C...Selects number of jets in matrix element approach.
41686
41687 SUBROUTINE PYXJET(ECM,NJET,CUT)
41688
41689C...Double precision and integer declarations.
41690 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41691 INTEGER PYK,PYCHGE,PYCOMP
41692C...Commonblocks.
41693 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41694 SAVE /PYDAT1/
41695C...Local array and data.
41696 DIMENSION ZHUT(5)
41697 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
41698
41699C...Trivial result for two-jets only, including parton shower.
41700 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41701 CUT=0D0
41702
41703C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
41704 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
41705 CF=4D0/3D0
41706 IF(MSTJ(109).EQ.2) CF=1D0
41707 IF(MSTJ(111).EQ.0) THEN
41708 Q2=ECM**2
41709 Q2R=ECM**2
41710 ELSEIF(MSTU(111).EQ.0) THEN
41711 PARJ(169)=MIN(1D0,PARJ(129))
41712 Q2=PARJ(169)*ECM**2
41713 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41714 & ((33D0-2D0*MSTU(112))*PARU(111)))))
41715 Q2R=PARJ(168)*ECM**2
41716 ELSE
41717 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
41718 Q2=PARJ(169)*ECM**2
41719 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41720 & (2D0*PARU(112)/ECM)**2))
41721 Q2R=PARJ(168)*ECM**2
41722 ENDIF
41723
41724C...alpha_strong for R and R itself.
41725 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
41726 IF(IABS(MSTJ(101)).EQ.1) THEN
41727 RQCD=1D0+ALSPI
41728 ELSEIF(MSTJ(109).EQ.0) THEN
41729 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41730 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
41731 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
41732 ELSE
41733 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
41734 ENDIF
41735
41736C...alpha_strong for jet rate. Initial value for y cut.
41737 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41738 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
41739 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
41740 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
41741 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41742
41743C...Parametrization of first order three-jet cross-section.
41744 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
41745 PARJ(152)=0D0
41746 ELSE
41747 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
41748 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
41749 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
41750 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
41751 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
41752 & PARJ(152)=0D0
41753 ENDIF
41754
41755C...Parametrization of second order three-jet cross-section.
41756 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
41757 & CUT.GE.0.25D0) THEN
41758 PARJ(153)=0D0
41759 ELSEIF(MSTJ(110).LE.1) THEN
41760 CT=LOG(1D0/CUT-2D0)
41761 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
41762 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
41763
41764C...Interpolation in second/first order ratio for Zhu parametrization.
41765 ELSEIF(MSTJ(110).EQ.2) THEN
41766 IZA=0
41767 DO 110 IY=1,5
41768 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41769 110 CONTINUE
41770 IF(IZA.NE.0) THEN
41771 ZHURAT=ZHUT(IZA)
41772 ELSE
41773 IZ=100D0*CUT
41774 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
41775 ENDIF
41776 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
41777 ENDIF
41778
41779C...Shift in second order three-jet cross-section with optimized Q^2.
41780 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
41781 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
41782 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
41783
41784C...Parametrization of second order four-jet cross-section.
41785 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
41786 PARJ(154)=0D0
41787 ELSE
41788 CT=LOG(1D0/CUT-5D0)
41789 IF(CUT.LE.0.018D0) THEN
41790 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
41791 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
41792 & 0.4059D0*CT**2)
41793 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
41794 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41795 ELSE
41796 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
41797 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
41798 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
41799 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
41800 & 0.002093D0*CT**3)
41801 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41802 ENDIF
41803 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
41804 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
41805 ENDIF
41806
41807C...If negative three-jet rate, change y' optimization parameter.
41808 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
41809 & PARJ(169).LT.0.99D0) THEN
41810 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41811 Q2=PARJ(169)*ECM**2
41812 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41813 GOTO 100
41814 ENDIF
41815
41816C...If too high cross-section, use harder cuts, or fail.
41817 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
41818 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
41819 & PARJ(169).LT.0.99D0) THEN
41820 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41821 Q2=PARJ(169)*ECM**2
41822 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41823 GOTO 100
41824 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
41825 CALL PYERRM(26,
41826 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
41827 ENDIF
41828 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
41829 & PARJ(154))**(-1D0/3D0)
41830 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41831 GOTO 100
41832 ENDIF
41833
41834C...Scalar gluon (first order only).
41835 ELSE
41836 ALSPI=PYALPS(ECM**2)/PARU(1)
41837 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
41838 PARJ(152)=0D0
41839 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
41840 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
41841 PARJ(153)=0D0
41842 PARJ(154)=0D0
41843 ENDIF
41844
41845C...Select number of jets.
41846 PARJ(150)=CUT
41847 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41848 NJET=2
41849 ELSEIF(MSTJ(101).LE.0) THEN
41850 NJET=MIN(4,2-MSTJ(101))
41851 ELSE
41852 RNJ=PYR(0)
41853 NJET=2
41854 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
41855 IF(PARJ(154).GT.RNJ) NJET=4
41856 ENDIF
41857
41858 RETURN
41859 END
41860
41861C*********************************************************************
41862
41863*$ CREATE PYX3JT.FOR
41864*COPY PYX3JT
41865C...PYX3JT
41866C...Selects the kinematical variables of three-jet events.
41867
41868 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
41869
41870C...Double precision and integer declarations.
41871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41872 INTEGER PYK,PYCHGE,PYCOMP
41873C...Commonblocks.
41874 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41875 SAVE /PYDAT1/
41876C...Local array.
41877 DIMENSION ZHUP(5,12)
41878
41879C...Coefficients of Zhu second order parametrization.
41880 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
41881 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
41882 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
41883 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
41884 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
41885 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
41886 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
41887 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
41888 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
41889 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
41890 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
41891
41892C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
41893 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
41894 &X**7/49D0
41895
41896C...Event type. Mass effect factors and other common constants.
41897 MSTJ(120)=2
41898 MSTJ(121)=0
41899 PMQ=PYMASS(KFL)
41900 QME=(2D0*PMQ/ECM)**2
41901 IF(MSTJ(109).NE.1) THEN
41902 CUTL=LOG(CUT)
41903 CUTD=LOG(1D0/CUT-2D0)
41904 IF(MSTJ(109).EQ.0) THEN
41905 CF=4D0/3D0
41906 CN=3D0
41907 TR=2D0
41908 WTMX=MIN(20D0,37D0-6D0*CUTD)
41909 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
41910 ELSE
41911 CF=1D0
41912 CN=0D0
41913 TR=12D0
41914 WTMX=0D0
41915 ENDIF
41916
41917C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
41918 ALS2PI=PARU(118)/PARU(2)
41919 WTOPT=0D0
41920 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
41921 & LOG(PARJ(169))*ALS2PI
41922 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
41923
41924C...Choose three-jet events in allowed region.
41925 100 NJET=3
41926 110 Y13L=CUTL+CUTD*PYR(0)
41927 Y23L=CUTL+CUTD*PYR(0)
41928 Y13=EXP(Y13L)
41929 Y23=EXP(Y23L)
41930 Y12=1D0-Y13-Y23
41931 IF(Y12.LE.CUT) GOTO 110
41932 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
41933
41934C...Second order corrections.
41935 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
41936 Y12L=LOG(Y12)
41937 Y13M=LOG(1D0-Y13)
41938 Y23M=LOG(1D0-Y23)
41939 Y12M=LOG(1D0-Y12)
41940 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
41941 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
41942 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
41943 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
41944 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
41945 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
41946 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
41947 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
41948 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
41949 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
41950 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
41951 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
41952 & TR*(2D0*CUTL/3D0-10D0/9D0)+
41953 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
41954 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
41955 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
41956 & Y13*Y23)/(Y12+Y13)**2)/WT1+
41957 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
41958 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
41959 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
41960 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
41961 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
41962 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
41963 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
41964 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41965 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41966 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
41967
41968 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
41969C...Second order corrections; Zhu parametrization of ERT.
41970 ZX=(Y23-Y13)**2
41971 ZY=1D0-Y12
41972 IZA=0
41973 DO 120 IY=1,5
41974 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41975 120 CONTINUE
41976 IF(IZA.NE.0) THEN
41977 IZ=IZA
41978 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41979 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41980 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41981 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41982 ELSE
41983 IZ=100D0*CUT
41984 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41985 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41986 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41987 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41988 IZ=IZ+1
41989 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41990 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41991 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41992 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41993 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
41994 ENDIF
41995 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41996 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41997 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
41998 ENDIF
41999
42000C...Impose mass cuts (gives two jets). For fixed jet number new try.
42001 X1=1D0-Y23
42002 X2=1D0-Y13
42003 X3=1D0-Y12
42004 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
42005 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
42006 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
42007 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
42008 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
42009
42010C...Scalar gluon model (first order only, no mass effects).
42011 ELSE
42012 130 NJET=3
42013 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
42014 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
42015 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
42016 X1=1D0-0.5D0*(X3+YD)
42017 X2=1D0-0.5D0*(X3-YD)
42018 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
42019 IF(MSTJ(102).GE.2) THEN
42020 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
42021 & X3**2*PYR(0)) NJET=2
42022 ENDIF
42023 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
42024 ENDIF
42025
42026 RETURN
42027 END
42028
42029C*********************************************************************
42030
42031*$ CREATE PYX4JT.FOR
42032*COPY PYX4JT
42033C...PYX4JT
42034C...Selects the kinematical variables of four-jet events.
42035
42036 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
42037
42038C...Double precision and integer declarations.
42039 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42040 INTEGER PYK,PYCHGE,PYCOMP
42041C...Commonblocks.
42042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42043 SAVE /PYDAT1/
42044C...Local arrays.
42045 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
42046
42047C...Common constants. Colour factors for QCD and Abelian gluon theory.
42048 PMQ=PYMASS(KFL)
42049 QME=(2D0*PMQ/ECM)**2
42050 CT=LOG(1D0/CUT-5D0)
42051 IF(MSTJ(109).EQ.0) THEN
42052 CF=4D0/3D0
42053 CN=3D0
42054 TR=2.5D0
42055 ELSE
42056 CF=1D0
42057 CN=0D0
42058 TR=15D0
42059 ENDIF
42060
42061C...Choice of process (qqbargg or qqbarqqbar).
42062 100 NJET=4
42063 IT=1
42064 IF(PARJ(155).GT.PYR(0)) IT=2
42065 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
42066 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
42067 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
42068 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
42069 ID=1
42070
42071C...Sample the five kinematical variables (for qqgg preweighted in y34).
42072 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
42073 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
42074 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
42075 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
42076 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
42077 VT=PYR(0)
42078 CP=COS(PARU(1)*PYR(0))
42079 Y14=(Y134-Y34)*VT
42080 Y13=Y134-Y14-Y34
42081 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
42082 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
42083 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
42084 Y23=Y234-Y34-Y24
42085 Y12=1D0-Y134-Y23-Y24
42086 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
42087 Y123=Y12+Y13+Y23
42088 Y124=Y12+Y14+Y24
42089
42090C...Calculate matrix elements for qqgg or qqqq process.
42091 IC=0
42092 WTTOT=0D0
42093 120 IC=IC+1
42094 IF(IT.EQ.1) THEN
42095 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
42096 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
42097 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
42098 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
42099 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
42100 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
42101 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
42102 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
42103 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
42104 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
42105 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
42106 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
42107 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
42108 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
42109 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
42110 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
42111 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
42112 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
42113 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
42114 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
42115 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
42116 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
42117 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
42118 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
42119 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
42120 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
42121 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
42122 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
42123 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
42124 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
42125 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
42126 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
42127 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
42128 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
42129 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
42130 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
42131 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
42132 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
42133 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
42134 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
42135 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
42136 & CN*WTC(IC))/8D0
42137 ELSE
42138 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
42139 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
42140 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
42141 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
42142 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
42143 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
42144 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
42145 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
42146 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
42147 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
42148 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
42149 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
42150 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
42151 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
42152 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
42153 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
42154 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
42155 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
42156 ENDIF
42157
42158C...Permutations of momenta in matrix element. Weighting.
42159 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
42160 YSAV=Y13
42161 Y13=Y14
42162 Y14=YSAV
42163 YSAV=Y23
42164 Y23=Y24
42165 Y24=YSAV
42166 YSAV=Y123
42167 Y123=Y124
42168 Y124=YSAV
42169 ENDIF
42170 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
42171 YSAV=Y13
42172 Y13=Y23
42173 Y23=YSAV
42174 YSAV=Y14
42175 Y14=Y24
42176 Y24=YSAV
42177 YSAV=Y134
42178 Y134=Y234
42179 Y234=YSAV
42180 ENDIF
42181 IF(IC.LE.3) GOTO 120
42182 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
42183 IC=5
42184
42185C...qqgg events: string configuration and event type.
42186 IF(IT.EQ.1) THEN
42187 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
42188 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
42189 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
42190 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
42191 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
42192 IF(ID.EQ.2) GOTO 130
42193 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
42194 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
42195 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
42196 IF(ID.EQ.2) GOTO 130
42197 ENDIF
42198 MSTJ(120)=3
42199 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
42200 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
42201 KFLN=21
42202
42203C...Mass cuts. Kinematical variables out.
42204 IF(Y12.LE.CUT+QME) NJET=2
42205 IF(NJET.EQ.2) GOTO 150
42206 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
42207 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
42208 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
42209 X2=1D0-Y124
42210 X12=(1D0-Q12)*Y13+Q12*Y23
42211 X14=Y12-0.5D0*QME
42212 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
42213
42214C...qqbarqqbar events: string configuration, choose new flavour.
42215 ELSE
42216 IF(ID.EQ.1) THEN
42217 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
42218 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
42219 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
42220 IF(WTR.LT.WTD(4)) ID=4
42221 IF(ID.GE.2) GOTO 130
42222 ENDIF
42223 MSTJ(120)=5
42224 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
42225 140 KFLN=1+INT(5D0*PYR(0))
42226 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
42227 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
42228 IF(KFLN.GT.MSTJ(104)) NJET=2
42229 PMQN=PYMASS(KFLN)
42230 QMEN=(2D0*PMQN/ECM)**2
42231
42232C...Mass cuts. Kinematical variables out.
42233 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
42234 IF(NJET.EQ.2) GOTO 150
42235 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
42236 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
42237 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
42238 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
42239 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
42240 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
42241 & Q13*Y23)
42242 X14=Y24-0.5D0*QME
42243 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
42244 & Q13*Y14)
42245 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
42246 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
42247 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
42248 ENDIF
42249 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
42250
42251 RETURN
42252 END
42253
42254C*********************************************************************
42255
42256*$ CREATE PYXDIF.FOR
42257*COPY PYXDIF
42258C...PYXDIF
42259C...Gives the angular orientation of events.
42260
42261 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
42262
42263C...Double precision and integer declarations.
42264 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42265 INTEGER PYK,PYCHGE,PYCOMP
42266C...Commonblocks.
42267 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42268 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42269 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42270 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42271
42272C...Charge. Factors depending on polarization for QED case.
42273 QF=KCHG(KFL,1)/3D0
42274 POLL=1D0-PARJ(131)*PARJ(132)
42275 POLD=PARJ(132)-PARJ(131)
42276 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
42277 HF1=POLL
42278 HF2=0D0
42279 HF3=PARJ(133)**2
42280 HF4=0D0
42281
42282C...Factors depending on flavour, energy and polarization for QFD case.
42283 ELSE
42284 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
42285 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
42286 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
42287 AE=-1D0
42288 VE=4D0*PARU(102)-1D0
42289 AF=SIGN(1D0,QF)
42290 VF=AF-4D0*QF*PARU(102)
42291 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
42292 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
42293 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
42294 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
42295 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
42296 & SFW*SFF**2*(VE**2-AE**2))
42297 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
42298 & SFF*AE
42299 ENDIF
42300
42301C...Mass factor. Differential cross-sections for two-jet events.
42302 SQ2=SQRT(2D0)
42303 QME=0D0
42304 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
42305 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
42306 IF(NJET.EQ.2) THEN
42307 SIGU=4D0*SQRT(1D0-QME)
42308 SIGL=2D0*QME*SQRT(1D0-QME)
42309 SIGT=0D0
42310 SIGI=0D0
42311 SIGA=0D0
42312 SIGP=4D0
42313
42314C...Kinematical variables. Reduce four-jet event to three-jet one.
42315 ELSE
42316 IF(NJET.EQ.3) THEN
42317 X1=2D0*P(NC+1,4)/ECM
42318 X2=2D0*P(NC+3,4)/ECM
42319 ELSE
42320 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
42321 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
42322 X1=2D0*P(NC+1,4)/ECMR
42323 X2=2D0*P(NC+4,4)/ECMR
42324 ENDIF
42325
42326C...Differential cross-sections for three-jet (or reduced four-jet).
42327 XQ=(1D0-X1)/(1D0-X2)
42328 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
42329 ST12=SQRT(1D0-CT12**2)
42330 IF(MSTJ(109).NE.1) THEN
42331 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
42332 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
42333 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
42334 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
42335 & X2)*XQ
42336 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
42337 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
42338 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
42339 SIGA=X2**2*ST12/SQ2
42340 SIGP=2D0*(X1**2-X2**2*CT12)
42341
42342C...Differential cross-sect for scalar gluons (no mass effects).
42343 ELSE
42344 X3=2D0-X1-X2
42345 XT=X2*ST12
42346 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
42347 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
42348 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
42349 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
42350 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
42351 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
42352 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
42353 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
42354 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
42355 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
42356 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
42357 ENDIF
42358 ENDIF
42359
42360C...Upper bounds for differential cross-section.
42361 HF1A=ABS(HF1)
42362 HF2A=ABS(HF2)
42363 HF3A=ABS(HF3)
42364 HF4A=ABS(HF4)
42365 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
42366 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
42367 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
42368 &2D0*HF2A*ABS(SIGP)
42369
42370C...Generate angular orientation according to differential cross-sect.
42371 100 CHI=PARU(2)*PYR(0)
42372 CTHE=2D0*PYR(0)-1D0
42373 PHI=PARU(2)*PYR(0)
42374 CCHI=COS(CHI)
42375 SCHI=SIN(CHI)
42376 C2CHI=COS(2D0*CHI)
42377 S2CHI=SIN(2D0*CHI)
42378 THE=ACOS(CTHE)
42379 STHE=SIN(THE)
42380 C2PHI=COS(2D0*(PHI-PARJ(134)))
42381 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42382 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
42383 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
42384 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
42385 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
42386 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
42387 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
42388 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
42389 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
42390
42391 RETURN
42392 END
42393
42394C*********************************************************************
42395
42396*$ CREATE PYONIA.FOR
42397*COPY PYONIA
42398C...PYONIA
42399C...Generates Upsilon and toponium decays into three gluons
42400C...or two gluons and a photon.
42401
42402 SUBROUTINE PYONIA(KFL,ECM)
42403
42404C...Double precision and integer declarations.
42405 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42406 INTEGER PYK,PYCHGE,PYCOMP
42407C...Commonblocks.
42408 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42409 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42410 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42411 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42412
42413C...Printout. Check input parameters.
42414 IF(MSTU(12).GE.1) CALL PYLIST(0)
42415 IF(KFL.LT.0.OR.KFL.GT.8) THEN
42416 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
42417 IF(MSTU(21).GE.1) RETURN
42418 ENDIF
42419 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
42420 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
42421 IF(MSTU(21).GE.1) RETURN
42422 ENDIF
42423
42424C...Initial e+e- and onium state (optional).
42425 NC=0
42426 IF(MSTJ(115).GE.2) THEN
42427 NC=NC+2
42428 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
42429 K(NC-1,1)=21
42430 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
42431 K(NC,1)=21
42432 ENDIF
42433 KFLC=IABS(KFL)
42434 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
42435 NC=NC+1
42436 KF=110*KFLC+3
42437 MSTU10=MSTU(10)
42438 MSTU(10)=1
42439 P(NC,5)=ECM
42440 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
42441 K(NC,1)=21
42442 K(NC,3)=1
42443 MSTU(10)=MSTU10
42444 ENDIF
42445
42446C...Choose x1 and x2 according to matrix element.
42447 NTRY=0
42448 100 X1=PYR(0)
42449 X2=PYR(0)
42450 X3=2D0-X1-X2
42451 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
42452 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
42453 NTRY=NTRY+1
42454 NJET=3
42455 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
42456 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
42457
42458C...Photon-gluon-gluon events. Small system modifications. Jet origin.
42459 MSTU(111)=MSTJ(108)
42460 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
42461 &MSTU(111)=1
42462 PARU(112)=PARJ(121)
42463 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
42464 QF=0D0
42465 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
42466 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
42467 MK=0
42468 ECMC=ECM
42469 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
42470 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
42471 & NJET=2
42472 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
42473 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
42474 ELSE
42475 MK=1
42476 ECMC=SQRT(1D0-X1)*ECM
42477 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
42478 K(NC+1,1)=1
42479 K(NC+1,2)=22
42480 K(NC+1,4)=0
42481 K(NC+1,5)=0
42482 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
42483 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
42484 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
42485 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
42486 NJET=2
42487 IF(ECMC.LT.4D0*PARJ(127)) THEN
42488 MSTU10=MSTU(10)
42489 MSTU(10)=1
42490 P(NC+2,5)=ECMC
42491 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
42492 MSTU(10)=MSTU10
42493 NJET=0
42494 ENDIF
42495 ENDIF
42496 DO 110 IP=NC+1,N
42497 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
42498 110 CONTINUE
42499
42500C...Differential cross-sections. Upper limit for cross-section.
42501 IF(MSTJ(106).EQ.1) THEN
42502 SQ2=SQRT(2D0)
42503 HF1=1D0-PARJ(131)*PARJ(132)
42504 HF3=PARJ(133)**2
42505 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
42506 ST13=SQRT(1D0-CT13**2)
42507 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
42508 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
42509 SIGT=0.5D0*SIGL
42510 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
42511 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
42512 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
42513
42514C...Angular orientation of event.
42515 120 CHI=PARU(2)*PYR(0)
42516 CTHE=2D0*PYR(0)-1D0
42517 PHI=PARU(2)*PYR(0)
42518 CCHI=COS(CHI)
42519 SCHI=SIN(CHI)
42520 C2CHI=COS(2D0*CHI)
42521 S2CHI=SIN(2D0*CHI)
42522 THE=ACOS(CTHE)
42523 STHE=SIN(THE)
42524 C2PHI=COS(2D0*(PHI-PARJ(134)))
42525 S2PHI=SIN(2D0*(PHI-PARJ(134)))
42526 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
42527 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
42528 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
42529 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
42530 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
42531 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
42532 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
42533 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
42534 ENDIF
42535
42536C...Generate parton shower. Rearrange along strings and check.
42537 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
42538 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
42539 MSTJ14=MSTJ(14)
42540 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
42541 IF(MSTJ(105).GE.0) MSTU(28)=0
42542 CALL PYPREP(0)
42543 MSTJ(14)=MSTJ14
42544 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
42545 ENDIF
42546
42547C...Generate fragmentation. Information for PYTABU:
42548 IF(MSTJ(105).EQ.1) CALL PYEXEC
42549 MSTU(161)=110*KFLC+3
42550 MSTU(162)=0
42551
42552 RETURN
42553 END
42554
42555C*********************************************************************
42556
42557*$ CREATE PYBOOK.FOR
42558*COPY PYBOOK
42559C...PYBOOK
42560C...Books a histogram.
42561
42562 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
42563
42564C...Double precision declaration.
42565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42566C...Commonblock.
42567 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42568 SAVE /PYBINS/
42569C...Local character variables.
42570 CHARACTER TITLE*(*), TITFX*60
42571
42572C...Check that input is sensible. Find initial address in memory.
42573 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42574 &'(PYBOOK:) not allowed histogram number')
42575 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
42576 &'(PYBOOK:) not allowed number of bins')
42577 IF(XL.GE.XU) CALL PYERRM(28,
42578 &'(PYBOOK:) x limits in wrong order')
42579 INDX(ID)=IHIST(4)
42580 IHIST(4)=IHIST(4)+28+NX
42581 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
42582 &'(PYBOOK:) out of histogram space')
42583 IS=INDX(ID)
42584
42585C...Store histogram size and reset contents.
42586 BIN(IS+1)=NX
42587 BIN(IS+2)=XL
42588 BIN(IS+3)=XU
42589 BIN(IS+4)=(XU-XL)/NX
42590 CALL PYNULL(ID)
42591
42592C...Store title by conversion to integer to double precision.
42593 TITFX=TITLE//' '
42594 DO 100 IT=1,20
42595 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
42596 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
42597 100 CONTINUE
42598
42599 RETURN
42600 END
42601
42602C*********************************************************************
42603
42604*$ CREATE PYFILL.FOR
42605*COPY PYFILL
42606C...PYFILL
42607C...Fills entry in histogram.
42608
42609 SUBROUTINE PYFILL(ID,X,W)
42610
42611C...Double precision declaration.
42612 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42613C...Commonblock.
42614 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42615 SAVE /PYBINS/
42616
42617C...Find initial address in memory. Increase number of entries.
42618 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42619 &'(PYFILL:) not allowed histogram number')
42620 IS=INDX(ID)
42621 IF(IS.EQ.0) CALL PYERRM(28,
42622 &'(PYFILL:) filling unbooked histogram')
42623 BIN(IS+5)=BIN(IS+5)+1D0
42624
42625C...Find bin in x, including under/overflow, and fill.
42626 IF(X.LT.BIN(IS+2)) THEN
42627 BIN(IS+6)=BIN(IS+6)+W
42628 ELSEIF(X.GE.BIN(IS+3)) THEN
42629 BIN(IS+8)=BIN(IS+8)+W
42630 ELSE
42631 BIN(IS+7)=BIN(IS+7)+W
42632 IX=(X-BIN(IS+2))/BIN(IS+4)
42633 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
42634 BIN(IS+9+IX)=BIN(IS+9+IX)+W
42635 ENDIF
42636
42637 RETURN
42638 END
42639
42640C*********************************************************************
42641
42642*$ CREATE PYFACT.FOR
42643*COPY PYFACT
42644C...PYFACT
42645C...Multiplies histogram contents by factor.
42646
42647 SUBROUTINE PYFACT(ID,F)
42648
42649C...Double precision declaration.
42650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42651C...Commonblock.
42652 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42653 SAVE /PYBINS/
42654
42655C...Find initial address in memory. Multiply all contents bins.
42656 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42657 &'(PYFACT:) not allowed histogram number')
42658 IS=INDX(ID)
42659 IF(IS.EQ.0) CALL PYERRM(28,
42660 &'(PYFACT:) scaling unbooked histogram')
42661 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
42662 BIN(IX)=F*BIN(IX)
42663 100 CONTINUE
42664
42665 RETURN
42666 END
42667
42668C*********************************************************************
42669
42670*$ CREATE PYOPER.FOR
42671*COPY PYOPER
42672C...PYOPER
42673C...Performs operations between histograms.
42674
42675 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
42676
42677C...Double precision declaration.
42678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42679C...Commonblock.
42680 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42681 SAVE /PYBINS/
42682C...Character variable.
42683 CHARACTER OPER*(*)
42684
42685C...Find initial addresses in memory, and histogram size.
42686 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
42687 &'(PYFACT:) not allowed histogram number')
42688 IS1=INDX(ID1)
42689 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
42690 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
42691 NX=NINT(BIN(IS3+1))
42692 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
42693
42694C...Update info on number of histogram entries.
42695 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
42696 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
42697 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
42698 BIN(IS3+5)=BIN(IS1+5)
42699 ENDIF
42700
42701C...Operations on pair of histograms: addition, subtraction,
42702C...multiplication, division.
42703 IF(OPER.EQ.'+') THEN
42704 DO 100 IX=6,8+NX
42705 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
42706 100 CONTINUE
42707 ELSEIF(OPER.EQ.'-') THEN
42708 DO 110 IX=6,8+NX
42709 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
42710 110 CONTINUE
42711 ELSEIF(OPER.EQ.'*') THEN
42712 DO 120 IX=6,8+NX
42713 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
42714 120 CONTINUE
42715 ELSEIF(OPER.EQ.'/') THEN
42716 DO 130 IX=6,8+NX
42717 FA2=F2*BIN(IS2+IX)
42718 IF(ABS(FA2).LE.1D-20) THEN
42719 BIN(IS3+IX)=0D0
42720 ELSE
42721 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
42722 ENDIF
42723 130 CONTINUE
42724
42725C...Operations on single histogram: multiplication+addition,
42726C...square root+addition, logarithm+addition.
42727 ELSEIF(OPER.EQ.'A') THEN
42728 DO 140 IX=6,8+NX
42729 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
42730 140 CONTINUE
42731 ELSEIF(OPER.EQ.'S') THEN
42732 DO 150 IX=6,8+NX
42733 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
42734 150 CONTINUE
42735 ELSEIF(OPER.EQ.'L') THEN
42736 ZMIN=1D20
42737 DO 160 IX=9,8+NX
42738 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
42739 & ZMIN=0.8D0*BIN(IS1+IX)
42740 160 CONTINUE
42741 DO 170 IX=6,8+NX
42742 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
42743 170 CONTINUE
42744
42745C...Operation on two or three histograms: average and
42746C...standard deviation.
42747 ELSEIF(OPER.EQ.'M') THEN
42748 DO 180 IX=6,8+NX
42749 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42750 BIN(IS2+IX)=0D0
42751 ELSE
42752 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
42753 ENDIF
42754 IF(ID3.NE.0) THEN
42755 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42756 BIN(IS3+IX)=0D0
42757 ELSE
42758 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
42759 & BIN(IS2+IX)**2))
42760 ENDIF
42761 ENDIF
42762 BIN(IS1+IX)=F1*BIN(IS1+IX)
42763 180 CONTINUE
42764 ENDIF
42765
42766 RETURN
42767 END
42768
42769C*********************************************************************
42770
42771*$ CREATE PYHIST.FOR
42772*COPY PYHIST
42773C...PYHIST
42774C...Prints and resets all histograms.
42775
42776 SUBROUTINE PYHIST
42777
42778C...Double precision declaration.
42779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42780C...Commonblock.
42781 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42782 SAVE /PYBINS/
42783
42784C...Loop over histograms, print and reset used ones.
42785 DO 100 ID=1,IHIST(1)
42786 IS=INDX(ID)
42787 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
42788 CALL PYPLOT(ID)
42789 CALL PYNULL(ID)
42790 ENDIF
42791 100 CONTINUE
42792
42793 RETURN
42794 END
42795
42796C*********************************************************************
42797
42798*$ CREATE PYPLOT.FOR
42799*COPY PYPLOT
42800C...PYPLOT
42801C...Prints a histogram (but does not reset it).
42802
42803 SUBROUTINE PYPLOT(ID)
42804
42805C...Double precision declaration.
42806 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42807C...Commonblocks.
42808 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42809 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42810 SAVE /PYDAT1/,/PYBINS/
42811C...Local arrays and character variables.
42812 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
42813 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
42814
42815C...Steps in histogram scale. Character sequence.
42816 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
42817 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
42818
42819C...Find initial address in memory; skip if empty histogram.
42820 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42821 IS=INDX(ID)
42822 IF(IS.EQ.0) RETURN
42823 IF(NINT(BIN(IS+5)).LE.0) THEN
42824 WRITE(MSTU(11),5000) ID
42825 RETURN
42826 ENDIF
42827
42828C...Number of histogram lines and x bins.
42829 LIN=IHIST(3)-18
42830 NX=NINT(BIN(IS+1))
42831
42832C...Extract title by conversion from double precision via integer.
42833 DO 100 IT=1,20
42834 IEQ=NINT(BIN(IS+8+NX+IT))
42835 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
42836 & //CHAR(MOD(IEQ,256))
42837 100 CONTINUE
42838
42839C...Find time; print title.
42840 CALL PYTIME(IDATI)
42841 IF(IDATI(1).GT.0) THEN
42842 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
42843 ELSE
42844 WRITE(MSTU(11),5200) ID, TITLE
42845 ENDIF
42846
42847C...Find minimum and maximum bin content.
42848 YMIN=BIN(IS+9)
42849 YMAX=BIN(IS+9)
42850 DO 110 IX=IS+10,IS+8+NX
42851 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
42852 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
42853 110 CONTINUE
42854
42855C...Determine scale and step size for y axis.
42856 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
42857 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
42858 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
42859 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
42860 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
42861 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
42862 DELY=DYAC(1)
42863 DO 120 IDEL=1,9
42864 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
42865 120 CONTINUE
42866 DY=DELY*10D0**IPOT
42867
42868C...Convert bin contents to integer form; fractional fill in top row.
42869 DO 130 IX=1,NX
42870 CTA=ABS(BIN(IS+8+IX))/DY
42871 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
42872 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
42873 130 CONTINUE
42874 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
42875 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
42876
42877C...Print histogram row by row.
42878 DO 150 IR=IRMA,IRMI,-1
42879 IF(IR.EQ.0) GOTO 150
42880 OUT=' '
42881 DO 140 IX=1,NX
42882 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
42883 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
42884 140 CONTINUE
42885 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
42886 150 CONTINUE
42887
42888C...Print sign and value of bin contents.
42889 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
42890 OUT=' '
42891 DO 160 IX=1,NX
42892 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
42893 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
42894 160 CONTINUE
42895 WRITE(MSTU(11),5400) OUT
42896 DO 180 IR=4,1,-1
42897 DO 170 IX=1,NX
42898 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42899 170 CONTINUE
42900 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
42901 180 CONTINUE
42902
42903C...Print sign and value of lower bin edge.
42904 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
42905 & 10.0001D0)-10
42906 OUT=' '
42907 DO 190 IX=1,NX
42908 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
42909 & OUT(IX:IX)=CHA(11)
42910 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
42911 190 CONTINUE
42912 WRITE(MSTU(11),5600) OUT
42913 DO 210 IR=3,1,-1
42914 DO 200 IX=1,NX
42915 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42916 200 CONTINUE
42917 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
42918 210 CONTINUE
42919 ENDIF
42920
42921C...Calculate and print statistics.
42922 CSUM=0D0
42923 CXSUM=0D0
42924 CXXSUM=0D0
42925 DO 220 IX=1,NX
42926 CTA=ABS(BIN(IS+8+IX))
42927 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
42928 CSUM=CSUM+CTA
42929 CXSUM=CXSUM+CTA*X
42930 CXXSUM=CXXSUM+CTA*X**2
42931 220 CONTINUE
42932 XMEAN=CXSUM/MAX(CSUM,1D-20)
42933 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
42934 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
42935 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
42936
42937C...Formats for output.
42938 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
42939 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
42940 &I2,':',I2/)
42941 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
42942 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
42943 5400 FORMAT(/8X,'Contents',3X,A100)
42944 5500 FORMAT(9X,'*10**',I2,3X,A100)
42945 5600 FORMAT(/8X,'Low edge',3X,A100)
42946 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
42947 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
42948 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
42949
42950 RETURN
42951 END
42952
42953C*********************************************************************
42954
42955*$ CREATE PYNULL.FOR
42956*COPY PYNULL
42957C...PYNULL
42958C...Resets bin contents of a histogram.
42959
42960 SUBROUTINE PYNULL(ID)
42961
42962C...Double precision declaration.
42963 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42964C...Commonblock.
42965 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42966 SAVE /PYBINS/
42967
42968 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42969 IS=INDX(ID)
42970 IF(IS.EQ.0) RETURN
42971 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
42972 BIN(IX)=0D0
42973 100 CONTINUE
42974
42975 RETURN
42976 END
42977
42978C*********************************************************************
42979
42980*$ CREATE PYDUMP.FOR
42981*COPY PYDUMP
42982C...PYDUMP
42983C...Dumps histogram contents on file for reading by other program.
42984C...Can also read back own dump.
42985
42986 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
42987
42988C...Double precision declaration.
42989 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42990C...Commonblock.
42991 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42992 SAVE /PYBINS/
42993C...Local arrays and character variables.
42994 DIMENSION IHI(*),ISS(100),VAL(5)
42995 CHARACTER TITLE*60,FORMAT*13
42996
42997C...Dump all histograms that have been booked,
42998C...including titles and ranges, one after the other.
42999 IF(MDUMP.EQ.1) THEN
43000
43001C...Loop over histograms and find which are wanted and booked.
43002 IF(NHI.LE.0) THEN
43003 NW=IHIST(1)
43004 ELSE
43005 NW=NHI
43006 ENDIF
43007 DO 130 IW=1,NW
43008 IF(NHI.EQ.0) THEN
43009 ID=IW
43010 ELSE
43011 ID=IHI(IW)
43012 ENDIF
43013 IS=INDX(ID)
43014 IF(IS.NE.0) THEN
43015
43016C...Write title, histogram size, filling statistics.
43017 NX=NINT(BIN(IS+1))
43018 DO 100 IT=1,20
43019 IEQ=NINT(BIN(IS+8+NX+IT))
43020 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
43021 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
43022 100 CONTINUE
43023 WRITE(LFN,5100) ID,TITLE
43024 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
43025 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
43026 & BIN(IS+8)
43027
43028
43029C...Write histogram contents, in groups of five.
43030 DO 120 IXG=1,(NX+4)/5
43031 DO 110 IXV=1,5
43032 IX=5*IXG+IXV-5
43033 IF(IX.LE.NX) THEN
43034 VAL(IXV)=BIN(IS+8+IX)
43035 ELSE
43036 VAL(IXV)=0D0
43037 ENDIF
43038 110 CONTINUE
43039 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
43040 120 CONTINUE
43041
43042C...Go to next histogram; finish.
43043 ELSEIF(NHI.GT.0) THEN
43044 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
43045 ENDIF
43046 130 CONTINUE
43047
43048C...Read back in histograms dumped MDUMP=1.
43049 ELSEIF(MDUMP.EQ.2) THEN
43050
43051C...Read histogram number, title and range, and book.
43052 140 READ(LFN,5100,END=170) ID,TITLE
43053 READ(LFN,5200) NX,XL,XU
43054 CALL PYBOOK(ID,TITLE,NX,XL,XU)
43055 IS=INDX(ID)
43056
43057C...Read filling statistics.
43058 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
43059 BIN(IS+5)=DBLE(NENTRY)
43060
43061C...Read histogram contents, in groups of five.
43062 DO 160 IXG=1,(NX+4)/5
43063 READ(LFN,5400) (VAL(IXV),IXV=1,5)
43064 DO 150 IXV=1,5
43065 IX=5*IXG+IXV-5
43066 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
43067 150 CONTINUE
43068 160 CONTINUE
43069
43070C...Go to next histogram; finish.
43071 GOTO 140
43072 170 CONTINUE
43073
43074C...Write histogram contents in column format,
43075C...convenient e.g. for GNUPLOT input.
43076 ELSEIF(MDUMP.EQ.3) THEN
43077
43078C...Find addresses to wanted histograms.
43079 NSS=0
43080 IF(NHI.LE.0) THEN
43081 NW=IHIST(1)
43082 ELSE
43083 NW=NHI
43084 ENDIF
43085 DO 180 IW=1,NW
43086 IF(NHI.EQ.0) THEN
43087 ID=IW
43088 ELSE
43089 ID=IHI(IW)
43090 ENDIF
43091 IS=INDX(ID)
43092 IF(IS.NE.0.AND.NSS.LT.100) THEN
43093 NSS=NSS+1
43094 ISS(NSS)=IS
43095 ELSEIF(NSS.GE.100) THEN
43096 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
43097 ELSEIF(NHI.GT.0) THEN
43098 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
43099 ENDIF
43100 180 CONTINUE
43101
43102C...Check that they have common number of x bins. Fix format.
43103 NX=NINT(BIN(ISS(1)+1))
43104 DO 190 IW=2,NSS
43105 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
43106 CALL PYERRM(8,'(PYDUMP:) different number of bins')
43107 RETURN
43108 ENDIF
43109 190 CONTINUE
43110 FORMAT='(1P,000E12.4)'
43111 WRITE(FORMAT(5:7),'(I3)') NSS+1
43112
43113C...Write histogram contents; first column x values.
43114 DO 200 IX=1,NX
43115 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
43116 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
43117 200 CONTINUE
43118
43119 ENDIF
43120
43121C...Formats for output.
43122 5100 FORMAT(I5,5X,A60)
43123 5200 FORMAT(I5,1P,2D12.4)
43124 5300 FORMAT(I12,1P,3D12.4)
43125 5400 FORMAT(1P,5D12.4)
43126
43127 RETURN
43128 END
43129
43130C*********************************************************************
43131
43132*$ CREATE PYKCUT.FOR
43133*COPY PYKCUT
43134C...PYKCUT
43135C...Dummy routine, which the user can replace in order to make cuts on
43136C...the kinematics on the parton level before the matrix elements are
43137C...evaluated and the event is generated. The cross-section estimates
43138C...will automatically take these cuts into account, so the given
43139C...values are for the allowed phase space region only. MCUT=0 means
43140C...that the event has passed the cuts, MCUT=1 that it has failed.
43141
43142 SUBROUTINE PYKCUT(MCUT)
43143
43144C...Double precision and integer declarations.
43145 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43146 INTEGER PYK,PYCHGE,PYCOMP
43147C...Commonblocks.
43148 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43149 COMMON/PYINT1/MINT(400),VINT(400)
43150 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43151 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
43152
43153C...Set default value (accepting event) for MCUT.
43154 MCUT=0
43155
43156C...Read out subprocess number.
43157 ISUB=MINT(1)
43158 ISTSB=ISET(ISUB)
43159
43160C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
43161 TAU=VINT(21)
43162 YST=VINT(22)
43163 CTH=0D0
43164 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
43165 TAUP=0D0
43166 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
43167
43168C...Calculate x_1, x_2, x_F.
43169 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
43170 X1=SQRT(TAU)*EXP(YST)
43171 X2=SQRT(TAU)*EXP(-YST)
43172 ELSE
43173 X1=SQRT(TAUP)*EXP(YST)
43174 X2=SQRT(TAUP)*EXP(-YST)
43175 ENDIF
43176 XF=X1-X2
43177
43178C...Calculate shat, that, uhat, p_T^2.
43179 SHAT=TAU*VINT(2)
43180 SQM3=VINT(63)
43181 SQM4=VINT(64)
43182 RM3=SQM3/SHAT
43183 RM4=SQM4/SHAT
43184 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
43185 RPTS=4D0*VINT(71)**2/SHAT
43186 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
43187 RM34=2D0*RM3*RM4
43188 RSQM=1D0+RM34
43189 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
43190 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
43191 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
43192 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
43193
43194C...Decisions by user to be put here.
43195
43196C...Stop program if this routine is ever called.
43197C...You should not copy these lines to your own routine.
43198 WRITE(MSTU(11),5000)
43199 IF(PYR(0).LT.10D0) STOP
43200
43201C...Format for error printout.
43202 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
43203 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43204 &1X,'Execution stopped!')
43205
43206 RETURN
43207 END
43208
43209C*********************************************************************
43210
43211*$ CREATE PYEVWT.FOR
43212*COPY PYEVWT
43213C...PYEVWT
43214C...Dummy routine, which the user can replace in order to multiply the
43215C...standard PYTHIA differential cross-section by a process- and
43216C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
43217C...to generation of weighted events, with weight 1/WTXS, while for
43218C...MSTP(142)=2 it corresponds to a modification of the underlying
43219C...physics.
43220
43221 SUBROUTINE PYEVWT(WTXS)
43222
43223C...Double precision and integer declarations.
43224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43225 INTEGER PYK,PYCHGE,PYCOMP
43226C...Commonblocks.
43227 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43228 COMMON/PYINT1/MINT(400),VINT(400)
43229 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43230 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
43231
43232C...Set default weight for WTXS.
43233 WTXS=1D0
43234
43235C...Read out subprocess number.
43236 ISUB=MINT(1)
43237 ISTSB=ISET(ISUB)
43238
43239C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
43240 TAU=VINT(21)
43241 YST=VINT(22)
43242 CTH=0D0
43243 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
43244 TAUP=0D0
43245 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
43246
43247C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
43248 X1=VINT(41)
43249 X2=VINT(42)
43250 XF=X1-X2
43251 SHAT=VINT(44)
43252 THAT=VINT(45)
43253 UHAT=VINT(46)
43254 PT2=VINT(48)
43255
43256C...Modifications by user to be put here.
43257
43258C...Stop program if this routine is ever called.
43259C...You should not copy these lines to your own routine.
43260 WRITE(MSTU(11),5000)
43261 IF(PYR(0).LT.10D0) STOP
43262
43263C...Format for error printout.
43264 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
43265 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43266 &1X,'Execution stopped!')
43267
43268 RETURN
43269 END
43270
43271C*********************************************************************
43272
43273*$ CREATE PYUPIN.FOR
43274*COPY PYUPIN
43275C...PYUPIN
43276C...Dummy copy of routine to be called by user to set up a user-defined
43277C...process.
43278
43279 SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
43280
43281C...Double precision and integer declarations.
43282 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43283 INTEGER PYK,PYCHGE,PYCOMP
43284C...Commonblocks.
43285 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43286 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43287 COMMON/PYINT6/PROC(0:500)
43288 CHARACTER PROC*28
43289 SAVE /PYDAT1/,/PYINT2/,/PYINT6/
43290C...Local character variable.
43291 CHARACTER*(*) TITLE
43292
43293C...Check that subprocess number free.
43294 IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
43295 WRITE(MSTU(11),5000) ISUB
43296 STOP
43297 ENDIF
43298
43299C...Fill information on new process.
43300 ISET(ISUB)=11
43301 COEF(ISUB,1)=SIGMAX
43302 PROC(ISUB)=TITLE//' '
43303
43304C...Format for error output.
43305 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
43306 &' not allowed.'//1X,'Execution stopped!')
43307
43308 RETURN
43309 END
43310
43311C*********************************************************************
43312
43313*$ CREATE PYUPEV.FOR
43314*COPY PYUPEV
43315C...PYUPEV
43316C...Dummy routine, to be replaced by user. When called from PYTHIA
43317C...the subprocess number ISUB will be given, and PYUPEV is supposed
43318C...to generate an event of this type, to be stored in the PYUPPR
43319C...commonblock. SIGEV gives the differential cross-section associated
43320C...with the event, i.e. the acceptance probability of the event is
43321C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
43322C...call.
43323
43324 SUBROUTINE PYUPEV(ISUB,SIGEV)
43325
43326C...Double precision and integer declarations.
43327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43328 INTEGER PYK,PYCHGE,PYCOMP
43329C...Commonblocks.
43330 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43331 COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
43332 SAVE /PYDAT1/,/PYUPPR/
43333
43334C...Stop program if this routine is ever called.
43335C...You should not copy these lines to your own routine.
43336 WRITE(MSTU(11),5000)
43337 IF(PYR(0).LT.10D0) STOP
43338 SIGEV=ISUB
43339
43340C...Format for error printout.
43341 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
43342 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43343 &1X,'Execution stopped!')
43344
43345 RETURN
43346 END
43347
43348C*********************************************************************
43349
43350*$ CREATE PYTAUD.FOR
43351*COPY PYTAUD
43352C...PYTAUD
43353C...Dummy routine, to be replaced by user, to handle the decay of a
43354C...polarized tau lepton.
43355C...Input:
43356C...ITAU is the position where the decaying tau is stored in /PYJETS/.
43357C...IORIG is the position where the mother of the tau is stored;
43358C... is 0 when the mother is not stored.
43359C...KFORIG is the flavour of the mother of the tau;
43360C... is 0 when the mother is not known.
43361C...Note that IORIG=0 does not necessarily imply KFORIG=0;
43362C... e.g. in B hadron semileptonic decays the W propagator
43363C... is not explicitly stored but the W code is still unambiguous.
43364C...Output:
43365C...NDECAY is the number of decay products in the current tau decay.
43366C...These decay products should be added to the /PYJETS/ common block,
43367C...in positions N+1 through N+NDECAY. For each product I you must
43368C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
43369C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
43370
43371 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
43372
43373C...Double precision and integer declarations.
43374 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43375 INTEGER PYK,PYCHGE,PYCOMP
43376C...Commonblocks.
43377 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43378 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43379 SAVE /PYJETS/,/PYDAT1/
43380
43381C...Stop program if this routine is ever called.
43382C...You should not copy these lines to your own routine.
43383 NDECAY=ITAU+IORIG+KFORIG
43384 WRITE(MSTU(11),5000)
43385 IF(PYR(0).LT.10D0) STOP
43386
43387C...Format for error printout.
43388 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
43389 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43390 &1X,'Execution stopped!')
43391
43392 RETURN
43393 END
43394
43395C*********************************************************************
43396
43397*$ CREATE PYTIME.FOR
43398*COPY PYTIME
43399C...PYTIME
43400C...Finds current date and time.
43401C...Since this task is not standardized in Fortran 77, the routine
43402C...is dummy, to be replaced by the user. Examples are given for
43403C...the Fortran 90 routine and DEC Fortran 77, and what to do if
43404C...you do not have access to suitable routines.
43405
43406 SUBROUTINE PYTIME(IDATI)
43407
43408C...Double precision and integer declarations.
43409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43410 INTEGER PYK,PYCHGE,PYCOMP
43411 CHARACTER*8 ATIME
43412C...Local array.
43413 INTEGER IDATI(6),IDTEMP(3)
43414
43415C...Example 0: if you do not have suitable routines.
43416 DO 100 J=1,6
43417 IDATI(J)=0
43418 100 CONTINUE
43419
43420C...Example 1: Fortran 90 routine.
43421C INTEGER IVAL(8)
43422C CALL DATE_AND_TIME(VALUES=IVAL)
43423C IDATI(1)=IVAL(1)
43424C IDATI(2)=IVAL(2)
43425C IDATI(3)=IVAL(3)
43426C IDATI(4)=IVAL(5)
43427C IDATI(5)=IVAL(6)
43428C IDATI(6)=IVAL(7)
43429
43430C...Example 2: DEC Fortran 77.
43431C CALL IDATE(IMON,IDAY,IYEAR)
43432C IDATI(1)=1900+IYEAR
43433C IDATI(2)=IMON
43434C IDATI(3)=IDAY
43435C CALL ITIME(IHOUR,IMIN,ISEC)
43436C IDATI(4)=IHOUR
43437C IDATI(5)=IMIN
43438C IDATI(6)=ISEC
43439
43440C...Example 3: DEC Fortran
43441C CALL IDATE(IMON,IDAY,IYEAR)
43442C IDATI(1)=1900+IYEAR
43443C IDATI(2)=IMON
43444C IDATI(3)=IDAY
43445C CALL TIME(ATIME)
43446C IHOUR=0
43447C IMIN=0
43448C ISEC=0
43449C READ(ATIME(1:2),'(I2)') IHOUR
43450C READ(ATIME(4:5),'(I2)') IMIN
43451C READ(ATIME(7:8),'(I2)') ISEC
43452C IDATI(4)=IHOUR
43453C IDATI(5)=IMIN
43454C IDATI(6)=ISEC
43455
43456C...Example 4: GNU LINUX libU77.
43457C CALL IDATE(IDTEMP)
43458C IDATI(1)=IDTEMP(3)
43459C IDATI(2)=IDTEMP(2)
43460C IDATI(3)=IDTEMP(1)
43461C CALL ITIME(IDTEMP)
43462C IDATI(4)=IDTEMP(1)
43463C IDATI(5)=IDTEMP(2)
43464C IDATI(6)=IDTEMP(3)
43465
43466 RETURN
43467 END